import cl
import for_mathlib.projective_space.affine_embedding
import for_mathlib.finite_dimensional
import data.zmod.algebra

noncomputable theory
open_locale tensor_product
open_locale classical

open module

variables {K F : Type*} [field K] [field F]

class is_prime_field (F : Type*) [field F] :=
(cond [] : ∀ a : F, ∃ (m : ℤ) (n : ℕ) (hn : (n : F) ≠ 0), a = m/n)

lemma eq_zero_or_one_of_is_prime_field_of_two (F : Type*) [field F]
  [is_prime_field F] (htwo : (2 : F) = 0) (a : F) :
  a = 0 ∨ a = 1 :=
begin
  obtain ⟨m,n,hnz,rfl⟩ := is_prime_field.cond a,
  have : (2 : ℤ) * (m / 2) + (m % 2) = m := int.div_add_mod m 2,
  rw ← this,
  field_simp,
  have : 2 * (n/2) + (n % 2) = n := nat.div_add_mod n 2,
  rw ← this at ⊢ hnz,
  push_cast at hnz, simp [(show (1 : F) + 1 = 2, by ring), htwo] at hnz,
  push_cast, simp [htwo, (show (1 : F) + 1 = 2, by ring)],
  cases int.mod_two_eq_zero_or_one m with hm hm;
  cases nat.mod_two_eq_zero_or_one n with hn hn;
  simp [hn,hm],
  apply hnz,
  rw hn, push_cast,
end

instance : is_prime_field ℚ :=
begin
  constructor, intros a,
  rcases a with ⟨m,n,h1,h2⟩,
  refine ⟨m,n,_,_⟩,
  { intro c, norm_cast at c, rw c at h1, exact nat.lt_asymm h1 h1 },
  { norm_cast, exact rat.num_denom', }
end

instance (p : ℕ) [fact (nat.prime p)] : is_prime_field (zmod p) :=
begin
  constructor, intros a,
  refine ⟨a.val, 1, _, _⟩,
  { push_cast, simp },
  { simp },
end

namespace bridge

structure setup
  (H : submodule F (mul_base_change K F))
  (hH : (H.dual_annihilator : submodule F _).acl) :=
(u v : Kˣ)
(hu : u.as ∉ H) (hv : v.as ∉ H)
(hu₁ : ∀ y : Kˣ, (y : K) = 1 + u → y.as ∉ H)
(hu₂ : ∀ y : Kˣ, (y : K) = 1 + u → (u⁻¹ * y).as ∉ H)
(hv₁: ∀ y : Kˣ, (y : K) = 1 + v → y.as ∉ H)
(hv₂ : ∀ y : Kˣ, (y : K) = 1 + v → (v⁻¹ * y).as ∉ H)
(li : linear_independent F ![H.mkq u.as, H.mkq v.as])

namespace setup

variables
  {H : submodule F (mul_base_change K F)}
  {hH : H.dual_annihilator.acl}
  (S : setup H hH)

def e := ![H.mkq S.u.as, H.mkq S.v.as]

include S
lemma mkq_neg_one : H.mkq (-1 : Kˣ).as = 0 :=
begin
  simp,
  have := hH.neg_one,
  rw ← H.dual_annihilator_dual_annihilator_comap,
  rw submodule.mem_dual_annihilator_comap_iff,
  exact this,
end

lemma mkq_neg (u : Kˣ) : H.mkq (-u).as = H.mkq u.as :=
begin
  have : -u = (-1) * u, by simp only [neg_mul, one_mul],
  simp only [this, units.as_mul, linear_map.map_add, S.mkq_neg_one, zero_add],
end

lemma exists_of_one_add_u (y : Kˣ) (hy : (y : K) = 1 + S.u) :
  ∃ (a : F) (ha0 : a ≠ 0) (ha1 : a ≠ 1),
  H.mkq y.as = a • H.mkq S.u.as :=
begin
  have := submodule.dependent_of_acl _ hH (-S.u) y _,
  swap, { push_cast, rwa [neg_add_eq_iff_eq_add, add_comm] },
  rw fintype.not_linear_independent_iff at this,
  obtain ⟨g,h1,i,h2⟩ := this,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero,
    fintype.univ_of_subsingleton,
    fin.mk_zero, matrix.cons_val_succ, finset.sum_singleton,
    fin.succ_zero_eq_one] at h1,
  apply_fun H.quotient_dual_dual_equiv at h1,
  simp only [linear_equiv.map_add,
    linear_equiv.map_smul, linear_equiv.map_zero,
    H.quotient_dual_dual_equiv_apply, S.mkq_neg] at h1,
  have hg1 : g 1 ≠ 0,
  { intro c,
    fin_cases i, swap, { contradiction },
    simp only [c, zero_smul, add_zero, zero_add, smul_eq_zero] at h1,
    cases h1, { contradiction },
    simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero] at h1,
    exact S.hu h1 },
  have hg0 : g 0 ≠ 0,
  { intro c,
    fin_cases i, { contradiction },
    simp only [c, zero_smul, add_zero, zero_add, smul_eq_zero] at h1,
    cases h1, { contradiction },
    simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero] at h1,
    exact S.hu₁ y hy h1 },
  use (- g 0 / g 1),
  refine ⟨_,_,_⟩,
  { field_simp, assumption },
  { field_simp,
    intro c, rw ← c at h1,
    simp only [neg_smul, ← sub_eq_add_neg, ← smul_sub, smul_eq_zero] at h1,
    cases h1, { contradiction },
    rw [sub_eq_zero] at h1, replace h1 := h1.symm,
    rw ← sub_eq_zero at h1,
    rw [← H.mkq.map_sub, submodule.mkq_apply,
      submodule.quotient.mk_eq_zero, ← units.as_div] at h1,
    apply S.hu₂ y hy, convert h1 using 2,
    rw [mul_comm, div_eq_mul_inv] },
  { apply_fun (λ e, (g 1)⁻¹ • e) at h1,
    simp only [smul_add, smul_zero, ← mul_smul, inv_mul_cancel hg1,
      one_smul, add_eq_zero_iff_neg_eq, ← neg_smul] at h1,
    convert h1.symm using 3, field_simp },
end

lemma exists_of_one_add_v (y : Kˣ) (hy : (y : K) = 1 + S.v) :
  ∃ (b : F) (hb0 : b ≠ 0) (ha1 : b ≠ 1),
  H.mkq y.as = b • H.mkq S.v.as :=
begin
  have := submodule.dependent_of_acl _ hH (-S.v) y _,
  swap, { push_cast, rwa [neg_add_eq_iff_eq_add, add_comm] },
  rw fintype.not_linear_independent_iff at this,
  obtain ⟨g,h1,i,h2⟩ := this,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero,
    fintype.univ_of_subsingleton,
    fin.mk_zero, matrix.cons_val_succ, finset.sum_singleton,
    fin.succ_zero_eq_one] at h1,
  apply_fun H.quotient_dual_dual_equiv at h1,
  simp only [linear_equiv.map_add,
    linear_equiv.map_smul, linear_equiv.map_zero,
    H.quotient_dual_dual_equiv_apply, S.mkq_neg] at h1,
  have hg1 : g 1 ≠ 0,
  { intro c,
    fin_cases i, swap, { contradiction },
    simp only [c, zero_smul, add_zero, zero_add, smul_eq_zero] at h1,
    cases h1, { contradiction },
    simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero] at h1,
    exact S.hv h1 },
  have hg0 : g 0 ≠ 0,
  { intro c,
    fin_cases i, { contradiction },
    simp only [c, zero_smul, add_zero, zero_add, smul_eq_zero] at h1,
    cases h1, { contradiction },
    simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero] at h1,
    exact S.hv₁ y hy h1 },
  use (- g 0 / g 1),
  refine ⟨_,_,_⟩,
  { field_simp, assumption },
  { field_simp,
    intro c, rw ← c at h1,
    simp only [neg_smul, ← sub_eq_add_neg, ← smul_sub, smul_eq_zero] at h1,
    cases h1, { contradiction },
    rw [sub_eq_zero] at h1, replace h1 := h1.symm,
    rw ← sub_eq_zero at h1,
    rw [← H.mkq.map_sub, submodule.mkq_apply,
      submodule.quotient.mk_eq_zero, ← units.as_div] at h1,
    apply S.hv₂ y hy, convert h1 using 2,
    rw [mul_comm, div_eq_mul_inv] },
  { apply_fun (λ e, (g 1)⁻¹ • e) at h1,
    simp only [smul_add, smul_zero, ← mul_smul, inv_mul_cancel hg1,
      one_smul, add_eq_zero_iff_neg_eq, ← neg_smul] at h1,
    convert h1.symm using 3, field_simp },
end

def basis := basis.sum_extend S.li
def f : dual F (mul_base_change K F ⧸ H) := S.basis.coord (sum.inl 0)
def g : dual F (mul_base_change K F ⧸ H) := S.basis.coord (sum.inl 1)

@[simp] lemma f_map_u : S.f (H.mkq S.u.as) = 1 :=
begin
  change S.f (S.e 0) = 1,
  dsimp only [f,e],
  rw ← basis.sum_extend_extends _ S.li 0,
  dsimp [basis],
  simp only [basis.repr_self, finsupp.single_apply, if_pos rfl],
end

@[simp] lemma f_map_v : S.f (H.mkq S.v.as) = 0 :=
begin
  change S.f (S.e 1) = 0,
  dsimp only [f,e],
  rw ← basis.sum_extend_extends _ S.li 1,
  dsimp [basis],
  simp only [basis.repr_self, finsupp.single_apply],
  rw if_neg, norm_num
end

@[simp] lemma g_map_u : S.g (H.mkq S.u.as) = 0 :=
begin
  change S.g (S.e 0) = 0,
  dsimp only [g,e],
  rw ← basis.sum_extend_extends _ S.li 0,
  dsimp [basis],
  simp only [basis.repr_self, finsupp.single_apply],
  rw if_neg, norm_num
end

@[simp] lemma g_map_v : S.g (H.mkq S.v.as) = 1 :=
begin
  change S.g (S.e 1) = 1,
  dsimp only [g,e],
  rw ← basis.sum_extend_extends _ S.li 1,
  dsimp [basis],
  simp only [basis.repr_self, finsupp.single_apply, if_pos rfl],
end

def ψₗ : (mul_base_change K F ⧸ H) →ₗ[F] (F × F) :=
{ to_fun := λ t, (S.f t, S.g t),
  map_add' := λ x y, by ext; simp,
  map_smul' := λ c x, by ext; simp }

.

def ψₗ' : (mul_base_change K F) →ₗ[F] (F × F) := S.ψₗ.comp H.mkq

def ψ : Kˣ → F × F := λ x, S.ψₗ (H.mkq x.as)

lemma ψ_apply' (x : Kˣ) : S.ψ x = S.ψₗ' x.as := rfl
lemma ψ_apply (x : Kˣ) : S.ψ x = S.ψₗ (H.mkq x.as) := rfl

@[simp]
lemma ψ_map_mul (x y : Kˣ) : S.ψ (x * y) = S.ψ x + S.ψ y :=
by simp only [S.ψ_apply', units.as_mul, linear_map.map_add]

@[simp]
lemma ψ_map_one : S.ψ 1 = 0 :=
by simp only [S.ψ_apply', units.as_one, linear_map.map_zero]

@[simp]
lemma ψ_map_inv (x : Kˣ) : S.ψ x⁻¹ = - S.ψ x :=
by simp only [S.ψ_apply', units.as_inv, linear_map.map_neg]

@[simp]
lemma ψ_map_neg_one : S.ψ (-1 : Kˣ) = 0 :=
begin
  have := submodule.neg_one_mem_of_acl _ hH,
  rw S.ψ_apply, rw submodule.dual_annihilator_dual_annihilator_comap at this,
  have : H.mkq (-1 : Kˣ).as = 0,
    simpa only [submodule.mkq_apply, submodule.quotient.mk_eq_zero],
  simp [this]
end

@[simp]
lemma ψ_map_neg (x : Kˣ) : S.ψ (-x) = S.ψ x :=
begin
  rw neg_eq_neg_one_mul,
  simp only [S.ψ_map_mul, S.ψ_map_neg_one, zero_add],
end

lemma ψ_dep (x y : Kˣ) (hxy : (x : K) + y = 1) :
  ¬ linear_independent F ![S.ψ x, S.ψ y] :=
begin
  have h := submodule.dependent_of_acl _ hH x y hxy,
  simp only [fintype.not_linear_independent_iff] at h ⊢,
  obtain ⟨g,h1,h2⟩ := h,
  refine ⟨g,_,h2⟩,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero, fintype.univ_of_subsingleton,
    fin.mk_zero, matrix.cons_val_succ, finset.sum_singleton,
    fin.succ_zero_eq_one] at h1 ⊢,
  simp only [S.ψ_apply, ← linear_map.map_smul, ← linear_map.map_add] at
    h1 ⊢,
  have : (H.mkq) (g 0 • x.as + g 1 • y.as) = 0,
  { simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero] at h1 ⊢,
    rwa [submodule.dual_annihilator_dual_annihilator_comap] at h1 },
  simp [this]
end

lemma ψ_dep' (x y : Kˣ) (hxy : (x : K) - y = 1) :
  ¬ linear_independent F ![S.ψ x, S.ψ y] :=
begin
  have h := submodule.dependent_of_acl _ hH x (-y) _,
  rw ← S.ψ_map_neg y,
  simp only [fintype.not_linear_independent_iff] at h ⊢,
  obtain ⟨g,h1,h2⟩ := h,
  refine ⟨g,_,h2⟩,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero, fintype.univ_of_subsingleton,
    fin.mk_zero, matrix.cons_val_succ, finset.sum_singleton,
    fin.succ_zero_eq_one] at h1 ⊢,
  simp only [S.ψ_apply, ← linear_map.map_smul, ← linear_map.map_add] at
    h1 ⊢,
  have : (H.mkq) (g 0 • x.as + g 1 • (-y).as) = 0,
  { simp only [submodule.mkq_apply, submodule.quotient.mk_eq_zero] at h1 ⊢,
    rwa [submodule.dual_annihilator_dual_annihilator_comap] at h1 },
  simp [this],
  convert hxy, push_cast, ring,
end

@[simp]
lemma ψ_map_u :
  S.ψ S.u = (1,0) :=
begin
  ext, exact S.f_map_u, exact S.g_map_u,
end

@[simp]
lemma ψ_map_v :
  S.ψ S.v = (0,1) :=
begin
  ext, exact S.f_map_v, exact S.g_map_v,
end

lemma one_add_u_ne_zero : (1 : K) + S.u ≠ 0 :=
begin
  intro c, rw add_eq_zero_iff_neg_eq at c,
  have hh : (-1 : Kˣ) = S.u, ext, exact c,
  have := S.ψ_map_u, rw [← hh, S.ψ_map_neg_one] at this,
  apply (zero_ne_one : ((0 : F) ≠ 1)),
  exact congr_arg prod.fst this
end

lemma one_sub_u_ne_zero : (1 : K) - S.u ≠ 0 :=
begin
  intro c, rw sub_eq_zero at c, have hh : S.u = 1, by { ext, exact c.symm },
  have := S.ψ_map_u, rw [hh, S.ψ_map_one] at this,
  apply (zero_ne_one : (0 : F) ≠ 1),
  exact congr_arg prod.fst this
end

lemma one_add_v_ne_zero : (1 : K) + S.v ≠ 0 :=
begin
  intro c, rw add_eq_zero_iff_neg_eq at c,
  have hh : (-1 : Kˣ) = S.v, ext, exact c,
  have := S.ψ_map_v, rw [← hh, S.ψ_map_neg_one] at this,
  apply (zero_ne_one : ((0 : F) ≠ 1)),
  exact congr_arg prod.snd this
end

lemma one_sub_v_ne_zero : (1 : K) - S.v ≠ 0 :=
begin
  intro c, rw sub_eq_zero at c, have hh : S.v = 1, by { ext, exact c.symm },
  have := S.ψ_map_v, rw [hh, S.ψ_map_one] at this,
  apply (zero_ne_one : (0 : F) ≠ 1),
  exact congr_arg prod.snd this
end

lemma ψ_exists_of_one_add_u (y : Kˣ) (hy : (y : K) = 1 + S.u) :
  ∃ (a : F) (ha0 : a ≠ 0) (ha1 : a ≠ 1), S.ψ y = (a,0) :=
begin
  obtain ⟨a,ha0,ha1,ha⟩ := S.exists_of_one_add_u y hy,
  use [a,ha0,ha1],
  rw [S.ψ_apply, ha, linear_map.map_smul, ← S.ψ_apply, S.ψ_map_u],
  simp,
end

lemma ψ_exists_of_one_add_v (y : Kˣ) (hy : (y : K) = 1 + S.v) :
  ∃ (b : F) (hb0 : b ≠ 0) (hb1 : b ≠ 1), S.ψ y = (0,b) :=
begin
  obtain ⟨a,ha0,ha1,ha⟩ := S.exists_of_one_add_v y hy,
  use [a,ha0,ha1],
  rw [S.ψ_apply, ha, linear_map.map_smul, ← S.ψ_apply, S.ψ_map_v],
  simp,
end

def one_add_u : Kˣ := units.mk0 _ S.one_add_u_ne_zero
def one_add_v : Kˣ := units.mk0 _ S.one_add_v_ne_zero

def A : F :=
(S.ψ_exists_of_one_add_u (units.mk0 _ S.one_add_u_ne_zero)
  (by { dsimp, ring })).some

def B : F :=
(S.ψ_exists_of_one_add_v (units.mk0 _ S.one_add_v_ne_zero)
  (by { dsimp, ring })).some

lemma A_ne_zero : S.A ≠ 0 :=
(S.ψ_exists_of_one_add_u (units.mk0 _ S.one_add_u_ne_zero)
  (by { dsimp, ring })).some_spec.some

lemma B_ne_zero : S.B ≠ 0 :=
(S.ψ_exists_of_one_add_v (units.mk0 _ S.one_add_v_ne_zero)
  (by { dsimp, ring })).some_spec.some

def A' : Fˣ := units.mk0 S.A S.A_ne_zero
def B' : Fˣ := units.mk0 S.B S.B_ne_zero

lemma A_ne_one : S.A ≠ 1 :=
(S.ψ_exists_of_one_add_u (units.mk0 _ S.one_add_u_ne_zero)
  (by { dsimp, ring })).some_spec.some_spec.some

lemma B_ne_one : S.B ≠ 1 :=
(S.ψ_exists_of_one_add_v (units.mk0 _ S.one_add_v_ne_zero)
  (by { dsimp, ring })).some_spec.some_spec.some

def A'_sub_one : Fˣ := units.mk0 (S.A - 1)
  (λ c, S.A_ne_one $ by rwa sub_eq_zero at c)

def B'_sub_one : Fˣ := units.mk0 (S.B - 1)
  (λ c, S.B_ne_one $ by rwa sub_eq_zero at c)

lemma ψ_map_one_add_u :
  S.ψ S.one_add_u = (S.A,0) :=
(S.ψ_exists_of_one_add_u (units.mk0 _ S.one_add_u_ne_zero)
  (by { dsimp, ring })).some_spec.some_spec.some_spec

lemma ψ_map_one_add_v :
  S.ψ S.one_add_v = (0,S.B) :=
(S.ψ_exists_of_one_add_v (units.mk0 _ S.one_add_v_ne_zero)
  (by { dsimp, ring })).some_spec.some_spec.some_spec

def transform :
  (F × F × F) →ₗ[F] (F × F × F) :=
{ to_fun := λ x, ⟨
    x.1 * S.A * S.B - x.2.1 * S.B - x.2.2 * S.A,
    x.2.1 * S.B * (S.A - 1),
    x.2.2 * S.A * (S.B - 1)⟩,
  map_add' := λ x y, begin
    ext; dsimp; ring
  end,
  map_smul' := λ c x, begin
    ext; dsimp; ring
  end }

lemma transform_injective :
  function.injective S.transform :=
begin
  rintros ⟨x₁,x₂,x₃⟩ ⟨y₁,y₂,y₃⟩ h,
  dsimp [transform] at h,
  simp only [prod.mk.inj_iff, mul_eq_mul_right_iff] at h,
  rcases h with ⟨h1,h2,h3⟩,
  cases h3, swap, { exfalso, apply S.B_ne_one, rwa [sub_eq_zero] at h3 },
  cases h3, swap, { exfalso, exact S.A_ne_zero h3 },
  cases h2, swap, { exfalso, apply S.A_ne_one, rwa [sub_eq_zero] at h2 },
  cases h2, swap, { exfalso, exact S.B_ne_zero h2 },
  simp only [h2, h3, sub_left_inj, mul_eq_mul_right_iff] at h1,
  cases h1, swap, { exfalso, exact S.B_ne_zero h1 },
  cases h1, swap, { exfalso, exact S.A_ne_zero h1 },
  ext, assumption'
end

def transform_equiv :
  (F × F × F) ≃ₗ[F] (F × F × F) :=
S.transform.linear_equiv_of_injective S.transform_injective (by simp)

def φ : K → ℙ F (F × F × F) :=
λ x, if hx : x = 0 then mk[F] (1,0,0) else
projectivization.map S.transform S.transform_injective $
projectivization.affine_embedding _ _ (S.ψ (units.mk0 x hx))

open projectivization

lemma φ_map_zero : S.φ 0 = (mk[F] (1,0,0)) :=
by { dsimp [φ], rw dif_pos rfl }

lemma φ_map_one : S.φ 1 = mk[F] (1,0,0) :=
begin
  dsimp [φ], rw dif_neg (one_ne_zero : (1 : K) ≠ 0),
  simp only [units.mk0_one, ψ_map_one],
  dsimp [affine_embedding],
  rw map_mk_eq_mk',
  dsimp [transform],
  rw mk_eq_mk_iff,
  use S.A' * S.B',
  simp [A', B', units.smul_def],
end

lemma φ_map_u : S.φ S.u = mk[F] (1,1,0) :=
begin
  dsimp [φ], rw dif_neg S.u.ne_zero,
  have : units.mk0 _ (S.u.ne_zero) = S.u, by { ext, refl }, rw this, clear this,
  rw S.ψ_map_u,
  dsimp [affine_embedding, map_mk_eq_mk', transform],
  rw mk_eq_mk_iff,
  simp,
  use S.B' * S.A'_sub_one,
  split,
  { dsimp [B', A'_sub_one, units.smul_def], ring },
  { dsimp [B', A'_sub_one, units.smul_def], ring }
end

lemma φ_map_v : S.φ S.v = mk[F] (1,0,1) :=
begin
  dsimp [φ], rw dif_neg S.v.ne_zero,
  have : units.mk0 _ (S.v.ne_zero) = S.v, by { ext, refl }, rw this, clear this,
  rw S.ψ_map_v,
  dsimp [affine_embedding, map_mk_eq_mk', transform],
  rw mk_eq_mk_iff,
  simp,
  use S.A' * S.B'_sub_one,
  split,
  { dsimp [A', B'_sub_one, units.smul_def], ring },
  { dsimp [A', B'_sub_one, units.smul_def], ring }
end

lemma φ_map_one_add_u : S.φ (1 + S.u) = mk[F] (0,1,0) :=
begin
  dsimp [φ], rw dif_neg S.one_add_u_ne_zero,
  have : units.mk0 _ S.one_add_u_ne_zero = S.one_add_u := rfl, rw this, clear this,
  rw S.ψ_map_one_add_u,
  dsimp [affine_embedding, map_mk_eq_mk', transform],
  rw mk_eq_mk_iff,
  simp,
  use S.A' * S.B' * S.A'_sub_one,
  dsimp [A', B', A'_sub_one, units.smul_def], ring,
end

lemma φ_map_one_add_v : S.φ (1 + S.v) = mk[F] (0,0,1) :=
begin
  dsimp [φ], rw dif_neg S.one_add_v_ne_zero,
  have : units.mk0 _ S.one_add_v_ne_zero = S.one_add_v := rfl, rw this, clear this,
  rw S.ψ_map_one_add_v,
  dsimp [affine_embedding, map_mk_eq_mk', transform],
  rw mk_eq_mk_iff,
  simp, split, { ring },
  use S.A' * S.B' * S.B'_sub_one,
  dsimp [A', B', B'_sub_one, units.smul_def], ring,
end

lemma φ_map_neg (x : K) : S.φ (-x) = S.φ x :=
begin
  by_cases hx : x = 0, { rw [hx, neg_zero] },
  dsimp [φ],
  rw [dif_neg (neg_ne_zero.mpr hx), dif_neg hx],
  have : units.mk0 (-x) (neg_ne_zero.mpr hx) = - (units.mk0 x hx), by { ext, refl },
  rw [this, S.ψ_map_neg],
end

lemma φ_dependent_pos (x y : K) :
  dependent ![S.φ x, S.φ y, S.φ (x + y)] :=
begin
  by_cases hx : x = 0,
  { simp only [hx, zero_add], rw [dependent_iff_rep, fintype.not_linear_independent_iff],
    use ![0,1,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 1, norm_num } },
  by_cases hy : y = 0,
  { simp only [hy, add_zero], rw [dependent_iff_rep, fintype.not_linear_independent_iff],
    use ![1,0,-1], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num } },
  by_cases hxy : x + y = 0,
  { rw add_eq_zero_iff_eq_neg at hxy,
    simp only [hxy, S.φ_map_neg, add_left_neg],
    rw [dependent_iff_rep, fintype.not_linear_independent_iff],
    use ![1,-1,0], split,
    { simp [fin.sum_univ_succ] },
    { use 0, norm_num } },
  dsimp [φ],
  rw [dif_neg hx, dif_neg hy, dif_neg hxy],
  dsimp [map_mk_eq_mk', affine_embedding],
  rw [dependent_mk_iff₃, ← comp_matrix_eq_matrix₃],

  let x' := units.mk0 x hx,
  let y' := units.mk0 y hy,
  let xy' := units.mk0 (x + y) hxy,

  suffices : ¬ linear_independent F ![((1 : F),S.ψ x'), (1, S.ψ y'), (1, S.ψ xy')],
  { intro c,
    apply this, apply linear_independent.of_comp _ c },

  rw fintype.not_linear_independent_iff,
  let r := y' * x'⁻¹,
  let s := xy' * x'⁻¹,
  have hrs : (s : K) = 1 + r,
  { dsimp [r,s,x', units.mk0], field_simp },
  have HH := S.ψ_dep (-r) s _,
  swap, { rw hrs, push_cast, ring },
  rw S.ψ_map_neg at HH,
  dsimp [r,s] at HH,
  simp only [S.ψ_apply, units.as_mul, units.as_inv,
    linear_map.map_add, linear_map.map_neg] at HH,
  simp only [← S.ψ_apply, fintype.not_linear_independent_iff] at HH,
  obtain ⟨g,h1,i,h2⟩ := HH,
  simp only [fin.sum_univ_succ, matrix.cons_val_zero, smul_add, smul_neg,
    fintype.univ_of_subsingleton,
    fin.mk_zero, matrix.cons_val_succ, finset.sum_singleton,
    fin.succ_zero_eq_one] at h1,
  use ![- g 0 - g 1, g 0, g 1],
  split,
  { simp only [fin.sum_univ_succ, matrix.cons_val_zero, prod.smul_mk,
      algebra.id.smul_eq_mul, mul_one, matrix.cons_val_succ,
      fintype.univ_of_subsingleton, fin.mk_zero,
      matrix.cons_val_fin_one, finset.sum_const, finset.card_singleton,
      nsmul_eq_mul, nat.cast_one, one_mul, prod.mk_add_mk, sub_add_add_cancel,
      add_left_neg, prod.mk_eq_zero, eq_self_iff_true, true_and],
    rw ← h1, ext; dsimp [smul_eq_mul]; ring },
  { fin_cases i, use 1, use 2 }
end

lemma φ_dependent_neg (x y : K) :
  dependent ![S.φ x, S.φ y, S.φ (x - y)] :=
begin
  rw [← S.φ_map_neg y, sub_eq_add_neg],
  apply φ_dependent_pos,
end

def make : _root_.setup S.φ S.u S.v :=
{ map_zero := S.φ_map_zero,
  map_one := S.φ_map_one,
  map_x := S.φ_map_u,
  map_y := S.φ_map_v,
  map_one_add_x := S.φ_map_one_add_u,
  map_one_add_y := S.φ_map_one_add_v,
  map_neg := S.φ_map_neg,
  dependent_pos := S.φ_dependent_pos,
  dependent_neg := S.φ_dependent_neg }

end setup

end bridge

theorem bridge
  [is_prime_field F]
  (H : submodule F (mul_base_change K F))
  (hH : H.dual_annihilator.acl)
  (u v : Kˣ)
  (hu : u.as ∉ H) (hv : v.as ∉ H)
  (hu₁ : ∀ y : Kˣ, (y : K) = 1 + u → y.as ∉ H)
  (hu₂ : ∀ y : Kˣ, (y : K) = 1 + u → (u⁻¹ * y).as ∉ H)
  (hv₁: ∀ y : Kˣ, (y : K) = 1 + v → y.as ∉ H)
  (hv₂ : ∀ y : Kˣ, (y : K) = 1 + v → (v⁻¹ * y).as ∉ H) :
  ¬ linear_independent F ![H.mkq u.as, H.mkq v.as] :=
begin
  intro c,
  let S : bridge.setup H hH := ⟨u,v,hu,hv,hu₁,hu₂,hv₁,hv₂,c⟩,
  let E := S.make,
  obtain ⟨m,n,hn,hh⟩ := is_prime_field.cond (1 - S.A),
  have := E.main_theorem m n (λ c, hn (congr_arg prod.fst c)),
  obtain ⟨t,ht⟩ := this,
  have hm : (m : F) ≠ 0,
  { intro c, simp only [c, zero_div] at hh,
    apply S.A_ne_one, rw sub_eq_zero at hh, exact hh.symm },
  have htz : t ≠ 0,
  { intro c,
    rw [c, E.map_zero] at ht,
    replace ht := ht.symm,
    rw projectivization.mk_eq_mk_iff at ht,
    obtain ⟨u,hu⟩ := ht,
    simp only [prod.smul_mk, smul_zero, prod.mk.inj_iff,
      eq_self_iff_true, and_true, units.smul_def, smul_eq_mul, mul_one,
      mul_zero] at hu,
    exact hm hu.2.symm },
  dsimp [bridge.setup.φ] at ht,
  rw dif_neg htz at ht,
  dsimp [projectivization.affine_embedding, projectivization.map_mk_eq_mk'] at ht,
  rw projectivization.mk_eq_mk_iff at ht,
  obtain ⟨a,ha⟩ := ht,
  dsimp [bridge.setup.transform] at ha,
  simp only [smul_zero, one_mul, prod.mk.inj_iff, zero_eq_mul, mul_eq_zero] at ha,
  rcases ha with ⟨h1,h2,h3⟩,
  cases h3, swap, { apply S.B_ne_one, rwa sub_eq_zero at h3 },
  cases h3, swap, { exact S.A_ne_zero h3 },
  rw [h3, zero_mul, sub_zero] at h1,
  have : S.A - 1 = (-m) / n,
  { field_simp at ⊢ hh, rw ← hh, ring },
  rw this at h2, dsimp [units.smul_def] at h2, field_simp at h2,
  --apply_fun (λ e, e / (m : F)) at h2, field_simp [hm] at h2,
  rw (show (a : F) * m * n = m * (a * n), by ring) at h2,
  rw (show -((S.ψ (units.mk0 t htz)).fst * S.B * m) =
    m * (-(S.ψ (units.mk0 t htz)).fst * S.B), by ring) at h2,
  apply_fun (λ e, (m : F)⁻¹ * e) at h2,
  simp only [← mul_assoc, inv_mul_cancel hm, one_mul] at h2,
  dsimp [units.smul_def, smul_eq_mul] at h1,
  rw h2 at h1,
  replace h1 := h1.symm,
  rw sub_eq_iff_eq_add at h1,
  simp only [neg_mul, add_left_neg, mul_eq_zero] at h1,
  cases h1,
  { apply S.A_ne_zero h1 },
  { apply S.B_ne_zero h1 }
end

def submodule.nonrig_condition (T : submodule F (mul_base_change K F))
  (x : Kˣ) : Prop :=
x.as ∉ T ∧
∀ (y : Kˣ) (hy : (y : K) = 1 + x), y.as ∉ T ∧ (x⁻¹ * y).as ∉ T

def submodule.nonrig (T : submodule F (mul_base_change K F)) :
  submodule F (mul_base_change K F) :=
T ⊔ (submodule.span _ $ units.as '' set_of T.nonrig_condition)

lemma submodule.le_nonrig (T : submodule F (mul_base_change K F)) :
  T ≤ T.nonrig := le_sup_left

lemma bridge_finite_dimensional
  [is_prime_field F]
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  finite_dimensional F (T.nonrig ⧸ T.comap T.nonrig.subtype) :=
begin
  by_cases hh : ∃ (u : Kˣ), T.nonrig_condition u,
  swap,
  { push_neg at hh,
    have : set_of T.nonrig_condition = ∅,
    { rw set.eq_empty_iff_forall_not_mem,
      exact hh },
    dsimp [submodule.nonrig],
    rw [this, set.image_empty],
    have he := submodule.mkq_comp_sup_mod_surjective (submodule.span F ∅) T,
    let e : _ →ₗ[_] _ := _, change function.surjective e at he,
    haveI : finite_dimensional F (submodule.span F (∅ : set (mul_base_change K F))),
    { apply finite_dimensional.span_of_finite, exact set.finite_empty },
    apply e.finite_dimensional_of_surjective,
    rwa linear_map.range_eq_top },
  obtain ⟨u,hu⟩ := hh,
  apply T.finite_dimensional_of_not_linear_independent
    (units.as '' set_of T.nonrig_condition) u.as ⟨u,hu,rfl⟩ hu.1,
  rintros a ⟨a,ha,rfl⟩,
  apply bridge T hT a u ha.1 hu.1
    (λ y hy, (ha.2 y hy).1)
    (λ y hy, (ha.2 y hy).2)
    (λ y hy, (hu.2 y hy).1)
    (λ y hy, (hu.2 y hy).2)
end

theorem bridge_codim
  [is_prime_field F]
  (T : submodule F (mul_base_change K F))
  (hT : T.dual_annihilator.acl) :
  finite_dimensional.finrank F (T.nonrig ⧸ T.comap T.nonrig.subtype) ≤ 1 :=
begin
  have fd : finite_dimensional F (T.nonrig ⧸ T.comap T.nonrig.subtype) :=
    bridge_finite_dimensional T hT,
  by_cases hh : ∃ (u : Kˣ), T.nonrig_condition u,
  swap,
  { push_neg at hh,
    have : set_of T.nonrig_condition = ∅,
    { rw set.eq_empty_iff_forall_not_mem,
      exact hh },
    dsimp [submodule.nonrig] at *,
    rw [this, set.image_empty] at *,
    have he := submodule.mkq_comp_sup_mod_surjective (submodule.span F ∅) T,
    resetI,
    rw finrank_le_one_iff,
    use 0, rintros ⟨w,hw⟩, use 0, rw submodule.mem_sup at hw,
    obtain ⟨y,hy,z,hz,rfl⟩ := hw,
    simp only [submodule.span_empty, submodule.mem_bot] at hz,
    symmetry,
    simpa only [hz, add_zero, submodule.quotient.quot_mk_eq_mk, smul_zero,
      submodule.quotient.mk_eq_zero] },
  obtain ⟨u,hu⟩ := hh,
  apply T.finrank_le_one_of_not_linear_independent
    (units.as '' set_of T.nonrig_condition) u.as ⟨u,hu,rfl⟩ hu.1,
  rintros a ⟨a,ha,rfl⟩,
  apply bridge T hT a u ha.1 hu.1
    (λ y hy, (ha.2 y hy).1)
    (λ y hy, (ha.2 y hy).2)
    (λ y hy, (hu.2 y hy).1)
    (λ y hy, (hu.2 y hy).2)
end


-- Copyright (c) 2018 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Scott Morrison

import category_theory.functor_category
import category_theory.isomorphism

universes v₁ v₂ v₃ u₁ u₂ u₃ -- declare the `v`'s first; see `category_theory.category` for an explanation

open category_theory

namespace category_theory.functor

variables (J : Type u₁) [𝒥 : category.{v₁} J]
variables {C : Type u₂} [𝒞 : category.{v₂} C]
include 𝒥 𝒞

def const : C ⥤ (J ⥤ C) :=
{ obj := λ X,
  { obj := λ j, X,
    map := λ j j' f, 𝟙 X },
  map := λ X Y f, { app := λ j, f } }

namespace const
@[simp] lemma obj_obj (X : C) (j : J) : ((const J).obj X).obj j = X := rfl
@[simp] lemma obj_map (X : C) {j j' : J} (f : j ⟶ j') : ((const J).obj X).map f = 𝟙 X := rfl
@[simp] lemma map_app {X Y : C} (f : X ⟶ Y) (j : J) : ((const J).map f).app j = f := rfl
end const

section
variables {D : Type u₃} [𝒟 : category.{v₃} D]
include 𝒟

/-- These are actually equal, of course, but not definitionally equal
  (the equality requires F.map (𝟙 _) = 𝟙 _). A natural isomorphism is
  more convenient than an equality between functors (compare id_to_iso). -/
@[simp] def const_comp (X : C) (F : C ⥤ D) :
  (const J).obj X ⋙ F ≅ (const J).obj (F.obj X) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

@[simp] lemma const_comp_hom_app (X : C) (F : C ⥤ D) (j : J) :
  (const_comp J X F).hom.app j = 𝟙 _ := rfl

@[simp] lemma const_comp_inv_app (X : C) (F : C ⥤ D) (j : J) :
  (const_comp J X F).inv.app j = 𝟙 _ := rfl

end

end category_theory.functor


/-
Copyright (c) 2022 Niels Voss. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Niels Voss
-/
import data.nat.prime
import field_theory.finite.basic
import order.filter.cofinite

/-!
# Fermat Pseudoprimes

In this file we define Fermat pseudoprimes: composite numbers that pass the Fermat primality test.
A natural number `n` passes the Fermat primality test to base `b` (and is therefore deemed a
"probable prime") if `n` divides `b ^ (n - 1) - 1`. `n` is a Fermat pseudoprime to base `b` if `n`
is a composite number that passes the Fermat primality test to base `b` and is coprime with `b`.

Fermat pseudoprimes can also be seen as composite numbers for which Fermat's little theorem holds
true.

Numbers which are Fermat pseudoprimes to all bases are known as Carmichael numbers (not yet defined
in this file).

## Main Results

The main definitions for this file are

- `fermat_psp.probable_prime`: A number `n` is a probable prime to base `b` if it passes the Fermat
  primality test; that is, if `n` divides `b ^ (n - 1) - 1`
- `fermat_psp`: A number `n` is a pseudoprime to base `b` if it is a probable prime to base `b`, is
  composite, and is coprime with `b` (this last condition is automatically true if `n` divides
  `b ^ (n - 1) - 1`, but some sources include it in the definition).

Note that all composite numbers are pseudoprimes to base 0 and 1, and that the definiton of
`probable_prime` in this file implies that all numbers are probable primes to bases 0 and 1, and
that 0 and 1 are probable primes to any base.

The main theorems are
- `fermat_psp.exists_infinite_pseudoprimes`: there are infinite pseudoprimes to any base `b ≥ 1`
-/

/--
`n` is a probable prime to base `b` if `n` passes the Fermat primality test; that is, `n` divides
`b ^ (n - 1) - 1`.
This definition implies that all numbers are probable primes to base 0 or 1, and that 0 and 1 are
probable primes to any base.
-/
def fermat_psp.probable_prime (n b : ℕ) : Prop := n ∣ b ^ (n - 1) - 1

/--
`n` is a Fermat pseudoprime to base `b` if `n` is a probable prime to base `b` and is composite. By
this definition, all composite natural numbers are pseudoprimes to base 0 and 1. This definition
also permits `n` to be less than `b`, so that 4 is a pseudoprime to base 5, for example.
-/
def fermat_psp (n b : ℕ) : Prop := fermat_psp.probable_prime n b ∧ ¬n.prime ∧ 1 < n

namespace fermat_psp

instance decidable_probable_prime (n b : ℕ) : decidable (probable_prime n b) :=
nat.decidable_dvd _ _

instance decidable_psp (n b : ℕ) : decidable (fermat_psp n b) := and.decidable

/--
If `n` passes the Fermat primality test to base `b`, then `n` is coprime with `b`, assuming that
`n` and `b` are both positive.
-/
lemma coprime_of_probable_prime {n b : ℕ} (h : probable_prime n b) (h₁ : 1 ≤ n) (h₂ : 1 ≤ b) :
  nat.coprime n b :=
begin
  by_cases h₃ : 2 ≤ n,

  { -- To prove that `n` is coprime with `b`, we we need to show that for all prime factors of `n`,
    -- we can derive a contradiction if `n` divides `b`.
    apply nat.coprime_of_dvd,

    -- If `k` is a prime number that divides both `n` and `b`, then we know that `n = m * k` and
    -- `b = j * k` for some natural numbers `m` and `j`. We substitute these into the hypothesis.
    rintros k hk ⟨m, rfl⟩ ⟨j, rfl⟩,

    -- Because prime numbers do not divide 1, it suffices to show that `k ∣ 1` to prove a
    -- contradiction
    apply nat.prime.not_dvd_one hk,

    -- Since `n` divides `b ^ (n - 1) - 1`, `k` also divides `b ^ (n - 1) - 1`
    replace h := dvd_of_mul_right_dvd h,

    -- Because `k` divides `b ^ (n - 1) - 1`, if we can show that `k` also divides `b ^ (n - 1)`,
    -- then we know `k` divides 1.
    rw [nat.dvd_add_iff_right h, nat.sub_add_cancel (nat.one_le_pow _ _ h₂)],

    -- Since `k` divides `b`, `k` also divides any power of `b` except `b ^ 0`. Therefore, it
    -- suffices to show that `n - 1` isn't zero. However, we know that `n - 1` isn't zero because we
    -- assumed `2 ≤ n` when doing `by_cases`.
    refine dvd_of_mul_right_dvd (dvd_pow_self (k * j) _),
    linarith },

  -- If `n = 1`, then it follows trivially that `n` is coprime with `b`.
  { rw (show n = 1, by linarith),
    norm_num }
end

lemma probable_prime_iff_modeq (n : ℕ) {b : ℕ} (h : 1 ≤ b) :
  probable_prime n b ↔ b ^ (n - 1) ≡ 1 [MOD n] :=
begin
  have : 1 ≤ b ^ (n - 1) := one_le_pow_of_one_le h (n - 1), -- For exact_mod_cast
  rw nat.modeq.comm,
  split,
  { intro h₁,
    apply nat.modeq_of_dvd,
    exact_mod_cast h₁, },
  { intro h₁,
    exact_mod_cast nat.modeq.dvd h₁, },
end

/--
If `n` is a Fermat pseudoprime to base `b`, then `n` is coprime with `b`, assuming that `b` is
positive.

This lemma is a small wrapper based on `coprime_of_probable_prime`
-/
lemma coprime_of_fermat_psp {n b : ℕ} (h : fermat_psp n b) (h₁ : 1 ≤ b) : nat.coprime n b :=
begin
  rcases h with ⟨hp, hn₁, hn₂⟩,
  exact coprime_of_probable_prime hp (by linarith) h₁,
end

/--
All composite numbers are Fermat pseudoprimes to base 1.
-/
lemma base_one {n : ℕ} (h₁ : 1 < n) (h₂ : ¬n.prime) : fermat_psp n 1 :=
begin
  refine ⟨show n ∣ 1 ^ (n - 1) - 1, from _, h₂, h₁⟩,
  exact (show 0 = 1 ^ (n - 1) - 1, by norm_num) ▸ dvd_zero n,
end

-- Lemmas that are needed to prove statements in this file, but aren't directly related to Fermat
-- pseudoprimes
section helper_lemmas

private lemma pow_gt_exponent {a : ℕ} (b : ℕ) (h : 2 ≤ a) : b < a ^ b :=
lt_of_lt_of_le (nat.lt_two_pow b) $ nat.pow_le_pow_of_le_left h _

private lemma a_id_helper {a b : ℕ} (ha : 2 ≤ a) (hb : 2 ≤ b) : 2 ≤ (a ^ b - 1) / (a - 1) :=
begin
  change 1 < _,
  have h₁ : a - 1 ∣ a ^ b - 1 := by simpa only [one_pow] using nat_sub_dvd_pow_sub_pow a 1 b,
  rw [nat.lt_div_iff_mul_lt h₁, mul_one, tsub_lt_tsub_iff_right (nat.le_of_succ_le ha)],
  convert pow_lt_pow (nat.lt_of_succ_le ha) hb,
  rw pow_one
end

private lemma b_id_helper {a b : ℕ} (ha : 2 ≤ a) (hb : 2 < b) : 2 ≤ (a ^ b + 1) / (a + 1) :=
begin
  rw nat.le_div_iff_mul_le (nat.zero_lt_succ _),
  apply nat.succ_le_succ,
  calc 2 * a + 1 ≤ a ^ 2 * a : by nlinarith
             ... = a ^ 3     : by rw pow_succ' a 2
             ... ≤ a ^ b     : pow_le_pow (nat.le_of_succ_le ha) hb
end

private lemma AB_id_helper (b p : ℕ) (hb : 2 ≤ b) (hp : odd p)
  : (b ^ p - 1) / (b - 1) * ((b ^ p + 1) / (b + 1)) = (b ^ (2 * p) - 1) / (b ^ 2 - 1) :=
begin
  have q₁ : b - 1 ∣ b ^ p - 1 := by simpa only [one_pow] using nat_sub_dvd_pow_sub_pow b 1 p,
  have q₂ : b + 1 ∣ b ^ p + 1 := by simpa only [one_pow] using hp.nat_add_dvd_pow_add_pow b 1,
  convert nat.div_mul_div_comm q₁ q₂; rw [mul_comm (_ - 1), ←nat.sq_sub_sq],
  { ring_exp },
  { simp }
end

/--
Used in the proof of `psp_from_prime_psp`
-/
private lemma bp_helper {b p : ℕ} (hb : 0 < b) (hp : 1 ≤ p) :
  b ^ (2 * p) - 1 - (b ^ 2 - 1) =  b * (b ^ (p - 1) - 1) * (b ^ p + b) :=
have hi_bsquared : 1 ≤ b ^ 2 := nat.one_le_pow _ _ hb,
calc b ^ (2 * p) - 1 - (b ^ 2 - 1) = b ^ (2 * p) - (1 + (b ^ 2 - 1)) : by rw nat.sub_sub
      ... = b ^ (2 * p) - (1 + b ^ 2 - 1)           : by rw nat.add_sub_assoc hi_bsquared
      ... = b ^ (2 * p) - (b ^ 2)                   : by rw nat.add_sub_cancel_left
      ... = b ^ (p * 2) - (b ^ 2)                   : by rw mul_comm
      ... = (b ^ p) ^ 2 - (b ^ 2)                   : by rw pow_mul
      ... = (b ^ p + b) * (b ^ p - b)               : by rw nat.sq_sub_sq
      ... = (b ^ p - b) * (b ^ p + b)               : by rw mul_comm
      ... = (b ^ (p - 1 + 1) - b) * (b ^ p + b)     : by rw nat.sub_add_cancel hp
      ... = (b * b ^ (p - 1) - b) * (b ^ p + b)     : by rw pow_succ
      ... = (b * b ^ (p - 1) - b * 1) * (b ^ p + b) : by rw mul_one
      ... = b * (b ^ (p - 1) - 1) * (b ^ p + b)     : by rw nat.mul_sub_left_distrib

end helper_lemmas

/--
Given a prime `p` which does not divide `b * (b ^ 2 - 1)`, we can produce a number `n` which is
larger than `p` and pseudoprime to base `b`. We do this by defining
`n = ((b ^ p - 1) / (b - 1)) * ((b ^ p + 1) / (b + 1))`

The primary purpose of this definition is to help prove `exists_infinite_pseudoprimes`. For a proof
that `n` is actually pseudoprime to base `b`, see `psp_from_prime_psp`, and for a proof that `n` is
greater than `p`, see `psp_from_prime_gt_p`.

This lemma is intended to be used when `2 ≤ b`, `2 < p`, `p` is prime, and `¬p ∣ b * (b ^ 2 - 1)`,
because those are the hypotheses for `psp_from_prime_psp`.
-/
private def psp_from_prime (b : ℕ) (p : ℕ) : ℕ := (b ^ p - 1) / (b - 1) * ((b ^ p + 1) / (b + 1))

/--
This is a proof that the number produced using `psp_from_prime` is actually pseudoprime to base `b`.
The primary purpose of this lemma is to help prove `exists_infinite_pseudoprimes`.

We use <https://primes.utm.edu/notes/proofs/a_pseudoprimes.html> as a rough outline of the proof.
-/
private lemma psp_from_prime_psp {b : ℕ} (b_ge_two : 2 ≤ b) {p : ℕ} (p_prime : p.prime)
  (p_gt_two : 2 < p) (not_dvd : ¬p ∣ b * (b ^ 2 - 1)) :
  fermat_psp (psp_from_prime b p) b :=
begin
  unfold psp_from_prime,
  set A := (b ^ p - 1) / (b - 1),
  set B := (b ^ p + 1) / (b + 1),

  -- Inequalities
  have hi_A : 1 < A := a_id_helper (nat.succ_le_iff.mp b_ge_two) (nat.prime.one_lt p_prime),
  have hi_B : 1 < B := b_id_helper (nat.succ_le_iff.mp b_ge_two) p_gt_two,
  have hi_AB : 1 < A * B := one_lt_mul'' hi_A hi_B,
  have hi_b : 0 < b := by linarith,
  have hi_p : 1 ≤ p := nat.one_le_of_lt p_gt_two,
  have hi_bsquared : 0 < b ^ 2 - 1 := by nlinarith [nat.one_le_pow 2 b hi_b],
  have hi_bpowtwop : 1 ≤ b ^ (2 * p) := nat.one_le_pow (2 * p) b hi_b,
  have hi_bpowpsubone : 1 ≤ b ^ (p - 1) := nat.one_le_pow (p - 1) b hi_b,

  -- Other useful facts
  have p_odd : odd p := p_prime.odd_of_ne_two p_gt_two.ne.symm,
  have AB_not_prime : ¬nat.prime (A * B) := nat.not_prime_mul hi_A hi_B,
  have AB_id : A * B = (b ^ (2 * p) - 1) / (b ^ 2 - 1) := AB_id_helper _ _ b_ge_two p_odd,
  have hd : b ^ 2 - 1 ∣ b ^ (2 * p) - 1,
  { simpa only [one_pow, pow_mul] using nat_sub_dvd_pow_sub_pow _ 1 p },

  -- We know that `A * B` is not prime, and that `1 < A * B`. Since two conditions of being
  -- pseudoprime are satisfied, we only need to show that `A * B` is probable prime to base `b`
  refine ⟨_, AB_not_prime, hi_AB⟩,

  -- Used to prove that `2 * p * (b ^ 2 - 1) ∣ (b ^ 2 - 1) * (A * B - 1)`.
  have ha₁ : (b ^ 2 - 1) * (A * B - 1) = b * (b ^ (p - 1) - 1) * (b ^ p + b),
  { apply_fun (λ x, x * (b ^ 2 - 1)) at AB_id,
    rw nat.div_mul_cancel hd at AB_id,
    apply_fun (λ x, x - (b ^ 2 - 1)) at AB_id,
    nth_rewrite 1 ←one_mul (b ^ 2 - 1) at AB_id,
    rw [←nat.mul_sub_right_distrib, mul_comm] at AB_id,
    rw AB_id,
    exact bp_helper hi_b hi_p },
  -- If `b` is even, then `b^p` is also even, so `2 ∣ b^p + b`
  -- If `b` is odd, then `b^p` is also odd, so `2 ∣ b^p + b`
  have ha₂ : 2 ∣ b ^ p + b,
  { by_cases h : even b,
    { replace h : 2 ∣ b := even_iff_two_dvd.mp h,
      have : p ≠ 0 := by linarith,
      have : 2 ∣ b^p := dvd_pow h this,
      exact dvd_add this h },
    { have h : odd b := nat.odd_iff_not_even.mpr h,
      have : odd (b ^ p) := odd.pow h,
      have : even (b ^ p + b) := odd.add_odd this h,
      exact even_iff_two_dvd.mp this } },
  -- Since `b` isn't divisible by `p`, `b` is coprime with `p`. we can use Fermat's Little Theorem
  -- to prove this.
  have ha₃ : p ∣ b ^ (p - 1) - 1,
  { have : ¬p ∣ b := mt (assume h : p ∣ b, dvd_mul_of_dvd_left h _) not_dvd,
    have : p.coprime b := or.resolve_right (nat.coprime_or_dvd_of_prime p_prime b) this,
    have : is_coprime (b : ℤ) ↑p := this.symm.is_coprime,
    have : ↑b ^ (p - 1) ≡ 1 [ZMOD ↑p] := int.modeq.pow_card_sub_one_eq_one p_prime this,
    have : ↑p ∣ ↑b ^ (p - 1) - ↑1 := int.modeq.dvd (int.modeq.symm this),
    exact_mod_cast this },
  -- Because `p - 1` is even, there is a `c` such that `2 * c = p - 1`. `nat_sub_dvd_pow_sub_pow`
  -- implies that `b ^ c - 1 ∣ (b ^ c) ^ 2 - 1`, and `(b ^ c) ^ 2 = b ^ (p - 1)`.
  have ha₄ : b ^ 2 - 1 ∣ b ^ (p - 1) - 1,
  { cases p_odd with k hk,
    have : 2 ∣ p - 1 := ⟨k, by simp [hk]⟩,
    cases this with c hc,
    have : b ^ 2 - 1 ∣ (b ^ 2) ^ c - 1 :=
      by simpa only [one_pow] using nat_sub_dvd_pow_sub_pow _ 1 c,
    have : b ^ 2 - 1 ∣ b ^ (2 * c) - 1 := by rwa ←pow_mul at this,
    rwa ←hc at this },
  -- Used to prove that `2 * p` divides `A * B - 1`
  have ha₅ : 2 * p * (b ^ 2 - 1) ∣ (b ^ 2 - 1) * (A * B - 1),
  { suffices q : 2 * p * (b ^ 2 - 1) ∣ b * (b ^ (p - 1) - 1) * (b ^ p + b),
    { rwa ha₁ },
    -- We already proved that `b ^ 2 - 1 ∣ b ^ (p - 1) - 1`.
    -- Since `2 ∣ b ^ p + b` and `p ∣ b ^ p + b`, if we show that 2 and p are coprime, then we
    -- know that `2 * p ∣ b ^ p + b`
    have q₁ : nat.coprime p (b ^ 2 - 1),
    { have q₂ : ¬p ∣ b ^ 2 - 1,
      { rw mul_comm at not_dvd,
        exact mt (assume h : p ∣ b ^ 2 - 1, dvd_mul_of_dvd_left h _) not_dvd },
      exact (nat.prime.coprime_iff_not_dvd p_prime).mpr q₂ },
    have q₂ : p * (b ^ 2 - 1) ∣ b ^ (p - 1) - 1 := nat.coprime.mul_dvd_of_dvd_of_dvd q₁ ha₃ ha₄,
    have q₃ : p * (b ^ 2 - 1) * 2 ∣ (b ^ (p - 1) - 1) * (b ^ p + b) := mul_dvd_mul q₂ ha₂,
    have q₄ : p * (b ^ 2 - 1) * 2 ∣ b * ((b ^ (p - 1) - 1) * (b ^ p + b)),
      from dvd_mul_of_dvd_right q₃ _,
    rwa [mul_assoc, mul_comm, mul_assoc b] },
  have ha₆ : 2 * p ∣ A * B - 1,
  { rw mul_comm at ha₅,
    exact nat.dvd_of_mul_dvd_mul_left hi_bsquared ha₅ },
  -- `A * B` divides `b ^ (2 * p) - 1` because `A * B * (b ^ 2 - 1) = b ^ (2 * p) - 1`.
  -- This can be proven by multiplying both sides of `AB_id` by `b ^ 2 - 1`.
  have ha₇ : A * B ∣ b ^ (2 * p) - 1,
  { use b ^ 2 - 1,
    have : A * B * (b ^ 2 - 1) = (b ^ (2 * p) - 1) / (b ^ 2 - 1) * (b ^ 2 - 1),
      from congr_arg (λ x : ℕ, x * (b ^ 2 - 1)) AB_id,
    simpa only [add_comm, nat.div_mul_cancel hd, nat.sub_add_cancel hi_bpowtwop] using this.symm },
  -- Since `2 * p ∣ A * B - 1`, there is a number `q` such that `2 * p * q = A * B - 1`.
  -- By `nat_sub_dvd_pow_sub_pow`, we know that `b ^ (2 * p) - 1 ∣ b ^ (2 * p * q) - 1`.
  -- This means that `b ^ (2 * p) - 1 ∣ b ^ (A * B - 1) - 1`.
  cases ha₆ with q hq,
  have ha₈ : b ^ (2 * p) - 1 ∣ b ^ (A * B - 1) - 1 :=
    by simpa only [one_pow, pow_mul, hq] using nat_sub_dvd_pow_sub_pow _ 1 q,
  -- We have proved that `A * B ∣ b ^ (2 * p) - 1` and `b ^ (2 * p) - 1 ∣ b ^ (A * B - 1) - 1`.
  -- Therefore, `A * B ∣ b ^ (A * B - 1) - 1`.
  exact dvd_trans ha₇ ha₈
end

/--
This is a proof that the number produced using `psp_from_prime` is greater than the prime `p` used
to create it. The primary purpose of this lemma is to help prove `exists_infinite_pseudoprimes`.
-/
private

  suffices h : p * (b ^ 2 - 1) < b ^ (2 * p) - 1,
  { have h₁ : (p * (b ^ 2 - 1)) / (b ^ 2 - 1) < (b ^ (2 * p) - 1) / (b ^ 2 - 1),
      from nat.div_lt_div_of_lt_of_dvd AB_dvd h,
    have h₂ : 0 < b ^ 2 - 1,
      by linarith [show 3 ≤ b ^ 2 - 1, from le_tsub_of_add_le_left (show 4 ≤ b ^ 2, by nlinarith)],
    rwa nat.mul_div_cancel _ h₂ at h₁ },

  rw [nat.mul_sub_left_distrib, mul_one, pow_mul],
  nth_rewrite_rhs 0 ←nat.sub_add_cancel (show 1 ≤ p, by linarith),
  rw pow_succ (b ^ 2),
  suffices h : p * b ^ 2 < b ^ 2 * (b ^ 2) ^ (p - 1),
  { apply gt_of_ge_of_gt,
    { exact tsub_le_tsub_left (show 1 ≤ p, by linarith) (b ^ 2 * (b ^ 2) ^ (p - 1)) },
    { have : p ≤ p * b ^ 2 := nat.le_mul_of_pos_right (show 0 < b ^ 2, by nlinarith),
      exact tsub_lt_tsub_right_of_le this h } },

  suffices h : p < (b ^ 2) ^ (p - 1),
  { rw mul_comm (b ^ 2),
    have : 4 ≤ b ^ 2 := by nlinarith,
    have : 0 < b ^ 2 := by linarith,
    exact mul_lt_mul_of_pos_right h this },

  rw [←pow_mul, nat.mul_sub_left_distrib, mul_one],
  have : 2 ≤ 2 * p - 2 := le_tsub_of_add_le_left (show 4 ≤ 2 * p, by linarith),
  have : 2 + p ≤ 2 * p := by linarith,
  have : p ≤ 2 * p - 2 := le_tsub_of_add_le_left this,
  exact nat.lt_of_le_of_lt this (pow_gt_exponent _ b_ge_two)
end

/--
For all positive bases, there exist Fermat infinite pseudoprimes to that base.
Given in this form: for all numbers `b ≥ 1` and `m`, there exists a pseudoprime `n` to base `b` such
that `m ≤ n`. This form is similar to `nat.exists_infinite_primes`.
-/
theorem exists_infinite_pseudoprimes {b : ℕ} (h : 1 ≤ b) (m : ℕ) : ∃ n : ℕ, fermat_psp n b ∧ m ≤ n
:=
begin
  by_cases b_ge_two : 2 ≤ b,
  -- If `2 ≤ b`, then because there exist infinite prime numbers, there is a prime number p such
  -- `m ≤ p` and `¬p ∣ b*(b^2 - 1)`. We pick a prime number `b*(b^2 - 1) + 1 + m ≤ p` because we
  -- automatically know that `p` is greater than m and that it does not divide `b*(b^2 - 1)`
  -- (because `p` can't divide a number less than `p`).
  -- From `p`, we can use the lemmas we proved earlier to show that
  -- `((b^p - 1)/(b - 1)) * ((b^p + 1)/(b + 1))` is a pseudoprime to base `b`.
  { have h := nat.exists_infinite_primes (b * (b ^ 2 - 1) + 1 + m),
    cases h with p hp,
    cases hp with hp₁ hp₂,
    have h₁ : 0 < b := pos_of_gt (nat.succ_le_iff.mp b_ge_two),
    have h₂ : 4 ≤ b ^ 2 := pow_le_pow_of_le_left' b_ge_two 2,
    have h₃ : 0 < b ^ 2 - 1 := tsub_pos_of_lt (gt_of_ge_of_gt h₂ (by norm_num)),
    have h₄ : 0 < b * (b ^ 2 - 1) := mul_pos h₁ h₃,
    have h₅ : b * (b ^ 2 - 1) < p := by linarith,
    have h₆ : ¬p ∣ b * (b ^ 2 - 1) := nat.not_dvd_of_pos_of_lt h₄ h₅,
    have h₇ : b ≤ b * (b ^ 2 - 1) := nat.le_mul_of_pos_right h₃,
    have h₈ : 2 ≤ b * (b ^ 2 - 1) := le_trans b_ge_two h₇,
    have h₉ : 2 < p := gt_of_gt_of_ge h₅ h₈,
    have h₁₀ := psp_from_prime_gt_p b_ge_two hp₂ h₉,
    use psp_from_prime b p,
    split,
    { exact psp_from_prime_psp b_ge_two hp₂ h₉ h₆ },
    { exact le_trans (show m ≤ p, by linarith) (le_of_lt h₁₀) } },
  -- If `¬2 ≤ b`, then `b = 1`. Since all composite numbers are pseudoprimes to base 1, we can pick
  -- any composite number greater than m. We choose `2 * (m + 2)` because it is greater than `m` and
  -- is composite for all natural numbers `m`.
  { have h₁ : b = 1 := by linarith,
    rw h₁,
    use 2 * (m + 2),
    have : ¬nat.prime (2 * (m + 2)) := nat.not_prime_mul (by norm_num) (by norm_num),
    exact ⟨base_one (by linarith) this, by linarith⟩ }
end

theorem frequently_at_top_fermat_psp {b : ℕ} (h : 1 ≤ b) : ∃ᶠ n in filter.at_top, fermat_psp n b :=
begin
  -- Based on the proof of `nat.frequently_at_top_modeq_one`
  refine filter.frequently_at_top.2 (λ n, _),
  obtain ⟨p, hp⟩ := exists_infinite_pseudoprimes h n,
  exact ⟨p, hp.2, hp.1⟩
end

/--
Infinite set variant of `exists_infinite_pseudoprimes`
-/
theorem infinite_set_of_prime_modeq_one {b : ℕ} (h : 1 ≤ b) :
  set.infinite {n : ℕ | fermat_psp n b} :=
nat.frequently_at_top_iff_infinite.mp (frequently_at_top_fermat_psp h)

end fermat_psp


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.metric_space.baire
import analysis.normed_space.operator_norm

/-!
# Banach open mapping theorem

This file contains the Banach open mapping theorem, i.e., the fact that a bijective
bounded linear map between Banach spaces has a bounded inverse.
-/

open function metric set filter finset
open_locale classical topological_space big_operators nnreal

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{F : Type*} [normed_group F] [normed_space 𝕜 F]
(f : E →L[𝕜] F)
include 𝕜

namespace continuous_linear_map

/-- A (possibly nonlinear) right inverse to a continuous linear map, which doesn't have to be
linear itself but which satisfies a bound `∥inverse x∥ ≤ C * ∥x∥`. A surjective continuous linear
map doesn't always have a continuous linear right inverse, but it always has a nonlinear inverse
in this sense, by Banach's open mapping theorem. -/
structure nonlinear_right_inverse :=
(to_fun : F → E)
(nnnorm : ℝ≥0)
(bound' : ∀ y, ∥to_fun y∥ ≤ nnnorm * ∥y∥)
(right_inv' : ∀ y, f (to_fun y) = y)

instance : has_coe_to_fun (nonlinear_right_inverse f) := ⟨_, λ fsymm, fsymm.to_fun⟩

@[simp] lemma nonlinear_right_inverse.right_inv {f : E →L[𝕜] F} (fsymm : nonlinear_right_inverse f)
  (y : F) : f (fsymm y) = y :=
fsymm.right_inv' y

lemma nonlinear_right_inverse.bound {f : E →L[𝕜] F} (fsymm : nonlinear_right_inverse f) (y : F) :
  ∥fsymm y∥ ≤ fsymm.nnnorm * ∥y∥ :=
fsymm.bound' y

end continuous_linear_map

/-- Given a continuous linear equivalence, the inverse is in particular an instance of
`nonlinear_right_inverse` (which turns out to be linear). -/
noncomputable def continuous_linear_equiv.to_nonlinear_right_inverse (f : E ≃L[𝕜] F) :
  continuous_linear_map.nonlinear_right_inverse (f : E →L[𝕜] F) :=
{ to_fun := f.inv_fun,
  nnnorm := nnnorm (f.symm : F →L[𝕜] E),
  bound' := λ y, continuous_linear_map.le_op_norm (f.symm : F →L[𝕜] E) _,
  right_inv' := f.apply_symm_apply }

noncomputable instance (f : E ≃L[𝕜] F) :
  inhabited (continuous_linear_map.nonlinear_right_inverse (f : E →L[𝕜] F)) :=
⟨f.to_nonlinear_right_inverse⟩

/-! ### Proof of the Banach open mapping theorem -/

variable [complete_space F]

/--
First step of the proof of the Banach open mapping theorem (using completeness of `F`):
by Baire's theorem, there exists a ball in `E` whose image closure has nonempty interior.
Rescaling everything, it follows that any `y ∈ F` is arbitrarily well approached by
images of elements of norm at most `C * ∥y∥`.
For further use, we will only need such an element whose image
is within distance `∥y∥/2` of `y`, to apply an iterative process. -/
lemma exists_approx_preimage_norm_le (surj : surjective f) :
  ∃C ≥ 0, ∀y, ∃x, dist (f x) y ≤ 1/2 * ∥y∥ ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  have A : (⋃n:ℕ, closure (f '' (ball 0 n))) = univ,
  { refine subset.antisymm (subset_univ _) (λy hy, _),
    rcases surj y with ⟨x, hx⟩,
    rcases exists_nat_gt (∥x∥) with ⟨n, hn⟩,
    refine mem_Union.2 ⟨n, subset_closure _⟩,
    refine (mem_image _ _ _).2 ⟨x, ⟨_, hx⟩⟩,
    rwa [mem_ball, dist_eq_norm, sub_zero] },
  have : ∃ (n : ℕ) x, x ∈ interior (closure (f '' (ball 0 n))) :=
    nonempty_interior_of_Union_of_closed (λn, is_closed_closure) A,
  simp only [mem_interior_iff_mem_nhds, mem_nhds_iff] at this,
  rcases this with ⟨n, a, ε, ⟨εpos, H⟩⟩,
  rcases normed_field.exists_one_lt_norm 𝕜 with ⟨c, hc⟩,
  refine ⟨(ε/2)⁻¹ * ∥c∥ * 2 * n, _, λy, _⟩,
  { refine mul_nonneg (mul_nonneg (mul_nonneg _ (norm_nonneg _)) (by norm_num)) _,
    exacts [inv_nonneg.2 (div_nonneg (le_of_lt εpos) (by norm_num)), n.cast_nonneg] },
  { by_cases hy : y = 0,
    { use 0, simp [hy] },
    { rcases rescale_to_shell hc (half_pos εpos) hy with ⟨d, hd, ydlt, leyd, dinv⟩,
      let δ := ∥d∥ * ∥y∥/4,
      have δpos : 0 < δ :=
        div_pos (mul_pos (norm_pos_iff.2 hd) (norm_pos_iff.2 hy)) (by norm_num),
      have : a + d • y ∈ ball a ε,
        by simp [dist_eq_norm, lt_of_le_of_lt ydlt.le (half_lt_self εpos)],
      rcases metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₁, z₁im, h₁⟩,
      rcases (mem_image _ _ _).1 z₁im with ⟨x₁, hx₁, xz₁⟩,
      rw ← xz₁ at h₁,
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₁,
      have : a ∈ ball a ε, by { simp, exact εpos },
      rcases metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₂, z₂im, h₂⟩,
      rcases (mem_image _ _ _).1 z₂im with ⟨x₂, hx₂, xz₂⟩,
      rw ← xz₂ at h₂,
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₂,
      let x := x₁ - x₂,
      have I : ∥f x - d • y∥ ≤ 2 * δ := calc
        ∥f x - d • y∥ = ∥f x₁ - (a + d • y) - (f x₂ - a)∥ :
          by { congr' 1, simp only [x, f.map_sub], abel }
        ... ≤ ∥f x₁ - (a + d • y)∥ + ∥f x₂ - a∥ :
          norm_sub_le _ _
        ... ≤ δ + δ : begin
            apply add_le_add,
            { rw [← dist_eq_norm, dist_comm], exact le_of_lt h₁ },
            { rw [← dist_eq_norm, dist_comm], exact le_of_lt h₂ }
          end
        ... = 2 * δ : (two_mul _).symm,
      have J : ∥f (d⁻¹ • x) - y∥ ≤ 1/2 * ∥y∥ := calc
        ∥f (d⁻¹ • x) - y∥ = ∥d⁻¹ • f x - (d⁻¹ * d) • y∥ :
          by rwa [f.map_smul _, inv_mul_cancel, one_smul]
        ... = ∥d⁻¹ • (f x - d • y)∥ : by rw [mul_smul, smul_sub]
        ... = ∥d∥⁻¹ * ∥f x - d • y∥ : by rw [norm_smul, normed_field.norm_inv]
        ... ≤ ∥d∥⁻¹ * (2 * δ) : begin
            apply mul_le_mul_of_nonneg_left I,
            rw inv_nonneg,
            exact norm_nonneg _
          end
        ... = (∥d∥⁻¹ * ∥d∥) * ∥y∥ /2 : by { simp only [δ], ring }
        ... = ∥y∥/2 : by { rw [inv_mul_cancel, one_mul],  simp [norm_eq_zero, hd] }
        ... = (1/2) * ∥y∥ : by ring,
      rw ← dist_eq_norm at J,
      have K : ∥d⁻¹ • x∥ ≤ (ε / 2)⁻¹ * ∥c∥ * 2 * ↑n * ∥y∥ := calc
        ∥d⁻¹ • x∥ = ∥d∥⁻¹ * ∥x₁ - x₂∥ : by rw [norm_smul, normed_field.norm_inv]
        ... ≤ ((ε / 2)⁻¹ * ∥c∥ * ∥y∥) * (n + n) : begin
            refine mul_le_mul dinv _ (norm_nonneg _) _,
            { exact le_trans (norm_sub_le _ _) (add_le_add (le_of_lt hx₁) (le_of_lt hx₂)) },
            { apply mul_nonneg (mul_nonneg _ (norm_nonneg _)) (norm_nonneg _),
              exact inv_nonneg.2 (le_of_lt (half_pos εpos)) }
          end
        ... = (ε / 2)⁻¹ * ∥c∥ * 2 * ↑n * ∥y∥ : by ring,
      exact ⟨d⁻¹ • x, J, K⟩ } },
end

variable [complete_space E]

/-- The Banach open mapping theorem: if a bounded linear map between Banach spaces is onto, then
any point has a preimage with controlled norm. -/
theorem exists_preimage_norm_le (surj : surjective f) :
  ∃C > 0, ∀y, ∃x, f x = y ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  obtain ⟨C, C0, hC⟩ := exists_approx_preimage_norm_le f surj,
  /- Second step of the proof: starting from `y`, we want an exact preimage of `y`. Let `g y` be
  the approximate preimage of `y` given by the first step, and `h y = y - f(g y)` the part that
  has no preimage yet. We will iterate this process, taking the approximate preimage of `h y`,
  leaving only `h^2 y` without preimage yet, and so on. Let `u n` be the approximate preimage
  of `h^n y`. Then `u` is a converging series, and by design the sum of the series is a
  preimage of `y`. This uses completeness of `E`. -/
  choose g hg using hC,
  let h := λy, y - f (g y),
  have hle : ∀y, ∥h y∥ ≤ (1/2) * ∥y∥,
  { assume y,
    rw [← dist_eq_norm, dist_comm],
    exact (hg y).1 },
  refine ⟨2 * C + 1, by linarith, λy, _⟩,
  have hnle : ∀n:ℕ, ∥(h^[n]) y∥ ≤ (1/2)^n * ∥y∥,
  { assume n,
    induction n with n IH,
    { simp only [one_div, nat.nat_zero_eq_zero, one_mul, iterate_zero_apply,
        pow_zero] },
    { rw [iterate_succ'],
      apply le_trans (hle _) _,
      rw [pow_succ, mul_assoc],
      apply mul_le_mul_of_nonneg_left IH,
      norm_num } },
  let u := λn, g((h^[n]) y),
  have ule : ∀n, ∥u n∥ ≤ (1/2)^n * (C * ∥y∥),
  { assume n,
    apply le_trans (hg _).2 _,
    calc C * ∥(h^[n]) y∥ ≤ C * ((1/2)^n * ∥y∥) : mul_le_mul_of_nonneg_left (hnle n) C0
         ... = (1 / 2) ^ n * (C * ∥y∥) : by ring },
  have sNu : summable (λn, ∥u n∥),
  { refine summable_of_nonneg_of_le (λn, norm_nonneg _) ule _,
    exact summable.mul_right _ (summable_geometric_of_lt_1 (by norm_num) (by norm_num)) },
  have su : summable u := summable_of_summable_norm sNu,
  let x := tsum u,
  have x_ineq : ∥x∥ ≤ (2 * C + 1) * ∥y∥ := calc
    ∥x∥ ≤ ∑'n, ∥u n∥ : norm_tsum_le_tsum_norm sNu
    ... ≤ ∑'n, (1/2)^n * (C * ∥y∥) :
      tsum_le_tsum ule sNu (summable.mul_right _ summable_geometric_two)
    ... = (∑'n, (1/2)^n) * (C * ∥y∥) : tsum_mul_right
    ... = 2 * C * ∥y∥ : by rw [tsum_geometric_two, mul_assoc]
    ... ≤ 2 * C * ∥y∥ + ∥y∥ : le_add_of_nonneg_right (norm_nonneg y)
    ... = (2 * C + 1) * ∥y∥ : by ring,
  have fsumeq : ∀n:ℕ, f (∑ i in range n, u i) = y - (h^[n]) y,
  { assume n,
    induction n with n IH,
    { simp [f.map_zero] },
    { rw [sum_range_succ, f.map_add, IH, iterate_succ', sub_add] } },
  have : tendsto (λn, ∑ i in range n, u i) at_top (𝓝 x) :=
    su.has_sum.tendsto_sum_nat,
  have L₁ : tendsto (λn, f (∑ i in range n, u i)) at_top (𝓝 (f x)) :=
    (f.continuous.tendsto _).comp this,
  simp only [fsumeq] at L₁,
  have L₂ : tendsto (λn, y - (h^[n]) y) at_top (𝓝 (y - 0)),
  { refine tendsto_const_nhds.sub _,
    rw tendsto_iff_norm_tendsto_zero,
    simp only [sub_zero],
    refine squeeze_zero (λ_, norm_nonneg _) hnle _,
    rw [← zero_mul ∥y∥],
    refine (tendsto_pow_at_top_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds; norm_num },
  have feq : f x = y - 0 := tendsto_nhds_unique L₁ L₂,
  rw sub_zero at feq,
  exact ⟨x, feq, x_ineq⟩
end

/-- The Banach open mapping theorem: a surjective bounded linear map between Banach spaces is
open. -/
theorem open_mapping (surj : surjective f) : is_open_map f :=
begin
  assume s hs,
  rcases exists_preimage_norm_le f surj with ⟨C, Cpos, hC⟩,
  refine is_open_iff.2 (λy yfs, _),
  rcases mem_image_iff_bex.1 yfs with ⟨x, xs, fxy⟩,
  rcases is_open_iff.1 hs x xs with ⟨ε, εpos, hε⟩,
  refine ⟨ε/C, div_pos εpos Cpos, λz hz, _⟩,
  rcases hC (z-y) with ⟨w, wim, wnorm⟩,
  have : f (x + w) = z, by { rw [f.map_add, wim, fxy, add_sub_cancel'_right] },
  rw ← this,
  have : x + w ∈ ball x ε := calc
    dist (x+w) x = ∥w∥ : by { rw dist_eq_norm, simp }
    ... ≤ C * ∥z - y∥ : wnorm
    ... < C * (ε/C) : begin
        apply mul_lt_mul_of_pos_left _ Cpos,
        rwa [mem_ball, dist_eq_norm] at hz,
      end
    ... = ε : mul_div_cancel' _ (ne_of_gt Cpos),
  exact set.mem_image_of_mem _ (hε this)
end

/-! ### Applications of the Banach open mapping theorem -/

namespace continuous_linear_map

lemma exists_nonlinear_right_inverse_of_surjective (f : E →L[𝕜] F) (hsurj : f.range = ⊤) :
  ∃ (fsymm : nonlinear_right_inverse f), 0 < fsymm.nnnorm :=
begin
  choose C hC fsymm h using exists_preimage_norm_le _ (linear_map.range_eq_top.mp hsurj),
  use { to_fun := fsymm,
        nnnorm := ⟨C, hC.lt.le⟩,
        bound' := λ y, (h y).2,
        right_inv' := λ y, (h y).1 },
  exact hC
end

/-- A surjective continuous linear map between Banach spaces admits a (possibly nonlinear)
controlled right inverse. In general, it is not possible to ensure that such a right inverse
is linear (take for instance the map from `E` to `E/F` where `F` is a closed subspace of `E`
without a closed complement. Then it doesn't have a continuous linear right inverse.) -/
@[irreducible] noncomputable def nonlinear_right_inverse_of_surjective
  (f : E →L[𝕜] F) (hsurj : f.range = ⊤) : nonlinear_right_inverse f :=
classical.some (exists_nonlinear_right_inverse_of_surjective f hsurj)

lemma nonlinear_right_inverse_of_surjective_nnnorm_pos (f : E →L[𝕜] F) (hsurj : f.range = ⊤) :
  0 < (nonlinear_right_inverse_of_surjective f hsurj).nnnorm :=
begin
  rw nonlinear_right_inverse_of_surjective,
  exact classical.some_spec (exists_nonlinear_right_inverse_of_surjective f hsurj)
end

end continuous_linear_map

namespace linear_equiv

/-- If a bounded linear map is a bijection, then its inverse is also a bounded linear map. -/
@[continuity]
theorem continuous_symm (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  continuous e.symm :=
begin
  rw continuous_def,
  intros s hs,
  rw [← e.image_eq_preimage],
  rw [← e.coe_coe] at h ⊢,
  exact open_mapping ⟨↑e, h⟩ e.surjective s hs
end

/-- Associating to a linear equivalence between Banach spaces a continuous linear equivalence when
the direct map is continuous, thanks to the Banach open mapping theorem that ensures that the
inverse map is also continuous. -/
def to_continuous_linear_equiv_of_continuous (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  E ≃L[𝕜] F :=
{ continuous_to_fun := h,
  continuous_inv_fun := e.continuous_symm h,
  ..e }

@[simp] lemma coe_fn_to_continuous_linear_equiv_of_continuous (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  ⇑(e.to_continuous_linear_equiv_of_continuous h) = e := rfl

@[simp] lemma coe_fn_to_continuous_linear_equiv_of_continuous_symm (e : E ≃ₗ[𝕜] F)
  (h : continuous e) :
  ⇑(e.to_continuous_linear_equiv_of_continuous h).symm = e.symm := rfl

end linear_equiv

namespace continuous_linear_equiv

/-- Convert a bijective continuous linear map `f : E →L[𝕜] F` between two Banach spaces
to a continuous linear equivalence. -/
noncomputable def of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  E ≃L[𝕜] F :=
(linear_equiv.of_bijective ↑f hinj hsurj).to_continuous_linear_equiv_of_continuous f.continuous

@[simp] lemma coe_fn_of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  ⇑(of_bijective f hinj hsurj) = f := rfl

@[simp] lemma of_bijective_symm_apply_apply (f : E →L[𝕜] F) (hinj : f.ker = ⊥)
  (hsurj : f.range = ⊤) (x : E) :
  (of_bijective f hinj hsurj).symm (f x) = x :=
(of_bijective f hinj hsurj).symm_apply_apply x

@[simp] lemma of_bijective_apply_symm_apply (f : E →L[𝕜] F) (hinj : f.ker = ⊥)
  (hsurj : f.range = ⊤) (y : F) :
  f ((of_bijective f hinj hsurj).symm y) = y :=
(of_bijective f hinj hsurj).apply_symm_apply y

end continuous_linear_equiv

namespace continuous_linear_map

/- TODO: remove the assumption `f.ker = ⊥` in the next lemma, by using the map induced by `f` on
`E / f.ker`, once we have quotient normed spaces. -/
lemma closed_complemented_range_of_is_compl_of_ker_eq_bot (f : E →L[𝕜] F) (G : submodule 𝕜 F)
  (h : is_compl f.range G) (hG : is_closed (G : set F)) (hker : f.ker = ⊥) :
  is_closed (f.range : set F) :=
begin
  let g : (E × G) →L[𝕜] F := f.coprod G.subtypeL,
  have : (f.range : set F) = g '' ((⊤ : submodule 𝕜 E).prod (⊥ : submodule 𝕜 G)),
    by { ext x, simp [continuous_linear_map.mem_range] },
  rw this,
  haveI : complete_space G := complete_space_coe_iff_is_complete.2 hG.is_complete,
  have grange : g.range = ⊤,
    by simp only [range_coprod, h.sup_eq_top, submodule.range_subtypeL],
  have gker : g.ker = ⊥,
  { rw [ker_coprod_of_disjoint_range, hker],
    { simp only [submodule.ker_subtypeL, submodule.prod_bot] },
    { convert h.disjoint,
      exact submodule.range_subtypeL _ } },
  apply (continuous_linear_equiv.of_bijective g gker grange).to_homeomorph.is_closed_image.2,
  exact is_closed_univ.prod is_closed_singleton,
end

end continuous_linear_map


import ring_theory.power_series
import combinatorics.composition
import data.nat.parity
import data.finset.nat_antidiagonal
import tactic.interval_cases
import tactic.apply_fun
import chap1

open finset
open_locale big_operators

lemma count_repeat_ite {α : Type*} [decidable_eq α] (a b : α) (n : ℕ)  :
  multiset.count a (multiset.repeat b n) = if (a = b) then n else 0 :=
begin
  split_ifs,
    cases h,
    rw multiset.count_repeat,
  apply multiset.count_eq_zero_of_not_mem,
  intro,
  apply h,
  apply multiset.eq_of_mem_repeat a_1,
end

open_locale classical
open power_series

noncomputable theory

variable {α : Type*}
/-- A composition of `n` is a list of positive integers summing to `n`. -/
@[ext] structure partition (n : ℕ) :=
(blocks : multiset ℕ)
(blocks_pos : ∀ {i}, i ∈ blocks → 0 < i)
(blocks_sum : blocks.sum = n)

def composition_to_partition (n : ℕ) (c : composition n) : partition n :=
{ blocks := c.blocks,
  blocks_pos := λ i hi, c.blocks_pos hi,
  blocks_sum := by rw [multiset.coe_sum, c.blocks_sum] }

instance (n : ℕ) : decidable_eq (partition n) :=
begin
  intros a b,
  rw partition.ext_iff,
  apply_instance,
end

instance (n : ℕ) : fintype (partition n) :=
begin
  apply fintype.of_surjective (composition_to_partition n),
  rintro ⟨_, _, _⟩,
  rcases quotient.exists_rep b_blocks with ⟨_, rfl⟩,
  refine ⟨⟨w, λ i hi, b_blocks_pos hi, _⟩, partition.ext _ _ rfl⟩,
  simpa using b_blocks_sum,
end

def partial_odd_gf (n : ℕ) := ∏ i in range n, (1 - (X : power_series ℚ)^(2*i+1))⁻¹
def partial_distinct_gf (n : ℕ) := ∏ i in range n, (1 + (X : power_series ℚ)^(i+1))

def odd_partition (n : ℕ) := {c : partition n // ∀ i ∈ c.blocks, ¬ nat.even i}
def distinct_partition (n : ℕ) := {c : partition n // multiset.nodup c.blocks}

instance (n : ℕ) : fintype (odd_partition n) :=
subtype.fintype _
instance (n : ℕ) : fintype (distinct_partition n) :=
subtype.fintype _

-- def splits (n k : ℕ) : finset (list ℕ) := sorry

-- lemma mem_splits (n k : ℕ) (l : list ℕ) : l ∈ splits n k ↔ l.sum = n ∧ l.length = k :=
-- begin
--   sorry
-- end

/-- Functions defined only on s, which sum to n. In other words, a partition of n indexed by s. -/
def cut {ι : Type*} (s : finset ι) (n : ℕ) : finset (ι → ℕ) :=
finset.filter (λ f, s.sum f = n) ((s.pi (λ _, range (n+1))).map
  ⟨λ f i, if h : i ∈ s then f i h else 0,
   λ f g h, by { ext i hi, simpa [dif_pos hi] using congr_fun h i }⟩)

lemma mem_cut {ι : Type*} (s : finset ι) (n : ℕ) (f : ι → ℕ) :
  f ∈ cut s n ↔ s.sum f = n ∧ ∀ i ∉ s, f i = 0 :=
begin
  rw [cut, mem_filter, and_comm, and_congr_right],
  intro h,
  rw [mem_map],
  simp only [exists_prop, function.embedding.coe_fn_mk, mem_pi],
  split,
  { rintro ⟨_, _, rfl⟩ _ _,
    simp [dif_neg H] },
  { intro hf,
    refine ⟨λ i hi, f i, λ i hi, _, _⟩,
    { rw [mem_range, nat.lt_succ_iff, ← h],
      apply single_le_sum _ hi,
      simp },
    { ext,
      split_ifs with q,
      { refl },
      { apply (hf _ q).symm } } }
end

@[simp]
lemma cut_zero {ι : Type*} (s : finset ι) :
  cut s 0 = {0} :=
begin
  ext f,
  rw [mem_cut, mem_singleton, function.funext_iff, sum_eq_zero_iff],
  split,
    rintro ⟨h₁, h₂⟩,
    intro a,
    by_cases (a ∈ s),
      apply h₁ a h,
    apply h₂ a h,
  intro h,
  exact ⟨λ a _, h _, λ a _, h _⟩,
end

@[simp]
lemma cut_empty_succ {ι : Type*} (n : ℕ) :
  cut (∅ : finset ι) (n+1) = ∅ :=
begin
  apply eq_empty_of_forall_not_mem,
  intros x hx,
  rw [mem_cut, sum_empty] at hx,
  cases hx.1,
end

lemma cut_insert {ι : Type*} (n : ℕ) (a : ι) (s : finset ι) (h : a ∉ s) :
  cut (insert a s) n = (nat.antidiagonal n).bind (λ (p : ℕ × ℕ), (cut s p.snd).map ⟨λ f, f + λ t, if t = a then p.fst else 0, add_left_injective _⟩) :=
begin
  ext f,
  rw [mem_cut, mem_bind, sum_insert h],
  split,
  { rintro ⟨rfl, h₁⟩,
    simp only [exists_prop, function.embedding.coe_fn_mk, mem_map, nat.mem_antidiagonal, prod.exists],
    refine ⟨f a, s.sum f, rfl, λ i, if i = a then 0 else f i, _, _⟩,
    { rw [mem_cut],
      refine ⟨_, _⟩,
      { rw [sum_ite],
        have : (filter (λ x, x ≠ a) s) = s,
          apply filter_true_of_mem,
          rintro i hi rfl,
          apply h hi,
        simp [this] },
      { intros i hi,
        split_ifs,
        { refl },
        { apply h₁ ,
          simpa [not_or_distrib, hi] } } },
    { ext,
      by_cases (x = a),
      { subst h, simp },
      { simp [if_neg h] } } },
  { simp only [mem_insert, function.embedding.coe_fn_mk, mem_map, nat.mem_antidiagonal, prod.exists,
               exists_prop, mem_cut, not_or_distrib],
    rintro ⟨p, q, rfl, g, ⟨rfl, hg₂⟩, rfl⟩,
    refine ⟨_, _⟩,
    { simp [sum_add_distrib, if_neg h, hg₂ _ h, add_comm] },
    { rintro i ⟨h₁, h₂⟩,
      simp [if_neg h₁, hg₂ _ h₂] } }
end

lemma coeff_prod_range [comm_semiring α] {ι : Type*} (s : finset ι) (f : ι → power_series α) (n : ℕ) :
  coeff α n (∏ j in s, f j) = ∑ l in cut s n, ∏ i in s, coeff α (l i) (f i) :=
begin
  revert n,
  apply finset.induction_on s,
    rintro ⟨_ | n⟩,
      simp,
    simp [cut_empty_succ, if_neg (nat.succ_ne_zero _)],
  intros a s hi ih n,
  rw [cut_insert _ _ _ hi, prod_insert hi, coeff_mul, sum_bind],
  { apply sum_congr rfl _,
    simp only [prod.forall, sum_map, pi.add_apply, function.embedding.coe_fn_mk, nat.mem_antidiagonal],
    rintro i j rfl,
    simp only [prod_insert hi, if_pos rfl],
    rw ih,
    rw mul_sum,
    apply sum_congr rfl _,
    intros x hx,
    rw mem_cut at hx,
    rw [hx.2 a hi, zero_add],
    congr' 1,
    apply prod_congr rfl,
    intros k hk,
    rw [if_neg, add_zero],
    rintro rfl,
    apply hi hk },
  { simp only [prod.forall, not_and, ne.def, nat.mem_antidiagonal, disjoint_left, mem_map,
               exists_prop, function.embedding.coe_fn_mk, exists_imp_distrib, not_exists],
    rintro p₁ q₁ rfl p₂ q₂ h t p q ⟨hq, rfl⟩ p hp z,
    rw mem_cut at hp hq,
    have := sum_congr (eq.refl s) (λ x _, function.funext_iff.1 z x),
    have : q₂ = q₁,
      simpa [sum_add_distrib, hp.1, hq.1, if_neg hi] using this,
    subst this,
    have : p₂ = p₁,
      simpa using h,
    subst this,
    apply t,
    refl }
end

def indicator_series (α : Type*) [semiring α] (f : set ℕ) : power_series α :=
power_series.mk (λ n, if f n then 1 else 0)

lemma coeff_indicator (f : set ℕ) [semiring α] (n : ℕ) :
  coeff α n (indicator_series _ f) = if f n then 1 else 0 :=
coeff_mk _ _
lemma coeff_indicator_pos (f : set ℕ) [semiring α] (n : ℕ) (h : f n):
  coeff α n (indicator_series _ f) = 1 :=
by rw [coeff_indicator, if_pos h]
lemma coeff_indicator_neg (f : set ℕ) [semiring α] (n : ℕ) (h : ¬f n):
  coeff α n (indicator_series _ f) = 0 :=
by rw [coeff_indicator, if_neg h]
lemma constant_coeff_indicator (f : set ℕ) [semiring α] :
  constant_coeff α (indicator_series _ f) = if f 0 then 1 else 0 :=
by rw [← coeff_zero_eq_constant_coeff_apply, coeff_indicator]

lemma two_series (i : ℕ) :
  (1 + (X : power_series ℚ)^i.succ) = indicator_series ℚ {0, i.succ} :=
begin
  ext,
  simp only [coeff_indicator, coeff_one, add_monoid_hom.map_add, coeff_X_pow,
             ← @set.mem_def _ _ {0, i.succ}, set.mem_insert_iff, set.mem_singleton_iff],
  by_cases n = 0,
    cases h,
    simp [(nat.succ_ne_zero i).symm],
  simp [h],
end

lemma num_series' [field α] (i : ℕ) :
  (1 - (X : power_series α)^(i+1))⁻¹ = indicator_series α (λ k, i + 1 ∣ k) :=
begin
  rw power_series.inv_eq_iff,
  { ext,
    cases n,
    { simp [mul_sub, zero_pow, constant_coeff_indicator] },
    { rw [coeff_one, if_neg (nat.succ_ne_zero n), mul_sub, mul_one, add_monoid_hom.map_sub,
          coeff_indicator],
      simp_rw [coeff_mul, coeff_X_pow, coeff_indicator, boole_mul, sum_ite, filter_filter,
               sum_const_zero, add_zero, sum_const, nsmul_eq_mul, mul_one, sub_eq_iff_eq_add,
               zero_add, filter_congr_decidable],
      symmetry,
      split_ifs,
      { suffices : ((nat.antidiagonal n.succ).filter (λ (a : ℕ × ℕ), i + 1 ∣ a.fst ∧ a.snd = i + 1)).card = 1,
          rw this, norm_cast,
        rw card_eq_one,
        cases h with p hp,
        refine ⟨((i+1) * (p-1), i+1), _⟩,
        ext ⟨a₁, a₂⟩,
        simp only [mem_filter, prod.mk.inj_iff, nat.mem_antidiagonal, mem_singleton],
        split,
        { rintro ⟨_, ⟨a, rfl⟩, rfl⟩,
          refine ⟨_, rfl⟩,
          rw [nat.mul_sub_left_distrib, ← hp, ← a_left, mul_one, nat.add_sub_cancel] },
        { rintro ⟨rfl, rfl⟩,
          cases p,
            rw mul_zero at hp, cases hp,
          rw hp,
          simp [nat.succ_eq_add_one, mul_add] } },
      { suffices : (filter (λ (a : ℕ × ℕ), i + 1 ∣ a.fst ∧ a.snd = i + 1) (nat.antidiagonal n.succ)).card = 0,
          rw this, norm_cast,
        rw card_eq_zero,
        apply eq_empty_of_forall_not_mem,
        simp only [prod.forall, mem_filter, not_and, nat.mem_antidiagonal],
        rintro _ h₁ h₂ ⟨a, rfl⟩ rfl,
        apply h,
        simp [← h₂] } } },
  { simp [zero_pow] },
end

lemma num_series (i : ℕ) :
  (1 - (X : power_series ℚ)^(i+1))⁻¹ = indicator_series ℚ (λ k, ∃ p, (i+1) * p = k) :=
begin
  rw power_series.inv_eq_iff,
  ext,
  cases n,
  { simp [mul_sub, zero_pow, constant_coeff_indicator] },
  { simp [nat.succ_ne_zero n, mul_sub, coeff_indicator],
    split_ifs,
    { cases h,
      simp [coeff_mul, coeff_X_pow, coeff_indicator, sum_ite, filter_filter],
      suffices : filter (λ (a : ℕ × ℕ), (∃ (p : ℕ), (i+1) * p = a.fst) ∧ a.snd = i + 1) (nat.antidiagonal n.succ) = {((i + 1) * (h_w - 1), i + 1)},
        rw this, simp,
      rw eq_singleton_iff_unique_mem,
      split,
        simp only [mem_filter, and_true, eq_self_iff_true, nat.mem_antidiagonal, exists_apply_eq_apply],
        cases h_w,
        { rw mul_zero at h_h, cases h_h },
        { simpa using h_h },
      rintro ⟨_, _⟩,
      simp only [and_imp, mem_filter, prod.mk.inj_iff, nat.mem_antidiagonal, exists_imp_distrib],
      rintro _ _ rfl rfl,
      refine ⟨_, rfl⟩,
      rw [nat.mul_sub_left_distrib, h_h, ← a, mul_one, nat.add_sub_cancel] },
    { simp [coeff_mul, coeff_X_pow, coeff_indicator, sum_ite, filter_filter],
      apply eq_empty_of_forall_not_mem,
      simp,
      rintro _ _ _ _ rfl _,
      subst a_3,
      apply h,
      refine ⟨x + 1, _⟩,
      simpa } },
  simp [zero_pow],
end

lemma card_eq_of_bijection {β : Type*} {s : finset α} {t : finset β}
  (f : α → β)
  (hf : ∀ a ∈ s, f a ∈ t)
  (hsurj : ∀ b ∈ t, ∃ (a ∈ s), f a = b)
  (hinj : ∀ a₁ a₂ ∈ s, f a₁ = f a₂ → a₁ = a₂) :
s.card = t.card :=
begin
  have : s.image f = t,
    ext, simp only [mem_image, exists_prop],
    split,
    rintro ⟨i, hi, rfl⟩,
    apply hf,
    apply hi,
    simpa using hsurj a,
  rw ← this,
  rw card_image_of_inj_on,
  intros,
  apply hinj; assumption,
end

lemma sum_multiset_count [decidable_eq α] [add_comm_monoid α] (s : multiset α) :
  s.sum = ∑ m in s.to_finset, s.count m •ℕ m :=
@prod_multiset_count (multiplicative α) _ _ s

lemma auxy (n : ℕ) (a_blocks : multiset ℕ) (s : finset ℕ)
  -- (a_blocks_pos : ∀ {i : ℕ}, i ∈ a_blocks → 0 < i)
  (a_blocks_sum : a_blocks.sum = n)
  (hp : ∀ (i : ℕ), i ∈ a_blocks → i ∈ s) :
  ∑ (i : ℕ) in s, multiset.count i a_blocks * i = n :=
begin
  rw ← a_blocks_sum,
  rw sum_multiset_count,
  simp_rw nat.nsmul_eq_mul,
  symmetry,
  apply sum_subset_zero_on_sdiff,
  intros i hi,
  apply hp,
  simpa using hi,
  intros,
  rw mem_sdiff at H,
  simp only [multiset.mem_to_finset] at H,
  rw [multiset.count_eq_zero_of_not_mem H.2, zero_mul],
  intros, refl,
end

def mk_odd : ℕ ↪ ℕ := ⟨λ i, 2 * i + 1, λ x y h, by linarith⟩

lemma mem_sum {β : Type*} {f : α → multiset β} (s : finset α) (b : β) :
  b ∈ ∑ x in s, f x ↔ ∃ a ∈ s, b ∈ f a :=
begin
  apply finset.induction_on s,
    simp,
  intros,
  simp [finset.sum_insert a_1, a_2],
  split,
  rintro (_ | ⟨_, _, _⟩),
    refine ⟨a, or.inl rfl, a_3⟩,
  refine ⟨_, or.inr ‹_›, ‹_›⟩,
  rintro ⟨_, (rfl | _), _⟩,
  left, assumption,
  right,
  refine ⟨a_3_w, ‹_›, ‹_›⟩,
end

lemma sum_sum {β : Type*} [add_comm_monoid β] (f : α → multiset β) (s : finset α) :
  multiset.sum (finset.sum s f) = ∑ x in s, (f x).sum :=
(sum_hom s multiset.sum).symm

lemma partial_odd_gf_prop (n m : ℕ) :
  (finset.card ((univ : finset (partition n)).filter (λ p, ∀ j ∈ p.blocks, j ∈ (range m).map mk_odd)) : ℚ) =
    coeff ℚ n (partial_odd_gf m) :=
begin
  simp_rw [partial_odd_gf, num_series],
  erw ← finset.prod_map (range m) mk_odd (λ t, indicator_series ℚ (λ (k : ℕ), ∃ (p : ℕ), t * p = k)),
  simp_rw [coeff_prod_range, coeff_indicator, prod_boole, sum_boole],
  norm_cast,
  refine card_eq_of_bijection _ _ _ _,
  { intros p i, apply multiset.count i p.blocks * i },
  { simp only [mem_cut, mem_filter, mem_univ, true_and, mem_map, exists_prop, not_and,
               mem_range, mul_eq_zero, and_assoc],
    rintro ⟨p, hp₁, hp₂⟩ hp₃,
    refine ⟨_, _, _⟩,
    { rw auxy _ _ _ hp₂,
      simpa using hp₃ },
    { intros i hi,
      left,
      apply multiset.count_eq_zero_of_not_mem,
      exact (λ t, hi (hp₃ i t)) },
    { simp only [and_imp, exists_imp_distrib],
      rintros i x hx rfl,
      exact ⟨_, mul_comm _ _⟩ } },
  { simp only [mem_filter, exists_prop, mem_cut, mem_univ, true_and],
    rintros f ⟨⟨hf₁, hf₂⟩, hf₃⟩,
    refine ⟨⟨∑ i in map mk_odd (range m), multiset.repeat i (f i / i), _, _⟩, _, _⟩,
    { intros i hi,
      simp only [exists_prop, mem_sum, mem_map] at hi,
      rcases hi with ⟨_, ⟨_, _, rfl⟩, _⟩,
      cases multiset.eq_of_mem_repeat hi_h_right,
      apply nat.zero_lt_succ },
    { rw sum_sum,
      simp_rw multiset.sum_repeat,
      have : ∀ i ∈ map mk_odd (range m), i ∣ f i,
        intros i hi, cases hf₃ i hi,
        rw ← h,
        exact dvd.intro w rfl,
      simp_rw nat.nsmul_eq_mul,
      rw sum_congr rfl (λ i hi, nat.div_mul_cancel (this i hi)),
      apply hf₁ },
    { intros j hj,
      rw mem_sum at hj,
      rcases hj with ⟨_, _, _⟩,
      cases multiset.eq_of_mem_repeat hj_h_h,
      assumption },
    { ext i,
      rw ← sum_hom (map mk_odd (range m)) (multiset.count i),
      simp_rw [count_repeat_ite],
      simp only [sum_ite_eq],
      split_ifs,
      { apply nat.div_mul_cancel,
        cases hf₃ i h,
        apply dvd.intro,
        exact h_1 },
      { rw [zero_mul, hf₂ i h] } } },
  { intros p₁ p₂ hp₁ hp₂ h,
    apply partition.ext,
    simp only [true_and, exists_prop, mem_filter, mem_univ] at hp₁ hp₂,
    ext i,
    rw function.funext_iff at h,
    specialize h i,
    cases nat.eq_zero_or_pos i,
    { cases h_1,
      have := hp₁ 0,
      simp [mk_odd] at this,
      have := hp₂ 0,
      simp [mk_odd] at this,
      rw multiset.count_eq_zero_of_not_mem ‹0 ∉ p₁.blocks›,
      rw multiset.count_eq_zero_of_not_mem ‹0 ∉ p₂.blocks› },
    { rwa nat.mul_left_inj at h,
      assumption } }
end

lemma multiset.single_le_sum {a : ℕ} (s : multiset ℕ) :
  a ∈ s → a ≤ s.sum :=
begin
  apply multiset.induction_on s,
    simp,
  rintros b s₁ ih h,
  rw multiset.sum_cons,
  rw multiset.mem_cons at h,
  rcases h with rfl | _,
  exact nat.le.intro rfl,
  apply le_add_left,
  apply ih h,
end

/--  If m is big enough, the partial product's coefficient counts the number of odd partitions -/
theorem odd_gf_prop (n m : ℕ) (h : n < m * 2) :
  (fintype.card (odd_partition n) : ℚ) = coeff ℚ n (partial_odd_gf m) :=
begin
  erw [fintype.subtype_card, ← partial_odd_gf_prop],
  congr' 2,
  apply filter_congr,
  intros p hp,
  apply ball_congr,
  intros i hi,
  have : i ≤ n,
    simpa [p.blocks_sum] using multiset.single_le_sum _ hi,
  simp only [mk_odd, exists_prop, mem_range, function.embedding.coe_fn_mk, mem_map],
  split,
    intro hi₂,
    have := nat.mod_add_div i 2,
    rw nat.not_even_iff at hi₂,
    rw [hi₂, add_comm] at this,
    refine ⟨i / 2, _, ‹_›⟩,
    rw nat.div_lt_iff_lt_mul,
    apply lt_of_le_of_lt ‹i ≤ n› h,
    norm_num,
  rintro ⟨_, _, rfl⟩,
  apply nat.two_not_dvd_two_mul_add_one,
end

lemma partial_distinct_gf_prop (n m : ℕ) :
  (finset.card ((univ : finset (partition n)).filter (λ p, p.blocks.nodup ∧ ∀ j ∈ p.blocks, j ∈ (range m).map ⟨nat.succ, nat.succ_injective⟩)) : ℚ) =
  coeff ℚ n (partial_distinct_gf m) :=
begin
  simp_rw [partial_distinct_gf, two_series],
  erw ← finset.prod_map (range m) ⟨_, nat.succ_injective⟩ (λ t, indicator_series ℚ {0, t}),
  simp_rw [coeff_prod_range, coeff_indicator, prod_boole, sum_boole,
           ← @set.mem_def _ _ {0, _}, set.mem_insert_iff, set.mem_singleton_iff],
  norm_cast,
  refine card_eq_of_bijection _ _ _ _,
  { intros p i, apply multiset.count i p.blocks * i },
  { simp only [mem_filter, mem_cut, mem_univ, true_and, exists_prop, and_assoc,
               and_imp, nat.mul_eq_zero, function.embedding.coe_fn_mk, exists_imp_distrib],
    rintro ⟨p, hp₁, hp₂⟩ hp₃ hp₄,
    refine ⟨_, _, _⟩,
    { rw auxy _ _ _ hp₂,
      apply hp₄ },
    { intros i hi,
      left,
      apply multiset.count_eq_zero_of_not_mem,
      apply mt (hp₄ i) hi },
    { intros i hi,
      rw multiset.nodup_iff_count_le_one at hp₃,
      specialize hp₃ i,
      dsimp at *,
      set k := multiset.count i p with q,
      rw ← q at *,
      interval_cases k,
        left, left, assumption,
      rw h, right, simp }
       },
  { simp only [mem_filter, mem_cut, mem_univ, exists_prop, true_and, and_assoc],
    rintros f ⟨hf₁, hf₂, hf₃⟩,
    refine ⟨⟨∑ i in map ⟨_, nat.succ_injective⟩ (range m), multiset.repeat i (f i / i), _, _⟩, _, _, _⟩,
    { intros i hi,
      simp only [exists_prop, mem_sum, mem_map, function.embedding.coe_fn_mk] at hi,
      rcases hi with ⟨_, ⟨_, _, rfl⟩, _⟩,
      cases multiset.eq_of_mem_repeat hi_h_right,
      exact nat.succ_pos hi_h_left_w },
    { rw sum_sum,
      simp_rw [multiset.sum_repeat, nat.nsmul_eq_mul],
      have : ∀ i ∈ map ⟨_, nat.succ_injective⟩ (range m), i ∣ f i,
      { intros i hi,
        cases hf₃ i hi; rw h,
          exact dvd_zero i },
      { rw sum_congr rfl (λ i hi, nat.div_mul_cancel (this i hi)),
        apply hf₁ } },
    { rw multiset.nodup_iff_count_le_one,
      intro i,
      dsimp,
      rw ← sum_hom _ (multiset.count i),
      simp_rw [count_repeat_ite],
      simp only [sum_ite_eq],
      split_ifs,
      { cases hf₃ i h with h₁ h₁; rw h₁,
          simp,
        cases i,
          simp,
        apply le_of_eq,
        apply nat.div_self,
        exact nat.succ_pos i },
      { norm_num } },
    { intros i hi,
      dsimp at hi,
      rw mem_sum at hi,
      rcases hi with ⟨_, _, _⟩,
      cases multiset.eq_of_mem_repeat hi_h_h,
      assumption },
    { ext i,
      dsimp,
      rw ← sum_hom _ (multiset.count i),
      simp_rw [count_repeat_ite],
      simp only [sum_ite_eq],
      split_ifs,
      { apply nat.div_mul_cancel,
        cases hf₃ i h; rw h_1,
        apply dvd_zero },
      { rw [zero_mul],
        apply (hf₂ i h).symm } } },
  { intros p₁ p₂ hp₁ hp₂ h,
    apply partition.ext,
    simp only [true_and, mem_univ, mem_filter] at hp₁ hp₂,
    ext i,
    rw function.funext_iff at h,
    specialize h i,
    cases i,
    { rw multiset.count_eq_zero_of_not_mem,
      rw multiset.count_eq_zero_of_not_mem,
      intro,
      simpa [nat.succ_ne_zero] using hp₂.2 0 a,
      intro,
      simpa [nat.succ_ne_zero] using hp₁.2 0 a },
    { rwa nat.mul_left_inj at h,
      exact nat.succ_pos i } },
end

/--  If m is big enough, the partial product's coefficient counts the number of distinct partitions -/
theorem distinct_gf_prop (n m : ℕ) (h : n < m + 1) :
  (fintype.card (distinct_partition n) : ℚ) = coeff ℚ n (partial_distinct_gf m) :=
begin
  erw [fintype.subtype_card, ← partial_distinct_gf_prop],
  congr' 2,
  apply filter_congr,
  intros p hp,
  apply (and_iff_left _).symm,
  intros i hi,
  have : i ≤ n,
    simpa [p.blocks_sum] using multiset.single_le_sum _ hi,
  simp only [mk_odd, exists_prop, mem_range, function.embedding.coe_fn_mk, mem_map],
  refine ⟨i-1, _, _⟩,
  rw nat.sub_lt_right_iff_lt_add,
  apply lt_of_le_of_lt ‹i ≤ n› h,
  apply p.blocks_pos hi,
  apply nat.succ_pred_eq_of_pos,
  apply p.blocks_pos hi,
end

lemma same_gf (n : ℕ) :
  partial_odd_gf n * (range n).prod (λ i, (1 - (X : power_series ℚ)^(n+i+1))) = partial_distinct_gf n :=
begin
  rw [partial_odd_gf, partial_distinct_gf],
  induction n with n ih,
  { simp },
  let Z : power_series ℚ := ∏ (x : ℕ) in range n, (1 - X^(2*x+1))⁻¹,
  rw [prod_range_succ _ n, prod_range_succ _ n, prod_range_succ _ n, ← ih],
  clear ih,
  erw ← two_mul (n+1),
  have : 1 - (X : power_series ℚ) ^ (2 * (n+1)) = (1 + X^(n+1)) * (1 - X^(n+1)),
    rw [← sq_sub_sq, one_pow, ← pow_mul, mul_comm],
  rw this, clear this,
  change (_ * Z) * (((1 + X^(n+1)) * _) * _) = (1 + X^(n+1)) * (Z * _),
  rw [mul_assoc, mul_assoc, ← mul_assoc Z, mul_left_comm _ (Z * _), mul_left_comm _ Z,
      ← mul_assoc Z],
  congr' 1,
  have := prod_range_succ' (λ x, 1 - (X : power_series ℚ)^(n.succ + x)) n,
  dsimp at this,
  simp_rw [← add_assoc, add_zero, mul_comm _ (1 - X ^ n.succ)] at this,
  erw [← this],
  rw [prod_range_succ],
  simp_rw [nat.succ_eq_add_one, add_right_comm _ 1, ← two_mul, ← mul_assoc],
  rw [power_series.inv_mul, one_mul],
  simp [zero_pow],
end

lemma coeff_prod_one_add (n : ℕ) [comm_semiring α] (φ ψ : power_series α) (h : ↑n < ψ.order) :
  coeff α n (φ * ψ) = 0 :=
begin
  rw [coeff_mul],
  have : ∑ p in nat.antidiagonal n, (0 : α) = 0,
    rw [sum_const, nsmul_zero],
  rw ← this,
  apply sum_congr rfl _,
  rintros pq hpq,
  apply mul_eq_zero_of_right,
  apply coeff_of_lt_order,
  apply lt_of_le_of_lt _ h,
  rw nat.mem_antidiagonal at hpq,
  norm_cast,
  rw ← hpq,
  apply le_add_left,
  apply le_refl,
end

lemma coeff_prod_one_sub (n : ℕ) [comm_ring α] (φ ψ : power_series α) (h : ↑n < ψ.order) :
  coeff α n (φ * (1 - ψ)) = coeff α n φ :=
by rw [mul_sub, mul_one, add_monoid_hom.map_sub, coeff_prod_one_add _ _ _ h, sub_zero]

lemma same_coeffs (n m : ℕ) (h : m ≤ n) :
  coeff ℚ m (partial_odd_gf n) = coeff ℚ m (partial_distinct_gf n) :=
begin
  rw ← same_gf,
  set! k := n with h,
  apply_fun range at h,
  rw ← h,
  clear_value k, clear h,
  induction k,
    simp,
  rwa [prod_range_succ, ← mul_assoc, mul_right_comm, coeff_prod_one_sub],
  simp only [enat.coe_one, enat.coe_add, order_X_pow],
  norm_cast,
  rw nat.lt_succ_iff,
  apply le_add_right,
  assumption,
end

theorem freek (n : ℕ) : fintype.card (odd_partition n) = fintype.card (distinct_partition n) :=
begin
  suffices : (fintype.card (odd_partition n) : ℚ) = fintype.card (distinct_partition n),
    norm_cast at this, assumption,
  rw distinct_gf_prop _ (n+1),
  rw odd_gf_prop _ (n+1),
  apply same_coeffs,
  linarith,
  linarith,
  linarith,
end


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

! This file was ported from Lean 3 source module algebra.category.Group.preadditive
! leanprover-community/mathlib commit 829895f162a1f29d0133f4b3538f4cd1fb5bffd3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Category.GroupCat.Basic
import Mathlib.CategoryTheory.Preadditive.Basic

/-!
# The category of additive commutative groups is preadditive.
-/

open CategoryTheory

universe u

namespace AddCommGroupCat

-- porting note: this instance was not necessary in mathlib
instance (P Q : AddCommGroupCat) : AddCommGroup (P ⟶ Q) :=
  (inferInstance : AddCommGroup (AddMonoidHom P Q))

-- porting note: this lemma was not necessary in mathlib
@[simp]
lemma hom_add_apply {P Q : AddCommGroupCat} (f g : P ⟶ Q) (x : P) :
  (f + g) x = f x + g x := rfl

section

-- porting note: the simp attribute was locally deactivated here,
-- otherwise Lean would try to infer `Preadditive AddCommGroupCat`
-- in order to prove the axioms `add_comp` and `comp_add` in the
-- next instance declaration
attribute [-simp] Preadditive.add_comp Preadditive.comp_add

instance : Preadditive AddCommGroupCat where

end

end AddCommGroupCat


import .group_representation
import algebra.module
universe variables u v w w' w'' w'''

open linear_map
/--
  a morphism `f : ρ ⟶ᵣ π` between representation is a linear map `f.ℓ : M(ρ) →ₗ[R] M(π)` satisfying
    `f.ℓ ∘   ρ g  = π g  ∘   f.ℓ` has function on `set`.
-/
structure morphism  {G : Type u} [group G] {R : Type v}[ring R]
                    {M : Type w}  [add_comm_group M] [module R M]
                    {M' : Type w'} [add_comm_group M'] [module R M']
                    (ρ : group_representation G R M)
                    (π : group_representation G R M')
  : Type (max w w') :=
      (ℓ       : M →ₗ[R] M')
      (commute : ∀(g : G), ℓ ⊚   ρ g  = π g  ⊚  ℓ)

infixr ` ⟶ᵣ `:25 := morphism

namespace morphism
variables {G : Type u} [group G] {R : Type v}[ring R]
          {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          {ρ : group_representation G R M}
          {ρ' : group_representation G R M'}

@[ext]lemma ext ( f g : ρ ⟶ᵣ ρ') :  f.ℓ  = g.ℓ  → f = g :=
begin
    intros,
    cases f,cases g, congr'; try {assumption},
end

instance : has_coe_to_fun ( ρ ⟶ᵣ ρ') := ⟨_,λ f, f.ℓ.to_fun⟩

lemma coersion (f : ρ ⟶ᵣ ρ') : ⇑f = (f.ℓ) := rfl

theorem commute_apply ( f : ρ ⟶ᵣ  ρ') (x : M) (g : G) : f ( ρ g x) = ρ' g (f x ) :=
begin
      change (f.ℓ  ⊚  ρ g ) x = _,
      rw f.commute, exact rfl,
end

def is_invariant (ρ : group_representation G R M) (ρ' : group_representation G R M')
 (ℓ : M →ₗ[R] M') := ∀(g : G), ℓ ⊚ ρ g   =  ρ' g   ⊚  ℓ

/--
  a constructor of morphism
-/
def to_morphism
(ℓ : M →ₗ[R] M') (commute : is_invariant ρ ρ' ℓ )  : ρ ⟶ᵣ ρ'  := {
  ℓ       := ℓ ,
  commute := λ _, commute _
}
@[simp] lemma to_morphism_coe
(ℓ : M →ₗ[R] M') (commute : is_invariant ρ ρ' ℓ)
: (to_morphism ℓ commute).ℓ = ℓ := rfl

@[simp]lemma of_morphism (f : ρ ⟶ᵣ ρ'  ) : is_invariant ρ ρ' f.ℓ  := λ g, f.commute g

/--
  The identity morphism
-/
def one (ρ : group_representation G R M) : ρ ⟶ᵣ ρ :=
{ ℓ         := linear_map.id,
  commute   := λ g, rfl
}

notation `𝟙` := one

instance : inhabited(ρ ⟶ᵣ ρ ) := { default := 𝟙 ρ }
end morphism

namespace morphism_module
open morphism linear_map
variables {G : Type u} [group G] {R : Type v}[comm_ring R]
          {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          {ρ : group_representation G R M}
          {ρ'  : group_representation G R M'}
variables {M'' : Type w''} [add_comm_group M''] [module R M'']

lemma comp_left_distrib (a : M' →ₗ[R]M'')(b c : M →ₗ[R]M') : a ⊚ (b + c) = a ⊚ b + a ⊚ c := begin
    intros, ext x, erw map_add, exact rfl,
end
lemma comp_smul (r : R) (a : M' →ₗ[R]M'')(b  : M →ₗ[R]M') : a ⊚  (r • b) = r • (a ⊚ b) :=
begin
    intros,ext,erw map_smul, exact rfl,
end
variables (r : R)
variables (f h : ρ ⟶ᵣ ρ')

def add : ρ ⟶ᵣ  ρ' := {
  ℓ       := f.ℓ + h.ℓ ,
  commute :=
    begin
      intros g, rw comp_left_distrib, rw ← f.commute, rw ← h.commute,
       ext, exact rfl,
    end
  }
instance : has_add (ρ ⟶ᵣ ρ') := ⟨add⟩
@[simp] lemma add_coe :  (f+h).ℓ = f.ℓ + h.ℓ := rfl
def neg : ρ ⟶ᵣ ρ' := {
  ℓ       := - f.ℓ,
  commute :=
    begin
       intros g,  ext, change - (f.ℓ  ⊚  ρ g) x = _, erw f.commute,
       change _ = (ρ' g) (- _),
       erw (ρ' g).map_neg,   exact rfl,
    end
  }
instance : has_neg(ρ ⟶ᵣ ρ') := ⟨neg⟩
@[simp] lemma neg_coe :  (-f).ℓ = -f.ℓ := rfl
def zero : ρ ⟶ᵣ ρ' := { ℓ := 0, commute := begin intros g,  ext, simp,end}
instance : has_zero (ρ ⟶ᵣ ρ') := ⟨zero⟩
@[simp] lemma zero_coe :  (0 : ρ ⟶ᵣ ρ').ℓ = 0 := rfl

instance : add_comm_group (ρ ⟶ᵣ ρ') := {
  add           := add   ,
  add_assoc     := begin  intros, apply morphism.ext, repeat {rw add_coe}, rw add_assoc, end,
  zero          := 0,
  zero_add      := begin intros,apply morphism.ext, erw add_coe, rw zero_coe, rw zero_add, end,
  add_zero      := begin intros,apply morphism.ext, erw add_coe, rw zero_coe,rw add_zero,  end,
  neg           := neg ,
  add_left_neg  := begin intros,apply morphism.ext, erw add_coe, rw neg_coe, simp, end,
  add_comm      := begin intros,apply morphism.ext, erw add_coe, rw add_comm, exact rfl,end,
}

def smul (r : R) (f : ρ ⟶ᵣ ρ') : ρ ⟶ᵣ ρ' := {
  ℓ       := r • f.ℓ ,
  commute :=
    begin
      intros g, ext,
      change r •( (f.ℓ ⊚  ρ g) x) = ρ' g (r • f.ℓ x),
      rw f.commute, erw (ρ' g).map_smul, exact rfl,
    end
}
instance : has_scalar R (ρ ⟶ᵣ ρ') := ⟨ smul ⟩
@[simp] lemma coe_smul (r : R):( r • f).ℓ = r • f.ℓ := rfl
instance : module R (ρ ⟶ᵣ ρ') := { smul := smul,
  one_smul  := begin intros, apply morphism.ext, rw coe_smul, rw one_smul, end,
  mul_smul  := begin intros, apply morphism.ext, repeat {rw coe_smul}, rw mul_smul,end,
  smul_add  := begin intros, apply morphism.ext, repeat {rw coe_smul, rw add_coe}, rw smul_add, exact rfl,  end,
  smul_zero := begin intros, apply morphism.ext, repeat {rw coe_smul, rw zero_coe}, rw smul_zero,   end,
  add_smul  := begin intros, apply morphism.ext, repeat {rw coe_smul, rw add_coe}, rw add_smul,exact rfl,  end,
  zero_smul := begin intros, apply morphism.ext, repeat {rw coe_smul, rw zero_coe}, rw zero_smul,   end }

instance : is_add_monoid_hom (@morphism.ℓ  G _ R _ M _ _ M' _ _ ρ ρ' ) := {
  map_add  := add_coe,
  map_zero := zero_coe }
end morphism_module

namespace Ring
variables {G : Type u}[group G]   {R : Type v}[comm_ring R] {M : Type w}
          [add_comm_group M] [module R M]
          {ρ : group_representation G R M}
          (f h : ρ ⟶ᵣ ρ )
open morphism morphism_module
/-
  Make an R algebra ? subalgebra of sub.type ! To check
-/
def mul : ρ ⟶ᵣ  ρ := {
  ℓ       := f.ℓ ⊚  h.ℓ ,
  commute :=
    begin
      intros g,
      rw [comp_assoc, h.commute,  ← comp_assoc,  f.commute,  comp_assoc],
    end
}
instance : has_mul (ρ ⟶ᵣ ρ ) := ⟨mul ⟩
@[simp] lemma mul_coe : ( f * h).ℓ = f.ℓ ⊚  h.ℓ  := rfl
def one : ρ ⟶ᵣ ρ := { ℓ := 1, commute := begin intros g,  ext, simp,end}
instance : has_one (ρ ⟶ᵣ ρ) := ⟨one⟩
@[simp] lemma one_coe :  (1 : ρ ⟶ᵣ ρ).ℓ = 1 := rfl
instance : ring (ρ ⟶ᵣ ρ ) := by refine { add := add,
  add_assoc     := add_assoc,
  zero          := zero,
  zero_add      := zero_add,
  add_zero      := add_zero,
  neg           := neg,
  add_left_neg  := add_left_neg,
  add_comm      := add_comm,
  mul           := mul,
  mul_assoc     := begin intros, apply morphism.ext, repeat {rw mul_coe}, rw comp_assoc,  end,
  one           := one,
  one_mul       := begin intros, apply morphism.ext, erw mul_coe, erw one_coe, erw id_comp,   end,
  mul_one       := begin intros, apply morphism.ext, erw mul_coe, erw one_coe, erw comp_id,   end,
  left_distrib  := begin intros, apply morphism.ext, repeat {erw mul_coe, erw add_coe}, rw comp_left_distrib, exact rfl,  end,
  right_distrib := begin intros, apply morphism.ext, erw mul_coe end,
}

notation `𝟙` := one

end Ring
namespace illustration
variables {G : Type u}[group G]   {R : Type v}[comm_ring R] {M : Type w}
          [add_comm_group M] [module R M]
          {ρ : group_representation G R M}
          (f g : ρ ⟶ᵣ ρ ) (r : R)
example :  f + g  = g + f := add_comm f g

example : (f + g).ℓ = f.ℓ + g.ℓ := by simp
open_locale big_operators
-- il nous faut une instance

lemma sum_coe (X : Type)[fintype X][decidable_eq X] (φ : X → (ρ ⟶ᵣ ρ)) :   (∑ x, φ x).ℓ  =  (∑ x, (φ x).ℓ ) :=
begin
  rw @finset.sum_hom _ _ _ _ _ (finset.univ) φ morphism.ℓ  _ , --- ici c'est moyen car faut vraiment preciser l'instance !
end

lemma sum_apply (X : Type)[fintype X][decidable_eq X] (φ : X → (ρ ⟶ᵣ ρ)) (m : M) :  (∑ x, φ x).ℓ   m =  ∑ x, (φ x).ℓ   m :=
begin
  erw ← sum_apply,
  rw sum_coe,
end
end illustration

namespace Projector
open Ring
variables {G : Type u}[group G]   {R : Type v}[comm_ring R] {M : Type w}
          [add_comm_group M] [module R M]
          {ρ : group_representation G R M}
          (f  : ρ ⟶ᵣ ρ ) (r : R)

/--
  I don't know if it s a good definition.
-/
class is_projector : Prop :=
(idem : f * f = f)

@[simp]lemma idem : is_projector f ↔  f * f = f :=
begin
  split, intros, rw  a.idem, intros, use a,
end

lemma is_projector_ext : is_projector f ↔ f.ℓ ⊚  f.ℓ = f.ℓ  :=
begin
  split,intros, rw ← mul_coe, erw (idem f).mp a, intros, apply (idem f).mpr,
  apply morphism.ext, rw mul_coe, exact a,
end

instance is_projector_zero : is_projector (0 : ρ ⟶ᵣ ρ )   := (idem 0).mpr $ zero_mul _
instance is_projector_one  : is_projector (1 : ρ ⟶ᵣ ρ )   := (idem 1).mpr $ one_mul _

def irreductible :=  ∀ f : ρ ⟶ᵣ ρ , (is_projector f ↔ (f = 0 ∨ f = 1))

end Projector

#lint