/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.lattice
import order.hom.bounded
import order.symm_diff

/-!
# Lattice homomorphisms

This file defines (bounded) lattice homomorphisms.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `sup_hom`: Maps which preserve `⊔`.
* `inf_hom`: Maps which preserve `⊓`.
* `sup_bot_hom`: Finitary supremum homomorphisms. Maps which preserve `⊔` and `⊥`.
* `inf_top_hom`: Finitary infimum homomorphisms. Maps which preserve `⊓` and `⊤`.
* `lattice_hom`: Lattice homomorphisms. Maps which preserve `⊔` and `⊓`.
* `bounded_lattice_hom`: Bounded lattice homomorphisms. Maps which preserve `⊤`, `⊥`, `⊔` and `⊓`.

## Typeclasses

* `sup_hom_class`
* `inf_hom_class`
* `sup_bot_hom_class`
* `inf_top_hom_class`
* `lattice_hom_class`
* `bounded_lattice_hom_class`

## TODO

Do we need more intersections between `bot_hom`, `top_hom` and lattice homomorphisms?
-/

open function order_dual

variables {F ι α β γ δ : Type*}

/-- The type of `⊔`-preserving functions from `α` to `β`. -/
structure sup_hom (α β : Type*) [has_sup α] [has_sup β] :=
(to_fun   : α → β)
(map_sup' (a b : α) : to_fun (a ⊔ b) = to_fun a ⊔ to_fun b)

/-- The type of `⊓`-preserving functions from `α` to `β`. -/
structure inf_hom (α β : Type*) [has_inf α] [has_inf β] :=
(to_fun   : α → β)
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of finitary supremum-preserving homomorphisms from `α` to `β`. -/
structure sup_bot_hom (α β : Type*) [has_sup α] [has_sup β] [has_bot α] [has_bot β]
  extends sup_hom α β :=
(map_bot' : to_fun ⊥ = ⊥)

/-- The type of finitary infimum-preserving homomorphisms from `α` to `β`. -/
structure inf_top_hom (α β : Type*) [has_inf α] [has_inf β] [has_top α] [has_top β]
  extends inf_hom α β :=
(map_top' : to_fun ⊤ = ⊤)

/-- The type of lattice homomorphisms from `α` to `β`. -/
structure lattice_hom (α β : Type*) [lattice α] [lattice β] extends sup_hom α β :=
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of bounded lattice homomorphisms from `α` to `β`. -/
structure bounded_lattice_hom (α β : Type*) [lattice α] [lattice β] [bounded_order α]
  [bounded_order β]
  extends lattice_hom α β :=
(map_top' : to_fun ⊤ = ⊤)
(map_bot' : to_fun ⊥ = ⊥)

/-- `sup_hom_class F α β` states that `F` is a type of `⊔`-preserving morphisms.

You should extend this class when you extend `sup_hom`. -/
class sup_hom_class (F : Type*) (α β : out_param $ Type*) [has_sup α] [has_sup β]
  extends fun_like F α (λ _, β) :=
(map_sup (f : F) (a b : α) : f (a ⊔ b) = f a ⊔ f b)

/-- `inf_hom_class F α β` states that `F` is a type of `⊓`-preserving morphisms.

You should extend this class when you extend `inf_hom`. -/
class inf_hom_class (F : Type*) (α β : out_param $ Type*) [has_inf α] [has_inf β]
  extends fun_like F α (λ _, β) :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

/-- `sup_bot_hom_class F α β` states that `F` is a type of finitary supremum-preserving morphisms.

You should extend this class when you extend `sup_bot_hom`. -/
class sup_bot_hom_class (F : Type*) (α β : out_param $ Type*) [has_sup α] [has_sup β] [has_bot α]
  [has_bot β] extends sup_hom_class F α β :=
(map_bot (f : F) : f ⊥ = ⊥)

/-- `inf_top_hom_class F α β` states that `F` is a type of finitary infimum-preserving morphisms.

You should extend this class when you extend `sup_bot_hom`. -/
class inf_top_hom_class (F : Type*) (α β : out_param $ Type*) [has_inf α]
  [has_inf β] [has_top α] [has_top β] extends inf_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)

/-- `lattice_hom_class F α β` states that `F` is a type of lattice morphisms.

You should extend this class when you extend `lattice_hom`. -/
class lattice_hom_class (F : Type*) (α β : out_param $ Type*) [lattice α] [lattice β]
  extends sup_hom_class F α β :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

/-- `bounded_lattice_hom_class F α β` states that `F` is a type of bounded lattice morphisms.

You should extend this class when you extend `bounded_lattice_hom`. -/
class bounded_lattice_hom_class (F : Type*) (α β : out_param $ Type*) [lattice α] [lattice β]
  [bounded_order α] [bounded_order β]
  extends lattice_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)
(map_bot (f : F) : f ⊥ = ⊥)

export sup_hom_class (map_sup)
export inf_hom_class (map_inf)

attribute [simp] map_top map_bot map_sup map_inf

@[priority 100] -- See note [lower instance priority]
instance sup_hom_class.to_order_hom_class [semilattice_sup α] [semilattice_sup β]
  [sup_hom_class F α β] :
  order_hom_class F α β :=
⟨λ f a b h, by rw [←sup_eq_right, ←map_sup, sup_eq_right.2 h]⟩

@[priority 100] -- See note [lower instance priority]
instance inf_hom_class.to_order_hom_class [semilattice_inf α] [semilattice_inf β]
  [inf_hom_class F α β] : order_hom_class F α β :=
⟨λ f a b h, by rw [←inf_eq_left, ←map_inf, inf_eq_left.2 h]⟩

@[priority 100] -- See note [lower instance priority]
instance sup_bot_hom_class.to_bot_hom_class [has_sup α] [has_sup β] [has_bot α] [has_bot β]
  [sup_bot_hom_class F α β] :
  bot_hom_class F α β :=
{ .. ‹sup_bot_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance inf_top_hom_class.to_top_hom_class [has_inf α] [has_inf β] [has_top α] [has_top β]
  [inf_top_hom_class F α β] :
  top_hom_class F α β :=
{ .. ‹inf_top_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance lattice_hom_class.to_inf_hom_class [lattice α] [lattice β] [lattice_hom_class F α β] :
  inf_hom_class F α β :=
{ .. ‹lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_sup_bot_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  sup_bot_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_inf_top_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  inf_top_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance bounded_lattice_hom_class.to_bounded_order_hom_class [lattice α] [lattice β]
  [bounded_order α] [bounded_order β] [bounded_lattice_hom_class F α β] :
  bounded_order_hom_class F α β :=
{ .. ‹bounded_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_sup_hom_class [semilattice_sup α] [semilattice_sup β]
  [order_iso_class F α β] :
  sup_hom_class F α β :=
⟨λ f a b, eq_of_forall_ge_iff $ λ c, by simp only [←le_map_inv_iff, sup_le_iff]⟩

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_inf_hom_class [semilattice_inf α] [semilattice_inf β]
  [order_iso_class F α β] :
  inf_hom_class F α β :=
⟨λ f a b, eq_of_forall_le_iff $ λ c, by simp only [←map_inv_le_iff, le_inf_iff]⟩

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_sup_bot_hom_class [semilattice_sup α] [order_bot α] [semilattice_sup β]
  [order_bot β] [order_iso_class F α β] :
  sup_bot_hom_class F α β :=
{ ..order_iso_class.to_sup_hom_class, ..order_iso_class.to_bot_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_inf_top_hom_class [semilattice_inf α] [order_top α] [semilattice_inf β]
  [order_top β] [order_iso_class F α β] :
  inf_top_hom_class F α β :=
{ ..order_iso_class.to_inf_hom_class, ..order_iso_class.to_top_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_lattice_hom_class [lattice α] [lattice β] [order_iso_class F α β] :
  lattice_hom_class F α β :=
{ ..order_iso_class.to_sup_hom_class, ..order_iso_class.to_inf_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_bounded_lattice_hom_class [lattice α] [lattice β] [bounded_order α]
  [bounded_order β] [order_iso_class F α β] :
  bounded_lattice_hom_class F α β :=
{ ..order_iso_class.to_lattice_hom_class, ..order_iso_class.to_bounded_order_hom_class }

@[simp] lemma map_finset_sup [semilattice_sup α] [order_bot α] [semilattice_sup β] [order_bot β]
  [sup_bot_hom_class F α β] (f : F) (s : finset ι) (g : ι → α) :
  f (s.sup g) = s.sup (f ∘ g) :=
finset.cons_induction_on s (map_bot f) $ λ i s _ h,
  by rw [finset.sup_cons, finset.sup_cons, map_sup, h]

@[simp] lemma map_finset_inf [semilattice_inf α] [order_top α] [semilattice_inf β] [order_top β]
  [inf_top_hom_class F α β] (f : F) (s : finset ι) (g : ι → α) :
  f (s.inf g) = s.inf (f ∘ g) :=
finset.cons_induction_on s (map_top f) $ λ i s _ h,
  by rw [finset.inf_cons, finset.inf_cons, map_inf, h]

section bounded_lattice
variables [lattice α] [bounded_order α] [lattice β] [bounded_order β]
  [bounded_lattice_hom_class F α β] (f : F) {a b : α}
include β

lemma disjoint.map (h : disjoint a b) : disjoint (f a) (f b) :=
by rw [disjoint_iff, ←map_inf, h.eq_bot, map_bot]

lemma is_compl.map (h : is_compl a b) : is_compl (f a) (f b) :=
{ inf_le_bot := h.disjoint.map _,
  top_le_sup := by rw [←map_sup, h.sup_eq_top, map_top] }

end bounded_lattice

section boolean_algebra
variables [boolean_algebra α] [boolean_algebra β] [bounded_lattice_hom_class F α β] (f : F)
include β

lemma map_compl (a : α) : f aᶜ = (f a)ᶜ := (is_compl_compl.map _).compl_eq.symm

lemma map_sdiff (a b : α) : f (a \ b) = f a \ f b := by rw [sdiff_eq, sdiff_eq, map_inf, map_compl]

lemma map_symm_diff (a b : α) : f (a ∆ b) = f a ∆ f b :=
by rw [symm_diff, symm_diff, map_sup, map_sdiff, map_sdiff]

end boolean_algebra

instance [has_sup α] [has_sup β] [sup_hom_class F α β] : has_coe_t F (sup_hom α β) :=
⟨λ f, ⟨f, map_sup f⟩⟩

instance [has_inf α] [has_inf β] [inf_hom_class F α β] : has_coe_t F (inf_hom α β) :=
⟨λ f, ⟨f, map_inf f⟩⟩

instance [has_sup α] [has_sup β] [has_bot α] [has_bot β] [sup_bot_hom_class F α β] :
  has_coe_t F (sup_bot_hom α β) :=
⟨λ f, ⟨f, map_bot f⟩⟩

instance [has_inf α] [has_inf β] [has_top α] [has_top β] [inf_top_hom_class F α β] :
  has_coe_t F (inf_top_hom α β) :=
⟨λ f, ⟨f, map_top f⟩⟩

instance [lattice α] [lattice β] [lattice_hom_class F α β] : has_coe_t F (lattice_hom α β) :=
⟨λ f, { to_fun := f, map_sup' := map_sup f, map_inf' := map_inf f }⟩

instance [lattice α] [lattice β] [bounded_order α] [bounded_order β]
  [bounded_lattice_hom_class F α β] : has_coe_t F (bounded_lattice_hom α β) :=
⟨λ f, { to_fun := f, map_top' := map_top f, map_bot' := map_bot f, ..(f : lattice_hom α β) }⟩

/-! ### Supremum homomorphisms -/

namespace sup_hom
variables [has_sup α]

section has_sup
variables [has_sup β] [has_sup γ] [has_sup δ]

instance : sup_hom_class (sup_hom α β) α β :=
{ coe := sup_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_sup := sup_hom.map_sup' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (sup_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : sup_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : sup_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `sup_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : sup_hom α β) (f' : α → β) (h : f' = f) : sup_hom α β :=
{ to_fun := f',
  map_sup' := h.symm ▸ f.map_sup' }

variables (α)

/-- `id` as a `sup_hom`. -/
protected def id : sup_hom α α := ⟨id, λ a b, rfl⟩

instance : inhabited (sup_hom α α) := ⟨sup_hom.id α⟩

@[simp] lemma coe_id : ⇑(sup_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : sup_hom.id α a = a := rfl

/-- Composition of `sup_hom`s as a `sup_hom`. -/
def comp (f : sup_hom β γ) (g : sup_hom α β) : sup_hom α γ :=
{ to_fun := f ∘ g,
  map_sup' := λ a b, by rw [comp_apply, map_sup, map_sup] }

@[simp] lemma coe_comp (f : sup_hom β γ) (g : sup_hom α β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : sup_hom β γ) (g : sup_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : sup_hom γ δ) (g : sup_hom β γ) (h : sup_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : sup_hom α β) : f.comp (sup_hom.id α) = f := sup_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : sup_hom α β) : (sup_hom.id β).comp f = f := sup_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : sup_hom β γ} {f : sup_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, sup_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : sup_hom β γ} {f₁ f₂ : sup_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, sup_hom.ext $ λ a, hg $
  by rw [←sup_hom.comp_apply, h, sup_hom.comp_apply], congr_arg _⟩

end has_sup

variables (α) [semilattice_sup β]

/-- The constant function as a `sup_hom`. -/
def const (b : β) : sup_hom α β := ⟨λ _, b, λ _ _, sup_idem.symm⟩

@[simp] lemma coe_const (b : β) : ⇑(const α b) = function.const α b := rfl
@[simp] lemma const_apply (b : β) (a : α) : const α b a = b := rfl

variables {α}

instance : has_sup (sup_hom α β) :=
⟨λ f g, ⟨f ⊔ g, λ a b, by { rw [pi.sup_apply, map_sup, map_sup], exact sup_sup_sup_comm _ _ _ _ }⟩⟩

instance : semilattice_sup (sup_hom α β) := fun_like.coe_injective.semilattice_sup _ $ λ f g, rfl

instance [has_bot β] : has_bot (sup_hom α β) := ⟨sup_hom.const α ⊥⟩
instance [has_top β] : has_top (sup_hom α β) := ⟨sup_hom.const α ⊤⟩

instance [order_bot β] : order_bot (sup_hom α β) :=
order_bot.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [order_top β] : order_top (sup_hom α β) :=
order_top.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [bounded_order β] : bounded_order (sup_hom α β) :=
bounded_order.lift (coe_fn : _ → α → β) (λ _ _, id) rfl rfl

@[simp] lemma coe_sup (f g : sup_hom α β) : ⇑(f ⊔ g) = f ⊔ g := rfl
@[simp] lemma coe_bot [has_bot β] : ⇑(⊥ : sup_hom α β) = ⊥ := rfl
@[simp] lemma coe_top [has_top β] : ⇑(⊤ : sup_hom α β) = ⊤ := rfl
@[simp] lemma sup_apply (f g : sup_hom α β) (a : α) : (f ⊔ g) a = f a ⊔ g a := rfl
@[simp] lemma bot_apply [has_bot β] (a : α) : (⊥ : sup_hom α β) a = ⊥ := rfl
@[simp] lemma top_apply [has_top β] (a : α) : (⊤ : sup_hom α β) a = ⊤ := rfl

end sup_hom

/-! ### Infimum homomorphisms -/

namespace inf_hom
variables [has_inf α]

section has_inf
variables [has_inf β] [has_inf γ] [has_inf δ]

instance : inf_hom_class (inf_hom α β) α β :=
{ coe := inf_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_inf := inf_hom.map_inf' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (inf_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : inf_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : inf_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `inf_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : inf_hom α β) (f' : α → β) (h : f' = f) : inf_hom α β :=
{ to_fun := f',
  map_inf' := h.symm ▸ f.map_inf' }

variables (α)

/-- `id` as an `inf_hom`. -/
protected def id : inf_hom α α := ⟨id, λ a b, rfl⟩

instance : inhabited (inf_hom α α) := ⟨inf_hom.id α⟩

@[simp] lemma coe_id : ⇑(inf_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : inf_hom.id α a = a := rfl

/-- Composition of `inf_hom`s as an `inf_hom`. -/
def comp (f : inf_hom β γ) (g : inf_hom α β) : inf_hom α γ :=
{ to_fun := f ∘ g,
  map_inf' := λ a b, by rw [comp_apply, map_inf, map_inf] }

@[simp] lemma coe_comp (f : inf_hom β γ) (g : inf_hom α β) : (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : inf_hom β γ) (g : inf_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : inf_hom γ δ) (g : inf_hom β γ) (h : inf_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : inf_hom α β) : f.comp (inf_hom.id α) = f := inf_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : inf_hom α β) : (inf_hom.id β).comp f = f := inf_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : inf_hom β γ} {f : inf_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, inf_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : inf_hom β γ} {f₁ f₂ : inf_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, inf_hom.ext $ λ a, hg $
  by rw [←inf_hom.comp_apply, h, inf_hom.comp_apply], congr_arg _⟩

end has_inf

variables (α) [semilattice_inf β]

/-- The constant function as an `inf_hom`. -/
def const (b : β) : inf_hom α β := ⟨λ _, b, λ _ _, inf_idem.symm⟩

@[simp] lemma coe_const (b : β) : ⇑(const α b) = function.const α b := rfl
@[simp] lemma const_apply (b : β) (a : α) : const α b a = b := rfl

variables {α}

instance : has_inf (inf_hom α β) :=
⟨λ f g, ⟨f ⊓ g, λ a b, by { rw [pi.inf_apply, map_inf, map_inf], exact inf_inf_inf_comm _ _ _ _ }⟩⟩

instance : semilattice_inf (inf_hom α β) := fun_like.coe_injective.semilattice_inf _ $ λ f g, rfl

instance [has_bot β] : has_bot (inf_hom α β) := ⟨inf_hom.const α ⊥⟩
instance [has_top β] : has_top (inf_hom α β) := ⟨inf_hom.const α ⊤⟩

instance [order_bot β] : order_bot (inf_hom α β) :=
order_bot.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [order_top β] : order_top (inf_hom α β) :=
order_top.lift (coe_fn : _ → α → β) (λ _ _, id) rfl

instance [bounded_order β] : bounded_order (inf_hom α β) :=
bounded_order.lift (coe_fn : _ → α → β) (λ _ _, id) rfl rfl

@[simp] lemma coe_inf (f g : inf_hom α β) : ⇑(f ⊓ g) = f ⊓ g := rfl
@[simp] lemma coe_bot [has_bot β] : ⇑(⊥ : inf_hom α β) = ⊥ := rfl
@[simp] lemma coe_top [has_top β] : ⇑(⊤ : inf_hom α β) = ⊤ := rfl
@[simp] lemma inf_apply (f g : inf_hom α β) (a : α) : (f ⊓ g) a = f a ⊓ g a := rfl
@[simp] lemma bot_apply [has_bot β] (a : α) : (⊥ : inf_hom α β) a = ⊥ := rfl
@[simp] lemma top_apply [has_top β] (a : α) : (⊤ : inf_hom α β) a = ⊤ := rfl

end inf_hom

/-! ### Finitary supremum homomorphisms -/

namespace sup_bot_hom
variables [has_sup α] [has_bot α]

section has_sup
variables [has_sup β] [has_bot β] [has_sup γ] [has_bot γ] [has_sup δ] [has_bot δ]

/-- Reinterpret a `sup_bot_hom` as a `bot_hom`. -/
def to_bot_hom (f : sup_bot_hom α β) : bot_hom α β := { ..f }

instance : sup_bot_hom_class (sup_bot_hom α β) α β :=
{ coe :=  λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_sup := λ f, f.map_sup',
  map_bot := λ f, f.map_bot' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (sup_bot_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : sup_bot_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : sup_bot_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `sup_bot_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : sup_bot_hom α β) (f' : α → β) (h : f' = f) : sup_bot_hom α β :=
{ to_sup_hom := f.to_sup_hom.copy f' h, ..f.to_bot_hom.copy f' h }

variables (α)

/-- `id` as a `sup_bot_hom`. -/
@[simps] protected def id : sup_bot_hom α α := ⟨sup_hom.id α, rfl⟩

instance : inhabited (sup_bot_hom α α) := ⟨sup_bot_hom.id α⟩

@[simp] lemma coe_id : ⇑(sup_bot_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : sup_bot_hom.id α a = a := rfl

/-- Composition of `sup_bot_hom`s as a `sup_bot_hom`. -/
def comp (f : sup_bot_hom β γ) (g : sup_bot_hom α β) : sup_bot_hom α γ :=
{ ..f.to_sup_hom.comp g.to_sup_hom, ..f.to_bot_hom.comp g.to_bot_hom }

@[simp] lemma coe_comp (f : sup_bot_hom β γ) (g : sup_bot_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : sup_bot_hom β γ) (g : sup_bot_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : sup_bot_hom γ δ) (g : sup_bot_hom β γ) (h : sup_bot_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : sup_bot_hom α β) : f.comp (sup_bot_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : sup_bot_hom α β) : (sup_bot_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : sup_bot_hom β γ} {f : sup_bot_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : sup_bot_hom β γ} {f₁ f₂ : sup_bot_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, sup_bot_hom.ext $ λ a, hg $
  by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_sup

variables [semilattice_sup β] [order_bot β]

instance : has_sup (sup_bot_hom α β) :=
⟨λ f g, { to_sup_hom := f.to_sup_hom ⊔ g.to_sup_hom, ..f.to_bot_hom ⊔ g.to_bot_hom }⟩

instance : semilattice_sup (sup_bot_hom α β) :=
fun_like.coe_injective.semilattice_sup _ $ λ f g, rfl

instance : order_bot (sup_bot_hom α β) := { bot := ⟨⊥, rfl⟩, bot_le := λ f, bot_le }

@[simp] lemma coe_sup (f g : sup_bot_hom α β) : ⇑(f ⊔ g) = f ⊔ g := rfl
@[simp] lemma coe_bot : ⇑(⊥ : sup_bot_hom α β) = ⊥ := rfl
@[simp] lemma sup_apply (f g : sup_bot_hom α β) (a : α) : (f ⊔ g) a = f a ⊔ g a := rfl
@[simp] lemma bot_apply (a : α) : (⊥ : sup_bot_hom α β) a = ⊥ := rfl

end sup_bot_hom

/-! ### Finitary infimum homomorphisms -/

namespace inf_top_hom
variables [has_inf α] [has_top α]

section has_inf
variables [has_inf β] [has_top β] [has_inf γ] [has_top γ] [has_inf δ] [has_top δ]

/-- Reinterpret an `inf_top_hom` as a `top_hom`. -/
def to_top_hom (f : inf_top_hom α β) : top_hom α β := { ..f }

instance : inf_top_hom_class (inf_top_hom α β) α β :=
{ coe :=  λ f, f.to_fun,
  coe_injective' := λ f g h, by { obtain ⟨⟨_, _⟩, _⟩ := f, obtain ⟨⟨_, _⟩, _⟩ := g, congr' },
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (inf_top_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : inf_top_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : inf_top_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of an `inf_top_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : inf_top_hom α β) (f' : α → β) (h : f' = f) : inf_top_hom α β :=
{ to_inf_hom := f.to_inf_hom.copy f' h, ..f.to_top_hom.copy f' h }

variables (α)

/-- `id` as an `inf_top_hom`. -/
@[simps] protected def id : inf_top_hom α α := ⟨inf_hom.id α, rfl⟩

instance : inhabited (inf_top_hom α α) := ⟨inf_top_hom.id α⟩

@[simp] lemma coe_id : ⇑(inf_top_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : inf_top_hom.id α a = a := rfl

/-- Composition of `inf_top_hom`s as an `inf_top_hom`. -/
def comp (f : inf_top_hom β γ) (g : inf_top_hom α β) : inf_top_hom α γ :=
{ ..f.to_inf_hom.comp g.to_inf_hom, ..f.to_top_hom.comp g.to_top_hom }

@[simp] lemma coe_comp (f : inf_top_hom β γ) (g : inf_top_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : inf_top_hom β γ) (g : inf_top_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : inf_top_hom γ δ) (g : inf_top_hom β γ) (h : inf_top_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : inf_top_hom α β) : f.comp (inf_top_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : inf_top_hom α β) : (inf_top_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : inf_top_hom β γ} {f : inf_top_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : inf_top_hom β γ} {f₁ f₂ : inf_top_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, inf_top_hom.ext $ λ a, hg $
  by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_inf

variables [semilattice_inf β] [order_top β]

instance : has_inf (inf_top_hom α β) :=
⟨λ f g, { to_inf_hom := f.to_inf_hom ⊓ g.to_inf_hom, ..f.to_top_hom ⊓ g.to_top_hom }⟩

instance : semilattice_inf (inf_top_hom α β) :=
fun_like.coe_injective.semilattice_inf _ $ λ f g, rfl

instance : order_top (inf_top_hom α β) := { top := ⟨⊤, rfl⟩, le_top := λ f, le_top }

@[simp] lemma coe_inf (f g : inf_top_hom α β) : ⇑(f ⊓ g) = f ⊓ g := rfl
@[simp] lemma coe_top : ⇑(⊤ : inf_top_hom α β) = ⊤ := rfl
@[simp] lemma inf_apply (f g : inf_top_hom α β) (a : α) : (f ⊓ g) a = f a ⊓ g a := rfl
@[simp] lemma top_apply (a : α) : (⊤ : inf_top_hom α β) a = ⊤ := rfl

end inf_top_hom

/-! ### Lattice homomorphisms -/

namespace lattice_hom
variables [lattice α] [lattice β] [lattice γ] [lattice δ]

/-- Reinterpret a `lattice_hom` as an `inf_hom`. -/
def to_inf_hom (f : lattice_hom α β) : inf_hom α β := { ..f }

instance : lattice_hom_class (lattice_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨_, _⟩, _⟩ := f; obtain ⟨⟨_, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : lattice_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : lattice_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `lattice_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : lattice_hom α β) (f' : α → β) (h : f' = f) : lattice_hom α β :=
{ .. f.to_sup_hom.copy f' h, .. f.to_inf_hom.copy f' h }

variables (α)

/-- `id` as a `lattice_hom`. -/
protected def id : lattice_hom α α :=
{ to_fun := id,
  map_sup' := λ _ _, rfl,
  map_inf' := λ _ _, rfl }

instance : inhabited (lattice_hom α α) := ⟨lattice_hom.id α⟩

@[simp] lemma coe_id : ⇑(lattice_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : lattice_hom.id α a = a := rfl

/-- Composition of `lattice_hom`s as a `lattice_hom`. -/
def comp (f : lattice_hom β γ) (g : lattice_hom α β) : lattice_hom α γ :=
{ ..f.to_sup_hom.comp g.to_sup_hom, ..f.to_inf_hom.comp g.to_inf_hom }

@[simp] lemma coe_comp (f : lattice_hom β γ) (g : lattice_hom α β) : (f.comp g : α → γ) = f ∘ g :=
rfl
@[simp] lemma comp_apply (f : lattice_hom β γ) (g : lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_sup_hom (f : lattice_hom β γ) (g : lattice_hom α β) :
  (f.comp g : sup_hom α γ) = (f : sup_hom β γ).comp g := rfl
@[simp] lemma coe_comp_inf_hom (f : lattice_hom β γ) (g : lattice_hom α β) :
  (f.comp g : inf_hom α γ) = (f : inf_hom β γ).comp g := rfl
@[simp] lemma comp_assoc (f : lattice_hom γ δ) (g : lattice_hom β γ) (h : lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : lattice_hom α β) : f.comp (lattice_hom.id α) = f :=
lattice_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : lattice_hom α β) : (lattice_hom.id β).comp f = f :=
lattice_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : lattice_hom β γ} {f : lattice_hom α β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, lattice_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : lattice_hom β γ} {f₁ f₂ : lattice_hom α β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, lattice_hom.ext $ λ a, hg $
  by rw [←lattice_hom.comp_apply, h, lattice_hom.comp_apply], congr_arg _⟩

end lattice_hom

namespace order_hom_class
variables (α β) [linear_order α] [lattice β] [order_hom_class F α β]

/-- An order homomorphism from a linear order is a lattice homomorphism. -/
@[reducible] def to_lattice_hom_class : lattice_hom_class F α β :=
{ map_sup := λ f a b, begin
    obtain h | h := le_total a b,
    { rw [sup_eq_right.2 h, sup_eq_right.2 (order_hom_class.mono f h : f a ≤ f b)] },
    { rw [sup_eq_left.2 h, sup_eq_left.2 (order_hom_class.mono f h : f b ≤ f a)] }
  end,
  map_inf := λ f a b, begin
    obtain h | h := le_total a b,
    { rw [inf_eq_left.2 h, inf_eq_left.2 (order_hom_class.mono f h : f a ≤ f b)] },
    { rw [inf_eq_right.2 h, inf_eq_right.2 (order_hom_class.mono f h : f b ≤ f a)] }
  end,
  .. ‹order_hom_class F α β› }

/-- Reinterpret an order homomorphism to a linear order as a `lattice_hom`. -/
def to_lattice_hom (f : F) : lattice_hom α β :=
by { haveI : lattice_hom_class F α β := order_hom_class.to_lattice_hom_class α β, exact f }

@[simp] lemma coe_to_lattice_hom (f : F) : ⇑(to_lattice_hom α β f) = f := rfl
@[simp] lemma to_lattice_hom_apply (f : F) (a : α) : to_lattice_hom α β f a = f a := rfl

end order_hom_class

/-! ### Bounded lattice homomorphisms -/

namespace bounded_lattice_hom
variables [lattice α] [lattice β] [lattice γ] [lattice δ] [bounded_order α] [bounded_order β]
  [bounded_order γ] [bounded_order δ]

/-- Reinterpret a `bounded_lattice_hom` as a `sup_bot_hom`. -/
def to_sup_bot_hom (f : bounded_lattice_hom α β) : sup_bot_hom α β := { ..f }

/-- Reinterpret a `bounded_lattice_hom` as an `inf_top_hom`. -/
def to_inf_top_hom (f : bounded_lattice_hom α β) : inf_top_hom α β := { ..f }

/-- Reinterpret a `bounded_lattice_hom` as a `bounded_order_hom`. -/
def to_bounded_order_hom (f : bounded_lattice_hom α β) : bounded_order_hom α β :=
{ ..f, ..(f.to_lattice_hom : α →o β) }

instance : bounded_lattice_hom_class (bounded_lattice_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top',
  map_bot := λ f, f.map_bot' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (bounded_lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : bounded_lattice_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : bounded_lattice_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `bounded_lattice_hom` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : bounded_lattice_hom α β) (f' : α → β) (h : f' = f) :
  bounded_lattice_hom α β :=
{ .. f.to_lattice_hom.copy f' h, .. f.to_bounded_order_hom.copy f' h }

variables (α)

/-- `id` as a `bounded_lattice_hom`. -/
protected def id : bounded_lattice_hom α α := { ..lattice_hom.id α, ..bounded_order_hom.id α }

instance : inhabited (bounded_lattice_hom α α) := ⟨bounded_lattice_hom.id α⟩

@[simp] lemma coe_id : ⇑(bounded_lattice_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : bounded_lattice_hom.id α a = a := rfl

/-- Composition of `bounded_lattice_hom`s as a `bounded_lattice_hom`. -/
def comp (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) : bounded_lattice_hom α γ :=
{ ..f.to_lattice_hom.comp g.to_lattice_hom, ..f.to_bounded_order_hom.comp g.to_bounded_order_hom }

@[simp] lemma coe_comp (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : α → γ) = f ∘ g := rfl
@[simp] lemma comp_apply (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma coe_comp_lattice_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : lattice_hom α γ) = (f : lattice_hom β γ).comp g := rfl
@[simp] lemma coe_comp_sup_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : sup_hom α γ) = (f : sup_hom β γ).comp g := rfl
@[simp] lemma coe_comp_inf_hom (f : bounded_lattice_hom β γ) (g : bounded_lattice_hom α β) :
  (f.comp g : inf_hom α γ) = (f : inf_hom β γ).comp g := rfl
@[simp] lemma comp_assoc (f : bounded_lattice_hom γ δ) (g : bounded_lattice_hom β γ)
  (h : bounded_lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : bounded_lattice_hom α β) : f.comp (bounded_lattice_hom.id α) = f :=
bounded_lattice_hom.ext $ λ a, rfl
@[simp] lemma id_comp (f : bounded_lattice_hom α β) : (bounded_lattice_hom.id β).comp f = f :=
bounded_lattice_hom.ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : bounded_lattice_hom β γ} {f : bounded_lattice_hom α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, bounded_lattice_hom.ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : bounded_lattice_hom β γ} {f₁ f₂ : bounded_lattice_hom α β}
  (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end bounded_lattice_hom

/-! ### Dual homs -/

namespace sup_hom
variables [has_sup α] [has_sup β] [has_sup γ]

/-- Reinterpret a supremum homomorphism as an infimum homomorphism between the dual lattices. -/
@[simps] protected def dual : sup_hom α β ≃ inf_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f, f.map_sup'⟩,
  inv_fun := λ f, ⟨f, f.map_inf'⟩,
  left_inv := λ f, sup_hom.ext $ λ _, rfl,
  right_inv := λ f, inf_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (sup_hom.id α).dual = inf_hom.id _ := rfl
@[simp] lemma dual_comp (g : sup_hom β γ) (f : sup_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : sup_hom.dual.symm (inf_hom.id _) = sup_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : inf_hom βᵒᵈ γᵒᵈ) (f : inf_hom αᵒᵈ βᵒᵈ) :
  sup_hom.dual.symm (g.comp f) = (sup_hom.dual.symm g).comp (sup_hom.dual.symm f) := rfl

end sup_hom

namespace inf_hom
variables [has_inf α] [has_inf β] [has_inf γ]

/-- Reinterpret an infimum homomorphism as a supremum homomorphism between the dual lattices. -/
@[simps] protected def dual : inf_hom α β ≃ sup_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f, f.map_inf'⟩,
  inv_fun := λ f, ⟨f, f.map_sup'⟩,
  left_inv := λ f, inf_hom.ext $ λ _, rfl,
  right_inv := λ f, sup_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (inf_hom.id α).dual = sup_hom.id _ := rfl
@[simp] lemma dual_comp (g : inf_hom β γ) (f : inf_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : inf_hom.dual.symm (sup_hom.id _) = inf_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : sup_hom βᵒᵈ γᵒᵈ) (f : sup_hom αᵒᵈ βᵒᵈ) :
  inf_hom.dual.symm (g.comp f) = (inf_hom.dual.symm g).comp (inf_hom.dual.symm f) := rfl

end inf_hom

namespace sup_bot_hom
variables [has_sup α] [has_bot α] [has_sup β] [has_bot β] [has_sup γ] [has_bot γ]

/-- Reinterpret a finitary supremum homomorphism as a finitary infimum homomorphism between the dual
lattices. -/
def dual : sup_bot_hom α β ≃ inf_top_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_sup_hom.dual, f.map_bot'⟩,
  inv_fun := λ f, ⟨sup_hom.dual.symm f.to_inf_hom, f.map_top'⟩,
  left_inv := λ f, sup_bot_hom.ext $ λ _, rfl,
  right_inv := λ f, inf_top_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (sup_bot_hom.id α).dual = inf_top_hom.id _ := rfl
@[simp] lemma dual_comp (g : sup_bot_hom β γ) (f : sup_bot_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : sup_bot_hom.dual.symm (inf_top_hom.id _) = sup_bot_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : inf_top_hom βᵒᵈ γᵒᵈ) (f : inf_top_hom αᵒᵈ βᵒᵈ) :
  sup_bot_hom.dual.symm (g.comp f) = (sup_bot_hom.dual.symm g).comp (sup_bot_hom.dual.symm f) := rfl

end sup_bot_hom

namespace inf_top_hom
variables [has_inf α] [has_top α] [has_inf β] [has_top β] [has_inf γ] [has_top γ]

/-- Reinterpret a finitary infimum homomorphism as a finitary supremum homomorphism between the dual
lattices. -/
@[simps] protected def dual : inf_top_hom α β ≃ sup_bot_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_inf_hom.dual, f.map_top'⟩,
  inv_fun := λ f, ⟨inf_hom.dual.symm f.to_sup_hom, f.map_bot'⟩,
  left_inv := λ f, inf_top_hom.ext $ λ _, rfl,
  right_inv := λ f, sup_bot_hom.ext $ λ _, rfl }

@[simp] lemma dual_id : (inf_top_hom.id α).dual = sup_bot_hom.id _ := rfl
@[simp] lemma dual_comp (g : inf_top_hom β γ) (f : inf_top_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : inf_top_hom.dual.symm (sup_bot_hom.id _) = inf_top_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : sup_bot_hom βᵒᵈ γᵒᵈ) (f : sup_bot_hom αᵒᵈ βᵒᵈ) :
  inf_top_hom.dual.symm (g.comp f) = (inf_top_hom.dual.symm g).comp (inf_top_hom.dual.symm f) := rfl

end inf_top_hom

namespace lattice_hom
variables [lattice α] [lattice β] [lattice γ]

/-- Reinterpret a lattice homomorphism as a lattice homomorphism between the dual lattices. -/
@[simps] protected def dual : lattice_hom α β ≃ lattice_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_inf_hom.dual, f.map_sup'⟩,
  inv_fun := λ f, ⟨f.to_inf_hom.dual, f.map_sup'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

@[simp] lemma dual_id : (lattice_hom.id α).dual = lattice_hom.id _ := rfl
@[simp] lemma dual_comp (g : lattice_hom β γ) (f : lattice_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id : lattice_hom.dual.symm (lattice_hom.id _) = lattice_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : lattice_hom βᵒᵈ γᵒᵈ) (f : lattice_hom αᵒᵈ βᵒᵈ) :
  lattice_hom.dual.symm (g.comp f) = (lattice_hom.dual.symm g).comp (lattice_hom.dual.symm f) := rfl

end lattice_hom

namespace bounded_lattice_hom
variables [lattice α] [bounded_order α] [lattice β] [bounded_order β] [lattice γ] [bounded_order γ]

/-- Reinterpret a bounded lattice homomorphism as a bounded lattice homomorphism between the dual
bounded lattices. -/
@[simps] protected def dual : bounded_lattice_hom α β ≃ bounded_lattice_hom αᵒᵈ βᵒᵈ :=
{ to_fun := λ f, ⟨f.to_lattice_hom.dual, f.map_bot', f.map_top'⟩,
  inv_fun := λ f, ⟨lattice_hom.dual.symm f.to_lattice_hom, f.map_bot', f.map_top'⟩,
  left_inv := λ f, ext $ λ a, rfl,
  right_inv := λ f, ext $ λ a, rfl }

@[simp] lemma dual_id : (bounded_lattice_hom.id α).dual = bounded_lattice_hom.id _ := rfl
@[simp] lemma dual_comp (g : bounded_lattice_hom β γ) (f : bounded_lattice_hom α β) :
  (g.comp f).dual = g.dual.comp f.dual := rfl

@[simp] lemma symm_dual_id :
  bounded_lattice_hom.dual.symm (bounded_lattice_hom.id _) = bounded_lattice_hom.id α := rfl
@[simp] lemma symm_dual_comp (g : bounded_lattice_hom βᵒᵈ γᵒᵈ) (f : bounded_lattice_hom αᵒᵈ βᵒᵈ) :
  bounded_lattice_hom.dual.symm (g.comp f) =
    (bounded_lattice_hom.dual.symm g).comp (bounded_lattice_hom.dual.symm f) := rfl

end bounded_lattice_hom


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import order.rel_classes

/-!
# Lexicographic ordering of lists.

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

The lexicographic order on `list α` is defined by `L < M` iff
* `[] < (a :: L)` for any `a` and `L`,
* `(a :: L) < (b :: M)` where `a < b`, or
* `(a :: L) < (a :: M)` where `L < M`.

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.psigma.order`: Lexicographic order on `Σ' i, α i`.
* `data.pi.lex`: Lexicographic order on `Πₗ i, α i`.
* `data.sigma.order`: Lexicographic order on `Σ i, α i`.
* `data.prod.lex`: Lexicographic order on `α × β`.
-/

namespace list

open nat

universes u

variables {α : Type u}

/-! ### lexicographic ordering -/

/-- Given a strict order `<` on `α`, the lexicographic strict order on `list α`, for which
`[a0, ..., an] < [b0, ..., b_k]` if `a0 < b0` or `a0 = b0` and `[a1, ..., an] < [b1, ..., bk]`.
The definition is given for any relation `r`, not only strict orders. -/
inductive lex (r : α → α → Prop) : list α → list α → Prop
| nil {a l} : lex [] (a :: l)
| cons {a l₁ l₂} (h : lex l₁ l₂) : lex (a :: l₁) (a :: l₂)
| rel {a₁ l₁ a₂ l₂} (h : r a₁ a₂) : lex (a₁ :: l₁) (a₂ :: l₂)

namespace lex
theorem cons_iff {r : α → α → Prop} [is_irrefl α r] {a l₁ l₂} :
  lex r (a :: l₁) (a :: l₂) ↔ lex r l₁ l₂ :=
⟨λ h, by cases h with _ _ _ _ _ h _ _ _ _ h;
  [exact h, exact (irrefl_of r a h).elim], lex.cons⟩

@[simp] theorem not_nil_right (r : α → α → Prop) (l : list α) : ¬ lex r l [].

instance is_order_connected (r : α → α → Prop)
  [is_order_connected α r] [is_trichotomous α r] :
  is_order_connected (list α) (lex r) :=
⟨λ l₁, match l₁ with
| _,     [],    c::l₃, nil    := or.inr nil
| _,     [],    c::l₃, rel _ := or.inr nil
| _,     [],    c::l₃, cons _ := or.inr nil
| _,     b::l₂, c::l₃, nil := or.inl nil
| a::l₁, b::l₂, c::l₃, rel h :=
  (is_order_connected.conn _ b _ h).imp rel rel
| a::l₁, b::l₂, _::l₃, cons h := begin
    rcases trichotomous_of r a b with ab | rfl | ab,
    { exact or.inl (rel ab) },
    { exact (_match _ l₂ _ h).imp cons cons },
    { exact or.inr (rel ab) }
  end
end⟩

instance is_trichotomous (r : α → α → Prop) [is_trichotomous α r] :
  is_trichotomous (list α) (lex r) :=
⟨λ l₁, match l₁ with
| [], [] := or.inr (or.inl rfl)
| [], b::l₂ := or.inl nil
| a::l₁, [] := or.inr (or.inr nil)
| a::l₁, b::l₂ := begin
    rcases trichotomous_of r a b with ab | rfl | ab,
    { exact or.inl (rel ab) },
    { exact (_match l₁ l₂).imp cons
      (or.imp (congr_arg _) cons) },
    { exact or.inr (or.inr (rel ab)) }
  end
end⟩

instance is_asymm (r : α → α → Prop)
  [is_asymm α r] : is_asymm (list α) (lex r) :=
⟨λ l₁, match l₁ with
| a::l₁, b::l₂, lex.rel h₁, lex.rel h₂ := asymm h₁ h₂
| a::l₁, b::l₂, lex.rel h₁, lex.cons h₂ := asymm h₁ h₁
| a::l₁, b::l₂, lex.cons h₁, lex.rel h₂ := asymm h₂ h₂
| a::l₁, b::l₂, lex.cons h₁, lex.cons h₂ :=
  by exact _match _ _ h₁ h₂
end⟩

instance is_strict_total_order (r : α → α → Prop)
  [is_strict_total_order α r] : is_strict_total_order (list α) (lex r) :=
{..is_strict_weak_order_of_is_order_connected}

instance decidable_rel [decidable_eq α] (r : α → α → Prop)
  [decidable_rel r] : decidable_rel (lex r)
| l₁ [] := is_false $ λ h, by cases h
| [] (b::l₂) := is_true lex.nil
| (a::l₁) (b::l₂) := begin
  haveI := decidable_rel l₁ l₂,
  refine decidable_of_iff (r a b ∨ a = b ∧ lex r l₁ l₂) ⟨λ h, _, λ h, _⟩,
  { rcases h with h | ⟨rfl, h⟩,
    { exact lex.rel h },
    { exact lex.cons h } },
  { rcases h with _ | h | h,
    { exact or.inr ⟨rfl, h⟩ },
    { exact or.inl h } }
end

theorem append_left (R : α → α → Prop) {t₁ t₂} (h : lex R t₁ t₂) :
  ∀ s, lex R (s ++ t₁) (s ++ t₂)
| []      := h
| (a::l) := cons (append_left l)

theorem imp {r s : α → α → Prop} (H : ∀ a b, r a b → s a b) :
  ∀ l₁ l₂, lex r l₁ l₂ → lex s l₁ l₂
| _ _ nil      := nil
| _ _ (cons h) := cons (imp _ _ h)
| _ _ (rel r)  := rel (H _ _ r)

theorem to_ne : ∀ {l₁ l₂ : list α}, lex (≠) l₁ l₂ → l₁ ≠ l₂
| _ _ (cons h) e := to_ne h (list.cons.inj e).2
| _ _ (rel r)  e := r (list.cons.inj e).1

theorem _root_.decidable.list.lex.ne_iff [decidable_eq α]
  {l₁ l₂ : list α} (H : length l₁ ≤ length l₂) : lex (≠) l₁ l₂ ↔ l₁ ≠ l₂ :=
⟨to_ne, λ h, begin
  induction l₁ with a l₁ IH generalizing l₂; cases l₂ with b l₂,
  { contradiction },
  { apply nil },
  { exact (not_lt_of_ge H).elim (succ_pos _) },
  { by_cases ab : a = b,
    { subst b, apply cons,
      exact IH (le_of_succ_le_succ H) (mt (congr_arg _) h) },
    { exact rel ab } }
end⟩

theorem ne_iff {l₁ l₂ : list α} (H : length l₁ ≤ length l₂) : lex (≠) l₁ l₂ ↔ l₁ ≠ l₂ :=
by classical; exact decidable.list.lex.ne_iff H

end lex

--Note: this overrides an instance in core lean
instance has_lt' [has_lt α] : has_lt (list α) := ⟨lex (<)⟩

theorem nil_lt_cons [has_lt α] (a : α) (l : list α) : [] < a :: l :=
lex.nil

instance [linear_order α] : linear_order (list α) :=
linear_order_of_STO (lex (<))

--Note: this overrides an instance in core lean
instance has_le' [linear_order α] : has_le (list α) :=
preorder.to_has_le _

end list


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import topology.constructions
import topology.algebra.monoid
/-!
# Topology on lists and vectors

-/
open topological_space set filter
open_locale topological_space filter

variables {α : Type*} {β : Type*} [topological_space α] [topological_space β]

instance : topological_space (list α) :=
topological_space.mk_of_nhds (traverse nhds)

lemma nhds_list (as : list α) : 𝓝 as = traverse 𝓝 as :=
begin
  refine nhds_mk_of_nhds _ _ _ _,
  { assume l, induction l,
    case list.nil { exact le_rfl },
    case list.cons : a l ih
    { suffices : list.cons <$> pure a <*> pure l ≤ list.cons <$> 𝓝 a <*> traverse 𝓝 l,
      { simpa only [] with functor_norm using this },
      exact filter.seq_mono (filter.map_mono $ pure_le_nhds a) ih } },
  { assume l s hs,
    rcases (mem_traverse_iff _ _).1 hs with ⟨u, hu, hus⟩, clear as hs,
    have : ∃v:list (set α), l.forall₂ (λa s, is_open s ∧ a ∈ s) v ∧ sequence v ⊆ s,
    { induction hu generalizing s,
      case list.forall₂.nil : hs this
        { existsi [], simpa only [list.forall₂_nil_left_iff, exists_eq_left] },
      case list.forall₂.cons : a s as ss ht h ih t hts
      { rcases mem_nhds_iff.1 ht with ⟨u, hut, hu⟩,
        rcases ih (subset.refl _) with ⟨v, hv, hvss⟩,
        exact ⟨u::v, list.forall₂.cons hu hv,
          subset.trans (set.seq_mono (set.image_subset _ hut) hvss) hts⟩ } },
    rcases this with ⟨v, hv, hvs⟩,
    refine ⟨sequence v, mem_traverse _ _ _, hvs, _⟩,
    { exact hv.imp (assume a s ⟨hs, ha⟩, is_open.mem_nhds hs ha) },
    { assume u hu,
      have hu := (list.mem_traverse _ _).1 hu,
      have : list.forall₂ (λa s, is_open s ∧ a ∈ s) u v,
      { refine list.forall₂.flip _,
        replace hv := hv.flip,
        simp only [list.forall₂_and_left, flip] at ⊢ hv,
        exact ⟨hv.1, hu.flip⟩ },
      refine mem_of_superset _ hvs,
      exact mem_traverse _ _ (this.imp $ assume a s ⟨hs, ha⟩, is_open.mem_nhds hs ha) } }
end

@[simp] lemma nhds_nil : 𝓝 ([] : list α) = pure [] :=
by rw [nhds_list, list.traverse_nil _]; apply_instance

lemma nhds_cons (a : α) (l : list α) :
  𝓝 (a :: l) = list.cons <$> 𝓝 a <*> 𝓝 l  :=
by rw [nhds_list, list.traverse_cons _, ← nhds_list]; apply_instance

lemma list.tendsto_cons {a : α} {l : list α} :
  tendsto (λp:α×list α, list.cons p.1 p.2) (𝓝 a ×ᶠ 𝓝 l) (𝓝 (a :: l)) :=
by rw [nhds_cons, tendsto, map_prod]; exact le_rfl

lemma filter.tendsto.cons {α : Type*} {f : α → β} {g : α → list β}
  {a : _root_.filter α} {b : β} {l : list β} (hf : tendsto f a (𝓝 b)) (hg : tendsto g a (𝓝 l)) :
  tendsto (λa, list.cons (f a) (g a)) a (𝓝 (b :: l)) :=
list.tendsto_cons.comp (tendsto.prod_mk hf hg)

namespace list

lemma tendsto_cons_iff {β : Type*} {f : list α → β} {b : _root_.filter β} {a : α} {l : list α} :
  tendsto f (𝓝 (a :: l)) b ↔ tendsto (λp:α×list α, f (p.1 :: p.2)) (𝓝 a ×ᶠ 𝓝 l) b :=
have 𝓝 (a :: l) = (𝓝 a ×ᶠ 𝓝 l).map (λp:α×list α, (p.1 :: p.2)),
begin
  simp only
    [nhds_cons, filter.prod_eq, (filter.map_def _ _).symm, (filter.seq_eq_filter_seq _ _).symm],
  simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm,
end,
by rw [this, filter.tendsto_map'_iff]

lemma continuous_cons : continuous (λ x : α × list α, (x.1 :: x.2 : list α)) :=
continuous_iff_continuous_at.mpr $ λ ⟨x, y⟩, continuous_at_fst.cons continuous_at_snd

lemma tendsto_nhds {β : Type*} {f : list α → β} {r : list α → _root_.filter β}
  (h_nil : tendsto f (pure []) (r []))
  (h_cons : ∀l a, tendsto f (𝓝 l) (r l) →
    tendsto (λp:α×list α, f (p.1 :: p.2)) (𝓝 a ×ᶠ 𝓝 l) (r (a::l))) :
  ∀l, tendsto f (𝓝 l) (r l)
| []     := by rwa [nhds_nil]
| (a::l) := by rw [tendsto_cons_iff]; exact h_cons l a (tendsto_nhds l)

lemma continuous_at_length :
  ∀(l : list α), continuous_at list.length l :=
begin
  simp only [continuous_at, nhds_discrete],
  refine tendsto_nhds _ _,
  { exact tendsto_pure_pure _ _ },
  { assume l a ih,
    dsimp only [list.length],
    refine tendsto.comp (tendsto_pure_pure (λx, x + 1) _) _,
    refine tendsto.comp ih tendsto_snd }
end

lemma tendsto_insert_nth' {a : α} : ∀{n : ℕ} {l : list α},
  tendsto (λp:α×list α, insert_nth n p.1 p.2) (𝓝 a ×ᶠ 𝓝 l) (𝓝 (insert_nth n a l))
| 0     l  := tendsto_cons
| (n+1) [] := by simp
| (n+1) (a'::l) :=
  have 𝓝 a ×ᶠ 𝓝 (a' :: l) =
    (𝓝 a ×ᶠ (𝓝 a' ×ᶠ 𝓝 l)).map (λp:α×α×list α, (p.1, p.2.1 :: p.2.2)),
  begin
    simp only [nhds_cons, filter.prod_eq, ← filter.map_def, ← filter.seq_eq_filter_seq],
    simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm
  end,
  begin
    rw [this, tendsto_map'_iff],
    exact (tendsto_fst.comp tendsto_snd).cons
      ((@tendsto_insert_nth' n l).comp $ tendsto_fst.prod_mk $ tendsto_snd.comp tendsto_snd)
  end

lemma tendsto_insert_nth {β} {n : ℕ} {a : α} {l : list α} {f : β → α} {g : β → list α}
  {b : _root_.filter β} (hf : tendsto f b (𝓝 a)) (hg : tendsto g b (𝓝 l)) :
  tendsto (λb:β, insert_nth n (f b) (g b)) b (𝓝 (insert_nth n a l)) :=
tendsto_insert_nth'.comp (tendsto.prod_mk hf hg)

lemma continuous_insert_nth {n : ℕ} : continuous (λp:α×list α, insert_nth n p.1 p.2) :=
continuous_iff_continuous_at.mpr $
  assume ⟨a, l⟩, by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth'

lemma tendsto_remove_nth : ∀{n : ℕ} {l : list α},
  tendsto (λl, remove_nth l n) (𝓝 l) (𝓝 (remove_nth l n))
| _ []      := by rw [nhds_nil]; exact tendsto_pure_nhds _ _
| 0 (a::l) := by rw [tendsto_cons_iff]; exact tendsto_snd
| (n+1) (a::l) :=
  begin
    rw [tendsto_cons_iff],
    dsimp [remove_nth],
    exact tendsto_fst.cons ((@tendsto_remove_nth n l).comp tendsto_snd)
  end

lemma continuous_remove_nth {n : ℕ} : continuous (λl : list α, remove_nth l n) :=
continuous_iff_continuous_at.mpr $ assume a, tendsto_remove_nth

@[to_additive]
lemma tendsto_prod [monoid α] [has_continuous_mul α] {l : list α} :
  tendsto list.prod (𝓝 l) (𝓝 l.prod) :=
begin
  induction l with x l ih,
  { simp [nhds_nil, mem_of_mem_nhds, tendsto_pure_left] {contextual := tt} },
  simp_rw [tendsto_cons_iff, prod_cons],
  have := continuous_iff_continuous_at.mp continuous_mul (x, l.prod),
  rw [continuous_at, nhds_prod_eq] at this,
  exact this.comp (tendsto_id.prod_map ih)
end

@[to_additive]
lemma continuous_prod [monoid α] [has_continuous_mul α] : continuous (prod : list α → α) :=
continuous_iff_continuous_at.mpr $ λ l, tendsto_prod

end list

namespace vector
open list

instance (n : ℕ) : topological_space (vector α n) :=
by unfold vector; apply_instance

lemma tendsto_insert_nth
  {n : ℕ} {i : fin (n+1)} {a:α} :
  ∀{l:vector α n}, tendsto (λp:α×vector α n, insert_nth p.1 i p.2)
    (𝓝 a ×ᶠ 𝓝 l) (𝓝 (insert_nth a i l))
| ⟨l, hl⟩ :=
begin
  rw [insert_nth, tendsto_subtype_rng],
  simp [insert_nth_val],
  exact list.tendsto_insert_nth tendsto_fst (tendsto.comp continuous_at_subtype_coe tendsto_snd : _)
end

lemma continuous_insert_nth' {n : ℕ} {i : fin (n+1)} :
  continuous (λp:α×vector α n, insert_nth p.1 i p.2) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩,
  by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth

lemma continuous_insert_nth {n : ℕ} {i : fin (n+1)}
  {f : β → α} {g : β → vector α n} (hf : continuous f) (hg : continuous g) :
  continuous (λb, insert_nth (f b) i (g b)) :=
continuous_insert_nth'.comp (hf.prod_mk hg : _)

lemma continuous_at_remove_nth {n : ℕ} {i : fin (n+1)} :
  ∀{l:vector α (n+1)}, continuous_at (remove_nth i) l
| ⟨l, hl⟩ :=
--  ∀{l:vector α (n+1)}, tendsto (remove_nth i) (𝓝 l) (𝓝 (remove_nth i l))
--| ⟨l, hl⟩ :=
begin
  rw [continuous_at, remove_nth, tendsto_subtype_rng],
  simp only [← subtype.val_eq_coe, vector.remove_nth_val],
  exact tendsto.comp list.tendsto_remove_nth continuous_at_subtype_coe,
end

lemma continuous_remove_nth {n : ℕ} {i : fin (n+1)} :
  continuous (remove_nth i : vector α (n+1) → vector α n) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩, continuous_at_remove_nth

end vector


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.asymptotics.asymptotics

/-!
# Salem-Spencer sets and Roth numbers

This file defines Salem-Spencer sets and the Roth number of a set.

A Salem-Spencer set is a set without arithmetic progressions of length `3`. Equivalently, the
average of any two distinct elements is not in the set.

The Roth number of a finset is the size of its biggest Salem-Spencer subset. This is a more general
definition than the one often found in mathematical litterature, where the `n`-th Roth number is
the size of the biggest Salem-Spencer subset of `{0, ..., n - 1}`.

## Main declarations

* `mul_salem_spencer`: Predicate for a set to be multiplicative Salem-Spencer.
* `add_salem_spencer`: Predicate for a set to be additive Salem-Spencer.
* `mul_roth_number`: The multiplicative Roth number of a finset.
* `add_roth_number`: The additive Roth number of a finset.
* `roth_number_nat`: The Roth number of a natural. This corresponds to
  `add_roth_number (finset.range n)`.

## TODO

Can `add_salem_spencer_iff_eq_right` be made more general?

## Tags

Salem-Spencer, Roth, arithmetic progression, average, three-free
-/

open finset nat

variables {α β : Type*}

section salem_spencer
section monoid
variables [monoid α] [monoid β] (s t : set α)

/-- A multiplicative Salem-Spencer, aka non averaging, set `s` in a monoid is a set such that the
multiplicative average of any two distinct elements is not in the set. -/
@[to_additive "A Salem-Spencer, aka non averaging, set `s` in an additive monoid
is a set such that the average of any two distinct elements is not in the set."]
def mul_salem_spencer : Prop := ∀ ⦃a b c⦄, a ∈ s → b ∈ s → c ∈ s → a * b = c * c → a = b

/-- Whether a given finset is Salem-Spencer is decidable. -/
@[to_additive]
instance {α : Type*} [decidable_eq α] [monoid α] {s : finset α} :
  decidable (mul_salem_spencer (s : set α)) :=
decidable_of_iff (∀ a ∈ s, ∀ b ∈ s, ∀ c ∈ s, a * b = c * c → a = b)
  ⟨λ h a b c ha hb hc, h a ha b hb c hc, λ h a ha b hb c hc, h ha hb hc⟩

variables {s t}

@[to_additive]
lemma mul_salem_spencer.mono (h : t ⊆ s) (hs : mul_salem_spencer s) : mul_salem_spencer t :=
λ a b c ha hb hc, hs (h ha) (h hb) (h hc)

@[simp, to_additive]
lemma mul_salem_spencer_empty : mul_salem_spencer (∅ : set α) := λ a _ _ ha, ha.elim

@[to_additive]
lemma set.subsingleton.mul_salem_spencer (hs : s.subsingleton) : mul_salem_spencer s :=
λ a b _ ha hb _ _, hs ha hb

@[simp, to_additive]
lemma mul_salem_spencer_singleton (a : α) : mul_salem_spencer ({a} : set α) :=
set.subsingleton_singleton.mul_salem_spencer

@[to_additive]
lemma mul_salem_spencer.prod {t : set β} (hs : mul_salem_spencer s) (ht : mul_salem_spencer t) :
  mul_salem_spencer (s ×ˢ t) :=
λ a b c ha hb hc h,
  prod.ext (hs ha.1 hb.1 hc.1 (prod.ext_iff.1 h).1) (ht ha.2 hb.2 hc.2 (prod.ext_iff.1 h).2)

@[to_additive]
lemma mul_salem_spencer_pi {ι : Type*} {α : ι → Type*} [Π i, monoid (α i)] {s : Π i, set (α i)}
  (hs : ∀ i, mul_salem_spencer (s i)) :
  mul_salem_spencer ((set.univ : set ι).pi s) :=
λ a b c ha hb hc h, funext $ λ i, hs i (ha i trivial) (hb i trivial) (hc i trivial) $ congr_fun h i

end monoid

section cancel_comm_monoid
variables [cancel_comm_monoid α] {s : set α} {a : α}

@[to_additive]
lemma mul_salem_spencer_insert :
  mul_salem_spencer (insert a s) ↔ mul_salem_spencer s ∧
    (∀ ⦃b c⦄, b ∈ s → c ∈ s → a * b = c * c → a = b) ∧
    ∀ ⦃b c⦄, b ∈ s → c ∈ s → b * c = a * a → b = c :=
begin
  refine ⟨λ hs, ⟨hs.mono (set.subset_insert _ _),
    λ b c hb hc, hs (or.inl rfl) (or.inr hb) (or.inr hc),
    λ b c hb hc, hs (or.inr hb) (or.inr hc) (or.inl rfl)⟩, _⟩,
  rintro ⟨hs, ha, ha'⟩ b c d hb hc hd h,
  rw set.mem_insert_iff at hb hc hd,
  obtain rfl | hb := hb;
  obtain rfl | hc := hc,
  { refl },
  all_goals { obtain rfl | hd := hd },
  { exact (mul_left_cancel h).symm },
  { exact ha hc hd h },
  { exact mul_right_cancel h },
  { exact (ha hb hd $ (mul_comm _ _).trans h).symm },
  { exact ha' hb hc h },
  { exact hs hb hc hd h }
end

@[simp, to_additive]
lemma mul_salem_spencer_pair (a b : α) : mul_salem_spencer ({a, b} : set α) :=
begin
  rw mul_salem_spencer_insert,
  refine ⟨mul_salem_spencer_singleton _, _, _⟩,
  { rintro c d (rfl : c = b) (rfl : d = c),
    exact mul_right_cancel },
  { rintro c d (rfl : c = b) (rfl : d = c) _,
    refl }
end

@[to_additive]
lemma mul_salem_spencer.mul_left (hs : mul_salem_spencer s) : mul_salem_spencer ((*) a '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm a d] at h,
  rw hs hb hc hd (mul_left_cancel h),
end

@[to_additive]
lemma mul_salem_spencer.mul_right (hs : mul_salem_spencer s) : mul_salem_spencer ((* a) '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm d] at h,
  rw hs hb hc hd (mul_right_cancel h),
end

@[to_additive]
lemma mul_salem_spencer_mul_left_iff : mul_salem_spencer ((*) a '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_left_cancel (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc)
  (set.mem_image_of_mem _ hd) $ by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  mul_salem_spencer.mul_left⟩

@[to_additive]
lemma mul_salem_spencer_mul_right_iff :
  mul_salem_spencer ((* a) '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_right_cancel (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc)
  (set.mem_image_of_mem _ hd) $ by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  mul_salem_spencer.mul_right⟩

end cancel_comm_monoid

section ordered_cancel_comm_monoid
variables [ordered_cancel_comm_monoid α] {s : set α} {a : α}

@[to_additive]
lemma mul_salem_spencer_insert_of_lt (hs : ∀ i ∈ s, i < a) :
  mul_salem_spencer (insert a s) ↔ mul_salem_spencer s ∧
    ∀ ⦃b c⦄, b ∈ s → c ∈ s → a * b = c * c → a = b :=
begin
  refine mul_salem_spencer_insert.trans _,
  rw ←and_assoc,
  exact and_iff_left (λ b c hb hc h, ((mul_lt_mul''' (hs _ hb) (hs _ hc)).ne h).elim),
end

end ordered_cancel_comm_monoid

section cancel_comm_monoid_with_zero
variables [cancel_comm_monoid_with_zero α] [no_zero_divisors α] {s : set α} {a : α}

lemma mul_salem_spencer.mul_left₀ (hs : mul_salem_spencer s) (ha : a ≠ 0) :
  mul_salem_spencer ((*) a '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm a d] at h,
  rw hs hb hc hd (mul_left_cancel₀ (mul_ne_zero ha ha) h),
end

lemma mul_salem_spencer.mul_right₀ (hs : mul_salem_spencer s) (ha : a ≠ 0) :
  mul_salem_spencer ((* a) '' s) :=
begin
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h,
  rw [mul_mul_mul_comm, mul_mul_mul_comm d] at h,
  rw hs hb hc hd (mul_right_cancel₀ (mul_ne_zero ha ha) h),
end

lemma mul_salem_spencer_mul_left_iff₀ (ha : a ≠ 0) :
  mul_salem_spencer ((*) a '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_left_cancel₀ ha
  (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc) (set.mem_image_of_mem _ hd) $
  by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  λ hs, hs.mul_left₀ ha⟩

lemma mul_salem_spencer_mul_right_iff₀ (ha : a ≠ 0) :
  mul_salem_spencer ((* a) '' s) ↔ mul_salem_spencer s :=
⟨λ hs b c d hb hc hd h, mul_right_cancel₀ ha
  (hs (set.mem_image_of_mem _ hb) (set.mem_image_of_mem _ hc) (set.mem_image_of_mem _ hd) $
  by rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
  λ hs, hs.mul_right₀ ha⟩

end cancel_comm_monoid_with_zero

section nat

lemma add_salem_spencer_iff_eq_right {s : set ℕ} :
  add_salem_spencer s ↔ ∀ ⦃a b c⦄, a ∈ s → b ∈ s → c ∈ s → a + b = c + c → a = c :=
begin
  refine forall₄_congr (λ a b c _, forall₃_congr $ λ _ _ habc, ⟨_, _⟩),
  { rintro rfl,
    simp_rw ←two_mul at habc,
    exact mul_left_cancel₀ two_ne_zero habc },
  { rintro rfl,
    exact (add_left_cancel habc).symm }
end

end nat
end salem_spencer

section roth_number
variables [decidable_eq α]

section monoid
variables [monoid α] [decidable_eq β] [monoid β] (s t : finset α)

/-- The multiplicative Roth number of a finset is the cardinality of its biggest multiplicative
Salem-Spencer subset. -/
@[to_additive "The additive Roth number of a finset is the cardinality of its biggest additive
Salem-Spencer subset. The usual Roth number corresponds to `roth_number (finset.range n)`, see
`roth_number_nat`. "]
def mul_roth_number : finset α →o ℕ :=
⟨λ s, nat.find_greatest (λ m, ∃ t ⊆ s, t.card = m ∧ mul_salem_spencer (t : set α)) s.card,
begin
  rintro t u htu,
  refine nat.find_greatest_mono (λ m, _) (card_le_of_subset htu),
  rintro ⟨v, hvt, hv⟩,
  exact ⟨v, hvt.trans htu, hv⟩,
end⟩

@[to_additive]
lemma mul_roth_number_le : mul_roth_number s ≤ s.card := by convert nat.find_greatest_le s.card

@[to_additive]
lemma mul_roth_number_spec : ∃ t ⊆ s, t.card = mul_roth_number s ∧ mul_salem_spencer (t : set α) :=
@nat.find_greatest_spec _ (λ m, ∃ t ⊆ s, t.card = m ∧ mul_salem_spencer (t : set α)) _ _
  (nat.zero_le _) ⟨∅, empty_subset _, card_empty, mul_salem_spencer_empty⟩

variables {s t} {n : ℕ}

@[to_additive]
lemma mul_salem_spencer.le_mul_roth_number (hs : mul_salem_spencer (s : set α)) (h : s ⊆ t) :
  s.card ≤ mul_roth_number t :=
le_find_greatest (card_le_of_subset h) ⟨s, h, rfl, hs⟩

@[to_additive]
lemma mul_salem_spencer.roth_number_eq (hs : mul_salem_spencer (s : set α)) :
  mul_roth_number s = s.card :=
(mul_roth_number_le _).antisymm $ hs.le_mul_roth_number $ subset.refl _

@[simp, to_additive]
lemma mul_roth_number_empty : mul_roth_number (∅ : finset α) = 0 :=
nat.eq_zero_of_le_zero $ (mul_roth_number_le _).trans card_empty.le

@[simp, to_additive]
lemma mul_roth_number_singleton (a : α) : mul_roth_number ({a} : finset α) = 1 :=
begin
  convert mul_salem_spencer.roth_number_eq _,
  rw coe_singleton,
  exact mul_salem_spencer_singleton a,
end

@[to_additive]
lemma mul_roth_number_union_le (s t : finset α) :
  mul_roth_number (s ∪ t) ≤ mul_roth_number s + mul_roth_number t :=
let ⟨u, hus, hcard, hu⟩ := mul_roth_number_spec (s ∪ t) in
calc
  mul_roth_number (s ∪ t)
      = u.card : hcard.symm
  ... = (u ∩ s ∪ u ∩ t).card
      : by rw [←inter_distrib_left, (inter_eq_left_iff_subset _ _).2 hus]
  ... ≤ (u ∩ s).card + (u ∩ t).card : card_union_le _ _
  ... ≤ mul_roth_number s + mul_roth_number t
      : add_le_add ((hu.mono $ inter_subset_left _ _).le_mul_roth_number $ inter_subset_right _ _)
          ((hu.mono $ inter_subset_left _ _).le_mul_roth_number $ inter_subset_right _ _)

@[to_additive]
lemma le_mul_roth_number_product (s : finset α) (t : finset β) :
  mul_roth_number s * mul_roth_number t ≤ mul_roth_number (s.product t) :=
begin
  obtain ⟨u, hus, hucard, hu⟩ := mul_roth_number_spec s,
  obtain ⟨v, hvt, hvcard, hv⟩ := mul_roth_number_spec t,
  rw [←hucard, ←hvcard, ←card_product],
  refine mul_salem_spencer.le_mul_roth_number _ (product_subset_product hus hvt),
  rw coe_product,
  exact hu.prod hv,
end

@[to_additive]
lemma mul_roth_number_lt_of_forall_not_mul_salem_spencer
  (h : ∀ t ∈ powerset_len n s, ¬mul_salem_spencer ((t : finset α) : set α)) :
  mul_roth_number s < n :=
begin
  obtain ⟨t, hts, hcard, ht⟩ := mul_roth_number_spec s,
  rw [←hcard, ←not_le],
  intro hn,
  obtain ⟨u, hut, rfl⟩ := exists_smaller_set t n hn,
  exact h _ (mem_powerset_len.2 ⟨hut.trans hts, rfl⟩) (ht.mono hut),
end

end monoid

section cancel_comm_monoid
variables [cancel_comm_monoid α] (s : finset α) (a : α)

@[simp, to_additive] lemma mul_roth_number_map_mul_left :
  mul_roth_number (s.map $ mul_left_embedding a) = mul_roth_number s :=
begin
  refine le_antisymm _ _,
  { obtain ⟨u, hus, hcard, hu⟩ := mul_roth_number_spec (s.map $ mul_left_embedding a),
    rw subset_map_iff at hus,
    obtain ⟨u, hus, rfl⟩ := hus,
    rw coe_map at hu,
    rw [←hcard, card_map],
    exact (mul_salem_spencer_mul_left_iff.1 hu).le_mul_roth_number hus },
  { obtain ⟨u, hus, hcard, hu⟩ := mul_roth_number_spec s,
    have h : mul_salem_spencer (u.map $ mul_left_embedding a : set α),
    { rw coe_map,
      exact hu.mul_left },
    convert h.le_mul_roth_number (map_subset_map.2 hus),
    rw [card_map, hcard] }
end

@[simp, to_additive] lemma mul_roth_number_map_mul_right :
  mul_roth_number (s.map $ mul_right_embedding a) = mul_roth_number s :=
by rw [←mul_left_embedding_eq_mul_right_embedding, mul_roth_number_map_mul_left s a]

end cancel_comm_monoid
end roth_number

section roth_number_nat
variables {s : finset ℕ} {k n : ℕ}

/-- The Roth number of a natural `N` is the largest integer `m` for which there is a subset of
`range N` of size `m` with no arithmetic progression of length 3.
Trivially, `roth_number N ≤ N`, but Roth's theorem (proved in 1953) shows that
`roth_number N = o(N)` and the construction by Behrend gives a lower bound of the form
`N * exp(-C sqrt(log(N))) ≤ roth_number N`.
A significant refinement of Roth's theorem by Bloom and Sisask announced in 2020 gives
`roth_number N = O(N / (log N)^(1+c))` for an absolute constant `c`. -/
def roth_number_nat : ℕ →o ℕ :=
⟨λ n, add_roth_number (range n), add_roth_number.mono.comp range_mono⟩

lemma roth_number_nat_def (n : ℕ) : roth_number_nat n = add_roth_number (range n) := rfl

lemma roth_number_nat_le (N : ℕ) : roth_number_nat N ≤ N :=
(add_roth_number_le _).trans (card_range _).le

lemma roth_number_nat_spec (n : ℕ) :
  ∃ t ⊆ range n, t.card = roth_number_nat n ∧ add_salem_spencer (t : set ℕ) :=
add_roth_number_spec _

/-- A verbose specialization of `add_salem_spencer.le_add_roth_number`, sometimes convenient in
practice. -/
lemma add_salem_spencer.le_roth_number_nat (s : finset ℕ) (hs : add_salem_spencer (s : set ℕ))
  (hsn : ∀ x ∈ s, x < n) (hsk : s.card = k) :
  k ≤ roth_number_nat n :=
hsk.ge.trans $ hs.le_add_roth_number $ λ x hx, mem_range.2 $ hsn x hx

/-- The Roth number is a subadditive function. Note that by Fekete's lemma this shows that
the limit `roth_number N / N` exists, but Roth's theorem gives the stronger result that this
limit is actually `0`. -/
lemma roth_number_nat_add_le (M N : ℕ) :
  roth_number_nat (M + N) ≤ roth_number_nat M + roth_number_nat N :=
begin
  simp_rw roth_number_nat_def,
  rw [range_add_eq_union, ←add_roth_number_map_add_left (range N) M],
  exact add_roth_number_union_le _ _,
end

@[simp] lemma roth_number_nat_zero : roth_number_nat 0 = 0 := rfl

lemma add_roth_number_Ico (a b : ℕ) : add_roth_number (Ico a b) = roth_number_nat (b - a) :=
begin
  obtain h | h := le_total b a,
  { rw [tsub_eq_zero_of_le h, Ico_eq_empty_of_le h, roth_number_nat_zero, add_roth_number_empty] },
  convert add_roth_number_map_add_left _ a,
  rw [range_eq_Ico, map_eq_image],
  convert (image_add_left_Ico 0 (b - a) _).symm,
  exact (add_tsub_cancel_of_le h).symm,
end

open asymptotics filter

lemma roth_number_nat_is_O_with_id :
  is_O_with 1 (λ N, (roth_number_nat N : ℝ)) (λ N, (N : ℝ)) at_top :=
is_O_with.of_bound $ by simpa only [one_mul, real.norm_coe_nat, nat.cast_le]
  using eventually_of_forall roth_number_nat_le

/-- The Roth number has the trivial bound `roth_number N = O(N)`. -/
lemma roth_number_nat_is_O_id : is_O (λ N, (roth_number_nat N : ℝ)) (λ N, (N : ℝ)) at_top :=
roth_number_nat_is_O_with_id.is_O

end roth_number_nat


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel

! This file was ported from Lean 3 source module algebra.homology.exact
! leanprover-community/mathlib commit 3feb151caefe53df080ca6ca67a0c6685cfd1b82
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Homology.ImageToKernel

/-!
# Exact sequences

In a category with zero morphisms, images, and equalizers we say that `f : A ⟶ B` and `g : B ⟶ C`
are exact if `f ≫ g = 0` and the natural map `image f ⟶ kernel g` is an epimorphism.

In any preadditive category this is equivalent to the homology at `B` vanishing.

However in general it is weaker than other reasonable definitions of exactness,
particularly that
1. the inclusion map `image.ι f` is a kernel of `g` or
2. `image f ⟶ kernel g` is an isomorphism or
3. `image_subobject f = kernel_subobject f`.
However when the category is abelian, these all become equivalent;
these results are found in `category_theory/abelian/exact.lean`.

# Main results
* Suppose that cokernels exist and that `f` and `g` are exact.
  If `s` is any kernel fork over `g` and `t` is any cokernel cofork over `f`,
  then `fork.ι s ≫ cofork.π t = 0`.
* Precomposing the first morphism with an epimorphism retains exactness.
  Postcomposing the second morphism with a monomorphism retains exactness.
* If `f` and `g` are exact and `i` is an isomorphism,
  then `f ≫ i.hom` and `i.inv ≫ g` are also exact.

# Future work
* Short exact sequences, split exact sequences, the splitting lemma (maybe only for abelian
  categories?)
* Two adjacent maps in a chain complex are exact iff the homology vanishes

-/

universe v v₂ u u₂

open CategoryTheory

open CategoryTheory.Limits

variable {V : Type u} [Category.{v} V]

variable [HasImages V]

namespace CategoryTheory

-- One nice feature of this definition is that we have
-- `epi f → exact g h → exact (f ≫ g) h` and `exact f g → mono h → exact f (g ≫ h)`,
-- which do not necessarily hold in a non-abelian category with the usual definition of `exact`.
/-- Two morphisms `f : A ⟶ B`, `g : B ⟶ C` are called exact if `w : f ≫ g = 0` and the natural map
`image_to_kernel f g w : image_subobject f ⟶ kernel_subobject g` is an epimorphism.

In any preadditive category, this is equivalent to `w : f ≫ g = 0` and `homology f g w ≅ 0`.

In an abelian category, this is equivalent to `image_to_kernel f g w` being an isomorphism,
and hence equivalent to the usual definition,
`image_subobject f = kernel_subobject g`.
-/
structure Exact [HasZeroMorphisms V] [HasKernels V] {A B C : V} (f : A ⟶ B) (g : B ⟶ C) : Prop where
  w : f ≫ g = 0
  Epi : Epi (imageToKernel f g w)
#align category_theory.exact CategoryTheory.Exact

-- This works as an instance even though `exact` itself is not a class, as long as the goal is
-- literally of the form `epi (image_to_kernel f g h.w)` (where `h : exact f g`). If the proof of
-- `f ≫ g = 0` looks different, we are out of luck and have to add the instance by hand.
attribute [instance] exact.epi

attribute [reassoc.1] exact.w

section

variable [HasZeroObject V] [Preadditive V] [HasKernels V] [HasCokernels V]

open ZeroObject

/-- In any preadditive category,
composable morphisms `f g` are exact iff they compose to zero and the homology vanishes.
-/
theorem Preadditive.exact_iff_homology_zero {A B C : V} (f : A ⟶ B) (g : B ⟶ C) :
    Exact f g ↔ ∃ w : f ≫ g = 0, Nonempty (homology f g w ≅ 0) :=
  ⟨fun h => ⟨h.w, ⟨cokernel.ofEpi _⟩⟩, fun h =>
    by
    obtain ⟨w, ⟨i⟩⟩ := h
    exact ⟨w, preadditive.epi_of_cokernel_zero ((cancel_mono i.hom).mp (by ext))⟩⟩
#align category_theory.preadditive.exact_iff_homology_zero CategoryTheory.Preadditive.exact_iff_homology_zero

theorem Preadditive.exact_of_iso_of_exact {A₁ B₁ C₁ A₂ B₂ C₂ : V} (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁)
    (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂) (α : Arrow.mk f₁ ≅ Arrow.mk f₂) (β : Arrow.mk g₁ ≅ Arrow.mk g₂)
    (p : α.Hom.right = β.Hom.left) (h : Exact f₁ g₁) : Exact f₂ g₂ :=
  by
  rw [preadditive.exact_iff_homology_zero] at h⊢
  rcases h with ⟨w₁, ⟨i⟩⟩
  suffices w₂ : f₂ ≫ g₂ = 0; exact ⟨w₂, ⟨(homology.mapIso w₁ w₂ α β p).symm.trans i⟩⟩
  rw [← cancel_epi α.hom.left, ← cancel_mono β.inv.right, comp_zero, zero_comp, ← w₁]
  simp only [← arrow.mk_hom f₁, ← arrow.left_hom_inv_right α.hom, ← arrow.mk_hom g₁, ←
    arrow.left_hom_inv_right β.hom, p]
  simp only [arrow.mk_hom, is_iso.inv_hom_id_assoc, category.assoc, ← arrow.inv_right,
    is_iso.iso.inv_hom]
#align category_theory.preadditive.exact_of_iso_of_exact CategoryTheory.Preadditive.exact_of_iso_of_exact

/-- A reformulation of `preadditive.exact_of_iso_of_exact` that does not involve the arrow
category. -/
theorem Preadditive.exact_of_iso_of_exact' {A₁ B₁ C₁ A₂ B₂ C₂ : V} (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁)
    (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂) (α : A₁ ≅ A₂) (β : B₁ ≅ B₂) (γ : C₁ ≅ C₂)
    (hsq₁ : α.Hom ≫ f₂ = f₁ ≫ β.Hom) (hsq₂ : β.Hom ≫ g₂ = g₁ ≫ γ.Hom) (h : Exact f₁ g₁) :
    Exact f₂ g₂ :=
  Preadditive.exact_of_iso_of_exact f₁ g₁ f₂ g₂ (Arrow.isoMk α β hsq₁) (Arrow.isoMk β γ hsq₂) rfl h
#align category_theory.preadditive.exact_of_iso_of_exact' CategoryTheory.Preadditive.exact_of_iso_of_exact'

theorem Preadditive.exact_iff_exact_of_iso {A₁ B₁ C₁ A₂ B₂ C₂ : V} (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁)
    (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂) (α : Arrow.mk f₁ ≅ Arrow.mk f₂) (β : Arrow.mk g₁ ≅ Arrow.mk g₂)
    (p : α.Hom.right = β.Hom.left) : Exact f₁ g₁ ↔ Exact f₂ g₂ :=
  ⟨Preadditive.exact_of_iso_of_exact _ _ _ _ _ _ p,
    Preadditive.exact_of_iso_of_exact _ _ _ _ α.symm β.symm
      (by
        rw [← cancel_mono α.hom.right]
        simp only [iso.symm_hom, ← comma.comp_right, α.inv_hom_id]
        simp only [p, ← comma.comp_left, arrow.id_right, arrow.id_left, iso.inv_hom_id]
        rfl)⟩
#align category_theory.preadditive.exact_iff_exact_of_iso CategoryTheory.Preadditive.exact_iff_exact_of_iso

end

section

variable [HasZeroMorphisms V] [HasKernels V]

theorem comp_eq_zero_of_image_eq_kernel {A B C : V} (f : A ⟶ B) (g : B ⟶ C)
    (p : imageSubobject f = kernelSubobject g) : f ≫ g = 0 :=
  by
  rw [← image_subobject_arrow_comp f, category.assoc]
  convert comp_zero
  rw [p]
  simp
#align category_theory.comp_eq_zero_of_image_eq_kernel CategoryTheory.comp_eq_zero_of_image_eq_kernel

theorem imageToKernel_isIso_of_image_eq_kernel {A B C : V} (f : A ⟶ B) (g : B ⟶ C)
    (p : imageSubobject f = kernelSubobject g) :
    IsIso (imageToKernel f g (comp_eq_zero_of_image_eq_kernel f g p)) :=
  by
  refine' ⟨⟨subobject.of_le _ _ p.ge, _⟩⟩
  dsimp [imageToKernel]
  simp only [subobject.of_le_comp_of_le, subobject.of_le_refl]
  simp
#align category_theory.image_to_kernel_is_iso_of_image_eq_kernel CategoryTheory.imageToKernel_isIso_of_image_eq_kernel

-- We'll prove the converse later, when `V` is abelian.
theorem exact_of_image_eq_kernel {A B C : V} (f : A ⟶ B) (g : B ⟶ C)
    (p : imageSubobject f = kernelSubobject g) : Exact f g :=
  { w := comp_eq_zero_of_image_eq_kernel f g p
    Epi := by
      haveI := image_to_kernel_is_iso_of_image_eq_kernel f g p
      infer_instance }
#align category_theory.exact_of_image_eq_kernel CategoryTheory.exact_of_image_eq_kernel

end

variable {A B C D : V} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}

attribute [local instance] epi_comp

section

variable [HasZeroMorphisms V] [HasEqualizers V]

theorem exact_comp_hom_inv_comp (i : B ≅ D) (h : Exact f g) : Exact (f ≫ i.Hom) (i.inv ≫ g) :=
  by
  refine' ⟨by simp [h.w], _⟩
  rw [imageToKernel_comp_hom_inv_comp]
  haveI := h.epi
  infer_instance
#align category_theory.exact_comp_hom_inv_comp CategoryTheory.exact_comp_hom_inv_comp

theorem exact_comp_inv_hom_comp (i : D ≅ B) (h : Exact f g) : Exact (f ≫ i.inv) (i.Hom ≫ g) :=
  exact_comp_hom_inv_comp i.symm h
#align category_theory.exact_comp_inv_hom_comp CategoryTheory.exact_comp_inv_hom_comp

theorem exact_comp_hom_inv_comp_iff (i : B ≅ D) : Exact (f ≫ i.Hom) (i.inv ≫ g) ↔ Exact f g :=
  ⟨fun h => by simpa using exact_comp_inv_hom_comp i h, exact_comp_hom_inv_comp i⟩
#align category_theory.exact_comp_hom_inv_comp_iff CategoryTheory.exact_comp_hom_inv_comp_iff

theorem exact_epi_comp (hgh : Exact g h) [Epi f] : Exact (f ≫ g) h :=
  by
  refine' ⟨by simp [hgh.w], _⟩
  rw [imageToKernel_comp_left]
  infer_instance
#align category_theory.exact_epi_comp CategoryTheory.exact_epi_comp

@[simp]
theorem exact_iso_comp [IsIso f] : Exact (f ≫ g) h ↔ Exact g h :=
  ⟨fun w => by
    rw [← is_iso.inv_hom_id_assoc f g]
    exact exact_epi_comp w, fun w => exact_epi_comp w⟩
#align category_theory.exact_iso_comp CategoryTheory.exact_iso_comp

theorem exact_comp_mono (hfg : Exact f g) [Mono h] : Exact f (g ≫ h) :=
  by
  refine' ⟨by simp [hfg.w_assoc], _⟩
  rw [imageToKernel_comp_right f g h hfg.w]
  infer_instance
#align category_theory.exact_comp_mono CategoryTheory.exact_comp_mono

/-- The dual of this lemma is only true when `V` is abelian, see `abelian.exact_epi_comp_iff`. -/
theorem exact_comp_mono_iff [Mono h] : Exact f (g ≫ h) ↔ Exact f g :=
  by
  refine'
    ⟨fun hfg => ⟨zero_of_comp_mono h (by rw [category.assoc, hfg.1]), _⟩, fun h =>
      exact_comp_mono h⟩
  rw [← (iso.eq_comp_inv _).1 (imageToKernel_comp_mono _ _ h hfg.1)]
  haveI := hfg.2; infer_instance
#align category_theory.exact_comp_mono_iff CategoryTheory.exact_comp_mono_iff

@[simp]
theorem exact_comp_iso [IsIso h] : Exact f (g ≫ h) ↔ Exact f g :=
  exact_comp_mono_iff
#align category_theory.exact_comp_iso CategoryTheory.exact_comp_iso

theorem exact_kernelSubobject_arrow : Exact (kernelSubobject f).arrow f :=
  by
  refine' ⟨by simp, _⟩
  apply @is_iso.epi_of_iso _ _ _ _ _ _
  exact
    ⟨⟨factor_thru_image_subobject _, by
        ext
        simp, by
        ext
        simp⟩⟩
#align category_theory.exact_kernel_subobject_arrow CategoryTheory.exact_kernelSubobject_arrow

theorem exact_kernel_ι : Exact (kernel.ι f) f :=
  by
  rw [← kernel_subobject_arrow', exact_iso_comp]
  exact exact_kernel_subobject_arrow
#align category_theory.exact_kernel_ι CategoryTheory.exact_kernel_ι

instance (h : Exact f g) : Epi (factorThruKernelSubobject g f h.w) :=
  by
  rw [← factorThruImageSubobject_comp_imageToKernel]
  apply epi_comp

instance (h : Exact f g) : Epi (kernel.lift g f h.w) :=
  by
  rw [← factor_thru_kernel_subobject_comp_kernel_subobject_iso]
  apply epi_comp

variable (A)

theorem kernelSubobject_arrow_eq_zero_of_exact_zero_left (h : Exact (0 : A ⟶ B) g) :
    (kernelSubobject g).arrow = 0 :=
  by
  rw [← cancel_epi (imageToKernel (0 : A ⟶ B) g h.w), ←
    cancel_epi (factor_thru_image_subobject (0 : A ⟶ B))]
  simp
#align category_theory.kernel_subobject_arrow_eq_zero_of_exact_zero_left CategoryTheory.kernelSubobject_arrow_eq_zero_of_exact_zero_left

theorem kernel_ι_eq_zero_of_exact_zero_left (h : Exact (0 : A ⟶ B) g) : kernel.ι g = 0 :=
  by
  rw [← kernel_subobject_arrow']
  simp [kernel_subobject_arrow_eq_zero_of_exact_zero_left A h]
#align category_theory.kernel_ι_eq_zero_of_exact_zero_left CategoryTheory.kernel_ι_eq_zero_of_exact_zero_left

theorem exact_zero_left_of_mono [HasZeroObject V] [Mono g] : Exact (0 : A ⟶ B) g :=
  ⟨by simp, imageToKernel_epi_of_zero_of_mono _⟩
#align category_theory.exact_zero_left_of_mono CategoryTheory.exact_zero_left_of_mono

end

section HasCokernels

variable [HasZeroMorphisms V] [HasEqualizers V] [HasCokernels V] (f g)

@[simp, reassoc.1]
theorem kernel_comp_cokernel (h : Exact f g) : kernel.ι g ≫ cokernel.π f = 0 :=
  by
  rw [← kernel_subobject_arrow', category.assoc]
  convert comp_zero
  apply zero_of_epi_comp (imageToKernel f g h.w) _
  rw [imageToKernel_arrow_assoc, ← image_subobject_arrow, category.assoc, ← iso.eq_inv_comp]
  ext
  simp
#align category_theory.kernel_comp_cokernel CategoryTheory.kernel_comp_cokernel

theorem comp_eq_zero_of_exact (h : Exact f g) {X Y : V} {ι : X ⟶ B} (hι : ι ≫ g = 0) {π : B ⟶ Y}
    (hπ : f ≫ π = 0) : ι ≫ π = 0 := by
  rw [← kernel.lift_ι _ _ hι, ← cokernel.π_desc _ _ hπ, category.assoc,
    kernel_comp_cokernel_assoc _ _ h, zero_comp, comp_zero]
#align category_theory.comp_eq_zero_of_exact CategoryTheory.comp_eq_zero_of_exact

@[simp, reassoc.1]
theorem fork_ι_comp_cofork_π (h : Exact f g) (s : KernelFork g) (t : CokernelCofork f) :
    Fork.ι s ≫ Cofork.π t = 0 :=
  comp_eq_zero_of_exact f g h (KernelFork.condition s) (CokernelCofork.condition t)
#align category_theory.fork_ι_comp_cofork_π CategoryTheory.fork_ι_comp_cofork_π

end HasCokernels

section

variable [HasZeroObject V]

open ZeroObject

section

variable [HasZeroMorphisms V] [HasKernels V]

theorem exact_of_zero {A C : V} (f : A ⟶ 0) (g : 0 ⟶ C) : Exact f g :=
  by
  obtain rfl : f = 0 := by ext
  obtain rfl : g = 0 := by ext
  fconstructor
  · simp
  · exact imageToKernel_epi_of_zero_of_mono 0
#align category_theory.exact_of_zero CategoryTheory.exact_of_zero

theorem exact_zero_mono {B C : V} (f : B ⟶ C) [Mono f] : Exact (0 : 0 ⟶ B) f :=
  ⟨by simp, inferInstance⟩
#align category_theory.exact_zero_mono CategoryTheory.exact_zero_mono

theorem exact_epi_zero {A B : V} (f : A ⟶ B) [Epi f] : Exact f (0 : B ⟶ 0) :=
  ⟨by simp, inferInstance⟩
#align category_theory.exact_epi_zero CategoryTheory.exact_epi_zero

end

section

variable [Preadditive V]

theorem mono_iff_exact_zero_left [HasKernels V] {B C : V} (f : B ⟶ C) :
    Mono f ↔ Exact (0 : 0 ⟶ B) f :=
  ⟨fun h => exact_zero_mono _, fun h =>
    Preadditive.mono_of_kernel_iso_zero
      ((kernelSubobjectIso f).symm ≪≫ isoZeroOfEpiZero (by simpa using h.epi))⟩
#align category_theory.mono_iff_exact_zero_left CategoryTheory.mono_iff_exact_zero_left

theorem epi_iff_exact_zero_right [HasEqualizers V] {A B : V} (f : A ⟶ B) :
    Epi f ↔ Exact f (0 : B ⟶ 0) :=
  ⟨fun h => exact_epi_zero _, fun h => by
    have e₁ := h.epi
    rw [imageToKernel_zero_right] at e₁
    have e₂ :
      epi
        (((image_subobject f).arrow ≫ inv (kernel_subobject 0).arrow) ≫
          (kernel_subobject 0).arrow) :=
      @epi_comp _ _ _ _ _ _ e₁ _ _
    rw [category.assoc, is_iso.inv_hom_id, category.comp_id] at e₂
    rw [← image_subobject_arrow] at e₂
    skip
    haveI : epi (image.ι f) := epi_of_epi (image_subobject_iso f).Hom (image.ι f)
    apply epi_of_epi_image⟩
#align category_theory.epi_iff_exact_zero_right CategoryTheory.epi_iff_exact_zero_right

end

end

namespace Functor

variable [HasZeroMorphisms V] [HasKernels V] {W : Type u₂} [Category.{v₂} W]

variable [HasImages W] [HasZeroMorphisms W] [HasKernels W]

/-- A functor reflects exact sequences if any composable pair of morphisms that is mapped to an
    exact pair is itself exact. -/
class ReflectsExactSequences (F : V ⥤ W) where
  reflects : ∀ {A B C : V} (f : A ⟶ B) (g : B ⟶ C), Exact (F.map f) (F.map g) → Exact f g
#align category_theory.functor.reflects_exact_sequences CategoryTheory.Functor.ReflectsExactSequences

theorem exact_of_exact_map (F : V ⥤ W) [ReflectsExactSequences F] {A B C : V} {f : A ⟶ B}
    {g : B ⟶ C} (hfg : Exact (F.map f) (F.map g)) : Exact f g :=
  ReflectsExactSequences.reflects f g hfg
#align category_theory.functor.exact_of_exact_map CategoryTheory.Functor.exact_of_exact_map

end Functor

end CategoryTheory


/-
Copyright (c) 2022 Jireh Loreaux. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux

! This file was ported from Lean 3 source module group_theory.subsemigroup.membership
! leanprover-community/mathlib commit 6cb77a8eaff0ddd100e87b1591c6d3ad319514ff
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Subsemigroup.Basic

/-!
# Subsemigroups: membership criteria

In this file we prove various facts about membership in a subsemigroup.
The intent is to mimic `GroupTheory/Submonoid/Membership`, but currently this file is mostly a
stub and only provides rudimentary support.

* `mem_supᵢ_of_directed`, `coe_supᵢ_of_directed`, `mem_supₛ_of_directed_on`,
  `coe_supₛ_of_directed_on`: the supremum of a directed collection of subsemigroup is their union.

## TODO

* Define the `FreeSemigroup` generated by a set. This might require some rather substantial
  additions to low-level API. For example, developing the subtype of nonempty lists, then defining
  a product on nonempty lists, powers where the exponent is a positive natural, et cetera.
  Another option would be to define the `FreeSemigroup` as the subsemigroup (pushed to be a
  semigroup) of the `FreeMonoid` consisting of non-identity elements.

## Tags
subsemigroup
-/

variable {ι : Sort _} {M A B : Type _}

section NonAssoc

variable [Mul M]

open Set

namespace Subsemigroup

-- TODO: this section can be generalized to `[mul_mem_class B M] [complete_lattice B]`
-- such that `complete_lattice.le` coincides with `set_like.le`
@[to_additive]
theorem mem_supᵢ_of_directed {S : ι → Subsemigroup M} (hS : Directed (· ≤ ·) S) {x : M} :
    (x ∈ ⨆ i, S i) ↔ ∃ i, x ∈ S i := by
  refine' ⟨_, fun ⟨i, hi⟩ => (SetLike.le_def.1 <| le_supᵢ S i) hi⟩
  suffices x ∈ closure (⋃ i, (S i : Set M)) → ∃ i, x ∈ S i by
    simpa only [closure_unionᵢ, closure_eq (S _)] using this
  refine' fun hx => closure_induction hx (fun y hy => mem_unionᵢ.mp hy) _
  · rintro x y ⟨i, hi⟩ ⟨j, hj⟩
    rcases hS i j with ⟨k, hki, hkj⟩
    exact ⟨k, (S k).mul_mem (hki hi) (hkj hj)⟩
#align subsemigroup.mem_supr_of_directed Subsemigroup.mem_supᵢ_of_directed
#align add_subsemigroup.mem_supr_of_directed AddSubsemigroup.mem_supᵢ_of_directed

@[to_additive]
theorem coe_supᵢ_of_directed {S : ι → Subsemigroup M} (hS : Directed (· ≤ ·) S) :
    ((⨆ i, S i : Subsemigroup M) : Set M) = ⋃ i, ↑(S i) :=
  Set.ext fun x => by simp [mem_supᵢ_of_directed hS]
#align subsemigroup.coe_supr_of_directed Subsemigroup.coe_supᵢ_of_directed
#align add_subsemigroup.coe_supr_of_directed AddSubsemigroup.coe_supᵢ_of_directed

@[to_additive]
theorem mem_supₛ_of_directed_on {S : Set (Subsemigroup M)} (hS : DirectedOn (· ≤ ·) S) {x : M} :
    x ∈ supₛ S ↔ ∃ s ∈ S, x ∈ s := by
  simp only [supₛ_eq_supᵢ', mem_supᵢ_of_directed hS.directed_val, SetCoe.exists, Subtype.coe_mk,
    exists_prop]
#align subsemigroup.mem_Sup_of_directed_on Subsemigroup.mem_supₛ_of_directed_on
#align add_subsemigroup.mem_Sup_of_directed_on AddSubsemigroup.mem_supₛ_of_directed_on

@[to_additive]
theorem coe_supₛ_of_directed_on {S : Set (Subsemigroup M)} (hS : DirectedOn (· ≤ ·) S) :
    (↑(supₛ S) : Set M) = ⋃ s ∈ S, ↑s :=
  Set.ext fun x => by simp [mem_supₛ_of_directed_on hS]
#align subsemigroup.coe_Sup_of_directed_on Subsemigroup.coe_supₛ_of_directed_on
#align add_subsemigroup.coe_Sup_of_directed_on AddSubsemigroup.coe_supₛ_of_directed_on

@[to_additive]
theorem mem_sup_left {S T : Subsemigroup M} : ∀ {x : M}, x ∈ S → x ∈ S ⊔ T := by
  have : S ≤ S ⊔ T := le_sup_left
  tauto
#align subsemigroup.mem_sup_left Subsemigroup.mem_sup_left
#align add_subsemigroup.mem_sup_left AddSubsemigroup.mem_sup_left

@[to_additive]
theorem mem_sup_right {S T : Subsemigroup M} : ∀ {x : M}, x ∈ T → x ∈ S ⊔ T := by
  have : T ≤ S ⊔ T := le_sup_right
  tauto
#align subsemigroup.mem_sup_right Subsemigroup.mem_sup_right
#align add_subsemigroup.mem_sup_right AddSubsemigroup.mem_sup_right

@[to_additive]

@[to_additive]
theorem mem_supᵢ_of_mem {S : ι → Subsemigroup M} (i : ι) : ∀ {x : M}, x ∈ S i → x ∈ supᵢ S := by
  have : S i ≤ supᵢ S := le_supᵢ _ _
  tauto
#align subsemigroup.mem_supr_of_mem Subsemigroup.mem_supᵢ_of_mem
#align add_subsemigroup.mem_supr_of_mem AddSubsemigroup.mem_supᵢ_of_mem

@[to_additive]
theorem mem_supₛ_of_mem {S : Set (Subsemigroup M)} {s : Subsemigroup M} (hs : s ∈ S) :
    ∀ {x : M}, x ∈ s → x ∈ supₛ S := by
  have : s ≤ supₛ S := le_supₛ hs
  tauto
#align subsemigroup.mem_Sup_of_mem Subsemigroup.mem_supₛ_of_mem
#align add_subsemigroup.mem_Sup_of_mem AddSubsemigroup.mem_supₛ_of_mem

/-- An induction principle for elements of `⨆ i, S i`.
If `C` holds all elements of `S i` for all `i`, and is preserved under multiplication,
then it holds for all elements of the supremum of `S`. -/
@[to_additive (attr := elab_as_elim)
"An induction principle for elements of `⨆ i, S i`. If `C` holds all
elements of `S i` for all `i`, and is preserved under addition, then it holds for all elements of
the supremum of `S`."]
theorem supᵢ_induction (S : ι → Subsemigroup M) {C : M → Prop} {x₁ : M} (hx₁ : x₁ ∈ ⨆ i, S i)
    (hp : ∀ (i) (x₂ : M) (_hxS : x₂ ∈ S i), C x₂) (hmul : ∀ x y, C x → C y → C (x * y)) : C x₁ := by
  rw [supᵢ_eq_closure] at hx₁
  refine' closure_induction hx₁ (fun x₂ hx₂ => _) hmul
  obtain ⟨i, hi⟩ := Set.mem_unionᵢ.mp hx₂
  exact hp _ _ hi
#align subsemigroup.supr_induction Subsemigroup.supᵢ_induction
#align add_subsemigroup.supr_induction AddSubsemigroup.supᵢ_induction

/-- A dependent version of `Subsemigroup.supᵢ_induction`. -/
@[to_additive (attr := elab_as_elim)
"A dependent version of `AddSubsemigroup.supᵢ_induction`."]
theorem supᵢ_induction' (S : ι → Subsemigroup M) {C : ∀ x, (x ∈ ⨆ i, S i) → Prop}
    (hp : ∀ (i) (x) (hxS : x ∈ S i), C x (mem_supᵢ_of_mem i ‹_›))
    (hmul : ∀ x y hx hy, C x hx → C y hy → C (x * y) (mul_mem ‹_› ‹_›)) {x₁ : M}
    (hx₁ : x₁ ∈ ⨆ i, S i) : C x₁ hx₁ := by
  refine Exists.elim ?_ fun (hx₁' : x₁ ∈ ⨆ i, S i) (hc : C x₁ hx₁') => hc
  refine @supᵢ_induction _ _ _ S (fun x' => ∃ hx'', C x' hx'') _ hx₁
      (fun i x₂ hx₂ => ?_) fun x₃ y => ?_
  · exact ⟨_, hp _ _ hx₂⟩
  · rintro ⟨_, Cx⟩ ⟨_, Cy⟩
    exact ⟨_, hmul _ _ _ _ Cx Cy⟩
#align subsemigroup.supr_induction' Subsemigroup.supᵢ_induction'
#align add_subsemigroup.supr_induction' AddSubsemigroup.supᵢ_induction'

end Subsemigroup

end NonAssoc


/-
Copyright (c) 2020 Paul van Wamelen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Paul van Wamelen.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.field
import Mathlib.ring_theory.int.basic
import Mathlib.algebra.group_with_zero.power
import Mathlib.tactic.ring
import Mathlib.tactic.ring_exp
import Mathlib.tactic.field_simp
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Pythagorean Triples
The main result is the classification of pythagorean triples. The final result is for general
pythagorean triples. It follows from the more interesting relatively prime case. We use the
"rational parametrization of the circle" method for the proof. The parametrization maps the point
`(x / z, y / z)` to the slope of the line through `(-1 , 0)` and `(x / z, y / z)`. This quickly
shows that `(x / z, y / z) = (2 * m * n / (m ^ 2 + n ^ 2), (m ^ 2 - n ^ 2) / (m ^ 2 + n ^ 2))` where
`m / n` is the slope. In order to identify numerators and denominators we now need results showing
that these are coprime. This is easy except for the prime 2. In order to deal with that we have to
analyze the parity of `x`, `y`, `m` and `n` and eliminate all the impossible cases. This takes up
the bulk of the proof below.
-/

/-- Three integers `x`, `y`, and `z` form a Pythagorean triple if `x * x + y * y = z * z`. -/
def pythagorean_triple (x : ℤ) (y : ℤ) (z : ℤ) := x * x + y * y = z * z

/-- Pythagorean triples are interchangable, i.e `x * x + y * y = y * y + x * x = z * z`.
This comes from additive commutativity. -/
theorem pythagorean_triple_comm {x : ℤ} {y : ℤ} {z : ℤ} :
    pythagorean_triple x y z ↔ pythagorean_triple y x z :=
  id
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (x * x + y * y = z * z ↔ y * y + x * x = z * z))
          (add_comm (x * x) (y * y))))
      (iff.refl (y * y + x * x = z * z)))

/-- The zeroth Pythagorean triple is all zeros. -/
theorem pythagorean_triple.zero : pythagorean_triple 0 0 0 := sorry

namespace pythagorean_triple

theorem eq {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : x * x + y * y = z * z := h

theorem symm {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : pythagorean_triple y x z :=
  eq.mpr (id (Eq._oldrec (Eq.refl (pythagorean_triple y x z)) (propext pythagorean_triple_comm))) h

/-- A triple is still a triple if you multiply `x`, `y` and `z`
by a constant `k`. -/
theorem mul {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (k : ℤ) :
    pythagorean_triple (k * x) (k * y) (k * z) :=
  sorry

/-- `(k*x, k*y, k*z)` is a Pythagorean triple if and only if
`(x, y, z)` is also a triple. -/
theorem mul_iff {x : ℤ} {y : ℤ} {z : ℤ} (k : ℤ) (hk : k ≠ 0) :
    pythagorean_triple (k * x) (k * y) (k * z) ↔ pythagorean_triple x y z :=
  sorry

/-- A pythogorean triple `x, y, z` is “classified” if there exist integers `k, m, n` such that either
 * `x = k * (m ^ 2 - n ^ 2)` and `y = k * (2 * m * n)`, or
 * `x = k * (2 * m * n)` and `y = k * (m ^ 2 - n ^ 2)`. -/
def is_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) :=
  ∃ (k : ℤ),
    ∃ (m : ℤ),
      ∃ (n : ℤ),
        (x = k * (m ^ bit0 1 - n ^ bit0 1) ∧ y = k * (bit0 1 * m * n) ∨
            x = k * (bit0 1 * m * n) ∧ y = k * (m ^ bit0 1 - n ^ bit0 1)) ∧
          int.gcd m n = 1

/-- A primitive pythogorean triple `x, y, z` is a pythagorean triple with `x` and `y` coprime.
 Such a triple is “primitively classified” if there exist coprime integers `m, n` such that either
 * `x = m ^ 2 - n ^ 2` and `y = 2 * m * n`, or
 * `x = 2 * m * n` and `y = m ^ 2 - n ^ 2`.
-/
def is_primitive_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) :=
  ∃ (m : ℤ),
    ∃ (n : ℤ),
      (x = m ^ bit0 1 - n ^ bit0 1 ∧ y = bit0 1 * m * n ∨
          x = bit0 1 * m * n ∧ y = m ^ bit0 1 - n ^ bit0 1) ∧
        int.gcd m n = 1 ∧ (m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0)

theorem mul_is_classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) (k : ℤ)
    (hc : is_classified h) : is_classified (mul h k) :=
  sorry

theorem even_odd_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z)
    (hc : int.gcd x y = 1) : x % bit0 1 = 0 ∧ y % bit0 1 = 1 ∨ x % bit0 1 = 1 ∧ y % bit0 1 = 0 :=
  sorry

theorem gcd_dvd {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : ↑(int.gcd x y) ∣ z := sorry

theorem normalize {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) :
    pythagorean_triple (x / ↑(int.gcd x y)) (y / ↑(int.gcd x y)) (z / ↑(int.gcd x y)) :=
  sorry

theorem is_classified_of_is_primitive_classified {x : ℤ} {y : ℤ} {z : ℤ}
    (h : pythagorean_triple x y z) (hp : is_primitive_classified h) : is_classified h :=
  sorry

theorem is_classified_of_normalize_is_primitive_classified {x : ℤ} {y : ℤ} {z : ℤ}
    (h : pythagorean_triple x y z) (hc : is_primitive_classified (normalize h)) : is_classified h :=
  sorry

theorem ne_zero_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z)
    (hc : int.gcd x y = 1) : z ≠ 0 :=
  sorry

theorem is_primitive_classified_of_coprime_of_zero_left {x : ℤ} {y : ℤ} {z : ℤ}
    (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hx : x = 0) :
    is_primitive_classified h :=
  sorry

theorem coprime_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z)
    (hc : int.gcd x y = 1) : int.gcd y z = 1 :=
  sorry

end pythagorean_triple

/-!
### A parametrization of the unit circle

For the classification of pythogorean triples, we will use a parametrization of the unit circle.
-/

/--  A parameterization of the unit circle that is useful for classifying Pythagorean triples.
 (To be applied in the case where `K = ℚ`.) -/
def circle_equiv_gen {K : Type u_1} [field K] (hk : ∀ (x : K), 1 + x ^ bit0 1 ≠ 0) :
    K ≃
        Subtype
          fun (p : K × K) => prod.fst p ^ bit0 1 + prod.snd p ^ bit0 1 = 1 ∧ prod.snd p ≠ -1 :=
  equiv.mk
    (fun (x : K) =>
      { val := (bit0 1 * x / (1 + x ^ bit0 1), (1 - x ^ bit0 1) / (1 + x ^ bit0 1)),
        property := sorry })
    (fun
      (p :
      Subtype fun (p : K × K) => prod.fst p ^ bit0 1 + prod.snd p ^ bit0 1 = 1 ∧ prod.snd p ≠ -1) =>
      prod.fst ↑p / (prod.snd ↑p + 1))
    sorry sorry

@[simp] theorem circle_equiv_apply {K : Type u_1} [field K] (hk : ∀ (x : K), 1 + x ^ bit0 1 ≠ 0)
    (x : K) :
    ↑(coe_fn (circle_equiv_gen hk) x) =
        (bit0 1 * x / (1 + x ^ bit0 1), (1 - x ^ bit0 1) / (1 + x ^ bit0 1)) :=
  rfl

@[simp] theorem circle_equiv_symm_apply {K : Type u_1} [field K]
    (hk : ∀ (x : K), 1 + x ^ bit0 1 ≠ 0)
    (v :
      Subtype fun (p : K × K) => prod.fst p ^ bit0 1 + prod.snd p ^ bit0 1 = 1 ∧ prod.snd p ≠ -1) :
    coe_fn (equiv.symm (circle_equiv_gen hk)) v = prod.fst ↑v / (prod.snd ↑v + 1) :=
  rfl

namespace pythagorean_triple

theorem is_primitive_classified_aux {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z)
    (hc : int.gcd x y = 1) (hzpos : 0 < z) {m : ℤ} {n : ℤ} (hm2n2 : 0 < m ^ bit0 1 + n ^ bit0 1)
    (hv2 : ↑x / ↑z = bit0 1 * ↑m * ↑n / (↑m ^ bit0 1 + ↑n ^ bit0 1))
    (hw2 : ↑y / ↑z = (↑m ^ bit0 1 - ↑n ^ bit0 1) / (↑m ^ bit0 1 + ↑n ^ bit0 1))
    (H : int.gcd (m ^ bit0 1 - n ^ bit0 1) (m ^ bit0 1 + n ^ bit0 1) = 1) (co : int.gcd m n = 1)
    (pp : m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0) :
    is_primitive_classified h :=
  sorry

theorem is_primitive_classified_of_coprime_of_odd_of_pos {x : ℤ} {y : ℤ} {z : ℤ}
    (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hyo : y % bit0 1 = 1) (hzpos : 0 < z) :
    is_primitive_classified h :=
  sorry

theorem is_primitive_classified_of_coprime_of_pos {x : ℤ} {y : ℤ} {z : ℤ}
    (h : pythagorean_triple x y z) (hc : int.gcd x y = 1) (hzpos : 0 < z) :
    is_primitive_classified h :=
  sorry

theorem is_primitive_classified_of_coprime {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z)
    (hc : int.gcd x y = 1) : is_primitive_classified h :=
  sorry

theorem classified {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z) : is_classified h := sorry

theorem coprime_classification {x : ℤ} {y : ℤ} {z : ℤ} :
    pythagorean_triple x y z ∧ int.gcd x y = 1 ↔
        ∃ (m : ℤ),
          ∃ (n : ℤ),
            (x = m ^ bit0 1 - n ^ bit0 1 ∧ y = bit0 1 * m * n ∨
                x = bit0 1 * m * n ∧ y = m ^ bit0 1 - n ^ bit0 1) ∧
              (z = m ^ bit0 1 + n ^ bit0 1 ∨ z = -(m ^ bit0 1 + n ^ bit0 1)) ∧
                int.gcd m n = 1 ∧
                  (m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0) :=
  sorry

/-- by assuming `x` is odd and `z` is positive we get a slightly more precise classification of
the pythagorean triple `x ^ 2 + y ^ 2 = z ^ 2`-/
theorem coprime_classification' {x : ℤ} {y : ℤ} {z : ℤ} (h : pythagorean_triple x y z)
    (h_coprime : int.gcd x y = 1) (h_parity : x % bit0 1 = 1) (h_pos : 0 < z) :
    ∃ (m : ℤ),
        ∃ (n : ℤ),
          x = m ^ bit0 1 - n ^ bit0 1 ∧
            y = bit0 1 * m * n ∧
              z = m ^ bit0 1 + n ^ bit0 1 ∧
                int.gcd m n = 1 ∧
                  (m % bit0 1 = 0 ∧ n % bit0 1 = 1 ∨ m % bit0 1 = 1 ∧ n % bit0 1 = 0) ∧ 0 ≤ m :=
  sorry

theorem classification {x : ℤ} {y : ℤ} {z : ℤ} :
    pythagorean_triple x y z ↔
        ∃ (k : ℤ),
          ∃ (m : ℤ),
            ∃ (n : ℤ),
              (x = k * (m ^ bit0 1 - n ^ bit0 1) ∧ y = k * (bit0 1 * m * n) ∨
                  x = k * (bit0 1 * m * n) ∧ y = k * (m ^ bit0 1 - n ^ bit0 1)) ∧
                (z = k * (m ^ bit0 1 + n ^ bit0 1) ∨ z = -k * (m ^ bit0 1 + n ^ bit0 1)) :=
  sorry

end Mathlib