/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import data.fin.fin2
import data.typevec
import logic.function.basic
import tactic.basic

/-!

Functors between the category of tuples of types, and the category Type

Features:

`mvfunctor n` : the type class of multivariate functors
`f <$$> x`    : notation for map

-/

universes u v w

open_locale mvfunctor

/-- multivariate functors, i.e. functor between the category of type vectors
and the category of Type -/
class mvfunctor {n : ℕ} (F : typevec n → Type*) :=
(map : Π {α β : typevec n}, (α ⟹ β) → (F α → F β))

localized "infixr ` <$$> `:100 := mvfunctor.map" in mvfunctor

variables {n : ℕ}

namespace mvfunctor

variables {α β γ : typevec.{u} n} {F : typevec.{u} n → Type v} [mvfunctor F]

/-- predicate lifting over multivariate functors -/
def liftp {α : typevec n} (p : Π i, α i → Prop) (x : F α) : Prop :=
∃ u : F (λ i, subtype (p i)), (λ i, @subtype.val _ (p i)) <$$> u = x

/-- relational lifting over multivariate functors -/
def liftr {α : typevec n} (r : Π {i}, α i → α i → Prop) (x y : F α) : Prop :=
∃ u : F (λ i, {p : α i × α i // r p.fst p.snd}),
  (λ i (t : {p : α i × α i // r p.fst p.snd}), t.val.fst) <$$> u = x ∧
  (λ i (t : {p : α i × α i // r p.fst p.snd}), t.val.snd) <$$> u = y

/-- given `x : F α` and a projection `i` of type vector `α`, `supp x i` is the set
of `α.i` contained in `x` -/
def supp {α : typevec n} (x : F α) (i : fin2 n) : set (α i) :=
{ y : α i | ∀ ⦃p⦄, liftp p x → p i y }

theorem of_mem_supp {α : typevec n} {x : F α} {p : Π ⦃i⦄, α i → Prop} (h : liftp p x) (i : fin2 n):
  ∀ y ∈ supp x i, p y :=
λ y hy, hy h

end mvfunctor

/-- laws for `mvfunctor` -/
class is_lawful_mvfunctor {n : ℕ} (F : typevec n → Type*) [mvfunctor F] : Prop :=
(id_map       : ∀ {α : typevec n} (x : F α), typevec.id <$$> x = x)
(comp_map     : ∀ {α β γ : typevec n} (g : α ⟹ β) (h : β ⟹ γ) (x : F α),
                    (h ⊚ g) <$$> x = h <$$> g <$$> x)

open nat typevec

namespace mvfunctor

export is_lawful_mvfunctor (comp_map)
open is_lawful_mvfunctor

variables {α β γ : typevec.{u} n}
variables {F : typevec.{u} n → Type v} [mvfunctor F]

variables (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

/-- adapt `mvfunctor.liftp` to accept predicates as arrows -/
def liftp' : F α → Prop :=
mvfunctor.liftp $ λ i x, of_repeat $ p i x

/-- adapt `mvfunctor.liftp` to accept relations as arrows -/
def liftr' : F α → F α → Prop :=
mvfunctor.liftr $ λ i x y, of_repeat $ r i $ typevec.prod.mk _ x y

variables [is_lawful_mvfunctor F]

@[simp]
lemma id_map (x : F α) :
  typevec.id <$$> x = x :=
id_map x

@[simp]
lemma id_map' (x : F α) :
  (λ i a, a) <$$> x = x :=
id_map x

lemma map_map (g : α ⟹ β) (h : β ⟹ γ) (x : F α) :
  h <$$> g <$$> x = (h ⊚ g) <$$> x :=
eq.symm $ comp_map _ _ _

section liftp'

variables (F)

lemma exists_iff_exists_of_mono {p : F α → Prop} {q : F β → Prop} (f : α ⟹ β) (g : β ⟹ α)
  (h₀ : f ⊚ g = id)
  (h₁ : ∀ u : F α, p u ↔ q (f <$$> u)) :
  (∃ u : F α, p u) ↔ (∃ u : F β, q u) :=
begin
  split; rintro ⟨u,h₂⟩; [ use f <$$> u, use g <$$> u ],
  { apply (h₁ u).mp h₂ },
  { apply (h₁ _).mpr _,
    simp only [mvfunctor.map_map,h₀,is_lawful_mvfunctor.id_map,h₂] },
end
variables {F}

lemma liftp_def (x : F α) : liftp' p x ↔ ∃ u : F (subtype_ p), subtype_val p <$$> u = x :=
exists_iff_exists_of_mono F _ _ (to_subtype_of_subtype p) (by simp [mvfunctor.map_map])

lemma liftr_def (x y : F α) :
  liftr' r x y ↔
  ∃ u : F (subtype_ r), (typevec.prod.fst ⊚ subtype_val r) <$$> u = x ∧
                        (typevec.prod.snd ⊚ subtype_val r) <$$> u = y :=
exists_iff_exists_of_mono _ _ _ (to_subtype'_of_subtype' r)
  (by simp only [map_map, comp_assoc, subtype_val_to_subtype']; simp [comp])

end liftp'

end mvfunctor

open nat

namespace mvfunctor

open typevec

section liftp_last_pred_iff
variables  {F : typevec.{u} (n+1) → Type*} [mvfunctor F] [is_lawful_mvfunctor F]
           {α : typevec.{u} n}
variables (p : α ⟹ repeat n Prop)
          (r : α ⊗ α ⟹ repeat n Prop)

open mvfunctor

variables {β : Type u}
variables (pp : β → Prop)

private def f : Π (n α), (λ (i : fin2 (n + 1)), {p_1 // of_repeat (pred_last' α pp i p_1)}) ⟹
    λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i // pred_last α pp p_1}
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [pred_last]; erw const_iff_true) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

private def g : Π (n α), (λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i // pred_last α pp p_1}) ⟹
    (λ (i : fin2 (n + 1)), {p_1 // of_repeat (pred_last' α pp i p_1)})
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [pred_last]; erw const_iff_true) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

lemma liftp_last_pred_iff {β} (p : β → Prop) (x : F (α ::: β)) :
  liftp' (pred_last' _ p) x ↔ liftp (pred_last _ p) x :=
begin
  dsimp only [liftp,liftp'],
  apply exists_iff_exists_of_mono F (f _ n α) (g _ n α),
  { clear x _inst_2 _inst_1 F, ext i ⟨x,_⟩, cases i; refl },
  { intros, rw [mvfunctor.map_map,(⊚)],
    congr'; ext i ⟨x,_⟩; cases i; refl }
end

open function
variables (rr : β → β → Prop)

private def f :
  Π (n α),
    (λ (i : fin2 (n + 1)),
      {p_1 : _ × _ // of_repeat (rel_last' α rr i (typevec.prod.mk _ p_1.fst p_1.snd))}) ⟹
    λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i × _ // rel_last α rr (p_1.fst) (p_1.snd)}
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [rel_last]; erw repeat_eq_iff_eq) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

private def g :
  Π (n α), (λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i × _ // rel_last α rr (p_1.fst) (p_1.snd)}) ⟹
    (λ (i : fin2 (n + 1)),
      {p_1 : _ × _ // of_repeat (rel_last' α rr i (typevec.prod.mk _ p_1.1 p_1.2))})
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [rel_last]; erw repeat_eq_iff_eq) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

lemma liftr_last_rel_iff  (x y : F (α ::: β)) :
  liftr' (rel_last' _ rr) x y ↔ liftr (rel_last _ rr) x y :=
begin
  dsimp only [liftr,liftr'],
  apply exists_iff_exists_of_mono F (f rr _ _) (g rr _ _),
  { clear x y _inst_2 _inst_1 F, ext i ⟨x,_⟩ : 2, cases i; refl, },
  { intros, rw [mvfunctor.map_map,mvfunctor.map_map,(⊚),(⊚)],
    congr'; ext i ⟨x,_⟩; cases i; refl }
end

end liftp_last_pred_iff

end mvfunctor


import tactic

open expr interactive tactic

-- Here is an attempt to "fix" `interval_cases`, which is quite slow

namespace tactic
namespace interactive

setup_tactic_parser

meta def interval_cases_aux' : expr → expr → expr → ℤ → tactic unit
| v l h d := do
  if 0 < d then (do
    trace $ "-> " ++ (to_string l),
    pf ← to_expr ``(nat.le_succ %%l),
    nm ← get_unused_name v.local_pp_name,
    trace nm,
    trace pf,
    -- TODO: Instead of adding a new goal, somehow create a new subgoal and reduce the other goals
    note "h" none pf,
    succ_l ← (to_expr ``(nat.succ %%l)),
    interval_cases_aux' v succ_l h (d - 1)
  ) else skip

meta def interval_cases' (bounds : parse (prod.mk <$> ident <*> ident)) :
  tactic unit :=
do
  [l1, l2] ← [bounds.1, bounds.2].mmap get_local,
  `(%%l ≤ %%v1) ← infer_type l1,
  `(%%v2 < %%h) ← infer_type l2,
  guard (v1 = v2),
  match (l.to_int, h.to_int) with
  | (some l', some h') := interval_cases_aux' v1 l h (h' - l')
  | _ := fail "not integers?"
  end

-- Create a tactic that splits goal
meta def split_prop : tactic unit :=
do {
  [c] ← target >>= get_constructors_for,
  mk_const c >>= tactic.apply,
  all_goals split_prop
} <|> skip

example {n : ℕ} (h : 1 ≤ n) (h' : n < 10) : true :=
begin
  interval_cases' h h',
  trivial,
end

example {n : ℕ} (h : 1 ≤ n) (h' : n < 5) : true :=
begin
  show_term { interval_cases using h h' };
  trivial,
end

example {A B C : Prop} : B ∧ C ∧ (A ∨ B ∨ C) ∧ (B ∨ C) :=
by split_prop

end interactive
end tactic

---------------------------------------------------------

-- If goal is a ≤ x ∧ a ≠ x, change it to a < x
meta def change1 : tactic unit :=
do
  `(%%a1 ≤ %%x1 ∧ %%a2 ≠ %%x2) ← target,
  guard (a1 = a2 ∧ x1 = x2),
  -- applyc `lt_iff_le_and_ne,
  to_expr ``(lt_iff_le_and_ne.1) >>= apply,
  trace target

example (a x : ℕ) : a ≤ x ∧ a ≠ x := by change1
example (a x : ℕ) : a ≤ x ∧ a ≠ x := by rw ← lt_iff_le_and_ne

-- If goal is 1 ≤ n ∧ n < 10, change it to
-- (n = 1) ∨ (n ≠ 1 ∧ 1 ≤ n ∧ n < 10)
-- (n = 1) ∨ (2 ≤ n ∧ n < 10)
lemma lem {a b n : ℕ} (h : a < b) : (a ≤ n ∧ n < b) ↔ (a = n) ∨ (a.succ ≤ n ∧ n < b) := by omega

meta def change : tactic unit :=
do
  `(%%a1 ≤ %%x1 ∧ %%a2 ≠ %%x2) ← target,
  guard (a1 = a2 ∧ x1 = x2)

example (a b x : ℕ) (h : a < b) : a ≤ x ∧ x < b := by sorry
example (a b x : ℕ) (h : a < b) : a ≤ x ∧ x < b := by rw lem

example {A B C D : Prop} (hp : A ∧ B) (h : A ∧ B → C) (h' : D) : C ∧ D :=
by conv_lhs {}


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Floris van Doorn
-/
import algebra.group_power.basic
import algebra.hom.equiv.basic
import algebra.hom.units
import data.set.lattice
import data.nat.order.basic

/-!
# Pointwise operations of sets

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines pointwise algebraic operations on sets.

## Main declarations

For sets `s` and `t` and scalar `a`:
* `s * t`: Multiplication, set of all `x * y` where `x ∈ s` and `y ∈ t`.
* `s + t`: Addition, set of all `x + y` where `x ∈ s` and `y ∈ t`.
* `s⁻¹`: Inversion, set of all `x⁻¹` where `x ∈ s`.
* `-s`: Negation, set of all `-x` where `x ∈ s`.
* `s / t`: Division, set of all `x / y` where `x ∈ s` and `y ∈ t`.
* `s - t`: Subtraction, set of all `x - y` where `x ∈ s` and `y ∈ t`.

For `α` a semigroup/monoid, `set α` is a semigroup/monoid.
As an unfortunate side effect, this means that `n • s`, where `n : ℕ`, is ambiguous between
pointwise scaling and repeated pointwise addition; the former has `(2 : ℕ) • {1, 2} = {2, 4}`, while
the latter has `(2 : ℕ) • {1, 2} = {2, 3, 4}`. See note [pointwise nat action].

Appropriate definitions and results are also transported to the additive theory via `to_additive`.

## Implementation notes

* The following expressions are considered in simp-normal form in a group:
  `(λ h, h * g) ⁻¹' s`, `(λ h, g * h) ⁻¹' s`, `(λ h, h * g⁻¹) ⁻¹' s`, `(λ h, g⁻¹ * h) ⁻¹' s`,
  `s * t`, `s⁻¹`, `(1 : set _)` (and similarly for additive variants).
  Expressions equal to one of these will be simplified.
* We put all instances in the locale `pointwise`, so that these instances are not available by
  default. Note that we do not mark them as reducible (as argued by note [reducible non-instances])
  since we expect the locale to be open whenever the instances are actually used (and making the
  instances reducible changes the behavior of `simp`.

## Tags

set multiplication, set addition, pointwise addition, pointwise multiplication,
pointwise subtraction
-/

/--
Pointwise monoids (`set`, `finset`, `filter`) have derived pointwise actions of the form
`has_smul α β → has_smul α (set β)`. When `α` is `ℕ` or `ℤ`, this action conflicts with the
nat or int action coming from `set β` being a `monoid` or `div_inv_monoid`. For example,
`2 • {a, b}` can both be `{2 • a, 2 • b}` (pointwise action, pointwise repeated addition,
`set.has_smul_set`) and `{a + a, a + b, b + a, b + b}` (nat or int action, repeated pointwise
addition, `set.has_nsmul`).

Because the pointwise action can easily be spelled out in such cases, we give higher priority to the
nat and int actions.
-/
library_note "pointwise nat action"

open function

variables {F α β γ : Type*}

namespace set

/-! ### `0`/`1` as sets -/

section one
variables [has_one α] {s : set α} {a : α}

/-- The set `1 : set α` is defined as `{1}` in locale `pointwise`. -/
@[to_additive "The set `0 : set α` is defined as `{0}` in locale `pointwise`."]
protected def has_one : has_one (set α) := ⟨{1}⟩

localized "attribute [instance] set.has_one set.has_zero" in pointwise

@[to_additive] lemma singleton_one : ({1} : set α) = 1 := rfl
@[simp, to_additive] lemma mem_one : a ∈ (1 : set α) ↔ a = 1 := iff.rfl
@[to_additive] lemma one_mem_one : (1 : α) ∈ (1 : set α) := eq.refl _
@[simp, to_additive] lemma one_subset : 1 ⊆ s ↔ (1 : α) ∈ s := singleton_subset_iff
@[to_additive] lemma one_nonempty : (1 : set α).nonempty := ⟨1, rfl⟩
@[simp, to_additive] lemma image_one {f : α → β} : f '' 1 = {f 1} := image_singleton
@[to_additive] lemma subset_one_iff_eq : s ⊆ 1 ↔ s = ∅ ∨ s = 1 := subset_singleton_iff_eq
@[to_additive] lemma nonempty.subset_one_iff (h : s.nonempty) : s ⊆ 1 ↔ s = 1 :=
h.subset_singleton_iff

/-- The singleton operation as a `one_hom`. -/
@[to_additive "The singleton operation as a `zero_hom`."]
def singleton_one_hom : one_hom α (set α) := ⟨singleton, singleton_one⟩

@[simp, to_additive] lemma coe_singleton_one_hom : (singleton_one_hom : α → set α) = singleton :=
rfl

end one

/-! ### Set negation/inversion -/

section inv

/-- The pointwise inversion of set `s⁻¹` is defined as `{x | x⁻¹ ∈ s}` in locale `pointwise`. It i
equal to `{x⁻¹ | x ∈ s}`, see `set.image_inv`. -/
@[to_additive "The pointwise negation of set `-s` is defined as `{x | -x ∈ s}` in locale
`pointwise`. It is equal to `{-x | x ∈ s}`, see `set.image_neg`."]
protected def has_inv [has_inv α] : has_inv (set α) := ⟨preimage has_inv.inv⟩

localized "attribute [instance] set.has_inv set.has_neg" in pointwise

section has_inv
variables {ι : Sort*} [has_inv α] {s t : set α} {a : α}

@[simp, to_additive] lemma mem_inv : a ∈ s⁻¹ ↔ a⁻¹ ∈ s := iff.rfl
@[simp, to_additive] lemma inv_preimage : has_inv.inv ⁻¹' s = s⁻¹ := rfl
@[simp, to_additive] lemma inv_empty : (∅ : set α)⁻¹ = ∅ := rfl
@[simp, to_additive] lemma inv_univ : (univ : set α)⁻¹ = univ := rfl
@[simp, to_additive] lemma inter_inv : (s ∩ t)⁻¹ = s⁻¹ ∩ t⁻¹ := preimage_inter
@[simp, to_additive] lemma union_inv : (s ∪ t)⁻¹ = s⁻¹ ∪ t⁻¹ := preimage_union
@[simp, to_additive] lemma Inter_inv (s : ι → set α) : (⋂ i, s i)⁻¹ = ⋂ i, (s i)⁻¹ := preimage_Inter
@[simp, to_additive] lemma Union_inv (s : ι → set α) : (⋃ i, s i)⁻¹ = ⋃ i, (s i)⁻¹ := preimage_Union
@[simp, to_additive] lemma compl_inv : (sᶜ)⁻¹ = (s⁻¹)ᶜ := preimage_compl

end has_inv

section has_involutive_inv
variables [has_involutive_inv α] {s t : set α} {a : α}

@[to_additive] lemma inv_mem_inv : a⁻¹ ∈ s⁻¹ ↔ a ∈ s := by simp only [mem_inv, inv_inv]

@[simp, to_additive] lemma nonempty_inv : s⁻¹.nonempty ↔ s.nonempty :=
inv_involutive.surjective.nonempty_preimage

@[to_additive] lemma nonempty.inv (h : s.nonempty) : s⁻¹.nonempty := nonempty_inv.2 h

@[simp, to_additive]
lemma image_inv : has_inv.inv '' s = s⁻¹ :=
congr_fun (image_eq_preimage_of_inverse inv_involutive.left_inverse inv_involutive.right_inverse) _

@[simp, to_additive]
instance : has_involutive_inv (set α) :=
{ inv := has_inv.inv,
  inv_inv := λ s, by { simp only [← inv_preimage, preimage_preimage, inv_inv, preimage_id'] } }

@[simp, to_additive]
lemma inv_subset_inv : s⁻¹ ⊆ t⁻¹ ↔ s ⊆ t :=
(equiv.inv α).surjective.preimage_subset_preimage_iff

@[to_additive] lemma inv_subset : s⁻¹ ⊆ t ↔ s ⊆ t⁻¹ := by { rw [← inv_subset_inv, inv_inv] }

@[simp, to_additive] lemma inv_singleton (a : α) : ({a} : set α)⁻¹ = {a⁻¹} :=
by rw [←image_inv, image_singleton]

@[simp, to_additive] lemma inv_insert (a : α) (s : set α) : (insert a s)⁻¹ = insert a⁻¹ s⁻¹ :=
by rw [insert_eq, union_inv, inv_singleton, insert_eq]

@[to_additive] lemma inv_range {ι : Sort*} {f : ι → α} : (range f)⁻¹ = range (λ i, (f i)⁻¹) :=
by { rw ←image_inv, exact (range_comp _ _).symm }

open mul_opposite

@[to_additive]
lemma image_op_inv : op '' s⁻¹ = (op '' s)⁻¹ :=
by simp_rw [←image_inv, function.semiconj.set_image op_inv s]

end has_involutive_inv
end inv

open_locale pointwise

/-! ### Set addition/multiplication -/

section has_mul
variables {ι : Sort*} {κ : ι → Sort*} [has_mul α] {s s₁ s₂ t t₁ t₂ u : set α} {a b : α}

/-- The pointwise multiplication of sets `s * t` and `t` is defined as `{x * y | x ∈ s, y ∈ t}` in
locale `pointwise`. -/
@[to_additive "The pointwise addition of sets `s + t` is defined as `{x + y | x ∈ s, y ∈ t}` in
locale `pointwise`."]
protected def has_mul : has_mul (set α) := ⟨image2 (*)⟩

localized "attribute [instance] set.has_mul set.has_add" in pointwise

@[simp, to_additive]
lemma image2_mul : image2 has_mul.mul s t = s * t := rfl

@[to_additive]

@[to_additive] lemma mul_mem_mul : a ∈ s → b ∈ t → a * b ∈ s * t := mem_image2_of_mem

@[to_additive add_image_prod]
lemma image_mul_prod : (λ x : α × α, x.fst * x.snd) '' s ×ˢ t = s * t := image_prod _

@[simp, to_additive] lemma empty_mul : ∅ * s = ∅ := image2_empty_left
@[simp, to_additive] lemma mul_empty : s * ∅ = ∅ := image2_empty_right
@[simp, to_additive] lemma mul_eq_empty : s * t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp, to_additive] lemma mul_nonempty : (s * t).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
@[to_additive] lemma nonempty.mul : s.nonempty → t.nonempty → (s * t).nonempty := nonempty.image2
@[to_additive] lemma nonempty.of_mul_left : (s * t).nonempty → s.nonempty := nonempty.of_image2_left
@[to_additive] lemma nonempty.of_mul_right : (s * t).nonempty → t.nonempty :=
nonempty.of_image2_right
@[simp, to_additive] lemma mul_singleton : s * {b} = (* b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_mul : {a} * t = ((*) a) '' t := image2_singleton_left
@[simp, to_additive] lemma singleton_mul_singleton : ({a} : set α) * {b} = {a * b} :=
image2_singleton

@[to_additive, mono] lemma mul_subset_mul : s₁ ⊆ t₁ → s₂ ⊆ t₂ → s₁ * s₂ ⊆ t₁ * t₂ := image2_subset
@[to_additive] lemma mul_subset_mul_left : t₁ ⊆ t₂ → s * t₁ ⊆ s * t₂ := image2_subset_left
@[to_additive] lemma mul_subset_mul_right : s₁ ⊆ s₂ → s₁ * t ⊆ s₂ * t := image2_subset_right
@[to_additive] lemma mul_subset_iff : s * t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x * y ∈ u := image2_subset_iff

attribute [mono] add_subset_add

@[to_additive] lemma union_mul : (s₁ ∪ s₂) * t = s₁ * t ∪ s₂ * t := image2_union_left
@[to_additive] lemma mul_union : s * (t₁ ∪ t₂) = s * t₁ ∪ s * t₂ := image2_union_right
@[to_additive] lemma inter_mul_subset : (s₁ ∩ s₂) * t ⊆ s₁ * t ∩ (s₂ * t) :=
image2_inter_subset_left
@[to_additive] lemma mul_inter_subset : s * (t₁ ∩ t₂) ⊆ s * t₁ ∩ (s * t₂) :=
image2_inter_subset_right
@[to_additive] lemma inter_mul_union_subset_union : s₁ ∩ s₂ * (t₁ ∪ t₂) ⊆ (s₁ * t₁) ∪ (s₂ * t₂) :=
image2_inter_union_subset_union
@[to_additive] lemma union_mul_inter_subset_union : (s₁ ∪ s₂) * (t₁ ∩ t₂) ⊆ (s₁ * t₁) ∪ (s₂ * t₂) :=
image2_union_inter_subset_union

@[to_additive] lemma Union_mul_left_image : (⋃ a ∈ s, ((*) a) '' t) = s * t := Union_image_left _
@[to_additive] lemma Union_mul_right_image : (⋃ a ∈ t, (* a) '' s) = s * t := Union_image_right _

@[to_additive] lemma Union_mul (s : ι → set α) (t : set α) : (⋃ i, s i) * t = ⋃ i, s i * t :=
image2_Union_left _ _ _
@[to_additive] lemma mul_Union (s : set α) (t : ι → set α) : s * (⋃ i, t i) = ⋃ i, s * t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_mul (s : Π i, κ i → set α) (t : set α) : (⋃ i j, s i j) * t = ⋃ i j, s i j * t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma mul_Union₂ (s : set α) (t : Π i, κ i → set α) : s * (⋃ i j, t i j) = ⋃ i j, s * t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_mul_subset (s : ι → set α) (t : set α) : (⋂ i, s i) * t ⊆ ⋂ i, s i * t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma mul_Inter_subset (s : set α) (t : ι → set α) : s * (⋂ i, t i) ⊆ ⋂ i, s * t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_mul_subset (s : Π i, κ i → set α) (t : set α) :
  (⋂ i j, s i j) * t ⊆ ⋂ i j, s i j * t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma mul_Inter₂_subset (s : set α) (t : Π i, κ i → set α) :
  s * (⋂ i j, t i j) ⊆ ⋂ i j, s * t i j :=
image2_Inter₂_subset_right _ _ _

/-- The singleton operation as a `mul_hom`. -/
@[to_additive "The singleton operation as an `add_hom`."]
def singleton_mul_hom : α →ₙ* set α := ⟨singleton, λ a b, singleton_mul_singleton.symm⟩

@[simp, to_additive] lemma coe_singleton_mul_hom : (singleton_mul_hom : α → set α) = singleton :=
rfl
@[simp, to_additive] lemma singleton_mul_hom_apply (a : α) : singleton_mul_hom a = {a} := rfl

open mul_opposite

@[simp, to_additive]
lemma image_op_mul : op '' (s * t) = op '' t * op '' s := image_image2_antidistrib op_mul

end has_mul

/-! ### Set subtraction/division -/

section has_div
variables {ι : Sort*} {κ : ι → Sort*} [has_div α] {s s₁ s₂ t t₁ t₂ u : set α} {a b : α}

/-- The pointwise division of sets `s / t` is defined as `{x / y | x ∈ s, y ∈ t}` in locale
`pointwise`. -/
@[to_additive "The pointwise subtraction of sets `s - t` is defined as `{x - y | x ∈ s, y ∈ t}` in
locale `pointwise`."]
protected def has_div : has_div (set α) := ⟨image2 (/)⟩

localized "attribute [instance] set.has_div set.has_sub" in pointwise

@[simp, to_additive]
lemma image2_div : image2 has_div.div s t = s / t := rfl

@[to_additive]
lemma mem_div : a ∈ s / t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x / y = a := iff.rfl

@[to_additive] lemma div_mem_div : a ∈ s → b ∈ t → a / b ∈ s / t := mem_image2_of_mem

@[to_additive add_image_prod]
lemma image_div_prod : (λ x : α × α, x.fst / x.snd) '' s ×ˢ t = s / t := image_prod _

@[simp, to_additive] lemma empty_div : ∅ / s = ∅ := image2_empty_left
@[simp, to_additive] lemma div_empty : s / ∅ = ∅ := image2_empty_right
@[simp, to_additive] lemma div_eq_empty : s / t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp, to_additive] lemma div_nonempty : (s / t).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
@[to_additive] lemma nonempty.div : s.nonempty → t.nonempty → (s / t).nonempty := nonempty.image2
@[to_additive] lemma nonempty.of_div_left : (s / t).nonempty → s.nonempty := nonempty.of_image2_left
@[to_additive] lemma nonempty.of_div_right : (s / t).nonempty → t.nonempty :=
nonempty.of_image2_right
@[simp, to_additive] lemma div_singleton : s / {b} = (/ b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_div : {a} / t = ((/) a) '' t := image2_singleton_left
@[simp, to_additive] lemma singleton_div_singleton : ({a} : set α) / {b} = {a / b} :=
image2_singleton

@[to_additive, mono] lemma div_subset_div : s₁ ⊆ t₁ → s₂ ⊆ t₂ → s₁ / s₂ ⊆ t₁ / t₂ := image2_subset
@[to_additive] lemma div_subset_div_left : t₁ ⊆ t₂ → s / t₁ ⊆ s / t₂ := image2_subset_left
@[to_additive] lemma div_subset_div_right : s₁ ⊆ s₂ → s₁ / t ⊆ s₂ / t := image2_subset_right
@[to_additive] lemma div_subset_iff : s / t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x / y ∈ u := image2_subset_iff

attribute [mono] sub_subset_sub

@[to_additive] lemma union_div : (s₁ ∪ s₂) / t = s₁ / t ∪ s₂ / t := image2_union_left
@[to_additive] lemma div_union : s / (t₁ ∪ t₂) = s / t₁ ∪ s / t₂ := image2_union_right
@[to_additive] lemma inter_div_subset : (s₁ ∩ s₂) / t ⊆ s₁ / t ∩ (s₂ / t) :=
image2_inter_subset_left
@[to_additive] lemma div_inter_subset : s / (t₁ ∩ t₂) ⊆ s / t₁ ∩ (s / t₂) :=
image2_inter_subset_right
@[to_additive] lemma inter_div_union_subset_union : s₁ ∩ s₂ / (t₁ ∪ t₂) ⊆ (s₁ / t₁) ∪ (s₂ / t₂) :=
image2_inter_union_subset_union
@[to_additive] lemma union_div_inter_subset_union : (s₁ ∪ s₂) / (t₁ ∩ t₂) ⊆ (s₁ / t₁) ∪ (s₂ / t₂) :=
image2_union_inter_subset_union

@[to_additive] lemma Union_div_left_image : (⋃ a ∈ s, ((/) a) '' t) = s / t := Union_image_left _
@[to_additive] lemma Union_div_right_image : (⋃ a ∈ t, (/ a) '' s) = s / t := Union_image_right _

@[to_additive] lemma Union_div (s : ι → set α) (t : set α) : (⋃ i, s i) / t = ⋃ i, s i / t :=
image2_Union_left _ _ _
@[to_additive] lemma div_Union (s : set α) (t : ι → set α) : s / (⋃ i, t i) = ⋃ i, s / t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_div (s : Π i, κ i → set α) (t : set α) : (⋃ i j, s i j) / t = ⋃ i j, s i j / t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma div_Union₂ (s : set α) (t : Π i, κ i → set α) : s / (⋃ i j, t i j) = ⋃ i j, s / t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_div_subset (s : ι → set α) (t : set α) : (⋂ i, s i) / t ⊆ ⋂ i, s i / t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma div_Inter_subset (s : set α) (t : ι → set α) : s / (⋂ i, t i) ⊆ ⋂ i, s / t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_div_subset (s : Π i, κ i → set α) (t : set α) :
  (⋂ i j, s i j) / t ⊆ ⋂ i j, s i j / t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma div_Inter₂_subset (s : set α) (t : Π i, κ i → set α) :
  s / (⋂ i j, t i j) ⊆ ⋂ i j, s / t i j :=
image2_Inter₂_subset_right _ _ _

end has_div

open_locale pointwise

/-- Repeated pointwise addition (not the same as pointwise repeated addition!) of a `finset`. See
note [pointwise nat action].-/
protected def has_nsmul [has_zero α] [has_add α] : has_smul ℕ (set α) := ⟨nsmul_rec⟩

/-- Repeated pointwise multiplication (not the same as pointwise repeated multiplication!) of a
`set`. See note [pointwise nat action]. -/
@[to_additive]
protected def has_npow [has_one α] [has_mul α] : has_pow (set α) ℕ := ⟨λ s n, npow_rec n s⟩

/-- Repeated pointwise addition/subtraction (not the same as pointwise repeated
addition/subtraction!) of a `set`. See note [pointwise nat action]. -/
protected def has_zsmul [has_zero α] [has_add α] [has_neg α] : has_smul ℤ (set α) := ⟨zsmul_rec⟩

/-- Repeated pointwise multiplication/division (not the same as pointwise repeated
multiplication/division!) of a `set`. See note [pointwise nat action]. -/
@[to_additive] protected def has_zpow [has_one α] [has_mul α] [has_inv α] : has_pow (set α) ℤ :=
⟨λ s n, zpow_rec n s⟩

localized "attribute [instance] set.has_nsmul set.has_npow set.has_zsmul set.has_zpow" in pointwise

/-- `set α` is a `semigroup` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_semigroup` under pointwise operations if `α` is."]
protected def semigroup [semigroup α] : semigroup (set α) :=
{ mul_assoc := λ _ _ _, image2_assoc mul_assoc,
  ..set.has_mul }

section comm_semigroup
variables [comm_semigroup α] {s t : set α}

/-- `set α` is a `comm_semigroup` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_comm_semigroup` under pointwise operations if `α` is."]
protected def comm_semigroup : comm_semigroup (set α) :=
{ mul_comm := λ s t, image2_comm mul_comm
  ..set.semigroup }

@[to_additive] lemma inter_mul_union_subset : (s ∩ t) * (s ∪ t) ⊆ s * t :=
image2_inter_union_subset mul_comm

@[to_additive] lemma union_mul_inter_subset : (s ∪ t) * (s ∩ t) ⊆ s * t :=
image2_union_inter_subset mul_comm

end comm_semigroup

section mul_one_class
variables [mul_one_class α]

/-- `set α` is a `mul_one_class` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_zero_class` under pointwise operations if `α` is."]
protected def mul_one_class : mul_one_class (set α) :=
{ mul_one := image2_right_identity mul_one,
  one_mul := image2_left_identity one_mul,
  ..set.has_one, ..set.has_mul }

localized "attribute [instance] set.mul_one_class set.add_zero_class set.semigroup set.add_semigroup
  set.comm_semigroup set.add_comm_semigroup" in pointwise

@[to_additive] lemma subset_mul_left (s : set α) {t : set α} (ht : (1 : α) ∈ t) : s ⊆ s * t :=
λ x hx, ⟨x, 1, hx, ht, mul_one _⟩

@[to_additive] lemma subset_mul_right {s : set α} (t : set α) (hs : (1 : α) ∈ s) : t ⊆ s * t :=
λ x hx, ⟨1, x, hs, hx, one_mul _⟩

/-- The singleton operation as a `monoid_hom`. -/
@[to_additive "The singleton operation as an `add_monoid_hom`."]
def singleton_monoid_hom : α →* set α := { ..singleton_mul_hom, ..singleton_one_hom }

@[simp, to_additive] lemma coe_singleton_monoid_hom :
  (singleton_monoid_hom : α → set α) = singleton := rfl
@[simp, to_additive] lemma singleton_monoid_hom_apply (a : α) : singleton_monoid_hom a = {a} := rfl

end mul_one_class

section monoid
variables [monoid α] {s t : set α} {a : α} {m n : ℕ}

/-- `set α` is a `monoid` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_monoid` under pointwise operations if `α` is."]
protected def monoid : monoid (set α) := { ..set.semigroup, ..set.mul_one_class, ..set.has_npow }

localized "attribute [instance] set.monoid set.add_monoid" in pointwise

@[to_additive] lemma pow_mem_pow (ha : a ∈ s) : ∀ n : ℕ, a ^ n ∈ s ^ n
| 0 := by { rw pow_zero, exact one_mem_one }
| (n + 1) := by { rw pow_succ, exact mul_mem_mul ha (pow_mem_pow _) }

@[to_additive] lemma pow_subset_pow (hst : s ⊆ t) : ∀ n : ℕ, s ^ n ⊆ t ^ n
| 0 := by { rw pow_zero, exact subset.rfl }
| (n + 1) := by { rw pow_succ, exact mul_subset_mul hst (pow_subset_pow _) }

@[to_additive] lemma pow_subset_pow_of_one_mem (hs : (1 : α) ∈ s) : m ≤ n → s ^ m ⊆ s ^ n :=
begin
  refine nat.le_induction _ (λ n h ih, _) _,
  { exact subset.rfl },
  { rw pow_succ,
    exact ih.trans (subset_mul_right _ hs) }
end

@[simp, to_additive] lemma empty_pow {n : ℕ} (hn : n ≠ 0) : (∅ : set α) ^ n = ∅ :=
by rw [← tsub_add_cancel_of_le (nat.succ_le_of_lt $ nat.pos_of_ne_zero hn), pow_succ, empty_mul]

@[to_additive] lemma mul_univ_of_one_mem (hs : (1 : α) ∈ s) : s * univ = univ :=
eq_univ_iff_forall.2 $ λ a, mem_mul.2 ⟨_, _, hs, mem_univ _, one_mul _⟩

@[to_additive] lemma univ_mul_of_one_mem (ht : (1 : α) ∈ t) : univ * t = univ :=
eq_univ_iff_forall.2 $ λ a, mem_mul.2 ⟨_, _, mem_univ _, ht, mul_one _⟩

@[simp, to_additive] lemma univ_mul_univ : (univ : set α) * univ = univ :=
mul_univ_of_one_mem $ mem_univ _

--TODO: `to_additive` trips up on the `1 : ℕ` used in the pattern-matching.
@[simp] lemma nsmul_univ {α : Type*} [add_monoid α] : ∀ {n : ℕ}, n ≠ 0 → n • (univ : set α) = univ
| 0 := λ h, (h rfl).elim
| 1 := λ _, one_nsmul _
| (n + 2) := λ _, by { rw [succ_nsmul, nsmul_univ n.succ_ne_zero, univ_add_univ] }

@[simp, to_additive nsmul_univ] lemma univ_pow : ∀ {n : ℕ}, n ≠ 0 → (univ : set α) ^ n = univ
| 0 := λ h, (h rfl).elim
| 1 := λ _, pow_one _
| (n + 2) := λ _, by { rw [pow_succ, univ_pow n.succ_ne_zero, univ_mul_univ] }

@[to_additive] protected lemma _root_.is_unit.set : is_unit a → is_unit ({a} : set α) :=
is_unit.map (singleton_monoid_hom : α →* set α)

end monoid

/-- `set α` is a `comm_monoid` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_comm_monoid` under pointwise operations if `α` is."]
protected def comm_monoid [comm_monoid α] : comm_monoid (set α) :=
{ ..set.monoid, ..set.comm_semigroup }

localized "attribute [instance] set.comm_monoid set.add_comm_monoid" in pointwise

open_locale pointwise

section division_monoid
variables [division_monoid α] {s t : set α}

@[to_additive] protected lemma mul_eq_one_iff : s * t = 1 ↔ ∃ a b, s = {a} ∧ t = {b} ∧ a * b = 1 :=
begin
  refine ⟨λ h, _, _⟩,
  { have hst : (s * t).nonempty := h.symm.subst one_nonempty,
    obtain ⟨a, ha⟩ := hst.of_image2_left,
    obtain ⟨b, hb⟩ := hst.of_image2_right,
    have H : ∀ {a b}, a ∈ s → b ∈ t → a * b = (1 : α) :=
      λ a b ha hb, (h.subset $ mem_image2_of_mem ha hb),
    refine ⟨a, b, _, _, H ha hb⟩; refine eq_singleton_iff_unique_mem.2 ⟨‹_›, λ x hx, _⟩,
    { exact (eq_inv_of_mul_eq_one_left $ H hx hb).trans (inv_eq_of_mul_eq_one_left $ H ha hb) },
    { exact (eq_inv_of_mul_eq_one_right $ H ha hx).trans (inv_eq_of_mul_eq_one_right $ H ha hb) } },
  { rintro ⟨b, c, rfl, rfl, h⟩,
    rw [singleton_mul_singleton, h, singleton_one] }
end

/-- `set α` is a division monoid under pointwise operations if `α` is. -/
@[to_additive "`set α` is a subtraction monoid under pointwise operations if `α` is."]
protected def division_monoid : division_monoid (set α) :=
{ mul_inv_rev := λ s t, by { simp_rw ←image_inv, exact image_image2_antidistrib mul_inv_rev },
  inv_eq_of_mul := λ s t h, begin
    obtain ⟨a, b, rfl, rfl, hab⟩ := set.mul_eq_one_iff.1 h,
    rw [inv_singleton, inv_eq_of_mul_eq_one_right hab],
  end,
  div_eq_mul_inv := λ s t,
    by { rw [←image_id (s / t), ←image_inv], exact image_image2_distrib_right div_eq_mul_inv },
  ..set.monoid, ..set.has_involutive_inv, ..set.has_div, ..set.has_zpow }

@[simp, to_additive] lemma is_unit_iff : is_unit s ↔ ∃ a, s = {a} ∧ is_unit a :=
begin
  split,
  { rintro ⟨u, rfl⟩,
    obtain ⟨a, b, ha, hb, h⟩ := set.mul_eq_one_iff.1 u.mul_inv,
    refine ⟨a, ha, ⟨a, b, h, singleton_injective _⟩, rfl⟩,
    rw [←singleton_mul_singleton, ←ha, ←hb],
    exact u.inv_mul },
  { rintro ⟨a, rfl, ha⟩,
    exact ha.set }
end

end division_monoid

/-- `set α` is a commutative division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_comm_monoid "`set α` is a commutative subtraction monoid under pointwise
operations if `α` is."]
protected def division_comm_monoid [division_comm_monoid α] : division_comm_monoid (set α) :=
{ ..set.division_monoid, ..set.comm_semigroup }

/-- `set α` has distributive negation if `α` has. -/
protected def has_distrib_neg [has_mul α] [has_distrib_neg α] : has_distrib_neg (set α) :=
{ neg_mul := λ _ _, by { simp_rw ←image_neg, exact image2_image_left_comm neg_mul },
  mul_neg := λ _ _, by { simp_rw ←image_neg, exact image_image2_right_comm mul_neg },
  ..set.has_involutive_neg }

localized "attribute [instance] set.division_monoid set.subtraction_monoid set.division_comm_monoid
  set.subtraction_comm_monoid set.has_distrib_neg" in pointwise

section distrib
variables [distrib α] (s t u : set α)

/-!
Note that `set α` is not a `distrib` because `s * t + s * u` has cross terms that `s * (t + u)`
lacks.
-/

lemma mul_add_subset : s * (t + u) ⊆ s * t + s * u := image2_distrib_subset_left mul_add
lemma add_mul_subset : (s + t) * u ⊆ s * u + t * u := image2_distrib_subset_right add_mul

end distrib

section mul_zero_class
variables [mul_zero_class α] {s t : set α}

/-! Note that `set` is not a `mul_zero_class` because `0 * ∅ ≠ 0`. -/

lemma mul_zero_subset (s : set α) : s * 0 ⊆ 0 := by simp [subset_def, mem_mul]
lemma zero_mul_subset (s : set α) : 0 * s ⊆ 0 := by simp [subset_def, mem_mul]

lemma nonempty.mul_zero (hs : s.nonempty) : s * 0 = 0 :=
s.mul_zero_subset.antisymm $ by simpa [mem_mul] using hs

lemma nonempty.zero_mul (hs : s.nonempty) : 0 * s = 0 :=
s.zero_mul_subset.antisymm $ by simpa [mem_mul] using hs

end mul_zero_class

section group
variables [group α] {s t : set α} {a b : α}

/-! Note that `set` is not a `group` because `s / s ≠ 1` in general. -/

@[simp, to_additive] lemma one_mem_div_iff : (1 : α) ∈ s / t ↔ ¬ disjoint s t :=
by simp [not_disjoint_iff_nonempty_inter, mem_div, div_eq_one, set.nonempty]

@[to_additive] lemma not_one_mem_div_iff : (1 : α) ∉ s / t ↔ disjoint s t :=
one_mem_div_iff.not_left

alias not_one_mem_div_iff ↔ _ _root_.disjoint.one_not_mem_div_set

attribute [to_additive] disjoint.one_not_mem_div_set

@[to_additive] lemma nonempty.one_mem_div (h : s.nonempty) : (1 : α) ∈ s / s :=
let ⟨a, ha⟩ := h in mem_div.2 ⟨a, a, ha, ha, div_self' _⟩

@[to_additive] lemma is_unit_singleton (a : α) : is_unit ({a} : set α) := (group.is_unit a).set

@[simp, to_additive] lemma is_unit_iff_singleton : is_unit s ↔ ∃ a, s = {a} :=
by simp only [is_unit_iff, group.is_unit, and_true]

@[simp, to_additive] lemma image_mul_left : ((*) a) '' t = ((*) a⁻¹) ⁻¹' t :=
by { rw image_eq_preimage_of_inverse; intro c; simp }

@[simp, to_additive] lemma image_mul_right : (* b) '' t = (* b⁻¹) ⁻¹' t :=
by { rw image_eq_preimage_of_inverse; intro c; simp }

@[to_additive] lemma image_mul_left' : (λ b, a⁻¹ * b) '' t = (λ b, a * b) ⁻¹' t := by simp
@[to_additive] lemma image_mul_right' : (* b⁻¹) '' t = (* b) ⁻¹' t := by simp

@[simp, to_additive] lemma preimage_mul_left_singleton : ((*) a) ⁻¹' {b} = {a⁻¹ * b} :=
by rw [← image_mul_left', image_singleton]

@[simp, to_additive] lemma preimage_mul_right_singleton : (* a) ⁻¹' {b} = {b * a⁻¹} :=
by rw [← image_mul_right', image_singleton]

@[simp, to_additive] lemma preimage_mul_left_one : ((*) a) ⁻¹' 1 = {a⁻¹} :=
by rw [← image_mul_left', image_one, mul_one]

@[simp, to_additive] lemma preimage_mul_right_one : (* b) ⁻¹' 1 = {b⁻¹} :=
by rw [← image_mul_right', image_one, one_mul]

@[to_additive] lemma preimage_mul_left_one' : (λ b, a⁻¹ * b) ⁻¹' 1 = {a} := by simp
@[to_additive] lemma preimage_mul_right_one' : (* b⁻¹) ⁻¹' 1 = {b} := by simp

@[simp, to_additive] lemma mul_univ (hs : s.nonempty) : s * (univ : set α) = univ :=
let ⟨a, ha⟩ := hs in eq_univ_of_forall $ λ b, ⟨a, a⁻¹ * b, ha, trivial, mul_inv_cancel_left _ _⟩

@[simp, to_additive] lemma univ_mul (ht : t.nonempty) : (univ : set α) * t = univ :=
let ⟨a, ha⟩ := ht in eq_univ_of_forall $ λ b, ⟨b * a⁻¹, a, trivial, ha, inv_mul_cancel_right _ _⟩

end group

section group_with_zero
variables [group_with_zero α] {s t : set α}

lemma div_zero_subset (s : set α) : s / 0 ⊆ 0 := by simp [subset_def, mem_div]
lemma zero_div_subset (s : set α) : 0 / s ⊆ 0 := by simp [subset_def, mem_div]

lemma nonempty.div_zero (hs : s.nonempty) : s / 0 = 0 :=
s.div_zero_subset.antisymm $ by simpa [mem_div] using hs

lemma nonempty.zero_div (hs : s.nonempty) : 0 / s = 0 :=
s.zero_div_subset.antisymm $ by simpa [mem_div] using hs

end group_with_zero

section has_mul
variables [has_mul α] [has_mul β] [mul_hom_class F α β] (m : F) {s t : set α}
include α β

@[to_additive] lemma image_mul : m '' (s * t) = m '' s * m '' t := image_image2_distrib $ map_mul m

@[to_additive]
lemma preimage_mul_preimage_subset {s t : set β} : m ⁻¹' s * m ⁻¹' t ⊆ m ⁻¹' (s * t) :=
by { rintro _ ⟨_, _, _, _, rfl⟩, exact ⟨_, _, ‹_›, ‹_›, (map_mul m _ _).symm ⟩ }

end has_mul

section group
variables [group α] [division_monoid β] [monoid_hom_class F α β] (m : F) {s t : set α}
include α β

@[to_additive] lemma image_div : m '' (s / t) = m '' s / m '' t := image_image2_distrib $ map_div m

@[to_additive]
lemma preimage_div_preimage_subset {s t : set β} : m ⁻¹' s / m ⁻¹' t ⊆ m ⁻¹' (s / t) :=
by { rintro _ ⟨_, _, _, _, rfl⟩, exact ⟨_, _, ‹_›, ‹_›, (map_div m _ _).symm ⟩ }

end group

@[to_additive]
lemma bdd_above_mul [ordered_comm_monoid α] {A B : set α} :
  bdd_above A → bdd_above B → bdd_above (A * B) :=
begin
  rintro ⟨bA, hbA⟩ ⟨bB, hbB⟩,
  use bA * bB,
  rintro x ⟨xa, xb, hxa, hxb, rfl⟩,
  exact mul_le_mul' (hbA hxa) (hbB hxb),
end

end set

/-! ### Miscellaneous -/

open set
open_locale pointwise

namespace group

lemma card_pow_eq_card_pow_card_univ_aux {f : ℕ → ℕ} (h1 : monotone f)
  {B : ℕ} (h2 : ∀ n, f n ≤ B) (h3 : ∀ n, f n = f (n + 1) → f (n + 1) = f (n + 2)) :
  ∀ k, B ≤ k → f k = f B :=
begin
  have key : ∃ n : ℕ, n ≤ B ∧ f n = f (n + 1),
  { contrapose! h2,
    suffices : ∀ n : ℕ, n ≤ B + 1 → n ≤ f n,
    { exact ⟨B + 1, this (B + 1) (le_refl (B + 1))⟩ },
    exact λ n, nat.rec (λ h, nat.zero_le (f 0)) (λ n ih h, lt_of_le_of_lt (ih (n.le_succ.trans h))
      (lt_of_le_of_ne (h1 n.le_succ) (h2 n (nat.succ_le_succ_iff.mp h)))) n },
  { obtain ⟨n, hn1, hn2⟩ := key,
    replace key : ∀ k : ℕ, f (n + k) = f (n + k + 1) ∧ f (n + k) = f n :=
    λ k, nat.rec ⟨hn2, rfl⟩ (λ k ih, ⟨h3 _ ih.1, ih.1.symm.trans ih.2⟩) k,
    replace key : ∀ k : ℕ, n ≤ k → f k = f n :=
    λ k hk, (congr_arg f (add_tsub_cancel_of_le hk)).symm.trans (key (k - n)).2,
    exact λ k hk, (key k (hn1.trans hk)).trans (key B hn1).symm },
end

end group


/-
Copyright (c) 2019 Jesse Michael Han. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Jesse Michael Han

Tests for `finish using [...]`
-/

import tactic.finish
import algebra.order.ring.defs

section list_rev
open list
variable {α : Type*}

def append1 (a : α) : list α → list α
| nil      := [a]
| (b :: l) := b :: (append1 l)

def rev : list α → list α
| nil := nil
| (a :: l) := append1 a (rev l)

lemma hd_rev (a : α) (l : list α) :
  a :: rev l =  rev (append1 a l) :=
begin
  induction l with l_hd l_tl ih, refl,
  -- finish -- fails
  -- finish[rev, append1] -- fails
  -- finish[rev, append1, ih] -- fails
  -- finish[rev, append1, ih.symm] -- times out
  finish using [rev, append1]
end

end list_rev

section barber
variables (man : Type) (barber : man)
variable  (shaves : man → man → Prop)

example (h : ∀ x : man, shaves barber x ↔ ¬ shaves x x) : false :=
by finish using [h barber]

end barber

constant real : Type
@[instance] constant orreal : ordered_ring real

-- TODO(Mario): suspicious fix
@[irreducible] noncomputable instance : has_lt real := by apply_instance
constants (log exp : real → real)
constant  log_exp_eq : ∀ x, log (exp x) = x
constant  exp_log_eq : ∀ {x}, x > 0 → exp (log x) = x
constant  exp_pos    : ∀ x, exp x > 0
constant  exp_add    : ∀ x y, exp (x + y) = exp x * exp y

theorem log_mul' {x y : real} (hx : x > 0) (hy : y > 0) :
  log (x * y) = log x + log y :=
by rw [←log_exp_eq (log x + log y), exp_add, exp_log_eq hx, exp_log_eq hy]


import tactic
import order.bounded_order
import data.equiv.denumerable

/- In this file we define the basic definitions of the propositional language.
The formulas are parametrized by a type which represents the collection of
propositional variables - this type is required to be denumerable
(bijective to ℕ), but this is enforced in the theorems not the definition.
We show that if the variables are denumerable then so is the type of formulas.
This is done by an explicit Godel encoding of the formulas' syntactic structure.
-/

/-- Formulas of propositional logic

Form vars ∷= ⦃x : vars⦄ | ⊥ | ~ Form | Form ⋀ Form | Form ⋁ Form -/
inductive Form (vars : Type) : Type
| Bottom : Form
| Var    : vars → Form
| Not    : Form → Form
| And    : Form → Form → Form
| Or     : Form → Form → Form

open Form

-- get the ⊥ notation for Bottom
instance {vars : Type} : has_bot (Form vars) := ⟨Form.Bottom⟩
-- and allow simp to unwrap this definition
@[simp] lemma bottom_eq_bot {vars : Type} : (Form.Bottom : Form vars) = ⊥ := rfl
notation `⦃` a `⦄`  := Form.Var a
notation `~` a     := Form.Not a
notation a ` ⋀ ` b := Form.And a b
notation a ` ⋁ ` b := Form.Or a b

instance {vars : Type} : inhabited (Form vars) := ⟨Form.Bottom⟩

/- Now we show that `Form vars` is denumerable with an explicit bijection,
given a denumerable `vars`. -/

variables {vars : Type} [denumerable vars]

/- We protect the constructions because they're intended to be used via the
encodable and denumerable typeclass interface, not directly. -/

/-- Bijective encoding of Form into ℕ -/
@[protected]
def enc : Form vars → ℕ
| ⊥       := 0
| ⦃x⦄     := (encodable.encode x) * 4 + 1
| (~ P)   := (enc P) * 4 + 2
| (P ⋀ Q) := (nat.mkpair (enc P) (enc Q)) * 4 + 3
| (P ⋁ Q) := (nat.mkpair (enc P) (enc Q)) * 4 + 4

/-- Bijective decoding of ℕ into Form -/
@[protected]
def dec : ℕ → Form vars
| 0       := ⊥
| (k + 1) :=
  let data := k / 4 in
  -- Proving these allow strong recursion which we need
  have hdata : data < k + 1 := nat.lt_succ_of_le (nat.div_le_self k 4),
  have hfst : data.unpair.fst < k + 1 := lt_of_le_of_lt data.unpair_left_le hdata,
  have hsnd : data.unpair.snd < k + 1 := lt_of_le_of_lt data.unpair_right_le hdata,
  -- the value of k % 4 determines which constructor of Form is encoded
  match k % 4, @nat.mod_lt k 4 dec_trivial with
    | 0, _ := ⦃denumerable.of_nat vars data⦄
    | 1, _ := ~ (dec data)
    | 2, _ := dec (data.unpair.fst) ⋀ dec (data.unpair.snd)
    | 3, _ := dec (data.unpair.fst) ⋁ dec (data.unpair.snd)
    -- k % 4 can't be ≥ 4, but I'm still not sure how dec_trivial works here...
    -- This is based on Mathlib's nat.mod_two_eq_zero_or_one
    | _ + 4, lt_four := absurd lt_four dec_trivial
  end

/-- Same as Form.dec, but returns the decoded formula wrapped in option.some -/
@[protected]
def dec' : ℕ → option (Form vars) := some ∘ dec

@[protected]
theorem dec_enc_eq : ∀ (A : Form vars), dec (enc A) = A :=
begin
  intro A,
  induction A,
  case Form.Bottom {
    simp [dec, enc],
  },
  case Form.Var {
    simp [dec, enc],
  },
  case Form.Not : A ih {
    simp [enc,  dec],
    -- simplify the argument to dec._match_1 before we can unfold the match
    rw add_comm,
    conv in ((1 + enc A * 4) % 4) {
      rw [nat.add_mul_mod_self_right, @nat.mod_eq_of_lt 1 4 (by norm_num)],
    },
    -- unfold the match
    simp [dec._match_1],
    -- simplify the code number
    simp [nat.add_mul_div_right, @nat.div_eq_of_lt 1 4 (by norm_num)],
    exact ih,
  },
  case Form.And : A B ihA ihB {
    -- similar steps to previous case
    simp [enc, dec],
    rw add_comm,
    conv in ((2 + nat.mkpair (enc A) (enc B) * 4) % 4) {
      rw [nat.add_mul_mod_self_right, @nat.mod_eq_of_lt 2 4 (by norm_num)],
    },
    simp [dec._match_1],
    simp [nat.add_mul_div_right, @nat.div_eq_of_lt 2 4 (by norm_num)],
    exact ⟨ihA, ihB⟩
  },
  case Form.Or : A B ihA ihB {
    -- copy pasted from previous case except 3 instead of 2
    simp [enc, dec],
    rw add_comm,
    conv in ((3 + nat.mkpair (enc A) (enc B) * 4) % 4) {
      rw [nat.add_mul_mod_self_right, @nat.mod_eq_of_lt 3 4 (by norm_num)],
    },
    simp [dec._match_1],
    simp [nat.add_mul_div_right, @nat.div_eq_of_lt 3 4 (by norm_num)],
    exact ⟨ihA, ihB⟩
  },
end

@[protected]
theorem dec'_enc_eq (A : Form vars) : dec' (enc A) = some A :=
begin
  simp [dec'],
  exact dec_enc_eq A
end

instance : encodable (Form vars) := ⟨enc, dec', dec'_enc_eq⟩

@[protected]
theorem enc_dec_eq (n : ℕ) : enc (dec n : Form vars) = n :=
begin
  induction n using nat.case_strong_induction_on with n ih,
  case hz {
    simp [dec, enc],
  },
  case hi {
    have : n % 4 = 0 ∨ n % 4 = 1 ∨ n % 4 = 2 ∨ n % 4 = 3, {
      exact match n % 4, @nat.mod_lt n 4 dec_trivial with
      | 0, _ := by {left, refl}
      | 1, _ := by {right, left, refl}
      | 2, _ := by {right, right, left, refl}
      | 3, _ := by {right, right, right, refl}
      | n + 4, lt_four := absurd lt_four dec_trivial
      end
    },
    simp [dec] at ⊢ ih,
    rcases this with (h0 | h1 | h2 | h3),
    { -- conv avoids "Motive not type correct" error when rw-ing
      conv in (n % 4) {rw h0},
      simp [dec._match_1, enc],
      apply congr_arg nat.succ,
      rw [←nat.add_zero (n / 4 * 4),
          ←h0,
          add_comm (n / 4 * 4) (n % 4),
          nat.mod_add_div' n 4],
    },
    { conv in (n % 4) {rw h1},
      simp [dec._match_1, enc],
      rw ih (n / 4) (nat.div_le_self n 4),
      apply congr_arg nat.succ,
      nth_rewrite 2 ←h1,
      rw [add_comm (n / 4 * 4) (n % 4), nat.mod_add_div' n 4]
    },
    {
      conv in (n % 4) {rw h2},
      simp [dec._match_1, enc],
      rw ih _ (trans (nat.unpair_left_le (n / 4)) (nat.div_le_self n 4)),
      rw ih _ (trans (nat.unpair_right_le (n / 4)) (nat.div_le_self n 4)),
      rw nat.mkpair_unpair,
      apply congr_arg nat.succ,
      nth_rewrite 2 ←h2,
      rw [add_comm (n / 4 * 4) (n % 4), nat.mod_add_div' n 4]
    },
    {
      conv in (n % 4) {rw h3},
      simp [dec._match_1, enc],
      rw ih _ (trans (nat.unpair_left_le (n / 4)) (nat.div_le_self n 4)),
      rw ih _ (trans (nat.unpair_right_le (n / 4)) (nat.div_le_self n 4)),
      rw nat.mkpair_unpair,
      apply congr_arg nat.succ,
      nth_rewrite 0 ←h3,
      rw [add_comm (n / 4 * 4) (n % 4), nat.mod_add_div' n 4]
    }
  }
end

@[protected]
theorem enc_decode_inv : ∀ (n : ℕ),
  ∃ (A : Form vars) (H : A ∈ encodable.decode (Form vars) n),
  encodable.encode A = n :=
begin
  intro n,
  use dec n,
  simp [encodable.encode, encodable.decode, dec'],
  exact enc_dec_eq n
end

instance : denumerable (Form vars) := ⟨enc_decode_inv⟩

#lint


/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import logic.function.basic
import tactic.protected

/-!
# Types that are empty

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

In this file we define a typeclass `is_empty`, which expresses that a type has no elements.

## Main declaration

* `is_empty`: a typeclass that expresses that a type is empty.
-/

variables {α β γ : Sort*}

/-- `is_empty α` expresses that `α` is empty. -/
@[protect_proj]
class is_empty (α : Sort*) : Prop :=
(false : α → false)

instance : is_empty empty   := ⟨empty.elim⟩
instance : is_empty pempty  := ⟨pempty.elim⟩
instance : is_empty false   := ⟨id⟩
instance : is_empty (fin 0) := ⟨λ n, nat.not_lt_zero n.1 n.2⟩

protected lemma function.is_empty [is_empty β] (f : α → β) : is_empty α :=
⟨λ x, is_empty.false (f x)⟩

instance {p : α → Sort*} [h : nonempty α] [∀ x, is_empty (p x)] : is_empty (Π x, p x) :=
h.elim $ λ x, function.is_empty $ function.eval x
instance pprod.is_empty_left [is_empty α] : is_empty (pprod α β) :=
function.is_empty pprod.fst
instance pprod.is_empty_right [is_empty β] : is_empty (pprod α β) :=
function.is_empty pprod.snd
instance prod.is_empty_left {α β} [is_empty α] : is_empty (α × β) :=
function.is_empty prod.fst
instance prod.is_empty_right {α β} [is_empty β] : is_empty (α × β) :=
function.is_empty prod.snd
instance [is_empty α] [is_empty β] : is_empty (psum α β) :=
⟨λ x, psum.rec is_empty.false is_empty.false x⟩
instance {α β} [is_empty α] [is_empty β] : is_empty (α ⊕ β) :=
⟨λ x, sum.rec is_empty.false is_empty.false x⟩
/-- subtypes of an empty type are empty -/
instance [is_empty α] (p : α → Prop) : is_empty (subtype p) :=
⟨λ x, is_empty.false x.1⟩
/-- subtypes by an all-false predicate are false. -/
lemma subtype.is_empty_of_false {p : α → Prop} (hp : ∀ a, ¬(p a)) : is_empty (subtype p) :=
⟨λ x, hp _ x.2⟩
/-- subtypes by false are false. -/
instance subtype.is_empty_false : is_empty {a : α // false} :=
subtype.is_empty_of_false (λ a, id)

instance sigma.is_empty_left {α} [is_empty α] {E : α → Type*} : is_empty (sigma E) :=
function.is_empty sigma.fst

/- Test that `pi.is_empty` finds this instance. -/
example [h : nonempty α] [is_empty β] : is_empty (α → β) := by apply_instance

/-- Eliminate out of a type that `is_empty` (without using projection notation). -/
@[elab_as_eliminator]
def is_empty_elim [is_empty α] {p : α → Sort*} (a : α) : p a :=
(is_empty.false a).elim

lemma is_empty_iff : is_empty α ↔ α → false :=
⟨@is_empty.false α, is_empty.mk⟩

namespace is_empty
open function
/-- Eliminate out of a type that `is_empty` (using projection notation). -/
protected def elim (h : is_empty α) {p : α → Sort*} (a : α) : p a :=
is_empty_elim a

/-- Non-dependent version of `is_empty.elim`. Helpful if the elaborator cannot elaborate `h.elim a`
  correctly. -/
protected def elim' {β : Sort*} (h : is_empty α) (a : α) : β :=
h.elim a

protected lemma prop_iff {p : Prop} : is_empty p ↔ ¬ p :=
is_empty_iff

variables [is_empty α]

@[simp] lemma forall_iff {p : α → Prop} : (∀ a, p a) ↔ true :=
iff_true_intro is_empty_elim

@[simp] lemma exists_iff {p : α → Prop} : (∃ a, p a) ↔ false :=
iff_false_intro $ λ ⟨x, hx⟩, is_empty.false x

@[priority 100] -- see Note [lower instance priority]
instance : subsingleton α := ⟨is_empty_elim⟩

end is_empty

@[simp] lemma not_nonempty_iff : ¬ nonempty α ↔ is_empty α :=
⟨λ h, ⟨λ x, h ⟨x⟩⟩, λ h1 h2, h2.elim h1.elim⟩

@[simp] lemma not_is_empty_iff : ¬ is_empty α ↔ nonempty α :=
not_iff_comm.mp not_nonempty_iff

@[simp] lemma is_empty_Prop {p : Prop} : is_empty p ↔ ¬p :=
by simp only [← not_nonempty_iff, nonempty_Prop]

@[simp] lemma is_empty_pi {π : α → Sort*} : is_empty (Π a, π a) ↔ ∃ a, is_empty (π a) :=
by simp only [← not_nonempty_iff, classical.nonempty_pi, not_forall]

@[simp] lemma is_empty_sigma {α} {E : α → Type*} :
  is_empty (sigma E) ↔ ∀ a, is_empty (E a) :=
by simp only [← not_nonempty_iff, nonempty_sigma, not_exists]

@[simp] lemma is_empty_psigma {α} {E : α → Sort*} :
  is_empty (psigma E) ↔ ∀ a, is_empty (E a) :=
by simp only [← not_nonempty_iff, nonempty_psigma, not_exists]

@[simp] lemma is_empty_subtype (p : α → Prop) : is_empty (subtype p) ↔ ∀ x, ¬p x :=
by simp only [← not_nonempty_iff, nonempty_subtype, not_exists]

@[simp] lemma is_empty_prod {α β : Type*} : is_empty (α × β) ↔ is_empty α ∨ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_prod, not_and_distrib]

@[simp] lemma is_empty_pprod : is_empty (pprod α β) ↔ is_empty α ∨ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_pprod, not_and_distrib]

@[simp] lemma is_empty_sum {α β} : is_empty (α ⊕ β) ↔ is_empty α ∧ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_sum, not_or_distrib]

@[simp] lemma is_empty_psum {α β} : is_empty (psum α β) ↔ is_empty α ∧ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_psum, not_or_distrib]

@[simp] lemma is_empty_ulift {α} : is_empty (ulift α) ↔ is_empty α :=
by simp only [← not_nonempty_iff, nonempty_ulift]

@[simp] lemma is_empty_plift {α} : is_empty (plift α) ↔ is_empty α :=
by simp only [← not_nonempty_iff, nonempty_plift]

lemma well_founded_of_empty {α} [is_empty α] (r : α → α → Prop) : well_founded r :=
⟨is_empty_elim⟩

variables (α)

lemma is_empty_or_nonempty : is_empty α ∨ nonempty α :=
(em $ is_empty α).elim or.inl $ or.inr ∘ not_is_empty_iff.mp

@[simp] lemma not_is_empty_of_nonempty [h : nonempty α] : ¬ is_empty α :=
not_is_empty_iff.mpr h

variable {α}

lemma function.extend_of_empty [is_empty α] (f : α → β) (g : α → γ) (h : β → γ) :
  function.extend f g h = h :=
funext $ λ x, function.extend_apply' _ _ _ $ λ ⟨a, h⟩, is_empty_elim a


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module category_theory.sums.basic
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.EqToHom

/-!
# Binary disjoint unions of categories

We define the category instance on `C ⊕ D` when `C` and `D` are categories.

We define:
* `inl_`      : the functor `C ⥤ C ⊕ D`
* `inr_`      : the functor `D ⥤ C ⊕ D`
* `swap`      : the functor `C ⊕ D ⥤ D ⊕ C`
    (and the fact this is an equivalence)

We further define sums of functors and natural transformations, written `F.sum G` and `α.sum β`.
-/

namespace CategoryTheory

universe v₁ u₁

-- morphism levels before object levels. See note [category_theory universes].
open Sum

section

variable (C : Type u₁) [Category.{v₁} C] (D : Type u₁) [Category.{v₁} D]

/- Porting note: `aesop_cat` not firing on `assoc` where autotac in Lean 3 did-/

/-- `sum C D` gives the direct sum of two categories.
-/
instance sum : Category.{v₁} (Sum C D)
    where
  Hom X Y :=
    match X, Y with
    | inl X, inl Y => X ⟶ Y
    | inl _, inr _ => PEmpty
    | inr _, inl _ => PEmpty
    | inr X, inr Y => X ⟶ Y
  id X :=
    match X with
    | inl X => 𝟙 X
    | inr X => 𝟙 X
  comp := @fun X Y Z f g =>
    match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g => f ≫ g
    | inr X, inr Y, inr Z, f, g => f ≫ g
  assoc := @fun W X Y Z f g h =>
    match X, Y, Z, W with
    | inl X, inl Y, inl Z, inl W => Category.assoc f g h
    | inr X, inr Y, inr Z, inr W => Category.assoc f g h
#align category_theory.sum CategoryTheory.sum

/- Porting note: seems similar to Mathlib4#1036 issue so marked as nolint  -/
@[simp, nolint simpComm]
theorem sum_comp_inl {P Q R : C} (f : (inl P : Sum C D) ⟶ inl Q) (g : (inl Q : Sum C D) ⟶ inl R) :
    @CategoryStruct.comp _ _ P Q R (f : P ⟶ Q) (g : Q ⟶ R) =
      @CategoryStruct.comp _ _ (inl P) (inl Q) (inl R) (f : P ⟶ Q) (g : Q ⟶ R) :=
  rfl
#align category_theory.sum_comp_inl CategoryTheory.sum_comp_inl

/- Porting note: seems similar to Mathlib4#1036 issue so marked as nolint  -/
@[simp, nolint simpComm]
theorem sum_comp_inr {P Q R : D} (f : (inr P : Sum C D) ⟶ inr Q) (g : (inr Q : Sum C D) ⟶ inr R) :
    @CategoryStruct.comp _ _ P Q R (f : P ⟶ Q) (g : Q ⟶ R) =
      @CategoryStruct.comp _ _ (inr P) (inr Q) (inr R) (f : P ⟶ Q) (g : Q ⟶ R) :=
  rfl
#align category_theory.sum_comp_inr CategoryTheory.sum_comp_inr

end

namespace Sum

variable (C : Type u₁) [Category.{v₁} C] (D : Type u₁) [Category.{v₁} D]

-- Unfortunate naming here, suggestions welcome.
/-- `inl_` is the functor `X ↦ inl X`. -/
@[simps]
def inl_ : C ⥤ Sum C D where
  obj X := inl X
  map := @fun X Y f => f
#align category_theory.sum.inl_ CategoryTheory.Sum.inl_

/-- `inr_` is the functor `X ↦ inr X`. -/
@[simps]
def inr_ : D ⥤ Sum C D where
  obj X := inr X
  map := @fun X Y f => f
#align category_theory.sum.inr_ CategoryTheory.Sum.inr_

/- Porting note: `aesop_cat` not firing on `map_comp` where autotac in Lean 3 did
but `map_id` was ok. -/

/-- The functor exchanging two direct summand categories. -/
def swap : Sum C D ⥤ Sum D C
    where
  obj X :=
    match X with
    | inl X => inr X
    | inr X => inl X
  map := @fun X Y f =>
    match X, Y, f with
    | inl _, inl _, f => f
    | inr _, inr _, f => f
  map_comp := fun {X} {Y} {Z} _ _ =>
    match X, Y, Z with
    | inl X, inl Y, inl Z => by rfl
    | inr X, inr Y, inr Z => by rfl
#align category_theory.sum.swap CategoryTheory.Sum.swap

@[simp]
theorem swap_obj_inl (X : C) : (swap C D).obj (inl X) = inr X :=
  rfl
#align category_theory.sum.swap_obj_inl CategoryTheory.Sum.swap_obj_inl

@[simp]
theorem swap_obj_inr (X : D) : (swap C D).obj (inr X) = inl X :=
  rfl
#align category_theory.sum.swap_obj_inr CategoryTheory.Sum.swap_obj_inr

@[simp]
theorem swap_map_inl {X Y : C} {f : inl X ⟶ inl Y} : (swap C D).map f = f :=
  rfl
#align category_theory.sum.swap_map_inl CategoryTheory.Sum.swap_map_inl

@[simp]
theorem swap_map_inr {X Y : D} {f : inr X ⟶ inr Y} : (swap C D).map f = f :=
  rfl
#align category_theory.sum.swap_map_inr CategoryTheory.Sum.swap_map_inr

namespace Swap

/- Porting note: had to manually call `cases f` for `f : PEmpty` -/

/-- `swap` gives an equivalence between `C ⊕ D` and `D ⊕ C`. -/
def equivalence : Sum C D ≌ Sum D C :=
  Equivalence.mk (swap C D) (swap D C)
    (NatIso.ofComponents (fun X => eqToIso (by cases X <;> rfl))
    (by simp only [swap]; aesop_cat_nonterminal; cases f; cases f))
    (NatIso.ofComponents (fun X => eqToIso (by cases X <;> rfl))
    (by simp only [swap]; aesop_cat_nonterminal; cases f; cases f))
#align category_theory.sum.swap.equivalence CategoryTheory.Sum.Swap.equivalence

instance isEquivalence : IsEquivalence (swap C D) :=
  (by infer_instance : IsEquivalence (equivalence C D).functor)
#align category_theory.sum.swap.is_equivalence CategoryTheory.Sum.Swap.isEquivalence

/-- The double swap on `C ⊕ D` is naturally isomorphic to the identity functor. -/
def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (Sum C D) :=
  (equivalence C D).unitIso.symm
#align category_theory.sum.swap.symmetry CategoryTheory.Sum.Swap.symmetry

end Swap

end Sum

variable {A : Type u₁} [Category.{v₁} A] {B : Type u₁} [Category.{v₁} B] {C : Type u₁}
  [Category.{v₁} C] {D : Type u₁} [Category.{v₁} D]

namespace Functor

/-- The sum of two functors. -/
def sum (F : A ⥤ B) (G : C ⥤ D) : Sum A C ⥤ Sum B D
    where
  obj X :=
    match X with
    | inl X => inl (F.obj X)
    | inr X => inr (G.obj X)
  map := @fun X Y f =>
    match X, Y, f with
    | inl X, inl Y, f => F.map f
    | inr X, inr Y, f => G.map f
  map_id := @fun X => by cases X <;> aesop_cat_nonterminal; erw [F.map_id]; rfl; erw [G.map_id]; rfl
  map_comp := @fun X Y Z f g =>
    match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g => by
      aesop_cat_nonterminal <;>
      erw [F.map_comp] <;>
      rfl
    | inr X, inr Y, inr Z, f, g => by
      aesop_cat_nonterminal <;>
      erw [G.map_comp] <;>
      rfl
#align category_theory.functor.sum CategoryTheory.Functor.sum

@[simp]
theorem sum_obj_inl (F : A ⥤ B) (G : C ⥤ D) (a : A) : (F.sum G).obj (inl a) = inl (F.obj a) :=
  rfl
#align category_theory.functor.sum_obj_inl CategoryTheory.Functor.sum_obj_inl

@[simp]
theorem sum_obj_inr (F : A ⥤ B) (G : C ⥤ D) (c : C) : (F.sum G).obj (inr c) = inr (G.obj c) :=
  rfl
#align category_theory.functor.sum_obj_inr CategoryTheory.Functor.sum_obj_inr

@[simp]
theorem sum_map_inl (F : A ⥤ B) (G : C ⥤ D) {a a' : A} (f : inl a ⟶ inl a') :
    (F.sum G).map f = F.map f :=
  rfl
#align category_theory.functor.sum_map_inl CategoryTheory.Functor.sum_map_inl

@[simp]
theorem sum_map_inr (F : A ⥤ B) (G : C ⥤ D) {c c' : C} (f : inr c ⟶ inr c') :
    (F.sum G).map f = G.map f :=
  rfl
#align category_theory.functor.sum_map_inr CategoryTheory.Functor.sum_map_inr

end Functor

namespace NatTrans

/-- The sum of two natural transformations. -/
def sum {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) : F.sum H ⟶ G.sum I
    where
  app X :=
    match X with
    | inl X => α.app X
    | inr X => β.app X
  naturality X Y f :=
    match X, Y, f with
    | inl X, inl Y, f => by aesop_cat_nonterminal <;> erw [α.naturality] <;> rfl
    | inr X, inr Y, f => by aesop_cat_nonterminal <;> erw [β.naturality] <;> rfl
#align category_theory.nat_trans.sum CategoryTheory.NatTrans.sum

@[simp]
theorem sum_app_inl {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (a : A) :
    (sum α β).app (inl a) = α.app a :=
  rfl
#align category_theory.nat_trans.sum_app_inl CategoryTheory.NatTrans.sum_app_inl

@[simp]
theorem sum_app_inr {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (c : C) :
    (sum α β).app (inr c) = β.app c :=
  rfl
#align category_theory.nat_trans.sum_app_inr CategoryTheory.NatTrans.sum_app_inr

end NatTrans

end CategoryTheory


/-
Copyright (c) 2018 Johan Commelin All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Chris Hughes, Kevin Buzzard
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.hom
import Mathlib.PostPort

universes u v w u_1 u_2

namespace Mathlib

/-!
# Lift monoid homomorphisms to group homomorphisms of their units subgroups.
-/

namespace units

/-- The group homomorphism on units induced by a `monoid_hom`. -/
def map {M : Type u} {N : Type v} [monoid M] [monoid N] (f : M →* N) : units M →* units N :=
  monoid_hom.mk' (fun (u : units M) => mk (coe_fn f (val u)) (coe_fn f (inv u)) sorry sorry) sorry

@[simp] theorem coe_map {M : Type u} {N : Type v} [monoid M] [monoid N] (f : M →* N) (x : units M) :
    ↑(coe_fn (map f) x) = coe_fn f ↑x :=
  rfl

@[simp] theorem Mathlib.add_units.coe_map_neg {M : Type u} {N : Type v} [add_monoid M]
    [add_monoid N] (f : M →+ N) (u : add_units M) :
    ↑(-coe_fn (add_units.map f) u) = coe_fn f ↑(-u) :=
  rfl

@[simp] theorem map_comp {M : Type u} {N : Type v} {P : Type w} [monoid M] [monoid N] [monoid P]
    (f : M →* N) (g : N →* P) : map (monoid_hom.comp g f) = monoid_hom.comp (map g) (map f) :=
  rfl

@[simp] theorem map_id (M : Type u) [monoid M] : map (monoid_hom.id M) = monoid_hom.id (units M) :=
  monoid_hom.ext fun (x : units M) => ext (Eq.refl ↑(coe_fn (map (monoid_hom.id M)) x))

/-- Coercion `units M → M` as a monoid homomorphism. -/
def coe_hom (M : Type u) [monoid M] : units M →* M := monoid_hom.mk coe coe_one coe_mul

@[simp] theorem coe_hom_apply {M : Type u} [monoid M] (x : units M) : coe_fn (coe_hom M) x = ↑x :=
  rfl

/-- If a map `g : M → units N` agrees with a homomorphism `f : M →* N`, then
this map is a monoid homomorphism too. -/
def lift_right {M : Type u} {N : Type v} [monoid M] [monoid N] (f : M →* N) (g : M → units N)
    (h : ∀ (x : M), ↑(g x) = coe_fn f x) : M →* units N :=
  monoid_hom.mk g sorry sorry

@[simp] theorem coe_lift_right {M : Type u} {N : Type v} [monoid M] [monoid N] {f : M →* N}
    {g : M → units N} (h : ∀ (x : M), ↑(g x) = coe_fn f x) (x : M) :
    ↑(coe_fn (lift_right f g h) x) = coe_fn f x :=
  h x

@[simp] theorem mul_lift_right_inv {M : Type u} {N : Type v} [monoid M] [monoid N] {f : M →* N}
    {g : M → units N} (h : ∀ (x : M), ↑(g x) = coe_fn f x) (x : M) :
    coe_fn f x * ↑(coe_fn (lift_right f g h) x⁻¹) = 1 :=
  sorry

@[simp] theorem lift_right_inv_mul {M : Type u} {N : Type v} [monoid M] [monoid N] {f : M →* N}
    {g : M → units N} (h : ∀ (x : M), ↑(g x) = coe_fn f x) (x : M) :
    ↑(coe_fn (lift_right f g h) x⁻¹) * coe_fn f x = 1 :=
  sorry

end units

namespace monoid_hom

/-- If `f` is a homomorphism from a group `G` to a monoid `M`,
then its image lies in the units of `M`,
and `f.to_hom_units` is the corresponding monoid homomorphism from `G` to `units M`. -/
def Mathlib.add_monoid_hom.to_hom_units {G : Type u_1} {M : Type u_2} [add_group G] [add_monoid M]
    (f : G →+ M) : G →+ add_units M :=
  add_monoid_hom.mk (fun (g : G) => add_units.mk (coe_fn f g) (coe_fn f (-g)) sorry sorry) sorry
    sorry

@[simp] theorem coe_to_hom_units {G : Type u_1} {M : Type u_2} [group G] [monoid M] (f : G →* M)
    (g : G) : ↑(coe_fn (to_hom_units f) g) = coe_fn f g :=
  rfl

end monoid_hom

theorem is_unit.map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) {x : M}
    (h : is_unit x) : is_unit (coe_fn f x) :=
  Exists.dcases_on h
    fun (y : units M) (h_h : ↑y = x) => Eq._oldrec (is_unit_unit (coe_fn (units.map f) y)) h_h

/-- If a homomorphism `f : M →* N` sends each element to an `is_unit`, then it can be lifted
to `f : M →* units N`. See also `units.lift_right` for a computable version. -/
def is_unit.lift_right {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N)
    (hf : ∀ (x : M), is_unit (coe_fn f x)) : M →* units N :=
  units.lift_right f (fun (x : M) => classical.some (hf x)) sorry

theorem is_add_unit.coe_lift_right {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N]
    (f : M →+ N) (hf : ∀ (x : M), is_add_unit (coe_fn f x)) (x : M) :
    ↑(coe_fn (is_add_unit.lift_right f hf) x) = coe_fn f x :=
  add_units.coe_lift_right (is_add_unit.lift_right._proof_1 f hf) x

@[simp] theorem is_add_unit.add_lift_right_neg {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (f : M →+ N) (h : ∀ (x : M), is_add_unit (coe_fn f x)) (x : M) :
    coe_fn f x + ↑(-coe_fn (is_add_unit.lift_right f h) x) = 0 :=
  add_units.add_lift_right_neg (fun (y : M) => classical.some_spec (h y)) x

@[simp] theorem is_add_unit.lift_right_neg_add {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (f : M →+ N) (h : ∀ (x : M), is_add_unit (coe_fn f x)) (x : M) :
    ↑(-coe_fn (is_add_unit.lift_right f h) x) + coe_fn f x = 0 :=
  add_units.lift_right_neg_add (fun (y : M) => classical.some_spec (h y)) x

end Mathlib


import linear_algebra.finite_dimensional

lemma set.eq_empty_or_eq_insert {x : Type*} (s : set x) : s = ∅ ∨ ∃ t (x ∉ t), s = insert x t :=
begin
  rcases s.eq_empty_or_nonempty with (rfl|⟨x, hx⟩),
  { exact or.inl rfl },
  { refine or.inr ⟨s \ {x}, x, _, _⟩; simp [set.insert_eq_of_mem hx] }
end

lemma csupr_subtype {α : Type*} [conditionally_complete_linear_order_bot α]
  {ι : Sort*} {P : ι → Sort*} (f : Π i, P i → α) (hf : ∃ X, ∀ i h, f i h ≤ X) :
    (⨆ i h, f i h) = ⨆ i : {x // P x}, f i i.prop :=
begin
  obtain ⟨X, hf⟩ := hf,
  apply le_antisymm,
  { have : bdd_above (set.range (λ (i : {x // P x}), f _ i.prop)),
    { use X, rintro _ ⟨x, rfl⟩, exact hf _ _ },
    exact csupr_le' (λ i, csupr_le' $ λ h, le_csupr this ⟨i, h⟩) },
  { refine csupr_le' (λ i, le_trans _ (le_csupr _ i)),
    refine le_trans _ (le_csupr _ i.prop),
    { exact rfl.le },
    { use X, rintro _ ⟨x, rfl⟩, exact hf _ _ },
    { use X, rintro _ ⟨x, rfl⟩, exact csupr_le' (hf x) } }
end

lemma cardinal.le_of_add_one_le_add_one {α β : cardinal} (h : α + 1 ≤ β + 1) : α ≤ β :=
begin
  rw [← α.mk_out, ← β.mk_out] at h ⊢,
  rw [← cardinal.mk_option, ← cardinal.mk_option] at h,
  rw [cardinal.le_def] at h ⊢,
  obtain ⟨f⟩ := h,
  cases e : f none,
  { have : ∀ x : α.out, ∃ y : β.out, f x = y,
    { intro x, apply option.ne_none_iff_exists'.mp, intro e', apply option.some_ne_none x,
      apply f.injective, rw [e, ← e'], refl },
    choose y hy,
    refine ⟨⟨y, λ a b h, option.some_injective _ (f.injective _)⟩⟩,
    rw [← option.coe_def, hy, hy, h] },
  { refine ⟨⟨λ a, (f a).elim val id, λ a b (h : (f a).elim val id = (f b).elim val id), _⟩⟩,
    apply option.some_injective, apply f.injective,
    show f a = f b,
    cases ha : f a with a'; cases hb : f b with b',
    { refl },
    all_goals { rw [ha, hb] at h, dsimp at h, subst h },
    { cases f.injective (hb.trans e.symm) },
    { cases f.injective (ha.trans e.symm) } },
end

lemma cardinal.add_one_injective {α β : cardinal} (h : α + 1 = β + 1) : α = β :=
cardinal.eq_of_add_eq_add_right h cardinal.one_lt_aleph_0

lemma cardinal.exists_add_one_eq_iff {α : cardinal} :
  (∃ β, β + 1 = α) ↔ α ≠ 0 :=
begin
  split,
  { rintros ⟨β, rfl⟩ e, exact not_le_of_lt cardinal.zero_lt_one (le_add_self.trans_eq e) },
  { intro e,
    cases le_or_gt cardinal.aleph_0 α,
    { exact ⟨α, cardinal.add_one_eq h⟩ },
    { refine ⟨(α.to_nat - 1 : _), (_ : ↑(α.to_nat - 1 + 1) = α)⟩,
      rw [← bot_eq_zero, ← bot_lt_iff_ne_bot, bot_eq_zero,
        ← cardinal.to_nat_lt_iff_lt_of_lt_aleph_0 _ h, cardinal.zero_to_nat, zero_lt_iff,
        ← nat.one_le_iff_ne_zero] at e,
      rwa [tsub_add_cancel_of_le, cardinal.cast_to_nat_of_lt_aleph_0 h],
      exact e.trans h } }
end

lemma add_one_le_dim_iff_exists_submodule_rank_eq {R : Type*} {M : Type*} [field R]
  [add_comm_group M] [module R M] {c : cardinal} :
  c + 1 ≤ module.rank R M ↔ ∃ p : submodule R M, p ≠ ⊤ ∧ module.rank R p = c :=
begin
  rw le_dim_iff_exists_linear_independent,
  split,
  { rintros ⟨s, e, h⟩,
    obtain ⟨x, hx⟩ := cardinal.mk_ne_zero_iff.mp (show cardinal.mk s ≠ 0, by simp [e]),
    use submodule.span R (s \ {x}),
    split,
    { intro e,
      apply h.not_mem_span_image
        (set.not_mem_compl_iff.mpr (set.mem_singleton (⟨x, hx⟩ : s))),
      simp [set.compl_eq_univ_diff, set.image_diff subtype.coe_injective, e] },
    { have : x ∉ s \ {x} := λ e, e.2 rfl,
      apply cardinal.add_one_injective,
      rw [dim_span_set (h.mono (s.diff_subset {x})), ← e, ← cardinal.mk_insert this,
        set.insert_diff_singleton, set.insert_eq_of_mem hx] } },
  { rintros ⟨p, hp, rfl⟩,
    obtain ⟨x, hx⟩ : ∃ x, x ∉ p := by { revert hp, contrapose!, rw eq_top_iff, exact λ H x _, H x },
    obtain ⟨b, hb, e, h⟩ := exists_linear_independent R (p : set M),
    refine ⟨insert x b, _, h.insert ((e.trans p.span_eq).symm ▸ hx)⟩,
    rw [cardinal.mk_insert (λ e, hx (hb e)), ← e.trans p.span_eq, dim_span_set h] },
end

lemma rank_supr_ne_top_add_one {R : Type*} {M : Type*} [field R] [add_comm_group M] [module R M] :
  (⨆ (p : submodule R M) (h : p ≠ ⊤), module.rank R p + 1) = module.rank R M :=
begin
  rw csupr_subtype,
  swap, { exact ⟨module.rank R M + 1, λ _ _, add_le_add (dim_submodule_le _) rfl.le⟩ },
  apply le_antisymm,
  { exact csupr_le' (λ p, add_one_le_dim_iff_exists_submodule_rank_eq.mpr ⟨p.1, p.2, rfl⟩) },
  { by_cases module.rank R M = 0, { rw h, exact zero_le _ },
    obtain ⟨α, hα⟩ := cardinal.exists_add_one_eq_iff.mpr h,
    obtain ⟨p, hp, rfl⟩ := add_one_le_dim_iff_exists_submodule_rank_eq.mp hα.le,
    have : bdd_above (set.range (λ p : {x : submodule R M // x ≠ ⊤}, module.rank R p + 1)),
    { refine ⟨module.rank R M + 1, _⟩, rintros _ ⟨a, rfl⟩,
      exact add_le_add (dim_submodule_le _) rfl.le },
    exact hα.symm.le.trans (le_csupr this ⟨p, hp⟩) }
end

lemma rank_supr_lt_add_one {R : Type*} {M : Type*} [field R] [add_comm_group M] [module R M]
  (q : submodule R M) :
  (⨆ p < q, module.rank R p + 1) = module.rank R q :=
begin
  rw [← rank_supr_ne_top_add_one, csupr_subtype, csupr_subtype],
  have : ∀ p : { p : submodule R q // p ≠ ⊤ }, p.1.map q.subtype < q,
  { rintros ⟨p, hp⟩, convert q^.map_subtype.order_embedding^.strict_mono (lt_top_iff_ne_top.mpr hp),
    exact q.map_subtype_top.symm },
  let : {x // x < q} ≃ {x : submodule R q // x ≠ ⊤} :=
  { to_fun := λ p, ⟨_, submodule.comap_subtype_eq_top.not.mpr $ not_le_of_lt p.2⟩,
    inv_fun := λ p, ⟨p.1.map q.subtype, this p⟩,
    left_inv := λ p, subtype.ext ((submodule.map_comap_eq _ _).trans $ by simpa using p.2.le),
    right_inv := λ p, by { ext, simp } },
  apply equiv.supr_congr this,
  { rintros ⟨p, hp⟩, congr' 1,
    exact linear_equiv.dim_eq (submodule.comap_subtype_equiv_of_le hp.le) },
  { exact ⟨module.rank R q + 1, λ _ _, add_le_add (dim_submodule_le _) rfl.le⟩ },
  { exact ⟨module.rank R M + 1, λ _ _, add_le_add (dim_submodule_le _) rfl.le⟩ },
end