/-
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 order.complete_lattice
import order.hom.lattice

/-!
# Complete lattice homomorphisms

This file defines frame homorphisms and complete 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 `⨅`.
* `frame_hom`: Frame homomorphisms. Maps which preserve `⨆` and `⊓`.
* `complete_lattice_hom`: Complete lattice homomorphisms. Maps which preserve `⨆` and `⨅`.

## Typeclasses

* `Sup_hom_class`
* `Inf_hom_class`
* `frame_hom_class`
* `complete_lattice_hom_class`
-/

open function

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

/-- The type of `⨆`-preserving functions from `α` to `β`. -/
structure Sup_hom (α β : Type*) [has_Sup α] [has_Sup β] :=
(to_fun   : α → β)
(map_Sup' (s : set α) : to_fun (Sup s) = Sup (to_fun '' s))

/-- The type of `⨅`-preserving functions from `α` to `β`. -/
structure Inf_hom (α β : Type*) [has_Inf α] [has_Inf β] :=
(to_fun   : α → β)
(map_Inf' (s : set α) : to_fun (Inf s) = Inf (to_fun '' s))

/-- The type of frame homomorphisms from `α` to `β`. They preserve `⊓` and `⨆`. -/
structure frame_hom (α β : Type*) [complete_lattice α] [complete_lattice β] extends Sup_hom α β :=
(map_inf' (a b : α) : to_fun (a ⊓ b) = to_fun a ⊓ to_fun b)

/-- The type of complete lattice homomorphisms from `α` to `β`. -/
structure complete_lattice_hom (α β : Type*) [complete_lattice α] [complete_lattice β]
  extends Sup_hom α β :=
(map_Inf' (s : set α) : to_fun (Inf s) = Inf (to_fun '' s))

/-- `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) (s : set α) : f (Sup s) = Sup (f '' s))

/-- `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) (s : set α) : f (Inf s) = Inf (f '' s))

/-- `frame_hom_class F α β` states that `F` is a type of frame morphisms. They preserve `⊓` and `⨆`.

You should extend this class when you extend `frame_hom`. -/
class frame_hom_class (F : Type*) (α β : out_param $ Type*) [complete_lattice α]
  [complete_lattice β] extends Sup_hom_class F α β :=
(map_inf (f : F) (a b : α) : f (a ⊓ b) = f a ⊓ f b)

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

You should extend this class when you extend `complete_lattice_hom`. -/
class complete_lattice_hom_class (F : Type*) (α β : out_param $ Type*) [complete_lattice α]
  [complete_lattice β] extends Sup_hom_class F α β :=
(map_Inf (f : F) (s : set α) : f (Inf s) = Inf (f '' s))

export Sup_hom_class (map_Sup)
export Inf_hom_class (map_Inf)

attribute [simp] map_Sup map_Inf

lemma map_supr [has_Sup α] [has_Sup β] [Sup_hom_class F α β] (f : F) (g : ι → α) :
  f (⨆ i, g i) = ⨆ i, f (g i) :=
by rw [supr, supr, map_Sup, set.range_comp]

lemma map_supr₂ [has_Sup α] [has_Sup β] [Sup_hom_class F α β] (f : F) (g : Π i, κ i → α) :
  f (⨆ i j, g i j) = ⨆ i j, f (g i j) :=
by simp_rw map_supr

lemma map_infi [has_Inf α] [has_Inf β] [Inf_hom_class F α β] (f : F) (g : ι → α) :
  f (⨅ i, g i) = ⨅ i, f (g i) :=
by rw [infi, infi, map_Inf, set.range_comp]

lemma map_infi₂ [has_Inf α] [has_Inf β] [Inf_hom_class F α β] (f : F) (g : Π i, κ i → α) :
  f (⨅ i j, g i j) = ⨅ i j, f (g i j) :=
by simp_rw map_infi

@[priority 100] -- See note [lower instance priority]
instance Sup_hom_class.to_sup_hom_class [complete_lattice α] [complete_lattice β]
  [Sup_hom_class F α β] :
  sup_hom_class F α β :=
⟨λ f a b, by rw [←Sup_pair, map_Sup, set.image_pair, Sup_pair]⟩

@[priority 100] -- See note [lower instance priority]
instance Sup_hom_class.to_bot_hom_class [complete_lattice α] [complete_lattice β]
  [Sup_hom_class F α β] :
  bot_hom_class F α β :=
⟨λ f, by rw [←Sup_empty, map_Sup, set.image_empty, Sup_empty]⟩

@[priority 100] -- See note [lower instance priority]
instance Inf_hom_class.to_inf_hom_class [complete_lattice α] [complete_lattice β]
  [Inf_hom_class F α β] :
  inf_hom_class F α β :=
⟨λ f a b, by rw [←Inf_pair, map_Inf, set.image_pair, Inf_pair]⟩

@[priority 100] -- See note [lower instance priority]
instance Inf_hom_class.to_top_hom_class [complete_lattice α] [complete_lattice β]
  [Inf_hom_class F α β] :
  top_hom_class F α β :=
⟨λ f, by rw [←Inf_empty, map_Inf, set.image_empty, Inf_empty]⟩

@[priority 100] -- See note [lower instance priority]
instance frame_hom_class.to_lattice_hom_class [complete_lattice α] [complete_lattice β]
  [frame_hom_class F α β] :
  lattice_hom_class F α β :=
{ .. ‹frame_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance complete_lattice_hom_class.to_Inf_hom_class [complete_lattice α] [complete_lattice β]
  [complete_lattice_hom_class F α β] :
  Inf_hom_class F α β :=
{ .. ‹complete_lattice_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance complete_lattice_hom_class.to_frame_hom_class [complete_lattice α] [complete_lattice β]
  [complete_lattice_hom_class F α β] :
  frame_hom_class F α β :=
{ .. ‹complete_lattice_hom_class F α β›, ..Inf_hom_class.to_inf_hom_class }

@[priority 100] -- See note [lower instance priority]
instance complete_lattice_hom_class.to_bounded_lattice_hom_class [complete_lattice α]
  [complete_lattice β] [complete_lattice_hom_class F α β] :
  bounded_lattice_hom_class F α β :=
{ ..Sup_hom_class.to_bot_hom_class, ..Inf_hom_class.to_top_hom_class }

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 [complete_lattice α] [complete_lattice β] [frame_hom_class F α β] :
  has_coe_t F (frame_hom α β) :=
⟨λ f, { to_fun := f, map_Sup' := map_Sup f, map_inf' := map_inf f }⟩

instance [complete_lattice α] [complete_lattice β] [complete_lattice_hom_class F α β] :
  has_coe_t F (complete_lattice_hom α β) :=
⟨λ f, { to_fun := f, map_Sup' := map_Sup f, map_Inf' := map_Inf f }⟩

/-! ### 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, λ s, by rw [id, set.image_id]⟩

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' := λ s, by rw [comp_apply, map_Sup, map_Sup, set.image_image] }

@[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 := ext $ λ a, rfl
@[simp] lemma id_comp (f : Sup_hom α β) : (Sup_hom.id β).comp f = f := 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, 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, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_Sup

variables [complete_lattice β]

instance : partial_order (Sup_hom α β) := partial_order.lift _ fun_like.coe_injective

instance : has_bot (Sup_hom α β) :=
⟨⟨λ _, ⊥, λ s, begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { rw [set.image_empty, Sup_empty] },
  { rw [hs.image_const, Sup_singleton] }
end⟩⟩

instance : order_bot (Sup_hom α β) := ⟨⊥, λ f a, bot_le⟩

@[simp] lemma coe_bot : ⇑(⊥ : Sup_hom α β) = ⊥ := rfl
@[simp] lemma bot_apply (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 a `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, λ s, by rw [id, set.image_id]⟩

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 a `Inf_hom`. -/
def comp (f : Inf_hom β γ) (g : Inf_hom α β) : Inf_hom α γ :=
{ to_fun := f ∘ g,
  map_Inf' := λ s, by rw [comp_apply, map_Inf, map_Inf, set.image_image] }

@[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 := ext $ λ a, rfl
@[simp] lemma id_comp (f : Inf_hom α β) : (Inf_hom.id β).comp f = f := 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, 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, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end has_Inf

variables [complete_lattice β]

instance : partial_order (Inf_hom α β) := partial_order.lift _ fun_like.coe_injective

instance : has_top (Inf_hom α β) :=
⟨⟨λ _, ⊤, λ s, begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { rw [set.image_empty, Inf_empty] },
  { rw [hs.image_const, Inf_singleton] }
end⟩⟩

instance : order_top (Inf_hom α β) := ⟨⊤, λ f a, le_top⟩

@[simp] lemma coe_top : ⇑(⊤ : Inf_hom α β) = ⊤ := rfl
@[simp] lemma top_apply (a : α) : (⊤ : Inf_hom α β) a = ⊤ := rfl

end Inf_hom

/-! ### Frame homomorphisms -/

namespace frame_hom
variables [complete_lattice α] [complete_lattice β] [complete_lattice γ] [complete_lattice δ]

instance : frame_hom_class (frame_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 (frame_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

/-- Reinterpret a `frame_hom` as a `lattice_hom`. -/
def to_lattice_hom (f : frame_hom α β) : lattice_hom α β :=
{ to_fun := f,
  map_sup' := λ a b, by rw [←Sup_pair, map_Sup, set.image_pair, Sup_pair], ..f }

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

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

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

variables (α)

/-- `id` as a `frame_hom`. -/
protected def id : frame_hom α α := { ..Sup_hom.id α, ..inf_hom.id α }

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

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

variables {α}

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

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

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

lemma cancel_right {g₁ g₂ : frame_hom β γ} {f : frame_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 : frame_hom β γ} {f₁ f₂ : frame_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 _⟩

instance : partial_order (frame_hom α β) := partial_order.lift _ fun_like.coe_injective

instance : has_bot (frame_hom α β) :=
⟨{ .. (inf_hom.const _ _), .. (⊥ : Sup_hom α β) }⟩

instance : order_bot (frame_hom α β) := ⟨⊥, λ f a, bot_le⟩

@[simp] lemma coe_bot : ⇑(⊥ : frame_hom α β) = ⊥ := rfl
@[simp] lemma bot_apply (a : α) : (⊥ : frame_hom α β) a = ⊥ := rfl

end frame_hom

/-! ### Complete lattice homomorphisms -/

namespace complete_lattice_hom
variables [complete_lattice α] [complete_lattice β] [complete_lattice γ] [complete_lattice δ]

/-- Reinterpret a `complete_lattice_hom` as an `Inf_hom`. -/
def to_Inf_hom (f : complete_lattice_hom α β) : Inf_hom α β := { ..f }

instance : complete_lattice_hom_class (complete_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 (complete_lattice_hom α β) (λ _, α → β) := ⟨λ f, f.to_fun⟩

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

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

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

variables (α)

/-- `id` as a `complete_lattice_hom`. -/
protected def id : complete_lattice_hom α α := { to_fun := id, ..Sup_hom.id α, ..Inf_hom.id α }

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

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

variables {α}

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

/-- Composition of `complete_lattice_hom`s as a `complete_lattice_hom`. -/
def comp (f : complete_lattice_hom β γ) (g : complete_lattice_hom α β) : complete_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 : complete_lattice_hom β γ) (g : complete_lattice_hom α β) :
  ⇑(f.comp g) = f ∘ g := rfl
@[simp] lemma comp_apply (f : complete_lattice_hom β γ) (g : complete_lattice_hom α β) (a : α) :
  (f.comp g) a = f (g a) := rfl
@[simp] lemma comp_assoc (f : complete_lattice_hom γ δ) (g : complete_lattice_hom β γ)
  (h : complete_lattice_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : complete_lattice_hom α β) : f.comp (complete_lattice_hom.id α) = f :=
ext $ λ a, rfl
@[simp] lemma id_comp (f : complete_lattice_hom α β) : (complete_lattice_hom.id β).comp f = f :=
ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : complete_lattice_hom β γ} {f : complete_lattice_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 : complete_lattice_hom β γ} {f₁ f₂ : complete_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 complete_lattice_hom


/-
Copyright (c) 2019 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Mario Carneiro, Isabel Longbottom, Scott Morrison, Apurva Nakade

! This file was ported from Lean 3 source module set_theory.game.basic
! leanprover-community/mathlib commit 6623e6af705e97002a9054c1c05a980180276fc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.SetTheory.Game.Pgame
import Mathbin.Tactic.Abel

/-!
# Combinatorial games.

In this file we define the quotient of pre-games by the equivalence relation
`p ≈ q ↔ p ≤ q ∧ q ≤ p` (its `antisymmetrization`), and construct an instance `add_comm_group game`,
as well as an instance `partial_order game`.

## Multiplication on pre-games

We define the operations of multiplication and inverse on pre-games, and prove a few basic theorems
about them. Multiplication is not well-behaved under equivalence of pre-games i.e. `x ≈ y` does not
imply `x * z ≈ y * z`. Hence, multiplication is not a well-defined operation on games. Nevertheless,
the abelian group structure on games allows us to simplify many proofs for pre-games.
-/

open Function Pgame

open Pgame

universe u

instance Pgame.setoid : Setoid Pgame :=
  ⟨(· ≈ ·), equiv_refl, @Pgame.Equiv.symm, @Pgame.Equiv.trans⟩
#align pgame.setoid Pgame.setoid

/-- The type of combinatorial games. In ZFC, a combinatorial game is constructed from
  two sets of combinatorial games that have been constructed at an earlier
  stage. To do this in type theory, we say that a combinatorial pre-game is built
  inductively from two families of combinatorial games indexed over any type
  in Type u. The resulting type `pgame.{u}` lives in `Type (u+1)`,
  reflecting that it is a proper class in ZFC.
  A combinatorial game is then constructed by quotienting by the equivalence
  `x ≈ y ↔ x ≤ y ∧ y ≤ x`. -/
abbrev Game :=
  Quotient Pgame.setoid
#align game Game

namespace Game

instance : AddCommGroupWithOne Game where
  zero := ⟦0⟧
  one := ⟦1⟧
  neg := Quot.lift (fun x => ⟦-x⟧) fun x y h => Quot.sound ((@neg_equiv_neg_iff x y).2 h)
  add :=
    Quotient.lift₂ (fun x y : Pgame => ⟦x + y⟧) fun x₁ y₁ x₂ y₂ hx hy =>
      Quot.sound (Pgame.add_congr hx hy)
  add_zero := by
    rintro ⟨x⟩
    exact Quot.sound (add_zero_equiv x)
  zero_add := by
    rintro ⟨x⟩
    exact Quot.sound (zero_add_equiv x)
  add_assoc := by
    rintro ⟨x⟩ ⟨y⟩ ⟨z⟩
    exact Quot.sound add_assoc_equiv
  add_left_neg := by
    rintro ⟨x⟩
    exact Quot.sound (add_left_neg_equiv x)
  add_comm := by
    rintro ⟨x⟩ ⟨y⟩
    exact Quot.sound add_comm_equiv

instance : Inhabited Game :=
  ⟨0⟩

instance : PartialOrder Game
    where
  le := Quotient.lift₂ (· ≤ ·) fun x₁ y₁ x₂ y₂ hx hy => propext (le_congr hx hy)
  le_refl := by
    rintro ⟨x⟩
    exact le_refl x
  le_trans := by
    rintro ⟨x⟩ ⟨y⟩ ⟨z⟩
    exact @le_trans _ _ x y z
  le_antisymm := by
    rintro ⟨x⟩ ⟨y⟩ h₁ h₂
    apply Quot.sound
    exact ⟨h₁, h₂⟩
  lt := Quotient.lift₂ (· < ·) fun x₁ y₁ x₂ y₂ hx hy => propext (lt_congr hx hy)
  lt_iff_le_not_le := by
    rintro ⟨x⟩ ⟨y⟩
    exact @lt_iff_le_not_le _ _ x y

/-- The less or fuzzy relation on games.

If `0 ⧏ x` (less or fuzzy with), then Left can win `x` as the first player. -/
def Lf : Game → Game → Prop :=
  Quotient.lift₂ Lf fun x₁ y₁ x₂ y₂ hx hy => propext (lf_congr hx hy)
#align game.lf Game.Lf

-- mathport name: «expr ⧏ »
local infixl:50 " ⧏ " => Lf

/-- On `game`, simp-normal inequalities should use as few negations as possible. -/
@[simp]
theorem not_le : ∀ {x y : Game}, ¬x ≤ y ↔ y ⧏ x :=
  by
  rintro ⟨x⟩ ⟨y⟩
  exact Pgame.not_le
#align game.not_le Game.not_le

/-- On `game`, simp-normal inequalities should use as few negations as possible. -/
@[simp]
theorem not_lf : ∀ {x y : Game}, ¬x ⧏ y ↔ y ≤ x :=
  by
  rintro ⟨x⟩ ⟨y⟩
  exact not_lf
#align game.not_lf Game.not_lf

instance : IsTrichotomous Game (· ⧏ ·) :=
  ⟨by
    rintro ⟨x⟩ ⟨y⟩
    change _ ∨ ⟦x⟧ = ⟦y⟧ ∨ _
    rw [Quotient.eq']
    apply lf_or_equiv_or_gf⟩

/-! It can be useful to use these lemmas to turn `pgame` inequalities into `game` inequalities, as
the `add_comm_group` structure on `game` often simplifies many proofs. -/

theorem Pgame.le_iff_game_le {x y : Pgame} : x ≤ y ↔ ⟦x⟧ ≤ ⟦y⟧ :=
  Iff.rfl
#align pgame.le_iff_game_le Pgame.le_iff_game_le

theorem Pgame.lf_iff_game_lf {x y : Pgame} : Pgame.Lf x y ↔ ⟦x⟧ ⧏ ⟦y⟧ :=
  Iff.rfl
#align pgame.lf_iff_game_lf Pgame.lf_iff_game_lf

theorem Pgame.lt_iff_game_lt {x y : Pgame} : x < y ↔ ⟦x⟧ < ⟦y⟧ :=
  Iff.rfl
#align pgame.lt_iff_game_lt Pgame.lt_iff_game_lt

theorem Pgame.equiv_iff_game_eq {x y : Pgame} : (x ≈ y) ↔ ⟦x⟧ = ⟦y⟧ :=
  (@Quotient.eq' _ _ x y).symm
#align pgame.equiv_iff_game_eq Pgame.equiv_iff_game_eq

/-- The fuzzy, confused, or incomparable relation on games.

If `x ‖ 0`, then the first player can always win `x`. -/
def Fuzzy : Game → Game → Prop :=
  Quotient.lift₂ Fuzzy fun x₁ y₁ x₂ y₂ hx hy => propext (fuzzy_congr hx hy)
#align game.fuzzy Game.Fuzzy

-- mathport name: «expr ‖ »
local infixl:50 " ‖ " => Fuzzy

theorem Pgame.fuzzy_iff_game_fuzzy {x y : Pgame} : Pgame.Fuzzy x y ↔ ⟦x⟧ ‖ ⟦y⟧ :=
  Iff.rfl
#align pgame.fuzzy_iff_game_fuzzy Pgame.fuzzy_iff_game_fuzzy

instance covariantClass_add_le : CovariantClass Game Game (· + ·) (· ≤ ·) :=
  ⟨by
    rintro ⟨a⟩ ⟨b⟩ ⟨c⟩ h
    exact @add_le_add_left _ _ _ _ b c h a⟩
#align game.covariant_class_add_le Game.covariantClass_add_le

instance covariantClass_swap_add_le : CovariantClass Game Game (swap (· + ·)) (· ≤ ·) :=
  ⟨by
    rintro ⟨a⟩ ⟨b⟩ ⟨c⟩ h
    exact @add_le_add_right _ _ _ _ b c h a⟩
#align game.covariant_class_swap_add_le Game.covariantClass_swap_add_le

instance covariantClass_add_lt : CovariantClass Game Game (· + ·) (· < ·) :=
  ⟨by
    rintro ⟨a⟩ ⟨b⟩ ⟨c⟩ h
    exact @add_lt_add_left _ _ _ _ b c h a⟩
#align game.covariant_class_add_lt Game.covariantClass_add_lt

instance covariantClass_swap_add_lt : CovariantClass Game Game (swap (· + ·)) (· < ·) :=
  ⟨by
    rintro ⟨a⟩ ⟨b⟩ ⟨c⟩ h
    exact @add_lt_add_right _ _ _ _ b c h a⟩
#align game.covariant_class_swap_add_lt Game.covariantClass_swap_add_lt

theorem add_lf_add_right : ∀ {b c : Game} (h : b ⧏ c) (a), b + a ⧏ c + a :=
  by
  rintro ⟨b⟩ ⟨c⟩ h ⟨a⟩
  apply add_lf_add_right h
#align game.add_lf_add_right Game.add_lf_add_right

theorem add_lf_add_left : ∀ {b c : Game} (h : b ⧏ c) (a), a + b ⧏ a + c :=
  by
  rintro ⟨b⟩ ⟨c⟩ h ⟨a⟩
  apply add_lf_add_left h
#align game.add_lf_add_left Game.add_lf_add_left

instance orderedAddCommGroup : OrderedAddCommGroup Game :=
  { Game.addCommGroupWithOne, Game.partialOrder with
    add_le_add_left := @add_le_add_left _ _ _ Game.covariantClass_add_le }
#align game.ordered_add_comm_group Game.orderedAddCommGroup

end Game

namespace Pgame

@[simp]
theorem quot_neg (a : Pgame) : ⟦-a⟧ = -⟦a⟧ :=
  rfl
#align pgame.quot_neg Pgame.quot_neg

@[simp]
theorem quot_add (a b : Pgame) : ⟦a + b⟧ = ⟦a⟧ + ⟦b⟧ :=
  rfl
#align pgame.quot_add Pgame.quot_add

@[simp]
theorem quot_sub (a b : Pgame) : ⟦a - b⟧ = ⟦a⟧ - ⟦b⟧ :=
  rfl
#align pgame.quot_sub Pgame.quot_sub

theorem quot_eq_of_mk'_quot_eq {x y : Pgame} (L : x.LeftMoves ≃ y.LeftMoves)
    (R : x.RightMoves ≃ y.RightMoves) (hl : ∀ i, ⟦x.moveLeft i⟧ = ⟦y.moveLeft (L i)⟧)
    (hr : ∀ j, ⟦x.moveRight j⟧ = ⟦y.moveRight (R j)⟧) : ⟦x⟧ = ⟦y⟧ :=
  by
  simp_rw [Quotient.eq'] at hl hr
  exact Quot.sound (equiv_of_mk_equiv L R hl hr)
#align pgame.quot_eq_of_mk_quot_eq Pgame.quot_eq_of_mk'_quot_eq

/-! Multiplicative operations can be defined at the level of pre-games,
but to prove their properties we need to use the abelian group structure of games.
Hence we define them here. -/

/-- The product of `x = {xL | xR}` and `y = {yL | yR}` is
`{xL*y + x*yL - xL*yL, xR*y + x*yR - xR*yR | xL*y + x*yR - xL*yR, x*yL + xR*y - xR*yL }`. -/
instance : Mul Pgame.{u} :=
  ⟨fun x y => by
    induction' x with xl xr xL xR IHxl IHxr generalizing y
    induction' y with yl yr yL yR IHyl IHyr
    have y := mk yl yr yL yR
    refine' ⟨Sum (xl × yl) (xr × yr), Sum (xl × yr) (xr × yl), _, _⟩ <;> rintro (⟨i, j⟩ | ⟨i, j⟩)
    · exact IHxl i y + IHyl j - IHxl i (yL j)
    · exact IHxr i y + IHyr j - IHxr i (yR j)
    · exact IHxl i y + IHyr j - IHxl i (yR j)
    · exact IHxr i y + IHyl j - IHxr i (yL j)⟩

theorem leftMoves_mul :
    ∀ x y : Pgame.{u},
      (x * y).LeftMoves = Sum (x.LeftMoves × y.LeftMoves) (x.RightMoves × y.RightMoves)
  | ⟨_, _, _, _⟩, ⟨_, _, _, _⟩ => rfl
#align pgame.left_moves_mul Pgame.leftMoves_mul

theorem rightMoves_mul :
    ∀ x y : Pgame.{u},
      (x * y).RightMoves = Sum (x.LeftMoves × y.RightMoves) (x.RightMoves × y.LeftMoves)
  | ⟨_, _, _, _⟩, ⟨_, _, _, _⟩ => rfl
#align pgame.right_moves_mul Pgame.rightMoves_mul

/-- Turns two left or right moves for `x` and `y` into a left move for `x * y` and vice versa.

Even though these types are the same (not definitionally so), this is the preferred way to convert
between them. -/
def toLeftMovesMul {x y : Pgame} :
    Sum (x.LeftMoves × y.LeftMoves) (x.RightMoves × y.RightMoves) ≃ (x * y).LeftMoves :=
  Equiv.cast (leftMoves_mul x y).symm
#align pgame.to_left_moves_mul Pgame.toLeftMovesMul

/-- Turns a left and a right move for `x` and `y` into a right move for `x * y` and vice versa.

Even though these types are the same (not definitionally so), this is the preferred way to convert
between them. -/
def toRightMovesMul {x y : Pgame} :
    Sum (x.LeftMoves × y.RightMoves) (x.RightMoves × y.LeftMoves) ≃ (x * y).RightMoves :=
  Equiv.cast (rightMoves_mul x y).symm
#align pgame.to_right_moves_mul Pgame.toRightMovesMul

@[simp]
theorem mk_mul_moveLeft_inl {xl xr yl yr} {xL xR yL yR} {i j} :
    (mk xl xr xL xR * mk yl yr yL yR).moveLeft (Sum.inl (i, j)) =
      xL i * mk yl yr yL yR + mk xl xr xL xR * yL j - xL i * yL j :=
  rfl
#align pgame.mk_mul_move_left_inl Pgame.mk_mul_moveLeft_inl

@[simp]
theorem mul_moveLeft_inl {x y : Pgame} {i j} :
    (x * y).moveLeft (toLeftMovesMul (Sum.inl (i, j))) =
      x.moveLeft i * y + x * y.moveLeft j - x.moveLeft i * y.moveLeft j :=
  by
  cases x
  cases y
  rfl
#align pgame.mul_move_left_inl Pgame.mul_moveLeft_inl

@[simp]
theorem mk_mul_moveLeft_inr {xl xr yl yr} {xL xR yL yR} {i j} :
    (mk xl xr xL xR * mk yl yr yL yR).moveLeft (Sum.inr (i, j)) =
      xR i * mk yl yr yL yR + mk xl xr xL xR * yR j - xR i * yR j :=
  rfl
#align pgame.mk_mul_move_left_inr Pgame.mk_mul_moveLeft_inr

@[simp]
theorem mul_moveLeft_inr {x y : Pgame} {i j} :
    (x * y).moveLeft (toLeftMovesMul (Sum.inr (i, j))) =
      x.moveRight i * y + x * y.moveRight j - x.moveRight i * y.moveRight j :=
  by
  cases x
  cases y
  rfl
#align pgame.mul_move_left_inr Pgame.mul_moveLeft_inr

@[simp]
theorem mk_mul_moveRight_inl {xl xr yl yr} {xL xR yL yR} {i j} :
    (mk xl xr xL xR * mk yl yr yL yR).moveRight (Sum.inl (i, j)) =
      xL i * mk yl yr yL yR + mk xl xr xL xR * yR j - xL i * yR j :=
  rfl
#align pgame.mk_mul_move_right_inl Pgame.mk_mul_moveRight_inl

@[simp]
theorem mul_moveRight_inl {x y : Pgame} {i j} :
    (x * y).moveRight (toRightMovesMul (Sum.inl (i, j))) =
      x.moveLeft i * y + x * y.moveRight j - x.moveLeft i * y.moveRight j :=
  by
  cases x
  cases y
  rfl
#align pgame.mul_move_right_inl Pgame.mul_moveRight_inl

@[simp]
theorem mk_mul_moveRight_inr {xl xr yl yr} {xL xR yL yR} {i j} :
    (mk xl xr xL xR * mk yl yr yL yR).moveRight (Sum.inr (i, j)) =
      xR i * mk yl yr yL yR + mk xl xr xL xR * yL j - xR i * yL j :=
  rfl
#align pgame.mk_mul_move_right_inr Pgame.mk_mul_moveRight_inr

@[simp]
theorem mul_moveRight_inr {x y : Pgame} {i j} :
    (x * y).moveRight (toRightMovesMul (Sum.inr (i, j))) =
      x.moveRight i * y + x * y.moveLeft j - x.moveRight i * y.moveLeft j :=
  by
  cases x
  cases y
  rfl
#align pgame.mul_move_right_inr Pgame.mul_moveRight_inr

@[simp]
theorem neg_mk_mul_moveLeft_inl {xl xr yl yr} {xL xR yL yR} {i j} :
    (-(mk xl xr xL xR * mk yl yr yL yR)).moveLeft (Sum.inl (i, j)) =
      -(xL i * mk yl yr yL yR + mk xl xr xL xR * yR j - xL i * yR j) :=
  rfl
#align pgame.neg_mk_mul_move_left_inl Pgame.neg_mk_mul_moveLeft_inl

@[simp]
theorem neg_mk_mul_moveLeft_inr {xl xr yl yr} {xL xR yL yR} {i j} :
    (-(mk xl xr xL xR * mk yl yr yL yR)).moveLeft (Sum.inr (i, j)) =
      -(xR i * mk yl yr yL yR + mk xl xr xL xR * yL j - xR i * yL j) :=
  rfl
#align pgame.neg_mk_mul_move_left_inr Pgame.neg_mk_mul_moveLeft_inr

@[simp]
theorem neg_mk_mul_moveRight_inl {xl xr yl yr} {xL xR yL yR} {i j} :
    (-(mk xl xr xL xR * mk yl yr yL yR)).moveRight (Sum.inl (i, j)) =
      -(xL i * mk yl yr yL yR + mk xl xr xL xR * yL j - xL i * yL j) :=
  rfl
#align pgame.neg_mk_mul_move_right_inl Pgame.neg_mk_mul_moveRight_inl

@[simp]
theorem neg_mk_mul_moveRight_inr {xl xr yl yr} {xL xR yL yR} {i j} :
    (-(mk xl xr xL xR * mk yl yr yL yR)).moveRight (Sum.inr (i, j)) =
      -(xR i * mk yl yr yL yR + mk xl xr xL xR * yR j - xR i * yR j) :=
  rfl
#align pgame.neg_mk_mul_move_right_inr Pgame.neg_mk_mul_moveRight_inr

theorem leftMoves_mul_cases {x y : Pgame} (k) {P : (x * y).LeftMoves → Prop}
    (hl : ∀ ix iy, P <| toLeftMovesMul (Sum.inl ⟨ix, iy⟩))
    (hr : ∀ jx jy, P <| toLeftMovesMul (Sum.inr ⟨jx, jy⟩)) : P k :=
  by
  rw [← to_left_moves_mul.apply_symm_apply k]
  rcases to_left_moves_mul.symm k with (⟨ix, iy⟩ | ⟨jx, jy⟩)
  · apply hl
  · apply hr
#align pgame.left_moves_mul_cases Pgame.leftMoves_mul_cases

theorem rightMoves_mul_cases {x y : Pgame} (k) {P : (x * y).RightMoves → Prop}
    (hl : ∀ ix jy, P <| toRightMovesMul (Sum.inl ⟨ix, jy⟩))
    (hr : ∀ jx iy, P <| toRightMovesMul (Sum.inr ⟨jx, iy⟩)) : P k :=
  by
  rw [← to_right_moves_mul.apply_symm_apply k]
  rcases to_right_moves_mul.symm k with (⟨ix, iy⟩ | ⟨jx, jy⟩)
  · apply hl
  · apply hr
#align pgame.right_moves_mul_cases Pgame.rightMoves_mul_cases

/-- `x * y` and `y * x` have the same moves. -/
def mulCommRelabelling : ∀ x y : Pgame.{u}, x * y ≡r y * x
  | ⟨xl, xr, xL, xR⟩, ⟨yl, yr, yL, yR⟩ => by
    refine'
            ⟨Equiv.sumCongr (Equiv.prodComm _ _) (Equiv.prodComm _ _),
              (Equiv.sumComm _ _).trans (Equiv.sumCongr (Equiv.prodComm _ _) (Equiv.prodComm _ _)),
              _, _⟩ <;>
          rintro (⟨i, j⟩ | ⟨i, j⟩) <;>
        dsimp <;>
      exact
        ((add_comm_relabelling _ _).trans <|
              (mul_comm_relabelling _ _).addCongr (mul_comm_relabelling _ _)).subCongr
          (mul_comm_relabelling _ _)decreasing_by
  pgame_wf_tac
#align pgame.mul_comm_relabelling Pgame.mulCommRelabelling

theorem quot_mul_comm (x y : Pgame.{u}) : ⟦x * y⟧ = ⟦y * x⟧ :=
  Quot.sound (mulCommRelabelling x y).Equiv
#align pgame.quot_mul_comm Pgame.quot_mul_comm

/-- `x * y` is equivalent to `y * x`. -/
theorem mul_comm_equiv (x y : Pgame) : x * y ≈ y * x :=
  Quotient.exact <| quot_mul_comm _ _
#align pgame.mul_comm_equiv Pgame.mul_comm_equiv

instance isEmpty_mul_zero_leftMoves (x : Pgame.{u}) : IsEmpty (x * 0).LeftMoves :=
  by
  cases x
  apply Sum.isEmpty
#align pgame.is_empty_mul_zero_left_moves Pgame.isEmpty_mul_zero_leftMoves

instance isEmpty_mul_zero_rightMoves (x : Pgame.{u}) : IsEmpty (x * 0).RightMoves :=
  by
  cases x
  apply Sum.isEmpty
#align pgame.is_empty_mul_zero_right_moves Pgame.isEmpty_mul_zero_rightMoves

instance isEmpty_zero_mul_leftMoves (x : Pgame.{u}) : IsEmpty (0 * x).LeftMoves :=
  by
  cases x
  apply Sum.isEmpty
#align pgame.is_empty_zero_mul_left_moves Pgame.isEmpty_zero_mul_leftMoves

instance isEmpty_zero_mul_rightMoves (x : Pgame.{u}) : IsEmpty (0 * x).RightMoves :=
  by
  cases x
  apply Sum.isEmpty
#align pgame.is_empty_zero_mul_right_moves Pgame.isEmpty_zero_mul_rightMoves

/-- `x * 0` has exactly the same moves as `0`. -/
def mulZeroRelabelling (x : Pgame) : x * 0 ≡r 0 :=
  Relabelling.isEmpty _
#align pgame.mul_zero_relabelling Pgame.mulZeroRelabelling

/-- `x * 0` is equivalent to `0`. -/
theorem mul_zero_equiv (x : Pgame) : x * 0 ≈ 0 :=
  (mulZeroRelabelling x).Equiv
#align pgame.mul_zero_equiv Pgame.mul_zero_equiv

@[simp]
theorem quot_mul_zero (x : Pgame) : ⟦x * 0⟧ = ⟦0⟧ :=
  @Quotient.sound _ _ (x * 0) _ x.mul_zero_equiv
#align pgame.quot_mul_zero Pgame.quot_mul_zero

/-- `0 * x` has exactly the same moves as `0`. -/
def zeroMulRelabelling (x : Pgame) : 0 * x ≡r 0 :=
  Relabelling.isEmpty _
#align pgame.zero_mul_relabelling Pgame.zeroMulRelabelling

/-- `0 * x` is equivalent to `0`. -/
theorem zero_mul_equiv (x : Pgame) : 0 * x ≈ 0 :=
  (zeroMulRelabelling x).Equiv
#align pgame.zero_mul_equiv Pgame.zero_mul_equiv

@[simp]
theorem quot_zero_mul (x : Pgame) : ⟦0 * x⟧ = ⟦0⟧ :=
  @Quotient.sound _ _ (0 * x) _ x.zero_mul_equiv
#align pgame.quot_zero_mul Pgame.quot_zero_mul

/-- `-x * y` and `-(x * y)` have the same moves. -/
def negMulRelabelling : ∀ x y : Pgame.{u}, -x * y ≡r -(x * y)
  | ⟨xl, xr, xL, xR⟩, ⟨yl, yr, yL, yR⟩ => by
    refine' ⟨Equiv.sumComm _ _, Equiv.sumComm _ _, _, _⟩ <;> rintro (⟨i, j⟩ | ⟨i, j⟩) <;> dsimp <;>
          apply ((neg_add_relabelling _ _).trans _).symm <;>
        apply ((neg_add_relabelling _ _).trans (relabelling.add_congr _ _)).subCongr <;>
      exact (neg_mul_relabelling _ _).symm decreasing_by
  pgame_wf_tac
#align pgame.neg_mul_relabelling Pgame.negMulRelabelling

@[simp]
theorem quot_neg_mul (x y : Pgame) : ⟦-x * y⟧ = -⟦x * y⟧ :=
  Quot.sound (negMulRelabelling x y).Equiv
#align pgame.quot_neg_mul Pgame.quot_neg_mul

/-- `x * -y` and `-(x * y)` have the same moves. -/
def mulNegRelabelling (x y : Pgame) : x * -y ≡r -(x * y) :=
  (mulCommRelabelling x _).trans <| (negMulRelabelling _ x).trans (mulCommRelabelling y x).negCongr
#align pgame.mul_neg_relabelling Pgame.mulNegRelabelling

@[simp]
theorem quot_mul_neg (x y : Pgame) : ⟦x * -y⟧ = -⟦x * y⟧ :=
  Quot.sound (mulNegRelabelling x y).Equiv
#align pgame.quot_mul_neg Pgame.quot_mul_neg

@[simp]
theorem quot_left_distrib : ∀ x y z : Pgame, ⟦x * (y + z)⟧ = ⟦x * y⟧ + ⟦x * z⟧
  | mk xl xr xL xR, mk yl yr yL yR, mk zl zr zL zR =>
    by
    let x := mk xl xr xL xR
    let y := mk yl yr yL yR
    let z := mk zl zr zL zR
    refine' quot_eq_of_mk_quot_eq _ _ _ _
    · fconstructor
      ·
        rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩) <;>
          solve_by_elim (config := { max_depth := 5 }) [Sum.inl, Sum.inr, Prod.mk]
      ·
        rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩) <;>
          solve_by_elim (config := { max_depth := 5 }) [Sum.inl, Sum.inr, Prod.mk]
      · rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩) <;> rfl
      · rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩) <;> rfl
    · fconstructor
      ·
        rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩) <;>
          solve_by_elim (config := { max_depth := 5 }) [Sum.inl, Sum.inr, Prod.mk]
      ·
        rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩) <;>
          solve_by_elim (config := { max_depth := 5 }) [Sum.inl, Sum.inr, Prod.mk]
      · rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩) <;> rfl
      · rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩) <;> rfl
    · rintro (⟨i, j | k⟩ | ⟨i, j | k⟩)
      · change
          ⟦xL i * (y + z) + x * (yL j + z) - xL i * (yL j + z)⟧ =
            ⟦xL i * y + x * yL j - xL i * yL j + x * z⟧
        simp [quot_left_distrib]
        abel
      · change
          ⟦xL i * (y + z) + x * (y + zL k) - xL i * (y + zL k)⟧ =
            ⟦x * y + (xL i * z + x * zL k - xL i * zL k)⟧
        simp [quot_left_distrib]
        abel
      · change
          ⟦xR i * (y + z) + x * (yR j + z) - xR i * (yR j + z)⟧ =
            ⟦xR i * y + x * yR j - xR i * yR j + x * z⟧
        simp [quot_left_distrib]
        abel
      · change
          ⟦xR i * (y + z) + x * (y + zR k) - xR i * (y + zR k)⟧ =
            ⟦x * y + (xR i * z + x * zR k - xR i * zR k)⟧
        simp [quot_left_distrib]
        abel
    · rintro (⟨i, j | k⟩ | ⟨i, j | k⟩)
      · change
          ⟦xL i * (y + z) + x * (yR j + z) - xL i * (yR j + z)⟧ =
            ⟦xL i * y + x * yR j - xL i * yR j + x * z⟧
        simp [quot_left_distrib]
        abel
      · change
          ⟦xL i * (y + z) + x * (y + zR k) - xL i * (y + zR k)⟧ =
            ⟦x * y + (xL i * z + x * zR k - xL i * zR k)⟧
        simp [quot_left_distrib]
        abel
      · change
          ⟦xR i * (y + z) + x * (yL j + z) - xR i * (yL j + z)⟧ =
            ⟦xR i * y + x * yL j - xR i * yL j + x * z⟧
        simp [quot_left_distrib]
        abel
      · change
          ⟦xR i * (y + z) + x * (y + zL k) - xR i * (y + zL k)⟧ =
            ⟦x * y + (xR i * z + x * zL k - xR i * zL k)⟧
        simp [quot_left_distrib]
        abel decreasing_by pgame_wf_tac
#align pgame.quot_left_distrib Pgame.quot_left_distrib

/-- `x * (y + z)` is equivalent to `x * y + x * z.`-/
theorem left_distrib_equiv (x y z : Pgame) : x * (y + z) ≈ x * y + x * z :=
  Quotient.exact <| quot_left_distrib _ _ _
#align pgame.left_distrib_equiv Pgame.left_distrib_equiv

@[simp]
theorem quot_left_distrib_sub (x y z : Pgame) : ⟦x * (y - z)⟧ = ⟦x * y⟧ - ⟦x * z⟧ :=
  by
  change ⟦x * (y + -z)⟧ = ⟦x * y⟧ + -⟦x * z⟧
  rw [quot_left_distrib, quot_mul_neg]
#align pgame.quot_left_distrib_sub Pgame.quot_left_distrib_sub

@[simp]
theorem quot_right_distrib (x y z : Pgame) : ⟦(x + y) * z⟧ = ⟦x * z⟧ + ⟦y * z⟧ := by
  simp only [quot_mul_comm, quot_left_distrib]
#align pgame.quot_right_distrib Pgame.quot_right_distrib

/-- `(x + y) * z` is equivalent to `x * z + y * z.`-/
theorem right_distrib_equiv (x y z : Pgame) : (x + y) * z ≈ x * z + y * z :=
  Quotient.exact <| quot_right_distrib _ _ _
#align pgame.right_distrib_equiv Pgame.right_distrib_equiv

@[simp]
theorem quot_right_distrib_sub (x y z : Pgame) : ⟦(y - z) * x⟧ = ⟦y * x⟧ - ⟦z * x⟧ :=
  by
  change ⟦(y + -z) * x⟧ = ⟦y * x⟧ + -⟦z * x⟧
  rw [quot_right_distrib, quot_neg_mul]
#align pgame.quot_right_distrib_sub Pgame.quot_right_distrib_sub

/-- `x * 1` has the same moves as `x`. -/
def mulOneRelabelling : ∀ x : Pgame.{u}, x * 1 ≡r x
  | ⟨xl, xr, xL, xR⟩ => by
    unfold One.one
    refine'
                  ⟨(Equiv.sumEmpty _ _).trans (Equiv.prodPUnit _),
                    (Equiv.emptySum _ _).trans (Equiv.prodPUnit _), _, _⟩ <;>
                try rintro (⟨i, ⟨⟩⟩ | ⟨i, ⟨⟩⟩) <;>
              try intro i <;>
            dsimp <;>
          apply (relabelling.sub_congr (relabelling.refl _) (mul_zero_relabelling _)).trans <;>
        rw [sub_zero] <;>
      exact
        (add_zero_relabelling _).trans
          (((mul_one_relabelling _).addCongr (mul_zero_relabelling _)).trans <|
            add_zero_relabelling _)
#align pgame.mul_one_relabelling Pgame.mulOneRelabelling

@[simp]
theorem quot_mul_one (x : Pgame) : ⟦x * 1⟧ = ⟦x⟧ :=
  Quot.sound <| mulOneRelabelling x
#align pgame.quot_mul_one Pgame.quot_mul_one

/-- `x * 1` is equivalent to `x`. -/
theorem mul_one_equiv (x : Pgame) : x * 1 ≈ x :=
  Quotient.exact <| quot_mul_one x
#align pgame.mul_one_equiv Pgame.mul_one_equiv

/-- `1 * x` has the same moves as `x`. -/
def oneMulRelabelling (x : Pgame) : 1 * x ≡r x :=
  (mulCommRelabelling 1 x).trans <| mulOneRelabelling x
#align pgame.one_mul_relabelling Pgame.oneMulRelabelling

@[simp]
theorem quot_one_mul (x : Pgame) : ⟦1 * x⟧ = ⟦x⟧ :=
  Quot.sound <| oneMulRelabelling x
#align pgame.quot_one_mul Pgame.quot_one_mul

/-- `1 * x` is equivalent to `x`. -/
theorem one_mul_equiv (x : Pgame) : 1 * x ≈ x :=
  Quotient.exact <| quot_one_mul x
#align pgame.one_mul_equiv Pgame.one_mul_equiv

theorem quot_mul_assoc : ∀ x y z : Pgame, ⟦x * y * z⟧ = ⟦x * (y * z)⟧
  | mk xl xr xL xR, mk yl yr yL yR, mk zl zr zL zR =>
    by
    let x := mk xl xr xL xR
    let y := mk yl yr yL yR
    let z := mk zl zr zL zR
    refine' quot_eq_of_mk_quot_eq _ _ _ _
    · fconstructor
      ·
        rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩) <;>
          solve_by_elim (config := { max_depth := 7 }) [Sum.inl, Sum.inr, Prod.mk]
      ·
        rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩) <;>
          solve_by_elim (config := { max_depth := 7 }) [Sum.inl, Sum.inr, Prod.mk]
      · rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩) <;> rfl
      · rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩) <;> rfl
    · fconstructor
      ·
        rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩) <;>
          solve_by_elim (config := { max_depth := 7 }) [Sum.inl, Sum.inr, Prod.mk]
      ·
        rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩) <;>
          solve_by_elim (config := { max_depth := 7 }) [Sum.inl, Sum.inr, Prod.mk]
      · rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩) <;> rfl
      · rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩) <;> rfl
    · rintro (⟨⟨i, j⟩ | ⟨i, j⟩, k⟩ | ⟨⟨i, j⟩ | ⟨i, j⟩, k⟩)
      · change
          ⟦(xL i * y + x * yL j - xL i * yL j) * z + x * y * zL k -
                (xL i * y + x * yL j - xL i * yL j) * zL k⟧ =
            ⟦xL i * (y * z) + x * (yL j * z + y * zL k - yL j * zL k) -
                xL i * (yL j * z + y * zL k - yL j * zL k)⟧
        simp [quot_mul_assoc]
        abel
      · change
          ⟦(xR i * y + x * yR j - xR i * yR j) * z + x * y * zL k -
                (xR i * y + x * yR j - xR i * yR j) * zL k⟧ =
            ⟦xR i * (y * z) + x * (yR j * z + y * zL k - yR j * zL k) -
                xR i * (yR j * z + y * zL k - yR j * zL k)⟧
        simp [quot_mul_assoc]
        abel
      · change
          ⟦(xL i * y + x * yR j - xL i * yR j) * z + x * y * zR k -
                (xL i * y + x * yR j - xL i * yR j) * zR k⟧ =
            ⟦xL i * (y * z) + x * (yR j * z + y * zR k - yR j * zR k) -
                xL i * (yR j * z + y * zR k - yR j * zR k)⟧
        simp [quot_mul_assoc]
        abel
      · change
          ⟦(xR i * y + x * yL j - xR i * yL j) * z + x * y * zR k -
                (xR i * y + x * yL j - xR i * yL j) * zR k⟧ =
            ⟦xR i * (y * z) + x * (yL j * z + y * zR k - yL j * zR k) -
                xR i * (yL j * z + y * zR k - yL j * zR k)⟧
        simp [quot_mul_assoc]
        abel
    · rintro (⟨⟨i, j⟩ | ⟨i, j⟩, k⟩ | ⟨⟨i, j⟩ | ⟨i, j⟩, k⟩)
      · change
          ⟦(xL i * y + x * yL j - xL i * yL j) * z + x * y * zR k -
                (xL i * y + x * yL j - xL i * yL j) * zR k⟧ =
            ⟦xL i * (y * z) + x * (yL j * z + y * zR k - yL j * zR k) -
                xL i * (yL j * z + y * zR k - yL j * zR k)⟧
        simp [quot_mul_assoc]
        abel
      · change
          ⟦(xR i * y + x * yR j - xR i * yR j) * z + x * y * zR k -
                (xR i * y + x * yR j - xR i * yR j) * zR k⟧ =
            ⟦xR i * (y * z) + x * (yR j * z + y * zR k - yR j * zR k) -
                xR i * (yR j * z + y * zR k - yR j * zR k)⟧
        simp [quot_mul_assoc]
        abel
      · change
          ⟦(xL i * y + x * yR j - xL i * yR j) * z + x * y * zL k -
                (xL i * y + x * yR j - xL i * yR j) * zL k⟧ =
            ⟦xL i * (y * z) + x * (yR j * z + y * zL k - yR j * zL k) -
                xL i * (yR j * z + y * zL k - yR j * zL k)⟧
        simp [quot_mul_assoc]
        abel
      · change
          ⟦(xR i * y + x * yL j - xR i * yL j) * z + x * y * zL k -
                (xR i * y + x * yL j - xR i * yL j) * zL k⟧ =
            ⟦xR i * (y * z) + x * (yL j * z + y * zL k - yL j * zL k) -
                xR i * (yL j * z + y * zL k - yL j * zL k)⟧
        simp [quot_mul_assoc]
        abel decreasing_by pgame_wf_tac
#align pgame.quot_mul_assoc Pgame.quot_mul_assoc

/-- `x * y * z` is equivalent to `x * (y * z).`-/
theorem mul_assoc_equiv (x y z : Pgame) : x * y * z ≈ x * (y * z) :=
  Quotient.exact <| quot_mul_assoc _ _ _
#align pgame.mul_assoc_equiv Pgame.mul_assoc_equiv

/-- Because the two halves of the definition of `inv` produce more elements
on each side, we have to define the two families inductively.
This is the indexing set for the function, and `inv_val` is the function part. -/
inductive InvTy (l r : Type u) : Bool → Type u
  | zero : inv_ty false
  | left₁ : r → inv_ty false → inv_ty false
  | left₂ : l → inv_ty true → inv_ty false
  | right₁ : l → inv_ty false → inv_ty true
  | right₂ : r → inv_ty true → inv_ty true
#align pgame.inv_ty Pgame.InvTy

instance (l r : Type u) [IsEmpty l] [IsEmpty r] : IsEmpty (InvTy l r true) :=
  ⟨by rintro (_ | _ | _ | a | a) <;> exact isEmptyElim a⟩

instance (l r : Type u) : Inhabited (InvTy l r false) :=
  ⟨InvTy.zero⟩

instance uniqueInvTy (l r : Type u) [IsEmpty l] [IsEmpty r] : Unique (InvTy l r false) :=
  { InvTy.inhabited l r with
    uniq := by
      rintro (a | a | a)
      rfl
      all_goals exact isEmptyElim a }
#align pgame.unique_inv_ty Pgame.uniqueInvTy

/-- Because the two halves of the definition of `inv` produce more elements
of each side, we have to define the two families inductively.
This is the function part, defined by recursion on `inv_ty`. -/
def invVal {l r} (L : l → Pgame) (R : r → Pgame) (IHl : l → Pgame) (IHr : r → Pgame) :
    ∀ {b}, InvTy l r b → Pgame
  | _, inv_ty.zero => 0
  | _, inv_ty.left₁ i j => (1 + (R i - mk l r L R) * inv_val j) * IHr i
  | _, inv_ty.left₂ i j => (1 + (L i - mk l r L R) * inv_val j) * IHl i
  | _, inv_ty.right₁ i j => (1 + (L i - mk l r L R) * inv_val j) * IHl i
  | _, inv_ty.right₂ i j => (1 + (R i - mk l r L R) * inv_val j) * IHr i
#align pgame.inv_val Pgame.invVal

@[simp]
theorem invVal_isEmpty {l r : Type u} {b} (L R IHl IHr) (i : InvTy l r b) [IsEmpty l] [IsEmpty r] :
    invVal L R IHl IHr i = 0 := by
  cases' i with a _ a _ a _ a
  · rfl
  all_goals exact isEmptyElim a
#align pgame.inv_val_is_empty Pgame.invVal_isEmpty

/-- The inverse of a positive surreal number `x = {L | R}` is
given by `x⁻¹ = {0,
  (1 + (R - x) * x⁻¹L) * R, (1 + (L - x) * x⁻¹R) * L |
  (1 + (L - x) * x⁻¹L) * L, (1 + (R - x) * x⁻¹R) * R}`.
Because the two halves `x⁻¹L, x⁻¹R` of `x⁻¹` are used in their own
definition, the sets and elements are inductively generated. -/
def inv' : Pgame → Pgame
  | ⟨l, r, L, R⟩ =>
    let l' := { i // 0 < L i }
    let L' : l' → Pgame := fun i => L i.1
    let IHl' : l' → Pgame := fun i => inv' (L i.1)
    let IHr i := inv' (R i)
    ⟨InvTy l' r false, InvTy l' r true, invVal L' R IHl' IHr, invVal L' R IHl' IHr⟩
#align pgame.inv' Pgame.inv'

theorem zero_lf_inv' : ∀ x : Pgame, 0 ⧏ inv' x
  | ⟨xl, xr, xL, xR⟩ => by
    convert lf_mk _ _ inv_ty.zero
    rfl
#align pgame.zero_lf_inv' Pgame.zero_lf_inv'

/-- `inv' 0` has exactly the same moves as `1`. -/
def inv'Zero : inv' 0 ≡r 1 := by
  change mk _ _ _ _ ≡r 1
  refine' ⟨_, _, fun i => _, IsEmpty.elim _⟩
  · apply Equiv.equivPUnit (inv_ty _ _ _)
    infer_instance
  · apply Equiv.equivPEmpty (inv_ty _ _ _)
    infer_instance
  · simp
  · dsimp
    infer_instance
#align pgame.inv'_zero Pgame.inv'Zero

theorem inv'_zero_equiv : inv' 0 ≈ 1 :=
  inv'Zero.Equiv
#align pgame.inv'_zero_equiv Pgame.inv'_zero_equiv

/-- `inv' 1` has exactly the same moves as `1`. -/
def inv'One : inv' 1 ≡r (1 : Pgame.{u}) :=
  by
  change relabelling (mk _ _ _ _) 1
  have : IsEmpty { i : PUnit.{u + 1} // (0 : Pgame.{u}) < 0 } :=
    by
    rw [lt_self_iff_false]
    infer_instance
  refine' ⟨_, _, fun i => _, IsEmpty.elim _⟩ <;> dsimp
  · apply Equiv.equivPUnit
  · apply Equiv.equivOfIsEmpty
  · simp
  · infer_instance
#align pgame.inv'_one Pgame.inv'One

theorem inv'_one_equiv : inv' 1 ≈ 1 :=
  inv'One.Equiv
#align pgame.inv'_one_equiv Pgame.inv'_one_equiv

/-- The inverse of a pre-game in terms of the inverse on positive pre-games. -/
noncomputable instance : Inv Pgame :=
  ⟨by classical exact fun x => if x ≈ 0 then 0 else if 0 < x then inv' x else -inv' (-x)⟩

noncomputable instance : Div Pgame :=
  ⟨fun x y => x * y⁻¹⟩

theorem inv_eq_of_equiv_zero {x : Pgame} (h : x ≈ 0) : x⁻¹ = 0 := by classical exact if_pos h
#align pgame.inv_eq_of_equiv_zero Pgame.inv_eq_of_equiv_zero

@[simp]
theorem inv_zero : (0 : Pgame)⁻¹ = 0 :=
  inv_eq_of_equiv_zero (equiv_refl _)
#align pgame.inv_zero Pgame.inv_zero

theorem inv_eq_of_pos {x : Pgame} (h : 0 < x) : x⁻¹ = inv' x := by
  classical exact (if_neg h.lf.not_equiv').trans (if_pos h)
#align pgame.inv_eq_of_pos Pgame.inv_eq_of_pos

theorem inv_eq_of_lf_zero {x : Pgame} (h : x ⧏ 0) : x⁻¹ = -inv' (-x) := by
  classical exact (if_neg h.not_equiv).trans (if_neg h.not_gt)
#align pgame.inv_eq_of_lf_zero Pgame.inv_eq_of_lf_zero

/-- `1⁻¹` has exactly the same moves as `1`. -/
def invOne : 1⁻¹ ≡r 1 := by
  rw [inv_eq_of_pos Pgame.zero_lt_one]
  exact inv'_one
#align pgame.inv_one Pgame.invOne

theorem inv_one_equiv : 1⁻¹ ≈ 1 :=
  invOne.Equiv
#align pgame.inv_one_equiv Pgame.inv_one_equiv

end Pgame


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.finite

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

open category_theory
open opposite

namespace category_theory.limits

universes v u u₂
variables {C : Type u} [category.{v} C]

variables {J : Type v} [small_category J]

-- We hide the "implementation details" inside a namespace
namespace has_limit_of_has_products_of_has_equalizers

variables {F : J ⥤ C}
          {c₁ : fan F.obj}
          {c₂ : fan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2)}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), s ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.1⟩ ≫ F.map f.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), t ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.2⟩)
          (i : fork s t)

include hs ht
/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def build_limit : cone F :=
{ X := i.X,
  π :=
  { app := λ j, i.ι ≫ c₁.π.app ⟨_⟩,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.id_comp, category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
  is_limit (build_limit s t hs ht i) :=
{ lift := λ q,
  begin
    refine hi.lift (fork.of_ι _ _),
    { refine t₁.lift (fan.mk _ (λ j, _)),
      apply q.π.app j },
    { apply t₂.hom_ext,
      intro j, discrete_cases,
      simp [hs, ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.equalizer_ext (t₁.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_limit_of_has_products_of_has_equalizers

open has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers,
we can construct a limit cone for `F`.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
noncomputable
def limit_cone_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : limit_cone F :=
{ cone := _,
  is_limit :=
    build_is_limit
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨_⟩ ≫ F.map f.2))
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨f.1.2⟩))
      (by simp)
      (by simp)
      (limit.is_limit _)
      (limit.is_limit _)
      (limit.is_limit _) }

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
lemma has_limit_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : has_limit F :=
has_limit.mk (limit_cone_of_equalizer_and_product F)

/-- A limit can be realised as a subobject of a product. -/
noncomputable
def limit_subobject_product [has_limits C] (F : J ⥤ C) :
  limit F ⟶ ∏ (λ j, F.obj j) :=
(limit.iso_limit_cone (limit_cone_of_equalizer_and_product F)).hom ≫ equalizer.ι _ _

instance limit_subobject_product_mono [has_limits C] (F : J ⥤ C) :
  mono (limit_subobject_product F) :=
mono_comp _ _

/--
Any category with products and equalizers has all limits.

See <https://stacks.math.columbia.edu/tag/002N>.
-/
lemma limits_from_equalizers_and_products
  [has_products C] [has_equalizers C] : has_limits C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite products and equalizers has all finite limits.

See <https://stacks.math.columbia.edu/tag/002O>.
-/
lemma finite_limits_from_equalizers_and_finite_products
  [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
⟨λ J _ _, { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F }⟩

variables {D : Type u₂} [category.{v} D]
noncomputable theory

section

variables [has_limits_of_shape (discrete.{v} J) C]
          [has_limits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_equalizers C]
variables (G : C ⥤ D)
          [preserves_limits_of_shape walking_parallel_pair.{v} G]
          [preserves_limits_of_shape (discrete.{v} J) G]
          [preserves_limits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product :
  preserves_limits_of_shape J G :=
{ preserves_limit := λ K,
  begin
    let P := ∏ K.obj,
    let Q := ∏ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.2),
    let s : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨_⟩ ≫ K.map f.2),
    let t : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨f.1.2⟩),
    let I := equalizer s t,
    let i : I ⟶ P := equalizer.ι s t,
    apply preserves_limit_of_preserves_limit_cone
      (build_is_limit s t (by simp) (by simp)
        (limit.is_limit _)
        (limit.is_limit _)
        (limit.is_limit _)),
    refine is_limit.of_iso_limit (build_is_limit _ _ _ _ _ _ _) _,
    { exact fan.mk _ (λ j, G.map (pi.π _ j)) },
    { exact fan.mk (G.obj Q) (λ f, G.map (pi.π _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { apply fork.of_ι (G.map i) _,
      simp only [← G.map_comp, equalizer.condition] },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_fork_map_of_is_limit,
      apply equalizer_is_equalizer },
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products
  [has_equalizers C] [has_finite_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair.{v} G]
  [∀ J [fintype J], preserves_limits_of_shape (discrete.{v} J) G] :
  preserves_finite_limits G :=
⟨λ _ _ _, by exactI preserves_limit_of_preserves_equalizers_and_product G⟩

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products
  [has_equalizers C] [has_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair.{v} G]
  [∀ J, preserves_limits_of_shape (discrete.{v} J) G] :
preserves_limits G :=
{ preserves_limits_of_shape := λ J 𝒥,
  by exactI preserves_limit_of_preserves_equalizers_and_product G }

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

-- We hide the "implementation details" inside a namespace
namespace has_colimit_of_has_coproducts_of_has_coequalizers

variables {F : J ⥤ C}
          {c₁ : cofan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1)}
          {c₂ : cofan F.obj}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ s = F.map f.2 ≫ c₂.ι.app ⟨f.1.2⟩)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ t = c₂.ι.app ⟨f.1.1⟩)
          (i : cofork s t)

include hs ht
/--
(Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def build_colimit : cocone F :=
{ X := i.X,
  ι :=
  { app := λ j, c₂.ι.app ⟨_⟩ ≫ i.π,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.comp_id, ←reassoc_of (hs ⟨⟨_, _⟩, f⟩), i.condition, ←category.assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cocone constructed in `build_colimit` is colimiting,
provided the cocones used in its construction are.
-/
def build_is_colimit (t₁ : is_colimit c₁) (t₂ : is_colimit c₂) (hi : is_colimit i) :
  is_colimit (build_colimit s t hs ht i) :=
{ desc := λ q,
  begin
    refine hi.desc (cofork.of_π _ _),
    { refine t₂.desc (cofan.mk _ (λ j, _)),
      apply q.ι.app j },
    { apply t₁.hom_ext,
      intro j, discrete_cases,
      simp [reassoc_of hs, reassoc_of ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.coequalizer_ext (t₂.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_colimit_of_has_coproducts_of_has_coequalizers

open has_colimit_of_has_coproducts_of_has_coequalizers

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we can construct a colimit cocone for `F`.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
noncomputable
def colimit_cocone_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : colimit_cocone F :=
{ cocone := _,
  is_colimit :=
    build_is_colimit
      (sigma.desc (λ f, F.map f.2 ≫ colimit.ι (discrete.functor F.obj) ⟨f.1.2⟩))
      (sigma.desc (λ f, colimit.ι (discrete.functor F.obj) ⟨f.1.1⟩))
      (by simp)
      (by simp)
      (colimit.is_colimit _)
      (colimit.is_colimit _)
      (colimit.is_colimit _) }

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
lemma has_colimit_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : has_colimit F :=
has_colimit.mk (colimit_cocone_of_coequalizer_and_coproduct F)

/-- A colimit can be realised as a quotient of a coproduct. -/
noncomputable
def colimit_quotient_coproduct [has_colimits C] (F : J ⥤ C) :
  ∐ (λ j, F.obj j) ⟶ colimit F :=
coequalizer.π _ _ ≫ (colimit.iso_colimit_cocone (colimit_cocone_of_coequalizer_and_coproduct F)).inv

instance colimit_quotient_coproduct_epi [has_colimits C] (F : J ⥤ C) :
  epi (colimit_quotient_coproduct F) :=
epi_comp _ _

/--
Any category with coproducts and coequalizers has all colimits.

See <https://stacks.math.columbia.edu/tag/002P>.
-/
lemma colimits_from_coequalizers_and_coproducts
  [has_coproducts C] [has_coequalizers C] : has_colimits C :=
{ has_colimits_of_shape := λ J 𝒥,
  { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F } }

/--
Any category with finite coproducts and coequalizers has all finite colimits.

See <https://stacks.math.columbia.edu/tag/002Q>.
-/
lemma finite_colimits_from_coequalizers_and_finite_coproducts
  [has_finite_coproducts C] [has_coequalizers C] : has_finite_colimits C :=
⟨λ J _ _, { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F }⟩

noncomputable theory

section

variables [has_colimits_of_shape (discrete.{v} J) C]
          [has_colimits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_coequalizers C]
variables (G : C ⥤ D)
          [preserves_colimits_of_shape walking_parallel_pair.{v} G]
          [preserves_colimits_of_shape (discrete.{v} J) G]
          [preserves_colimits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
def preserves_colimit_of_preserves_coequalizers_and_coproduct :
  preserves_colimits_of_shape J G :=
{ preserves_colimit := λ K,
  begin
    let P := ∐ K.obj,
    let Q := ∐ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.1),
    let s : Q ⟶ P := sigma.desc (λ f, K.map f.2 ≫ colimit.ι (discrete.functor K.obj) ⟨_⟩),
    let t : Q ⟶ P := sigma.desc (λ f, colimit.ι (discrete.functor K.obj) ⟨f.1.1⟩),
    let I := coequalizer s t,
    let i : P ⟶ I := coequalizer.π s t,
    apply preserves_colimit_of_preserves_colimit_cocone
      (build_is_colimit s t (by simp) (by simp)
        (colimit.is_colimit _)
        (colimit.is_colimit _)
        (colimit.is_colimit _)),
    refine is_colimit.of_iso_colimit (build_is_colimit _ _ _ _ _ _ _) _,
    { exact cofan.mk (G.obj Q) (λ j, G.map (sigma.ι _ j)) },
    { exact cofan.mk _ (λ f, G.map (sigma.ι _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { apply cofork.of_π (G.map i) _,
      simp only [← G.map_comp, coequalizer.condition] },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_cofork_map_of_is_colimit,
      apply coequalizer_is_coequalizer },
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
  [has_coequalizers C] [has_finite_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair.{v} G]
  [∀ J [fintype J], preserves_colimits_of_shape (discrete.{v} J) G] :
  preserves_finite_colimits G :=
⟨λ _ _ _, by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G⟩

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
def preserves_colimits_of_preserves_coequalizers_and_coproducts
  [has_coequalizers C] [has_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair.{v} G]
  [∀ J, preserves_colimits_of_shape (discrete.{v} J) G] :
preserves_colimits G :=
{ preserves_colimits_of_shape := λ J 𝒥,
  by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G }

end category_theory.limits


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import order.well_founded
import algebra.group.pi
import order.min_max

/-!
# Lexicographic order on Pi types

This file defines the lexicographic order for Pi types. `a` is less than `b` if `a i = b i` for all
`i` up to some point `k`, and `a k < b k`.

## Notation

* `Πₗ i, α i`: Pi type equipped with the lexicographic order. Type synonym of `Π i, α i`.

## See also

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

variables {ι : Type*} {β : ι → Type*} (r : ι → ι → Prop)
  (s : Π {i}, β i → β i → Prop)

namespace pi

instance {α : Type*} : Π [inhabited α], inhabited (lex α) := id

/-- The lexicographic relation on `Π i : ι, β i`, where `ι` is ordered by `r`,
  and each `β i` is ordered by `s`. -/
protected def lex (x y : Π i, β i) : Prop :=
∃ i, (∀ j, r j i → x j = y j) ∧ s (x i) (y i)

/- This unfortunately results in a type that isn't delta-reduced, so we keep the notation out of the
basic API, just in case -/
notation `Πₗ` binders `, ` r:(scoped p, lex (Π i, p i)) := r

@[simp] lemma to_lex_apply (x : Π i, β i) (i : ι) : to_lex x i = x i := rfl
@[simp] lemma of_lex_apply (x : lex (Π i, β i)) (i : ι) : of_lex x i = x i := rfl

lemma is_trichotomous_lex [∀ i, is_trichotomous (β i) s] (wf : well_founded r) :
  is_trichotomous (Π i, β i) (pi.lex r @s) :=
{ trichotomous := λ a b,
    begin
      cases eq_or_ne a b with hab hab,
      { exact or.inr (or.inl hab) },
      { rw function.ne_iff at hab,
        let i := wf.min _ hab,
        have hri : ∀ j, r j i → a j = b j,
        { intro j, rw ← not_imp_not,
          exact λ h', wf.not_lt_min _ _ h' },
        have hne : a i ≠ b i, from wf.min_mem _ hab,
        cases trichotomous_of s (a i) (b i) with hi hi,
        exacts [or.inl ⟨i, hri, hi⟩,
          or.inr $ or.inr $ ⟨i, λ j hj, (hri j hj).symm, hi.resolve_left hne⟩] },
    end }

instance [has_lt ι] [Π a, has_lt (β a)] : has_lt (lex (Π i, β i)) := ⟨pi.lex (<) (λ _, (<))⟩

instance lex.is_strict_order [linear_order ι] [∀ a, partial_order (β a)] :
  is_strict_order (lex (Π i, β i)) (<) :=
{ irrefl := λ a ⟨k, hk₁, hk₂⟩, lt_irrefl (a k) hk₂,
  trans :=
    begin
      rintro a b c ⟨N₁, lt_N₁, a_lt_b⟩ ⟨N₂, lt_N₂, b_lt_c⟩,
      rcases lt_trichotomy N₁ N₂ with (H|rfl|H),
      exacts [⟨N₁, λ j hj, (lt_N₁ _ hj).trans (lt_N₂ _ $ hj.trans H), lt_N₂ _ H ▸ a_lt_b⟩,
        ⟨N₁, λ j hj, (lt_N₁ _ hj).trans (lt_N₂ _ hj), a_lt_b.trans b_lt_c⟩,
        ⟨N₂, λ j hj, (lt_N₁ _ (hj.trans H)).trans (lt_N₂ _ hj), (lt_N₁ _ H).symm ▸ b_lt_c⟩]
    end }

instance [linear_order ι] [Π a, partial_order (β a)] : partial_order (lex (Π i, β i)) :=
partial_order_of_SO (<)

/-- `Πₗ i, α i` is a linear order if the original order is well-founded. -/
noncomputable instance [linear_order ι] [is_well_order ι (<)] [∀ a, linear_order (β a)] :
  linear_order (lex (Π i, β i)) :=
@linear_order_of_STO' (Πₗ i, β i) (<)
  { to_is_trichotomous := is_trichotomous_lex _ _ is_well_order.wf } (classical.dec_rel _)

lemma lex.le_of_forall_le [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  {a b : lex (Π i, β i)} (h : ∀ i, a i ≤ b i) : a ≤ b :=
le_of_not_lt (λ ⟨i, hi⟩, (h i).not_lt hi.2)

lemma lex.le_of_of_lex_le [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  {a b : lex (Π i, β i)} (h : of_lex a ≤ of_lex b) : a ≤ b :=
lex.le_of_forall_le h

lemma to_lex_monotone [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)] :
  monotone (@to_lex (Π i, β i)) :=
λ _ _, lex.le_of_forall_le

instance [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  [Π a, order_bot (β a)] : order_bot (lex (Π a, β a)) :=
{ bot := to_lex ⊥,
  bot_le := λ f, lex.le_of_of_lex_le bot_le }

instance [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  [Π a, order_top (β a)] : order_top (lex (Π a, β a)) :=
{ top := to_lex ⊤,
  le_top := λ f, lex.le_of_of_lex_le le_top }

instance [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  [Π a, bounded_order (β a)] : bounded_order (lex (Π a, β a)) :=
{ .. pi.lex.order_bot, .. pi.lex.order_top }

--we might want the analog of `pi.ordered_cancel_comm_monoid` as well in the future
@[to_additive]
instance lex.ordered_comm_group [linear_order ι] [∀ a, ordered_comm_group (β a)] :
  ordered_comm_group (lex (Π i, β i)) :=
{ mul_le_mul_left := λ x y hxy z,
    hxy.elim
      (λ hxyz, hxyz ▸ le_rfl)
      (λ ⟨i, hi⟩,
        or.inr ⟨i, λ j hji, show z j * x j = z j * y j, by rw hi.1 j hji,
          mul_lt_mul_left' hi.2 _⟩),
  ..pi.lex.partial_order,
  ..pi.comm_group }

end pi


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Kevin Buzzard

! This file was ported from Lean 3 source module number_theory.bernoulli
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.BigOperators.NatAntidiagonal
import Mathbin.Algebra.GeomSum
import Mathbin.Data.Fintype.BigOperators
import Mathbin.RingTheory.PowerSeries.WellKnown
import Mathbin.Tactic.FieldSimp

/-!
# Bernoulli numbers

The Bernoulli numbers are a sequence of rational numbers that frequently show up in
number theory.

## Mathematical overview

The Bernoulli numbers $(B_0, B_1, B_2, \ldots)=(1, -1/2, 1/6, 0, -1/30, \ldots)$ are
a sequence of rational numbers. They show up in the formula for the sums of $k$th
powers. They are related to the Taylor series expansions of $x/\tan(x)$ and
of $\coth(x)$, and also show up in the values that the Riemann Zeta function
takes both at both negative and positive integers (and hence in the
theory of modular forms). For example, if $1 \leq n$ is even then

$$\zeta(2n)=\sum_{t\geq1}t^{-2n}=(-1)^{n+1}\frac{(2\pi)^{2n}B_{2n}}{2(2n)!}.$$

Note however that this result is not yet formalised in Lean.

The Bernoulli numbers can be formally defined using the power series

$$\sum B_n\frac{t^n}{n!}=\frac{t}{1-e^{-t}}$$

although that happens to not be the definition in mathlib (this is an *implementation
detail* and need not concern the mathematician).

Note that $B_1=-1/2$, meaning that we are using the $B_n^-$ of
[from Wikipedia](https://en.wikipedia.org/wiki/Bernoulli_number).

## Implementation detail

The Bernoulli numbers are defined using well-founded induction, by the formula
$$B_n=1-\sum_{k\lt n}\frac{\binom{n}{k}}{n-k+1}B_k.$$
This formula is true for all $n$ and in particular $B_0=1$. Note that this is the definition
for positive Bernoulli numbers, which we call `bernoulli'`. The negative Bernoulli numbers are
then defined as `bernoulli := (-1)^n * bernoulli'`.

## Main theorems

`sum_bernoulli : ∑ k in finset.range n, (n.choose k : ℚ) * bernoulli k = 0`
-/

open Nat BigOperators

open Finset Nat Finset.Nat PowerSeries

variable (A : Type _) [CommRing A] [Algebra ℚ A]

/-! ### Definitions -/

/-- The Bernoulli numbers:
the $n$-th Bernoulli number $B_n$ is defined recursively via
$$B_n = 1 - \sum_{k < n} \binom{n}{k}\frac{B_k}{n+1-k}$$ -/
def bernoulli' : ℕ → ℚ :=
  WellFounded.fix lt_wfRel fun n bernoulli' =>
    1 - ∑ k : Fin n, n.choose k / (n - k + 1) * bernoulli' k k.2
#align bernoulli' bernoulli'

theorem bernoulli'_def' (n : ℕ) :
    bernoulli' n = 1 - ∑ k : Fin n, n.choose k / (n - k + 1) * bernoulli' k :=
  WellFounded.fix_eq _ _ _
#align bernoulli'_def' bernoulli'_def'

theorem bernoulli'_def (n : ℕ) :
    bernoulli' n = 1 - ∑ k in range n, n.choose k / (n - k + 1) * bernoulli' k :=
  by
  rw [bernoulli'_def', ← Fin.sum_univ_eq_sum_range]
  rfl
#align bernoulli'_def bernoulli'_def

theorem bernoulli'_spec (n : ℕ) :
    (∑ k in range n.succ, (n.choose (n - k) : ℚ) / (n - k + 1) * bernoulli' k) = 1 :=
  by
  rw [sum_range_succ_comm, bernoulli'_def n, tsub_self]
  conv in n.choose (_ - _) => rw [choose_symm (mem_range.1 H).le]
  simp only [one_mul, cast_one, sub_self, sub_add_cancel, choose_zero_right, zero_add, div_one]
#align bernoulli'_spec bernoulli'_spec

theorem bernoulli'_spec' (n : ℕ) :
    (∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli' k.1) = 1 :=
  by
  refine' ((sum_antidiagonal_eq_sum_range_succ_mk _ n).trans _).trans (bernoulli'_spec n)
  refine' sum_congr rfl fun x hx => _
  simp only [add_tsub_cancel_of_le, mem_range_succ_iff.mp hx, cast_sub]
#align bernoulli'_spec' bernoulli'_spec'

/-! ### Examples -/

section Examples

@[simp]
theorem bernoulli'_zero : bernoulli' 0 = 1 :=
  by
  rw [bernoulli'_def]
  norm_num
#align bernoulli'_zero bernoulli'_zero

@[simp]
theorem bernoulli'_one : bernoulli' 1 = 1 / 2 :=
  by
  rw [bernoulli'_def]
  norm_num
#align bernoulli'_one bernoulli'_one

@[simp]
theorem bernoulli'_two : bernoulli' 2 = 1 / 6 :=
  by
  rw [bernoulli'_def]
  norm_num [sum_range_succ]
#align bernoulli'_two bernoulli'_two

@[simp]
theorem bernoulli'_three : bernoulli' 3 = 0 :=
  by
  rw [bernoulli'_def]
  norm_num [sum_range_succ]
#align bernoulli'_three bernoulli'_three

@[simp]
theorem bernoulli'_four : bernoulli' 4 = -1 / 30 :=
  by
  have : Nat.choose 4 2 = 6 := by decide
  -- shrug
  rw [bernoulli'_def]
  norm_num [sum_range_succ, this]
#align bernoulli'_four bernoulli'_four

end Examples

@[simp]
theorem sum_bernoulli' (n : ℕ) : (∑ k in range n, (n.choose k : ℚ) * bernoulli' k) = n :=
  by
  cases n
  · simp
  suffices
    ((n + 1 : ℚ) * ∑ k in range n, ↑(n.choose k) / (n - k + 1) * bernoulli' k) =
      ∑ x in range n, ↑(n.succ.choose x) * bernoulli' x
    by
    rw_mod_cast [sum_range_succ, bernoulli'_def, ← this, choose_succ_self_right]
    ring
  simp_rw [mul_sum, ← mul_assoc]
  refine' sum_congr rfl fun k hk => _
  congr
  have : ((n - k : ℕ) : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero
  field_simp [← cast_sub (mem_range.1 hk).le, mul_comm]
  rw_mod_cast [tsub_add_eq_add_tsub (mem_range.1 hk).le, choose_mul_succ_eq]
#align sum_bernoulli' sum_bernoulli'

/-- The exponential generating function for the Bernoulli numbers `bernoulli' n`. -/
def bernoulli'PowerSeries :=
  mk fun n => algebraMap ℚ A (bernoulli' n / n !)
#align bernoulli'_power_series bernoulli'PowerSeries

theorem bernoulli'PowerSeries_mul_exp_sub_one : bernoulli'PowerSeries A * (exp A - 1) = x * exp A :=
  by
  ext n
  -- constant coefficient is a special case
  cases n
  · simp
  rw [bernoulli'PowerSeries, coeff_mul, mul_comm X, sum_antidiagonal_succ']
  suffices (∑ p in antidiagonal n, bernoulli' p.1 / p.1! * ((p.2 + 1) * p.2!)⁻¹) = n !⁻¹ by
    simpa [RingHom.map_sum] using congr_arg (algebraMap ℚ A) this
  apply eq_inv_of_mul_eq_one_left
  rw [sum_mul]
  convert bernoulli'_spec' n using 1
  apply sum_congr rfl
  simp_rw [mem_antidiagonal]
  rintro ⟨i, j⟩ rfl
  have : (j + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero j
  have : (j + 1 : ℚ) * j ! * i ! ≠ 0 := by simpa [factorial_ne_zero]
  have := factorial_mul_factorial_dvd_factorial_add i j
  field_simp [mul_comm _ (bernoulli' i), mul_assoc, add_choose]
  rw_mod_cast [mul_comm (j + 1), mul_div_assoc, ← mul_assoc]
  rw [cast_mul, cast_mul, mul_div_mul_right, cast_div_char_zero, cast_mul]
  assumption
  rwa [Nat.cast_succ]
#align bernoulli'_power_series_mul_exp_sub_one bernoulli'PowerSeries_mul_exp_sub_one

/-- Odd Bernoulli numbers (greater than 1) are zero. -/
theorem bernoulli'_odd_eq_zero {n : ℕ} (h_odd : Odd n) (hlt : 1 < n) : bernoulli' n = 0 :=
  by
  let B := mk fun n => bernoulli' n / n !
  suffices (B - eval_neg_hom B) * (exp ℚ - 1) = X * (exp ℚ - 1)
    by
    cases mul_eq_mul_right_iff.mp this <;>
      simp only [PowerSeries.ext_iff, eval_neg_hom, coeff_X] at h
    · apply eq_zero_of_neg_eq
      specialize h n
      split_ifs  at h <;> simp_all [h_odd.neg_one_pow, factorial_ne_zero]
    · simpa using h 1
  have h : B * (exp ℚ - 1) = X * exp ℚ := by
    simpa [bernoulli'PowerSeries] using bernoulli'PowerSeries_mul_exp_sub_one ℚ
  rw [sub_mul, h, mul_sub X, sub_right_inj, ← neg_sub, mul_neg, neg_eq_iff_eq_neg]
  suffices eval_neg_hom (B * (exp ℚ - 1)) * exp ℚ = eval_neg_hom (X * exp ℚ) * exp ℚ by
    simpa [mul_assoc, sub_mul, mul_comm (eval_neg_hom (exp ℚ)), exp_mul_exp_neg_eq_one]
  congr
#align bernoulli'_odd_eq_zero bernoulli'_odd_eq_zero

/-- The Bernoulli numbers are defined to be `bernoulli'` with a parity sign. -/
def bernoulli (n : ℕ) : ℚ :=
  (-1) ^ n * bernoulli' n
#align bernoulli bernoulli

theorem bernoulli'_eq_bernoulli (n : ℕ) : bernoulli' n = (-1) ^ n * bernoulli n := by
  simp [bernoulli, ← mul_assoc, ← sq, ← pow_mul, mul_comm n 2, pow_mul]
#align bernoulli'_eq_bernoulli bernoulli'_eq_bernoulli

@[simp]
theorem bernoulli_zero : bernoulli 0 = 1 := by simp [bernoulli]
#align bernoulli_zero bernoulli_zero

@[simp]
theorem bernoulli_one : bernoulli 1 = -1 / 2 := by norm_num [bernoulli]
#align bernoulli_one bernoulli_one

theorem bernoulli_eq_bernoulli'_of_ne_one {n : ℕ} (hn : n ≠ 1) : bernoulli n = bernoulli' n :=
  by
  by_cases h0 : n = 0; · simp [h0]
  rw [bernoulli, neg_one_pow_eq_pow_mod_two]
  cases mod_two_eq_zero_or_one n; · simp [h]
  simp [bernoulli'_odd_eq_zero (odd_iff.mpr h) (one_lt_iff_ne_zero_and_ne_one.mpr ⟨h0, hn⟩)]
#align bernoulli_eq_bernoulli'_of_ne_one bernoulli_eq_bernoulli'_of_ne_one

@[simp]
theorem sum_bernoulli (n : ℕ) :
    (∑ k in range n, (n.choose k : ℚ) * bernoulli k) = if n = 1 then 1 else 0 :=
  by
  cases n
  · simp
  cases n
  · simp
  suffices (∑ i in range n, ↑((n + 2).choose (i + 2)) * bernoulli (i + 2)) = n / 2
    by
    simp only [this, sum_range_succ', cast_succ, bernoulli_one, bernoulli_zero, choose_one_right,
      mul_one, choose_zero_right, cast_zero, if_false, zero_add, succ_succ_ne_one]
    ring
  have f := sum_bernoulli' n.succ.succ
  simp_rw [sum_range_succ', bernoulli'_one, choose_one_right, cast_succ, ← eq_sub_iff_add_eq] at f
  convert f
  · funext x
    rw [bernoulli_eq_bernoulli'_of_ne_one (succ_ne_zero x ∘ succ.inj)]
  · simp only [one_div, mul_one, bernoulli'_zero, cast_one, choose_zero_right, add_sub_cancel]
    ring
#align sum_bernoulli sum_bernoulli

theorem bernoulli_spec' (n : ℕ) :
    (∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli k.1) =
      if n = 0 then 1 else 0 :=
  by
  cases n; · simp
  rw [if_neg (succ_ne_zero _)]
  -- algebra facts
  have h₁ : (1, n) ∈ antidiagonal n.succ := by simp [mem_antidiagonal, add_comm]
  have h₂ : (n : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero
  have h₃ : (1 + n).choose n = n + 1 := by simp [add_comm]
  -- key equation: the corresponding fact for `bernoulli'`
  have H := bernoulli'_spec' n.succ
  -- massage it to match the structure of the goal, then convert piece by piece
  rw [sum_eq_add_sum_diff_singleton h₁] at H⊢
  apply add_eq_of_eq_sub'
  convert eq_sub_of_add_eq' H using 1
  · refine' sum_congr rfl fun p h => _
    obtain ⟨h', h''⟩ : p ∈ _ ∧ p ≠ _ := by rwa [mem_sdiff, mem_singleton] at h
    simp [bernoulli_eq_bernoulli'_of_ne_one ((not_congr (antidiagonal_congr h' h₁)).mp h'')]
  · field_simp [h₃]
    norm_num
#align bernoulli_spec' bernoulli_spec'

/-- The exponential generating function for the Bernoulli numbers `bernoulli n`. -/
def bernoulliPowerSeries :=
  mk fun n => algebraMap ℚ A (bernoulli n / n !)
#align bernoulli_power_series bernoulliPowerSeries

theorem bernoulliPowerSeries_mul_exp_sub_one : bernoulliPowerSeries A * (exp A - 1) = x :=
  by
  ext n
  -- constant coefficient is a special case
  cases n;
  · simp
  simp only [bernoulliPowerSeries, coeff_mul, coeff_X, sum_antidiagonal_succ', one_div, coeff_mk,
    coeff_one, coeff_exp, LinearMap.map_sub, factorial, if_pos, cast_succ, cast_one, cast_mul,
    sub_zero, RingHom.map_one, add_eq_zero_iff, if_false, _root_.inv_one, zero_add, one_ne_zero,
    MulZeroClass.mul_zero, and_false_iff, sub_self, ← RingHom.map_mul, ← RingHom.map_sum]
  cases n; · simp
  rw [if_neg n.succ_succ_ne_one]
  have hfact : ∀ m, (m ! : ℚ) ≠ 0 := fun m => by exact_mod_cast factorial_ne_zero m
  have hite2 : ite (n.succ = 0) 1 0 = (0 : ℚ) := if_neg n.succ_ne_zero
  rw [← map_zero (algebraMap ℚ A), ← zero_div (n.succ ! : ℚ), ← hite2, ← bernoulli_spec', sum_div]
  refine' congr_arg (algebraMap ℚ A) (sum_congr rfl fun x h => eq_div_of_mul_eq (hfact n.succ) _)
  rw [mem_antidiagonal] at h
  have hj : (x.2 + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero _
  field_simp [← h, mul_ne_zero hj (hfact x.2), hfact x.1, mul_comm _ (bernoulli x.1), mul_assoc,
    add_choose, cast_div_char_zero (factorial_mul_factorial_dvd_factorial_add _ _),
    Nat.factorial_ne_zero, hj]
  cc
#align bernoulli_power_series_mul_exp_sub_one bernoulliPowerSeries_mul_exp_sub_one

section Faulhaber

/-- **Faulhaber's theorem** relating the **sum of of p-th powers** to the Bernoulli numbers:
$$\sum_{k=0}^{n-1} k^p = \sum_{i=0}^p B_i\binom{p+1}{i}\frac{n^{p+1-i}}{p+1}.$$
See https://proofwiki.org/wiki/Faulhaber%27s_Formula and [orosi2018faulhaber] for
the proof provided here. -/
theorem sum_range_pow (n p : ℕ) :
    (∑ k in range n, (k : ℚ) ^ p) =
      ∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
  by
  have hne : ∀ m : ℕ, (m ! : ℚ) ≠ 0 := fun m => by exact_mod_cast factorial_ne_zero m
  -- compute the Cauchy product of two power series
  have h_cauchy :
    ((mk fun p => bernoulli p / p !) * mk fun q => coeff ℚ (q + 1) (exp ℚ ^ n)) =
      mk fun p =>
        ∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)! :=
    by
    ext q : 1
    let f a b := bernoulli a / a ! * coeff ℚ (b + 1) (exp ℚ ^ n)
    -- key step: use `power_series.coeff_mul` and then rewrite sums
    simp only [coeff_mul, coeff_mk, cast_mul, sum_antidiagonal_eq_sum_range_succ f]
    apply sum_congr rfl
    simp_intro m h only [Finset.mem_range]
    simp only [f, exp_pow_eq_rescale_exp, rescale, one_div, coeff_mk, RingHom.coe_mk, coeff_exp,
      RingHom.id_apply, cast_mul, algebraMap_rat_rat]
    -- manipulate factorials and binomial coefficients
    rw [choose_eq_factorial_div_factorial h.le, eq_comm, div_eq_iff (hne q.succ), succ_eq_add_one,
      mul_assoc _ _ ↑q.succ !, mul_comm _ ↑q.succ !, ← mul_assoc, div_mul_eq_mul_div,
      mul_comm (↑n ^ (q - m + 1)), ← mul_assoc _ _ (↑n ^ (q - m + 1)), ← one_div, mul_one_div,
      div_div, tsub_add_eq_add_tsub (le_of_lt_succ h), cast_div, cast_mul]
    · ring
    · exact factorial_mul_factorial_dvd_factorial h.le
    · simp [hne]
  -- same as our goal except we pull out `p!` for convenience
  have hps :
    (∑ k in range n, ↑k ^ p) =
      (∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!) * p ! :=
    by
    suffices
      (mk fun p => ∑ k in range n, ↑k ^ p * algebraMap ℚ ℚ p !⁻¹) =
        mk fun p =>
          ∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!
      by
      rw [← div_eq_iff (hne p), div_eq_mul_inv, sum_mul]
      rw [PowerSeries.ext_iff] at this
      simpa using this p
    -- the power series `exp ℚ - 1` is non-zero, a fact we need in order to use `mul_right_inj'`
    have hexp : exp ℚ - 1 ≠ 0 :=
      by
      simp only [exp, PowerSeries.ext_iff, Ne, not_forall]
      use 1
      simp
    have h_r : exp ℚ ^ n - 1 = X * mk fun p => coeff ℚ (p + 1) (exp ℚ ^ n) :=
      by
      have h_const : C ℚ (constant_coeff ℚ (exp ℚ ^ n)) = 1 := by simp
      rw [← h_const, sub_const_eq_X_mul_shift]
    -- key step: a chain of equalities of power series
    rw [← mul_right_inj' hexp, mul_comm, ← exp_pow_sum, geom_sum_mul, h_r, ←
      bernoulliPowerSeries_mul_exp_sub_one, bernoulliPowerSeries, mul_right_comm]
    simp [h_cauchy, mul_comm]
  -- massage `hps` into our goal
  rw [hps, sum_mul]
  refine' sum_congr rfl fun x hx => _
  field_simp [mul_right_comm _ ↑p !, ← mul_assoc _ _ ↑p !, cast_add_one_ne_zero, hne]
#align sum_range_pow sum_range_pow

/-- Alternate form of **Faulhaber's theorem**, relating the sum of p-th powers to the Bernoulli
numbers: $$\sum_{k=1}^{n} k^p = \sum_{i=0}^p (-1)^iB_i\binom{p+1}{i}\frac{n^{p+1-i}}{p+1}.$$
Deduced from `sum_range_pow`. -/
theorem sum_Ico_pow (n p : ℕ) :
    (∑ k in Ico 1 (n + 1), (k : ℚ) ^ p) =
      ∑ i in range (p + 1), bernoulli' i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
  by
  rw [← Nat.cast_succ]
  -- dispose of the trivial case
  cases p
  · simp
  let f i := bernoulli i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ
  let f' i := bernoulli' i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ
  suffices (∑ k in Ico 1 n.succ, ↑k ^ p.succ) = ∑ i in range p.succ.succ, f' i by convert this
  -- prove some algebraic facts that will make things easier for us later on
  have hle := Nat.le_add_left 1 n
  have hne : (p + 1 + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero p.succ
  have h1 : ∀ r : ℚ, r * (p + 1 + 1) * n ^ p.succ / (p + 1 + 1 : ℚ) = r * n ^ p.succ := fun r => by
    rw [mul_div_right_comm, mul_div_cancel _ hne]
  have h2 : f 1 + n ^ p.succ = 1 / 2 * n ^ p.succ :=
    by
    simp_rw [f, bernoulli_one, choose_one_right, succ_sub_succ_eq_sub, cast_succ, tsub_zero, h1]
    ring
  have :
    (∑ i in range p, bernoulli (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2)) =
      ∑ i in range p, bernoulli' (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2) :=
    sum_congr rfl fun i h => by rw [bernoulli_eq_bernoulli'_of_ne_one (succ_succ_ne_one i)]
  calc
    (-- replace sum over `Ico` with sum over `range` and simplify
        ∑ k in Ico 1 n.succ, ↑k ^ p.succ) =
        ∑ k in range n.succ, ↑k ^ p.succ :=
      by simp [sum_Ico_eq_sub _ hle, succ_ne_zero]
    -- extract the last term of the sum
        _ =
        (∑ k in range n, (k : ℚ) ^ p.succ) + n ^ p.succ :=
      by rw [sum_range_succ]
    -- apply the key lemma, `sum_range_pow`
        _ =
        (∑ i in range p.succ.succ, f i) + n ^ p.succ :=
      by simp [f, sum_range_pow]
    -- extract the first two terms of the sum
        _ =
        (∑ i in range p, f i.succ.succ) + f 1 + f 0 + n ^ p.succ :=
      by simp_rw [sum_range_succ']
    _ = (∑ i in range p, f i.succ.succ) + (f 1 + n ^ p.succ) + f 0 := by ring
    _ = (∑ i in range p, f i.succ.succ) + 1 / 2 * n ^ p.succ + f 0 := by rw [h2]
    -- convert from `bernoulli` to `bernoulli'`
        _ =
        (∑ i in range p, f' i.succ.succ) + f' 1 + f' 0 :=
      by
      simp only [f, f']
      simpa [h1, fun i => show i + 2 = i + 1 + 1 from rfl]
    -- rejoin the first two terms of the sum
        _ =
        ∑ i in range p.succ.succ, f' i :=
      by simp_rw [sum_range_succ']

#align sum_Ico_pow sum_Ico_pow

end Faulhaber