import tactic.pi_instances
import mod_forms.modular_group.mod_group
import linear_algebra.matrix.general_linear_group
import for_mathlib.mod_forms2
import data.matrix.notation
import data.setoid.partition
import topology.instances.ennreal
import topology.instances.nnreal
import mod_forms.Riemann_zeta_fin
import mod_forms.holomorphic_functions
import order.filter.archimedean
import mod_forms.Weierstrass_M_test
import analysis.complex.upper_half_plane.basic
import analysis.complex.upper_half_plane.topology
import topology.compact_open
import analysis.calculus.deriv
import number_theory.modular
import mod_forms.modular_group.mat_m

universes u v w

open complex
open modular_group
open integral_matrices_with_determinant
open_locale big_operators nnreal classical filter matrix upper_half_plane

local attribute [-instance] matrix.special_linear_group.has_coe_to_fun
local notation `SL2Z`:=matrix.special_linear_group (fin 2) ℤ
local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _
noncomputable theory

namespace Eisenstein_series

lemma ridic (a b c d : ℤ): a*d-b*c=1 → a*d-c*b=1:=
begin
intro h, linarith,
end

lemma ridic2 (a b c d z : ℤ) (h: a*d-b*c=1):  z*d*a-z*c*b=z:=
begin
ring_nf, rw h, rw one_mul,
end

/- This is the permutation of the summation index coming from the moebius action-/
def Ind_perm (A : SL2Z ): ℤ × ℤ → ℤ × ℤ:=
λ z, (z.1 * (A.1 0 0) + z.2 * (A.1 1 0), z.1 * (A.1 0 1) + z.2 * (A.1 1 1))

lemma det_sl_one  (M : SL2Z) : (M.1 0 0 * M.1 1 1 + -(M.1 0 1 * M.1 1 0)) = 1 :=
begin
apply det_m,
end

def Ind_equiv (A : SL2Z): ℤ × ℤ ≃ ℤ × ℤ  :=
{ to_fun:=Ind_perm A,
  inv_fun:=Ind_perm A⁻¹,
  left_inv:= λ z,
  by {simp_rw Ind_perm,
    ring_nf,
    have hdet := det_sl_one A,
    simp only [subtype.val_eq_coe,SL2Z_inv_a, SL2Z_inv_c, neg_mul, SL2Z_inv_b, SL2Z_inv_d] at *,
    nth_rewrite 1 mul_comm,
    nth_rewrite 2 mul_comm,
    ext,
    simp only,
    simp_rw hdet,
    ring,
    simp only,
    nth_rewrite 2 add_comm,
    simp_rw [hdet],
    ring,},
  right_inv :=  λ z, by
  { simp_rw Ind_perm,
    ring_nf,
    have hdet := det_sl_one A,
    simp only [subtype.val_eq_coe,SL2Z_inv_a, SL2Z_inv_c, neg_mul, SL2Z_inv_b, SL2Z_inv_d] at *,
    ext,
    simp only [mul_neg],
    nth_rewrite 2 mul_comm,
    simp_rw hdet,
    ring,
    simp only [mul_neg],
    nth_rewrite 2 add_comm,
    nth_rewrite 4 mul_comm,
    simp_rw [hdet],
    ring,}}

@[simp]lemma ind_simp (A: SL2Z) (z : ℤ × ℤ):
  Ind_equiv A z = (z.1* (A.1 0 0) +z.2* (A.1 1 0), z.1*(A.1 0 1)+z.2* (A.1 1 1)) :=
begin
refl,
end

lemma max_aux' (a b : ℕ): max a b = a ∨ max a b =b:=
begin
apply max_choice,
end

lemma max_aux (a b : ℕ):a= max a b  ∨  b=max a b :=
begin
have:= (max_aux' a b),  cases this, simp [this], simp [this],
end

lemma max_aux'' (a b n : ℕ) (h: max a b =n): a=n ∨ b =n :=
begin
rw ← h,
apply max_aux,
end

lemma max_aux3 (a b n : ℕ) (h: max a b =n): a ≤ n ∧ b ≤ n :=
begin
rw ← h, split, exact le_max_left a b, exact le_max_right a b,
end

/--For `m : ℤ` this is the finset of `ℤ × ℤ` of elements such that the maximum of the
absolute values of the pair is `m` -/
def Square (m: ℕ): finset (ℤ × ℤ):=
((finset.Ico (-m : ℤ) (m+1)).product (finset.Ico (-m : ℤ) (m+1))).filter
(λ x, max (x.1).nat_abs (x.2).nat_abs = m)

/--For `m : ℤ` this is the finset of `ℤ × ℤ` of elements such that..-/
def Square2 (m: ℕ) : finset (ℤ × ℤ):=
  (finset.Ico (-m : ℤ) (m+1)).product {m } ∪ (finset.Ico (-m : ℤ) (m+1)).product {-(m: ℤ)} ∪
  ({m} : finset (ℤ)).product (finset.Ico (-m+1) (m)) ∪
  ({-m} : finset (ℤ)).product (finset.Ico (-m+1) (m))

lemma square2_card (n : ℕ) (h: 1 ≤ n) : (finset.card (Square2 n) : ℤ) = 8 * n  :=
begin
    rw [Square2,finset.card_union_eq, finset.card_union_eq, finset.card_union_eq,finset.card_product,
    finset.card_product, finset.card_product, finset.card_product],
    { simp only [finset.card_singleton, mul_one, one_mul],
      have hn : -(n : ℤ) ≤ n+1, by {linarith,},
      have hn2 : -(n : ℤ) +1 ≤ n, by {linarith,},
      have r1 := int.card_Ico_of_le (-(n : ℤ)) (n+1) hn,
      have r2 := int.card_Ico_of_le (-(n : ℤ)+1) (n) hn2,
      simp only [int.coe_nat_add, int.card_Ico, sub_neg_eq_add, neg_add_le_iff_le_add] at *,
      rw [r1,r2],
      ring_nf },
    { rw finset.disjoint_iff_ne,
      intros a ha b hb,
      simp only [ne.def, finset.mem_singleton, finset.mem_product, finset.mem_Ico] at *,
      by_contra H,
      have haa := ha.2,
      have hbb := hb.2,
      rw H at haa,
      rw hbb at haa,
      have hv:=eq_zero_of_neg_eq haa,
      simp only [int.coe_nat_eq_zero] at hv,
      rw hv at h,
      simp only [nat.one_ne_zero,
      le_zero_iff] at h,
      exact h },
    { rw finset.disjoint_iff_ne,
      intros a ha b hb,
      simp only [ne.def, finset.mem_union, finset.mem_singleton, neg_add_le_iff_le_add,
      finset.mem_product, finset.mem_Ico] at *,
      cases ha,
      have hbb:=hb.2,
      have haa:=ha.2,
      by_contra H,
      rw ← H at hbb,
      rw haa at hbb,
      simp only [lt_self_iff_false, and_false] at hbb,
      exact hbb,
      have hbb:=hb.2,
      have haa:=ha.2,
      by_contra H,
      rw ← H at hbb,
      rw haa at hbb,
      simp at hbb,
      have hk:=hbb.1,
      linarith },
    { rw finset.disjoint_iff_ne,
    intros a ha b hb,
    simp only [ne.def, finset.mem_union, finset.union_assoc, finset.mem_singleton, neg_add_le_iff_le_add,
    finset.mem_product, finset.mem_Ico] at *,
    by_contra H,
    cases ha,
      { have hbb := hb.2,
       have haa:=ha.2,
       rw ← H at hbb,
       rw ←haa at hbb,
       simp [lt_self_iff_false, and_false] at hbb,
       exact hbb },
    cases ha,
    { have hbb:=hb.2,
      have haa:=ha.2,
      rw ← H at hbb,
      rw haa at hbb,
      simp only [int.coe_nat_pos, neg_lt_self_iff, add_right_neg] at hbb,
      linarith },
    { have hbb:=hb.1,
      have haa:=ha.1,
     rw H at haa,
     rw hbb at haa,
      have hv:=eq_zero_of_neg_eq haa,
      simp only [int.coe_nat_eq_zero] at hv,
      rw hv at h,
      simp only [nat.one_ne_zero, le_zero_iff] at h,
      exact h } }
end

lemma nat_abs_inter (a: ℤ) (n: ℕ) (h: a.nat_abs < n): a < (n: ℤ) ∧  0 <(n: ℤ)+ a:=
begin
  have:= int.nat_abs_eq  a,
  cases this,
  rw this,
  split,
  norm_cast,
  exact h,
  norm_cast,
  simp only [add_pos_iff],
  left,
  have h1 : 0 ≤ a.nat_abs, by {exact zero_le (int.nat_abs a),},
  linarith,
  rw this,
  split,
  rw neg_lt_iff_pos_add,
  norm_cast,
  simp,
  have h1 : 0 ≤ a.nat_abs, by {exact zero_le (int.nat_abs a),},
  left,
  linarith,
  rw ←int.coe_nat_lt at h,
  rw ← sub_pos at h,
  convert h,
end

lemma nat_abs_inter2 (a: ℤ) (n: ℕ) (h: a.nat_abs ≤ n): a ≤ (n: ℤ) ∧  0 ≤ (n: ℤ)+ a:=
begin
have := lt_or_eq_of_le h, cases this,
have H:= nat_abs_inter a n this, have H1:= le_of_lt H.1, have H2:=le_of_lt H.2, simp [H1,H2], rw ← this,
split, exact int.le_nat_abs, rw add_comm, rw ← neg_le_iff_add_nonneg', rw ← int.abs_eq_nat_abs,
simp_rw neg_le_abs_self ,
end

@[simp]lemma square_mem (n : ℕ) (x : ℤ × ℤ ) : x ∈ (Square n) ↔ max (x.1).nat_abs (x.2).nat_abs=n:=
begin
split,
intro x,
rw Square at x,
simp at x,
simp_rw x,
intro hx,
rw Square,
simp,
simp [hx],
have h2:=max_aux3 _ _ _ hx,
have h21:= nat_abs_inter2 _ _ h2.1,
have h22:= nat_abs_inter2 _ _ h2.2,
split,
split,
rw  neg_le_iff_add_nonneg',
exact h21.2,
have:= h21.1,
linarith,
split,
rw  neg_le_iff_add_nonneg',
exact h22.2,
have:= h22.1,linarith,
end

lemma square_mem' (n : ℕ) (x : ℤ × ℤ ) : x ∈ (Square n) ↔
((x.1).nat_abs=n ∧ (x.2).nat_abs <  n) ∨ ((x.2).nat_abs=n ∧ (x.1).nat_abs < n) ∨ ((x.1).nat_abs=n ∧
 (x.2).nat_abs=n) :=
begin
simp,
split,
intro c1,
have:= max_aux3 _ _ _ c1,
have H:= max_aux'' _ _ _ c1,
have h1:= this.1,
have h2:=this.2,
rw le_iff_lt_or_eq at h2,
rw le_iff_lt_or_eq at h1,
cases H,
simp_rw H,
simp,
exact h2,
simp_rw H,
simp,
exact h1,
intro c2,
cases c2,
rw c2.1,
simp,
have :=c2.2,
linarith,
cases c2,
rw c2.1,
simp,
have:=c2.2,
linarith,
rw [c2.1,c2.2],
simp,
end

lemma auxin (a: ℤ) (n: ℕ)(h: 0 < (n: ℤ)+a):  1 ≤  (n: ℤ)+a:=
begin
assumption,
end

lemma auxin2 (a: ℤ) (n: ℕ)(h: 0 < (n: ℤ)+a):   -(n: ℤ) ≤ a:=
begin
linarith,
end

lemma cat (a b : ℤ) (n: ℕ)  (h1: b=(n:ℤ)) (h2: -(n:ℤ) ≤ a ∧ a < (n:ℤ)+1 ):
 b.nat_abs= n ∧ (a.nat_abs < n ∨ a.nat_abs=n) :=
begin
  rw h1,
  simp,
  have:=int.nat_abs_eq a,
  cases this,
  rw this at h2,
  norm_cast at h2,
  have h22:=h2.2,
  exact nat.lt_succ_iff_lt_or_eq.mp h22,
  rw this at h2,
  have h22:=h2.1,
  have H:= lt_or_eq_of_le h22,
  simp only [neg_lt_neg_iff, neg_inj] at H,
  norm_cast at H,
  have h234: n = a.nat_abs ↔ a.nat_abs =n, by {exact comm, },
  rw ←h234,
  exact H,
end

lemma cat1 (a b : ℤ) (n: ℕ)  (h1: b=-(n:ℤ)) (h2: -(n:ℤ) ≤ a ∧ a < (n:ℤ)+1 ):
b.nat_abs= n ∧ (a.nat_abs < n ∨ a.nat_abs=n) :=
begin
 rw h1,
 simp,
 have:=int.nat_abs_eq a,
 cases this,
 rw this at h2,
 norm_cast at h2,
 have h22:=h2.2,
 exact nat.lt_succ_iff_lt_or_eq.mp h22,
 rw this at h2,
 have h22:=h2.1,
 have H:= lt_or_eq_of_le h22,
  simp only [neg_lt_neg_iff, neg_inj] at H,
  norm_cast at H,
  have h234: n = a.nat_abs ↔ a.nat_abs =n, by {exact comm, },
  rw ←h234,
  exact H,
end

lemma dog (a b : ℤ) (n: ℕ)  (h1: a=(n:ℤ)) (h2: 1 ≤ (n: ℤ)+ b ∧ b < (n:ℤ) ):
  a.nat_abs= n ∧ b.nat_abs < n :=
begin
 rw h1, simp,  have:=int.nat_abs_eq b, cases this, rw this at h2, norm_cast at h2,exact h2.2,
 rw this at h2, have h22:= h2.1, norm_cast at *, linarith,
end

lemma dog1 (a b : ℤ) (n: ℕ)  (h1: a=-(n:ℤ)) (h2: 1 ≤ (n: ℤ)+ b ∧ b < (n:ℤ) ): a.nat_abs= n ∧ b.nat_abs < n :=
begin
 rw h1, simp,  have:=int.nat_abs_eq b, cases this, rw this at h2, norm_cast at h2,exact h2.2,
 rw this at h2, have h22:= h2.1,  norm_cast at *, linarith,
end

lemma sqr_eq_sqr2 (n: ℕ): (Square n)=(Square2 n):=
begin
  ext1,
  split,
  rw square_mem',
  intro ha,
  rw Square2,
  simp_rw int.nat_abs_eq_iff at ha,
  simp only [finset.mem_union, finset.union_assoc, finset.mem_product,  finset.mem_Ico,
  neg_add_le_iff_le_add, finset.mem_singleton],
  cases ha,
  cases ha.1,
  have h1:= nat_abs_inter _ _ ha.2,
  have h2:= auxin _ _ h1.2,
  simp_rw [h,h1,h2],
  simp,
  have h1:= nat_abs_inter _ _ ha.2,
  have h2:= auxin _ _ h1.2,
  simp_rw [h,h1,h2],
  simp,
  cases ha,
  cases ha.1,
  have h1:= nat_abs_inter _ _ ha.2,
  have h2:= auxin2 _ _ h1.2,
  simp_rw [h,h2],
  simp,
  have h3:=h1.1,
  have Hk: a.1 < (n: ℤ)+1, by {linarith, },
  simp only [Hk, true_or],
  have h1:= nat_abs_inter _ _ ha.2,
  have h2:= auxin2 _ _ h1.2,
  simp_rw [h,h2],
  simp,
  have h3:=h1.1,
  have Hk: a.1 < (n: ℤ)+1, by {linarith, },
  simp only [Hk, true_or, or_true],
  cases  ha.1,
  cases  ha.2,
  simp_rw [h,h_1],
  have n1: -(n: ℤ) ≤ (n: ℤ), by {linarith,},
  simp_rw [n1],
  simp only [lt_add_iff_pos_right, true_or, eq_self_iff_true, and_self, zero_lt_one],
  simp_rw [h,h_1],
  have n1: -(n: ℤ) ≤ (n: ℤ), by {linarith,},
  simp_rw [n1],
  simp only [lt_add_iff_pos_right, true_or, eq_self_iff_true, or_true, and_self, zero_lt_one],
  cases ha.2,
  simp_rw [h,h_1],
  simp only [true_and, lt_self_iff_false, le_refl, and_true, eq_self_iff_true, or_false, and_false] at *,
  have n1: -(n: ℤ) < (n: ℤ)+1, by {linarith,} ,
  simp_rw [n1],
  simp only [true_or],
  have hg: -(n: ℤ) < n+1, by {linarith,},
  simp_rw [h,h_1, hg],
  simp,
  intro ha,
  rw Square2 at ha,
  simp only [finset.mem_union, finset.union_assoc, finset.mem_product,  finset.mem_Ico,
  neg_add_le_iff_le_add, finset.mem_singleton] at ha,
  rw square_mem',
  cases ha,
  have:= cat _ _ _ ha.2 ha.1,
  simp_rw this,
  simp only [true_and, lt_self_iff_false, and_true, false_or, eq_self_iff_true, and_false],
  exact this.2,
  cases ha,
  have:= cat1 _ _ _ ha.2 ha.1,
  simp_rw this,
  simp,
  exact this.2,
  cases ha,
  have:= dog _ _ _ ha.1 ha.2,
  simp_rw this,
  simp only [true_or, eq_self_iff_true, and_self],
  have:= dog1 _ _ _ ha.1 ha.2,
  simp_rw this,
  simp only [true_or, eq_self_iff_true, and_self],
  end

lemma Square_size (n : ℕ) (h: 1 ≤ n) : finset.card (Square (n)) = 8 * n :=
begin
  rw sqr_eq_sqr2,
  have := square2_card n h,
  norm_cast at this,
  apply this,
end

lemma Squares_are_disjoint: ∀ (i j : ℕ), i ≠ j → disjoint (Square i) (Square j):=
begin
  intros i j hij,
  rw finset.disjoint_iff_ne,
  intros a ha,
  simp at ha,
  intros b hb,
  simp at hb,
  by_contradiction,
  rw h at ha,
  rw hb at ha,
  induction ha,
  induction h,
  cases a,
  induction hb,
  cases b,
  dsimp at *,
  simp at *,
  assumption,
end

lemma Squares_cover_all :  ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ Square (i) :=
begin
intro y,
use max y.1.nat_abs y.2.nat_abs,
simp only [square_mem, and_self, forall_eq'],
end

lemma Square_zero : Square (0: ℕ)={(0,0)}:=
begin
refl,
end

lemma Square_zero_card: finset.card (Square 0)=1:=
begin
rw Square_zero,
refl,
end

/- Some summable lemmas-/

variables {α : Type u} {β : Type v} {γ : Type w} {i : α → set β}

instance  (a: α): has_lift_t (i a) (set.Union i):=
begin
  fsplit,
  intros H,
  cases H,
  fsplit,
  apply H_val,
  simp at *, fsplit, work_on_goal 2 { assumption },
  end

instance: has_coe_t  (finset (ℤ × ℤ))  (set (ℤ × ℤ)):=infer_instance

def coef (s : finset (ℤ × ℤ)): set (ℤ × ℤ):=
(s: set (ℤ × ℤ ))

def fn (In: ℕ → finset (ℤ × ℤ))  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) ) (x : ℤ × ℤ):
  x ∈  (⋃ (s: ℕ), coef (In s)):=
begin
  have h1:=HI x,
  rw set.mem_Union,
  cases h1,
  cases x,
  cases h1_h,
  dsimp at *,
  simp at *,
  fsplit, work_on_goal 2 { assumption },
end

def fnn  (In: ℕ → finset (ℤ × ℤ))  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) ) (x:  ℤ × ℤ)  :
(⋃ (s: ℕ), coef (In s)):= ⟨x, fn In HI x⟩

def union_equiv (In: ℕ → finset (ℤ × ℤ))  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) ) :
  (⋃ (s: ℕ), coef (In s)) ≃ ℤ × ℤ:={
to_fun:=λ x, x.1 ,
inv_fun:=λ x,   fnn In HI x,
left_inv:= by {simp, intros x, cases x, refl},
right_inv:=by {simp, intros x, refl}}

lemma unionmem (i: α → set β) (x : α) (y : i x): (coe y)  ∈ (⋃ x, i x):=
begin
  simp,
  use x,
  cases y,
  assumption,
end

lemma summable_disjoint_union_of_nonneg {i : α →  set β} {f : (⋃ x, i x) → ℝ}
  (h: ∀ a b, a ≠ b →  disjoint (i a) (i b)) (hf : ∀ x, 0 ≤ f x) :
  summable f ↔ (∀ x, summable (λ (y : i x), f ⟨y, unionmem i x y⟩ )) ∧
  summable (λ x, ∑' (y : i x), f ⟨y , unionmem i x y⟩) :=
 begin
  let h0:=(set.Union_eq_sigma_of_disjoint h).symm,
  have h01: summable f ↔ summable ( f ∘ h0 ),
    by {have:= equiv.summable_iff h0 , rw this, },
  have h22 : ∀ y : (Σ (s: α ), i s), 0 ≤ (f ∘ h0) y:= by {simp_rw h0,
  rw set.Union_eq_sigma_of_disjoint,
  simp only [equiv.symm_symm, function.comp_app, sigma.forall, equiv.of_bijective_apply],
  simp_rw set.sigma_to_Union,
  simp_rw hf,
  simp only [forall_2_true_iff],},
  have h1:=summable_sigma_of_nonneg h22 ,
  rw h01, rw h1,
  have H1: ∀ (x : α), summable (λ (y : (λ (s : α), ↥(i s)) x), f (h0 ⟨x, y⟩)) ↔
  summable (λ (y : ↥(i x)), f ⟨y,  unionmem i x y⟩),
  by { intro x,
     dsimp,
    simp_rw h0,
    rw set.Union_eq_sigma_of_disjoint,
    simp only [equiv.symm_symm, equiv.of_bijective_apply],
    simp_rw set.sigma_to_Union, },
  simp_rw H1,
  simp only [ and.congr_right_iff],
  intro hfin,
  have H2: ∀  (x : α), ∑' (y : (λ (s : α), ↥(i s)) x),
  (f ∘ ⇑h0) ⟨x, y⟩=∑' (y : ↥(i x)), f ⟨↑y, unionmem i x y⟩,
   by { intro x,
   simp only [function.comp_app],
   simp_rw h0,
   rw set.Union_eq_sigma_of_disjoint,
   simp only [equiv.symm_symm, equiv.of_bijective_apply],
   simp_rw set.sigma_to_Union,},
  simp_rw H2,
 end

lemma tsum_disjoint_union_of_nonneg' {i : α →  set β} {f : (⋃ x, i x) → ℝ}
  (h: ∀ a b, a ≠ b →  disjoint (i a) (i b)) (h1: summable f):
  ∑' x, f x= ∑' x , ∑' (y : i x), f ⟨y , unionmem i x y⟩   :=
 begin
  let h0:=(set.Union_eq_sigma_of_disjoint h).symm,
  have h01: ∑' x, f x = ∑' y , ( f  (h0 y)) , by {have:= equiv.tsum_eq h0 f,rw ← this,   },
  rw h01,
  rw tsum_sigma,
  simp_rw h0,
  rw set.Union_eq_sigma_of_disjoint,
  simp,
  simp_rw set.sigma_to_Union,
  have h01: summable f ↔ summable ( f ∘ h0 ), by {have:= equiv.summable_iff h0 , rw this, },
  rw ← h01,
  exact h1,
 end

lemma tsum_disjoint_union_of_nonneg'' {i : α →  set β} {f : (⋃ x, i x) → ℂ}
  (h: ∀ a b, a ≠ b →  disjoint (i a) (i b)) (h1: summable f) :
  ∑' x, f x= ∑' x , ∑' (y : i x), f ⟨y , unionmem i x y⟩   :=
 begin
  let h0:=(set.Union_eq_sigma_of_disjoint h).symm,
  have h01: ∑' x, f x = ∑' y , ( f  (h0 y)) , by {have:= equiv.tsum_eq h0 f,rw ← this,   },
  rw h01,
  rw tsum_sigma,
  simp_rw h0,
  rw set.Union_eq_sigma_of_disjoint,
  simp,
  simp_rw set.sigma_to_Union,
  have h01: summable f ↔ summable ( f ∘ h0 ), by {have:= equiv.summable_iff h0 , rw this, },
  rw ← h01,
  exact h1,
 end

lemma disjoint_aux (In: ℕ → finset (ℤ × ℤ))  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) ) :
  ∀ (i j : ℕ), i ≠ j → disjoint (In i) (In j):=
begin
 intros i j h,
 intros x h1 h2 a h3,
 cases a,
 dsimp at *,
 simp at *,
 have HI0:=HI a_fst a_snd,
  have:= exists_unique.unique HI0 (h1 h3) (h2 h3),
  rw this at h,
  simp at *,
  exact h,
end

lemma sum_lemma (f: ℤ × ℤ → ℝ) (h: ∀ y : ℤ × ℤ, 0 ≤ f y) (In: ℕ → finset (ℤ × ℤ))
  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) )  :
  summable f ↔ summable (λ ( n : ℕ), ∑ x in In (n), f x)  :=
begin
  let h2:= union_equiv In HI,
  have h22: ∀ y : (⋃ (s: ℕ), coef (In s)), 0 ≤ (f ∘ h2) y:= by {simp_rw h2, simp_rw union_equiv, simp,
  simp_rw coef, simp_rw h, simp only [forall_const, implies_true_iff],},
  have hdis':=disjoint_aux In HI,
  have h5: ∀ (x : ℕ), finset ((coef (In x))), by {intro x, rw coef, exact finset.univ,},
  have hg:∀ (x : ℕ), (coef (In x))={y : ℤ × ℤ | y ∈ In x}, by {intros x, refl,},
  have hdis:∀ (a b : ℕ) , a ≠ b →  disjoint (coef (In a)) (coef (In b)), by {intros a b hab, simp_rw coef,
  rw finset.disjoint_coe, apply hdis', exact hab,},
  have h3:=summable_disjoint_union_of_nonneg  hdis h22 ,
  have h4: summable f ↔ summable (f ∘ h2), by {have:= equiv.summable_iff h2 , rw this, },
  rw h4,
  rw h3,
  simp only [function.comp_app],
  dsimp,
  have h6: ∀ (x : ℕ), ∑' (y : ↥(coef (In x))), f (h2 ⟨y,_⟩) = ∑ y in  (In x), f y, by {
    simp only, intro x, apply finset.tsum_subtype', },
  simp_rw h6,
  simp only [and_iff_right_iff_imp],
  simp_rw h2,
  rw union_equiv,
  simp only [equiv.coe_fn_mk, subtype.coe_mk],
  intros H x,
  rw hg,
  apply finset.summable,
  apply unionmem,
  end

lemma tsum_lemma (f: ℤ × ℤ → ℝ) (In: ℕ → finset (ℤ × ℤ))
  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) ) (hs :summable f):
  ∑' x, f x =  ∑' ( n : ℕ), (∑ x in In (n), f x)  :=
begin
  let h2:= union_equiv In HI,
  have hdis':=disjoint_aux In HI,
  have h5: ∀ (x : ℕ), finset ((coef (In x))), by {intro x, rw coef, exact finset.univ,},
  have hg:∀ (x : ℕ), (coef (In x))={y : ℤ × ℤ | y ∈ In x}, by {intros x, refl,},
  have hdis:∀ (a b : ℕ) , a ≠ b →  disjoint (coef (In a)) (coef (In b)),
    by {intros a b hab, simp_rw coef,
    rw finset.disjoint_coe, apply hdis', exact hab,},
  have h6: ∀ (x : ℕ), ∑' (y : ↥(coef (In x))), f (h2 ⟨y,_⟩) = ∑ y in  (In x), f y,
   by {  simp only, intro x, apply finset.tsum_subtype', },
  simp_rw h6,
  have HS:summable (f ∘ h2), by {rw equiv.summable_iff  h2, exact hs,},
  have HH:= tsum_disjoint_union_of_nonneg'  hdis HS,
  simp at HH,
  have:= equiv.tsum_eq h2 f,
  rw ← this,
  rw HH,
  simp_rw h6,
  apply unionmem,
end

lemma tsum_lemma' (f: ℤ × ℤ → ℂ) (In: ℕ → finset (ℤ × ℤ))  (HI: ∀ (y : ℤ × ℤ), ∃! (i : ℕ), y ∈ In (i) )
(hs :summable f): ∑' x, f x =  ∑'  ( n : ℕ), (∑ x in In (n), f x)  :=
begin
  let h2:= union_equiv In HI,
  have hdis':=disjoint_aux In HI,
  have h5: ∀ (x : ℕ), finset ((coef (In x))), by {intro x, rw coef, exact finset.univ,},
  have hg:∀ (x : ℕ), (coef (In x))={y : ℤ × ℤ | y ∈ In x}, by {intros x, refl,},
  have hdis:∀ (a b : ℕ) , a ≠ b →  disjoint (coef (In a)) (coef (In b)),
    by {intros a b hab,
    simp_rw coef,
    rw finset.disjoint_coe,
    apply hdis',
    exact hab,},
  have h6: ∀ (x : ℕ), ∑' (y : ↥(coef (In x))), f (h2 ⟨y,_⟩) = ∑ y in  (In x), f y,
  by {simp only,
  intro x,
  apply finset.tsum_subtype', },
  simp_rw h6,
  have HS:summable (f ∘ h2), by {rw equiv.summable_iff  h2, exact hs,},
  have HH:= tsum_disjoint_union_of_nonneg''  hdis HS,
  simp at HH,
  have:= equiv.tsum_eq h2 f,
  rw ← this,
  rw HH,
  simp_rw h6,
  apply unionmem,
end

lemma realpow (n : ℕ ) (k : ℤ): (n: ℝ)^((k : ℝ)-1)= n^(k-1):=
begin
  have:=real.rpow_int_cast (n: ℝ) (k-1),
  rw ← this,
  simp only [int.cast_one, int.cast_sub],
end

lemma summable_if_complex_abs_summable {f : α → ℂ} :
  summable (λ x, complex.abs (f x)) →  summable f :=
begin
intro h,
apply summable_of_norm_bounded  (λ x, complex.abs (f x))  h,
intro i,
unfold norm,
exact complete_of_proper,
end

lemma complex_abs_sum_le {ι : Type*} (s : finset ι) (f : ι → ℂ) :
complex.abs(∑ i in s, f i) ≤ ∑ i in s, complex.abs(f i) :=
begin
 exact abv_sum_le_sum_abv (λ (k : ι), f k) s,
end

lemma upper_gt_zero (z: ℍ) : 0<(z: ℂ ).im:=
begin
 have H:= z.property,
 simp at H,
 apply H,
end
/--Auxilary function use for bounding Eisentein series-/
def lb (z: ℍ): ℝ:=((z.1.2)^4 + (z.1.1*z.1.2)^2)/(z.1.1^2+z.1.2^2)^2

lemma lb_pos (z : ℍ): 0 < lb z :=
begin
  rw lb,
  simp only [upper_half_plane.coe_im, subtype.val_eq_coe, upper_half_plane.coe_re],
  have H1: 0 < ((z.1.2)^4 + (z.1.1*z.1.2)^2),
  by {rw add_comm,
  apply add_pos_of_nonneg_of_pos,
  nlinarith,
  have h1: z.1.2^4=z.1.2^2*z.1.2^2,
  ring_nf,
  rw h1,
  apply mul_pos,
  simp only [upper_half_plane.coe_im, subtype.val_eq_coe],
  have:=upper_gt_zero z,
  rw pow_two,
  apply mul_pos,
  exact this,
  exact this,
  simp only [upper_half_plane.coe_im, subtype.val_eq_coe],
  have:=upper_gt_zero z,
  rw pow_two,
  apply mul_pos,
  exact this,
  exact this, },
  have H2: 0 < (z.1.1^2+z.1.2^2)^2, by {nlinarith,},
  have H3: ((z.1.2)^4 + (z.1.1*z.1.2)^2)/(z.1.1^2+z.1.2^2)^2=
    ((z.1.2)^4 + (z.1.1*z.1.2)^2)*((z.1.1^2+z.1.2^2)^2)⁻¹ , by {ring,},
  simp at H3,
  rw H3,
  have H4: 0 < ((z.1.1^2+z.1.2^2)^2)⁻¹,
  by {rw inv_pos, exact H2,},
  apply mul_pos H1 H4,
end

/--This function is used to give an upper bound on Eisenstein series-/
def rfunct (z: ℍ): ℝ:=
min (real.sqrt((z.1.2)^2)) (real.sqrt(lb z))

lemma rfunct_pos (z : ℍ): 0 < (rfunct z):=
begin
  have H:= z.property, simp at H,
  rw rfunct,
  simp only [lt_min_iff, real.sqrt_pos, upper_half_plane.coe_im, subtype.val_eq_coe],
  split,
  rw pow_two,
  apply mul_pos,
  exact H,
  exact H,
  apply lb_pos,
end

lemma alem (a b c : ℝ): (a-b) ≤ a+c ↔ -b ≤ c:=
begin
  have: a-b= a+(-b), by {ring,},
  split,
  rw this,
  simp_rw add_le_add_iff_left,
  simp,
  rw this,
  simp_rw add_le_add_iff_left,
  simp,
end

lemma ineq1 (x y d: ℝ  ): 0 ≤ d^2*(x^2+y^2)^2+2*d*x*(x^2+y^2)+x^2:=
begin
  have h1: d^2*(x^2+y^2)^2+2*d*x*(x^2+y^2)+x^2 =(d*(x^2+y^2)+x)^2, by {ring,},
  rw h1,
  nlinarith,
end

lemma lowbound (z : ℍ) (δ : ℝ): ((z.1.2)^4 + (z.1.1*z.1.2)^2)/(z.1.1^2+z.1.2^2)^2 ≤
  (δ*z.1.1+1)^2+(δ*z.1.2)^2:=
begin
  simp only [upper_half_plane.coe_im, subtype.val_eq_coe, upper_half_plane.coe_re],
  have H1: (δ*z.1.1+1)^2+(δ*z.1.2)^2=δ^2*(z.1.1^2+z.1.2^2)+2*δ*z.1.1+1, by {ring,},
  simp only [upper_half_plane.coe_im, subtype.val_eq_coe, upper_half_plane.coe_re] at H1,
  rw H1,
  rw div_le_iff,
  simp only,
  have H2: (δ ^ 2 * ( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2) + 2 * δ *  (z: ℂ).re + 1) *
  ( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2) ^ 2=δ ^ 2 * ( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2)^3 + 2 * δ *
  (z: ℂ).re* ( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2) ^ 2+   ( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2) ^ 2,
  by {ring,},
  simp only [upper_half_plane.coe_im, upper_half_plane.coe_re] at H2,
  rw H2,
  rw ← sub_nonneg,
  have H3:( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2) ^ 2-((z: ℂ).im ^ 4 + ((z: ℂ).re * (z: ℂ).im) ^ 2)=
  ((z: ℂ).re)^2*( (z: ℂ).re ^ 2 +  (z: ℂ).im ^ 2), by {ring,},
  have H4: δ ^ 2 * ((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2) ^ 3 + 2 * δ *
  (z: ℂ).re * ((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2) ^ 2 + ((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2) ^ 2 -
  ((z: ℂ).im ^ 4 + ((z: ℂ).re * (z: ℂ).im) ^ 2)=
  (((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2))*(δ ^ 2 * ((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2)^2 + 2 * δ *
  (z: ℂ).re * ((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2) +(z: ℂ).re ^ 2), by {ring,},
  simp only [upper_half_plane.coe_im, upper_half_plane.coe_re] at H4,
  rw H4,
  have H5: 0 ≤ (δ ^ 2 * ((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2)^2 + 2 * δ * (z: ℂ).re * ((z: ℂ).re ^ 2 +
  (z: ℂ).im ^ 2) +(z: ℂ).re ^ 2), by {apply ineq1,},
  have H6: 0 ≤ (((z: ℂ).re ^ 2 + (z: ℂ).im ^ 2)), by {nlinarith,},
  apply mul_nonneg H6 H5,
  have H7:= z.property, simp at H7,
  have H8:0 < (z: ℂ).im ^ 2, by {simp only [H7, pow_pos, upper_half_plane.coe_im], },
  have H9: 0 <((z: ℂ).im ^ 2+(z: ℂ).re ^ 2), by {nlinarith,},
  apply pow_two_pos_of_ne_zero,
  nlinarith,
end

lemma auxlem (z : ℍ) (δ : ℝ) :
  (rfunct z) ≤ complex.abs ( (z: ℂ)+δ ) ∧ (rfunct z) ≤ complex.abs ( δ*(z: ℂ) +1):=
begin
  split,
  {rw rfunct,
  rw complex.abs,
  simp,
  have H1: real.sqrt (((z: ℂ).im)^2) ≤
  real.sqrt (((z: ℂ).re + δ) * ((z: ℂ).re + δ) + (z: ℂ).im * (z: ℂ).im),
  by {rw real.sqrt_le_sqrt_iff,
  nlinarith,nlinarith,},
  simp at *,
  left,
  rw norm_sq_apply,
  simp,
  simp_rw H1,},
  {rw rfunct,
  rw complex.abs,
  simp,
  have H1:  real.sqrt (lb z) ≤
  real.sqrt ((δ*(z: ℂ).re  + 1) * (δ*(z: ℂ).re  + 1) + δ*(z: ℂ).im *  (δ*(z: ℂ).im )),
  by { rw lb,
  rw real.sqrt_le_sqrt_iff,
  have:= lowbound z δ,
  rw ← pow_two,
  rw ← pow_two,
  simp only [upper_half_plane.coe_im, subtype.val_eq_coe, upper_half_plane.coe_re] at *,
  apply this,
  nlinarith,},
  simp only [upper_half_plane.coe_im, upper_half_plane.coe_re] at H1,
  rw norm_sq_apply,
  right,
  simp,
  simp_rw H1,},
end

lemma le_of_pow' (a b : ℝ) (k: ℕ)(h : 0 ≤ a) (h2: 0 ≤ b) (h3: a ≤ b): a^k ≤ b^k:=
begin
exact pow_le_pow_of_le_left h h3 k,
end

lemma baux (a : ℝ) (k : ℕ) (b : ℂ) (h: 0 ≤ a) (h2: a ≤ complex.abs b): a^k ≤ complex.abs (b^k):=
begin
  rw complex.abs_pow,
  apply pow_le_pow_of_le_left,
  exact h,
  exact h2,
end

lemma baux2 (z : ℍ) (k: ℕ): complex.abs ((rfunct z)^k)=(rfunct z)^k:=
begin
  norm_cast,
  let a:=rfunct z,
  simp,
  have ha: 0 ≤ a, by {simp_rw a, have:= rfunct_pos z , apply le_of_lt this, },
  have:= complex.abs_of_nonneg ha,
  norm_cast at this,
  simp_rw a at this,
  rw this,
end

lemma auxlem2 (z : ℍ) (n : ℕ)  (x: ℤ × ℤ) (h2: x ∈ Square n) (k : ℕ)  :
  complex.abs (((rfunct z): ℂ)^k) ≤ complex.abs (( (z: ℂ)+(x.2: ℂ)/(x.1 : ℂ) )^k):=
begin
  norm_cast,
  have H1: complex.abs ((rfunct z)^k)=(rfunct z)^k, by {apply baux2,},
  norm_cast at H1,
  rw H1,
  apply baux,
  have:= rfunct_pos z,
  apply le_of_lt this,
  have:= auxlem z ((x.2/x.1): ℝ),
  norm_cast at this,
  apply this.1,
end

lemma auxlem3 (z : ℍ) (n : ℕ)  (x: ℤ × ℤ) (h2: x ∈ Square n) (k : ℕ)  :
 complex.abs (((rfunct z): ℂ)^k) ≤  complex.abs (( ((x.1: ℂ)/(x.2 : ℂ))*(z: ℂ) +1)^k):=
begin
  norm_cast,
  have H1:= (baux2 z k),
  norm_cast at H1,
  rw H1,
  apply baux,
  have:= rfunct_pos z,
  apply le_of_lt this,
  have:= auxlem z ((x.1/x.2): ℝ),
  norm_cast at *,
  apply this.2,
end

end Eisenstein_series


/-
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

Relator for functions, pairs, sums, and lists.
-/

import tactic.reserved_notation

namespace relator
universe variables u₁ u₂ v₁ v₂

/- TODO(johoelzl):
 * should we introduce relators of datatypes as recursive function or as inductive
predicate? For now we stick to the recursor approach.
 * relation lift for datatypes, Π, Σ, set, and subtype types
 * proof composition and identity laws
 * implement method to derive relators from datatype
-/

section
variables {α : Sort u₁} {β : Sort u₂} {γ : Sort v₁} {δ : Sort v₂}
variables (R : α → β → Prop) (S : γ → δ → Prop)

def lift_fun (f : α → γ) (g : β → δ) : Prop :=
∀⦃a b⦄, R a b → S (f a) (g b)

infixr ⇒ := lift_fun

end

section
variables {α : Type u₁} {β : out_param $ Type u₂} (R : out_param $ α → β → Prop)

class right_total : Prop := (right : ∀b, ∃a, R a b)
class left_total : Prop := (left : ∀a, ∃b, R a b)
class bi_total extends left_total R, right_total R : Prop

end

section
variables {α : Type u₁} {β : Type u₂} (R : α → β → Prop)

class left_unique : Prop := (left : ∀{a b c}, R a b → R c b → a = c)
class right_unique : Prop := (right : ∀{a b c}, R a b → R a c → b = c)

lemma left_unique.unique {R : α → β → Prop} (h : left_unique R) {a b c} :
  R a b → R c b → a = c := left_unique.left β

lemma right_unique.unique {R : α → β → Prop} (h : right_unique R) {a b c} :
  R a b → R a c → b = c := right_unique.right α

lemma rel_forall_of_right_total [right_total R] :
  ((R ⇒ implies) ⇒ implies) (λp, ∀i, p i) (λq, ∀i, q i) :=
assume p q Hrel H b, exists.elim (right_total.right b) (assume a Rab, Hrel Rab (H _))

lemma rel_exists_of_left_total [left_total R] :
  ((R ⇒ implies) ⇒ implies) (λp, ∃i, p i) (λq, ∃i, q i) :=
assume p q Hrel ⟨a, pa⟩, let ⟨b, Rab⟩ := left_total.left a in ⟨b, Hrel Rab pa⟩

lemma rel_forall_of_total [bi_total R] : ((R ⇒ iff) ⇒ iff) (λp, ∀i, p i) (λq, ∀i, q i) :=
assume p q Hrel,
  ⟨assume H b, exists.elim (right_total.right b) (assume a Rab, (Hrel Rab).mp (H _)),
    assume H a, exists.elim (left_total.left a) (assume b Rab, (Hrel Rab).mpr (H _))⟩

lemma rel_exists_of_total [bi_total R] : ((R ⇒ iff) ⇒ iff) (λp, ∃i, p i) (λq, ∃i, q i) :=
assume p q Hrel,
  ⟨assume ⟨a, pa⟩, let ⟨b, Rab⟩ := left_total.left a in ⟨b, (Hrel Rab).1 pa⟩,
    assume ⟨b, qb⟩, let ⟨a, Rab⟩ := right_total.right b in ⟨a, (Hrel Rab).2 qb⟩⟩

lemma left_unique_of_rel_eq {eq' : β → β → Prop} (he : (R ⇒ (R ⇒ iff)) eq eq') : left_unique R :=
⟨λ a b c (ab : R a b) (cb : R c b),
have eq' b b,
  from iff.mp (he ab ab) rfl,
iff.mpr (he ab cb) this⟩

end

lemma rel_imp : (iff ⇒ (iff  ⇒ iff)) implies implies :=
assume p q h r s l, imp_congr h l

lemma rel_not : (iff ⇒ iff) not not :=
assume p q h, not_congr h

@[priority 100] -- see Note [lower instance priority]
-- (this is an instance is always applies, since the relation is an out-param)
instance bi_total_eq {α : Type u₁} : relator.bi_total (@eq α) :=
{ left := λ a, ⟨a, rfl⟩, right := λ a, ⟨a, rfl⟩ }

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables {r : α → β → Prop} {p : β → γ → Prop} {q : γ → δ → Prop}

class bi_unique (r : α → β → Prop) extends left_unique r, right_unique r : Prop

lemma left_unique_flip : left_unique r → right_unique (flip r)
| ⟨h⟩ := ⟨λ a b c h₁ h₂, h h₁ h₂⟩

lemma rel_and : ((↔) ⇒ (↔) ⇒ (↔)) (∧) (∧) :=
assume a b h₁ c d h₂, and_congr h₁ h₂

lemma rel_or : ((↔) ⇒ (↔) ⇒ (↔)) (∨) (∨) :=
assume a b h₁ c d h₂, or_congr h₁ h₂

lemma rel_iff : ((↔) ⇒ (↔) ⇒ (↔)) (↔) (↔) :=
assume a b h₁ c d h₂, iff_congr h₁ h₂

lemma rel_eq {r : α → β → Prop} (hr : bi_unique r) : (r ⇒ r ⇒ (↔)) (=) (=) :=
assume a b h₁ c d h₂,
iff.intro
  begin intro h, subst h, exact right_unique.right α h₁ h₂ end
  begin intro h, subst h, exact left_unique.left β h₁ h₂ end

end relator


/-
Copyright (c) 2021 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import algebra.group_power.basic
import algebra.ring.opposite
import group_theory.group_action.opposite
import group_theory.group_action.prod

/-!
# Introduce `smul_with_zero`

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

In analogy with the usual monoid action on a Type `M`, we introduce an action of a
`monoid_with_zero` on a Type with `0`.

In particular, for Types `R` and `M`, both containing `0`, we define `smul_with_zero R M` to
be the typeclass where the products `r • 0` and `0 • m` vanish for all `r : R` and all `m : M`.

Moreover, in the case in which `R` is a `monoid_with_zero`, we introduce the typeclass
`mul_action_with_zero R M`, mimicking group actions and having an absorbing `0` in `R`.
Thus, the action is required to be compatible with

* the unit of the monoid, acting as the identity;
* the zero of the monoid_with_zero, acting as zero;
* associativity of the monoid.

We also add an `instance`:

* any `monoid_with_zero` has a `mul_action_with_zero R R` acting on itself.

## Main declarations

* `smul_monoid_with_zero_hom`: Scalar multiplication bundled as a morphism of monoids with zero.
-/

variables {R R' M M' : Type*}

section has_zero

variables (R M)
/--  `smul_with_zero` is a class consisting of a Type `R` with `0 ∈ R` and a scalar multiplication
of `R` on a Type `M` with `0`, such that the equality `r • m = 0` holds if at least one among `r`
or `m` equals `0`. -/
class smul_with_zero [has_zero R] [has_zero M] extends smul_zero_class R M :=
(zero_smul : ∀ m : M, (0 : R) • m = 0)

instance mul_zero_class.to_smul_with_zero [mul_zero_class R] : smul_with_zero R R :=
{ smul := (*),
  smul_zero := mul_zero,
  zero_smul := zero_mul }

/-- Like `mul_zero_class.to_smul_with_zero`, but multiplies on the right. -/
instance mul_zero_class.to_opposite_smul_with_zero [mul_zero_class R] : smul_with_zero Rᵐᵒᵖ R :=
{ smul := (•),
  smul_zero := λ r, zero_mul _,
  zero_smul := mul_zero }

variables (R) {M} [has_zero R] [has_zero M] [smul_with_zero R M]

@[simp] lemma zero_smul (m : M) : (0 : R) • m = 0 := smul_with_zero.zero_smul m

variables {R} {a : R} {b : M}

lemma smul_eq_zero_of_left (h : a = 0) (b : M) : a • b = 0 := h.symm ▸ zero_smul _ b
lemma smul_eq_zero_of_right (a : R) (h : b = 0) : a • b = 0 := h.symm ▸ smul_zero a
lemma left_ne_zero_of_smul : a • b ≠ 0 → a ≠ 0 := mt $ λ h, smul_eq_zero_of_left h b
lemma right_ne_zero_of_smul : a • b ≠ 0 → b ≠ 0 := mt $ smul_eq_zero_of_right a

variables {R M} [has_zero R'] [has_zero M'] [has_smul R M']

/-- Pullback a `smul_with_zero` structure along an injective zero-preserving homomorphism.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.smul_with_zero
  (f : zero_hom M' M) (hf : function.injective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  smul_with_zero R M' :=
{ smul := (•),
  zero_smul := λ a, hf $ by simp [smul],
  smul_zero := λ a, hf $ by simp [smul]}

/-- Pushforward a `smul_with_zero` structure along a surjective zero-preserving homomorphism.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.smul_with_zero
  (f : zero_hom M M') (hf : function.surjective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  smul_with_zero R M' :=
{ smul := (•),
  zero_smul := λ m, by { rcases hf m with ⟨x, rfl⟩, simp [←smul] },
  smul_zero := λ c, by simp only [← f.map_zero, ← smul, smul_zero] }

variables (M)

/-- Compose a `smul_with_zero` with a `zero_hom`, with action `f r' • m` -/
def smul_with_zero.comp_hom (f : zero_hom R' R) : smul_with_zero R' M :=
{ smul := (•) ∘ f,
  smul_zero := λ m, by simp,
  zero_smul := λ m, by simp }

end has_zero

instance add_monoid.nat_smul_with_zero [add_monoid M] : smul_with_zero ℕ M :=
{ smul_zero := nsmul_zero,
  zero_smul := zero_nsmul }

instance add_group.int_smul_with_zero [add_group M] : smul_with_zero ℤ M :=
{ smul_zero := zsmul_zero,
  zero_smul := zero_zsmul }

section monoid_with_zero

variables [monoid_with_zero R] [monoid_with_zero R'] [has_zero M]

variables (R M)
/--  An action of a monoid with zero `R` on a Type `M`, also with `0`, extends `mul_action` and
is compatible with `0` (both in `R` and in `M`), with `1 ∈ R`, and with associativity of
multiplication on the monoid `M`. -/
class mul_action_with_zero extends mul_action R M :=
-- these fields are copied from `smul_with_zero`, as `extends` behaves poorly
(smul_zero : ∀ r : R, r • (0 : M) = 0)
(zero_smul : ∀ m : M, (0 : R) • m = 0)

@[priority 100] -- see Note [lower instance priority]
instance mul_action_with_zero.to_smul_with_zero [m : mul_action_with_zero R M] :
  smul_with_zero R M :=
{..m}

/-- See also `semiring.to_module` -/
instance monoid_with_zero.to_mul_action_with_zero : mul_action_with_zero R R :=
{ ..mul_zero_class.to_smul_with_zero R,
  ..monoid.to_mul_action R }

/-- Like `monoid_with_zero.to_mul_action_with_zero`, but multiplies on the right. See also
`semiring.to_opposite_module` -/
instance monoid_with_zero.to_opposite_mul_action_with_zero : mul_action_with_zero Rᵐᵒᵖ R :=
{ ..mul_zero_class.to_opposite_smul_with_zero R,
  ..monoid.to_opposite_mul_action R }

protected lemma mul_action_with_zero.subsingleton
  [mul_action_with_zero R M] [subsingleton R] : subsingleton M :=
⟨λ x y, by rw [←one_smul R x, ←one_smul R y, subsingleton.elim (1 : R) 0, zero_smul, zero_smul]⟩

protected lemma mul_action_with_zero.nontrivial
  [mul_action_with_zero R M] [nontrivial M] : nontrivial R :=
(subsingleton_or_nontrivial R).resolve_left $ λ hR, not_subsingleton M $
  by exactI mul_action_with_zero.subsingleton R M

variables {R M} [mul_action_with_zero R M] [has_zero M'] [has_smul R M']

/-- Pullback a `mul_action_with_zero` structure along an injective zero-preserving homomorphism.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.mul_action_with_zero
  (f : zero_hom M' M) (hf : function.injective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  mul_action_with_zero R M' :=
{ ..hf.mul_action f smul, ..hf.smul_with_zero f smul }

/-- Pushforward a `mul_action_with_zero` structure along a surjective zero-preserving homomorphism.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.mul_action_with_zero
  (f : zero_hom M M') (hf : function.surjective f) (smul : ∀ (a : R) b, f (a • b) = a • f b) :
  mul_action_with_zero R M' :=
{ ..hf.mul_action f smul, ..hf.smul_with_zero f smul }

variables (M)

/-- Compose a `mul_action_with_zero` with a `monoid_with_zero_hom`, with action `f r' • m` -/
def mul_action_with_zero.comp_hom (f : R' →*₀ R) : mul_action_with_zero R' M :=
{ smul := (•) ∘ f,
  mul_smul := λ r s m, by simp [mul_smul],
  one_smul := λ m, by simp,
  .. smul_with_zero.comp_hom M f.to_zero_hom}

end monoid_with_zero

section group_with_zero
variables {α β : Type*} [group_with_zero α] [group_with_zero β] [mul_action_with_zero α β]

lemma smul_inv₀ [smul_comm_class α β β] [is_scalar_tower α β β] (c : α) (x : β) :
  (c • x)⁻¹ = c⁻¹ • x⁻¹ :=
begin
  obtain rfl | hc := eq_or_ne c 0,
  { simp only [inv_zero, zero_smul] },
  obtain rfl | hx := eq_or_ne x 0,
  { simp only [inv_zero, smul_zero] },
  { refine inv_eq_of_mul_eq_one_left _,
    rw [smul_mul_smul, inv_mul_cancel hc, inv_mul_cancel hx, one_smul] }
end

end group_with_zero

/-- Scalar multiplication as a monoid homomorphism with zero. -/
@[simps]
def smul_monoid_with_zero_hom {α β : Type*} [monoid_with_zero α] [mul_zero_one_class β]
  [mul_action_with_zero α β] [is_scalar_tower α β β] [smul_comm_class α β β] :
  α × β →*₀ β :=
{ map_zero' := smul_zero _,
  .. smul_monoid_hom }


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.norm_cast
import Mathlib.data.int.cast
import Mathlib.PostPort

namespace Mathlib

/-!
# A tactic to shift `ℕ` goals to `ℤ`

It is often easier to work in `ℤ`, where subtraction is well behaved, than in `ℕ` where it isn't.
`zify` is a tactic that casts goals and hypotheses about natural numbers to ones about integers.
It makes use of `push_cast`, part of the `norm_cast` family, to simplify these goals.

## Implementation notes

`zify` is extensible, using the attribute `@[zify]` to label lemmas used for moving propositions
from `ℕ` to `ℤ`.
`zify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pz (a₁ : ℤ) ... (aₙ : ℤ) ↔ Pn a₁ ... aₙ`.
For example, `int.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `zify` lemma.

`zify` is very nearly just `simp only with zify push_cast`. There are a few minor differences:
* `zify` lemmas are used in the opposite order of the standard simp form.
  E.g. we will rewrite with `int.coe_nat_le_coe_nat_iff` from right to left.
* `zify` should fail if no `zify` lemma applies (i.e. it was unable to shift any proposition to ℤ).
  However, once this succeeds, it does not necessarily need to rewrite with any `push_cast` rules.
-/

namespace zify

/--
The `zify` attribute is used by the `zify` tactic. It applies to lemmas that shift propositions
between `nat` and `int`.

`zify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pz (a₁ : ℤ) ... (aₙ : ℤ) ↔ Pn a₁ ... aₙ`.
For example, `int.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `zify` lemma.
-/
/--
Given an expression `e`, `lift_to_z e` looks for subterms of `e` that are propositions "about"
natural numbers and change them to propositions about integers.

Returns an expression `e'` and a proof that `e = e'`.

Includes `ge_iff_le` and `gt_iff_lt` in the simp set. These can't be tagged with `zify` as we
want to use them in the "forward", not "backward", direction.
-/
end zify

theorem int.coe_nat_ne_coe_nat_iff (a : ℕ) (b : ℕ) : ↑a ≠ ↑b ↔ a ≠ b := sorry

/--
`zify extra_lems e` is used to shift propositions in `e` from `ℕ` to `ℤ`.
This is often useful since `ℤ` has well-behaved subtraction.

The list of extra lemmas is used in the `push_cast` step.

Returns an expression `e'` and a proof that `e = e'`.-/
/--
A variant of `tactic.zify` that takes `h`, a proof of a proposition about natural numbers,
and returns a proof of the zified version of that propositon.
-/
/--
The `zify` tactic is used to shift propositions from `ℕ` to `ℤ`.
This is often useful since `ℤ` has well-behaved subtraction.

```lean
example (a b c x y z : ℕ) (h : ¬ x*y*z < 0) : c < a + 3*b :=
begin
  zify,
  zify at h,
  /-
  h : ¬↑x * ↑y * ↑z < 0
  ⊢ ↑c < ↑a + 3 * ↑b
  -/


import Mathlib

namespace List

def empty : List α → Bool
| []       => true
| (_ :: _) => false

def findIndex (p : α → Prop) [DecidablePred p] : List α → Nat
  | []     => 0
  | (a::l) => if p a then 0 else Nat.succ (findIndex p l)

def indexOf [DecidableEq α] (a : α) : List α → Nat := findIndex (Eq a)

theorem index_of_cons_self [DecidableEq α] (a : α) (l : List α) :
  indexOf a (a::l) = 0 :=
  sorry

variable (r : α → α → Prop)

theorem pairwisePWFilter {R : α → α → Prop} [DecidableRel R] :
  ∀ (l : List α), pairwise R (pwFilter R l) :=
  sorry

def sorted : List α → Prop := pairwise r

theorem nodup_erase_of_nodup [DecidableEq α] (a : α) {l} :
  nodup l → nodup (l.erase a) :=
  sorry

-- From the old "mathlib.lean"
theorem index_of_erase_lt {α : Type _} [DecidableEq α] {l : List α} {e x x' : α} (h : l.indexOf x < l.indexOf x') (hₘ : x ∈ l.erase e) (hₘ' : x' ∈ l.erase e) (hₙ : l.nodup) :
  (l.erase e).indexOf x < (l.erase e).indexOf x' :=
  sorry

theorem nodupEraseDup [DecidableEq α] : ∀ l : List α, l.eraseDup.nodup := pairwisePWFilter

theorem perm_ext {l₁ l₂ : List α} (d₁ : nodup l₁) (d₂ : nodup l₂) :
  l₁ ~ l₂ ↔ ∀a, a ∈ l₁ ↔ a ∈ l₂ :=
  sorry

theorem perm.mem_iff {a : α} {l₁ l₂ : List α} (h : l₁ ~ l₂) :
  a ∈ l₁ ↔ a ∈ l₂ :=
  sorry

theorem Perm.length_eq {l₁ l₂ : List α} (p : l₁ ~ l₂) : length l₁ = length l₂ := by
  induction p with
  | nil => rfl
  | cons _ _ h => simp [h]
  | swap => simp
  | trans _ _ h₁ h₂ => exact Eq.trans h₁ h₂

theorem Perm.eq_nil {l : List α} (p : l ~ []) :
  l = [] :=
  eq_nil_of_length_eq_zero p.length_eq

theorem Perm.nil_eq {l : List α} (p : [] ~ l) :
  [] = l :=
  p.symm.eq_nil.symm

theorem Perm.cons_inv {a : α} {l₁ l₂ : List α} : a::l₁ ~ a::l₂ → l₁ ~ l₂ := sorry

theorem Perm.pairwise_iff {R : α → α → Prop} (S : ∀ {x y}, R x y → R y x) : ∀ {l₁ l₂ : List α} (p : l₁ ~ l₂), pairwise R l₁ ↔ pairwise R l₂ := sorry

theorem Perm.nodup_iff {l₁ l₂ : List α} : l₁ ~ l₂ → (List.nodup l₁ ↔ List.nodup l₂) := Perm.pairwise_iff Ne.symm

theorem Perm.mem_iff {a : α} {l₁ l₂ : List α} (h : l₁ ~ l₂) : a ∈ l₁ ↔ a ∈ l₂ := sorry

def keys {β : α → Type v} : List (Sigma β) → List α := map Sigma.fst

def nodupkeys {β : α → Type v} (l : List (Sigma β)) : Prop := l.keys.nodup

theorem filterMapConsSome (f : α → Option β) (a : α) (l : List α) {b : β} (h : f a = some b) : filterMap f (a :: l) = b :: filterMap f l := sorry

theorem filterMapEqMap (f : α → β) : filterMap (some ∘ f) = map f := sorry

theorem Perm.filterMap (f : α → Option β) {l₁ l₂ : List α} (p : l₁ ~ l₂) : filterMap f l₁ ~ filterMap f l₂ := sorry

theorem Perm.map {β} (f : α → β) {l₁ l₂ : List α} (p : l₁ ~ l₂) : map f l₁ ~ map f l₂ := filterMapEqMap f ▸ p.filterMap _

theorem perm_nodup_keys {β : α → Type v} {l₁ l₂ : List (Sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ := (h.map _).nodup_iff

theorem permIffCount [DecidableEq α] {l₁ l₂ : List α} : l₁ ~ l₂ ↔ (∀ a, count a l₁ = count a l₂) := sorry

theorem perm.eraseDup [DecidableEq α] {l₁ l₂ : List α} (p : l₁ ~ l₂) : eraseDup l₁ ~ eraseDup l₂ := sorry

def lookup' (a : α) : List (Sigma β) → Option (β a)
| []             => none
| (⟨a', b⟩ :: l) => sorry -- if h : a' = a then some (Eq.recOn h b) else lookup' l

theorem permLookup (a : α) {l₁ l₂ : List (Sigma β)} (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup' a l₁ = lookup' a l₂ := sorry

def attach (l : List α) : List {x // x ∈ l} := sorry

@[simp] theorem mem_attach (l : List α) : ∀ x, x ∈ l.attach := sorry

inductive forall₂ (R : α → β → Prop) : List α → List β → Prop
  | nil : forall₂ R [] []
  | cons {a b l₁ l₂} : R a b → forall₂ R l₁ l₂ → forall₂ R (a::l₁) (b::l₂)

end List


/-
  Copyright (c) 2022 Arthur Paulino. All rights reserved.
  Released under Apache 2.0 license as described in the file LICENSE.
  Authors: Arthur Paulino, Joseph O
-/

import FxyLang.Implementation.NEList

def NEList.isEqToList : NEList α → List α → Prop
  | .cons a as, b :: bs => a = b ∧ isEqToList as bs
  | .uno  a   , [b]     => a = b
  | _,          _       => False

theorem NEList.ListToNEListIsEqList {a : α} {as : List α} :
    (as.toNEList a).isEqToList (a :: as) := by
  induction as with
  | nil            => simp only [isEqToList]
  | cons a' as' hi =>
    cases as' with
    | nil      => simp only [isEqToList]
    | cons _ _ => simp [isEqToList] at hi ⊢; exact hi

theorem NEList.toListEqList {a : α} {as : List α} :
    (as.toNEList a).toList = a :: as := by
  induction as with
  | nil           => simp only [toList]
  | cons _ as' hi =>
    cases as' with
    | nil      => simp only [toList]
    | cons _ _ => simp [toList] at hi ⊢; exact hi

theorem eqIffBEq [BEq α] [LawfulBEq α] {a b : α} : a == b ↔ a = b := by
  constructor
  · intro h; exact eq_of_beq h
  · intro h; simp [h]

theorem eqRfl [BEq α] {a x : α} : a = x ↔ x = a := by
  constructor
  all_goals
  · intro h; simp [h]

theorem notEqRfl [BEq α] {a x : α} : ¬ a = x ↔ ¬ x = a := by
  constructor
  · intro h
    by_cases h' : x = a
    · simp [eqRfl, h] at h'
    · exact h'
  · intro h
    by_cases h' : a = x
    · simp [h'] at h
    · exact h'

theorem notBEqOfNotEq [BEq α] [LawfulBEq α] {a x : α} (h : ¬a = x) :
    ¬ x == a := by
  by_cases h' : x == a
  · simp [eq_of_beq h'] at h
  · exact h'

theorem List.eqOfSingletonListContains [BEq α] [LawfulBEq α] {a x : α} :
    [a].contains x ↔ a == x := by
  constructor
  · intro h
    simp [contains, elem] at h
    by_cases h' : a = x
    · simp [h']
    · simp [notBEqOfNotEq h'] at h
  · intro h
    rw [contains, elem]
    have : x == a := by
      rw [eqIffBEq] at h ⊢
      exact eqRfl.mpr h
    simp only [this]

theorem NEList.containsOfListContains [BEq α] [LawfulBEq α] {l : NEList α}
    (h : l.toList.contains x) : l.contains x := by
  induction l with
  | uno  _      => exact List.eqOfSingletonListContains.mp h
  | cons a _ hi =>
    rw [toList] at h
    simp [contains]
    by_cases h' : a == x
    · exact Or.inl h'
    · rw [List.contains] at h
      have : ¬ x == a := by
        rw [eqIffBEq] at h' ⊢
        exact notEqRfl.mp h'
      simp only [this, List.elem] at h
      exact Or.inr $ hi h

theorem NEList.listContainsOfNEListContains [BEq α] [LawfulBEq α] {l : NEList α}
    (h : l.contains x) : l.toList.contains x := by
  induction l with
  | uno  _      => exact List.eqOfSingletonListContains.mpr h
  | cons a _ hi =>
    rw [toList]
    simp [contains] at h
    cases h with | _ h => ?_
    · simp [eqIffBEq.mp h, List.contains, List.elem]
    · rw [List.contains, List.elem]
      by_cases h' : x == a
      · rw [h']
      · simp only [h', hi h]

theorem NEList.containsIffListContains [BEq α] [LawfulBEq α] {l : NEList α} :
    l.contains x ↔ l.toList.contains x :=
  ⟨listContainsOfNEListContains, containsOfListContains⟩

theorem NEList.notContainsIffListNotContains [BEq α] [LawfulBEq α]
    {l : NEList α} : l.contains x = false ↔ l.toList.contains x = false := by
  constructor
  · intro h
    by_cases h' : List.contains (toList l) x
    · simp only [containsIffListContains.mpr h'] at h
    · simp only [h']
  · intro h
    by_cases h' : l.contains x
    · simp only [containsIffListContains.mp h'] at h
    · simp only [h']

theorem NEList.noDupIffToListNoDup [BEq α] [LawfulBEq α] {l : NEList α} :
    l.noDup ↔ l.toList.noDup := by
  constructor
  · intro h
    induction l with
    | uno _ => simp [noDup, List.noDup, List.contains, List.elem]
    | cons _ _ hi =>
      simp [noDup] at h
      simp [toList, List.noDup]
      exact ⟨(notContainsIffListNotContains.mp h.1), (hi h.2)⟩
  · intro h
    induction l with
    | uno _ => rw [noDup]
    | cons _ _ hi =>
      simp [List.noDup] at h
      simp [noDup]
      exact ⟨(notContainsIffListNotContains.mpr h.1), (hi h.2)⟩

theorem NEList.lengthEqToListLength [BEq α] {l : NEList α} :
    l.length = l.toList.length := by
  induction l with
  | uno _ => simp [length, toList]
  | cons a as hi =>
    simp [length, toList, hi, Nat.add_comm]

theorem NEList.mapEqToListMap {α β : Type} (f : α → β) (l : NEList α) :
    (l.map f).isEqToList (l.toList.map f) := by
  induction l with
  | uno  _      => simp only [map, List.map, isEqToList]
  | cons _ _ hi => simp only [map, List.map, isEqToList, hi]

theorem NEList.foldlEqToListFoldl {α β : Type}
  (l : NEList β) (a : α) (f : α → β → α) :
    l.foldl f a = l.toList.foldl f a := by
  induction l generalizing a with
  | uno  _      => simp only [foldl, List.foldl]
  | cons _ _ hi => simp only [foldl, List.foldl, hi]


/-
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

! This file was ported from Lean 3 source module category_theory.idempotents.functor_categories
! leanprover-community/mathlib commit 31019c2504b17f85af7e0577585fad996935a317
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Idempotents.Karoubi

/-!
# Idempotent completeness and functor categories

In this file we define an instance `functor_category_is_idempotent_complete` expressing
that a functor category `J ⥤ C` is idempotent complete when the target category `C` is.

We also provide a fully faithful functor
`karoubi_functor_category_embedding : karoubi (J ⥤ C)) : J ⥤ karoubi C` for all categories
`J` and `C`.

-/

open CategoryTheory

open CategoryTheory.Category

open CategoryTheory.Idempotents.Karoubi

open CategoryTheory.Limits

namespace CategoryTheory

namespace Idempotents

variable {J C : Type _} [Category J] [Category C] (P Q : Karoubi (J ⥤ C)) (f : P ⟶ Q) (X : J)

@[simp, reassoc.1]
theorem app_idem : P.p.app X ≫ P.p.app X = P.p.app X :=
  congr_app P.idem X
#align category_theory.idempotents.app_idem CategoryTheory.Idempotents.app_idem

variable {P Q}

@[simp, reassoc.1]
theorem app_p_comp : P.p.app X ≫ f.f.app X = f.f.app X :=
  congr_app (p_comp f) X
#align category_theory.idempotents.app_p_comp CategoryTheory.Idempotents.app_p_comp

@[simp, reassoc.1]
theorem app_comp_p : f.f.app X ≫ Q.p.app X = f.f.app X :=
  congr_app (comp_p f) X
#align category_theory.idempotents.app_comp_p CategoryTheory.Idempotents.app_comp_p

@[reassoc.1]
theorem app_p_comm : P.p.app X ≫ f.f.app X = f.f.app X ≫ Q.p.app X :=
  congr_app (p_comm f) X
#align category_theory.idempotents.app_p_comm CategoryTheory.Idempotents.app_p_comm

variable (J C)

instance functor_category_isIdempotentComplete [IsIdempotentComplete C] :
    IsIdempotentComplete (J ⥤ C) := by
  refine' ⟨_⟩
  intro F p hp
  have hC := (is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent C).mp inferInstance
  haveI : ∀ j : J, has_equalizer (𝟙 _) (p.app j) := fun j => hC _ _ (congr_app hp j)
  /- We construct the direct factor `Y` associated to `p : F ⟶ F` by computing
      the equalizer of the identity and `p.app j` on each object `(j : J)`.  -/
  let Y : J ⥤ C :=
    { obj := fun j => limits.equalizer (𝟙 _) (p.app j)
      map := fun j j' φ =>
        equalizer.lift (limits.equalizer.ι (𝟙 _) (p.app j) ≫ F.map φ)
          (by rw [comp_id, assoc, p.naturality φ, ← assoc, ← limits.equalizer.condition, comp_id])
      map_id' := fun j => by
        ext
        simp only [comp_id, Functor.map_id, equalizer.lift_ι, id_comp]
      map_comp' := fun j j' j'' φ φ' => by
        ext
        simp only [assoc, functor.map_comp, equalizer.lift_ι, equalizer.lift_ι_assoc] }
  let i : Y ⟶ F :=
    { app := fun j => equalizer.ι _ _
      naturality' := fun j j' φ => by rw [equalizer.lift_ι] }
  let e : F ⟶ Y :=
    { app := fun j =>
        equalizer.lift (p.app j)
          (by
            rw [comp_id]
            exact (congr_app hp j).symm)
      naturality' := fun j j' φ => by
        ext
        simp only [assoc, equalizer.lift_ι, nat_trans.naturality, equalizer.lift_ι_assoc] }
  use Y, i, e
  constructor <;> ext j
  ·
    simp only [nat_trans.comp_app, assoc, equalizer.lift_ι, nat_trans.id_app, id_comp, ←
      equalizer.condition, comp_id]
  · simp only [nat_trans.comp_app, equalizer.lift_ι]
#align category_theory.idempotents.functor_category_is_idempotent_complete CategoryTheory.Idempotents.functor_category_isIdempotentComplete

namespace KaroubiFunctorCategoryEmbedding

variable {J C}

/-- On objects, the functor which sends a formal direct factor `P` of a
functor `F : J ⥤ C` to the functor `J ⥤ karoubi C` which sends `(j : J)` to
the corresponding direct factor of `F.obj j`. -/
@[simps]
def obj (P : Karoubi (J ⥤ C)) : J ⥤ Karoubi C
    where
  obj j := ⟨P.pt.obj j, P.p.app j, congr_app P.idem j⟩
  map j j' φ :=
    { f := P.p.app j ≫ P.pt.map φ
      comm := by
        simp only [nat_trans.naturality, assoc]
        have h := congr_app P.idem j
        rw [nat_trans.comp_app] at h
        slice_rhs 1 3 => erw [h, h] }
#align category_theory.idempotents.karoubi_functor_category_embedding.obj CategoryTheory.Idempotents.KaroubiFunctorCategoryEmbedding.obj

/-- Tautological action on maps of the functor `karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C)`. -/
@[simps]
def map {P Q : Karoubi (J ⥤ C)} (f : P ⟶ Q) : obj P ⟶ obj Q
    where app j := ⟨f.f.app j, congr_app f.comm j⟩
#align category_theory.idempotents.karoubi_functor_category_embedding.map CategoryTheory.Idempotents.KaroubiFunctorCategoryEmbedding.map

end KaroubiFunctorCategoryEmbedding

variable (J C)

/-- The tautological fully faithful functor `karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C)`. -/
@[simps]
def karoubiFunctorCategoryEmbedding : Karoubi (J ⥤ C) ⥤ J ⥤ Karoubi C
    where
  obj := KaroubiFunctorCategoryEmbedding.obj
  map P Q := KaroubiFunctorCategoryEmbedding.map
#align category_theory.idempotents.karoubi_functor_category_embedding CategoryTheory.Idempotents.karoubiFunctorCategoryEmbedding

instance : Full (karoubiFunctorCategoryEmbedding J C)
    where
  preimage P Q f :=
    { f :=
        { app := fun j => (f.app j).f
          naturality' := fun j j' φ => by
            rw [← karoubi.comp_p_assoc]
            have h := hom_ext.mp (f.naturality φ)
            simp only [comp_f] at h
            dsimp [karoubi_functor_category_embedding] at h
            erw [← h, assoc, ← P.p.naturality_assoc φ, p_comp (f.app j')] }
      comm := by
        ext j
        exact (f.app j).comm }
  witness' P Q f := by
    ext j
    rfl

instance : Faithful (karoubiFunctorCategoryEmbedding J C)
    where map_injective' P Q f f' h := by
    ext j
    exact hom_ext.mp (congr_app h j)

/-- The composition of `(J ⥤ C) ⥤ karoubi (J ⥤ C)` and `karoubi (J ⥤ C) ⥤ (J ⥤ karoubi C)`
equals the functor `(J ⥤ C) ⥤ (J ⥤ karoubi C)` given by the composition with
`to_karoubi C : C ⥤ karoubi C`. -/
theorem toKaroubi_comp_karoubiFunctorCategoryEmbedding :
    toKaroubi _ ⋙ karoubiFunctorCategoryEmbedding J C = (whiskeringRight J _ _).obj (toKaroubi C) :=
  by
  apply Functor.ext
  · intro X Y f
    ext j
    dsimp [to_karoubi]
    simp only [eq_to_hom_app, eq_to_hom_refl, id_comp]
    erw [comp_id]
  · intro X
    apply Functor.ext
    · intro j j' φ
      ext
      dsimp
      simpa only [comp_id, id_comp]
    · intro j
      rfl
#align category_theory.idempotents.to_karoubi_comp_karoubi_functor_category_embedding CategoryTheory.Idempotents.toKaroubi_comp_karoubiFunctorCategoryEmbedding

end Idempotents

end CategoryTheory


import GMLInit.Data.List.Basic

structure ListN (α : Type _) (n : Nat) where
  toList : List α
  length_eq : toList.length = n

namespace ListN

protected theorem eq {α n} : {xs ys : ListN α n} → xs.toList = ys.toList → xs = ys
| ⟨_,_⟩, ⟨_,_⟩, rfl => rfl

protected theorem heq {α β m n} : {xs : ListN α m} → {ys : ListN β n} → α = β → m = n → xs.toList ≅ ys.toList → xs ≅ ys
| ⟨_,_⟩, ⟨_,_⟩, rfl, rfl, HEq.rfl => HEq.rfl

def ofList (xs : List α) : ListN α xs.length := ⟨xs, rfl⟩

@[matchPattern] def nil {α} : ListN α 0 := ⟨[], rfl⟩

@[matchPattern] def cons {α n} (x : α) : ListN α n → ListN α (n+1)
| ⟨xs, hxs⟩ => ⟨x :: xs, congrArgs Nat.succ hxs⟩

def append {α m n} : ListN α m → ListN α n → ListN α (n + m)
| ⟨xs, hxs⟩, ⟨ys, hys⟩ => ⟨xs ++ ys, by rw [List.length_append, Nat.add_comm, hxs, hys]⟩
instance (α m n) : HAppend (ListN α m) (ListN α n) (ListN α (n + m)) := ⟨ListN.append⟩

theorem nil_append {α n} (xs : ListN α n) : append nil xs = xs := rfl

theorem cons_append {α m n} (x : α) (xs : ListN α m) (ys : ListN α n) : append (cons x xs) ys = cons x (append xs ys) := rfl

theorem append_nil {α n} (xs : ListN α n) : append xs nil ≅ xs := by
  cases xs
  apply ListN.heq
  · rfl
  · rw [Nat.zero_add]
  · clean unfold ListN.append
    rw [List.append_nil]
    reflexivity using (.≅.)

theorem append_assoc {α l m n} (xs : ListN α l) (ys : ListN α m) (zs : ListN α n) : append (append xs ys) zs ≅ append xs (append ys zs) := by
  _

#exit
@[scoped simp] theorem append_toList_left (xs : List1 α) (ys : List α) : (xs ++ ys).toList = xs.toList ++ ys :=
  match xs with | cons _ _ => rfl

@[scoped simp] theorem append_toList (xs ys : List1 α) : (xs ++ ys).toList = xs.toList ++ ys.toList :=
  append_toList_left xs (ys.toList)

@[scoped simp] theorem append_nil (xs : List1 α) : append xs [] = xs :=
  match xs with
  | cons x xs => congrArg (cons x) (List.append_nil xs)

theorem append_compat_right (xs : List1 α) (ys zs : List α) : (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
  match xs with
  | cons x xs => congrArg (cons x) (List.append_assoc xs ys zs)

theorem append_compat_left (xs ys : List1 α) (zs : List α) : (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
  match xs with
  | cons x xs => congrArg (cons x) $ by rw [append_toList_left, List.append_assoc]

theorem append_assoc (xs ys zs : List1 α) : xs ++ (ys ++ zs) = (xs ++ ys) ++ zs :=
  match xs with
  | cons x xs => congrArg (cons x) $ by rw [append_toList, List.append_assoc]

abbrev pure (x : α) := cons x []

def map : (α → β) → List1 α → List1 β
| f, cons x xs => cons (f x) (xs.map f)

def bind : List1 α → (α → List1 β) → List1 β
| cons x xs, f => append (f x) (xs.bind (λ x => (f x).toList))

abbrev join (xss : List1 (List1 α)) : List1 α := xss.bind id

end List1


/-
Copyright (c) 2020 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 topology.category.Compactum
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monad.Types
import Mathbin.CategoryTheory.Monad.Limits
import Mathbin.CategoryTheory.Equivalence
import Mathbin.Topology.Category.CompHaus.Basic
import Mathbin.Topology.Category.Profinite.Basic
import Mathbin.Data.Set.Constructions

/-!

# Compacta and Compact Hausdorff Spaces

Recall that, given a monad `M` on `Type*`, an *algebra* for `M` consists of the following data:
- A type `X : Type*`
- A "structure" map `M X → X`.
This data must also satisfy a distributivity and unit axiom, and algebras for `M` form a category
in an evident way.

See the file `category_theory.monad.algebra` for a general version, as well as the following link.
https://ncatlab.org/nlab/show/monad

This file proves the equivalence between the category of *compact Hausdorff topological spaces*
and the category of algebras for the *ultrafilter monad*.

## Notation:

Here are the main objects introduced in this file.
- `Compactum` is the type of compacta, which we define as algebras for the ultrafilter monad.
- `Compactum_to_CompHaus` is the functor `Compactum ⥤ CompHaus`. Here `CompHaus` is the usual
  category of compact Hausdorff spaces.
- `Compactum_to_CompHaus.is_equivalence` is a term of type `is_equivalence Compactum_to_CompHaus`.

The proof of this equivalence is a bit technical. But the idea is quite simply that the structure
map `ultrafilter X → X` for an algebra `X` of the ultrafilter monad should be considered as the map
sending an ultrafilter to its limit in `X`. The topology on `X` is then defined by mimicking the
characterization of open sets in terms of ultrafilters.

Any `X : Compactum` is endowed with a coercion to `Type*`, as well as the following instances:
- `topological_space X`.
- `compact_space X`.
- `t2_space X`.

Any morphism `f : X ⟶ Y` of is endowed with a coercion to a function `X → Y`, which is shown to
be continuous in `continuous_of_hom`.

The function `Compactum.of_topological_space` can be used to construct a `Compactum` from a
topological space which satisfies `compact_space` and `t2_space`.

We also add wrappers around structures which already exist. Here are the main ones, all in the
`Compactum` namespace:

- `forget : Compactum ⥤ Type*` is the forgetful functor, which induces a `concrete_category`
  instance for `Compactum`.
- `free : Type* ⥤ Compactum` is the left adjoint to `forget`, and the adjunction is in `adj`.
- `str : ultrafilter X → X` is the structure map for `X : Compactum`.
  The notation `X.str` is preferred.
- `join : ultrafilter (ultrafilter X) → ultrafilter X` is the monadic join for `X : Compactum`.
  Again, the notation `X.join` is preferred.
- `incl : X → ultrafilter X` is the unit for `X : Compactum`. The notation `X.incl` is preferred.

## References

- E. Manes, Algebraic Theories, Graduate Texts in Mathematics 26, Springer-Verlag, 1976.
- https://ncatlab.org/nlab/show/ultrafilter

-/

universe u

open CategoryTheory Filter Ultrafilter TopologicalSpace CategoryTheory.Limits FiniteInter

open Classical Topology

-- mathport name: exprβ
local notation "β" => ofTypeMonad Ultrafilter

/-- The type `Compactum` of Compacta, defined as algebras for the ultrafilter monad. -/
def Compactum :=
  Monad.Algebra β deriving Category, Inhabited
#align Compactum Compactum

namespace Compactum

/-- The forgetful functor to Type* -/
def forget : Compactum ⥤ Type _ :=
  Monad.forget _ deriving CreatesLimits, Faithful
#align Compactum.forget Compactum.forget

/-- The "free" Compactum functor. -/
def free : Type _ ⥤ Compactum :=
  Monad.free _
#align Compactum.free Compactum.free

/-- The adjunction between `free` and `forget`. -/
def adj : free ⊣ forget :=
  Monad.adj _
#align Compactum.adj Compactum.adj

-- Basic instances
instance : ConcreteCategory Compactum where forget := forget

instance : CoeSort Compactum (Type _) :=
  ⟨forget.obj⟩

instance {X Y : Compactum} : CoeFun (X ⟶ Y) fun f => X → Y :=
  ⟨fun f => f.f⟩

instance : HasLimits Compactum :=
  has_limits_of_has_limits_creates_limits forget

/-- The structure map for a compactum, essentially sending an ultrafilter to its limit. -/
def str (X : Compactum) : Ultrafilter X → X :=
  X.a
#align Compactum.str Compactum.str

/-- The monadic join. -/
def join (X : Compactum) : Ultrafilter (Ultrafilter X) → Ultrafilter X :=
  β.μ.app _
#align Compactum.join Compactum.join

/-- The inclusion of `X` into `ultrafilter X`. -/
def incl (X : Compactum) : X → Ultrafilter X :=
  β.η.app _
#align Compactum.incl Compactum.incl

@[simp]
theorem str_incl (X : Compactum) (x : X) : X.str (X.incl x) = x :=
  by
  change (β.η.app _ ≫ X.a) _ = _
  rw [monad.algebra.unit]
  rfl
#align Compactum.str_incl Compactum.str_incl

@[simp]
theorem str_hom_commute (X Y : Compactum) (f : X ⟶ Y) (xs : Ultrafilter X) :
    f (X.str xs) = Y.str (map f xs) :=
  by
  change (X.a ≫ f.f) _ = _
  rw [← f.h]
  rfl
#align Compactum.str_hom_commute Compactum.str_hom_commute

@[simp]
theorem join_distrib (X : Compactum) (uux : Ultrafilter (Ultrafilter X)) :
    X.str (X.join uux) = X.str (map X.str uux) :=
  by
  change (β.μ.app _ ≫ X.a) _ = _
  rw [monad.algebra.assoc]
  rfl
#align Compactum.join_distrib Compactum.join_distrib

instance {X : Compactum} : TopologicalSpace X
    where
  IsOpen U := ∀ F : Ultrafilter X, X.str F ∈ U → U ∈ F
  isOpen_univ _ _ := Filter.univ_sets _
  isOpen_inter S T h3 h4 h5 h6 := Filter.inter_sets _ (h3 _ h6.1) (h4 _ h6.2)
  isOpen_unionₛ := fun S h1 F ⟨T, hT, h2⟩ =>
    mem_of_superset (h1 T hT _ h2) (Set.subset_unionₛ_of_mem hT)

theorem isClosed_iff {X : Compactum} (S : Set X) :
    IsClosed S ↔ ∀ F : Ultrafilter X, S ∈ F → X.str F ∈ S :=
  by
  rw [← isOpen_compl_iff]
  constructor
  · intro cond F h
    by_contra c
    specialize cond F c
    rw [compl_mem_iff_not_mem] at cond
    contradiction
  · intro h1 F h2
    specialize h1 F
    cases F.mem_or_compl_mem S
    exacts[absurd (h1 h) h2, h]
#align Compactum.is_closed_iff Compactum.isClosed_iff

instance {X : Compactum} : CompactSpace X :=
  by
  constructor
  rw [isCompact_iff_ultrafilter_le_nhds]
  intro F h
  refine' ⟨X.str F, by tauto, _⟩
  rw [le_nhds_iff]
  intro S h1 h2
  exact h2 F h1

/-- A local definition used only in the proofs. -/
private def basic {X : Compactum} (A : Set X) : Set (Ultrafilter X) :=
  { F | A ∈ F }
#align Compactum.basic Compactum.basic

/-- A local definition used only in the proofs. -/
private def cl {X : Compactum} (A : Set X) : Set X :=
  X.str '' basic A
#align Compactum.cl Compactum.cl

private theorem basic_inter {X : Compactum} (A B : Set X) : basic (A ∩ B) = basic A ∩ basic B :=
  by
  ext G
  constructor
  · intro hG
    constructor <;> filter_upwards [hG]with _
    exacts[And.left, And.right]
  · rintro ⟨h1, h2⟩
    exact inter_mem h1 h2
#align Compactum.basic_inter Compactum.basic_inter

private theorem subset_cl {X : Compactum} (A : Set X) : A ⊆ cl A := fun a ha =>
  ⟨X.incl a, ha, by simp⟩
#align Compactum.subset_cl Compactum.subset_cl

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (B C «expr ∈ » C0) -/
private theorem cl_cl {X : Compactum} (A : Set X) : cl (cl A) ⊆ cl A :=
  by
  rintro _ ⟨F, hF, rfl⟩
  -- Notation to be used in this proof.
  let fsu := Finset (Set (Ultrafilter X))
  let ssu := Set (Set (Ultrafilter X))
  let ι : fsu → ssu := coe
  let C0 : ssu := { Z | ∃ B ∈ F, X.str ⁻¹' B = Z }
  let AA := { G : Ultrafilter X | A ∈ G }
  let C1 := insert AA C0
  let C2 := finite_inter_closure C1
  -- C0 is closed under intersections.
  have claim1 : ∀ (B) (_ : B ∈ C0) (C) (_ : C ∈ C0), B ∩ C ∈ C0 :=
    by
    rintro B ⟨Q, hQ, rfl⟩ C ⟨R, hR, rfl⟩
    use Q ∩ R
    simp only [and_true_iff, eq_self_iff_true, Set.preimage_inter, Subtype.val_eq_coe]
    exact inter_sets _ hQ hR
  -- All sets in C0 are nonempty.
  have claim2 : ∀ B ∈ C0, Set.Nonempty B :=
    by
    rintro B ⟨Q, hQ, rfl⟩
    obtain ⟨q⟩ := Filter.nonempty_of_mem hQ
    use X.incl q
    simpa
  -- The intersection of AA with every set in C0 is nonempty.
  have claim3 : ∀ B ∈ C0, (AA ∩ B).Nonempty :=
    by
    rintro B ⟨Q, hQ, rfl⟩
    have : (Q ∩ cl A).Nonempty := Filter.nonempty_of_mem (inter_mem hQ hF)
    rcases this with ⟨q, hq1, P, hq2, hq3⟩
    refine' ⟨P, hq2, _⟩
    rw [← hq3] at hq1
    simpa
  -- Suffices to show that the intersection of any finite subcollection of C1 is nonempty.
  suffices ∀ T : fsu, ι T ⊆ C1 → (⋂₀ ι T).Nonempty
    by
    obtain ⟨G, h1⟩ := exists_ultrafilter_of_finite_inter_nonempty _ this
    use X.join G
    have : G.map X.str = F := Ultrafilter.coe_le_coe.1 fun S hS => h1 (Or.inr ⟨S, hS, rfl⟩)
    rw [join_distrib, this]
    exact ⟨h1 (Or.inl rfl), rfl⟩
  -- C2 is closed under finite intersections (by construction!).
  have claim4 := finite_inter_closure_has_finite_inter C1
  -- C0 is closed under finite intersections by claim1.
  have claim5 : FiniteInter C0 := ⟨⟨_, univ_mem, Set.preimage_univ⟩, claim1⟩
  -- Every element of C2 is nonempty.
  have claim6 : ∀ P ∈ C2, (P : Set (Ultrafilter X)).Nonempty :=
    by
    suffices ∀ P ∈ C2, P ∈ C0 ∨ ∃ Q ∈ C0, P = AA ∩ Q
      by
      intro P hP
      cases this P hP
      · exact claim2 _ h
      · rcases h with ⟨Q, hQ, rfl⟩
        exact claim3 _ hQ
    intro P hP
    exact claim5.finite_inter_closure_insert _ hP
  intro T hT
  -- Suffices to show that the intersection of the T's is contained in C2.
  suffices ⋂₀ ι T ∈ C2 by exact claim6 _ this
  -- Finish
  apply claim4.finite_inter_mem
  intro t ht
  exact finite_inter_closure.basic (@hT t ht)
#align Compactum.cl_cl Compactum.cl_cl

theorem isClosed_cl {X : Compactum} (A : Set X) : IsClosed (cl A) :=
  by
  rw [is_closed_iff]
  intro F hF
  exact cl_cl _ ⟨F, hF, rfl⟩
#align Compactum.is_closed_cl Compactum.isClosed_cl

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (S1 S2 «expr ∈ » T0) -/
theorem str_eq_of_le_nhds {X : Compactum} (F : Ultrafilter X) (x : X) : ↑F ≤ 𝓝 x → X.str F = x :=
  by
  -- Notation to be used in this proof.
  let fsu := Finset (Set (Ultrafilter X))
  let ssu := Set (Set (Ultrafilter X))
  let ι : fsu → ssu := coe
  let T0 : ssu := { S | ∃ A ∈ F, S = basic A }
  let AA := X.str ⁻¹' {x}
  let T1 := insert AA T0
  let T2 := finite_inter_closure T1
  intro cond
  -- If F contains a closed set A, then x is contained in A.
  have claim1 : ∀ A : Set X, IsClosed A → A ∈ F → x ∈ A :=
    by
    intro A hA h
    by_contra H
    rw [le_nhds_iff] at cond
    specialize cond (Aᶜ) H hA.is_open_compl
    rw [Ultrafilter.mem_coe, Ultrafilter.compl_mem_iff_not_mem] at cond
    contradiction
  -- If A ∈ F, then x ∈ cl A.
  have claim2 : ∀ A : Set X, A ∈ F → x ∈ cl A :=
    by
    intro A hA
    exact claim1 (cl A) (is_closed_cl A) (mem_of_superset hA (subset_cl A))
  -- T0 is closed under intersections.
  have claim3 : ∀ (S1) (_ : S1 ∈ T0) (S2) (_ : S2 ∈ T0), S1 ∩ S2 ∈ T0 :=
    by
    rintro S1 ⟨S1, hS1, rfl⟩ S2 ⟨S2, hS2, rfl⟩
    exact ⟨S1 ∩ S2, inter_mem hS1 hS2, by simp [basic_inter]⟩
  -- For every S ∈ T0, the intersection AA ∩ S is nonempty.
  have claim4 : ∀ S ∈ T0, (AA ∩ S).Nonempty :=
    by
    rintro S ⟨S, hS, rfl⟩
    rcases claim2 _ hS with ⟨G, hG, hG2⟩
    exact ⟨G, hG2, hG⟩
  -- Every element of T0 is nonempty.
  have claim5 : ∀ S ∈ T0, Set.Nonempty S :=
    by
    rintro S ⟨S, hS, rfl⟩
    exact ⟨F, hS⟩
  -- Every element of T2 is nonempty.
  have claim6 : ∀ S ∈ T2, Set.Nonempty S :=
    by
    suffices ∀ S ∈ T2, S ∈ T0 ∨ ∃ Q ∈ T0, S = AA ∩ Q
      by
      intro S hS
      cases' this _ hS with h h
      · exact claim5 S h
      · rcases h with ⟨Q, hQ, rfl⟩
        exact claim4 Q hQ
    intro S hS
    apply finite_inter_closure_insert
    · constructor
      · use Set.univ
        refine' ⟨Filter.univ_sets _, _⟩
        ext
        refine' ⟨_, by tauto⟩
        · intro
          apply Filter.univ_sets
      · exact claim3
    · exact hS
  -- It suffices to show that the intersection of any finite subset of T1 is nonempty.
  suffices ∀ F : fsu, ↑F ⊆ T1 → (⋂₀ ι F).Nonempty
    by
    obtain ⟨G, h1⟩ := Ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ this
    have c1 : X.join G = F := Ultrafilter.coe_le_coe.1 fun P hP => h1 (Or.inr ⟨P, hP, rfl⟩)
    have c2 : G.map X.str = X.incl x :=
      by
      refine' Ultrafilter.coe_le_coe.1 fun P hP => _
      apply mem_of_superset (h1 (Or.inl rfl))
      rintro x ⟨rfl⟩
      exact hP
    simp [← c1, c2]
  -- Finish...
  intro T hT
  refine' claim6 _ (finite_inter_mem (finite_inter_closure_has_finite_inter _) _ _)
  intro t ht
  exact finite_inter_closure.basic (@hT t ht)
#align Compactum.str_eq_of_le_nhds Compactum.str_eq_of_le_nhds

theorem le_nhds_of_str_eq {X : Compactum} (F : Ultrafilter X) (x : X) : X.str F = x → ↑F ≤ 𝓝 x :=
  fun h => le_nhds_iff.mpr fun s hx hs => hs _ <| by rwa [h]
#align Compactum.le_nhds_of_str_eq Compactum.le_nhds_of_str_eq

-- All the hard work above boils down to this t2_space instance.
instance {X : Compactum} : T2Space X :=
  by
  rw [t2_iff_ultrafilter]
  intro _ _ F hx hy
  rw [← str_eq_of_le_nhds _ _ hx, ← str_eq_of_le_nhds _ _ hy]

/-- The structure map of a compactum actually computes limits. -/
theorem lim_eq_str {X : Compactum} (F : Ultrafilter X) : F.lim = X.str F :=
  by
  rw [Ultrafilter.lim_eq_iff_le_nhds, le_nhds_iff]
  tauto
#align Compactum.Lim_eq_str Compactum.lim_eq_str

theorem cl_eq_closure {X : Compactum} (A : Set X) : cl A = closure A :=
  by
  ext
  rw [mem_closure_iff_ultrafilter]
  constructor
  · rintro ⟨F, h1, h2⟩
    exact ⟨F, h1, le_nhds_of_str_eq _ _ h2⟩
  · rintro ⟨F, h1, h2⟩
    exact ⟨F, h1, str_eq_of_le_nhds _ _ h2⟩
#align Compactum.cl_eq_closure Compactum.cl_eq_closure

/-- Any morphism of compacta is continuous. -/
theorem continuous_of_hom {X Y : Compactum} (f : X ⟶ Y) : Continuous f :=
  by
  rw [continuous_iff_ultrafilter]
  intro x _ h
  rw [tendsto, ← coe_map]
  apply le_nhds_of_str_eq
  rw [← str_hom_commute, str_eq_of_le_nhds _ x h]
#align Compactum.continuous_of_hom Compactum.continuous_of_hom

/-- Given any compact Hausdorff space, we construct a Compactum. -/
noncomputable def ofTopologicalSpace (X : Type _) [TopologicalSpace X] [CompactSpace X]
    [T2Space X] : Compactum where
  a := X
  a := Ultrafilter.lim
  unit' := by
    ext x
    exact lim_eq (pure_le_nhds _)
  assoc' := by
    ext FF
    change Ultrafilter (Ultrafilter X) at FF
    set x := (Ultrafilter.map Ultrafilter.lim FF).lim with c1
    have c2 : ∀ (U : Set X) (F : Ultrafilter X), F.lim ∈ U → IsOpen U → U ∈ F :=
      by
      intro U F h1 hU
      exact c1 ▸ is_open_iff_ultrafilter.mp hU _ h1 _ (Ultrafilter.le_nhds_lim _)
    have c3 : ↑(Ultrafilter.map Ultrafilter.lim FF) ≤ 𝓝 x :=
      by
      rw [le_nhds_iff]
      intro U hx hU
      exact mem_coe.2 (c2 _ _ (by rwa [← c1]) hU)
    have c4 : ∀ U : Set X, x ∈ U → IsOpen U → { G : Ultrafilter X | U ∈ G } ∈ FF :=
      by
      intro U hx hU
      suffices Ultrafilter.lim ⁻¹' U ∈ FF
        by
        apply mem_of_superset this
        intro P hP
        exact c2 U P hP hU
      exact @c3 U (IsOpen.mem_nhds hU hx)
    apply lim_eq
    rw [le_nhds_iff]
    exact c4
#align Compactum.of_topological_space Compactum.ofTopologicalSpace

/-- Any continuous map between Compacta is a morphism of compacta. -/
def homOfContinuous {X Y : Compactum} (f : X → Y) (cont : Continuous f) : X ⟶ Y :=
  { f
    h' := by
      rw [continuous_iff_ultrafilter] at cont
      ext (F : Ultrafilter X)
      specialize cont (X.str F) F (le_nhds_of_str_eq F (X.str F) rfl)
      have := str_eq_of_le_nhds (Ultrafilter.map f F) _ cont
      simpa only [← this, types_comp_apply, of_type_functor_map] }
#align Compactum.hom_of_continuous Compactum.homOfContinuous

end Compactum

/-- The functor functor from Compactum to CompHaus. -/
def compactumToCompHaus : Compactum ⥤ CompHaus
    where
  obj X := { toTop := { α := X } }
  map X Y f :=
    { toFun := f
      continuous_toFun := Compactum.continuous_of_hom _ }
#align Compactum_to_CompHaus compactumToCompHaus

namespace compactumToCompHaus

/-- The functor Compactum_to_CompHaus is full. -/
def full : Full compactumToCompHaus.{u} where preimage X Y f := Compactum.homOfContinuous f.1 f.2
#align Compactum_to_CompHaus.full compactumToCompHaus.full

/-- The functor Compactum_to_CompHaus is faithful. -/
theorem faithful : Faithful compactumToCompHaus :=
  { }
#align Compactum_to_CompHaus.faithful compactumToCompHaus.faithful

/-- This definition is used to prove essential surjectivity of Compactum_to_CompHaus. -/
def isoOfTopologicalSpace {D : CompHaus} :
    compactumToCompHaus.obj (Compactum.ofTopologicalSpace D) ≅ D
    where
  Hom :=
    { toFun := id
      continuous_toFun :=
        continuous_def.2 fun _ h => by
          rw [isOpen_iff_ultrafilter'] at h
          exact h }
  inv :=
    { toFun := id
      continuous_toFun :=
        continuous_def.2 fun _ h1 => by
          rw [isOpen_iff_ultrafilter']
          intro _ h2
          exact h1 _ h2 }
#align Compactum_to_CompHaus.iso_of_topological_space compactumToCompHaus.isoOfTopologicalSpace

/-- The functor Compactum_to_CompHaus is essentially surjective. -/
theorem essSurj : EssSurj compactumToCompHaus :=
  { mem_essImage := fun X => ⟨Compactum.ofTopologicalSpace X, ⟨isoOfTopologicalSpace⟩⟩ }
#align Compactum_to_CompHaus.ess_surj compactumToCompHaus.essSurj

/-- The functor Compactum_to_CompHaus is an equivalence of categories. -/
noncomputable instance isEquivalence : IsEquivalence compactumToCompHaus :=
  by
  apply equivalence.of_fully_faithfully_ess_surj _
  exact compactumToCompHaus.full
  exact compactumToCompHaus.faithful
  exact compactumToCompHaus.essSurj
#align Compactum_to_CompHaus.is_equivalence compactumToCompHaus.isEquivalence

end compactumToCompHaus

/-- The forgetful functors of `Compactum` and `CompHaus` are compatible via
`Compactum_to_CompHaus`. -/
def compactumToCompHausCompForget :
    compactumToCompHaus ⋙ CategoryTheory.forget CompHaus ≅ Compactum.forget :=
  (NatIso.ofComponents fun X => eqToIso rfl) <|
    by
    intro X Y f
    dsimp
    simpa
#align Compactum_to_CompHaus_comp_forget compactumToCompHausCompForget

/-
TODO: `forget CompHaus` is monadic, as it is isomorphic to the composition
of an equivalence with the monadic functor `forget Compactum`.
Once we have the API to transfer monadicity of functors along such isomorphisms,
the instance `creates_limits (forget CompHaus)` can be deduced from this
monadicity.
-/
noncomputable instance CompHaus.forgetCreatesLimits : CreatesLimits (forget CompHaus) :=
  by
  let e : forget CompHaus ≅ Compactum_to_CompHaus.inv ⋙ Compactum.forget :=
    _ ≪≫ iso_whisker_left _ compactumToCompHausCompForget
  swap
  refine' _ ≪≫ functor.associator _ _ _
  refine' (functor.left_unitor _).symm ≪≫ _
  refine' iso_whisker_right _ _
  exact Compactum_to_CompHaus.as_equivalence.symm.unit_iso
  exact creates_limits_of_nat_iso e.symm
#align CompHaus.forget_creates_limits CompHaus.forgetCreatesLimits

noncomputable instance Profinite.forgetCreatesLimits : CreatesLimits (forget Profinite) :=
  by
  change creates_limits (profiniteToCompHaus ⋙ forget _)
  infer_instance
#align Profinite.forget_creates_limits Profinite.forgetCreatesLimits


import .sia

namespace sia
section
    parameters {R : Type} [sia R]
    variables {a b c : R}

    @[reducible] private def Delta := Delta R
    @[reducible] private def DeltaT := subtype Delta

    -- Useful properties of Delta
    lemma neg_delta : forall d: DeltaT, Delta (-d.val) :=
        assume d, calc -d.val * -d.val
            = d.val * d.val : by rw [neg_mul_neg]
        ... = 0 : d.property
    instance : has_neg DeltaT := { neg := fun d : DeltaT, { val := -d.val, property := neg_delta d } }

    lemma mul_delta : forall d: DeltaT, forall a: R, Delta (d.val * a) :=
        assume d,
        assume a,
        have d.val * d.val = 0, from d.property,
        show (d.val * a) * (d.val * a) = 0, from calc
            (d.val * a) * (d.val * a)
                = d.val * d.val * a * a : by simp
            ... = 0 * a * a             : by rw this
            ... = 0                     : by simp [zero_mul]
    instance : has_mul DeltaT := { mul := fun d e : DeltaT, { val := d.val * e.val, property := mul_delta d e.val } }

    -- Other theorems
    theorem microaffinity : forall f: R -> R, forall x: R, exists! a: R, forall d: DeltaT, f (x + d.val) = f x + a * d.val :=
        assume f: R -> R,
        assume x: R,
        let g (d: DeltaT) : R := f (x + d.val) in
        have nice: f x = g 0, from eq.symm (eq.subst (add_group.add_zero x) (eq.refl _)),
        by {rewrite nice, apply kock_lawvere}

    theorem delta_near_zero : forall d: DeltaT, 0 <= d.val /\ d.val <= 0 :=
        assume d,
        have left: not (d.val < 0), from
            assume bad,
            have 0 < -d.val, by {rw <-neg_zero, apply st_ordered_field.lt_neg_flip bad},
            have 0 < d.val * d.val, by {rw <-neg_mul_neg, rw <-mul_zero, apply st_ordered_field.lt_mul_pos_left this, assumption},
            absurd d.property (ne.symm (st_order.lt_ne this)),
        have right: not (0 < d.val), from
            assume bad,
            have 0 < d.val * d.val, by {rw <-mul_zero, apply st_ordered_field.lt_mul_pos_left bad bad},
            absurd d.property (ne.symm (st_order.lt_ne this)),
        and.intro left right

    section -- Theorem 1.1
        theorem delta_in_zero_interval : set.subset Delta [[(0: R) ... 0]] :=
            assume a,
            assume a_in_Delta,
            delta_near_zero { val := a, property := a_in_Delta }

        @[reducible]
        def degenerate (S : set R) : Prop := forall x y : subtype S, x.val = y.val

        theorem delta_nondegenerate : not (degenerate Delta) :=
            assume deg,
            have d_eq_zero: forall y: DeltaT, (0: R) = y.val, from deg 0,
            let f := fun r: R, r in
            have bad: exists! a: R, forall d: DeltaT, 0 + d.val = 0 + a * d.val, from microaffinity f 0,
            have pf_zero: forall d: DeltaT, 0 + d.val = 0 + 0 * d.val, from
                assume d,
                calc
                    0 + d.val = d.val + 0 * d.val : by simp
                    ...       = 0 + 0 * d.val     : by rw d_eq_zero d,
            have pf_one: forall d: DeltaT, 0 + d.val = 0 + 1 * d.val, by simp,
            have (0: R) = 1, from unique_of_exists_unique bad pf_zero pf_one,
            absurd this (st_order.lt_ne (st_ordered_field.lt_zero_one R))

        theorem delta_indistinguishable_zero : forall d: DeltaT, not (not (d.val = 0)) :=
            assume d,
            assume bad: d.val != 0,
            have d.val < 0 \/ 0 < d.val, from st_order.ne_lt bad,
            have left: not (d.val < 0), from and.elim_left (delta_near_zero d),
            have right: not (0 < d.val), from and.elim_right (delta_near_zero d),
            or.elim this left right

        theorem not_lem_eq_delta_zero : not (forall d: DeltaT, d.val = 0 \/ d.val != 0) :=
            assume bad,
            have forall d: DeltaT, d.val = 0, from
                assume d,
                or.resolve_right (bad d) (delta_indistinguishable_zero d),
            have forall x y: DeltaT, x.val = y.val, from
                assume x y,
                eq.trans (this x) (eq.symm (this y)),
            delta_nondegenerate this

        theorem microcancellation : forall {a b: R}, (forall d: DeltaT, a * d.val = b * d.val) -> a = b :=
            assume a b,
            assume ea_eq_eb : forall d: DeltaT, a * d.val = b * d.val,
            let f (d : DeltaT) : R := a * d.val in
            begin
                apply (unique_of_exists_unique (kock_lawvere f)),
                show forall d, f d = a * 0 + a * d.val,
                    simp,
                show forall d, f d = a * 0 + b * d.val,
                    simp,
                    show forall d, f d = b * d.val,
                    intro d,
                    apply eq.trans (ea_eq_eb d),
                    reflexivity,
            end
    end
end
end sia


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

! This file was ported from Lean 3 source module data.prod.tprod
! leanprover-community/mathlib commit c227d107bbada5d0d9d20287e3282c0a7f1651a0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Nodup
/-!
# Finite products of types

This file defines the product of types over a list. For `l : List ι` and `α : ι → Type v` we define
`List.TProd α l = l.foldr (λ i β, α i × β) PUnit`.
This type should not be used if `∀ i, α i` or `∀ i ∈ l, α i` can be used instead
(in the last expression, we could also replace the list `l` by a set or a finset).
This type is used as an intermediary between binary products and finitary products.
The application of this type is finitary product measures, but it could be used in any
construction/theorem that is easier to define/prove on binary products than on finitary products.

* Once we have the construction on binary products (like binary product measures in
  `MeasureTheory.prod`), we can easily define a finitary version on the type `TProd l α`
  by iterating. Properties can also be easily extended from the binary case to the finitary case
  by iterating.
* Then we can use the equivalence `List.TProd.piEquivTProd` below (or enhanced versions of it,
  like a `MeasurableEquiv` for product measures) to get the construction on `∀ i : ι, α i`, at
  least when assuming `[Fintype ι] [Encodable ι]` (using `Encodable.sortedUniv`).
  Using `local attribute [instance] Fintype.toEncodable` we can get rid of the argument
  `[Encodable ι]`.

## Main definitions

* We have the equivalence `TProd.piEquivTProd : (∀ i, α i) ≃ TProd α l`
  if `l` contains every element of `ι` exactly once.
* The product of sets is `Set.tprod : (∀ i, Set (α i)) → Set (TProd α l)`.
-/

open List Function
universe u v
variable {ι : Type u} {α : ι → Type v} {i j : ι} {l : List ι} {f : ∀ i, α i}

namespace List

variable (α)

/-- The product of a family of types over a list. -/
def TProd (l : List ι) : Type v :=
  l.foldr (fun i β => α i × β) PUnit
#align list.tprod List.TProd

variable {α}

namespace TProd

open List

/-- Turning a function `f : ∀ i, α i` into an element of the iterated product `TProd α l`. -/
protected def mk : ∀ (l : List ι) (_f : ∀ i, α i), TProd α l
  | [] => fun _ => PUnit.unit
  | i :: is => fun f => (f i, TProd.mk is f)
#align list.tprod.mk List.TProd.mk

instance [∀ i, Inhabited (α i)] : Inhabited (TProd α l) :=
  ⟨TProd.mk l default⟩

@[simp]
theorem fst_mk (i : ι) (l : List ι) (f : ∀ i, α i) : (TProd.mk (i :: l) f).1 = f i :=
  rfl
#align list.tprod.fst_mk List.TProd.fst_mk

@[simp]
theorem snd_mk (i : ι) (l : List ι) (f : ∀ i, α i) :
    (TProd.mk.{u,v} (i :: l) f).2 = TProd.mk.{u,v} l f :=
  rfl
#align list.tprod.snd_mk List.TProd.snd_mk

variable [DecidableEq ι]

/-- Given an element of the iterated product `l.Prod α`, take a projection into direction `i`.
  If `i` appears multiple times in `l`, this chooses the first component in direction `i`. -/
protected def elim : ∀ {l : List ι} (_ : TProd α l) {i : ι} (_ : i ∈ l), α i
  | i :: is, v, j, hj =>
    if hji : j = i then by
      subst hji
      exact v.1
    else TProd.elim v.2 ((List.mem_cons.mp hj).resolve_left hji)
#align list.tprod.elim List.TProd.elim

@[simp]
theorem elim_self (v : TProd α (i :: l)) : v.elim (l.mem_cons_self i) = v.1 := by simp [TProd.elim]
#align list.tprod.elim_self List.TProd.elim_self

@[simp]
theorem elim_of_ne (hj : j ∈ i :: l) (hji : j ≠ i) (v : TProd α (i :: l)) :
    v.elim hj = TProd.elim v.2 ((List.mem_cons.mp hj).resolve_left hji) := by simp [TProd.elim, hji]
#align list.tprod.elim_of_ne List.TProd.elim_of_ne

@[simp]
theorem elim_of_mem (hl : (i :: l).Nodup) (hj : j ∈ l) (v : TProd α (i :: l)) :
    v.elim (mem_cons_of_mem _ hj) = TProd.elim v.2 hj :=
  by
  apply elim_of_ne
  rintro rfl
  exact hl.not_mem hj
#align list.tprod.elim_of_mem List.TProd.elim_of_mem

theorem elim_mk : ∀ (l : List ι) (f : ∀ i, α i) {i : ι} (hi : i ∈ l), (TProd.mk l f).elim hi = f i
  | i :: is, f, j, hj => by
    by_cases hji : j = i
    · subst hji
      simp
    · rw [TProd.elim_of_ne _ hji, snd_mk, elim_mk is]
    termination_by elim_mk l f j hj => l.length
#align list.tprod.elim_mk List.TProd.elim_mk

@[ext]
theorem ext :
    ∀ {l : List ι} (_ : l.Nodup) {v w : TProd α l}
      (_ : ∀ (i) (hi : i ∈ l), v.elim hi = w.elim hi), v = w
  | [], _, v, w, _ => PUnit.ext v w
  | i :: is, hl, v, w, hvw => by
    apply Prod.ext; rw [← elim_self v, hvw, elim_self]
    refine' ext (nodup_cons.mp hl).2 fun j hj => _
    rw [← elim_of_mem hl, hvw, elim_of_mem hl]
#align list.tprod.ext List.TProd.ext

/-- A version of `TProd.elim` when `l` contains all elements. In this case we get a function into
  `Π i, α i`. -/
@[simp]
protected def elim' (h : ∀ i, i ∈ l) (v : TProd α l) (i : ι) : α i :=
  v.elim (h i)
#align list.tprod.elim' List.TProd.elim'

theorem mk_elim (hnd : l.Nodup) (h : ∀ i, i ∈ l) (v : TProd α l) : TProd.mk l (v.elim' h) = v :=
  TProd.ext hnd fun i hi => by simp [elim_mk]
#align list.tprod.mk_elim List.TProd.mk_elim

/-- Pi-types are equivalent to iterated products. -/
def piEquivTProd (hnd : l.Nodup) (h : ∀ i, i ∈ l) : (∀ i, α i) ≃ TProd α l :=
  ⟨TProd.mk l, TProd.elim' h, fun f => funext fun i => elim_mk l f (h i), mk_elim hnd h⟩
#align list.tprod.pi_equiv_tprod List.TProd.piEquivTProd

end TProd

end List

namespace Set

open List

/-- A product of sets in `TProd α l`. -/
@[simp]
protected def tprod : ∀ (l : List ι) (_t : ∀ i, Set (α i)), Set (TProd α l)
  | [], _ => univ
  | i :: is, t => t i ×ˢ Set.tprod is t
#align set.tprod Set.tprod

theorem mk_preimage_tprod :
    ∀ (l : List ι) (t : ∀ i, Set (α i)), TProd.mk l ⁻¹' Set.tprod l t = { i | i ∈ l }.pi t
  | [], t => by simp [Set.tprod]
  | i :: l, t => by
    ext f
    have h : TProd.mk l f ∈ Set.tprod l t ↔ ∀ i : ι, i ∈ l → f i ∈ t i := by
      change f ∈ TProd.mk l ⁻¹' Set.tprod l t ↔ f ∈ { x | x ∈ l }.pi t
      rw [mk_preimage_tprod l t]

    -- `simp [Set.TProd, TProd.mk, this]` can close this goal but is slow.
    rw [Set.tprod, TProd.mk, mem_preimage, mem_pi, prod_mk_mem_set_prod_eq]
    simp_rw [mem_setOf_eq, mem_cons]
    rw [forall_eq_or_imp, and_congr_right_iff]
    exact fun _ => h
#align set.mk_preimage_tprod Set.mk_preimage_tprod

theorem elim_preimage_pi [DecidableEq ι] {l : List ι} (hnd : l.Nodup) (h : ∀ i, i ∈ l)
    (t : ∀ i, Set (α i)) : TProd.elim' h ⁻¹' pi univ t = Set.tprod l t :=
  by
  have h2 : { i | i ∈ l } = univ := by
    ext i
    simp [h]
  rw [← h2, ← mk_preimage_tprod, preimage_preimage]
  simp only [TProd.mk_elim hnd h]
  dsimp; rfl
#align set.elim_preimage_pi Set.elim_preimage_pi

end Set