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

import algebraic_topology.dold_kan.split_simplicial_object

/-!

# Construction of the inverse functor of the Dold-Kan equivalence

In this file, we construct the functor `Γ₀ : chain_complex C ℕ ⥤ simplicial_object C`
which shall be the inverse functor of the Dold-Kan equivalence in the case of abelian categories,
and more generally pseudoabelian categories.

By definition, when `K` is a chain_complex, `Γ₀.obj K` is a simplicial object which
sends `Δ : simplex_categoryᵒᵖ` to a certain coproduct indexed by the set
`splitting.index_set Δ` whose elements consists of epimorphisms `e : Δ.unop ⟶ Δ'.unop`
(with `Δ' : simplex_categoryᵒᵖ`); the summand attached to such an `e` is `K.X Δ'.unop.len`.
By construction, `Γ₀.obj K` is a split simplicial object whose splitting is `Γ₀.splitting K`.

We also construct `Γ₂ : karoubi (chain_complex C ℕ) ⥤ karoubi (simplicial_object C)`
which shall be an equivalence for any additive category `C`.

-/

noncomputable theory

open category_theory category_theory.category category_theory.limits
  simplex_category simplicial_object opposite category_theory.idempotents
open_locale simplicial dold_kan

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C] (K K' : chain_complex C ℕ) (f : K ⟶ K')
  {Δ'' Δ' Δ : simplex_category} (i' : Δ'' ⟶ Δ') [mono i'] (i : Δ' ⟶ Δ) [mono i]

/-- `is_δ₀ i` is a simple condition used to check whether a monomorphism `i` in
`simplex_category` identifies to the coface map `δ 0`. -/
@[nolint unused_arguments]
def is_δ₀ {Δ Δ' : simplex_category} (i : Δ' ⟶ Δ) [mono i] : Prop :=
(Δ.len = Δ'.len+1) ∧ (i.to_order_hom 0 ≠ 0)

namespace is_δ₀

lemma iff {j : ℕ} {i : fin (j+2)} : is_δ₀ (simplex_category.δ i) ↔ i = 0 :=
begin
  split,
  { rintro ⟨h₁, h₂⟩,
    by_contradiction,
    exact h₂ (fin.succ_above_ne_zero_zero h), },
  { rintro rfl,
    exact ⟨rfl, fin.succ_ne_zero _⟩, },
end

lemma eq_δ₀ {n : ℕ} {i : [n] ⟶ [n+1]} [mono i] (hi : is_δ₀ i) :
  i = simplex_category.δ 0 :=
begin
  unfreezingI { obtain ⟨j, rfl⟩ := simplex_category.eq_δ_of_mono i, },
  rw iff at hi,
  rw hi,
end

end is_δ₀

namespace Γ₀

namespace obj

/-- In the definition of `(Γ₀.obj K).obj Δ` as a direct sum indexed by `A : splitting.index_set Δ`,
the summand `summand K Δ A` is `K.X A.1.len`. -/
def summand (Δ : simplex_categoryᵒᵖ) (A : splitting.index_set Δ) : C := K.X A.1.unop.len

/-- The functor `Γ₀` sends a chain complex `K` to the simplicial object which
sends `Δ` to the direct sum of the objects `summand K Δ A` for all `A : splitting.index_set Δ` -/
def obj₂ (K : chain_complex C ℕ) (Δ : simplex_categoryᵒᵖ) [has_finite_coproducts C] : C :=
∐ (λ (A : splitting.index_set Δ), summand K Δ A)

namespace termwise

/-- A monomorphism `i : Δ' ⟶ Δ` induces a morphism `K.X Δ.len ⟶ K.X Δ'.len` which
is the identity if `Δ = Δ'`, the differential on the complex `K` if `i = δ 0`, and
zero otherwise. -/
def map_mono (K : chain_complex C ℕ) {Δ' Δ : simplex_category} (i : Δ' ⟶ Δ) [mono i] :
  K.X Δ.len ⟶ K.X Δ'.len :=
begin
  by_cases Δ = Δ',
  { exact eq_to_hom (by congr'), },
  { by_cases is_δ₀ i,
    { exact K.d Δ.len Δ'.len, },
    { exact 0, }, },
end

variable (Δ)

lemma map_mono_id : map_mono K (𝟙 Δ) = 𝟙 _ :=
by { unfold map_mono, simp only [eq_self_iff_true, eq_to_hom_refl, dite_eq_ite, if_true], }

variable {Δ}

lemma map_mono_δ₀' (hi : is_δ₀ i) : map_mono K i = K.d Δ.len Δ'.len :=
begin
  unfold map_mono,
  classical,
  rw [dif_neg, dif_pos hi],
  unfreezingI { rintro rfl, },
  simpa only [self_eq_add_right, nat.one_ne_zero] using hi.1,
end

@[simp]
lemma map_mono_δ₀ {n : ℕ} : map_mono K (δ (0 : fin (n+2))) = K.d (n+1) n :=
map_mono_δ₀' K _ (by rw is_δ₀.iff)

lemma map_mono_eq_zero (h₁ : Δ ≠ Δ') (h₂ : ¬is_δ₀ i) : map_mono K i = 0 :=
by { unfold map_mono, rw ne.def at h₁, split_ifs, refl, }

variables {K K'}

@[simp, reassoc]
lemma map_mono_naturality : map_mono K i ≫ f.f Δ'.len = f.f Δ.len ≫ map_mono K' i :=
begin
  unfold map_mono,
  split_ifs,
  { unfreezingI { subst h, },
    simp only [id_comp, eq_to_hom_refl, comp_id], },
  { rw homological_complex.hom.comm, },
  { rw [zero_comp, comp_zero], }
end

variable (K)

@[simp, reassoc]
lemma map_mono_comp : map_mono K i ≫ map_mono K i' = map_mono K (i' ≫ i) :=
begin
  /- case where i : Δ' ⟶ Δ is the identity -/
  by_cases h₁ : Δ = Δ',
  { unfreezingI { subst h₁, },
    simp only [simplex_category.eq_id_of_mono i,
      comp_id, id_comp, map_mono_id K, eq_to_hom_refl], },
  /- case where i' : Δ'' ⟶ Δ' is the identity -/
  by_cases h₂ : Δ' = Δ'',
  { unfreezingI { subst h₂, },
    simp only [simplex_category.eq_id_of_mono i',
      comp_id, id_comp, map_mono_id K, eq_to_hom_refl], },
  /- then the RHS is always zero -/
  obtain ⟨k, hk⟩ := nat.exists_eq_add_of_lt (len_lt_of_mono i h₁),
  obtain ⟨k', hk'⟩ := nat.exists_eq_add_of_lt (len_lt_of_mono i' h₂),
  have eq : Δ.len = Δ''.len + (k+k'+2) := by linarith,
  rw map_mono_eq_zero K (i' ≫ i) _ _, rotate,
  { by_contradiction,
    simpa only [self_eq_add_right, h] using eq, },
  { by_contradiction,
    simp only [h.1, add_right_inj] at eq,
    linarith, },
  /- in all cases, the LHS is also zero, either by definition, or because d ≫ d = 0 -/
  by_cases h₃ : is_δ₀ i,
  { by_cases h₄ : is_δ₀ i',
    { rw [map_mono_δ₀' K i h₃, map_mono_δ₀' K i' h₄,
        homological_complex.d_comp_d], },
    { simp only [map_mono_eq_zero K i' h₂ h₄, comp_zero], }, },
  { simp only [map_mono_eq_zero K i h₁ h₃, zero_comp], },
end

end termwise

variable [has_finite_coproducts C]

/-- The simplicial morphism on the simplicial object `Γ₀.obj K` induced by
a morphism `Δ' → Δ` in `simplex_category` is defined on each summand
associated to an `A : Γ_index_set Δ` in terms of the epi-mono factorisation
of `θ ≫ A.e`. -/
def map (K : chain_complex C ℕ) {Δ' Δ : simplex_categoryᵒᵖ} (θ : Δ ⟶ Δ') :
  obj₂ K Δ ⟶ obj₂ K Δ' :=
sigma.desc (λ A, termwise.map_mono K (image.ι (θ.unop ≫ A.e)) ≫
  (sigma.ι (summand K Δ') (A.pull θ)))

@[reassoc]
lemma map_on_summand₀ {Δ Δ' : simplex_categoryᵒᵖ} (A : splitting.index_set Δ) {θ : Δ ⟶ Δ'}
  {Δ'' : simplex_category} {e : Δ'.unop ⟶ Δ''} {i : Δ'' ⟶ A.1.unop} [epi e] [mono i]
  (fac : e ≫ i = θ.unop ≫ A.e) :
  (sigma.ι (summand K Δ) A) ≫ map K θ =
    termwise.map_mono K i ≫ sigma.ι (summand K Δ') (splitting.index_set.mk e) :=
begin
  simp only [map, colimit.ι_desc, cofan.mk_ι_app],
  have h := simplex_category.image_eq fac,
  unfreezingI { subst h, },
  congr,
  { exact simplex_category.image_ι_eq fac, },
  { dsimp only [simplicial_object.splitting.index_set.pull],
    congr,
    exact simplex_category.factor_thru_image_eq fac, },
end

@[reassoc]
lemma map_on_summand₀' {Δ Δ' : simplex_categoryᵒᵖ} (A : splitting.index_set Δ) (θ : Δ ⟶ Δ') :
  (sigma.ι (summand K Δ) A) ≫ map K θ =
    termwise.map_mono K (image.ι (θ.unop ≫ A.e)) ≫ sigma.ι (summand K _) (A.pull θ) :=
map_on_summand₀ K A (A.fac_pull θ)

end obj

variable [has_finite_coproducts C]

/-- The functor `Γ₀ : chain_complex C ℕ ⥤ simplicial_object C`, on objects. -/
@[simps]
def obj (K : chain_complex C ℕ) : simplicial_object C :=
{ obj := λ Δ, obj.obj₂ K Δ,
  map := λ Δ Δ' θ, obj.map K θ,
  map_id' := λ Δ, begin
    ext A,
    cases A,
    have fac : A.e ≫ 𝟙 A.1.unop = (𝟙 Δ).unop ≫ A.e := by rw [unop_id, comp_id, id_comp],
    erw [obj.map_on_summand₀ K A fac, obj.termwise.map_mono_id, id_comp, comp_id],
    unfreezingI { rcases A with ⟨Δ', ⟨e, he⟩⟩, },
    refl,
  end,
  map_comp' := λ Δ'' Δ' Δ θ' θ, begin
    ext A,
    cases A,
    have fac : θ.unop ≫ θ'.unop ≫ A.e = (θ' ≫ θ).unop ≫ A.e := by rw [unop_comp, assoc],
    rw [← image.fac (θ'.unop ≫ A.e), ← assoc,
      ← image.fac (θ.unop ≫ factor_thru_image (θ'.unop ≫ A.e)), assoc] at fac,
    simpa only [obj.map_on_summand₀'_assoc K A θ', obj.map_on_summand₀' K _ θ,
      obj.termwise.map_mono_comp_assoc, obj.map_on_summand₀ K A fac],
  end }

lemma splitting_map_eq_id (Δ : simplex_categoryᵒᵖ) :
  (simplicial_object.splitting.map (Γ₀.obj K)
    (λ (n : ℕ), sigma.ι (Γ₀.obj.summand K (op [n])) (splitting.index_set.id (op [n]))) Δ)
    = 𝟙 _ :=
begin
  ext A,
  discrete_cases,
  induction Δ using opposite.rec,
  induction Δ with n,
  dsimp,
  simp only [colimit.ι_desc, cofan.mk_ι_app, comp_id, Γ₀.obj_map],
  rw [Γ₀.obj.map_on_summand₀ K
    (simplicial_object.splitting.index_set.id A.1) (show A.e ≫ 𝟙 _ = A.e.op.unop ≫ 𝟙 _, by refl),
    Γ₀.obj.termwise.map_mono_id, A.ext'],
  apply id_comp,
end

/-- By construction, the simplicial `Γ₀.obj K` is equipped with a splitting. -/
def splitting (K : chain_complex C ℕ) : simplicial_object.splitting (Γ₀.obj K) :=
{ N := λ n, K.X n,
  ι := λ n, sigma.ι (Γ₀.obj.summand K (op [n])) (splitting.index_set.id (op [n])),
  map_is_iso' := λ Δ, begin
    rw Γ₀.splitting_map_eq_id,
    apply is_iso.id,
  end, }

@[simp]
lemma splitting_iso_hom_eq_id (Δ : simplex_categoryᵒᵖ) : ((splitting K).iso Δ).hom = 𝟙 _ :=
splitting_map_eq_id K Δ

@[reassoc]
lemma obj.map_on_summand {Δ Δ' : simplex_categoryᵒᵖ} (A : splitting.index_set Δ) (θ : Δ ⟶ Δ')
  {Δ'' : simplex_category}
  {e : Δ'.unop ⟶ Δ''} {i : Δ'' ⟶ A.1.unop} [epi e] [mono i]
  (fac : e ≫ i = θ.unop ≫ A.e) : (Γ₀.splitting K).ι_summand A ≫ (Γ₀.obj K).map θ =
  Γ₀.obj.termwise.map_mono K i ≫ (Γ₀.splitting K).ι_summand (splitting.index_set.mk e) :=
begin
  dsimp only [simplicial_object.splitting.ι_summand,
    simplicial_object.splitting.ι_coprod],
  simp only [assoc, Γ₀.splitting_iso_hom_eq_id, id_comp, comp_id],
  exact Γ₀.obj.map_on_summand₀ K A fac,
end

@[reassoc]

@[reassoc]
lemma obj.map_mono_on_summand_id {Δ Δ' : simplex_category} (i : Δ' ⟶ Δ) [mono i] :
  (splitting K).ι_summand (splitting.index_set.id (op Δ)) ≫ (obj K).map i.op =
  obj.termwise.map_mono K i ≫ (splitting K).ι_summand (splitting.index_set.id (op Δ')) :=
obj.map_on_summand K (splitting.index_set.id (op Δ)) i.op (rfl : 𝟙 _ ≫ i = i ≫ 𝟙 _)

@[reassoc]
lemma obj.map_epi_on_summand_id {Δ Δ' : simplex_category } (e : Δ' ⟶ Δ) [epi e] :
  (Γ₀.splitting K).ι_summand (splitting.index_set.id (op Δ)) ≫ (Γ₀.obj K).map e.op =
    (Γ₀.splitting K).ι_summand (splitting.index_set.mk e) :=
by simpa only [Γ₀.obj.map_on_summand K (splitting.index_set.id (op Δ)) e.op
    (rfl : e ≫ 𝟙 Δ = e ≫ 𝟙 Δ), Γ₀.obj.termwise.map_mono_id] using id_comp _

/-- The functor `Γ₀ : chain_complex C ℕ ⥤ simplicial_object C`, on morphisms. -/
@[simps]
def map {K K' : chain_complex C ℕ} (f : K ⟶ K') : obj K ⟶ obj K' :=
{ app := λ Δ, (Γ₀.splitting K).desc Δ (λ A, f.f A.1.unop.len ≫ (Γ₀.splitting K').ι_summand A),
  naturality' := λ Δ' Δ θ, begin
    apply (Γ₀.splitting K).hom_ext',
    intro A,
    simp only [(splitting K).ι_desc_assoc, obj.map_on_summand'_assoc K _ θ,
      (splitting K).ι_desc, assoc, obj.map_on_summand' K' _ θ],
    apply obj.termwise.map_mono_naturality_assoc,
  end, }

end Γ₀

variable [has_finite_coproducts C]

/-- The functor `Γ₀' : chain_complex C ℕ ⥤ simplicial_object.split C`
that induces `Γ₀ : chain_complex C ℕ ⥤ simplicial_object C`, which
shall be the inverse functor of the Dold-Kan equivalence for
abelian or pseudo-abelian categories. -/
@[simps]
def Γ₀' : chain_complex C ℕ ⥤ simplicial_object.split C :=
{ obj := λ K, simplicial_object.split.mk' (Γ₀.splitting K),
  map := λ K K' f,
  { F := Γ₀.map f,
    f := f.f,
    comm' := λ n, by { dsimp, simpa only [← splitting.ι_summand_id,
      (Γ₀.splitting K).ι_desc], }, }, }

/-- The functor `Γ₀ : chain_complex C ℕ ⥤ simplicial_object C`, which is
the inverse functor of the Dold-Kan equivalence when `C` is an abelian
category, or more generally a pseudoabelian category. -/
@[simps]
def Γ₀ : chain_complex C ℕ ⥤ simplicial_object C := Γ₀' ⋙ split.forget _

/-- The extension of `Γ₀ : chain_complex C ℕ ⥤ simplicial_object C`
on the idempotent completions. It shall be an equivalence of categories
for any additive category `C`. -/
@[simps]
def Γ₂ : karoubi (chain_complex C ℕ) ⥤ karoubi (simplicial_object C) :=
(category_theory.idempotents.functor_extension₂ _ _).obj Γ₀

lemma higher_faces_vanish.on_Γ₀_summand_id (K : chain_complex C ℕ) (n : ℕ) :
  higher_faces_vanish (n+1) ((Γ₀.splitting K).ι_summand (splitting.index_set.id (op [n+1]))) :=
begin
  intros j hj,
  have eq := Γ₀.obj.map_mono_on_summand_id K (simplex_category.δ j.succ),
  rw [Γ₀.obj.termwise.map_mono_eq_zero K, zero_comp] at eq, rotate,
  { intro h,
    exact (nat.succ_ne_self n) (congr_arg simplex_category.len h), },
  { exact λ h, fin.succ_ne_zero j (by simpa only [is_δ₀.iff] using h), },
  exact eq,
end

@[simp, reassoc]
lemma P_infty_on_Γ₀_splitting_summand_eq_self
  (K : chain_complex C ℕ) {n : ℕ} :
  (Γ₀.splitting K).ι_summand (splitting.index_set.id (op [n])) ≫ (P_infty : K[Γ₀.obj K] ⟶ _).f n =
    (Γ₀.splitting K).ι_summand (splitting.index_set.id (op [n])) :=
begin
  rw P_infty_f,
  cases n,
  { simpa only [P_f_0_eq] using comp_id _, },
  { exact (higher_faces_vanish.on_Γ₀_summand_id K n).comp_P_eq_self, },
end

end dold_kan

end algebraic_topology


/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import number_theory.padics.padic_integers
import topology.continuous_function.compact
import topology.continuous_function.locally_constant

/-!
# p-adic measure theory

This file defines p-adic distributions and measure on the space of locally constant functions
from a profinite space to a normed ring. We then use the measure to construct the p-adic integral.
In fact, we prove that this integral is linearly and continuously extended on `C(X, A`.

## Main definitions and theorems
 * `exists_finset_clopen`
 * `measures`
 * `integral`

## Implementation notes
TODO (optional)

## References
Introduction to Cyclotomic Fields, Washington (Chapter 12)

## Tags
p-adic L-function, p-adic integral, measure, totally disconnected, locally constant, compact,
Hausdorff

###############
Note (jmc): this file was copied with permission of Ashvni Narayan from
https://github.com/leanprover-community/mathlib/blob/f2fd1fb4507431cf2f2a873db4b97d360633fb69/src/number_theory/L_functions.lean#L453
and subsequently mildly modified.
###############

-/

variables (X : Type*) [topological_space X]
variables (A : Type*) [normed_add_comm_group A]

variable {X}
variables [compact_space X]

namespace set
lemma diff_inter_eq_empty {α : Type*} (a : set α) {b c : set α} (h : c ⊆ b) :
  a \ b ∩ c = ∅ :=
begin
  ext x,
  simp only [and_imp, not_and, mem_diff, iff_false, mem_inter_iff, mem_empty_iff_false],
  intro _,
  exact mt (@h x),
end

lemma diff_inter_mem_sUnion {α : Type*} {s : set (set α)} (a y : set α) (h : y ∈ s) :
  (a \ ⋃₀ s) ∩ y = ∅ :=
diff_inter_eq_empty a $ subset_sUnion_of_mem h

end set

namespace is_clopen

lemma is_closed_sUnion {H : Type*} [topological_space H]
  {s : finset(set H)} (hs : ∀ x ∈ s, is_closed x) :
  is_closed ⋃₀ (s : set(set H)) :=
by { simpa only [← is_open_compl_iff, set.compl_sUnion, set.sInter_image] using is_open_bInter
    (finset.finite_to_set s) (λ i hi, _), apply is_open_compl_iff.2 (hs i hi), }

lemma is_clopen_sUnion {H : Type*} [topological_space H]
  (s : finset(set H)) (hs : ∀ x ∈ s, is_clopen x) :
  is_clopen ⋃₀ (s : set(set H)) :=
⟨is_open_sUnion (λ t ht, (hs t ht).1), is_closed_sUnion (λ t ht, (hs t ht).2) ⟩

/-- The finite union of clopen sets is clopen. -/
lemma clopen_finite_Union {H : Type*} [topological_space H]
  (s : finset(set H)) (hs : ∀ x ∈ s, is_clopen x) :
  is_clopen ⋃₀ (s : set(set H)) :=
  by { rw set.sUnion_eq_bUnion, apply is_clopen_bUnion s.finite_to_set hs, }

/-- Given a finite set of clopens, one can find a finite disjoint set of clopens contained in
  it. -/
lemma clopen_Union_disjoint {H : Type*} [topological_space H]
  (s : finset(set H)) (hs : ∀ x ∈ s, is_clopen x) :
  ∃ (t : finset (set H)),
  (∀ (x ∈ (t : set (set H))), is_clopen x) ∧
  ⋃₀ (s : set(set H)) = ⋃₀ (t : set(set H)) ∧
  (∀ (x : set H) (hx : x ∈ t), ∃ z ∈ s, x ⊆ z) ∧
  ∀ (x y : set H) (hx : x ∈ t) (hy : y ∈ t) (h : x ≠ y), x ∩ y = ∅ :=
begin
  classical,
  apply finset.induction_on' s,
  { use ∅, simp only [finset.coe_empty, set.mem_empty_iff_false, is_empty.forall_iff, forall_const,
      eq_self_iff_true, finset.not_mem_empty, and_self]},
  { rintros a S h's hS aS ⟨t, clo, union, sub, disj⟩,
    set b := a \ ⋃₀ S with hb,
    refine ⟨insert b t, _, _, ⟨λ x hx, _, λ x y hx hy ne, _⟩⟩,
    { rintros x hx,
      simp only [finset.coe_insert, set.mem_insert_iff, finset.mem_coe] at hx,
      cases hx,
      { rw hx, apply is_clopen.diff (hs a h's) (clopen_finite_Union _ (λ y hy, (hs y (hS hy)))), },
      { apply clo x hx, }, },
    { simp only [finset.coe_insert, set.sUnion_insert], rw [←union, set.diff_union_self], },
    { simp only [finset.mem_insert] at hx, cases hx,
      { use a, rw hx, simp only [true_and, true_or, eq_self_iff_true, finset.mem_insert],
        apply set.diff_subset, },
      { rcases sub x hx with ⟨z, hz, xz⟩, refine ⟨z, _, xz⟩,
        rw finset.mem_insert, right, assumption, }, },
    { rw finset.mem_insert at hx, rw finset.mem_insert at hy,
      have : ∀ y ∈ t, b ∩ y = ∅,
      { rintros y hy, rw [hb, union], apply set.diff_inter_mem_sUnion, assumption, },
      cases hx,
      { cases hy,
        { exfalso, apply ne, rw [hx, hy], },
        { rw hx, apply this y hy, }, },
      { cases hy,
        { rw set.inter_comm, rw hy, apply this x hx, },
        { apply disj x y hx hy ne, }, }, }, },
end

end is_clopen

namespace locally_constant.density

variables (ε : ℝ)

/-- Takes an element of `A` to an `ε/4`-ball centered around it. -/
abbreviation h {A : Type*} [normed_add_comm_group A] : A → set A :=
  λ (x : A), metric.ball x (ε / 4)

/-- The set of (ε/4)-balls. -/
abbreviation S {A : Type*} [normed_add_comm_group A] : set (set A) := set.range (h ε)

variables {A} (f : C(X, A))

/-- Preimage of (ε/4)-balls. -/
abbreviation B : set(set X) := { j : set X | ∃ (U ∈ ((S ε) : set(set A))), j = f ⁻¹' U }

lemma opens {j : set X} (hj : j ∈ (B ε f)) : is_open j :=
begin
  rcases hj with ⟨hj_w, ⟨hj_h_w_w, rfl⟩, rfl⟩,
  exact continuous.is_open_preimage f.2 _ (metric.is_open_ball),
end

variable [fact (0 < ε)]
/-- `X` is covered by a union of preimage of finitely many elements of `S` under `f` -/
lemma exists_finset_univ_sub : ∃ (t : finset (set A)), set.univ ⊆ ⨆ (i : set A) (H : i ∈ t)
  (H : i ∈ ((S ε) : set(set A))), f ⁻¹' i :=
begin
  have g : (⋃₀ S ε) = (set.univ : set A),
  { rw set.sUnion_eq_univ_iff, rintros, refine ⟨metric.ball a (ε/4), _, _⟩,
    { simp only [set.mem_range, exists_apply_eq_apply], },
    { simp only [metric.mem_ball, dist_self],
      refine div_pos (fact.out _) zero_lt_four, }, },
  have g' : set.preimage f (⋃₀ S ε) = set.univ,
  { rw g, exact set.preimage_univ, },
  rw [set.preimage_sUnion, set.subset.antisymm_iff] at g',
  refine is_compact.elim_finite_subcover compact_univ _ (λ i, is_open_Union
    (λ hi, continuous.is_open_preimage (continuous_map.continuous f) i _)) g'.2,
  cases hi with y hy, rw [←hy], refine @metric.is_open_ball A _ y (ε/4),
end

/-- Choosing a finset as given in `exists_finset_univ_sub` -/
noncomputable abbreviation t : finset (set A) := classical.some (exists_finset_univ_sub ε f)

lemma exists_finset_univ_sub_prop : set.univ ⊆ ⨆ (i : set A) (H : i ∈ t ε f)
  (H : i ∈ ((S ε) : set(set A))), f ⁻¹' i := classical.some_spec (exists_finset_univ_sub ε f)

/-- If there is a finite set of sets from `S` whose preimage forms a cover for `X`,
  then the union of the preimages of all the sets from `S` also forms a cover. -/
lemma sUnion_sub_of_finset_sub : set.univ ⊆ set.sUnion (B ε f) :=
begin
  rintros x hx,
  obtain ⟨-, ⟨j, rfl⟩, -, ⟨hj, rfl⟩, -, ⟨⟨a, jS⟩, rfl⟩, fj⟩ := (exists_finset_univ_sub_prop ε f) hx,
  exact ⟨f⁻¹' j, ⟨j, ⟨_, jS⟩, rfl⟩, fj⟩,
end

variables [t2_space X] [totally_disconnected_space X]

/-- If there is a finite set of sets from `S` whose preimage forms a cover for `X`,
  then there is a cover of `X` by clopen sets, with the image of each set being
  contained in an element of `S`. -/
def set_clopen : set (set X) := {j : set X | ∃ (U : set X) (hU : U ∈ (B ε f)),
    j ∈ classical.some (topological_space.is_topological_basis.open_eq_sUnion
    (@loc_compact_Haus_tot_disc_of_zero_dim X _ _ _ _) (opens ε f hU))}

lemma mem_set_clopen {x : set X} : x ∈ (set_clopen ε f) ↔ ∃ (U : set X) (hU : U ∈ (B ε f)),
    x ∈ classical.some (topological_space.is_topological_basis.open_eq_sUnion
    (@loc_compact_Haus_tot_disc_of_zero_dim X _ _ _ _) (opens ε f hU)) := iff.rfl

/-- Elements of `set_clopen` are clopen. -/
lemma set_clopen_sub_clopen_set : (set_clopen ε f) ⊆ {s : set X | is_clopen s} :=
begin
  intros j hj,
  obtain ⟨W, hW, hj⟩ := (mem_set_clopen ε f).1 hj,
  obtain ⟨H, -⟩ := classical.some_spec (topological_space.is_topological_basis.open_eq_sUnion
    (@loc_compact_Haus_tot_disc_of_zero_dim X _ _ _ _) (opens ε f hW)),
  exact H hj,
end

/-- `set_clopen` covers X. -/
lemma univ_sub_sUnion_set_clopen : set.univ ⊆ ⋃₀ (set_clopen ε f) :=
begin
  rintros x hx, rw set.mem_sUnion,
  have f' := @loc_compact_Haus_tot_disc_of_zero_dim X _ _ _ _,
  have sUnion_sub_of_finset_sub := sUnion_sub_of_finset_sub ε f,
-- writing `f⁻¹' U` as a union of basis elements (clopen sets)
  conv at sUnion_sub_of_finset_sub { congr, skip, rw set.sUnion_eq_Union, congr, funext,
    apply_congr classical.some_spec (classical.some_spec
    (topological_space.is_topological_basis.open_eq_sUnion f' (opens ε f i.prop))), },
  rw set.Union at sUnion_sub_of_finset_sub,
  have g3 := sUnion_sub_of_finset_sub hx,
  simp only [exists_prop, set.mem_Union, set.mem_range, set_coe.exists, exists_exists_eq_and,
    set.supr_eq_Union, set.mem_set_of_eq, subtype.coe_mk] at g3,
  rcases g3 with ⟨U, hU, a, ha, xa⟩,
  refine ⟨a, _, xa⟩,
  rw mem_set_clopen,
  simp only [exists_prop, set.mem_range, exists_exists_eq_and, set.mem_set_of_eq],
  refine ⟨U, hU, ha⟩,
end

/-- The image of each element of `set_clopen` is contained in an element of `S`. -/
lemma exists_B_of_mem_clopen {x : set X} (hx : x ∈ set_clopen ε f) :
  ∃ (U : set X) (H : U ∈ B ε f), x ⊆ U :=
begin
  rcases hx with ⟨U, hU, xU⟩, refine ⟨U, hU, _⟩,
  obtain ⟨H, H1⟩ := classical.some_spec
    (topological_space.is_topological_basis.open_eq_sUnion
    (@loc_compact_Haus_tot_disc_of_zero_dim X _ _ _ _) (opens ε f hU)),
  rw H1, intros u hu, simp only [exists_prop, set.mem_set_of_eq],
  refine ⟨x, _, hu⟩,
  convert xU,
  ext, simp only [exists_prop, iff_self],
end

/-- Every element of `set_clopen` is open. -/
lemma mem_set_clopen_is_open (i : (set_clopen ε f)) : is_open (i : set X) :=
 topological_space.is_topological_basis.is_open (@loc_compact_Haus_tot_disc_of_zero_dim X _ _ _ _)
  ((set_clopen_sub_clopen_set ε f) i.2)

/-- A restatement of `univ_sub_sUnion_set_clopen`. -/
lemma cover : (set.univ : set X) ⊆ ⋃ (i : (set_clopen ε f)), ↑i :=
by { convert univ_sub_sUnion_set_clopen ε f, rw set.sUnion_eq_Union, }

/-- Obtain a finite subcover of `set_clopen` using the compactness of `X`. -/
noncomputable abbreviation s' := classical.some (is_compact.elim_finite_subcover
  (@compact_univ X _ _) _ (mem_set_clopen_is_open ε f) (cover ε f))

/-- Coercing a subset of `set_clopen` in `s'` to `set X`. -/
abbreviation s1 := λ (x : s' ε f), (x.1 : set X)

/-- The range of `s1` is finite. -/
lemma fin : (set.range (s1 ε f)).finite :=
by { apply set.finite_range _, exact finite.of_fintype ↥(s' ε f), }

/-- Any element in the range of `s1` is clopen. -/
lemma is_clopen_x {x : set X} (hx : x ∈ (fin ε f).to_finset) : is_clopen x :=
begin
  simp only [set.mem_range, set_coe.exists, set.finite.mem_to_finset, finset.mem_coe] at hx,
  rcases hx with ⟨⟨⟨v, hv⟩, hw⟩, hU⟩,
  convert (set_clopen_sub_clopen_set ε f) hv,
  rw ←hU,
  delta s1,
  simp,
end

/-- If there is a finite set of sets from `S` whose preimage forms a cover for `X`,
  then there is a finset of `sets X` containing clopen sets, with the image of each set being
  contained in an element of `S`. We use `s'` to get a finite disjoint clopen cover of `X`;
  note : it is not a partition -/
noncomputable def finset_clopen : finset (set X) :=
  classical.some (is_clopen.clopen_Union_disjoint
    (set.finite.to_finset (fin ε f)) (λ x hx, (is_clopen_x ε f hx)))

/-- Elements of `finset_clopen` are clopen. -/
lemma finset_clopen_is_clopen {x : set X} (hx : x ∈ finset_clopen ε f) : is_clopen x :=
  (classical.some_spec (is_clopen.clopen_Union_disjoint (set.finite.to_finset (fin ε f))
    (λ x hx, (is_clopen_x ε f hx)))).1 x hx

/-- The image of every element of `finset_clopen` is contained in some element of `S`. -/
lemma exists_sub_S {x : set X} (hx : x ∈ finset_clopen ε f) :
  ∃ U ∈ ((S ε) : set(set A)), (set.image f x : set A) ⊆ U :=
begin
  rcases (classical.some_spec (is_clopen.clopen_Union_disjoint
    (set.finite.to_finset (fin ε f)) (λ x hx, (is_clopen_x ε f hx)))).2.2.1 x hx with ⟨z, hz, wz⟩,
  simp only [set.mem_range, set_coe.exists, set.finite.mem_to_finset, finset.mem_coe] at hz,
  -- `z'` is a lift of `x` in `V`
  rcases hz with ⟨⟨⟨z', h1⟩, h2⟩, h3⟩,
  rcases exists_B_of_mem_clopen ε f h1 with ⟨U, BU, xU⟩,
  simp only [exists_prop, exists_exists_eq_and, set.mem_set_of_eq] at BU,
  cases BU with U' h4,
  refine ⟨U', h4.1, _⟩, transitivity (set.image f z),
  { apply set.image_subset _ wz, },
  { simp only [set.image_subset_iff], rw [←h4.2, ←h3],
    delta s1,
    simp only [xU, subtype.coe_mk], },
end

/-- Showing that `finset_clopen` is a disjoint cover of `X`. -/
lemma finset_clopen_prop (a : X) : ∃! (b ∈ finset_clopen ε f), a ∈ b :=
begin
-- proving that every element `a : X` is contained in a unique element `j` of `s`
  obtain ⟨j, hj, aj⟩ : ∃ j ∈ finset_clopen ε f, a ∈ j,
  { -- `s'` covers `X`
    have ha := classical.some_spec (is_compact.elim_finite_subcover
      (@compact_univ X _ _) _ (mem_set_clopen_is_open ε f) (cover ε f)) (set.mem_univ a),
    have hs := (classical.some_spec (is_clopen.clopen_Union_disjoint
      (set.finite.to_finset (fin ε f)) (λ x hx, (is_clopen_x ε f hx)))).2.1,
    delta s1 at hs,
    suffices : a ∈ ⋃₀ (finset_clopen ε f : set(set X)),
    { simp only [set.mem_sUnion, finset.mem_coe, exists_prop] at this,
      cases this with j hj, refine ⟨j, hj.1, hj.2⟩, },
    { rw finset_clopen,
      rw ←hs,
      simp only [set.mem_Union, set.finite.coe_to_finset, subtype.val_eq_coe, set.sUnion_range],
      simp only [exists_prop, set.mem_Union, set_coe.exists, exists_and_distrib_right,
        subtype.coe_mk] at ha,
      -- have the element `U` of `V`, now translate it to `s`
      rcases ha with ⟨U, ⟨hU, s'U⟩, aU⟩,
      delta s',
      refine ⟨⟨⟨U, hU⟩, s'U⟩, aU⟩, }, },
  refine ⟨j, _, λ y hy, _⟩,
  { -- existence
    simp only [exists_prop, set.image_subset_iff, set.mem_range, exists_exists_eq_and,
      exists_unique_iff_exists],
    refine ⟨hj, aj⟩, },
  { -- uniqueness, coming from the disjointness of the clopen cover, `disj`
    simp only [exists_prop, exists_unique_iff_exists] at hy,
    cases hy with h1 h2,
    have disj := (classical.some_spec (is_clopen.clopen_Union_disjoint
      (set.finite.to_finset (fin ε f)) (λ x hx, (is_clopen_x ε f hx)))).2.2.2 j y hj h1,
    by_cases h : j = y,
    { rw h.symm, },
    { exfalso, specialize disj h, rw ←set.mem_empty_iff_false, rw ←disj,
      apply set.mem_inter aj _,
      simp only [and_true, implies_true_iff, eq_iff_true_of_subsingleton] at h2,
      exact h2, }, },
end

/-- Takes a nonempty `s` in `finset_clopen` and returns an element of it. -/
noncomputable abbreviation c' := λ (s : set X) (H : s ∈ (finset_clopen ε f) ∧ nonempty s),
  classical.choice (H.2)

/-- Any `x` in `X` must belong to a unique `s` in `finset_clopen`. `c2` takes `x` to the image of
  any element of `s` under `f`, which is the same `f x`. -/
noncomputable abbreviation c2 (f : C(X, A)) : X → A :=
λ x, f (c' ε f (classical.some (exists_of_exists_unique (finset_clopen_prop ε f x)) )
begin
  have := (exists_prop.1 (exists_of_exists_unique (classical.some_spec
    (exists_of_exists_unique (finset_clopen_prop ε f x))))),
  split,
  refine finset.mem_coe.1 (this).1,
  apply set.nonempty.to_subtype,
  refine ⟨x, this.2⟩,
end).

/-- Any element of `finset_clopen` is open. -/
lemma mem_finset_clopen_is_open {U : set X} (hU : U ∈ finset_clopen ε f) : is_open U :=
by { rw finset_clopen at hU, apply (finset_clopen_is_clopen ε f hU).1, }

/-- An equivalent version of `disj`. -/
lemma mem_finset_clopen_unique' {U V : set X} {y : X}
  (hU : U ∈ finset_clopen ε f) (hUy : y ∈ U) (hVy : y ∈ V) (hV : V ∈ finset_clopen ε f) : V = U :=
begin
  by_contra,
  have := (classical.some_spec (is_clopen.clopen_Union_disjoint
    (set.finite.to_finset (fin ε f)) (λ x hx, (is_clopen_x ε f hx)))).2.2.2 _ _ hV hU h,
  revert this,
  --change (V ∩ U) ≠ ∅,
  refine set.nonempty.ne_empty ⟨y, set.mem_inter hVy hUy⟩,
end

/-- Given `x` in `X`, there is a unique element `U` of `finset_clopen` such that `x ∈ U`. For any
  `y ∈ U`, `y` is contained in any other element `V` of `finset_clopen` containing `x`. -/
lemma mem_finset_clopen_unique {U V : set X} {x y : X}
  (U_prop : (U ∈ finset_clopen ε f ∧ x ∈ U) ∧ ∀ (y : set X), y ∈ finset_clopen ε f →
    x ∈ y → y = U) (hy : y ∈ U) (hV : V ∈ finset_clopen ε f) : x ∈ V ↔ y ∈ V :=
begin
  obtain ⟨W, hW⟩ := finset_clopen_prop ε f y,
  simp only [and_imp, exists_prop, exists_unique_iff_exists] at hW,
  split; intro h,
  { rw U_prop.2 V hV h, assumption, },
  { rw hW.2 V hV h, rw ←(hW.2 U U_prop.1.1 hy), apply U_prop.1.2, },
end

/-- `c2` is locally constant -/
lemma loc_const : is_locally_constant (c2 ε f) :=
begin
  rw is_locally_constant.iff_exists_open, rintros x,
  obtain ⟨U, hU⟩ := finset_clopen_prop ε f x,
  simp only [and_imp, exists_prop, exists_unique_iff_exists] at hU,
  refine ⟨U, mem_finset_clopen_is_open ε f hU.1.1, hU.1.2, λ x' hx', _⟩,
  delta c2,
  congr',
  swap 4, ext y, revert y, rw ←set.ext_iff, congr, -- is there a better way to do this?
  any_goals
  { ext y, simp only [exists_prop, and.congr_right_iff, exists_unique_iff_exists],
    intro hy, symmetry, apply mem_finset_clopen_unique ε f hU hx' hy, },
end

/-- Given an `f ∈ C(X, A)` and an `ε > 0`, one can find a locally constant function `b` which is in
  an ε-ball with center `f`, `b` is precisely `c2`. -/
theorem loc_const_dense' : ∃ (b : C(X, A))
  (H : b ∈ set.range (@locally_constant.to_continuous_map X A _ _)),
  dist f b < ε := ⟨@locally_constant.to_continuous_map X A _ _ ⟨c2 ε f, loc_const ε f⟩, ⟨⟨c2 ε f, loc_const ε f⟩, rfl⟩,
  gt_of_gt_of_ge (half_lt_self (fact.out _))
begin
-- showing that the distance between `f` and `c2` is less than or equal to `ε/2`
  rw [dist_eq_norm, continuous_map.norm_eq_supr_norm],
  -- empty type is special case
  cases is_empty_or_nonempty X with hempty hnonempty,
  { change _ ≥ dite _ _ _,
    split_ifs with h,
    { rcases h with ⟨⟨_, x, _⟩, _⟩,
      exact (@is_empty.false _ hempty x).elim },
    exact le_of_lt (half_pos (fact.out _)) },
-- writing the distance in terms of the sup norm
  refine cSup_le _ (λ m hm, _),
  { rw set.range_nonempty_iff_nonempty, assumption, }, -- this is where `nonempty X` is needed
  { cases hm with y hy,
    simp only [continuous_map.coe_sub, locally_constant.coe_mk,
      locally_constant.to_continuous_map_linear_map_apply, pi.sub_apply,
      locally_constant.coe_continuous_map] at hy,
    rw ←hy,
    -- reduced to proving ∥f(y) - c2(y)∥ ≤ ε/2
    obtain ⟨w, wT, hw⟩ := finset_clopen_prop ε f y,
    -- `w` is the unique element of `finset_clopen` to which `y` belongs
    simp only [exists_prop, exists_unique_iff_exists] at wT,
    simp only [and_imp, exists_prop, exists_unique_iff_exists] at hw,
    have : c2 ε f y = f (c' ε f w ⟨wT.1, ⟨⟨y, wT.2⟩⟩⟩),
    -- showing that `w` is the same as the `classical.some _` used in `c2`
    { delta c2, congr',
      any_goals
      { have := classical.some_spec (exists_of_exists_unique (finset_clopen_prop ε f y)),
        simp only [exists_prop, exists_unique_iff_exists] at *,
        apply hw _ (this.1) (this.2), }, },
    dsimp,
    rw this,
    obtain ⟨U, hU, wU⟩ := exists_sub_S ε f wT.1,
    -- `U` is a set of `A` which is an element of `S` and contains `f(w)`
    cases hU with z hz,
    -- `U` is the `ε/4`-ball centered at `z`
    have mem_U : f (c' ε f w ⟨wT.1, ⟨⟨y, wT.2⟩⟩⟩) ∈ U :=
      wU ⟨(c' ε f w ⟨wT.1, ⟨⟨y, wT.2⟩⟩⟩), subtype.coe_prop _, rfl⟩,
    have tS : f y ∈ U := wU ⟨y, wT.2, rfl⟩,
    rw [hz.symm, mem_ball_iff_norm] at *,
    conv_lhs { rw sub_eq_sub_add_sub _ _ z, },
    -- unfolding everything in terms of `z`, and then using `mem_U` and `tS`
    have : ε/2 = ε/4 + ε/4, { rw div_add_div_same, linarith, },
    rw this, apply norm_add_le_of_le (le_of_lt _) (le_of_lt tS),
    rw ←norm_neg _, simp only [mem_U, neg_sub], },
end ⟩

variable (X)
/-- The locally constant functions from `X` to `A` (viewed as a subset of C(X, A)) are dense
  in C(X, A). -/
theorem loc_const_dense : dense (set.range (@locally_constant.to_continuous_map X A _ _)) :=
  λ f, begin
  rw metric.mem_closure_iff,
  rintros ε hε,
  haveI : fact (0 < ε) := fact.mk hε,
-- we have all the ingredients from `loc_const_dense'`, only need `exists_finset_univ_sub_prop`
  apply loc_const_dense' ε f,
end

end locally_constant.density


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot

! This file was ported from Lean 3 source module algebra.module.pi
! leanprover-community/mathlib commit be24ec5de6701447e5df5ca75400ffee19d65659
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Module.Basic
import Mathbin.Algebra.Regular.Smul
import Mathbin.Algebra.Ring.Pi
import Mathbin.GroupTheory.GroupAction.Pi

/-!
# Pi instances for modules

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

This file defines instances for module and related structures on Pi Types
-/

universe u v w

variable {I : Type u}

-- The indexing type
variable {f : I → Type v}

-- The family of types already equipped with instances
variable (x y : ∀ i, f i) (i : I)

namespace Pi

/- warning: is_smul_regular.pi -> Pi.IsSMulRegular.pi is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} {α : Type.{u3}} [_inst_1 : forall (i : I), SMul.{u3, u2} α (f i)] {k : α}, (forall (i : I), IsSMulRegular.{u3, u2} α (f i) (_inst_1 i) k) -> (IsSMulRegular.{u3, max u1 u2} α (forall (i : I), f i) (Pi.instSMul.{u1, u2, u3} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i)) k)
but is expected to have type
  forall {I : Type.{u2}} {f : I -> Type.{u3}} {α : Type.{u1}} [_inst_1 : forall (i : I), SMul.{u1, u3} α (f i)] {k : α}, (forall (i : I), IsSMulRegular.{u1, u3} α (f i) (_inst_1 i) k) -> (IsSMulRegular.{u1, max u2 u3} α (forall (i : I), f i) (Pi.instSMul.{u2, u3, u1} I α (fun (i : I) => f i) (fun (i : I) => _inst_1 i)) k)
Case conversion may be inaccurate. Consider using '#align is_smul_regular.pi Pi.IsSMulRegular.piₓ'. -/
theorem Pi.IsSMulRegular.pi {α : Type _} [∀ i, SMul α <| f i] {k : α}
    (hk : ∀ i, IsSMulRegular (f i) k) : IsSMulRegular (∀ i, f i) k := fun _ _ h =>
  funext fun i => hk i (congr_fun h i : _)
#align is_smul_regular.pi Pi.IsSMulRegular.pi

#print Pi.smulWithZero /-
instance smulWithZero (α) [Zero α] [∀ i, Zero (f i)] [∀ i, SMulWithZero α (f i)] :
    SMulWithZero α (∀ i, f i) :=
  { Pi.instSMul with
    smul_zero := fun _ => funext fun _ => smul_zero _
    zero_smul := fun _ => funext fun _ => zero_smul _ _ }
#align pi.smul_with_zero Pi.smulWithZero
-/

#print Pi.smulWithZero' /-
instance smulWithZero' {g : I → Type _} [∀ i, Zero (g i)] [∀ i, Zero (f i)]
    [∀ i, SMulWithZero (g i) (f i)] : SMulWithZero (∀ i, g i) (∀ i, f i) :=
  { Pi.smul' with
    smul_zero := fun _ => funext fun _ => smul_zero _
    zero_smul := fun _ => funext fun _ => zero_smul _ _ }
#align pi.smul_with_zero' Pi.smulWithZero'
-/

#print Pi.mulActionWithZero /-
instance mulActionWithZero (α) [MonoidWithZero α] [∀ i, Zero (f i)]
    [∀ i, MulActionWithZero α (f i)] : MulActionWithZero α (∀ i, f i) :=
  { Pi.mulAction _, Pi.smulWithZero _ with }
#align pi.mul_action_with_zero Pi.mulActionWithZero
-/

#print Pi.mulActionWithZero' /-
instance mulActionWithZero' {g : I → Type _} [∀ i, MonoidWithZero (g i)] [∀ i, Zero (f i)]
    [∀ i, MulActionWithZero (g i) (f i)] : MulActionWithZero (∀ i, g i) (∀ i, f i) :=
  { Pi.mulAction', Pi.smulWithZero' with }
#align pi.mul_action_with_zero' Pi.mulActionWithZero'
-/

variable (I f)

#print Pi.module /-
instance module (α) {r : Semiring α} {m : ∀ i, AddCommMonoid <| f i} [∀ i, Module α <| f i] :
    @Module α (∀ i : I, f i) r (@Pi.addCommMonoid I f m) :=
  {
    Pi.distribMulAction
      _ with
    add_smul := fun c f g => funext fun i => add_smul _ _ _
    zero_smul := fun f => funext fun i => zero_smul α _ }
#align pi.module Pi.module
-/

#print Pi.Function.module /-
/- Extra instance to short-circuit type class resolution.
For unknown reasons, this is necessary for certain inference problems. E.g., for this to succeed:
```lean
example (β X : Type*) [normed_add_comm_group β] [normed_space ℝ β] : module ℝ (X → β) :=
infer_instance
```
See: https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/Typeclass.20resolution.20under.20binders/near/281296989
-/
/-- A special case of `pi.module` for non-dependent types. Lean struggles to elaborate
definitions elsewhere in the library without this. -/
instance Pi.Function.module (α β : Type _) [Semiring α] [AddCommMonoid β] [Module α β] :
    Module α (I → β) :=
  Pi.module _ _ _
#align function.module Pi.Function.module
-/

variable {I f}

#print Pi.module' /-
instance module' {g : I → Type _} {r : ∀ i, Semiring (f i)} {m : ∀ i, AddCommMonoid (g i)}
    [∀ i, Module (f i) (g i)] : Module (∀ i, f i) (∀ i, g i)
    where
  add_smul := by
    intros
    ext1
    apply add_smul
  zero_smul := by
    intros
    ext1
    apply zero_smul
#align pi.module' Pi.module'
-/

instance (α) {r : Semiring α} {m : ∀ i, AddCommMonoid <| f i} [∀ i, Module α <| f i]
    [∀ i, NoZeroSMulDivisors α <| f i] : NoZeroSMulDivisors α (∀ i : I, f i) :=
  ⟨fun c x h =>
    or_iff_not_imp_left.mpr fun hc =>
      funext fun i => (smul_eq_zero.mp (congr_fun h i)).resolve_left hc⟩

/- warning: function.no_zero_smul_divisors -> Function.noZeroSMulDivisors is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} {r : Semiring.{u2} α} {m : AddCommMonoid.{u3} β} [_inst_1 : Module.{u2, u3} α β r m] [_inst_2 : NoZeroSMulDivisors.{u2, u3} α β (MulZeroClass.toHasZero.{u2} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u2} α (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} α (Semiring.toNonAssocSemiring.{u2} α r)))) (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (SMulZeroClass.toHasSmul.{u2, u3} α β (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (SMulWithZero.toSmulZeroClass.{u2, u3} α β (MulZeroClass.toHasZero.{u2} α (MulZeroOneClass.toMulZeroClass.{u2} α (MonoidWithZero.toMulZeroOneClass.{u2} α (Semiring.toMonoidWithZero.{u2} α r)))) (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (MulActionWithZero.toSMulWithZero.{u2, u3} α β (Semiring.toMonoidWithZero.{u2} α r) (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (Module.toMulActionWithZero.{u2, u3} α β r m _inst_1))))], NoZeroSMulDivisors.{u2, max u1 u3} α (ι -> β) (MulZeroClass.toHasZero.{u2} α (NonUnitalNonAssocSemiring.toMulZeroClass.{u2} α (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} α (Semiring.toNonAssocSemiring.{u2} α r)))) (Pi.instZero.{u1, u3} ι (fun (ᾰ : ι) => β) (fun (i : ι) => AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)))) (Function.hasSMul.{u1, u2, u3} ι α β (SMulZeroClass.toHasSmul.{u2, u3} α β (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (SMulWithZero.toSmulZeroClass.{u2, u3} α β (MulZeroClass.toHasZero.{u2} α (MulZeroOneClass.toMulZeroClass.{u2} α (MonoidWithZero.toMulZeroOneClass.{u2} α (Semiring.toMonoidWithZero.{u2} α r)))) (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (MulActionWithZero.toSMulWithZero.{u2, u3} α β (Semiring.toMonoidWithZero.{u2} α r) (AddZeroClass.toHasZero.{u3} β (AddMonoid.toAddZeroClass.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (Module.toMulActionWithZero.{u2, u3} α β r m _inst_1)))))
but is expected to have type
  forall {ι : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} {r : Semiring.{u2} α} {m : AddCommMonoid.{u3} β} [_inst_1 : Module.{u2, u3} α β r m] [_inst_2 : NoZeroSMulDivisors.{u2, u3} α β (MonoidWithZero.toZero.{u2} α (Semiring.toMonoidWithZero.{u2} α r)) (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (SMulZeroClass.toSMul.{u2, u3} α β (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (SMulWithZero.toSMulZeroClass.{u2, u3} α β (MonoidWithZero.toZero.{u2} α (Semiring.toMonoidWithZero.{u2} α r)) (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (MulActionWithZero.toSMulWithZero.{u2, u3} α β (Semiring.toMonoidWithZero.{u2} α r) (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (Module.toMulActionWithZero.{u2, u3} α β r m _inst_1))))], NoZeroSMulDivisors.{u2, max u1 u3} α (ι -> β) (MonoidWithZero.toZero.{u2} α (Semiring.toMonoidWithZero.{u2} α r)) (Pi.instZero.{u1, u3} ι (fun (ᾰ : ι) => β) (fun (i : ι) => AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m))) (Pi.instSMul.{u1, u3, u2} ι α (fun (a._@.Mathlib.Algebra.Module.Pi._hyg.938 : ι) => β) (fun (i : ι) => SMulZeroClass.toSMul.{u2, u3} α β (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (SMulWithZero.toSMulZeroClass.{u2, u3} α β (MonoidWithZero.toZero.{u2} α (Semiring.toMonoidWithZero.{u2} α r)) (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (MulActionWithZero.toSMulWithZero.{u2, u3} α β (Semiring.toMonoidWithZero.{u2} α r) (AddMonoid.toZero.{u3} β (AddCommMonoid.toAddMonoid.{u3} β m)) (Module.toMulActionWithZero.{u2, u3} α β r m _inst_1)))))
Case conversion may be inaccurate. Consider using '#align function.no_zero_smul_divisors Function.noZeroSMulDivisorsₓ'. -/
/-- A special case of `pi.no_zero_smul_divisors` for non-dependent types. Lean struggles to
synthesize this instance by itself elsewhere in the library. -/
instance Function.noZeroSMulDivisors {ι α β : Type _} {r : Semiring α} {m : AddCommMonoid β}
    [Module α β] [NoZeroSMulDivisors α β] : NoZeroSMulDivisors α (ι → β) :=
  Pi.noZeroSMulDivisors _
#align function.no_zero_smul_divisors Function.noZeroSMulDivisors

end Pi


/-
Copyright (c) Ian Riley. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ian Riley
-/
import common big_step.basic

def partial_hoare (P : scope → Prop) (S : stmt) (Q : scope → Prop) : Prop :=
    ∀ (s t : scope), P s → (S, s) ⟹ t → Q t

notation `{* ` P : 1 ` *} ` S : 1 ` {* ` Q : 1 ` *}` := partial_hoare P S Q

/-
Instructions for how to use partial_hoare and its notation

A partial Hoare triple is used to represent the pre- and post-condition of
an instruction or composition of instructions. A partial Hoare can be
constructed with the following notation.

                                {* P *} S {* Q *}

P is the pre-condition and Q is the post condition of
statement S (from common.stmt). It states that when stmt S is executed with
pre-condition P, it will either (a) terminate with post-condition Q or
(b) not terminate. These Hoare triples are referred to as partial Hoare triples
precisely because a stmt S executed with pre-condition P may not terminate.

This partial Hoare triple is implemented using big_step semantics, so it is
used to construct proofs of properties of a program which
executes synchronously/deterministically.

Given any big_step (S, s) ⟹ t, there is a corresponding partial Hoare triple

                            {* P s *} S {* Q t *}

Note that P and Q are both defined with the type scope → Prop. Thus, the
pre-condition P is defined over the scope s in which stmt S is executed while
the post-condition Q is defined over the scope t which results from the
execution of stmt S in scope s.

This construction of a partial Hoare triple from big_step semantics allows us
to more easily reason over the properties of statement S. See documentation
in big_step.basic for more information on big_step semantics. See documentation
in common.basic for more information on specifying program properties.
-/
namespace partial_hoare

/-
Sequent:

        Skip     ___________

                {P} skip {P}
-/
lemma skip_intro {P : scope → Prop} : {* P *} stmt.skip {* P *} :=
begin
    intros s t hP hst,
    cases hst,
    exact hP,
end

/-
Sequent:

        Assign   __________________ ,

                {P[a/x]} x := a {P}

where P[a/x] means "the scope P where the proposition of a is substituted
into the predicate x." If there is no predicate x, then one is created.
-/
lemma assign_intro (P : scope → Prop) {x : string} {a : scope → Prop} :
    {* λ (s : scope), P (s{x ↦ a s}) *} stmt.assign x a {* P *} :=
begin
    intros s t hP hst,
    cases hst,
    exact hP,
end

/-
Sequent:

                {P} S {Q}   {Q} T {R}
        Comp    _____________________

                    {P} S ;; T {R}
-/
lemma comp_intro {P Q R : scope → Prop} {S T : stmt} (hS : {* P *} S {* Q *})
    (hT : {* Q *} T {* R *}) : {* P *} S ;; T {* R *} :=
begin
    intros s t hP hst,
    cases hst,
    apply hT hst_t,
    {
        apply hS s,
        {
            exact hP,
        },
        {
            exact hst_hS,
        }
    },
    {
        exact hst_hT,
    }
end

/-
Sequent:

                        {P ∧ b} S {Q}   {P ∧ ¬ b} T {Q}
        If-Then-Else    _______________________________

                            {P} if b then S else T {Q}
-/
lemma ite_intro {b P Q : scope → Prop} {S T : stmt}
    (hS : {* λ (s : scope), P s ∧ b s *} S {* Q *})
    (hT : {* λ (s : scope), P s ∧ ¬ b s *} T {* Q *}) :
        {* P *} stmt.ite b S T {* Q *} :=
begin
    intros s t hP hst,
    cases hst,
    {
        apply hS,
        {
            exact and.intro hP hst_hcond,
        },
        {
            exact hst_hbody,
        }
    },
    {
        apply hT,
        {
            exact and.intro hP hst_hcond,
        },
        {
            exact hst_hbody,
        }
    }
end

/-
Sequent:

                       {I ∧ b} S {I}
        While   __________________________

                {I} while b do S {I ∧ ¬ b}
-/
lemma while_intro (I : scope → Prop) {b : scope → Prop} {S : stmt}
    (hS : {* λ (s : scope), I s ∧ b s *} S {* I *}) :
        {* I *} stmt.while b S {* λ (s : scope), I s ∧ ¬ b s *} :=
begin
    intros s t hP,
    generalize hws : (stmt.while b S, s) = ws,
    intro hst,
    induction hst generalizing s; cases hws,
    {
        apply hst_ih_hrest hst_t,
        {
            apply hS hst_s,
            {
                exact and.intro hP hst_hcond,
            },
            {
                exact hst_hbody,
            }
        },
        {
            refl,
        }
    },
    {
        exact and.intro hP hst_hcond,
    }
end

/-
Sequent:

            P → (v₀ s) ∧ (v₁ s)     P → P[(σ s)]    {P[(σ s)]} F {Q}
    Call    ________________________________________________________ ,

                            {P} call f v₀ v₁ σ F {Q}

where P[(σ s)] means "the scope P injected with the predicates of (σ s)." The
predicates of (σ s) include input (read-only) parameters, in-out (read-write)
paramters, local variables. These predicates (except for those predicates
relating to v₁) must use a distinct naming convention, so that predicates
of s are not overwritten. Return statements that return a local variable
must be reformulated as an in-out parameter.    -- σ \s
-/
lemma call_intro {v₀ v₁ P Q : scope → Prop} {f : string} {F : stmt}
    {σ : scope → scope} (hargs : ∀ (s : scope), P s → (v₀ s ∧ v₁ s))
    (hP : ∀ (s : scope), P s → P (σ s))
    (hF : {* λ (s : scope), P (σ s) *} F {* Q *}) :
        {* P *} stmt.call f v₀ v₁ σ F {* Q *} :=
begin
    intros s t hP' hF',
    cases hF',
    apply hF (σ s),
    {
        apply hP (σ s),
        apply hP s,
        exact hP',
    },
    {
        exact hF'_hF,
    }
end

/-
Sequent:

                        P' → P  {P} S {Q}   Q → Q'
        Consequence     __________________________

                               {P'} S {Q'}
-/
lemma consequence {P P' Q Q' : scope → Prop} {S : stmt}
    (hP : ∀ (s : scope), P' s → P s) (hS : {* P *} S {* Q *})
    (hQ : ∀ (s : scope), Q s → Q' s) : {* P' *} S {* Q' *} :=
begin
    intros s t hP' hst,
    apply hQ t,
    apply hS,
    {
        apply hP s,
        exact hP',
    },
    {
        exact hst,
    }
end

/-
Sequent:

                            P' → P  {P} S {Q}
        Consequence-Left    _________________

                              {P'} S {Q}
-/
lemma consequence_left (P' : scope → Prop) {P Q : scope → Prop} {S : stmt}
    (hP : ∀ (s : scope), P' s → P s) (hS : {* P *} S {* Q *}) :
        {* P' *} S {* Q *} :=
consequence hP hS (by cc)

/-
Sequent:

                            {P} S {Q}   Q → Q'
        Consequence-Right   __________________

                                {P} S {Q'}
-/
lemma consequence_right (Q : scope → Prop) {P Q' : scope → Prop} {S : stmt}
    (hS : {* P *} S {* Q *}) (hQ : ∀ (s : scope), Q s → Q' s) :
        {* P *} S {* Q' *} :=
consequence (by cc) hS hQ

/-
Sequent:

                    P → Q
        Skip'   ____________

                {P} skip {Q}
-/
lemma skip_intro' {P Q : scope → Prop} (hP : ∀ (s : scope), P s → Q s) :
    {* P *} stmt.skip {* Q *} :=
consequence hP skip_intro (by cc)

/-
Sequent:

                  P → Q[a/x]
        Assign' _____________ ,

                {P} x := a {Q}

where Q[a/x] means "the scope Q where the proposition of a is substituted
into the predicate x." If there is no predicate x, then one is created.
-/
lemma assign_intro' {P Q : scope → Prop} {x : string} {a : scope → Prop}
    (hP : ∀ (s : scope), P s → Q (s{x ↦ a s})) :
        {* P *} stmt.assign x a {* Q *} :=
consequence hP (assign_intro Q) (by cc)

/-
Sequent:

                P' → P  {P} S {Q}   {Q} T {R}   R → R'
        Comp'   ______________________________________

                          {P'} S ;; T {R'}
-/
lemma comp_intro' {P P' Q R R' : scope → Prop} {S T : stmt}
    (hP : ∀ (s : scope), P' s → P s) (hS : {* P *} S {* Q *})
    (hT : {* Q *} T {* R *}) (hR : ∀ (s : scope), R s → R' s) :
        {* P' *} S ;; T {* R' *} :=
begin
    apply consequence_left,
    {
        exact hP,
    },
    {
        intros s t hP₂ hst,
        cases hst,
        apply hR,
        apply hT,
        {
            apply hS,
            {
                exact hP₂,
            },
            {
                exact hst_hS,
            }
        },
        {
            exact hst_hT,
        }
    }
end

/-
Sequent:

                    P' → P  {P} S {Q}   {Q} T {R}
        Comp-Left   _____________________________

                          {P'} S ;; T {R}
-/
lemma comp_intro_left (P' : scope → Prop) {P Q R : scope → Prop} {S T : stmt}
    (hP : ∀ (s : scope), P' s → P s) (hS : {* P *} S {* Q *})
    (hT : {* Q *} T {* R *}) : {* P' *} S ;; T {* R *} :=
consequence_left P' hP (comp_intro hS hT)

/-
Sequent:

                    {P} S {Q}   {Q} T {R}   R → R'
        Comp-Right  ______________________________

                           {P} S ;; T {R'}
-/
lemma comp_intro_right (R : scope → Prop) {P Q R' : scope → Prop} {S T : stmt}
    (hS : {* P *} S {* Q *}) (hT : {* Q *} T {* R *})
    (hR : ∀ (s : scope), R s → R' s) : {* P *} S ;; T {* R' *} :=
consequence_right R (comp_intro hS hT) hR

/-
Sequent:

                                P → b      {P} S {Q}
        If-Then-Else-True   __________________________

                            {P} if b then S else T {Q}
-/
lemma ite_true_intro {b P Q : scope → Prop} {S T : stmt}
    (hP : ∀ (s : scope), P s → b s)
    (hS : {* P *} S {* Q *}) :
        {* P *} stmt.ite b S T {* Q *} :=
begin
    intros s t hP' hst,
    apply hS,
    {
        exact hP',
    },
    {
        cases hst,
        {
            exact hst_hbody,
        },
        {
            exfalso,
            apply hst_hcond,
            apply hP,
            exact hP',
        }
    }
end

/-
Sequent:

                                P → ¬ b     {P} T {Q}
        If-Then-Else-False  __________________________

                            {P} if b then S else T {Q}
-/
lemma ite_false_intro {b P Q : scope → Prop} {S T : stmt}
    (hP : ∀ (s : scope), P s → ¬ b s)
    (hT : {* P *} T {* Q *}) :
        {* P *} stmt.ite b S T {* Q *} :=
begin
    intros s t hP' hst,
    apply hT,
    {
        exact hP',
    },
    {
        cases hst,
        {
            exfalso,
            apply hP s hP',
            exact hst_hcond,
        },
        {
            exact hst_hbody,
        }
    }
end

/-
Sequent:

                            P → I   {I ∧ b} S {I}   I ∧ ¬ b → Q
        While-Invariant     ___________________________________

                                  {P} while b do S {Q}
-/
lemma while_invariant {b P Q : scope → Prop} {S : stmt} (I : scope → Prop)
    (hP : ∀ (s : scope), P s → I s)
    (hS : {* λ (s : scope), I s ∧ b s *} S {* I *})
    (hQ : ∀ (s : scope), ¬ b s → I s → Q s) :
        {* P *} stmt.while b S {* Q *} :=
begin
    apply consequence,
    {
        exact hP,
    },
    {
        apply while_intro I hS,
    },
    {
        intros s h,
        apply hQ,
        {
            exact h.right,
        },
        {
            exact h.left,
        }
    }
end

/-
Sequent:

                        {P ∧ b} S ;; while b do S {Q}   P ∧ ¬ b → Q
        While-Right     ___________________________________________

                                   {P} while b do S {Q}
-/
lemma while_right {b P Q : scope → Prop} {S : stmt}
    (hS : {* λ (s : scope), P s ∧ b s *} S ;; stmt.while b S {* Q *})
    (hQ : ∀ (s : scope), ¬ b s → P s → Q s) :
        {* P *} stmt.while b S {* Q *} :=
begin
    intros s t hP hst,
    cases hst,
    {
        apply hS,
        {
            exact and.intro hP hst_hcond,
        },
        {
            apply big_step.comp hst_hbody hst_hrest,
        }
    },
    {
        apply hQ s hst_hcond hP,
    }
end

/-
Sequent:

                                P → b   {P} S ;; while b do S {Q}
        While-Unwind-Right      _________________________________

                                    {P} while b do S {Q}
-/
lemma while_unwind_right {b P Q : scope → Prop} {S : stmt}
    (hP : ∀ (s : scope), P s → b s)
    (hS : {* P *} S ;; stmt.while b S {* Q *}) :
        {* P *} stmt.while b S {* Q *} :=
begin
    intros s t hP' hst,
    cases hst,
    {
        apply hS,
        {
            exact hP',
        },
        {
            apply big_step.comp hst_hbody hst_hrest,
        }
    },
    {
        exfalso,
        apply hst_hcond,
        apply hP s hP',
    }
end

/-
Sequent:

                                P → ¬ b
        While-False     ____________________

                        {P} while b do S {P}
-/
lemma while_false_intro {b P : scope → Prop} {S : stmt}
    (hP : ∀ (s : scope), P s → ¬ b s) : {* P *} stmt.while b S {* P *} :=
begin
    intros s t hP' hst,
    cases hst,
    {
        exfalso,
        apply hP s hP',
        exact hst_hcond,
    },
    {
        exact hP',
    }
end

/-
Sequent:

                                Q
        Assign-Left     ___________________ ,

                        {Q[a/x]} x := a {Q}

where Q[a/x] means "the scope Q where the proposition of a is substituted
into the predicate x." If there is no predicate x, then one is created.
-/
lemma assign_intro_left (Q : scope → Prop) {x : string} {a : scope → Prop}  :
    {* λ (s : scope), ∃ (t₀ : Prop), Q (s{x ↦ t₀}) ∧ t₀ = a s *}
    stmt.assign x a
    {* Q *} :=
begin
    apply assign_intro',
    intros s hP,
    cases hP,
    rw ← hP_h.right,
    exact hP_h.left
end

/-
Sequent:

                                P
        Assign-Right    ___________________ ,

                        {P} x := a {P[a/x]}

where P[a/x] means "the scope P where the proposition of a is substituted
into the predicate x." If there is no predicate x, then one is created.
-/
lemma assign_intro_right (P : scope → Prop) {x : string} {a : scope → Prop}  :
    {* P *}
    stmt.assign x a
    {* λ (s : scope), ∃ (t₀ : Prop), P (s{x ↦ t₀}) ∧ s x = a (s{x ↦ t₀}) *} :=
begin
    apply assign_intro',
    intros s hP,
    apply exists.intro (s x),
    apply and.intro,
    {
        rw (scope.update_squash x (s x) (a s) s),
        rw (scope.update_id x s),
        exact hP
    },
    {
        rw (scope.update_apply x (a s) s),
        rw (scope.update_squash x (s x) (a s) s),
        rw (scope.update_id x s),
    }
end

end partial_hoare


import may_assume.lemmas

namespace flt_regular

/-- Statement of case II. -/
def caseII.statement : Prop := ∀ ⦃a b c : ℤ⦄ ⦃p : ℕ⦄ [hp : fact p.prime]
  (hreg : @is_regular_prime p hp)
  (hodd : p ≠ 2) (hprod : a * b * c ≠ 0) (caseII : ↑p ∣ a * b * c), a ^ p + b ^ p ≠ c ^ p

/-- CaseII. -/
theorem caseII {a b c : ℤ} {p : ℕ} [fact p.prime] (hreg : is_regular_prime p)
  (hodd : p ≠ 2) (hprod : a * b * c ≠ 0) (caseII : ↑p ∣ a * b * c) : a ^ p + b ^ p ≠ c ^ p := sorry

end flt_regular


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Chris Hughes, Morenikeji Neri
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.noetherian
import Mathlib.ring_theory.unique_factorization_domain
import Mathlib.PostPort

universes u v l u_1 u_2

namespace Mathlib

/-!
# Principal ideal rings and principal ideal domains

A principal ideal ring (PIR) is a commutative ring in which all ideals are principal. A
principal ideal domain (PID) is an integral domain which is a principal ideal ring.

# Main definitions

Note that for principal ideal domains, one should use
`[integral domain R] [is_principal_ideal_ring R]`. There is no explicit definition of a PID.
Theorems about PID's are in the `principal_ideal_ring` namespace.

- `is_principal_ideal_ring`: a predicate on commutative rings, saying that every
  ideal is principal.
- `generator`: a generator of a principal ideal (or more generally submodule)
- `to_unique_factorization_monoid`: a PID is a unique factorization domain

# Main results

- `to_maximal_ideal`: a non-zero prime ideal in a PID is maximal.
- `euclidean_domain.to_principal_ideal_domain` : a Euclidean domain is a PID.

-/

/-- An `R`-submodule of `M` is principal if it is generated by one element. -/
class submodule.is_principal {R : Type u} {M : Type v} [ring R] [add_comm_group M] [module R M] (S : submodule R M)
where
  principal : ∃ (a : M), S = submodule.span R (singleton a)

/-- A commutative ring is a principal ideal ring if all ideals are principal. -/
class is_principal_ideal_ring (R : Type u) [comm_ring R]
where
  principal : ∀ (S : ideal R), submodule.is_principal S

namespace submodule.is_principal

/-- `generator I`, if `I` is a principal submodule, is an `x ∈ M` such that `span R {x} = I` -/
def generator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M] (S : submodule R M) [is_principal S] : M :=
  classical.some sorry

theorem span_singleton_generator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M] (S : submodule R M) [is_principal S] : span R (singleton (generator S)) = S :=
  Eq.symm (classical.some_spec (principal S))

@[simp] theorem generator_mem {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M] (S : submodule R M) [is_principal S] : generator S ∈ S := sorry

theorem mem_iff_eq_smul_generator {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M] (S : submodule R M) [is_principal S] {x : M} : x ∈ S ↔ ∃ (s : R), x = s • generator S := sorry

theorem mem_iff_generator_dvd {R : Type u} [comm_ring R] (S : ideal R) [is_principal S] {x : R} : x ∈ S ↔ generator S ∣ x := sorry

theorem eq_bot_iff_generator_eq_zero {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M] [module R M] (S : submodule R M) [is_principal S] : S = ⊥ ↔ generator S = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (S = ⊥ ↔ generator S = 0)) (Eq.symm (propext span_singleton_eq_bot))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (S = ⊥ ↔ span R (singleton (generator S)) = ⊥)) (span_singleton_generator S)))
      (iff.refl (S = ⊥)))

end submodule.is_principal

namespace is_prime

-- TODO -- for a non-ID one could perhaps prove that if p < q are prime then q maximal;

-- 0 isn't prime in a non-ID PIR but the Krull dimension is still <= 1.

-- The below result follows from this, but we could also use the below result to

-- prove this (quotient out by p).

theorem to_maximal_ideal {R : Type u} [integral_domain R] [is_principal_ideal_ring R] {S : ideal R} [hpi : ideal.is_prime S] (hS : S ≠ ⊥) : ideal.is_maximal S := sorry

end is_prime

theorem mod_mem_iff {R : Type u} [euclidean_domain R] {S : ideal R} {x : R} {y : R} (hy : y ∈ S) : x % y ∈ S ↔ x ∈ S := sorry

protected instance euclidean_domain.to_principal_ideal_domain {R : Type u} [euclidean_domain R] : is_principal_ideal_ring R := sorry

namespace principal_ideal_ring

protected instance is_noetherian_ring {R : Type u} [integral_domain R] [is_principal_ideal_ring R] : is_noetherian_ring R :=
  is_noetherian.mk
    fun (s : ideal R) =>
      Exists.dcases_on (submodule.is_principal.principal s)
        fun (a : R) (h : s = submodule.span R (singleton a)) =>
          Eq._oldrec
            (eq.mpr
              (id
                (Eq._oldrec (Eq.refl (submodule.fg (submodule.span R (singleton a)))) (Eq.symm (finset.coe_singleton a))))
              (Exists.intro (singleton a) (submodule.coe_injective rfl)))
            (Eq.symm h)

theorem is_maximal_of_irreducible {R : Type u} [integral_domain R] [is_principal_ideal_ring R] {p : R} (hp : irreducible p) : ideal.is_maximal (submodule.span R (singleton p)) := sorry

theorem irreducible_iff_prime {R : Type u} [integral_domain R] [is_principal_ideal_ring R] {p : R} : irreducible p ↔ prime p := sorry

theorem associates_irreducible_iff_prime {R : Type u} [integral_domain R] [is_principal_ideal_ring R] {p : associates R} : irreducible p ↔ prime p :=
  iff.mp associates.irreducible_iff_prime_iff fun (_x : R) => irreducible_iff_prime

/-- `factors a` is a multiset of irreducible elements whose product is `a`, up to units -/
def factors {R : Type u} [integral_domain R] [is_principal_ideal_ring R] (a : R) : multiset R :=
  dite (a = 0) (fun (h : a = 0) => ∅) fun (h : ¬a = 0) => classical.some sorry

theorem factors_spec {R : Type u} [integral_domain R] [is_principal_ideal_ring R] (a : R) (h : a ≠ 0) : (∀ (b : R), b ∈ factors a → irreducible b) ∧ associated (multiset.prod (factors a)) a := sorry

theorem ne_zero_of_mem_factors {R : Type v} [integral_domain R] [is_principal_ideal_ring R] {a : R} {b : R} (ha : a ≠ 0) (hb : b ∈ factors a) : b ≠ 0 :=
  irreducible.ne_zero (and.left (factors_spec a ha) b hb)

theorem mem_submonoid_of_factors_subset_of_units_subset {R : Type u} [integral_domain R] [is_principal_ideal_ring R] (s : submonoid R) {a : R} (ha : a ≠ 0) (hfac : ∀ (b : R), b ∈ factors a → b ∈ s) (hunit : ∀ (c : units R), ↑c ∈ s) : a ∈ s := sorry

/-- If a `ring_hom` maps all units and all factors of an element `a` into a submonoid `s`, then it
also maps `a` into that submonoid. -/
theorem ring_hom_mem_submonoid_of_factors_subset_of_units_subset {R : Type u_1} {S : Type u_2} [integral_domain R] [is_principal_ideal_ring R] [semiring S] (f : R →+* S) (s : submonoid S) (a : R) (ha : a ≠ 0) (h : ∀ (b : R), b ∈ factors a → coe_fn f b ∈ s) (hf : ∀ (c : units R), coe_fn f ↑c ∈ s) : coe_fn f a ∈ s :=
  mem_submonoid_of_factors_subset_of_units_subset (submonoid.comap (ring_hom.to_monoid_hom f) s) ha h hf

/-- A principal ideal domain has unique factorization -/
protected instance to_unique_factorization_monoid {R : Type u} [integral_domain R] [is_principal_ideal_ring R] : unique_factorization_monoid R :=
  unique_factorization_monoid.mk fun (_x : R) => irreducible_iff_prime