/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import field_theory.normal
import field_theory.primitive_element
import field_theory.fixed
import group_theory.group_action.fixing_subgroup

/-!
# Galois Extensions

In this file we define Galois extensions as extensions which are both separable and normal.

## Main definitions

- `is_galois F E` where `E` is an extension of `F`
- `fixed_field H` where `H : subgroup (E ≃ₐ[F] E)`
- `fixing_subgroup K` where `K : intermediate_field F E`
- `galois_correspondence` where `E/F` is finite dimensional and Galois

## Main results

- `intermediate_field.fixing_subgroup_fixed_field` : If `E/F` is finite dimensional (but not
  necessarily Galois) then `fixing_subgroup (fixed_field H) = H`
- `intermediate_field.fixed_field_fixing_subgroup`: If `E/F` is finite dimensional and Galois
  then `fixed_field (fixing_subgroup K) = K`

Together, these two results prove the Galois correspondence.

- `is_galois.tfae` : Equivalent characterizations of a Galois extension of finite degree
-/

open_locale polynomial

open finite_dimensional alg_equiv

section

variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

/-- A field extension E/F is galois if it is both separable and normal. Note that in mathlib
a separable extension of fields is by definition algebraic. -/
class is_galois : Prop :=
[to_is_separable : is_separable F E]
[to_normal : normal F E]

variables {F E}

theorem is_galois_iff : is_galois F E ↔ is_separable F E ∧ normal F E :=
⟨λ h, ⟨h.1, h.2⟩, λ h, { to_is_separable := h.1, to_normal := h.2 }⟩

attribute [instance, priority 100] -- see Note [lower instance priority]
is_galois.to_is_separable is_galois.to_normal

variables (F E)

namespace is_galois

instance self : is_galois F F :=
⟨⟩

variables (F) {E}

lemma integral [is_galois F E] (x : E) : is_integral F x := to_normal.is_integral x

lemma separable [is_galois F E] (x : E) : (minpoly F x).separable := is_separable.separable F x

lemma splits [is_galois F E] (x : E) : (minpoly F x).splits (algebra_map F E) := normal.splits' x

variables (F E)

instance of_fixed_field (G : Type*) [group G] [finite G] [mul_semiring_action G E] :
  is_galois (fixed_points.subfield G E) E :=
⟨⟩

lemma intermediate_field.adjoin_simple.card_aut_eq_finrank
  [finite_dimensional F E] {α : E} (hα : is_integral F α)
  (h_sep : (minpoly F α).separable)
  (h_splits : (minpoly F α).splits (algebra_map F F⟮α⟯)) :
  fintype.card (F⟮α⟯ ≃ₐ[F] F⟮α⟯) = finrank F F⟮α⟯ :=
begin
  letI : fintype (F⟮α⟯ →ₐ[F] F⟮α⟯) := intermediate_field.fintype_of_alg_hom_adjoin_integral F hα,
  rw intermediate_field.adjoin.finrank hα,
  rw ← intermediate_field.card_alg_hom_adjoin_integral F hα h_sep h_splits,
  exact fintype.card_congr (alg_equiv_equiv_alg_hom F F⟮α⟯)
end

lemma card_aut_eq_finrank [finite_dimensional F E] [is_galois F E] :
  fintype.card (E ≃ₐ[F] E) = finrank F E :=
begin
  cases field.exists_primitive_element F E with α hα,
  let iso : F⟮α⟯ ≃ₐ[F] E :=
  { to_fun := λ e, e.val,
    inv_fun := λ e, ⟨e, by { rw hα, exact intermediate_field.mem_top }⟩,
    left_inv := λ _, by { ext, refl },
    right_inv := λ _, rfl,
    map_mul' := λ _ _, rfl,
    map_add' := λ _ _, rfl,
    commutes' := λ _, rfl },
  have H : is_integral F α := is_galois.integral F α,
  have h_sep : (minpoly F α).separable := is_galois.separable F α,
  have h_splits : (minpoly F α).splits (algebra_map F E) := is_galois.splits F α,
  replace h_splits : polynomial.splits (algebra_map F F⟮α⟯) (minpoly F α),
  { have p : iso.symm.to_alg_hom.to_ring_hom.comp (algebra_map F E) = (algebra_map F ↥F⟮α⟯),
    { ext, simp, },
    simpa [p] using polynomial.splits_comp_of_splits
      (algebra_map F E) iso.symm.to_alg_hom.to_ring_hom h_splits, },
  rw ← linear_equiv.finrank_eq iso.to_linear_equiv,
  rw ← intermediate_field.adjoin_simple.card_aut_eq_finrank F E H h_sep h_splits,
  apply fintype.card_congr,
  apply equiv.mk (λ ϕ, iso.trans (trans ϕ iso.symm)) (λ ϕ, iso.symm.trans (trans ϕ iso)),
  { intro ϕ, ext1, simp only [trans_apply, apply_symm_apply] },
  { intro ϕ, ext1, simp only [trans_apply, symm_apply_apply] },
end

end is_galois

end

section is_galois_tower

variables (F K E : Type*) [field F] [field K] [field E] {E' : Type*} [field E'] [algebra F E']
variables [algebra F K] [algebra F E] [algebra K E] [is_scalar_tower F K E]

lemma is_galois.tower_top_of_is_galois [is_galois F E] : is_galois K E :=
{ to_is_separable := is_separable_tower_top_of_is_separable F K E,
  to_normal := normal.tower_top_of_normal F K E }

variables {F E}

@[priority 100] -- see Note [lower instance priority]
instance is_galois.tower_top_intermediate_field (K : intermediate_field F E) [h : is_galois F E] :
  is_galois K E := is_galois.tower_top_of_is_galois F K E

lemma is_galois_iff_is_galois_bot : is_galois (⊥ : intermediate_field F E) E ↔ is_galois F E :=
begin
  split,
  { introI h,
    exact is_galois.tower_top_of_is_galois (⊥ : intermediate_field F E) F E },
  { introI h, apply_instance },
end

lemma is_galois.of_alg_equiv [h : is_galois F E] (f : E ≃ₐ[F] E') : is_galois F E' :=
{ to_is_separable := is_separable.of_alg_hom F E f.symm, to_normal := normal.of_alg_equiv f }

lemma alg_equiv.transfer_galois (f : E ≃ₐ[F] E') : is_galois F E ↔ is_galois F E' :=
⟨λ h, by exactI is_galois.of_alg_equiv f, λ h, by exactI is_galois.of_alg_equiv f.symm⟩

lemma is_galois_iff_is_galois_top : is_galois F (⊤ : intermediate_field F E) ↔ is_galois F E :=
(intermediate_field.top_equiv : (⊤ : intermediate_field F E) ≃ₐ[F] E).transfer_galois

instance is_galois_bot : is_galois F (⊥ : intermediate_field F E) :=
(intermediate_field.bot_equiv F E).transfer_galois.mpr (is_galois.self F)

end is_galois_tower

section galois_correspondence

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]
variables (H : subgroup (E ≃ₐ[F] E)) (K : intermediate_field F E)

/-- The intermediate field of fixed points fixed by a monoid action that commutes with the
`F`-action on `E`. -/
def fixed_points.intermediate_field (M : Type*) [monoid M] [mul_semiring_action M E]
  [smul_comm_class M F E] : intermediate_field F E :=
{ carrier := mul_action.fixed_points M E,
  algebra_map_mem' := λ a g, by rw [algebra.algebra_map_eq_smul_one, smul_comm, smul_one],
  ..fixed_points.subfield M E }

namespace intermediate_field

/-- The intermediate_field fixed by a subgroup -/
def fixed_field : intermediate_field F E :=
fixed_points.intermediate_field H

lemma finrank_fixed_field_eq_card [finite_dimensional F E] [decidable_pred (∈ H)] :
  finrank (fixed_field H) E = fintype.card H :=
fixed_points.finrank_eq_card H E

/-- The subgroup fixing an intermediate_field -/
def fixing_subgroup : subgroup (E ≃ₐ[F] E) :=
fixing_subgroup (E ≃ₐ[F] E) (K : set E)

lemma le_iff_le : K ≤ fixed_field H ↔ H ≤ fixing_subgroup K :=
⟨λ h g hg x, h (subtype.mem x) ⟨g, hg⟩, λ h x hx g, h (subtype.mem g) ⟨x, hx⟩⟩

/-- The fixing_subgroup of `K : intermediate_field F E` is isomorphic to `E ≃ₐ[K] E` -/
def fixing_subgroup_equiv : fixing_subgroup K ≃* (E ≃ₐ[K] E) :=
{ to_fun := λ ϕ, { commutes' := ϕ.mem, ..alg_equiv.to_ring_equiv ↑ϕ },
  inv_fun := λ ϕ, ⟨ϕ.restrict_scalars _, ϕ.commutes⟩,
  left_inv := λ _, by { ext, refl },
  right_inv := λ _, by { ext, refl },
  map_mul' := λ _ _, by { ext, refl } }

theorem fixing_subgroup_fixed_field [finite_dimensional F E] :
  fixing_subgroup (fixed_field H) = H :=
begin
  have H_le : H ≤ (fixing_subgroup (fixed_field H)) := (le_iff_le _ _).mp le_rfl,
  classical,
  suffices : fintype.card H = fintype.card (fixing_subgroup (fixed_field H)),
  { exact set_like.coe_injective
      (set.eq_of_inclusion_surjective ((fintype.bijective_iff_injective_and_card
        (set.inclusion H_le)).mpr ⟨set.inclusion_injective H_le, this⟩).2).symm },
  apply fintype.card_congr,
  refine (fixed_points.to_alg_hom_equiv H E).trans _,
  refine (alg_equiv_equiv_alg_hom (fixed_field H) E).to_equiv.symm.trans _,
  exact (fixing_subgroup_equiv (fixed_field H)).to_equiv.symm
end

instance fixed_field.algebra : algebra K (fixed_field (fixing_subgroup K)) :=
{ smul := λ x y, ⟨x*y, λ ϕ, by rw [smul_mul', (show ϕ • ↑x = ↑x, by exact subtype.mem ϕ x),
    (show ϕ • ↑y = ↑y, by exact subtype.mem y ϕ)]⟩,
  to_fun := λ x, ⟨x, λ ϕ, subtype.mem ϕ x⟩,
  map_zero' := rfl,
  map_add' := λ _ _, rfl,
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  commutes' := λ _ _, mul_comm _ _,
  smul_def' := λ _ _, rfl }

instance fixed_field.is_scalar_tower : is_scalar_tower K (fixed_field (fixing_subgroup K)) E :=
⟨λ _ _ _, mul_assoc _ _ _⟩

end intermediate_field

namespace is_galois
theorem fixed_field_fixing_subgroup [finite_dimensional F E] [h : is_galois F E] :
  intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) = K :=
begin
  have K_le : K ≤ intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) :=
    (intermediate_field.le_iff_le _ _).mpr le_rfl,
  suffices : finrank K E =
    finrank (intermediate_field.fixed_field (intermediate_field.fixing_subgroup K)) E,
  { exact (intermediate_field.eq_of_le_of_finrank_eq' K_le this).symm },
  classical,
  rw [intermediate_field.finrank_fixed_field_eq_card,
    fintype.card_congr (intermediate_field.fixing_subgroup_equiv K).to_equiv],
  exact (card_aut_eq_finrank K E).symm,
end

lemma card_fixing_subgroup_eq_finrank [decidable_pred (∈ intermediate_field.fixing_subgroup K)]
  [finite_dimensional F E] [is_galois F E] :
  fintype.card (intermediate_field.fixing_subgroup K) = finrank K E :=
by conv { to_rhs, rw [←fixed_field_fixing_subgroup K,
  intermediate_field.finrank_fixed_field_eq_card] }

/-- The Galois correspondence from intermediate fields to subgroups -/
def intermediate_field_equiv_subgroup [finite_dimensional F E] [is_galois F E] :
  intermediate_field F E ≃o (subgroup (E ≃ₐ[F] E))ᵒᵈ :=
{ to_fun := intermediate_field.fixing_subgroup,
  inv_fun := intermediate_field.fixed_field,
  left_inv := λ K, fixed_field_fixing_subgroup K,
  right_inv := λ H, intermediate_field.fixing_subgroup_fixed_field H,
  map_rel_iff' := λ K L, by { rw [←fixed_field_fixing_subgroup L, intermediate_field.le_iff_le,
                                  fixed_field_fixing_subgroup L], refl } }

/-- The Galois correspondence as a galois_insertion -/
def galois_insertion_intermediate_field_subgroup [finite_dimensional F E] :
  galois_insertion (order_dual.to_dual ∘
      (intermediate_field.fixing_subgroup : intermediate_field F E → subgroup (E ≃ₐ[F] E)))
    ((intermediate_field.fixed_field : subgroup (E ≃ₐ[F] E) → intermediate_field F E) ∘
      order_dual.to_dual) :=
{ choice := λ K _, intermediate_field.fixing_subgroup K,
  gc := λ K H, (intermediate_field.le_iff_le H K).symm,
  le_l_u := λ H, le_of_eq (intermediate_field.fixing_subgroup_fixed_field H).symm,
  choice_eq := λ K _, rfl }

/-- The Galois correspondence as a galois_coinsertion -/
def galois_coinsertion_intermediate_field_subgroup [finite_dimensional F E] [is_galois F E] :
  galois_coinsertion (order_dual.to_dual ∘
      (intermediate_field.fixing_subgroup : intermediate_field F E → subgroup (E ≃ₐ[F] E)))
    ((intermediate_field.fixed_field : subgroup (E ≃ₐ[F] E) → intermediate_field F E) ∘
      order_dual.to_dual) :=
{ choice := λ H _, intermediate_field.fixed_field H,
  gc := λ K H, (intermediate_field.le_iff_le H K).symm,
  u_l_le := λ K, le_of_eq (fixed_field_fixing_subgroup K),
  choice_eq := λ H _, rfl }

end is_galois

end galois_correspondence

section galois_equivalent_definitions

variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

namespace is_galois

lemma is_separable_splitting_field [finite_dimensional F E] [is_galois F E] :
  ∃ p : F[X], p.separable ∧ p.is_splitting_field F E :=
begin
  cases field.exists_primitive_element F E with α h1,
  use [minpoly F α, separable F α, is_galois.splits F α],
  rw [eq_top_iff, ←intermediate_field.top_to_subalgebra, ←h1],
  rw intermediate_field.adjoin_simple_to_subalgebra_of_integral (integral F α),
  apply algebra.adjoin_mono,
  rw [set.singleton_subset_iff, finset.mem_coe, multiset.mem_to_finset, polynomial.mem_roots],
  { dsimp only [polynomial.is_root],
    rw [polynomial.eval_map, ←polynomial.aeval_def],
    exact minpoly.aeval _ _ },
  { exact polynomial.map_ne_zero (minpoly.ne_zero (integral F α)) }
end

lemma of_fixed_field_eq_bot [finite_dimensional F E]
  (h : intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E)) = ⊥) : is_galois F E :=
begin
  rw [←is_galois_iff_is_galois_bot, ←h],
  classical,
  exact is_galois.of_fixed_field E (⊤ : subgroup (E ≃ₐ[F] E)),
end

lemma of_card_aut_eq_finrank [finite_dimensional F E]
  (h : fintype.card (E ≃ₐ[F] E) = finrank F E) : is_galois F E :=
begin
  apply of_fixed_field_eq_bot,
  have p : 0 < finrank (intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E))) E := finrank_pos,
  classical,
  rw [←intermediate_field.finrank_eq_one_iff, ←mul_left_inj' (ne_of_lt p).symm, finrank_mul_finrank,
      ←h, one_mul, intermediate_field.finrank_fixed_field_eq_card],
  apply fintype.card_congr,
  exact { to_fun := λ g, ⟨g, subgroup.mem_top g⟩, inv_fun := coe,
          left_inv := λ g, rfl, right_inv := λ _, by { ext, refl } },
end

variables {F} {E} {p : F[X]}

lemma of_separable_splitting_field_aux
  [hFE : finite_dimensional F E]
  [sp : p.is_splitting_field F E] (hp : p.separable)
  (K : Type*) [field K] [algebra F K] [algebra K E] [is_scalar_tower F K E]
  {x : E} (hx : x ∈ (p.map (algebra_map F E)).roots)
  -- these are both implied by `hFE`, but as they carry data this makes the lemma more general
  [fintype (K →ₐ[F] E)] [fintype (K⟮x⟯.restrict_scalars F →ₐ[F] E)] :
  fintype.card (K⟮x⟯.restrict_scalars F →ₐ[F] E) =
    fintype.card (K →ₐ[F] E) * finrank K K⟮x⟯ :=
begin
  have h : is_integral K x := is_integral_of_is_scalar_tower
    (is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) x),
  have h1 : p ≠ 0 := λ hp, by rwa [hp, polynomial.map_zero, polynomial.roots_zero] at hx,
  have h2 : (minpoly K x) ∣ p.map (algebra_map F K),
  { apply minpoly.dvd,
    rw [polynomial.aeval_def, polynomial.eval₂_map, ←polynomial.eval_map,
      ←is_scalar_tower.algebra_map_eq],
    exact (polynomial.mem_roots (polynomial.map_ne_zero h1)).mp hx },
  let key_equiv : (K⟮x⟯.restrict_scalars F →ₐ[F] E) ≃ Σ (f : K →ₐ[F] E),
    @alg_hom K K⟮x⟯ E _ _ _ _ (ring_hom.to_algebra f),
  { change (K⟮x⟯ →ₐ[F] E) ≃ Σ (f : K →ₐ[F] E), _,
    exact alg_hom_equiv_sigma },
  haveI : Π (f : K →ₐ[F] E), fintype (@alg_hom K K⟮x⟯ E _ _ _ _ (ring_hom.to_algebra f)) := λ f, by
  { apply fintype.of_injective (sigma.mk f) (λ _ _ H, eq_of_heq ((sigma.mk.inj H).2)),
    exact fintype.of_equiv _ key_equiv },
  rw [fintype.card_congr key_equiv, fintype.card_sigma, intermediate_field.adjoin.finrank h],
  apply finset.sum_const_nat,
  intros f hf,
  rw ← @intermediate_field.card_alg_hom_adjoin_integral K _ E _ _ x E _ (ring_hom.to_algebra f) h,
  { apply fintype.card_congr, refl },
  { exact polynomial.separable.of_dvd ((polynomial.separable_map (algebra_map F K)).mpr hp) h2 },
  { refine polynomial.splits_of_splits_of_dvd _ (polynomial.map_ne_zero h1) _ h2,
    rw [polynomial.splits_map_iff, ←is_scalar_tower.algebra_map_eq],
    exact sp.splits },
end

lemma of_separable_splitting_field [sp : p.is_splitting_field F E] (hp : p.separable) :
  is_galois F E :=
begin
  haveI hFE : finite_dimensional F E := polynomial.is_splitting_field.finite_dimensional E p,
  letI := classical.dec_eq E,
  let s := (p.map (algebra_map F E)).roots.to_finset,
  have adjoin_root : intermediate_field.adjoin F ↑s = ⊤,
  { apply intermediate_field.to_subalgebra_injective,
    rw [intermediate_field.top_to_subalgebra, ←top_le_iff, ←sp.adjoin_roots],
    apply intermediate_field.algebra_adjoin_le_adjoin, },
  let P : intermediate_field F E → Prop := λ K, fintype.card (K →ₐ[F] E) = finrank F K,
  suffices : P (intermediate_field.adjoin F ↑s),
  { rw adjoin_root at this,
    apply of_card_aut_eq_finrank,
    rw ← eq.trans this (linear_equiv.finrank_eq intermediate_field.top_equiv.to_linear_equiv),
    exact fintype.card_congr ((alg_equiv_equiv_alg_hom F E).to_equiv.trans
      (intermediate_field.top_equiv.symm.arrow_congr alg_equiv.refl)) },
  apply intermediate_field.induction_on_adjoin_finset s P,
  { have key := intermediate_field.card_alg_hom_adjoin_integral F
      (show is_integral F (0 : E), by exact is_integral_zero),
    rw [minpoly.zero, polynomial.nat_degree_X] at key,
    specialize key polynomial.separable_X (polynomial.splits_X (algebra_map F E)),
    rw [←@subalgebra.finrank_bot F E _ _ _, ←intermediate_field.bot_to_subalgebra] at key,
    refine eq.trans _ key,
    apply fintype.card_congr,
    rw intermediate_field.adjoin_zero },
  intros K x hx hK,
  simp only [P] at *,
  rw [of_separable_splitting_field_aux hp K (multiset.mem_to_finset.mp hx),
    hK, finrank_mul_finrank],
  symmetry,
  refine linear_equiv.finrank_eq _,
  refl,
end

/--Equivalent characterizations of a Galois extension of finite degree-/
theorem tfae [finite_dimensional F E] :
  tfae [is_galois F E,
    intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E)) = ⊥,
    fintype.card (E ≃ₐ[F] E) = finrank F E,
    ∃ p : F[X], p.separable ∧ p.is_splitting_field F E] :=
begin
  tfae_have : 1 → 2,
  { exact λ h, order_iso.map_bot (@intermediate_field_equiv_subgroup F _ E _ _ _ h).symm },
  tfae_have : 1 → 3,
  { introI _, exact card_aut_eq_finrank F E },
  tfae_have : 1 → 4,
  { introI _, exact is_separable_splitting_field F E },
  tfae_have : 2 → 1,
  { exact of_fixed_field_eq_bot F E },
  tfae_have : 3 → 1,
  { exact of_card_aut_eq_finrank F E },
  tfae_have : 4 → 1,
  { rintros ⟨h, hp1, _⟩, exactI of_separable_splitting_field hp1 },
  tfae_finish,
end

end is_galois

end galois_equivalent_definitions


import tactic

@[derive decidable_rel]
protected def myintrel : ℕ × ℕ → ℕ × ℕ → Prop := λ a b, a.1 + b.2 = b.1 + a.2

local infix `~` := myintrel

protected theorem myintrel.refl : ∀ n : ℕ × ℕ, n ~ n := λ n, rfl

protected theorem myintrel.symm : ∀ n m : ℕ × ℕ, n ~ m → m ~ n :=
  λ n m h, by { dsimp [myintrel] at *, symmetry, rw h, }

protected theorem myintrel.trans : ∀ n m k : ℕ × ℕ, n ~ m → m ~ k → n ~ k :=
  by { dsimp [myintrel], intros n m k h₁ h₂, linarith, }

protected theorem is_equivalence :
  equivalence myintrel := mk_equivalence myintrel myintrel.refl myintrel.symm myintrel.trans

instance myint.setoid : setoid (ℕ × ℕ) := setoid.mk myintrel is_equivalence

def myint := quotient myint.setoid

namespace myint

def mk (a₁ a₂ : ℕ) : myint := ⟦(a₁, a₂)⟧

notation `[[` a₁ `,` a₂ `]]` := mk a₁ a₂

example : [[1, 6]] = [[10, 15]] := dec_trivial

@[derive decidable] private def is_nonneg' (n : ℕ × ℕ) : Prop := n.1 ≥ n.2

example : is_nonneg' (10,8) := dec_trivial

def prod_nat_to_prod_nat (n : ℕ × ℕ) : ℕ × ℕ := if is_nonneg' n then (n.1-n.2, 0) else (0, n.2-n.1)

example : prod_nat_to_prod_nat (5,7) = (0, 2) := rfl

example : prod_nat_to_prod_nat (13, 4) = (9, 0) := rfl

def prod_nat_to_string (n : ℕ × ℕ) : string :=
  if is_nonneg' n then to_string (n.1-n.2) else  "-" ++ to_string (n.2 - n.1)

lemma prod_nat_of_is_nonneg {n : ℕ × ℕ} (h : is_nonneg' n) :
  prod_nat_to_prod_nat n = (n.1 - n.2, 0) := if_pos h

lemma prod_nat_of_is_neg {n : ℕ × ℕ} (h : ¬(is_nonneg' n)) :
  prod_nat_to_prod_nat n = (0, n.2 - n.1) := if_neg h

-- An auxiliary lemma needed only in the proof of `myint_to_prod_nat`.
private lemma aux {x y u v : nat} (h : x + v = u + y) (k : x ≥ y) : x - y = u - v :=
begin
  have h₂ : u = x - y + v := (nat.add_sub_cancel u y) ▸ h ▸ (nat.sub_add_comm k),
  rw [h₂, nat.add_sub_cancel],
end

/-
`myint_to_prod_nat` is our main workhorse. Given `n : myint`, it produces a canonical representative
of type `ℕ × ℕ`. To do this, we use `quotient.lift` - a result that shows a function of type `α → β`
can be lifted to a function of type `quotient s → β` as long as the function respects the
equivalence relation that defines `quotient s`.
-/
def myint_to_prod_nat (n : myint) : ℕ × ℕ :=
begin
  apply quotient.lift_on n prod_nat_to_prod_nat,
  dsimp [has_equiv.equiv, setoid.r, myintrel, prod_nat_to_prod_nat],
  intros a b h,
  split_ifs; unfold is_nonneg' at *,
  { ext, { dsimp, rwa aux h, }, refl, },
  iterate 2 { ext; { dsimp, exfalso, linarith }, },
  { ext; dsimp, { refl }, { apply aux; linarith }, },
end

example : myint_to_prod_nat [[10, 4]] = (6,0) := rfl

@[derive decidable]
def is_nonneg : myint → Prop := is_nonneg' ∘ myint_to_prod_nat

example : is_nonneg [[10, 3]] := dec_trivial

def myint_to_string : myint → string := prod_nat_to_string ∘ myint_to_prod_nat

instance myint_repr : has_repr myint := ⟨myint_to_string⟩

instance has_coe_to_myint : has_coe nat (quotient myint.setoid) := ⟨λ n, [[n,0]]⟩

instance has_one_myint : has_one myint := ⟨[[1, 0]]⟩

instance has_zero_myint : has_zero myint := ⟨[[0, 0]]⟩

protected def neg_pair (n : ℕ × ℕ) : myint := [[n.2, n.1]]

/-
The definition `neg` below uses `quotient.sound`. This result states that two elements `⟦a⟧` and `⟦b⟧`
of a quotient type are equal if their representatives are equivalent. That is, `a ≈ b → ⟦a⟧ = ⟦b⟧`.
-/
def neg (n : myint) : quotient myint.setoid :=
quotient.lift_on n myint.neg_pair
( λ a b h, quotient.sound (by {dsimp [has_equiv.equiv, setoid.r, myintrel] at h ⊢,
    simp only [add_comm, h], }))

instance has_neg_myint : has_neg myint := ⟨neg⟩

example : - [[5, 9]] = [[9, 5]] := rfl

def add_pair (n m : ℕ × ℕ) : myint := [[n.1 + m.1, n.2 + m.2]]

def add : myint → myint → myint :=
quotient.lift₂ add_pair
( λ a₁ a₂ b₁ b₂ h₁ h₂, quot.sound (by {dsimp [has_equiv.equiv, setoid.r, myintrel] at *, linarith,}))

instance has_add_myint : has_add myint := ⟨add⟩

instance has_add_myint' : has_add (quotient myint.setoid) := ⟨add⟩

instance has_sub_myint : has_sub myint := ⟨λ a b, a + -b⟩

example : is_nonneg (10 : myint) := dec_trivial

example : ¬(is_nonneg (-10 : myint)) := dec_trivial

example : [[6, 8]] + [[5, 1]] = [[2, 0]] := dec_trivial

#eval [[6, 8]] + [[5, 36]] -- outputs `-33`.

#eval ((5 - 78) : myint) -- outputs `-73`.

end myint


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Devon Tuma
-/
import probability.probability_mass_function.monad

/-!
# Specific Constructions of Probability Mass Functions

This file gives a number of different `pmf` constructions for common probability distributions.

`map` and `seq` allow pushing a `pmf α` along a function `f : α → β` (or distribution of
functions `f : pmf (α → β)`) to get a `pmf β`

`of_finset` and `of_fintype` simplify the construction of a `pmf α` from a function `f : α → ℝ≥0∞`,
by allowing the "sum equals 1" constraint to be in terms of `finset.sum` instead of `tsum`.

`normalize` constructs a `pmf α` by normalizing a function `f : α → ℝ≥0∞` by its sum,
and `filter` uses this to filter the support of a `pmf` and re-normalize the new distribution.

`bernoulli` represents the bernoulli distribution on `bool`

-/

namespace pmf

noncomputable theory
variables {α β γ : Type*}
open_locale classical big_operators nnreal ennreal

section map

/-- The functorial action of a function on a `pmf`. -/
def map (f : α → β) (p : pmf α) : pmf β := bind p (pure ∘ f)

variables (f : α → β) (p : pmf α) (b : β)

lemma monad_map_eq_map {α β : Type*} (f : α → β) (p : pmf α) : f <$> p = p.map f := rfl

@[simp] lemma map_apply : (map f p) b = ∑' a, if b = f a then p a else 0 := by simp [map]

@[simp] lemma support_map : (map f p).support = f '' p.support :=
set.ext (λ b, by simp [map, @eq_comm β b])

lemma mem_support_map_iff : b ∈ (map f p).support ↔ ∃ a ∈ p.support, f a = b := by simp

lemma bind_pure_comp : bind p (pure ∘ f) = map f p := rfl

lemma map_id : map id p = p := bind_pure _

lemma map_comp (g : β → γ) : (p.map f).map g = p.map (g ∘ f) := by simp [map]

lemma pure_map (a : α) : (pure a).map f = pure (f a) := pure_bind _ _

lemma map_bind (q : α → pmf β) (f : β → γ) :
  (p.bind q).map f = p.bind (λ a, (q a).map f) := bind_bind _ _ _

@[simp]

@[simp] lemma map_const : p.map (function.const α b) = pure b :=
by simp only [map, bind_const, function.comp_const]

section measure

variable (s : set β)

@[simp] lemma to_outer_measure_map_apply :
  (p.map f).to_outer_measure s = p.to_outer_measure (f ⁻¹' s) :=
by simp [map, set.indicator, to_outer_measure_apply p (f ⁻¹' s)]

@[simp] lemma to_measure_map_apply [measurable_space α] [measurable_space β] (hf : measurable f)
  (hs : measurable_set s) : (p.map f).to_measure s = p.to_measure (f ⁻¹' s) :=
begin
  rw [to_measure_apply_eq_to_outer_measure_apply _ s hs,
    to_measure_apply_eq_to_outer_measure_apply _ (f ⁻¹' s) (measurable_set_preimage hf hs)],
  exact to_outer_measure_map_apply f p s,
end

end measure

end map

section seq

/-- The monadic sequencing operation for `pmf`. -/
def seq (q : pmf (α → β)) (p : pmf α) : pmf β := q.bind (λ m, p.bind $ λ a, pure (m a))

variables (q : pmf (α → β)) (p : pmf α) (b : β)

lemma monad_seq_eq_seq {α β : Type*} (q : pmf (α → β)) (p : pmf α) : q <*> p = q.seq p := rfl

@[simp] lemma seq_apply : (seq q p) b = ∑' (f : α → β) (a : α), if b = f a then q f * p a else 0 :=
begin
  simp only [seq, mul_boole, bind_apply, pure_apply],
  refine tsum_congr (λ f, (ennreal.tsum_mul_left).symm.trans (tsum_congr (λ a, _))),
  simpa only [mul_zero] using mul_ite (b = f a) (q f) (p a) 0
end

@[simp] lemma support_seq : (seq q p).support = ⋃ f ∈ q.support, f '' p.support :=
set.ext (λ b, by simp [-mem_support_iff, seq, @eq_comm β b])

lemma mem_support_seq_iff : b ∈ (seq q p).support ↔ ∃ (f ∈ q.support), b ∈ f '' p.support :=
by simp

end seq

instance : is_lawful_functor pmf :=
{ map_const_eq := λ α β, rfl,
  id_map := λ α, bind_pure,
  comp_map := λ α β γ g h x, (map_comp _ _ _).symm }

instance : is_lawful_monad pmf :=
{ bind_pure_comp_eq_map := λ α β f x, rfl,
  bind_map_eq_seq := λ α β f x, rfl,
  pure_bind := λ α β, pure_bind,
  bind_assoc := λ α β γ, bind_bind }

section of_finset

/-- Given a finset `s` and a function `f : α → ℝ≥0∞` with sum `1` on `s`,
  such that `f a = 0` for `a ∉ s`, we get a `pmf` -/
def of_finset (f : α → ℝ≥0∞) (s : finset α) (h : ∑ a in s, f a = 1)
  (h' : ∀ a ∉ s, f a = 0) : pmf α :=
⟨f, h ▸ has_sum_sum_of_ne_finset_zero h'⟩

variables {f : α → ℝ≥0∞} {s : finset α} (h : ∑ a in s, f a = 1) (h' : ∀ a ∉ s, f a = 0)

@[simp] lemma of_finset_apply (a : α) : of_finset f s h h' a = f a := rfl

@[simp] lemma support_of_finset : (of_finset f s h h').support = s ∩ (function.support f) :=
set.ext (λ a, by simpa [mem_support_iff] using mt (h' a))

lemma mem_support_of_finset_iff (a : α) : a ∈ (of_finset f s h h').support ↔ a ∈ s ∧ f a ≠ 0 :=
by simp

lemma of_finset_apply_of_not_mem {a : α} (ha : a ∉ s) : of_finset f s h h' a = 0 :=
h' a ha

section measure

variable (t : set α)

@[simp] lemma to_outer_measure_of_finset_apply :
  (of_finset f s h h').to_outer_measure t = ∑' x, t.indicator f x :=
to_outer_measure_apply (of_finset f s h h') t

@[simp] lemma to_measure_of_finset_apply [measurable_space α] (ht : measurable_set t) :
  (of_finset f s h h').to_measure t = ∑' x, t.indicator f x :=
(to_measure_apply_eq_to_outer_measure_apply _ t ht).trans
  (to_outer_measure_of_finset_apply h h' t)

end measure

end of_finset

section of_fintype

/-- Given a finite type `α` and a function `f : α → ℝ≥0∞` with sum 1, we get a `pmf`. -/
def of_fintype [fintype α] (f : α → ℝ≥0∞) (h : ∑ a, f a = 1) : pmf α :=
of_finset f finset.univ h (λ a ha, absurd (finset.mem_univ a) ha)

variables [fintype α] {f : α → ℝ≥0∞} (h : ∑ a, f a = 1)

@[simp] lemma of_fintype_apply (a : α) : of_fintype f h a = f a := rfl

@[simp] lemma support_of_fintype : (of_fintype f h).support = function.support f := rfl

lemma mem_support_of_fintype_iff (a : α) : a ∈ (of_fintype f h).support ↔ f a ≠ 0 := iff.rfl

section measure

variable (s : set α)

@[simp] lemma to_outer_measure_of_fintype_apply :
  (of_fintype f h).to_outer_measure s = ∑' x, s.indicator f x :=
to_outer_measure_apply (of_fintype f h) s

@[simp] lemma to_measure_of_fintype_apply [measurable_space α] (hs : measurable_set s) :
  (of_fintype f h).to_measure s = ∑' x, s.indicator f x :=
(to_measure_apply_eq_to_outer_measure_apply _ s hs).trans
  (to_outer_measure_of_fintype_apply h s)

end measure

end of_fintype

section normalize

/-- Given a `f` with non-zero and non-infinite sum, get a `pmf` by normalizing `f` by its `tsum` -/
def normalize (f : α → ℝ≥0∞) (hf0 : tsum f ≠ 0) (hf : tsum f ≠ ∞) : pmf α :=
⟨λ a, f a * (∑' x, f x)⁻¹, ennreal.summable.has_sum_iff.2
  (ennreal.tsum_mul_right.trans (ennreal.mul_inv_cancel hf0 hf))⟩

variables {f : α → ℝ≥0∞} (hf0 : tsum f ≠ 0) (hf : tsum f ≠ ∞)

@[simp] lemma normalize_apply (a : α) : (normalize f hf0 hf) a = f a * (∑' x, f x)⁻¹ := rfl

@[simp] lemma support_normalize : (normalize f hf0 hf).support = function.support f :=
set.ext (λ a, by simp [hf, mem_support_iff])

lemma mem_support_normalize_iff (a : α) : a ∈ (normalize f hf0 hf).support ↔ f a ≠ 0 := by simp

end normalize

section filter

/-- Create new `pmf` by filtering on a set with non-zero measure and normalizing -/
def filter (p : pmf α) (s : set α) (h : ∃ a ∈ s, a ∈ p.support) : pmf α :=
pmf.normalize (s.indicator p) (by simpa using h) (p.tsum_coe_indicator_ne_top s)

variables {p : pmf α} {s : set α} (h : ∃ a ∈ s, a ∈ p.support)

@[simp]
lemma filter_apply (a : α) : (p.filter s h) a = (s.indicator p a) * (∑' a', (s.indicator p) a')⁻¹ :=
by rw [filter, normalize_apply]

lemma filter_apply_eq_zero_of_not_mem {a : α} (ha : a ∉ s) : (p.filter s h) a = 0 :=
by rw [filter_apply, set.indicator_apply_eq_zero.mpr (λ ha', absurd ha' ha), zero_mul]

lemma mem_support_filter_iff {a : α} : a ∈ (p.filter s h).support ↔ a ∈ s ∧ a ∈ p.support :=
(mem_support_normalize_iff _ _ _).trans set.indicator_apply_ne_zero

@[simp] lemma support_filter : (p.filter s h).support = s ∩ p.support:=
set.ext $ λ x, (mem_support_filter_iff _)

lemma filter_apply_eq_zero_iff (a : α) : (p.filter s h) a = 0 ↔ a ∉ s ∨ a ∉ p.support :=
by erw [apply_eq_zero_iff, support_filter, set.mem_inter_iff, not_and_distrib]

lemma filter_apply_ne_zero_iff (a : α) : (p.filter s h) a ≠ 0 ↔ a ∈ s ∧ a ∈ p.support :=
by rw [ne.def, filter_apply_eq_zero_iff, not_or_distrib, not_not, not_not]

end filter

section bernoulli

/-- A `pmf` which assigns probability `p` to `tt` and `1 - p` to `ff`. -/
def bernoulli (p : ℝ≥0∞) (h : p ≤ 1) : pmf bool :=
of_fintype (λ b, cond b p (1 - p)) (by simp [h])

variables {p : ℝ≥0∞} (h : p ≤ 1) (b : bool)

@[simp] lemma bernoulli_apply : bernoulli p h b = cond b p (1 - p) := rfl

@[simp] lemma support_bernoulli : (bernoulli p h).support = {b | cond b (p ≠ 0) (p ≠ 1)} :=
begin
  refine set.ext (λ b, _),
  induction b,
  { simp_rw [mem_support_iff, bernoulli_apply, bool.cond_ff, ne.def, tsub_eq_zero_iff_le, not_le],
    exact ⟨ne_of_lt, lt_of_le_of_ne h⟩ },
  { simp only [mem_support_iff, bernoulli_apply, bool.cond_tt, set.mem_set_of_eq], }
end

lemma mem_support_bernoulli_iff : b ∈ (bernoulli p h).support ↔ cond b (p ≠ 0) (p ≠ 1) := by simp

end bernoulli

end pmf


import logic.misc

attribute [reducible]
definition is_binary (p : Prop) : Prop := p ∨ ¬p

--- An "internal" version of decidability.
class idecidable (p : Prop) : Prop :=
  (is_either : is_binary p)

@[reducible]
definition idecidable_pred {α : Sort _} (p : α → Prop) :=
  ∀ a, idecidable (p a)

--- Class of types that has internally decidable equality.
@[reducible]
definition idecidable_eq (α : Sort _) : Prop := ∀ (a b : α), idecidable (a=b)

@[reducible]
def idecidable_rel {α : Sort _} (r : α → α → Prop) :=
  ∀ a b, idecidable (r a b)

@[elab_as_eliminator]
lemma whether (p : Prop) [idec : idecidable p] : p ∨ ¬ p :=
  idec.is_either

lemma not_binary {p : Prop} (hbp : is_binary p) : is_binary (¬p) :=
  begin
    apply or.elim hbp,
    show p → is_binary (¬p), { intro hp; right; exact not_not_intro hp},
    show ¬p → is_binary (¬p), { intro hnp; left; assumption },
  end

lemma or_binary {p q : Prop} (hbp : is_binary p) (hbq : is_binary q)  : is_binary (p∨ q) :=
  begin
    apply or.elim hbq; apply or.elim hbp,
    show p → q → is_binary (p∨ q), {
      intros hp hq,
      left; left; exact hp
    },
    show ¬p → q → is_binary (p∨ q), {
      intros hnp hq,
      left; right; exact hq
    },
    show p → ¬q → is_binary (p∨ q), {
      intros hp hnq,
      left; left; exact hp
    },
    show ¬p → ¬q → is_binary (p∨ q), {
      intros hnp hnq,
      right, intros hnpq,
      apply or.elim hnpq; intros; contradiction
    }
  end

lemma and_binary {p q : Prop} (hbp : is_binary p) (hbq : is_binary q) : is_binary (p∧q) :=
  begin
    apply or.elim hbq; apply or.elim hbp,
    show p → q → is_binary (p∧q), {
      intros hp hq,
      left; exact ⟨hp,hq⟩
    },
    show ¬p → q → is_binary (p∧q), {
      intros hnp hq,
      right; intros hnpq,
      exact hnp hnpq.left
    },
    show p → ¬q → is_binary (p∧q), {
      intros hp hnq,
      right; intros hnpq,
      exact hnq hnpq.right
    },
    show ¬p → ¬q → is_binary (p∧q), {
      intros hnp hnq,
      right; intros hnpq,
      exact hnp hnpq.left
    },
  end

lemma xor_binary {p q : Prop} (hbp : is_binary p) (hbq : is_binary q) : is_binary (xor p q) :=
  begin
    have hbnp : is_binary ¬p, from not_binary hbp,
    have hbnq : is_binary ¬q, from not_binary hbq,
    apply or_binary; apply and_binary; assumption
  end

instance not_idecidable (p : Prop) [idecidable p] : idecidable ¬p :=
  {is_either := not_binary (whether p)}
instance or_idecidable (p q : Prop) [idecidable p] [idecidable q] : idecidable (p∨q) :=
  {is_either := or_binary (whether p) (whether q)}
instance and_idecidable (p q : Prop) [idecidable p] [idecidable q] : idecidable (p∧q) :=
  {is_either := and_binary (whether p) (whether q)}
instance xor_idecidable (p q : Prop) [idecidable p] [idecidable q] : idecidable (xor p q) :=
  {is_either := xor_binary (whether p) (whether q)}

#print axioms xor_idecidable

lemma not_xor_iff {p q : Prop} [idecidable p] [idecidable q] : ¬xor p q → (p ↔ q) :=
  begin
    intros hnx,
    let h := not_or_distrib.mp hnx,
    apply or.elim (whether q); apply or.elim (whether p),
    show p → q → (p↔ q),
      from λ hp hq, {mp := (λ _, hq), mpr := (λ _, hp)},
    show ¬p → q → (p↔ q),
      from λ hnp hq, (h.right ⟨hq,hnp⟩).elim,
    show p → ¬q → (p↔ q),
      from λ hp hnq, (h.left ⟨hp,hnq⟩).elim,
    show ¬p → ¬q → (p↔ q),
      from λ hnp hnq, {mp := (λ hp, (hnp hp).elim), mpr := (λ hq, (hnq hq).elim)}
  end

private
lemma xor_assoc_impl (p q r : Prop) [idecidable p] [idecidable q] [idecidable r] : xor (xor p q) r → xor p (xor q r) :=
  begin
    intros h,
    apply or.elim h,
    show (xor p q) ∧ ¬r → xor p (xor q r), {
      intros hpqr,
      apply or.elim (whether r),
      show r → xor p (xor q r), {intro hr; exfalso; exact hpqr.right hr},
      intros hnr,
      apply or.elim hpqr.left,
      show p∧¬q → xor p (xor q r), {
        intros hpq,
        left; split; try {exact hpq.left},
        intros hx; apply or.elim hx,
        show q∧¬r → false, {
          intros hqr,
          exact hpq.right hqr.left
        },
        show r∧¬q → false, {
          intros hrq,
          exact hnr hrq.left
        },
      },
      show q∧¬p → xor p (xor q r), {
        intros hqr,
        right; split; try {exact hqr.right},
        exact or.inl ⟨hqr.left,hnr⟩
      }
    },
    show r ∧ ¬xor p q → xor p (xor q r), {
      intros hrpq,
      have hpq : p↔q, from not_xor_iff hrpq.right,
      apply or.elim (whether p),
      show p → xor p (xor q r), {
        intros hp,
        left; split; try {assumption},
        intros hx,
        apply or.elim hx,
        show q ∧ ¬r → false, {
          intro hqr,
          exact hqr.right hrpq.left
        },
        show r ∧ ¬q → false, {
          intro hrq,
          exact hrq.right (hpq.mp hp)
        },
      },
      show ¬p → xor p (xor q r), {
        intros hnp,
        right; split; try {assumption},
        right,
        exact ⟨hrpq.left, (λ hq, hnp (hpq.mpr hq))⟩
      }
    },
  end

definition xor_assoc (p q r : Prop) [idecidable p] [idecidable q] [idecidable r] : xor (xor p q) r ↔ xor p (xor q r) :=
{
  mp := xor_assoc_impl p q r,
  mpr :=
    by calc
      xor p (xor q r)
          → xor p (xor r q) : (xor_congr iff.rfl (xor_comm q r)).mp
      ... → xor (xor r q) p : (xor_comm p (xor r q)).mp
      ... → xor r (xor q p) : xor_assoc_impl r q p
      ... → xor r (xor p q) : (xor_congr iff.rfl (xor_comm q p)).mp
      ... → xor (xor p q) r : (xor_comm r (xor p q)).mp
}

#print axioms xor_assoc


import ..basic
       ring_theory.algebra
       linear_algebra.tensor_product
       ring_theory.ideal_operations
       category_theory.concrete_category
open set

universes u v w

/- move to ideal-/
namespace ideal
namespace quotient
variables {α : Type*} {β : Type*} [comm_ring α] [comm_ring β] {S : ideal α} {T : ideal β}
  {f : α → β} {H : ∀ {{a : α}}, a ∈ S → f a ∈ T}

-- replace lift
def lift' (S : ideal α) (f : α → β) [is_add_group_hom f] (H : ∀ (a : α), a ∈ S → f a = 0) :
  quotient S → β :=
λ x, quotient.lift_on' x f $ λ (a b) (h : _ ∈ _),
eq_of_sub_eq_zero (by simpa only [is_add_group_hom.map_sub f] using H _ h)

def map (S : ideal α) (T : ideal β) (f : α → β) [is_add_group_hom f]
  (H : ∀ {{a : α}}, a ∈ S → f a ∈ T) : quotient S → quotient T :=
begin
  haveI : is_add_group_hom ((mk T : β → quotient T) ∘ f) := is_add_group_hom.comp _ _,
  refine ideal.quotient.lift' S (mk T ∘ f) _,
  intros x hx, refine ideal.quotient.eq.2 _, rw [sub_zero], exact H hx
end

@[simp] lemma map_mk' [is_add_group_hom f] (x : α) : map S T f H (mk S x) = mk T (f x) := rfl

instance map.is_ring_hom [is_ring_hom f] : is_ring_hom (map S T f H) :=
by dsimp [map]; exact omitted

end quotient
end ideal

/- move to module -/

section module

variables {R : Type u} {S : Type*} [ring R]
variables {M : Type*} [add_comm_group M]
variables [module R M]

instance smul.is_add_group_hom {r : R} : is_add_group_hom (λ x : M, r • x) :=
by refine_struct {..}; simp [smul_add]

def quotient_add_group.quotient.module {s : set M} [normal_add_subgroup s]
  (h : ∀(r : R) {x : M}, x ∈ s → r • x ∈ s) : module R (quotient_add_group.quotient s) :=
{ smul := λ r, quotient_add_group.map _ _ (λ(x : M), r • x) (λ x h', h r h'),
  smul_add := omitted,
  add_smul := omitted,
  mul_smul := omitted,
  one_smul := omitted,
  zero_smul := omitted,
  smul_zero := omitted }

end module

variables {R : Type u} {S : Type*} [comm_ring R] [comm_ring S]
variables {M : Type*} {N : Type*} {P : Type*} [ring M] [ring N] [ring P]
variables {A : Type*} {B : Type*} {A' : Type*} {B' : Type*} {X : Type*}
variables [comm_ring A] [comm_ring B] [comm_ring A'] [comm_ring B'] [comm_ring X]
variables [algebra R M] [algebra R N] [algebra R P]
variables [algebra R A] [algebra R B] [algebra R A'] [algebra R B'] [algebra R X]

notation M ` ⊗[`:100 R `] ` N:100 := tensor_product R M N

namespace algebra

/-- A R-module is an R-algebra if scalar multiplication commutes with multiplication -/
def of_module {R : Type u} {A : Type v} [comm_ring R] [ring A] [m : module R A]
  (h : ∀(r : R) (x y : A), r • x * y = x * r • y) : algebra R A :=
{ to_fun := λ r, r • 1,
  hom := ⟨one_smul R 1, by { intros, rw [h, one_mul, mul_smul] }, λ x y, add_smul x y 1⟩,
  commutes' := by { intros, rw [h, one_mul, ←h, mul_one] },
  smul_def' := by { intros, rw [h, one_mul] },
  ..m }

/-- The codomain of a ring homomorphism viewed as an algebra over the domain -/
def induced_algebra (f : R → S) [is_ring_hom f] : Type* := S
instance (f : R → S) [is_ring_hom f] : comm_ring (induced_algebra f) := _inst_2
instance (f : R → S) [is_ring_hom f] : algebra R (induced_algebra f) :=
algebra.of_ring_hom f (by apply_instance)

end algebra
open algebra
namespace alg_hom

/-- A ring homomorphism induces an algebra homomorphism -/
protected def of_ring_hom (f : R → S) [is_ring_hom f] : R →ₐ[R] induced_algebra f :=
{ to_fun := f,
  hom := by apply_instance,
  commutes' := λ r, rfl }

end alg_hom

open algebra

namespace tensor_product

/- short-ciruiting some type class inference -/
protected def add_comm_group' : add_comm_group (M ⊗[R] N) := by apply_instance
protected def module' : module R (M ⊗[R] N) := by apply_instance
local attribute [instance, priority 2000] tensor_product.add_comm_group' tensor_product.module'
  linear_map.module
protected def lmap_add_comm_group : add_comm_group (M ⊗[R] N →ₗ[R] M ⊗[R] N) := by apply_instance
protected def lmap_module : module R (M ⊗[R] N →ₗ[R] M ⊗[R] N) := by apply_instance
local attribute [instance, priority 2000]
  tensor_product.lmap_add_comm_group tensor_product.lmap_module

/-- The multiplication on the tensor product of two R-algebras as a bilinear map -/
protected def mul : M ⊗[R] N →ₗ[R] M ⊗[R] N →ₗ[R] M ⊗[R] N :=
begin
  refine tensor_product.lift ⟨λ m, ⟨λ n, _, omitted, omitted⟩, omitted, omitted⟩,
  refine tensor_product.lift ⟨λ m', ⟨λ n', _, omitted, omitted⟩, omitted, omitted⟩,
  exact tmul R (m * m') (n * n')
end

/-- The ring structure on the tensor product of two R-algebras -/
instance : ring (M ⊗[R] N) :=
{ mul := λ x y, tensor_product.mul.to_fun x y,
  mul_assoc := omitted,
  one := tmul R 1 1,
  one_mul := omitted,
  mul_one := omitted,
  left_distrib := omitted,
  right_distrib := omitted,
  ..tensor_product.add_comm_group M N }

lemma mul_def (m m' : M) (n n' : N) : tmul R m n * tmul R m' n' = tmul R (m * m') (n * n') := rfl

instance : comm_ring (A ⊗[R] B) :=
{ mul_comm := omitted,
  ..tensor_product.ring }

/-- The algebra structure on the tensor product of two R-algebras -/
instance : algebra R (M ⊗[R] N) := algebra.of_module omitted

@[simp] lemma algebra_map_tensor (r : R) : algebra_map (M ⊗[R] N) r = r • 1 := rfl

def tensor_inl : M →ₐ[R] M ⊗[R] N :=
{ to_fun := λ m, tmul R m 1,
  hom := ⟨rfl, by { intros, rw [mul_def, one_mul] }, λ x y, add_tmul x y 1⟩,
  commutes' := λ r, omitted }

def tensor_inr : N →ₐ[R] M ⊗[R] N :=
{ to_fun := λ n, tmul R 1 n,
  hom := omitted,
  commutes' := omitted }

def tensor_lift (f : A →ₐ[R] X) (g : B →ₐ[R] X) : A ⊗[R] B →ₐ[R] X :=
begin
  refine ⟨lift_aux _, _⟩,
  fapply linear_map.mk₂,
  exact (λ a b, f a * g b),
  all_goals {exact omitted}
end

def tensor_functor (f : A →ₐ[R] A') (g : B →ₐ[R] B') : A ⊗[R] B →ₐ[R] A' ⊗[R] B' :=
tensor_lift (tensor_inl.comp f) (tensor_inr.comp g)

def tensor_lift_equiv : ((A →ₐ[R] X) × (B →ₐ[R] X)) ≃ (A ⊗[R] B →ₐ[R] X) :=
⟨λ fg, tensor_lift fg.1 fg.2, λ f, ⟨f.comp tensor_inl, f.comp tensor_inr⟩, omitted, omitted⟩

end tensor_product

namespace quotient

def smul {I : ideal A} (r : R) : I.quotient → I.quotient :=
ideal.quotient.map _ _ (λ(x : A), r • x) (λ x h', by rw [smul_def]; exact I.mul_mem_left h')

@[simp] lemma smul_mk {I : ideal A} (r : R) (x : A) :
  quotient.smul r (ideal.quotient.mk I x) = ideal.quotient.mk I (r • x) :=
by refl

end quotient

instance quotient.algebra (I : ideal A) : algebra R I.quotient :=
{ smul := quotient.smul,
  smul_add := λ r x y, quotient.induction_on₂' x y $ λ a b, congr_arg (ideal.quotient.mk _) $
    smul_add r a b,
  add_smul := λ r s x, quotient.induction_on' x $ λ a, congr_arg (ideal.quotient.mk _) $
    add_smul r s a,
  mul_smul := λ r s x, quotient.induction_on' x $ λ a, congr_arg (ideal.quotient.mk _) $
    mul_smul r s a,
  one_smul := λ x, quotient.induction_on' x $ λ a, congr_arg (ideal.quotient.mk _) $
    by simp only [one_smul],
  zero_smul := λ x, quotient.induction_on' x $ λ a, congr_arg (ideal.quotient.mk _) $
    by simp only [zero_smul],
  smul_zero := λ r, congr_arg (ideal.quotient.mk _) $ by simp only [smul_zero],
  to_fun := ideal.quotient.mk I ∘ algebra_map A,
  commutes' := λ r x, quotient.induction_on' x $ λ a, congr_arg (ideal.quotient.mk _) $
    commutes r a,
  smul_def' := λ r x, quotient.induction_on' x $ λ a, congr_arg (ideal.quotient.mk _) $
    smul_def r a }

namespace algebra.quotient

def mk (I : ideal A) : A →ₐ[R] I.quotient :=
{ to_fun := ideal.quotient.mk I,
  hom := by apply_instance,
  commutes' := omitted }

def lift {I : ideal A} (f : A →ₐ[R] B) (H : ∀ (a : A), a ∈ I → f a = 0) : I.quotient →ₐ[R] B :=
{ to_fun := ideal.quotient.lift I f.to_fun H,
  hom := by apply_instance,
  commutes' := omitted }

def functor {I : ideal A} {J : ideal B} (f : A →ₐ[R] B) (H : ∀ (a : A), a ∈ I → f a ∈ J) :
  I.quotient →ₐ[R] J.quotient :=
lift ((mk J).comp f) omitted

end algebra.quotient

namespace pi

variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equiped with instances
variables (x y : Π i, f i) (i : I)

instance algebra (α) {r : comm_ring α} [∀ i, ring $ f i] [∀ i, algebra α $ f i] :
  algebra α (Π i : I, f i) :=
by { haveI : module α (Π i : I, f i) := infer_instance, exact algebra.of_module omitted }

end pi

namespace mv_polynomial

variables {σ : Type*} [decidable_eq σ] [decidable_eq R]

/-- (σ → A) → Hom[R-Alg](R[σ],A). Maybe this should replace aeval? -/
def aeval₂ (f : σ → A) : mv_polynomial σ R →ₐ[R] A :=
{ to_fun := eval₂ (algebra_map A) f,
  hom := ⟨eval₂_one _ _, λ _ _, eval₂_mul _ _, λ _ _, eval₂_add _ _⟩,
  commutes' := λ r, eval₂_C _ _ _ }

-- def alg_hom {σ τ : Type*} [decidable_eq σ] [decidable_eq τ] [decidable_eq R] :
--   mv_polynomial σ R →ₐ[R] mv_polynomial τ R :=
-- sorry

end mv_polynomial

open mv_polynomial
local attribute [instance, priority 0] classical.prop_decidable
/-- An algebra `β` is finitely generated over a ring `α` if there is a finite subset `s` of `β` such that every element of `β` can be expressed as a polynomial in the elements of `s` with coefficients in `α` -/
def is_finitely_generated (α : Type u) [comm_ring α] (β : Type v) [comm_ring β] [algebra α β] :
  Prop :=
∃(s : finset β), ∀(x : β), ∃(p : mv_polynomial {x // x ∈ s} α),
  p.eval₂ (algebra_map β) subtype.val = x

def is_finitely_generated_base (α : Type u) [comm_ring α] : is_finitely_generated α α :=
⟨∅, λ x, ⟨C x, eval₂_C _ _ _⟩⟩

/-- Every quotient algebra is finitely generated -/
lemma is_finitely_generated_quotient {α : Type u} [comm_ring α] {β : Type v} [comm_ring β]
  [algebra α β] [decidable_eq α] [decidable_eq β] (h : is_finitely_generated α β) (I : ideal β) :
  is_finitely_generated α (I.quotient) :=
omitted

/-- The tensor product of two finitely generated algebras is finitely generated -/
lemma is_finitely_generated_tensor (hA : is_finitely_generated R A)
  (hB : is_finitely_generated R B) : is_finitely_generated R (A ⊗[R] B) :=
omitted

/-- The type of algebras over a fixed commutative ring. -/
structure Algebra (R : Type u) [comm_ring R] : Type max u (v+1) :=
  (β : Type v)
  (ring : ring β)
  (algebra : algebra R β)

attribute [instance] Algebra.ring Algebra.algebra
instance : has_coe_to_sort (Algebra.{u v} R) := { S := Type v, coe := Algebra.β }
-- instance Algebra.ring' (x : Algebra R) : ring x := by apply_instance
-- instance Algebra.algebra' (x : Algebra R) : algebra R x := by apply_instance

open category_theory
/-- The category of algebras over a fixed commutative ring. -/
instance Algebra.category : category (Algebra.{u v} R) :=
{ hom   := λ a b, a.β →ₐ[R] b.β,
  id    := λ a, alg_hom.id R a,
  comp  := λ a b c f g, alg_hom.comp g f }


/-
Copyright (c) 2018 Violeta Hernández Palacios, Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Violeta Hernández Palacios, Mario Carneiro

! This file was ported from Lean 3 source module set_theory.ordinal.fixed_point
! leanprover-community/mathlib commit 0dd4319a17376eda5763cd0a7e0d35bbaaa50e83
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.SetTheory.Ordinal.Arithmetic
import Mathlib.SetTheory.Ordinal.Exponential

/-!
# Fixed points of normal functions

We prove various statements about the fixed points of normal ordinal functions. We state them in
three forms: as statements about type-indexed families of normal functions, as statements about
ordinal-indexed families of normal functions, and as statements about a single normal function. For
the most part, the first case encompasses the others.

Moreover, we prove some lemmas about the fixed points of specific normal functions.

## Main definitions and results

* `nfpFamily`, `nfpBFamily`, `nfp`: the next fixed point of a (family of) normal function(s).
* `fp_family_unbounded`, `fp_bfamily_unbounded`, `fp_unbounded`: the (common) fixed points of a
  (family of) normal function(s) are unbounded in the ordinals.
* `deriv_add_eq_mul_omega_add`: a characterization of the derivative of addition.
* `deriv_mul_eq_opow_omega_mul`: a characterization of the derivative of multiplication.
-/

noncomputable section

universe u v

open Function Order

namespace Ordinal

/-! ### Fixed points of type-indexed families of ordinals -/

section

variable {ι : Type u} {f : ι → Ordinal.{max u v} → Ordinal.{max u v}}

/-- The next common fixed point, at least `a`, for a family of normal functions.

This is defined for any family of functions, as the supremum of all values reachable by applying
finitely many functions in the family to `a`.

`Ordinal.nfpFamily_fp` shows this is a fixed point, `Ordinal.le_nfpFamily` shows it's at
least `a`, and `Ordinal.nfpFamily_le_fp` shows this is the least ordinal with these properties. -/
def nfpFamily (f : ι → Ordinal → Ordinal) (a : Ordinal) : Ordinal :=
  sup (List.foldr f a)
#align ordinal.nfp_family Ordinal.nfpFamily

theorem nfpFamily_eq_sup (f : ι → Ordinal.{max u v} → Ordinal.{max u v}) (a : Ordinal.{max u v}) :
    nfpFamily.{u, v} f a = sup.{u, v} (List.foldr f a) :=
  rfl
#align ordinal.nfp_family_eq_sup Ordinal.nfpFamily_eq_sup

theorem foldr_le_nfpFamily (f : ι → Ordinal → Ordinal)
    (a l) : List.foldr f a l ≤ nfpFamily.{u, v} f a :=
  le_sup.{u, v} _ _
#align ordinal.foldr_le_nfp_family Ordinal.foldr_le_nfpFamily

theorem le_nfpFamily (f : ι → Ordinal → Ordinal) (a) : a ≤ nfpFamily f a :=
  le_sup _ []
#align ordinal.le_nfp_family Ordinal.le_nfpFamily

theorem lt_nfpFamily {a b} : a < nfpFamily.{u, v} f b ↔ ∃ l, a < List.foldr f b l :=
  lt_sup.{u, v}
#align ordinal.lt_nfp_family Ordinal.lt_nfpFamily

theorem nfpFamily_le_iff {a b} : nfpFamily.{u, v} f a ≤ b ↔ ∀ l, List.foldr f a l ≤ b :=
  sup_le_iff
#align ordinal.nfp_family_le_iff Ordinal.nfpFamily_le_iff

theorem nfpFamily_le {a b} : (∀ l, List.foldr f a l ≤ b) → nfpFamily.{u, v} f a ≤ b :=
  sup_le.{u, v}
#align ordinal.nfp_family_le Ordinal.nfpFamily_le

theorem nfpFamily_monotone (hf : ∀ i, Monotone (f i)) : Monotone (nfpFamily.{u, v} f) :=
  fun _ _ h => sup_le.{u, v} fun l => (List.foldr_monotone hf l h).trans (le_sup.{u, v} _ l)
#align ordinal.nfp_family_monotone Ordinal.nfpFamily_monotone

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem apply_lt_nfpFamily (H : ∀ i, IsNormal (f i)) {a b} (hb : b < nfpFamily.{u, v} f a) (i) :
    f i b < nfpFamily.{u, v} f a :=
  let ⟨l, hl⟩ := lt_nfpFamily.1 hb
  lt_sup.2 ⟨i::l, (H i).strictMono hl⟩
#align ordinal.apply_lt_nfp_family Ordinal.apply_lt_nfpFamily

theorem apply_lt_nfpFamily_iff [Nonempty ι] (H : ∀ i, IsNormal (f i)) {a b} :
    (∀ i, f i b < nfpFamily.{u, v} f a) ↔ b < nfpFamily.{u, v} f a :=
  ⟨fun h =>
    lt_nfpFamily.2 <|
      let ⟨l, hl⟩ := lt_sup.1 <| h <| Classical.arbitrary ι
      ⟨l, ((H _).self_le b).trans_lt hl⟩,
    apply_lt_nfpFamily H⟩
#align ordinal.apply_lt_nfp_family_iff Ordinal.apply_lt_nfpFamily_iff

theorem nfpFamily_le_apply [Nonempty ι] (H : ∀ i, IsNormal (f i)) {a b} :
    (∃ i, nfpFamily.{u, v} f a ≤ f i b) ↔ nfpFamily.{u, v} f a ≤ b := by
  rw [← not_iff_not]
  push_neg
  exact apply_lt_nfpFamily_iff H
#align ordinal.nfp_family_le_apply Ordinal.nfpFamily_le_apply

theorem nfpFamily_le_fp (H : ∀ i, Monotone (f i)) {a b} (ab : a ≤ b) (h : ∀ i, f i b ≤ b) :
    nfpFamily.{u, v} f a ≤ b :=
  sup_le fun l => by
    by_cases hι : IsEmpty ι
    · skip
      rwa [Unique.eq_default l]
    · haveI := not_isEmpty_iff.1 hι
      induction' l with i l IH generalizing a
      · exact ab
      exact (H i (IH ab)).trans (h i)
#align ordinal.nfp_family_le_fp Ordinal.nfpFamily_le_fp

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem nfpFamily_fp {i} (H : IsNormal (f i)) (a) :
    f i (nfpFamily.{u, v} f a) = nfpFamily.{u, v} f a := by
  unfold nfpFamily
  rw [@IsNormal.sup.{u, v, v} _ H _ _ ⟨[]⟩]
  apply le_antisymm <;> refine' Ordinal.sup_le fun l => _
  · exact le_sup _ (i::l)
  · exact (H.self_le _).trans (le_sup _ _)
#align ordinal.nfp_family_fp Ordinal.nfpFamily_fp

theorem apply_le_nfpFamily [hι : Nonempty ι] {f : ι → Ordinal → Ordinal} (H : ∀ i, IsNormal (f i))
    {a b} : (∀ i, f i b ≤ nfpFamily.{u, v} f a) ↔ b ≤ nfpFamily.{u, v} f a := by
  refine' ⟨fun h => _, fun h i => _⟩
  · cases' hι with i
    exact ((H i).self_le b).trans (h i)
  rw [← nfpFamily_fp (H i)]
  exact (H i).monotone h
#align ordinal.apply_le_nfp_family Ordinal.apply_le_nfpFamily

theorem nfpFamily_eq_self {f : ι → Ordinal → Ordinal} {a} (h : ∀ i, f i a = a) :
    nfpFamily f a = a :=
  le_antisymm (sup_le fun l => by rw [List.foldr_fixed' h l]) <| le_nfpFamily f a
#align ordinal.nfp_family_eq_self Ordinal.nfpFamily_eq_self

-- Todo: This is actually a special case of the fact the intersection of club sets is a club set.
/-- A generalization of the fixed point lemma for normal functions: any family of normal functions
    has an unbounded set of common fixed points. -/
theorem fp_family_unbounded (H : ∀ i, IsNormal (f i)) :
    (⋂ i, Function.fixedPoints (f i)).Unbounded (· < ·) := fun a =>
  ⟨nfpFamily.{u, v} f a, fun s ⟨i, hi⟩ => by
    rw [← hi, mem_fixedPoints_iff]
    exact nfpFamily_fp.{u, v} (H i) a, (le_nfpFamily f a).not_lt⟩
#align ordinal.fp_family_unbounded Ordinal.fp_family_unbounded

/-- The derivative of a family of normal functions is the sequence of their common fixed points.

This is defined for all functions such that `Ordinal.derivFamily_zero`,
`Ordinal.derivFamily_succ`, and `Ordinal.derivFamily_limit` are satisfied. -/
def derivFamily (f : ι → Ordinal → Ordinal) (o : Ordinal) : Ordinal :=
  limitRecOn.{max u v} o (nfpFamily.{u, v} f 0) (fun _ IH => nfpFamily.{u, v} f (succ IH))
    fun a _ => bsup.{max u v, u} a
#align ordinal.deriv_family Ordinal.derivFamily

@[simp]
theorem derivFamily_zero (f : ι → Ordinal → Ordinal) :
    derivFamily.{u, v} f 0 = nfpFamily.{u, v} f 0 :=
  limitRecOn_zero _ _ _
#align ordinal.deriv_family_zero Ordinal.derivFamily_zero

@[simp]
theorem derivFamily_succ (f : ι → Ordinal → Ordinal) (o) :
    derivFamily.{u, v} f (succ o) = nfpFamily.{u, v} f (succ (derivFamily.{u, v} f o)) :=
  limitRecOn_succ _ _ _ _
#align ordinal.deriv_family_succ Ordinal.derivFamily_succ

theorem derivFamily_limit (f : ι → Ordinal → Ordinal) {o} :
    IsLimit o → derivFamily.{u, v} f o = bsup.{max u v, u} o fun a _ => derivFamily.{u, v} f a :=
  limitRecOn_limit _ _ _ _
#align ordinal.deriv_family_limit Ordinal.derivFamily_limit

theorem derivFamily_isNormal (f : ι → Ordinal → Ordinal) : IsNormal (derivFamily f) :=
  ⟨fun o => by rw [derivFamily_succ, ← succ_le_iff]; apply le_nfpFamily, fun o l a => by
    rw [derivFamily_limit _ l, bsup_le_iff]⟩
#align ordinal.deriv_family_is_normal Ordinal.derivFamily_isNormal

theorem derivFamily_fp {i} (H : IsNormal (f i)) (o : Ordinal.{max u v}) :
    f i (derivFamily.{u, v} f o) = derivFamily.{u, v} f o := by
  induction' o using limitRecOn with o _  o l IH
  · rw [derivFamily_zero]
    exact nfpFamily_fp H 0
  · rw [derivFamily_succ]
    exact nfpFamily_fp H _
  · rw [derivFamily_limit _ l,
      IsNormal.bsup.{max u v, u, max u v} H (fun a _ => derivFamily f a) l.1]
    refine' eq_of_forall_ge_iff fun c => _
    simp (config := { contextual := true }) only [bsup_le_iff, IH]
#align ordinal.deriv_family_fp Ordinal.derivFamily_fp

theorem le_iff_derivFamily (H : ∀ i, IsNormal (f i)) {a} :
    (∀ i, f i a ≤ a) ↔ ∃ o, derivFamily.{u, v} f o = a :=
  ⟨fun ha => by
    suffices : ∀ (o) (_ : a ≤ derivFamily.{u, v} f o), ∃ o, derivFamily.{u, v} f o = a
    exact this a ((derivFamily_isNormal _).self_le _)
    intro o
    induction' o using limitRecOn with o IH o l IH
    · intro h₁
      refine' ⟨0, le_antisymm _ h₁⟩
      rw [derivFamily_zero]
      exact nfpFamily_le_fp (fun i => (H i).monotone) (Ordinal.zero_le _) ha
    · intro h₁
      cases' le_or_lt a (derivFamily.{u, v} f o) with h h
      · exact IH h
      refine' ⟨succ o, le_antisymm _ h₁⟩
      rw [derivFamily_succ]
      exact nfpFamily_le_fp (fun i => (H i).monotone) (succ_le_of_lt h) ha
    · intro h₁
      cases' eq_or_lt_of_le h₁ with h h
      · exact ⟨_, h.symm⟩
      rw [derivFamily_limit _ l, ← not_le, bsup_le_iff, not_ball] at h
      exact
        let ⟨o', h, hl⟩ := h
        IH o' h (le_of_not_le hl),
    fun ⟨o, e⟩ i => e ▸ (derivFamily_fp (H i) _).le⟩
#align ordinal.le_iff_deriv_family Ordinal.le_iff_derivFamily

theorem fp_iff_derivFamily (H : ∀ i, IsNormal (f i)) {a} :
    (∀ i, f i a = a) ↔ ∃ o, derivFamily.{u, v} f o = a :=
  Iff.trans ⟨fun h i => le_of_eq (h i), fun h i => (H i).le_iff_eq.1 (h i)⟩ (le_iff_derivFamily H)
#align ordinal.fp_iff_deriv_family Ordinal.fp_iff_derivFamily

/-- For a family of normal functions, `Ordinal.derivFamily` enumerates the common fixed points. -/
theorem derivFamily_eq_enumOrd (H : ∀ i, IsNormal (f i)) :
    derivFamily.{u, v} f = enumOrd (⋂ i, Function.fixedPoints (f i)) := by
  rw [← eq_enumOrd _ (fp_family_unbounded.{u, v} H)]
  use (derivFamily_isNormal f).strictMono
  rw [Set.range_eq_iff]
  refine' ⟨_, fun a ha => _⟩
  · rintro a S ⟨i, hi⟩
    rw [← hi]
    exact derivFamily_fp (H i) a
  rw [Set.mem_interᵢ] at ha
  rwa [← fp_iff_derivFamily H]
#align ordinal.deriv_family_eq_enum_ord Ordinal.derivFamily_eq_enumOrd

end

/-! ### Fixed points of ordinal-indexed families of ordinals -/

section

variable {o : Ordinal.{u}} {f : ∀ b < o, Ordinal.{max u v} → Ordinal.{max u v}}

/-- The next common fixed point, at least `a`, for a family of normal functions indexed by ordinals.

This is defined as `ordinal.nfp_family` of the type-indexed family associated to `f`. -/
def nfpBFamily (o : Ordinal) (f : ∀ b < o, Ordinal → Ordinal) : Ordinal → Ordinal :=
  nfpFamily (familyOfBFamily o f)
#align ordinal.nfp_bfamily Ordinal.nfpBFamily

theorem nfpBFamily_eq_nfpFamily {o : Ordinal} (f : ∀ b < o, Ordinal → Ordinal) :
    nfpBFamily.{u, v} o f = nfpFamily.{u, v} (familyOfBFamily o f) :=
  rfl
#align ordinal.nfp_bfamily_eq_nfp_family Ordinal.nfpBFamily_eq_nfpFamily

theorem foldr_le_nfpBFamily {o : Ordinal}
    (f : ∀ b < o, Ordinal → Ordinal) (a l) :
    List.foldr (familyOfBFamily o f) a l ≤ nfpBFamily.{u, v} o f a :=
  le_sup.{u, v} _ _
#align ordinal.foldr_le_nfp_bfamily Ordinal.foldr_le_nfpBFamily

theorem le_nfpBFamily {o : Ordinal} (f : ∀ b < o, Ordinal → Ordinal) (a) :
    a ≤ nfpBFamily.{u, v} o f a :=
  le_sup.{u, v} _ []
#align ordinal.le_nfp_bfamily Ordinal.le_nfpBFamily

theorem lt_nfpBFamily {a b} :
    a < nfpBFamily.{u, v} o f b ↔ ∃ l, a < List.foldr (familyOfBFamily o f) b l :=
  lt_sup.{u, v}
#align ordinal.lt_nfp_bfamily Ordinal.lt_nfpBFamily

theorem nfpBFamily_le_iff {o : Ordinal} {f : ∀ b < o, Ordinal → Ordinal} {a b} :
    nfpBFamily.{u, v} o f a ≤ b ↔ ∀ l, List.foldr (familyOfBFamily o f) a l ≤ b :=
  sup_le_iff.{u, v}
#align ordinal.nfp_bfamily_le_iff Ordinal.nfpBFamily_le_iff

theorem nfpBFamily_le {o : Ordinal} {f : ∀ b < o, Ordinal → Ordinal} {a b} :
    (∀ l, List.foldr (familyOfBFamily o f) a l ≤ b) → nfpBFamily.{u, v} o f a ≤ b :=
  sup_le.{u, v}
#align ordinal.nfp_bfamily_le Ordinal.nfpBFamily_le

theorem apply_lt_nfpBFamily (H : ∀ i hi, IsNormal (f i hi)) {a b} (hb : b < nfpBFamily.{u, v} o f a)
    (i hi) : f i hi b < nfpBFamily.{u, v} o f a := by
  rw [←familyOfBFamily_enum o f]
  apply apply_lt_nfpFamily (fun _ => H _ _) hb
#align ordinal.apply_lt_nfp_bfamily Ordinal.apply_lt_nfpBFamily

theorem apply_lt_nfpBFamily_iff (ho : o ≠ 0) (H : ∀ i hi, IsNormal (f i hi)) {a b} :
    (∀ i hi, f i hi b < nfpBFamily.{u, v} o f a) ↔ b < nfpBFamily.{u, v} o f a :=
  ⟨fun h => by
    haveI := out_nonempty_iff_ne_zero.2 ho
    refine' (apply_lt_nfpFamily_iff.{u, v} _).1 fun _ => h _ _
    exact fun _ => H _ _, apply_lt_nfpBFamily H⟩
#align ordinal.apply_lt_nfp_bfamily_iff Ordinal.apply_lt_nfpBFamily_iff

theorem nfpBFamily_le_apply (ho : o ≠ 0) (H : ∀ i hi, IsNormal (f i hi)) {a b} :
    (∃ i hi, nfpBFamily.{u, v} o f a ≤ f i hi b) ↔ nfpBFamily.{u, v} o f a ≤ b := by
  rw [← not_iff_not]
  push_neg
  exact apply_lt_nfpBFamily_iff.{u, v} ho H
#align ordinal.nfp_bfamily_le_apply Ordinal.nfpBFamily_le_apply

theorem nfpBFamily_le_fp (H : ∀ i hi, Monotone (f i hi)) {a b} (ab : a ≤ b)
    (h : ∀ i hi, f i hi b ≤ b) : nfpBFamily.{u, v} o f a ≤ b :=
  nfpFamily_le_fp (fun _ => H _ _) ab fun _ => h _ _
#align ordinal.nfp_bfamily_le_fp Ordinal.nfpBFamily_le_fp

theorem nfpBFamily_fp {i hi} (H : IsNormal (f i hi)) (a) :
    f i hi (nfpBFamily.{u, v} o f a) = nfpBFamily.{u, v} o f a := by
  rw [← familyOfBFamily_enum o f]
  apply nfpFamily_fp
  rw [familyOfBFamily_enum]
  exact H
#align ordinal.nfp_bfamily_fp Ordinal.nfpBFamily_fp

theorem apply_le_nfpBFamily (ho : o ≠ 0) (H : ∀ i hi, IsNormal (f i hi)) {a b} :
    (∀ i hi, f i hi b ≤ nfpBFamily.{u, v} o f a) ↔ b ≤ nfpBFamily.{u, v} o f a := by
  refine' ⟨fun h => _, fun h i hi => _⟩
  · have ho' : 0 < o := Ordinal.pos_iff_ne_zero.2 ho
    exact ((H 0 ho').self_le b).trans (h 0 ho')
  · rw [← nfpBFamily_fp (H i hi)]
    exact (H i hi).monotone h
#align ordinal.apply_le_nfp_bfamily Ordinal.apply_le_nfpBFamily

theorem nfpBFamily_eq_self {a} (h : ∀ i hi, f i hi a = a) : nfpBFamily.{u, v} o f a = a :=
  nfpFamily_eq_self fun _ => h _ _
#align ordinal.nfp_bfamily_eq_self Ordinal.nfpBFamily_eq_self

/-- A generalization of the fixed point lemma for normal functions: any family of normal functions
    has an unbounded set of common fixed points. -/
theorem fp_bfamily_unbounded (H : ∀ i hi, IsNormal (f i hi)) :
    (⋂ (i) (hi), Function.fixedPoints (f i hi)).Unbounded (· < ·) := fun a =>
  ⟨nfpBFamily.{u, v} _ f a, by
    rw [Set.mem_interᵢ₂]
    exact fun i hi => nfpBFamily_fp (H i hi) _, (le_nfpBFamily f a).not_lt⟩
#align ordinal.fp_bfamily_unbounded Ordinal.fp_bfamily_unbounded

/-- The derivative of a family of normal functions is the sequence of their common fixed points.

This is defined as `Ordinal.derivFamily` of the type-indexed family associated to `f`. -/
def derivBFamily (o : Ordinal) (f : ∀ b < o, Ordinal → Ordinal) : Ordinal → Ordinal :=
  derivFamily (familyOfBFamily o f)
#align ordinal.deriv_bfamily Ordinal.derivBFamily

theorem derivBFamily_eq_derivFamily {o : Ordinal} (f : ∀ b < o, Ordinal → Ordinal) :
    derivBFamily.{u, v} o f = derivFamily.{u, v} (familyOfBFamily o f) :=
  rfl
#align ordinal.deriv_bfamily_eq_deriv_family Ordinal.derivBFamily_eq_derivFamily

theorem derivBFamily_isNormal {o : Ordinal} (f : ∀ b < o, Ordinal → Ordinal) :
    IsNormal (derivBFamily o f) :=
  derivFamily_isNormal _
#align ordinal.deriv_bfamily_is_normal Ordinal.derivBFamily_isNormal

theorem derivBFamily_fp {i hi} (H : IsNormal (f i hi)) (a : Ordinal) :
    f i hi (derivBFamily.{u, v} o f a) = derivBFamily.{u, v} o f a := by
  rw [← familyOfBFamily_enum o f]
  apply derivFamily_fp
  rw [familyOfBFamily_enum]
  exact H
#align ordinal.deriv_bfamily_fp Ordinal.derivBFamily_fp

theorem le_iff_derivBFamily (H : ∀ i hi, IsNormal (f i hi)) {a} :
    (∀ i hi, f i hi a ≤ a) ↔ ∃ b, derivBFamily.{u, v} o f b = a := by
  unfold derivBFamily
  rw [← le_iff_derivFamily]
  · refine' ⟨fun h i => h _ _, fun h i hi => _⟩
    rw [← familyOfBFamily_enum o f]
    apply h
  · exact fun _ => H _ _
#align ordinal.le_iff_deriv_bfamily Ordinal.le_iff_derivBFamily

theorem fp_iff_derivBFamily (H : ∀ i hi, IsNormal (f i hi)) {a} :
    (∀ i hi, f i hi a = a) ↔ ∃ b, derivBFamily.{u, v} o f b = a := by
  rw [← le_iff_derivBFamily H]
  refine' ⟨fun h i hi => le_of_eq (h i hi), fun h i hi => _⟩
  rw [← (H i hi).le_iff_eq]
  exact h i hi
#align ordinal.fp_iff_deriv_bfamily Ordinal.fp_iff_derivBFamily

/-- For a family of normal functions, `ordinal.deriv_bfamily` enumerates the common fixed points. -/
theorem derivBFamily_eq_enumOrd (H : ∀ i hi, IsNormal (f i hi)) :
    derivBFamily.{u, v} o f = enumOrd (⋂ (i) (hi), Function.fixedPoints (f i hi)) := by
  rw [← eq_enumOrd _ (fp_bfamily_unbounded.{u, v} H)]
  use (derivBFamily_isNormal f).strictMono
  rw [Set.range_eq_iff]
  refine' ⟨fun a => Set.mem_interᵢ₂.2 fun i hi => derivBFamily_fp (H i hi) a, fun a ha => _⟩
  rw [Set.mem_interᵢ₂] at ha
  rwa [← fp_iff_derivBFamily H]
#align ordinal.deriv_bfamily_eq_enum_ord Ordinal.derivBFamily_eq_enumOrd

end

/-! ### Fixed points of a single function -/

section

variable {f : Ordinal.{u} → Ordinal.{u}}

/-- The next fixed point function, the least fixed point of the normal function `f`, at least `a`.

This is defined as `ordinal.nfpFamily` applied to a family consisting only of `f`. -/
def nfp (f : Ordinal → Ordinal) : Ordinal → Ordinal :=
  nfpFamily fun _ : Unit => f
#align ordinal.nfp Ordinal.nfp

theorem nfp_eq_nfpFamily (f : Ordinal → Ordinal) : nfp f = nfpFamily fun _ : Unit => f :=
  rfl
#align ordinal.nfp_eq_nfp_family Ordinal.nfp_eq_nfpFamily

@[simp]
theorem sup_iterate_eq_nfp (f : Ordinal.{u} → Ordinal.{u}) :
    (fun a => sup fun n : ℕ => (f^[n]) a) = nfp f := by
  refine' funext fun a => le_antisymm _ (sup_le fun l => _)
  · rw [sup_le_iff]
    intro n
    rw [← List.length_replicate n Unit.unit, ← List.foldr_const f a]
    apply le_sup
  · rw [List.foldr_const f a l]
    exact le_sup _ _
#align ordinal.sup_iterate_eq_nfp Ordinal.sup_iterate_eq_nfp

theorem iterate_le_nfp (f a n) : (f^[n]) a ≤ nfp f a := by
  rw [← sup_iterate_eq_nfp]
  exact le_sup _ n
#align ordinal.iterate_le_nfp Ordinal.iterate_le_nfp

theorem le_nfp (f a) : a ≤ nfp f a :=
  iterate_le_nfp f a 0
#align ordinal.le_nfp Ordinal.le_nfp

theorem lt_nfp {a b} : a < nfp f b ↔ ∃ n, a < (f^[n]) b := by
  rw [← sup_iterate_eq_nfp]
  exact lt_sup
#align ordinal.lt_nfp Ordinal.lt_nfp

theorem nfp_le_iff {a b} : nfp f a ≤ b ↔ ∀ n, (f^[n]) a ≤ b := by
  rw [← sup_iterate_eq_nfp]
  exact sup_le_iff
#align ordinal.nfp_le_iff Ordinal.nfp_le_iff

theorem nfp_le {a b} : (∀ n, (f^[n]) a ≤ b) → nfp f a ≤ b :=
  nfp_le_iff.2
#align ordinal.nfp_le Ordinal.nfp_le

@[simp]
theorem nfp_id : nfp id = id :=
  funext fun a => by
    simp_rw [← sup_iterate_eq_nfp, iterate_id]
    exact sup_const a
#align ordinal.nfp_id Ordinal.nfp_id

theorem nfp_monotone (hf : Monotone f) : Monotone (nfp f) :=
  nfpFamily_monotone fun _ => hf
#align ordinal.nfp_monotone Ordinal.nfp_monotone

theorem IsNormal.apply_lt_nfp {f} (H : IsNormal f) {a b} : f b < nfp f a ↔ b < nfp f a := by
  unfold nfp
  rw [← @apply_lt_nfpFamily_iff Unit (fun _ => f) _ (fun _ => H) a b]
  exact ⟨fun h _ => h, fun h => h Unit.unit⟩
#align ordinal.is_normal.apply_lt_nfp Ordinal.IsNormal.apply_lt_nfp

theorem IsNormal.nfp_le_apply {f} (H : IsNormal f) {a b} : nfp f a ≤ f b ↔ nfp f a ≤ b :=
  le_iff_le_iff_lt_iff_lt.2 H.apply_lt_nfp
#align ordinal.is_normal.nfp_le_apply Ordinal.IsNormal.nfp_le_apply

theorem nfp_le_fp {f} (H : Monotone f) {a b} (ab : a ≤ b) (h : f b ≤ b) : nfp f a ≤ b :=
  nfpFamily_le_fp (fun _ => H) ab fun _ => h
#align ordinal.nfp_le_fp Ordinal.nfp_le_fp

theorem IsNormal.nfp_fp {f} (H : IsNormal f) : ∀ a, f (nfp f a) = nfp f a :=
  @nfpFamily_fp Unit (fun _ => f) Unit.unit H
#align ordinal.is_normal.nfp_fp Ordinal.IsNormal.nfp_fp

theorem IsNormal.apply_le_nfp {f} (H : IsNormal f) {a b} : f b ≤ nfp f a ↔ b ≤ nfp f a :=
  ⟨le_trans (H.self_le _), fun h => by simpa only [H.nfp_fp] using H.le_iff.2 h⟩
#align ordinal.is_normal.apply_le_nfp Ordinal.IsNormal.apply_le_nfp

theorem nfp_eq_self {f : Ordinal → Ordinal} {a} (h : f a = a) : nfp f a = a :=
  nfpFamily_eq_self fun _ => h
#align ordinal.nfp_eq_self Ordinal.nfp_eq_self

/-- The fixed point lemma for normal functions: any normal function has an unbounded set of
fixed points. -/
theorem fp_unbounded (H : IsNormal f) : (Function.fixedPoints f).Unbounded (· < ·) := by
  convert fp_family_unbounded fun _ : Unit => H
  exact (Set.interᵢ_const _).symm
#align ordinal.fp_unbounded Ordinal.fp_unbounded

/-- The derivative of a normal function `f` is the sequence of fixed points of `f`.

This is defined as `Ordinal.derivFamily` applied to a trivial family consisting only of `f`. -/
def deriv (f : Ordinal → Ordinal) : Ordinal → Ordinal :=
  derivFamily fun _ : Unit => f
#align ordinal.deriv Ordinal.deriv

theorem deriv_eq_derivFamily (f : Ordinal → Ordinal) : deriv f = derivFamily fun _ : Unit => f :=
  rfl
#align ordinal.deriv_eq_deriv_family Ordinal.deriv_eq_derivFamily

@[simp]
theorem deriv_zero (f) : deriv f 0 = nfp f 0 :=
  derivFamily_zero _
#align ordinal.deriv_zero Ordinal.deriv_zero

@[simp]
theorem deriv_succ (f o) : deriv f (succ o) = nfp f (succ (deriv f o)) :=
  derivFamily_succ _ _
#align ordinal.deriv_succ Ordinal.deriv_succ

theorem deriv_limit (f) {o} : IsLimit o → deriv f o = bsup.{u, 0} o fun a _ => deriv f a :=
  derivFamily_limit _
#align ordinal.deriv_limit Ordinal.deriv_limit

theorem deriv_isNormal (f) : IsNormal (deriv f) :=
  derivFamily_isNormal _
#align ordinal.deriv_is_normal Ordinal.deriv_isNormal

theorem deriv_id_of_nfp_id {f : Ordinal → Ordinal} (h : nfp f = id) : deriv f = id :=
  ((deriv_isNormal _).eq_iff_zero_and_succ IsNormal.refl).2 (by simp [h])
#align ordinal.deriv_id_of_nfp_id Ordinal.deriv_id_of_nfp_id

theorem IsNormal.deriv_fp {f} (H : IsNormal f) : ∀ o, f (deriv f o) = deriv f o :=
  @derivFamily_fp Unit (fun _ => f) Unit.unit H
#align ordinal.is_normal.deriv_fp Ordinal.IsNormal.deriv_fp

theorem IsNormal.le_iff_deriv {f} (H : IsNormal f) {a} : f a ≤ a ↔ ∃ o, deriv f o = a := by
  unfold deriv
  rw [← le_iff_derivFamily fun _ : Unit => H]
  exact ⟨fun h _ => h, fun h => h Unit.unit⟩
#align ordinal.is_normal.le_iff_deriv Ordinal.IsNormal.le_iff_deriv

theorem IsNormal.fp_iff_deriv {f} (H : IsNormal f) {a} : f a = a ↔ ∃ o, deriv f o = a := by
  rw [← H.le_iff_eq, H.le_iff_deriv]
#align ordinal.is_normal.fp_iff_deriv Ordinal.IsNormal.fp_iff_deriv

/-- `ordinal.deriv` enumerates the fixed points of a normal function. -/
theorem deriv_eq_enumOrd (H : IsNormal f) : deriv f = enumOrd (Function.fixedPoints f) := by
  convert derivFamily_eq_enumOrd fun _ : Unit => H
  exact (Set.interᵢ_const _).symm
#align ordinal.deriv_eq_enum_ord Ordinal.deriv_eq_enumOrd

theorem deriv_eq_id_of_nfp_eq_id {f : Ordinal → Ordinal} (h : nfp f = id) : deriv f = id :=
  (IsNormal.eq_iff_zero_and_succ (deriv_isNormal _) IsNormal.refl).2 <| by simp [h]
#align ordinal.deriv_eq_id_of_nfp_eq_id Ordinal.deriv_eq_id_of_nfp_eq_id

end

/-! ### Fixed points of addition -/

@[simp]
theorem nfp_add_zero (a) : nfp (a + ·) 0 = a * omega := by
  simp_rw [← sup_iterate_eq_nfp, ← sup_mul_nat]
  congr ; funext n
  induction' n with n hn
  · rw [Nat.cast_zero, mul_zero, iterate_zero_apply]
  · nth_rw 2 [Nat.succ_eq_one_add]
    rw [Nat.cast_add, Nat.cast_one, mul_one_add, iterate_succ_apply', hn]
#align ordinal.nfp_add_zero Ordinal.nfp_add_zero

theorem nfp_add_eq_mul_omega {a b} (hba : b ≤ a * omega) : nfp (a + ·) b = a * omega := by
  apply le_antisymm (nfp_le_fp (add_isNormal a).monotone hba _)
  · rw [← nfp_add_zero]
    exact nfp_monotone (add_isNormal a).monotone (Ordinal.zero_le b)
  · dsimp; rw [← mul_one_add, one_add_omega]
#align ordinal.nfp_add_eq_mul_omega Ordinal.nfp_add_eq_mul_omega

theorem add_eq_right_iff_mul_omega_le {a b : Ordinal} : a + b = b ↔ a * omega ≤ b := by
  refine' ⟨fun h => _, fun h => _⟩
  · rw [← nfp_add_zero a, ← deriv_zero]
    cases' (add_isNormal a).fp_iff_deriv.1 h with c hc
    rw [← hc]
    exact (deriv_isNormal _).monotone (Ordinal.zero_le _)
  · have := Ordinal.add_sub_cancel_of_le h
    nth_rw 1 [← this]
    rwa [← add_assoc, ← mul_one_add, one_add_omega]
#align ordinal.add_eq_right_iff_mul_omega_le Ordinal.add_eq_right_iff_mul_omega_le

theorem add_le_right_iff_mul_omega_le {a b : Ordinal} : a + b ≤ b ↔ a * omega ≤ b := by
  rw [← add_eq_right_iff_mul_omega_le]
  exact (add_isNormal a).le_iff_eq
#align ordinal.add_le_right_iff_mul_omega_le Ordinal.add_le_right_iff_mul_omega_le

theorem deriv_add_eq_mul_omega_add (a b : Ordinal.{u}) : deriv (a + ·) b = a * omega + b := by
  revert b
  rw [← funext_iff, IsNormal.eq_iff_zero_and_succ (deriv_isNormal _) (add_isNormal _)]
  refine' ⟨_, fun a h => _⟩
  · dsimp; rw [deriv_zero, add_zero]
    exact nfp_add_zero a
  · dsimp; rw [deriv_succ, h, add_succ]
    exact nfp_eq_self (add_eq_right_iff_mul_omega_le.2 ((le_add_right _ _).trans (le_succ _)))
#align ordinal.deriv_add_eq_mul_omega_add Ordinal.deriv_add_eq_mul_omega_add

/-! ### Fixed points of multiplication -/

--Porting note: commented out, doesn't seem necessary
-- local infixr:0 "^" => @Pow.pow Ordinal Ordinal Ordinal.hasPow

@[simp]
theorem nfp_mul_one {a : Ordinal} (ha : 0 < a) : nfp (a * .) 1 = (a^omega) := by
  rw [← sup_iterate_eq_nfp, ← sup_opow_nat]
  · dsimp
    congr
    funext n
    induction' n with n hn
    · rw [Nat.cast_zero, opow_zero, iterate_zero_apply]
    nth_rw 2 [Nat.succ_eq_one_add]
    rw [Nat.cast_add, Nat.cast_one, opow_add, opow_one, iterate_succ_apply', hn]
  · exact ha
#align ordinal.nfp_mul_one Ordinal.nfp_mul_one

@[simp]
theorem nfp_mul_zero (a : Ordinal) : nfp (a * .) 0 = 0 := by
  rw [← Ordinal.le_zero, nfp_le_iff]
  intro n
  induction' n with n hn; · rfl
  dsimp only; rwa [iterate_succ_apply, mul_zero]
#align ordinal.nfp_mul_zero Ordinal.nfp_mul_zero

@[simp]
theorem nfp_zero_mul : nfp (HMul.hMul 0) = id := by
  rw [← sup_iterate_eq_nfp]
  refine' funext fun a => (sup_le fun n => _).antisymm (le_sup (fun n => ((· * ·) 0^[n]) a) 0)
  induction' n with n _; · rfl
  rw [Function.iterate_succ']
  change 0 * _ ≤ a
  rw [zero_mul]
  exact Ordinal.zero_le a
#align ordinal.nfp_zero_mul Ordinal.nfp_zero_mul

@[simp]
theorem deriv_mul_zero : deriv (HMul.hMul 0) = id :=
  deriv_eq_id_of_nfp_eq_id nfp_zero_mul
#align ordinal.deriv_mul_zero Ordinal.deriv_mul_zero

theorem nfp_mul_eq_opow_omega {a b : Ordinal} (hb : 0 < b) (hba : b ≤ (a^omega)) :
    nfp (a * ·) b = (a^omega.{u}) := by
  cases' eq_zero_or_pos a with ha ha
  · rw [ha, zero_opow omega_ne_zero] at hba ⊢
    rw [Ordinal.le_zero.1 hba, nfp_zero_mul]
    rfl
  apply le_antisymm
  · apply nfp_le_fp (mul_isNormal ha).monotone hba
    dsimp only; rw [← opow_one_add, one_add_omega]
  rw [← nfp_mul_one ha]
  exact nfp_monotone (mul_isNormal ha).monotone (one_le_iff_pos.2 hb)
#align ordinal.nfp_mul_eq_opow_omega Ordinal.nfp_mul_eq_opow_omega

theorem eq_zero_or_opow_omega_le_of_mul_eq_right {a b : Ordinal} (hab : a * b = b) :
    b = 0 ∨ (a^omega.{u}) ≤ b := by
  cases' eq_zero_or_pos a with ha ha
  · rw [ha, zero_opow omega_ne_zero]
    exact Or.inr (Ordinal.zero_le b)
  rw [or_iff_not_imp_left]
  intro hb
  rw [← nfp_mul_one ha]
  rw [← Ne.def, ← one_le_iff_ne_zero] at hb
  exact nfp_le_fp (mul_isNormal ha).monotone hb (le_of_eq hab)
#align ordinal.eq_zero_or_opow_omega_le_of_mul_eq_right Ordinal.eq_zero_or_opow_omega_le_of_mul_eq_right

theorem mul_eq_right_iff_opow_omega_dvd {a b : Ordinal} : a * b = b ↔ (a^omega) ∣ b := by
  cases' eq_zero_or_pos a with ha ha
  · rw [ha, zero_mul, zero_opow omega_ne_zero, zero_dvd_iff]
    exact eq_comm
  refine' ⟨fun hab => _, fun h => _⟩
  · rw [dvd_iff_mod_eq_zero]
    rw [← div_add_mod b (a^omega), mul_add, ← mul_assoc, ← opow_one_add, one_add_omega,
      add_left_cancel] at hab
    cases' eq_zero_or_opow_omega_le_of_mul_eq_right hab with hab hab
    · exact hab
    refine' (not_lt_of_le hab (mod_lt b (opow_ne_zero omega _))).elim
    rwa [← Ordinal.pos_iff_ne_zero]
  cases' h with c hc
  rw [hc, ← mul_assoc, ← opow_one_add, one_add_omega]
#align ordinal.mul_eq_right_iff_opow_omega_dvd Ordinal.mul_eq_right_iff_opow_omega_dvd

theorem mul_le_right_iff_opow_omega_dvd {a b : Ordinal} (ha : 0 < a) : a * b ≤ b ↔ (a^omega) ∣ b :=
  by
  rw [← mul_eq_right_iff_opow_omega_dvd]
  exact (mul_isNormal ha).le_iff_eq
#align ordinal.mul_le_right_iff_opow_omega_dvd Ordinal.mul_le_right_iff_opow_omega_dvd

theorem nfp_mul_opow_omega_add {a c : Ordinal} (b) (ha : 0 < a) (hc : 0 < c) (hca : c ≤ (a^omega)) :
    nfp (a * ·) ((a^omega) * b + c) = (a^omega.{u}) * succ b := by
  apply le_antisymm
  · apply nfp_le_fp (mul_isNormal ha).monotone
    · rw [mul_succ]
      apply add_le_add_left hca
    · dsimp only; rw [← mul_assoc, ← opow_one_add, one_add_omega]
  · cases' mul_eq_right_iff_opow_omega_dvd.1 ((mul_isNormal ha).nfp_fp ((a^omega) * b + c)) with
      d hd
    rw [hd]
    apply mul_le_mul_left'
    have := le_nfp (Mul.mul a) ((a^omega) * b + c)
    erw [hd] at this
    have := (add_lt_add_left hc ((a^omega) * b)).trans_le this
    rw [add_zero, mul_lt_mul_iff_left (opow_pos omega ha)] at this
    rwa [succ_le_iff]
#align ordinal.nfp_mul_opow_omega_add Ordinal.nfp_mul_opow_omega_add

theorem deriv_mul_eq_opow_omega_mul {a : Ordinal.{u}} (ha : 0 < a) (b) :
    deriv (a * ·) b = (a^omega) * b := by
  revert b
  rw [← funext_iff,
    IsNormal.eq_iff_zero_and_succ (deriv_isNormal _) (mul_isNormal (opow_pos omega ha))]
  refine' ⟨_, fun c h => _⟩
  · dsimp only; rw [deriv_zero, nfp_mul_zero, mul_zero]
  · rw [deriv_succ, h]
    exact nfp_mul_opow_omega_add c ha zero_lt_one (one_le_iff_pos.2 (opow_pos _ ha))
#align ordinal.deriv_mul_eq_opow_omega_mul Ordinal.deriv_mul_eq_opow_omega_mul

end Ordinal


import tactic
import data.int.parity
import data.int.modeq
import data.nat.modeq
import data.nat.factorization.basic
import number_theory.legendre_symbol.quadratic_reciprocity

import Mordell.CongruencesMod4

lemma mod_8_of_factors_17 {n : ℕ} (hn: n ≥ 1) (hfac : ∀ p ∈ n.factors, p ≡ 1 [MOD 8] ∨ p ≡ 7 [MOD 8]) :
  n ≡ 1 [MOD 8] ∨ n ≡ 7 [MOD 8] :=
begin
  induction n using nat.rec_on_mul with p hp a b ha hb,
  { linarith },
  { left, refl },
  { rw nat.factors_prime hp at hfac,
    exact hfac p (list.mem_cons_self p list.nil) },
  { by_cases ha2 : a = 0,
    { nlinarith },
    by_cases hb2 : b = 0,
    { nlinarith },
    { have key_a : ∀ p ∈ a.factors, p ≡ 1 [MOD 8] ∨ p ≡ 7 [MOD 8] :=
        (λ p hp, hfac p (nat.mem_factors_mul_left hp hb2)),
      have key_b : ∀ p ∈ b.factors, p ≡ 1 [MOD 8] ∨ p ≡ 7 [MOD 8] :=
        (λ p hp, hfac p (nat.mem_factors_mul_right hp ha2)),
      cases ha (by nlinarith) key_a with a_8 a_8;
      cases hb (by nlinarith) key_b with b_8 b_8,
      { left, have : a * b ≡ 1 * 1 [MOD 8] := nat.modeq.mul a_8 b_8, assumption },
      { right, have : a * b ≡ 1 * 7 [MOD 8] := nat.modeq.mul a_8 b_8, assumption },
      { right, have : a * b ≡ 7 * 1 [MOD 8] := nat.modeq.mul a_8 b_8, assumption },
      { left, have : a * b ≡ 7 * 7 [MOD 8] := nat.modeq.mul a_8 b_8, assumption },
    },
  },
end

lemma mod_8_of_mod {n : ℕ} (n_odd : odd n) :  ¬( n ≡ 3 [MOD 8] ∨ n ≡ 5 [MOD 8]) ↔ (n ≡ 1 [MOD 8] ∨ n ≡ 7 [MOD 8]) :=
begin
  push_neg,
  split,
  swap,
  { intro h17,
    cases h17 with h h; split;
    { unfold nat.modeq at h ⊢, rw h, norm_num, }, },
  { rintro ⟨hn3_8, hn5_8⟩,
    have n_odd' : n % 2 = 1,
    { rcases n_odd with ⟨k, rfl⟩,
      rw add_comm,
      norm_num, },
    cases nat.odd_mod_four_iff.mp n_odd' with h1_4 h3_4,
    { left,
      obtain ⟨k, hk⟩ : (4 : ℤ) ∣ 1-n := nat.modeq.dvd h1_4,
      rw nat.modeq_iff_dvd at hn5_8 ⊢,
      norm_num at hn5_8 ⊢,
      rw hk,
      rcases int.even_or_odd' k with ⟨l, rfl | rfl⟩,
      { ring_nf,
        norm_num, },
      { have key : 5 - ↑n = 8*(l+1) := by linarith,
        rw key at hn5_8,
        exfalso,
        norm_num at hn5_8, },
    },
    { right,
      have H : (4 : ℤ) ∣ 7-n := nat.modeq.dvd h3_4,
      cases H with k hk,
      rw nat.modeq_iff_dvd at hn3_8 ⊢,
      norm_num at hn3_8 ⊢,
      rw hk,
      rcases int.even_or_odd' k with ⟨l, rfl | rfl⟩,
      { ring_nf,
        norm_num, },
      { have key : 3 - ↑n = 8*l := by linarith,
        rw key at hn3_8,
        exfalso,
        norm_num at hn3_8, }, }, },
end

lemma prime_factor_congr_3_mod_4 {n : ℤ} (hn_8 : n ≡ 3 [ZMOD 8] ∨ n ≡ 5 [ZMOD 8]) :
  ∃ (p : ℕ), p.prime ∧ (p : int) ∣ n  ∧ (p ≡ 3 [MOD 8] ∨ p ≡ 5  [MOD 8]) :=
begin
  by_contradiction hdiv,
  push_neg at hdiv,
  have n_odd : odd n,
  { cases hn_8 with hn_8 hn_8;
    exact int.odd_iff.mpr (int.modeq.modeq_of_dvd (by norm_num : (2 : ℤ) ∣ 8) hn_8), },
  let N : ℕ := n.nat_abs,
  have N_odd : odd N := int.nat_abs_odd.mpr n_odd,
  have hfac : ∀ p ∈ N.factors, p ≡ 1 [MOD 8] ∨ p ≡ 7 [MOD 8],
  { intros p hp,
    have p_div_N := nat.dvd_of_mem_factors hp,
    have p_odd : odd p,
    { cases p_div_N with k hk,
      rw hk at N_odd,
      apply nat.odd.of_mul_left N_odd, },
    apply (mod_8_of_mod p_odd).mp,
    push_neg,
    apply hdiv p (nat.prime_of_mem_factors hp),
    exact int.coe_nat_dvd_left.mpr p_div_N, },
  have N_ne_0 : N ≠ 0 := nat.ne_of_odd_add N_odd,
  have key := mod_8_of_factors_17 (nat.one_le_iff_ne_zero.mpr N_ne_0) hfac,
  apply (mod_8_of_mod N_odd).mpr key,
  rw [← int.coe_nat_modeq_iff, ← int.coe_nat_modeq_iff],
  by_cases n_pos : 0 ≤ n,
  { rw int.nat_abs_of_nonneg n_pos,
    exact hn_8, },
  { have hNn : ↑N = -n := int.of_nat_nat_abs_of_nonpos (by linarith),
    rw hNn,
    cases hn_8 with hn3_8 hn5_8,
    { right,
      apply int.modeq.add_left_cancel hn3_8,
      norm_num,
      refl, },
    { left,
      apply int.modeq.add_left_cancel hn5_8,
      norm_num,
      refl, },
  },
end

example (x y : ℤ) : y^2 ≠ x^3 - 6 :=
begin
  intro heq,
  have oddx: odd x,
  { by_contradiction evenx,
    rw ← int.even_iff_not_odd at evenx,
    rw even_iff_two_dvd at evenx,
    have hy2 : y^2 ≡ 2 [ZMOD 8],
    { rw heq,
      rcases evenx with ⟨k, rfl⟩,
      apply int.modeq_of_dvd,
      exact dvd.intro (1-k^3) (by ring),
    },
    replace hy2 := int.modeq.modeq_of_dvd (by norm_num : (4:ℤ)∣8) hy2,
    exact int.square_ne_two_mod_four y hy2,
  },
  have oddy: odd y,
  { rw [int.odd_iff_not_even, ← int.even_pow' (by norm_num : 2≠0), ← int.odd_iff_not_even, heq],
    rcases oddx with ⟨k, rfl⟩,
    refine ⟨(((4*k+6)*k+3)*k-3), _⟩,
    ring
  },
  have x_8 : x ≡ 7 [ZMOD 8],
  { have heq' : x^3 = y^2 + 6 := by linarith,
    have x3_8 : x^3 ≡ 7 [ZMOD 8],
    { rw heq',
      rcases oddy with ⟨k, rfl⟩,
      apply int.modeq_of_dvd,
      ring_nf,
      rw (by ring : (-(4*k)-4)*k = -4*(k*(k+1))),
      cases int.even_mul_succ_self k with m hm,
      rw hm,
      exact dvd.intro (-m) (by ring),
    },
    have x2_8 : x^2 ≡ 1 [ZMOD 8],
    { rcases oddx with ⟨k, rfl⟩,
      cases int.even_mul_succ_self k with m hm,
      calc ((2*k + 1)^2) % 8 = (4*(k*(k+1)) + 1) % 8 : by ring_nf
                         ... = (4*(m+m) + 1) % 8     : by rw hm
                         ... = (1 + 8*m) % 8         : by ring_nf
                         ... = 1                     : int.modeq_add_fac_self,
    },
    calc x % 8 = x * 1 % 8   : by ring_nf
           ... = x * x^2 % 8 : (int.modeq.mul_left x x2_8).symm
           ... = x^3 % 8     : by ring_nf
           ... = 7           : x3_8,
  },
  have h2 : y^2 - 2 = (x-2)*(x^2 + 2*x + 4),
  { rw heq,
    ring, },
  have H : x^2 + 2*x + 4 ≡ 3 [ZMOD 8],
  { obtain ⟨k, hk⟩ := int.modeq.dvd x_8,
    replace hk : x = 7 - 8*k := by linarith,
    rw [hk, int.modeq_iff_dvd],
    exact dvd.intro ((16 - k * 8) * k - 8) (by ring), },
  rcases prime_factor_congr_3_mod_4 (or.inl H) with ⟨p, p_prime, p_div, p35_8⟩,
  have y22_p : y^2 ≡ 2 [ZMOD p],
  { symmetry,
    apply int.modeq_iff_dvd.mpr,
    rw h2,
    exact dvd_mul_of_dvd_right p_div (x - 2), },
  have sq2_p : is_square (2 : zmod p),
  { apply is_square_of_exists_sq (2 : zmod p),
    refine ⟨y, _⟩,
    have key := (zmod.int_coe_eq_int_coe_iff 2 (y^2) p).mpr y22_p.symm,
    norm_num at key,
    exact key, },
  have p_ne_2 : p ≠ 2,
  { rintro rfl,
    cases p35_8 with p35_8 p35_8;
    rw nat.modeq_iff_dvd at p35_8;
    norm_num at p35_8, },
  haveI K : fact (nat.prime p) := {out := p_prime},
  have p17_8 := (zmod.exists_sq_eq_two_iff p_ne_2).mp sq2_p,
  exact (mod_8_of_mod (nat.prime.odd p_prime p_ne_2)).mpr p17_8 p35_8,
end


/-
Copyright (c) 2020 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.num.lemmas
import data.nat.prime
import tactic.ring

/-!
# Primality for binary natural numbers

This file defines versions of `nat.min_fac` and `nat.prime` for `num` and `pos_num`. As with other
`num` definitions, they are not intended for general use (`nat` should be used instead of `num` in
most cases) but they can be used in contexts where kernel computation is required, such as proofs
by `rfl` and `dec_trivial`, as well as in `#reduce`.

The default decidable instance for `nat.prime` is optimized for VM evaluation, so it should be
preferred within `#eval` or in tactic execution, while for proofs the `norm_num` tactic can be used
to construct primality and non-primality proofs more efficiently than kernel computation.

Nevertheless, sometimes proof by computational reflection requires natural number computations, and
`num` implements algorithms directly on binary natural numbers for this purpose.
-/

namespace pos_num

/-- Auxiliary function for computing the smallest prime factor of a `pos_num`. Unlike
`nat.min_fac_aux`, we use a natural number `fuel` variable that is set to an upper bound on the
number of iterations. It is initialized to the number `n` we are determining primality for. Even
though this is exponential in the input (since it is a `nat`, not a `num`), it will get lazily
evaluated during kernel reduction, so we will only require about `sqrt n` unfoldings, for the
`sqrt n` iterations of the loop. -/
def min_fac_aux (n : pos_num) : ℕ → pos_num → pos_num
| 0 _ := n
| (fuel+1) k :=
  if h : n < k.bit1 * k.bit1 then n else
  if k.bit1 ∣ n then k.bit1 else
  min_fac_aux fuel k.succ

theorem min_fac_aux_to_nat {fuel:ℕ} {n k : pos_num} (h : nat.sqrt n < fuel + k.bit1) :
  (min_fac_aux n fuel k : ℕ) = nat.min_fac_aux n k.bit1 :=
begin
  induction fuel with fuel ih generalizing k; rw [min_fac_aux, nat.min_fac_aux],
  { rw if_pos, rwa [zero_add, nat.sqrt_lt] at h },
  rw [← mul_to_nat], simp only [cast_lt, dvd_to_nat, ite_cast],
  congr' 2,
  rw ih; [congr, convert nat.lt_succ_of_lt h using 1];
  simp only [_root_.bit1, _root_.bit0, cast_bit1, cast_succ,
    nat.succ_eq_add_one, add_assoc, add_left_comm]
end

/-- Returns the smallest prime factor of `n ≠ 1`. -/
def min_fac : pos_num → pos_num
| 1 := 1
| (bit0 n) := 2
| (bit1 n) := min_fac_aux (bit1 n) n 1

@[simp] theorem min_fac_to_nat (n : pos_num) : (min_fac n : ℕ) = nat.min_fac n :=
begin
  cases n, {refl},
  { rw [min_fac, nat.min_fac_eq, if_neg], swap, {simp},
    rw [min_fac_aux_to_nat], {refl},
    simp only [cast_one, cast_bit1],
    rw [nat.sqrt_lt],
    convert lt_add_of_pos_right _ (dec_trivial : (0:ℕ) < (n+4)*n + 8),
    unfold _root_.bit1 _root_.bit0, ring },
  { rw [min_fac, nat.min_fac_eq, if_pos], {refl},
    simp },
end

/-- Primality predicate for a `pos_num`. -/
@[simp] def prime (n : pos_num) : Prop := nat.prime n

instance decidable_prime : decidable_pred pos_num.prime
| 1 := decidable.is_false nat.not_prime_one
| (bit0 n) := decidable_of_iff' (n = 1) begin
    refine nat.prime_def_min_fac.trans ((and_iff_right _).trans $ eq_comm.trans _),
    { exact bit0_le_bit0.2 (to_nat_pos _) },
    rw [← min_fac_to_nat, to_nat_inj],
    exact ⟨bit0.inj, congr_arg _⟩,
  end
| (bit1 n) := decidable_of_iff' (min_fac_aux (bit1 n) n 1 = bit1 n) begin
    refine nat.prime_def_min_fac.trans ((and_iff_right _).trans _),
    { exact nat.bit0_le_bit1_iff.2 (to_nat_pos _) },
    rw [← min_fac_to_nat, to_nat_inj], refl,
  end

end pos_num

namespace num

/-- Returns the smallest prime factor of `n ≠ 1`. -/
def min_fac : num → pos_num
| 0 := 2
| (pos n) := n.min_fac

@[simp] theorem min_fac_to_nat : ∀ (n : num), (min_fac n : ℕ) = nat.min_fac n
| 0 := rfl
| (pos n) := pos_num.min_fac_to_nat _

/-- Primality predicate for a `num`. -/
@[simp] def prime (n : num) : Prop := nat.prime n

instance decidable_prime : decidable_pred num.prime
| 0 := decidable.is_false nat.not_prime_zero
| (pos n) := pos_num.decidable_prime n

end num


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz

! This file was ported from Lean 3 source module category_theory.sites.limits
! leanprover-community/mathlib commit 94b2c2cba7d64557ac30df4df8a25e9bdfa50911
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Creates
import Mathbin.CategoryTheory.Sites.Sheafification

/-!

# Limits and colimits of sheaves

## Limits

We prove that the forgetful functor from `Sheaf J D` to presheaves creates limits.
If the target category `D` has limits (of a certain shape),
this then implies that `Sheaf J D` has limits of the same shape and that the forgetful
functor preserves these limits.

## Colimits

Given a diagram `F : K ⥤ Sheaf J D` of sheaves, and a colimit cocone on the level of presheaves,
we show that the cocone obtained by sheafifying the cocone point is a colimit cocone of sheaves.

This allows us to show that `Sheaf J D` has colimits (of a certain shape) as soon as `D` does.

-/

namespace CategoryTheory

namespace Sheaf

open CategoryTheory.Limits

open Opposite

section Limits

universe w v u z

variable {C : Type max v u} [Category.{v} C] {J : GrothendieckTopology C}

variable {D : Type w} [Category.{max v u} D]

variable {K : Type z} [SmallCategory K]

noncomputable section

section

/-- An auxiliary definition to be used below.

Whenever `E` is a cone of shape `K` of sheaves, and `S` is the multifork associated to a
covering `W` of an object `X`, with respect to the cone point `E.X`, this provides a cone of
shape `K` of objects in `D`, with cone point `S.X`.

See `is_limit_multifork_of_is_limit` for more on how this definition is used.
-/
def multiforkEvaluationCone (F : K ⥤ Sheaf J D) (E : Cone (F ⋙ sheafToPresheaf J D)) (X : C)
    (W : J.cover X) (S : Multifork (W.index E.pt)) :
    Cone (F ⋙ sheafToPresheaf J D ⋙ (evaluation Cᵒᵖ D).obj (op X))
    where
  pt := S.pt
  π :=
    { app := fun k =>
        (Presheaf.isLimitOfIsSheaf J (F.obj k).1 W (F.obj k).2).lift <|
          Multifork.ofι _ S.pt (fun i => S.ι i ≫ (E.π.app k).app (op i.y))
            (by
              intro i
              simp only [category.assoc]
              erw [← (E.π.app k).naturality, ← (E.π.app k).naturality]
              dsimp
              simp only [← category.assoc]
              congr 1
              apply S.condition)
      naturality' := by
        intro i j f
        dsimp [presheaf.is_limit_of_is_sheaf]
        rw [category.id_comp]
        apply presheaf.is_sheaf.hom_ext (F.obj j).2 W
        intro ii
        rw [presheaf.is_sheaf.amalgamate_map, category.assoc, ← (F.map f).val.naturality, ←
          category.assoc, presheaf.is_sheaf.amalgamate_map]
        dsimp [multifork.of_ι]
        erw [category.assoc, ← E.w f]
        tidy }
#align category_theory.Sheaf.multifork_evaluation_cone CategoryTheory.Sheaf.multiforkEvaluationCone

variable [HasLimitsOfShape K D]

/-- If `E` is a cone of shape `K` of sheaves, which is a limit on the level of presheves,
this definition shows that the limit presheaf satisfies the multifork variant of the sheaf
condition, at a given covering `W`.

This is used below in `is_sheaf_of_is_limit` to show that the limit presheaf is indeed a sheaf.
-/
def isLimitMultiforkOfIsLimit (F : K ⥤ Sheaf J D) (E : Cone (F ⋙ sheafToPresheaf J D))
    (hE : IsLimit E) (X : C) (W : J.cover X) : IsLimit (W.Multifork E.pt) :=
  Multifork.IsLimit.mk _
    (fun S =>
      (isLimitOfPreserves ((evaluation Cᵒᵖ D).obj (op X)) hE).lift <|
        multifork_evaluation_cone F E X W S)
    (by
      intro S i
      apply (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op i.Y)) hE).hom_ext
      intro k
      dsimp [multifork.of_ι]
      erw [category.assoc, (E.π.app k).naturality]
      dsimp
      rw [← category.assoc]
      erw [(is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).fac
          (multifork_evaluation_cone F E X W S)]
      dsimp [multifork_evaluation_cone, presheaf.is_limit_of_is_sheaf]
      erw [presheaf.is_sheaf.amalgamate_map]
      rfl)
    (by
      intro S m hm
      apply (is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).hom_ext
      intro k
      dsimp
      erw [(is_limit_of_preserves ((evaluation Cᵒᵖ D).obj (op X)) hE).fac]
      apply presheaf.is_sheaf.hom_ext (F.obj k).2 W
      intro i
      erw [presheaf.is_sheaf.amalgamate_map]
      dsimp [multifork.of_ι]
      change _ = S.ι i ≫ _
      erw [← hm, category.assoc, ← (E.π.app k).naturality, category.assoc]
      rfl)
#align category_theory.Sheaf.is_limit_multifork_of_is_limit CategoryTheory.Sheaf.isLimitMultiforkOfIsLimit

/-- If `E` is a cone which is a limit on the level of presheaves,
then the limit presheaf is again a sheaf.

This is used to show that the forgetful functor from sheaves to presheaves creates limits.
-/
theorem isSheaf_of_isLimit (F : K ⥤ Sheaf J D) (E : Cone (F ⋙ sheafToPresheaf J D))
    (hE : IsLimit E) : Presheaf.IsSheaf J E.pt :=
  by
  rw [presheaf.is_sheaf_iff_multifork]
  intro X S
  exact ⟨is_limit_multifork_of_is_limit _ _ hE _ _⟩
#align category_theory.Sheaf.is_sheaf_of_is_limit CategoryTheory.Sheaf.isSheaf_of_isLimit

instance (F : K ⥤ Sheaf J D) : CreatesLimit F (sheafToPresheaf J D) :=
  createsLimitOfReflectsIso fun E hE =>
    { liftedCone :=
        ⟨⟨E.pt, is_sheaf_of_is_limit _ _ hE⟩,
          ⟨fun t => ⟨E.π.app _⟩, fun u v e => Sheaf.Hom.ext _ _ <| E.π.naturality _⟩⟩
      validLift :=
        Cones.ext (eqToIso rfl) fun j => by
          dsimp
          simp
      makesLimit :=
        { lift := fun S => ⟨hE.lift ((sheafToPresheaf J D).mapCone S)⟩
          fac := fun S j => by
            ext1
            apply hE.fac ((Sheaf_to_presheaf J D).mapCone S) j
          uniq := fun S m hm => by
            ext1
            exact
              hE.uniq ((Sheaf_to_presheaf J D).mapCone S) m.val fun j =>
                congr_arg hom.val (hm j) } }

instance : CreatesLimitsOfShape K (sheafToPresheaf J D) where

instance : HasLimitsOfShape K (Sheaf J D) :=
  hasLimitsOfShape_of_hasLimitsOfShape_createsLimitsOfShape (sheafToPresheaf J D)

end

instance [HasLimits D] : CreatesLimits (sheafToPresheaf J D) :=
  ⟨⟩

instance [HasLimits D] : HasLimits (Sheaf J D) :=
  has_limits_of_has_limits_creates_limits (sheafToPresheaf J D)

end Limits

section Colimits

universe w v u

variable {C : Type max v u} [Category.{v} C] {J : GrothendieckTopology C}

variable {D : Type w} [Category.{max v u} D]

variable {K : Type max v u} [SmallCategory K]

-- Now we need a handful of instances to obtain sheafification...
variable [ConcreteCategory.{max v u} D]

variable [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), HasMultiequalizer (S.index P)]

variable [PreservesLimits (forget D)]

variable [∀ X : C, HasColimitsOfShape (J.cover X)ᵒᵖ D]

variable [∀ X : C, PreservesColimitsOfShape (J.cover X)ᵒᵖ (forget D)]

variable [ReflectsIsomorphisms (forget D)]

/-- Construct a cocone by sheafifying a cocone point of a cocone `E` of presheaves
over a functor which factors through sheaves.
In `is_colimit_sheafify_cocone`, we show that this is a colimit cocone when `E` is a colimit. -/
@[simps]
def sheafifyCocone {F : K ⥤ Sheaf J D} (E : Cocone (F ⋙ sheafToPresheaf J D)) : Cocone F
    where
  pt := ⟨J.sheafify E.pt, GrothendieckTopology.Plus.isSheaf_plus_plus _ _⟩
  ι :=
    { app := fun k => ⟨E.ι.app k ≫ J.toSheafify E.pt⟩
      naturality' := fun i j f => by
        ext1
        dsimp
        erw [category.comp_id, ← category.assoc, E.w f] }
#align category_theory.Sheaf.sheafify_cocone CategoryTheory.Sheaf.sheafifyCocone

/-- If `E` is a colimit cocone of presheaves, over a diagram factoring through sheaves,
then `sheafify_cocone E` is a colimit cocone. -/
@[simps]
def isColimitSheafifyCocone {F : K ⥤ Sheaf J D} (E : Cocone (F ⋙ sheafToPresheaf J D))
    (hE : IsColimit E) : IsColimit (sheafify_cocone E)
    where
  desc S := ⟨J.sheafifyLift (hE.desc ((sheafToPresheaf J D).mapCocone S)) S.pt.2⟩
  fac := by
    intro S j
    ext1
    dsimp [sheafify_cocone]
    erw [category.assoc, J.to_sheafify_sheafify_lift, hE.fac]
    rfl
  uniq := by
    intro S m hm
    ext1
    apply J.sheafify_lift_unique
    apply hE.uniq ((Sheaf_to_presheaf J D).mapCocone S)
    intro j
    dsimp
    simpa only [← category.assoc, ← hm]
#align category_theory.Sheaf.is_colimit_sheafify_cocone CategoryTheory.Sheaf.isColimitSheafifyCocone

instance [HasColimitsOfShape K D] : HasColimitsOfShape K (Sheaf J D) :=
  ⟨fun F =>
    HasColimit.mk
      ⟨sheafify_cocone (colimit.cocone _), is_colimit_sheafify_cocone _ (colimit.isColimit _)⟩⟩

instance [HasColimits D] : HasColimits (Sheaf J D) :=
  ⟨inferInstance⟩

end Colimits

end Sheaf

end CategoryTheory