/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.sum.basic
import logic.nontrivial

/-!
# Two-pointings

This file defines `two_pointing α`, the type of two pointings of `α`. A two-pointing is the data of
two distinct terms.

This is morally a Type-valued `nontrivial`. Another type which is quite close in essence is `sym2`.
Categorically speaking, `prod` is a cospan in the category of types. This forms the category of
bipointed types. Two-pointed types form a full subcategory of those.

## References

[Coalgebra of the real interval]
[http://nlab-pages.s3.us-east-2.amazonaws.com/nlab/show/coalgebra+of+the+real+interval]
-/

open function

variables {α β : Type*}

/-- Two-pointing of a type. This is a Type-valued termed `nontrivial`. -/
@[ext, derive decidable_eq] structure two_pointing (α : Type*) extends α × α :=
(fst_ne_snd : fst ≠ snd)

namespace two_pointing
variables (p : two_pointing α) (q : two_pointing β)

lemma snd_ne_fst : p.snd ≠ p.fst := p.fst_ne_snd.symm

/-- Swaps the two pointed elements. -/
@[simps] def swap : two_pointing α := ⟨(p.snd, p.fst), p.snd_ne_fst⟩

lemma swap_fst : p.swap.fst = p.snd := rfl
lemma swap_snd : p.swap.snd = p.fst := rfl
@[simp] lemma swap_swap : p.swap.swap = p := by ext; refl

@[reducible] -- See note [reducible non instances]
lemma to_nontrivial : nontrivial α := ⟨⟨p.fst, p.snd, p.fst_ne_snd⟩⟩

instance [nontrivial α] : nonempty (two_pointing α) :=
let ⟨a, b, h⟩ := exists_pair_ne α in ⟨⟨(a, b), h⟩⟩

@[simp] lemma nonempty_two_pointing_iff : nonempty (two_pointing α) ↔ nontrivial α :=
⟨λ ⟨p⟩, p.to_nontrivial, @two_pointing.nonempty _⟩

section pi
variables (α) [nonempty α]

/-- The two-pointing of constant functions. -/
def pi : two_pointing (α → β) :=
{ fst := λ _, q.fst,
  snd := λ _, q.snd,
  fst_ne_snd := λ h, q.fst_ne_snd $ by convert congr_fun h (classical.arbitrary α) }

@[simp] lemma pi_fst : (q.pi α).fst = const α (q.fst) := rfl
@[simp] lemma pi_snd : (q.pi α).snd = const α (q.snd) := rfl

end pi

/-- The product of two two-pointings. -/
def prod : two_pointing (α × β) :=
{ fst := (p.fst, q.fst),
  snd := (p.snd, q.snd),
  fst_ne_snd := λ h, p.fst_ne_snd (congr_arg prod.fst h) }

@[simp] lemma prod_fst : (p.prod q).fst = (p.fst, q.fst) := rfl
@[simp] lemma prod_snd : (p.prod q).snd = (p.snd, q.snd) := rfl

/-- The sum of two pointings. Keeps the first point from the left and the second point from the
right. -/
protected def sum : two_pointing (α ⊕ β) := ⟨(sum.inl (p.fst), sum.inr (q.snd)), sum.inl_ne_inr⟩

@[simp] lemma sum_fst : (p.sum q).fst = sum.inl p.fst := rfl
@[simp] lemma sum_snd : (p.sum q).snd = sum.inr q.snd := rfl

/-- The `ff`, `tt` two-pointing of `bool`. -/
protected def bool : two_pointing bool := ⟨(ff, tt), bool.ff_ne_tt⟩

@[simp] lemma bool_fst : two_pointing.bool.fst = ff := rfl
@[simp] lemma bool_snd : two_pointing.bool.snd = tt := rfl

instance : inhabited (two_pointing bool) := ⟨two_pointing.bool⟩

/-- The `false`, `true` two-pointing of `Prop`. -/
protected def «Prop» : two_pointing Prop := ⟨(false, true), false_ne_true⟩

@[simp] lemma Prop_fst : two_pointing.Prop.fst = false := rfl
@[simp] lemma Prop_snd : two_pointing.Prop.snd = true := rfl

end two_pointing


/-
Copyright (c) 2022 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker
-/
import topology.algebra.uniform_convergence

/-!
# Algebra-related equicontinuity criterions
-/

open function
open_locale uniform_convergence

@[to_additive] lemma equicontinuous_of_equicontinuous_at_one {ι G M hom : Type*}
  [topological_space G] [uniform_space M] [group G] [group M] [topological_group G]
  [uniform_group M] [monoid_hom_class hom G M] (F : ι → hom)
  (hf : equicontinuous_at (coe_fn ∘ F) (1 : G)) :
  equicontinuous (coe_fn ∘ F) :=
begin
  letI : has_coe_to_fun hom (λ _, G → M) := fun_like.has_coe_to_fun,
  rw equicontinuous_iff_continuous,
  rw equicontinuous_at_iff_continuous_at at hf,
  let φ : G →* (ι → M) :=
  { to_fun := swap (coe_fn ∘ F),
    map_one' := by ext; exact map_one _,
    map_mul' := λ a b, by ext; exact map_mul _ _ _ },
  exact continuous_of_continuous_at_one φ hf
end

@[to_additive] lemma uniform_equicontinuous_of_equicontinuous_at_one {ι G M hom : Type*}
  [uniform_space G] [uniform_space M] [group G] [group M] [uniform_group G] [uniform_group M]
  [monoid_hom_class hom G M] (F : ι → hom) (hf : equicontinuous_at (coe_fn ∘ F) (1 : G)) :
  uniform_equicontinuous (coe_fn ∘ F) :=
begin
  letI : has_coe_to_fun hom (λ _, G → M) := fun_like.has_coe_to_fun,
  rw uniform_equicontinuous_iff_uniform_continuous,
  rw equicontinuous_at_iff_continuous_at at hf,
  let φ : G →* (ι → M) :=
  { to_fun := swap (coe_fn ∘ F),
    map_one' := by ext; exact map_one _,
    map_mul' := λ a b, by ext; exact map_mul _ _ _ },
  exact uniform_continuous_of_continuous_at_one φ hf
end


import field_theory.krull_topology
import topology.category.CompHaus.default
import topology.category.Profinite.default

section finite_stuff

variables {K E L : Type*} [field K] [field E] [algebra K E] [field L] [algebra K L]
  [finite_dimensional K E]

noncomputable instance foo {E : Type*} {X : set E} (hX : X.finite) {L : Type*}
  (F : E → multiset L) : fintype (Π x : X, {l : L // l ∈ F x}) :=
by { classical, letI : fintype X := set.finite.fintype hX, exact pi.fintype}

variable (K)

noncomputable def aux_fun1 : E → multiset L :=
λ e, ((minpoly K e).map (algebra_map K L)).roots

lemma minpoly.ne_zero' (e : E) : minpoly K e ≠ 0 :=
minpoly.ne_zero $ is_integral_of_noetherian (is_noetherian.iff_fg.2 infer_instance) _

variable (E)

def basis_set: set E :=
set.range (finite_dimensional.fin_basis K E : _ → E)

variable (L)

-- function from Hom_K(E,L) to pi type Π (x : basis), roots of min poly of x
def aux_fun2 (φ : E →ₐ[K] L) (x : basis_set K E) :
  {l : L // l ∈ (aux_fun1 K x.1 : multiset L)} :=
⟨φ x, begin
  unfold aux_fun1,
  rw [polynomial.mem_roots_map (minpoly.ne_zero' K x.val),
    ← polynomial.alg_hom_eval₂_algebra_map, ← φ.map_zero],
  exact congr_arg φ (minpoly.aeval K (x : E)),
end⟩

lemma aux_inj : function.injective (aux_fun2 K E L) :=
begin
  intros f g h,
  suffices : (f : E →ₗ[K] L) = g,
  { rw linear_map.ext_iff at this,
    ext x, exact this x },
  rw function.funext_iff at h,
  apply linear_map.ext_on (finite_dimensional.fin_basis K E).span_eq,
  rintro e he,
  have := (h ⟨e, he⟩),
  apply_fun subtype.val at this,
  exact this,
end

/-- Given field extensions `E/K` and `L/K`, with `E/K` finite, there are finitely many `K`-algebra
  homomorphisms `E →ₐ[K] L`. -/
noncomputable def its_finite : fintype (E →ₐ[K] L) :=
let n := finite_dimensional.finrank K E in
begin
  let B : basis (fin n) K E := finite_dimensional.fin_basis K E,
  let X := set.range (B : fin n → E),
  have hX : X.finite := set.finite_range ⇑B,
  refine @fintype.of_injective _ _
    (foo hX (λ e, ((minpoly K e).map (algebra_map K L)).roots)) _ (aux_inj K E L),
end

end finite_stuff

open set

lemma ultrafilter.eq_principal_of_fintype (X : Type*) [fintype X]
  (f : ultrafilter X) : ∃ x : X, (f : filter X) = pure x :=
let ⟨x, hx1, (hx2 : (f : filter X) = pure x)⟩ :=
  ultrafilter.eq_principal_of_finite_mem (finite_univ : (univ : set X).finite)
  (filter.univ_mem) in
⟨x, hx2⟩

universe u

noncomputable def alg_hom_of_finite_dimensional_of_ultrafilter
  {K : Type*} {L : Type u} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (h_findim : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) : E →ₐ[K] L :=
classical.some
  (@ultrafilter.eq_principal_of_fintype (E →ₐ[K] L) (its_finite K E L)
  (f.map (λ σ, σ.to_alg_hom.comp (intermediate_field.val E))))

-- f.map ((L ≃ₐ[K] L) → (E →ₐ[K] L)) is generated by
-- alg_hom_of_finite_dimensional_of_ultrafilter_spec h_findim f
lemma alg_hom_of_finite_dimensional_of_ultrafilter_spec {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (h_findim : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) :

(f.map (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val E)) : filter (E →ₐ[K] L)) =
  pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) :=

classical.some_spec
  (@ultrafilter.eq_principal_of_fintype (E →ₐ[K] L) (its_finite K E L)
  (f.map (λ σ, σ.to_alg_hom.comp (intermediate_field.val E))))

-- next five lemmas should be a PR

def intermediate_field.inclusion {K L : Type*} [field K] [field L] [algebra K L]
  {E F : intermediate_field K L} (hEF : E ≤ F):
  E →ₐ[K] F :=
{ to_fun := set.inclusion hEF,
  map_one' := rfl,
  map_add' := λ _ _, rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  commutes' := λ _, rfl }

lemma subalgebra.inclusion_eq_identity {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  {E F : subalgebra R A} (hEF : E ≤ F) (x : E) :
  F.val ((subalgebra.inclusion hEF) x) = E.val x := rfl

lemma subalgebra.val_injective {R A : Type*} [comm_semiring R] [semiring A] [algebra R A] {E : subalgebra R A} :
function.injective E.val := λ x y hxy, subtype.ext hxy

lemma subalgebra.inclusion_mk {R A : Type*} [comm_semiring R] [semiring A] [algebra R A] {E F : subalgebra R A}
(hEF : E ≤ F) {x : A} (hx : x ∈ E) :
(subalgebra.inclusion hEF) ⟨x, hx⟩ = ⟨x, hEF hx⟩ :=
begin
  apply subalgebra.val_injective,
  rw subalgebra.inclusion_eq_identity,
  simp,
end

lemma ultrafilter.map_map {X Y Z: Type*} (m : X → Y) (n : Y → Z) (f : ultrafilter X) :
(f.map m).map n = f.map(n ∘ m) :=
begin
  ext,
  split,
  { intro hs,
    rw [ultrafilter.mem_map, set.preimage_comp, ← ultrafilter.mem_map, ← ultrafilter.mem_map],
    exact hs },
  { intro hs,
    rw [ultrafilter.mem_map, ultrafilter.mem_map, ← set.preimage_comp, ← ultrafilter.mem_map],
    exact hs },
end

lemma ultrafilter.map_pure {X Y : Type*} (x : X) (m : X → Y):
(pure x : ultrafilter X).map m = pure (m x) := rfl

lemma alg_hom_of_finite_dimensional_of_ultrafilter_functor {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (hE : finite_dimensional K E)
  (f : ultrafilter (L ≃ₐ[K] L)) {F : intermediate_field K L} (hF : finite_dimensional K F) (hEF : E ≤ F)
  :
  alg_hom_of_finite_dimensional_of_ultrafilter hE f =
  (alg_hom_of_finite_dimensional_of_ultrafilter hF f).comp (subalgebra.inclusion hEF) :=
  begin
    set p_E :=  (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val E)) with p_E_def,
    set p_F :=  (λ σ : L ≃ₐ[K] L, σ.to_alg_hom.comp (intermediate_field.val F)) with p_F_def,
    set σ_E := alg_hom_of_finite_dimensional_of_ultrafilter hE f with σ_E_def,
    set σ_F := alg_hom_of_finite_dimensional_of_ultrafilter hF f with σ_F_def,
    have hσ_E := alg_hom_of_finite_dimensional_of_ultrafilter_spec hE f,
    rw [← p_E_def, ← σ_E_def] at hσ_E,
    have hσ_F := alg_hom_of_finite_dimensional_of_ultrafilter_spec hF f,
    rw [← p_F_def, ← σ_F_def] at hσ_F,
    set res : (F →ₐ[K] L) → (E →ₐ[K] L) := (λ ϕ, ϕ.comp (subalgebra.inclusion hEF))
    with res_def,
    have h_pF_pE_res : res ∘ p_F = p_E := rfl,
    have h_maps_commute : ((f.map p_F).map res : filter (E →ₐ[K] L)) = f.map p_E,
    { rw [ultrafilter.map_map, h_pF_pE_res] },
    have hEf  := alg_hom_of_finite_dimensional_of_ultrafilter_spec hE f,
    rw [← σ_E_def, ← p_E_def] at hEf,
    have hFf := alg_hom_of_finite_dimensional_of_ultrafilter_spec hF f,
    rw [← σ_F_def, ← p_F_def] at hFf,
    have hFf' : (ultrafilter.map p_F f) = (pure σ_F : ultrafilter (F →ₐ[K] L)),
    { exact ultrafilter.coe_inj.mp hFf },
    rw [hEf, hFf', ultrafilter.map_pure] at h_maps_commute,
    have h := filter.pure_injective h_maps_commute,
    rw res_def at h,
    dsimp at h,
    exact h.symm,
  end

noncomputable def function_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
(L → L) :=
λ x, (alg_hom_of_finite_dimensional_of_ultrafilter
(intermediate_field.adjoin.finite_dimensional (h_int x)) f)
(⟨x, intermediate_field.mem_adjoin_simple_self K x⟩)

lemma function_of_ultrafilter_spec {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) {E : intermediate_field K L}
(hE : finite_dimensional K E) (x : E) :
(function_of_ultrafilter h_int f) x = (alg_hom_of_finite_dimensional_of_ultrafilter hE f) x :=
begin
   have h_le : intermediate_field.adjoin K {(x : L)} ≤ E,
   {
     apply intermediate_field.gc.l_le,
     simp only [set_like.coe_mem, set_like.mem_coe, set.singleton_subset_iff, set.le_eq_subset],
   },
   have h_Kx : finite_dimensional K (intermediate_field.adjoin K {(x : L)}) :=
   intermediate_field.adjoin.finite_dimensional (h_int x),
   let h_functor := alg_hom_of_finite_dimensional_of_ultrafilter_functor h_Kx f hE h_le,
   have h : (function_of_ultrafilter h_int f) x =
   (alg_hom_of_finite_dimensional_of_ultrafilter h_Kx f) ⟨x,
   intermediate_field.mem_adjoin_simple_self K x⟩ := rfl,
   rw [h, h_functor],
   let x_in_Kx : intermediate_field.adjoin K {(x : L)} := ⟨(x : L),
   intermediate_field.mem_adjoin_simple_self K (x : L)⟩,
   have h' : (subalgebra.inclusion h_le) x_in_Kx = x := by
     simp [subalgebra.inclusion_mk h_le (intermediate_field.mem_adjoin_simple_self K (x : L))],
   simp [h'],
end

lemma adj_finset_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
(S : finset L)
(h_int : ∀ (x : L), x ∈ S → is_integral K x) :
finite_dimensional K (intermediate_field.adjoin K (coe S : set L)) :=
begin
  refine intermediate_field.induction_on_adjoin_finset (S) (λ (E : intermediate_field K L),
  finite_dimensional K E) _ _,
  { have temp : (⊥ : intermediate_field K L) = (⊥ : intermediate_field K L) := rfl,
    rw ← intermediate_field.finrank_eq_one_iff at temp,
    refine finite_dimensional.finite_dimensional_of_finrank _,
    rw temp,
    exact zero_lt_one },
  { intros E x hx,
    specialize h_int x hx,
    introI h,
    haveI h2 : finite_dimensional ↥E (↥E)⟮x⟯,
    { apply intermediate_field.adjoin.finite_dimensional,
      exact is_integral_of_is_scalar_tower x h_int },
    change finite_dimensional K ↥(↥E)⟮x⟯,
    exact finite_dimensional.trans K ↥E ↥(↥E)⟮x⟯ },
end

noncomputable def alg_hom_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
(L →ₐ[K] L) :=
{ to_fun := function_of_ultrafilter h_int f,
  map_one' :=
  begin
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h_one_bot : (1 : L) ∈ (⊥: intermediate_field K L) := (⊥ : intermediate_field K L).one_mem,
    have h := function_of_ultrafilter_spec h_int f h_findim_bot (1 : (⊥ : intermediate_field K L)),
    simp at h,
    exact h,
  end,
  map_mul' :=
  begin
    intros x y,
    let E := intermediate_field.adjoin K ({x, y} : set L),
    have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
    have hxE : x ∈ E := h_sub (mem_insert x {y}),
    have hyE : y ∈ E,
    { apply h_sub,
      simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
    have hxyE : x * y ∈ E := E.mul_mem' hxE hyE,
    haveI : decidable_eq L := classical.dec_eq L,
    let S := ({x, y} : finset L),
    have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
    λ a ha, h_int a,
    have hE := adj_finset_finite_dimensional S h_S_int,
    have h_S_coes : (S : set L) = {x, y},
    { simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true] },
    rw h_S_coes at hE,
    change finite_dimensional K E at hE,
    have h : function_of_ultrafilter h_int f x = function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) := rfl,
    change function_of_ultrafilter h_int f (⟨x * y, hxyE⟩ : E) =
    function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) *
    function_of_ultrafilter h_int f (⟨y, hyE⟩ : E),
    rw [function_of_ultrafilter_spec h_int f hE ⟨x, hxE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨y, hyE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨x * y, hxyE⟩],
    have h2 : (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨x, hxE⟩ *
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨y, hyE⟩ =
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) (⟨x, hxE⟩ * ⟨y, hyE⟩),
    { simp only [mul_eq_mul_left_iff, true_or, eq_self_iff_true, map_mul] },
    rw h2,
    refl,
  end,
  map_zero' :=
  begin
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h_zero_bot : (0 : L) ∈ (⊥: intermediate_field K L) := (⊥ : intermediate_field K L).zero_mem,
    have h := function_of_ultrafilter_spec h_int f h_findim_bot (0 : (⊥ : intermediate_field K L)),
    simp at h,
    exact h,
  end,
  map_add' :=
  begin
    intros x y,
    let E := intermediate_field.adjoin K ({x, y} : set L),
    have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
    have hxE : x ∈ E := h_sub (mem_insert x {y}),
    have hyE : y ∈ E,
    { apply h_sub,
      simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
    have hxyE : x + y ∈ E := E.add_mem' hxE hyE,
    haveI : decidable_eq L := classical.dec_eq L,
    let S := ({x, y} : finset L),
    have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
    λ a ha, h_int a,
    have hE := adj_finset_finite_dimensional S h_S_int,
    have h_S_coes : (S : set L) = {x, y},
    { simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true] },
    rw h_S_coes at hE,
    change finite_dimensional K E at hE,
    have h : function_of_ultrafilter h_int f x = function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) := rfl,
    change function_of_ultrafilter h_int f (⟨x + y, hxyE⟩ : E) =
    function_of_ultrafilter h_int f (⟨x, hxE⟩ : E) +
    function_of_ultrafilter h_int f (⟨y, hyE⟩ : E),
    rw [function_of_ultrafilter_spec h_int f hE ⟨x, hxE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨y, hyE⟩,
    function_of_ultrafilter_spec h_int f hE ⟨x + y, hxyE⟩],
    have h2 : (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨x, hxE⟩ +
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) ⟨y, hyE⟩ =
  (alg_hom_of_finite_dimensional_of_ultrafilter hE f) (⟨x, hxE⟩ + ⟨y, hyE⟩),
    { simp },
    rw h2,
    refl,
  end,
  commutes' :=
  begin
    intro r,
    let r' := (algebra_map K L) r,
    have h_findim_bot : finite_dimensional K (⊥ : intermediate_field K L) :=
    intermediate_field.finite_dimensional_bot K L,
    have h : r' ∈ (⊥ : intermediate_field K L) := (⊥ : intermediate_field K L).algebra_map_mem r,
    change function_of_ultrafilter h_int f (⟨r', h⟩ : (⊥ : intermediate_field K L)) =
    (⟨r', h⟩ : (⊥ : intermediate_field K L)),
    rw function_of_ultrafilter_spec h_int f h_findim_bot (⟨r', h⟩ : (⊥ : intermediate_field K L)),
    have h2 : (⟨r', h⟩ : (⊥ : intermediate_field K L)) = (algebra_map K (⊥ : intermediate_field K L)
    r) := rfl,
    rw h2,
    simp,
    refl,
  end }

lemma alg_hom_of_ultrafilter_injective {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (f : ultrafilter (L ≃ₐ[K] L)) :
function.injective (alg_hom_of_ultrafilter h_int f) :=
begin
  intros x y hxy,
  haveI : decidable_eq L := classical.dec_eq L,
  let E := intermediate_field.adjoin K ({x, y} : set L),
  let S := ({x, y} : finset L),
  have h_S_int : ∀ (x : L), x ∈ S → is_integral K x :=
  λ a ha, h_int a,
  have hE := adj_finset_finite_dimensional S h_S_int,
  have h_S_coes : (S : set L) = {x, y},
  { simp only [finset.coe_insert, finset.coe_singleton, eq_self_iff_true] },
  rw h_S_coes at hE,
  change finite_dimensional K E at hE,
  have h_sub : {x, y} ⊆ E.carrier := intermediate_field.gc.le_u_l {x, y},
  have hxE : x ∈ E := h_sub (mem_insert x {y}),
  have hyE : y ∈ E,
  { apply h_sub,
    simp only [set.mem_insert_iff, set.mem_singleton, or_true] },
  change (alg_hom_of_ultrafilter h_int f) (⟨x, hxE⟩ : E) =
  (alg_hom_of_ultrafilter h_int f) (⟨y, hyE⟩ : E) at hxy,
  change (function_of_ultrafilter h_int f) (⟨x, hxE⟩ : E) =
  (function_of_ultrafilter h_int f) (⟨y, hyE⟩ : E) at hxy,
  rw [function_of_ultrafilter_spec h_int f hE (⟨x, hxE⟩ : E),
  function_of_ultrafilter_spec h_int f hE (⟨y, hyE⟩ : E)] at hxy,
  have h : (⟨x, hxE⟩ : E) = (⟨y, hyE⟩ : E),
  { exact ring_hom.injective (alg_hom_of_finite_dimensional_of_ultrafilter hE f).to_ring_hom hxy },
  simp at h,
  exact h,
end

lemma eq_of_map_le {K L : Type*} [field K] [field L] [algebra K L] {E : intermediate_field K L}
{f : L →ₐ[K] L} (h_findim : finite_dimensional K E) (h_map_le : E.map f ≤ E) :
E.map f = E :=
begin
  have hf_inj : function.injective f := ring_hom.injective f.to_ring_hom,
  haveI hE_submod_fin : finite_dimensional K E.to_subalgebra.to_submodule,
  { exact h_findim },
  have h_finrank_eq : finite_dimensional.finrank K (E.map f) =
  finite_dimensional.finrank K E,
  { exact (linear_equiv.finrank_eq (submodule.equiv_map_of_injective (f.to_linear_map)
    hf_inj E.to_subalgebra.to_submodule)).symm },
  have h_submod_le : (E.map f).to_subalgebra.to_submodule ≤ E.to_subalgebra.to_submodule := h_map_le,
  exact intermediate_field.to_subalgebra_eq_iff.mp (subalgebra.to_submodule_injective
  (finite_dimensional.eq_of_le_of_finrank_eq h_map_le h_finrank_eq)),
end

lemma alg_hom_of_ultrafilter_surjective {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
function.surjective (alg_hom_of_ultrafilter h_int f) :=
begin
  intro y,
  specialize h_splits y,
  let p := minpoly K y,
  haveI : decidable_eq L := classical.dec_eq L,
  let S := (p.map (algebra_map K L)).roots.to_finset,
  let E := intermediate_field.adjoin K (S : set L),
  have hE_findim : finite_dimensional K E := adj_finset_finite_dimensional S (λ x hx, h_int x),
  let σ := alg_hom_of_ultrafilter h_int f,
  have hσSS : σ '' S ⊆ S,
  { rintros x ⟨a, ha, hax⟩,
    rw ← hax,
    simp,
    rw polynomial.mem_roots,
    { rw [polynomial.is_root.def, ← polynomial.eval₂_eq_eval_map, ← polynomial.alg_hom_eval₂_algebra_map],
      have hσ0 : σ 0 = 0 := by simp,
      rw ← hσ0,
      apply congr_arg σ,
      simp at ha,
      rw polynomial.mem_roots at ha,
      { rw [polynomial.is_root.def, ← polynomial.eval₂_eq_eval_map] at ha,
        exact ha },
      { exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)) } },
    exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)) },
  have hSE : (S : set L) ⊆ E := intermediate_field.gc.le_u_l (S : set L),
  have hσSE : σ '' S ⊆ E := set.subset.trans hσSS hSE,
  have h1 : E.map σ = intermediate_field.adjoin K (σ '' S) := intermediate_field.adjoin_map K S σ,
  have h2 : intermediate_field.adjoin K (σ '' S) ≤ E,
  { apply intermediate_field.gc.l_le,
    exact hσSE },
  change ∃ (a : L), σ a = y,
  rw ← h1 at h2,
  have h3 := eq_of_map_le hE_findim h2,
  have hyE : y ∈ E,
  { have hyS : y ∈ S,
    { simp,
      rw polynomial.mem_roots,
      { rw [polynomial.is_root.def,
         ← polynomial.eval₂_eq_eval_map,
         ← polynomial.aeval_def],
        exact minpoly.aeval K y },
      { exact polynomial.map_monic_ne_zero (minpoly.monic (h_int y)) } },
    exact hSE hyS },
  rw ← h3 at hyE,
  rcases hyE with ⟨a, ha, hay⟩,
  exact ⟨a, hay⟩,
end

lemma alg_hom_of_ultrafilter_bijection {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
function.bijective (alg_hom_of_ultrafilter h_int f) :=
begin
  exact ⟨alg_hom_of_ultrafilter_injective h_int f,
  alg_hom_of_ultrafilter_surjective h_int h_splits f⟩,
end

noncomputable def equiv_of_ultrafilter {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(L ≃ₐ[K] L) :=
alg_equiv.of_bijective (alg_hom_of_ultrafilter h_int f) (alg_hom_of_ultrafilter_bijection h_int h_splits f)

lemma equiv_of_ultrafilter_to_fun {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(equiv_of_ultrafilter h_int h_splits f).to_fun = function_of_ultrafilter h_int f :=
rfl

lemma equiv_of_ultrafilter_to_alg_hom {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) :
(equiv_of_ultrafilter h_int h_splits f).to_alg_hom = alg_hom_of_ultrafilter h_int f :=
rfl

/-- Let `L/K` be a normal algebraic field extension, let `f` be an ultrafilter on
  `L ≃ₐ[K] L`, and let `E/K` be a finite subextension. Then `equiv_of_ultrafilter h_int h_splits f`
  is a term of `L ≃ₐ[K] L`, and `alg_hom_of_finite_dimensional_of_ultrafilter h_findim f` is a term
  `E →ₐ[K] L`. This Lemma tells us that the underlying maps of these two terms agree on `E`.
    -/
lemma equiv_restricts_to_alg_hom_of_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) (f : ultrafilter (L ≃ₐ[K] L)) {E : intermediate_field K L}
(h_findim : finite_dimensional K E) :
((equiv_of_ultrafilter h_int h_splits f).to_alg_hom.comp E.val) =
alg_hom_of_finite_dimensional_of_ultrafilter h_findim f :=
begin
  ext,
  exact function_of_ultrafilter_spec h_int f h_findim x,
end

def res {K L : Type*} [field K] [field L] [algebra K L] (E : intermediate_field K L):
(L ≃ₐ[K] L) → (E →ₐ[K] L) :=
λ f, f.to_alg_hom.comp E.val

lemma res_eq_map {K L : Type*} [field K] [field L] [algebra K L] {E : intermediate_field K L}
(σ : L ≃ₐ[K] L) (x : E) :
σ x = (res E σ) x :=
begin
  unfold res,
  simp,
end

lemma inv_mul_alg_equiv_of_elem {K L : Type*} [field K] [field L] [algebra K L]
(x : L) (f g : L ≃ₐ[K] L)  :
(f⁻¹ * g) x = x ↔ g x = f x :=
begin
   rw alg_equiv.mul_apply,
   split,
   { intro h,
    have h' := congr_arg f h,
    rw [← alg_equiv.mul_apply, mul_right_inv] at h',
    exact h' },
   { intro h,
    have h' := congr_arg f.symm h,
    rw alg_equiv.symm_apply_apply at h',
    exact h' },
end

lemma top_group_map_nhds_eq {G : Type*} [group G] [topological_space G]
[topological_group G] (g x : G) :
filter.map (λ y, g * y) (nhds x) = nhds (g * x) :=
begin
  ext,
  split,
  { intro h,
    rw [filter.mem_map, mem_nhds_iff] at h,
    rcases h with ⟨U, h_subset, h_open, hxU⟩,
    rw mem_nhds_iff,
    use left_coset g U,
    split,
    { rw ← set.image_subset_iff at h_subset,
      exact h_subset },
    refine ⟨_, ⟨x, ⟨hxU, rfl⟩⟩⟩,
    apply is_open_map_mul_left g,
    exact h_open },
  { intro h,
    rw mem_nhds_iff at h,
    rcases h with ⟨U, h_subset, h_open, hgxU⟩,
    rw [filter.mem_map, mem_nhds_iff],
    use left_coset g⁻¹ U,
    split,
    { rw ← set.image_subset_iff,
      have h : (λ (y : G), g * y) '' left_coset g⁻¹ U = U,
      { ext a,
        refine ⟨_, λ ha, ⟨g⁻¹ * a, ⟨a, ha, rfl⟩, by simp⟩⟩,
        rintro ⟨b, ⟨c, hcU, hcb⟩, hba⟩,
        change g⁻¹ * c = b at hcb,
        change g * b = a at hba,
        rw [← hcb, ← mul_assoc, mul_right_inv, one_mul] at hba,
        rw ← hba,
        exact hcU },
      rw h,
      exact h_subset },
    refine ⟨_, ⟨g * x, hgxU, by simp⟩⟩,
    apply is_open_map_mul_left g⁻¹,
    exact h_open },
end

lemma sigma_is_limit {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x))
(f : ultrafilter (L ≃ₐ[K] L))
(h_le_princ : ↑f ≤ filter.principal
 (set.univ : set (L ≃ₐ[K] L))) :
(f : filter (L ≃ₐ[K] L)) ≤ nhds (equiv_of_ultrafilter h_int h_splits f) :=
begin
  let σ := equiv_of_ultrafilter h_int h_splits f,
  intros A hA,
  have hA_coset : left_coset σ⁻¹ A ∈ nhds (1 : L ≃ₐ[K] L),
  { have h_sigma_1 : σ = σ * 1 := by simp,
    change A ∈ nhds σ at hA,
    rw [h_sigma_1, ← top_group_map_nhds_eq σ 1, filter.mem_map] at hA,
    have h : left_coset σ⁻¹ A = (λ y, σ * y)⁻¹' A,
    { ext,
      split,
      { rintro ⟨a, ha, hax⟩,
        simp [hax.symm, ha] },
      { intro hx,
        rw set.mem_preimage at hx,
        rw [mem_left_coset_iff, inv_inv],
        exact hx } },
    rw h,
    exact hA },
  have hA_coset_cont_H : ∃ (E : intermediate_field K L), finite_dimensional K E
  ∧ E.fixing_subgroup.carrier ⊆ left_coset σ⁻¹ A,
  { rw [group_filter_basis.nhds_one_eq, filter_basis.mem_filter_iff] at hA_coset,
    rcases hA_coset with ⟨H_set, hH, hA_coset⟩,
    change H_set ∈ gal_basis K L at hH,
    rw mem_gal_basis_iff at hH,
    rcases hH with ⟨H, ⟨E, hE, hHE⟩, hHH_set⟩,
    refine ⟨E, hE, _⟩,
    rw [hHE, hHH_set],
    exact hA_coset },
  rcases hA_coset_cont_H with ⟨E, h_findim, hEA⟩,
  have hEA' : left_coset σ E.fixing_subgroup ⊆ A,
  { rintros x ⟨y, hy, hyx⟩,
    change σ * y = x at hyx,
    specialize hEA hy,
    rcases hEA with ⟨a, ha, hay⟩,
    change σ⁻¹ * a = y at hay,
    rw inv_mul_eq_iff_eq_mul at hay,
    rw [← hyx, ← hay],
    exact ha },
  let p : (L ≃ₐ[K] L) → (E →ₐ[K] L) := λ σ, (σ.to_alg_hom.comp E.val),
  have h_principal : f.map p = pure (p σ),
  { have h : p σ = alg_hom_of_finite_dimensional_of_ultrafilter h_findim f :=
    equiv_restricts_to_alg_hom_of_finite_dimensional h_int h_splits f h_findim,
    rw h,
    have h2 : ↑(ultrafilter.map p f) = pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) :=
    alg_hom_of_finite_dimensional_of_ultrafilter_spec h_findim f,
    ext,
    split,
    { intro hs,
      rw [← ultrafilter.mem_coe, h2] at hs,
      exact hs },
    { intro hs,
      rw ultrafilter.mem_pure at hs,
      have h3 : s ∈ (pure (alg_hom_of_finite_dimensional_of_ultrafilter h_findim f) : filter (↥E →ₐ[K] L)),
      { rw filter.mem_pure,
        exact hs },
      rw ← h2 at h3,
      rw ultrafilter.mem_coe at h3,
      exact h3 } },
  have h_small_set : left_coset σ E.fixing_subgroup ∈ f,
  { have h : {p σ} ∈ (pure (p σ) : ultrafilter (E →ₐ[K] L)) := set.mem_singleton (p σ),
    rw [← h_principal, ultrafilter.mem_map] at h,
    have h_preim : p⁻¹' {p σ} = left_coset σ E.fixing_subgroup,
    { ext g,
      split,
      { intro hg,
        rw [set.mem_preimage, set.mem_singleton_iff] at hg,
        rw mem_left_coset_iff,
        intro x,
        have h_g_on_x : g x = (p g) x := res_eq_map g x,
        have h_σ_on_x : σ x = (p σ) x := res_eq_map σ x,
        change (σ⁻¹ * g) x = x,
        rw [inv_mul_alg_equiv_of_elem, h_g_on_x, h_σ_on_x, hg] },
      { intro hg,
        rw [set.mem_preimage, set.mem_singleton_iff],
        ext,
        have h_g_on_x : g x = (p g) x := res_eq_map g x,
        have h_σ_on_x : σ x = (p σ) x := res_eq_map σ x,
        rw [← h_g_on_x, ← h_σ_on_x, ← inv_mul_alg_equiv_of_elem],
        exact (mem_left_coset_iff σ).1 hg x } },
    rw h_preim at h,
    exact h },
  exact f.to_filter.sets_of_superset h_small_set hEA',
end

lemma krull_topology_compact {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x))  :
is_compact (set.univ : set (L ≃ₐ[K] L)) := is_compact_iff_ultrafilter_le_nhds.2
  (λ f hf,  ⟨equiv_of_ultrafilter h_int h_splits f,
  set.mem_univ (equiv_of_ultrafilter h_int h_splits f),
  sigma_is_limit h_int h_splits f hf⟩)

def krull_topology_comphaus {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)):
CompHaus :=
{ to_Top := Top.of (L ≃ₐ[K] L),
  is_compact := {
    compact_univ := krull_topology_compact h_int h_splits},
  is_hausdorff := krull_topology_t2 h_int,
}

def krull_topology_totally_disconnected_space {K L : Type*} [field K] [field L] [algebra K L]
(h_int : ∀ (x : L), is_integral K x) :
totally_disconnected_space (L ≃ₐ[K] L) :=
{ is_totally_disconnected_univ := krull_topology_totally_disconnected h_int}

def krull_topology_profinite {K L : Type*} [field K] [field L] [algebra K L]
(h_int : algebra.is_integral K L) (h_splits : ∀ (x : L), polynomial.splits (algebra_map K L)
(minpoly K x)) :
Profinite :=
{ to_CompHaus := krull_topology_comphaus h_int h_splits,
  is_totally_disconnected := krull_topology_totally_disconnected_space h_int}


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Std.Classes.LawfulMonad
import Dijkstra.Control.Functor.Subreg

import Algdata.Init.Logic
import Algdata.Data.List.Basic

namespace List

--- Apply a predicator to `head` if any, or `True` otherwise
def predHead {α : Type _} (p : α → Prop) : List α → Prop
| [] => True
| (a::_) => p a

def predHead_of_predHead {α : Type _} {p q : α → Prop} : (∀ a, p a → q a) → ∀ {as : List α}, as.predHead p → as.predHead q
| _, [] => λ _ => True.intro
| hpq, (a::_) => hpq a

def relHead {α β : Type _} (r : α → β → Prop) : List α → List β → Prop
| [], _ => True
| (_::_), [] => True
| (a::_), (b::_) => r a b

@[simp]
theorem relHead_nil_left {α β : Type _} {r : α → β → Prop} {bs : List β} : relHead r [] bs = True := rfl

@[simp]
theorem relHead_nil_right {α β : Type _} {r : α → β → Prop} {as : List α} : relHead r as [] = True := by
  cases as <;> rfl

@[simp]
theorem relHead_cons_left {α β : Type _} {r : α → β → Prop} {a : α} {as : List α} {bs : List β} : relHead r (a::as) bs = predHead (r a) bs := by
  cases bs <;> rfl

@[simp]
theorem relHead_cons_right {α β : Type _} {r : α → β → Prop} {as : List α} {b : β} {bs : List β} : relHead r as (b::bs) = predHead (λ a => r a b) as := by
  cases as <;> rfl

theorem relHead_of_trans {α β γ : Type _} {r₁ : α → β → Prop} {r₂ : β → γ → Prop} {r : α → γ → Prop} [Trans r₁ r₂ r] {as : List α} {b : β} {cs : List γ} : as.predHead (λ a => r₁ a b) → cs.predHead (r₂ b) → as.relHead r cs := by
  cases as <;> cases cs <;> intros <;> try {intros; exact True.intro}
  dsimp [relHead]; dsimp [predHead] at *
  exact trans ‹r₁ _ b› ‹r₂ b _›

theorem relHead_eq_predHead_predHead {α β : Type _} {r : α → β → Prop} {as : List α} {bs : List β} : as.relHead r bs = predHead (λ b => as.predHead (flip r b)) bs := by
  cases as <;> cases bs <;> rfl

/-
protected
def runP : List Prop → Prop := foldr And True

section runP

@[simp]
theorem runP_nil : List.runP [] = True := rfl

@[simp]
theorem runP_cons_iff {p : Prop} {ps : List Prop} : List.runP (p::ps) = (p ∧ List.runP ps) :=
  rfl

@[simp]
theorem runP_append {ps qs : List Prop} : List.runP (ps ++ qs) = (List.runP ps ∧ List.runP qs) := by
  induction ps
  case nil => simp
  case cons p ps h_ind => simp [h_ind, and_assoc]

end runP

-/

section forAll

theorem predHead_of_forAll {α : Type _} {p : α → Prop} {as : List α} : as.forAll p → as.predHead p :=
  as.casesOn id (λ _ _ => And.left)

theorem forAll_map_eq {α β : Type _} (p : β → Prop) (f : α → β) {as : List α} : (as.map f).forAll p = as.forAll (p ∘ f) := by
  induction as
  case nil => exact rfl
  case cons a as h_ind =>
    dsimp [List.forAll]
    rw [h_ind]

@[simp]
theorem forAll_append {α : Type _} (p : α → Prop) {as bs : List α} : List.forAll p (as ++ bs) = (List.forAll p as ∧ List.forAll p bs) := by
  induction as
  case nil => dsimp [forAll]; rw [true_and]
  case cons _ _ h_ind => dsimp [forAll]; rw [h_ind, and_assoc]

@[simp]
theorem forAll_reverse {α : Type _} (p : α → Prop) {as : List α} : as.reverse.forAll p = as.forAll p := by
  induction as <;> simp
  -- case nil has been closed
  case cons a as h_ind =>
    dsimp [forAll]
    rw [h_ind, And.comm, and_true]

@[simp]
theorem forAll_reverseAux {α : Type _} (p : α → Prop) {as bs : List α} : List.forAll p (List.reverseAux as bs) = (as.forAll p ∧ bs.forAll p) := by
  have : reverseAux as [] = reverse as := rfl
  rw [reverseAux_eq_append, forAll_append, this, forAll_reverse]

theorem forAll_of_forAll {α : Type _} {p q : α → Prop} : (∀ a, p a → q a) → {as : List α} → List.forAll p as → List.forAll q as
| _, [], _ => True.intro
| hpq, (_::_), hp =>
  And.intro (hpq _ hp.left) $
    forAll_of_forAll hpq hp.right

end forAll

protected
def forAllRel {α β : Type _} (r : α → β → Prop) (as : List α) (bs : List β) : Prop :=
  as.forAll λ a => bs.forAll (r a)

section forAllRel

variable {α β : Type _} {r : α → β → Prop}

@[simp]
theorem forAllRel_nil_left {bs : List β} : List.forAllRel r [] bs = True := rfl

@[simp]
theorem forAllRel_cons_left {a : α} {as : List α} {bs : List β} : List.forAllRel r (a::as) bs =(List.forAll (r a) bs ∧ List.forAllRel r as bs) := by
  simp [List.forAllRel, map, cons_bind, List.forAll]

@[simp]
theorem forAllRel_nil_right {as : List α} : List.forAllRel r as [] = True := by
  induction as
  case nil => rfl
  case cons a as h_ind => dsimp [List.forAllRel, forAll] at *; rw [h_ind, true_and]

@[simp]
theorem forAllRel_cons_right {as : List α} {b : β} {bs : List β} : List.forAllRel r as (b::bs) = (List.forAll (r · b) as ∧ List.forAllRel r as bs) := by
  induction as
  case nil => dsimp [List.forAllRel, forAll]; rw[true_and]
  case cons a as h_ind =>
    rw [forAllRel_cons_left, h_ind]
    dsimp [forAll]
    conv =>
      lhs
      rw [←and_assoc (c:=List.forAllRel _ _ _), and_assoc (a:=r a b), And.comm (a:=List.forAll _ _) (b:=List.forAll _ _), ←and_assoc]
    simp [and_assoc]

@[simp]
theorem forAllRel_of_forAllRel {r₁ : α → β → Prop} : (∀ a b, r a b → r₁ a b) → {as : List α} → {bs : List β} → List.forAllRel r as bs → List.forAllRel r₁ as bs := by
  intro himp as
  induction as <;> simp; intro bs ha has
  -- case nil has been closed
  case cons a as h_ind =>
    constructor
    case left => exact List.forAll_of_forAll (himp a) ha
    case right => exact h_ind has

theorem forAllRel_of_trans_forAll_forAll {α β γ : Type _} {r₁ : α → β → Prop} {r₂ : β → γ → Prop} {r : α → γ → Prop} [Trans r₁ r₂ r] {as : List α} {b : β} {cs : List γ} : as.forAll (r₁ · b) → cs.forAll (r₂ b) → List.forAllRel r as cs := by
  induction as <;> simp
  -- case nil has been closed
  case cons a as h_ind =>
    dsimp [List.forAllRel, forAll]
    intro habsb hbc
    constructor
    case left =>
      exact forAll_of_forAll (λ c (h : r₂ b c) => trans habsb.left h) hbc
    case right =>
      exact h_ind habsb.right hbc

theorem forAllRel_trans {α β γ : Type _} {r₁ : α → β → Prop} {r₂ : β → γ → Prop} {r : α → γ → Prop} [Trans r₁ r₂ r ] {as : List α} {bs : List β} {cs : List γ} : bs ≠ [] → List.forAllRel r₁ as bs → List.forAllRel r₂ bs cs → List.forAllRel r as cs := by
  intro hbs hab hbc
  cases bs
  case nil => exact absurd rfl hbs
  case cons b bs =>
    simp at hab hbc
    exact forAllRel_of_trans_forAll_forAll hab.left hbc.left

@[simp]
theorem forAllRel_flip {as : List α} {bs : List β} : List.forAllRel (flip r) bs as = List.forAllRel r as bs := by
  induction as <;> simp
  -- case nil has been closed
  case cons a as h_ind =>
    rw [h_ind]; exact And.substIff Iff.rfl Iff.rfl

@[simp]
theorem forAllRel_reverse_left {as : List α} {bs : List β} : List.forAllRel r as.reverse bs = List.forAllRel r as bs := by
  induction bs generalizing as <;> simp
  -- case nil has been closed.
  case cons _ _ h_ind =>
    rw [h_ind]; intros; exact Iff.rfl

@[simp]
theorem forAllRel_reverse_right {as : List α} {bs : List β} : List.forAllRel r as bs.reverse = List.forAllRel r as bs:= by
  rw [←forAllRel_flip, ←forAllRel_flip (r:=r)]
  exact forAllRel_reverse_left

end forAllRel

end List


/-
Copyright (c) 2014 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.order.field
import data.nat.basic

/-!
# Cast of naturals

This file defines the *canonical* homomorphism from the natural numbers into a type `α` with `0`,
`1` and `+` (typically an `add_monoid` with one).

## Main declarations

* `cast`: Canonical homomorphism `ℕ → α` where `α` has a `0`, `1` and `+`.
* `bin_cast`: Binary representation version of `cast`.
* `cast_add_monoid_hom`: `cast` bundled as an `add_monoid_hom`.
* `cast_ring_hom`: `cast` bundled as a `ring_hom`.

## Implementation note

Setting up the coercions priorities is tricky. See Note [coercion into rings].
-/

namespace nat
variables {α : Type*}

section
variables [has_zero α] [has_one α] [has_add α]

/-- Canonical homomorphism from `ℕ` to a type `α` with `0`, `1` and `+`. -/
protected def cast : ℕ → α
| 0     := 0
| (n+1) := cast n + 1

/-- Computationally friendlier cast than `nat.cast`, using binary representation. -/
protected def bin_cast (n : ℕ) : α :=
@nat.binary_rec (λ _, α) 0 (λ odd k a, cond odd (a + a + 1) (a + a)) n

/--
Coercions such as `nat.cast_coe` that go from a concrete structure such as
`ℕ` to an arbitrary ring `α` should be set up as follows:
```lean
@[priority 900] instance : has_coe_t ℕ α := ⟨...⟩
```

It needs to be `has_coe_t` instead of `has_coe` because otherwise type-class
inference would loop when constructing the transitive coercion `ℕ → ℕ → ℕ → ...`.
The reduced priority is necessary so that it doesn't conflict with instances
such as `has_coe_t α (option α)`.

For this to work, we reduce the priority of the `coe_base` and `coe_trans`
instances because we want the instances for `has_coe_t` to be tried in the
following order:

 1. `has_coe_t` instances declared in mathlib (such as `has_coe_t α (with_top α)`, etc.)
 2. `coe_base`, which contains instances such as `has_coe (fin n) n`
 3. `nat.cast_coe : has_coe_t ℕ α` etc.
 4. `coe_trans`

If `coe_trans` is tried first, then `nat.cast_coe` doesn't get a chance to apply.
-/
library_note "coercion into rings"
attribute [instance, priority 950] coe_base
attribute [instance, priority 500] coe_trans

-- see note [coercion into rings]
@[priority 900] instance cast_coe : has_coe_t ℕ α := ⟨nat.cast⟩

@[simp, norm_cast] theorem cast_zero : ((0 : ℕ) : α) = 0 := rfl

theorem cast_add_one (n : ℕ) : ((n + 1 : ℕ) : α) = n + 1 := rfl

@[simp, norm_cast, priority 500]
theorem cast_succ (n : ℕ) : ((succ n : ℕ) : α) = n + 1 := rfl

@[simp, norm_cast] theorem cast_ite (P : Prop) [decidable P] (m n : ℕ) :
  (((ite P m n) : ℕ) : α) = ite P (m : α) (n : α) :=
by { split_ifs; refl, }

end

@[simp, norm_cast] theorem cast_one [add_monoid α] [has_one α] : ((1 : ℕ) : α) = 1 := zero_add _

@[simp, norm_cast] theorem cast_add [add_monoid α] [has_one α] (m) : ∀ n, ((m + n : ℕ) : α) = m + n
| 0     := (add_zero _).symm
| (n+1) := show ((m + n : ℕ) : α) + 1 = m + (n + 1), by rw [cast_add n, add_assoc]

@[simp] lemma bin_cast_eq [add_monoid α] [has_one α] (n : ℕ) :
  (nat.bin_cast n : α) = ((n : ℕ) : α) :=
begin
  rw nat.bin_cast,
  apply binary_rec _ _ n,
  { rw [binary_rec_zero, cast_zero] },
  { intros b k h,
    rw [binary_rec_eq, h],
    { cases b; simp [bit, bit0, bit1] },
    { simp } },
end

/-- `coe : ℕ → α` as an `add_monoid_hom`. -/
def cast_add_monoid_hom (α : Type*) [add_monoid α] [has_one α] : ℕ →+ α :=
{ to_fun := coe,
  map_add' := cast_add,
  map_zero' := cast_zero }

@[simp] lemma coe_cast_add_monoid_hom [add_monoid α] [has_one α] :
  (cast_add_monoid_hom α : ℕ → α) = coe := rfl

@[simp, norm_cast] theorem cast_bit0 [add_monoid α] [has_one α] (n : ℕ) :
  ((bit0 n : ℕ) : α) = bit0 n := cast_add _ _

@[simp, norm_cast] theorem cast_bit1 [add_monoid α] [has_one α] (n : ℕ) :
  ((bit1 n : ℕ) : α) = bit1 n :=
by rw [bit1, cast_add_one, cast_bit0]; refl

lemma cast_two {α : Type*} [add_monoid α] [has_one α] : ((2 : ℕ) : α) = 2 := by simp

@[simp, norm_cast] theorem cast_pred [add_group α] [has_one α] :
  ∀ {n}, 0 < n → ((n - 1 : ℕ) : α) = n - 1
| (n+1) h := (add_sub_cancel (n:α) 1).symm

@[simp, norm_cast] theorem cast_sub [add_group α] [has_one α] {m n} (h : m ≤ n) :
  ((n - m : ℕ) : α) = n - m :=
eq_sub_of_add_eq $ by rw [← cast_add, tsub_add_cancel_of_le h]

@[simp, norm_cast] theorem cast_mul [non_assoc_semiring α] (m) : ∀ n, ((m * n : ℕ) : α) = m * n
| 0     := (mul_zero _).symm
| (n+1) := (cast_add _ _).trans $
show ((m * n : ℕ) : α) + m = m * (n + 1), by rw [cast_mul n, left_distrib, mul_one]

@[simp] theorem cast_dvd {α : Type*} [field α] {m n : ℕ} (n_dvd : n ∣ m) (n_nonzero : (n:α) ≠ 0) :
  ((m / n : ℕ) : α) = m / n :=
begin
  rcases n_dvd with ⟨k, rfl⟩,
  have : n ≠ 0, {rintro rfl, simpa using n_nonzero},
  rw nat.mul_div_cancel_left _ (pos_iff_ne_zero.2 this),
  rw [nat.cast_mul, mul_div_cancel_left _ n_nonzero],
end

/-- `coe : ℕ → α` as a `ring_hom` -/
def cast_ring_hom (α : Type*) [non_assoc_semiring α] : ℕ →+* α :=
{ to_fun := coe,
  map_one' := cast_one,
  map_mul' := cast_mul,
  .. cast_add_monoid_hom α }

@[simp] lemma coe_cast_ring_hom [non_assoc_semiring α] : (cast_ring_hom α : ℕ → α) = coe := rfl

lemma cast_commute [non_assoc_semiring α] (n : ℕ) (x : α) : commute ↑n x :=
nat.rec_on n (commute.zero_left x) $ λ n ihn, ihn.add_left $ commute.one_left x

lemma cast_comm [non_assoc_semiring α] (n : ℕ) (x : α) : (n : α) * x = x * n :=
(cast_commute n x).eq

lemma commute_cast [semiring α] (x : α) (n : ℕ) : commute x n :=
(n.cast_commute x).symm

section

variables [ordered_semiring α]

@[simp] theorem cast_nonneg : ∀ n : ℕ, 0 ≤ (n : α)
| 0     := le_refl _
| (n+1) := add_nonneg (cast_nonneg n) zero_le_one

@[mono] theorem mono_cast : monotone (coe : ℕ → α) :=
λ m n h, let ⟨k, hk⟩ := le_iff_exists_add.1 h in by simp [hk]

variable [nontrivial α]

theorem strict_mono_cast : strict_mono (coe : ℕ → α) :=
λ m n h, nat.le_induction (lt_add_of_pos_right _ zero_lt_one)
  (λ n _ h, lt_add_of_lt_of_pos h zero_lt_one) _ h

@[simp, norm_cast] theorem cast_le {m n : ℕ} :
  (m : α) ≤ n ↔ m ≤ n :=
strict_mono_cast.le_iff_le

@[simp, norm_cast, mono] theorem cast_lt {m n : ℕ} : (m : α) < n ↔ m < n :=
strict_mono_cast.lt_iff_lt

@[simp] theorem cast_pos {n : ℕ} : (0 : α) < n ↔ 0 < n :=
by rw [← cast_zero, cast_lt]

lemma cast_add_one_pos (n : ℕ) : 0 < (n : α) + 1 :=
  add_pos_of_nonneg_of_pos n.cast_nonneg zero_lt_one

@[simp, norm_cast] theorem one_lt_cast {n : ℕ} : 1 < (n : α) ↔ 1 < n :=
by rw [← cast_one, cast_lt]

@[simp, norm_cast] theorem one_le_cast {n : ℕ} : 1 ≤ (n : α) ↔ 1 ≤ n :=
by rw [← cast_one, cast_le]

@[simp, norm_cast] theorem cast_lt_one {n : ℕ} : (n : α) < 1 ↔ n = 0 :=
by rw [← cast_one, cast_lt, lt_succ_iff, le_zero_iff]

@[simp, norm_cast] theorem cast_le_one {n : ℕ} : (n : α) ≤ 1 ↔ n ≤ 1 :=
by rw [← cast_one, cast_le]

end

@[simp, norm_cast] theorem cast_min [linear_ordered_semiring α] {a b : ℕ} :
  (↑(min a b) : α) = min a b :=
(@mono_cast α _).map_min

@[simp, norm_cast] theorem cast_max [linear_ordered_semiring α] {a b : ℕ} :
  (↑(max a b) : α) = max a b :=
(@mono_cast α _).map_max

@[simp, norm_cast] theorem abs_cast [linear_ordered_ring α] (a : ℕ) :
  |(a : α)| = a :=
abs_of_nonneg (cast_nonneg a)

lemma coe_nat_dvd [comm_semiring α] {m n : ℕ} (h : m ∣ n) :
  (m : α) ∣ (n : α) :=
ring_hom.map_dvd (nat.cast_ring_hom α) h

alias coe_nat_dvd ← has_dvd.dvd.nat_cast

section linear_ordered_field
variables [linear_ordered_field α]

/-- Natural division is always less than division in the field. -/
lemma cast_div_le {m n : ℕ} : ((m / n : ℕ) : α) ≤ m / n :=
begin
  cases n,
  { rw [cast_zero, div_zero, nat.div_zero, cast_zero] },
  rwa [le_div_iff, ←nat.cast_mul],
  exact nat.cast_le.2 (nat.div_mul_le_self m n.succ),
  { exact nat.cast_pos.2 n.succ_pos }
end

lemma inv_pos_of_nat {n : ℕ} : 0 < ((n : α) + 1)⁻¹ :=
inv_pos.2 $ add_pos_of_nonneg_of_pos n.cast_nonneg zero_lt_one

lemma one_div_pos_of_nat {n : ℕ} : 0 < 1 / ((n : α) + 1) :=
by { rw one_div, exact inv_pos_of_nat }

lemma one_div_le_one_div {n m : ℕ} (h : n ≤ m) : 1 / ((m : α) + 1) ≤ 1 / ((n : α) + 1) :=
by { refine one_div_le_one_div_of_le _ _, exact nat.cast_add_one_pos _, simpa }

lemma one_div_lt_one_div {n m : ℕ} (h : n < m) : 1 / ((m : α) + 1) < 1 / ((n : α) + 1) :=
by { refine one_div_lt_one_div_of_lt _ _, exact nat.cast_add_one_pos _, simpa }

end linear_ordered_field

end nat

namespace prod

variables {α : Type*} {β : Type*} [has_zero α] [has_one α] [has_add α]
  [has_zero β] [has_one β] [has_add β]

@[simp] lemma fst_nat_cast (n : ℕ) : (n : α × β).fst = n :=
by induction n; simp *

@[simp] lemma snd_nat_cast (n : ℕ) : (n : α × β).snd = n :=
by induction n; simp *

end prod

namespace add_monoid_hom

variables {A B : Type*} [add_monoid A]

@[ext] lemma ext_nat {f g : ℕ →+ A} (h : f 1 = g 1) : f = g :=
ext $ λ n, nat.rec_on n (f.map_zero.trans g.map_zero.symm) $ λ n ihn,
by simp only [nat.succ_eq_add_one, *, map_add]

variables [has_one A] [add_monoid B] [has_one B]

lemma eq_nat_cast (f : ℕ →+ A) (h1 : f 1 = 1) :
  ∀ n : ℕ, f n = n :=
congr_fun $ show f = nat.cast_add_monoid_hom A, from ext_nat (h1.trans nat.cast_one.symm)

lemma map_nat_cast (f : A →+ B) (h1 : f 1 = 1) (n : ℕ) : f n = n :=
(f.comp (nat.cast_add_monoid_hom A)).eq_nat_cast (by simp [h1]) _

end add_monoid_hom

namespace monoid_with_zero_hom

variables {A : Type*} [monoid_with_zero A]

/-- If two `monoid_with_zero_hom`s agree on the positive naturals they are equal. -/
@[ext] theorem ext_nat {f g : monoid_with_zero_hom ℕ A}
  (h_pos : ∀ {n : ℕ}, 0 < n → f n = g n) : f = g :=
begin
  ext (_ | n),
  { rw [f.map_zero, g.map_zero] },
  { exact h_pos n.zero_lt_succ, },
end

end monoid_with_zero_hom

namespace ring_hom

variables {R : Type*} {S : Type*} [non_assoc_semiring R] [non_assoc_semiring S]

@[simp] lemma eq_nat_cast (f : ℕ →+* R) (n : ℕ) : f n = n :=
f.to_add_monoid_hom.eq_nat_cast f.map_one n

@[simp] lemma map_nat_cast (f : R →+* S) (n : ℕ) :
  f n = n :=
(f.comp (nat.cast_ring_hom R)).eq_nat_cast n

lemma ext_nat (f g : ℕ →+* R) : f = g :=
coe_add_monoid_hom_injective $ add_monoid_hom.ext_nat $ f.map_one.trans g.map_one.symm

end ring_hom

@[simp, norm_cast] theorem nat.cast_id (n : ℕ) : ↑n = n :=
((ring_hom.id ℕ).eq_nat_cast n).symm

@[simp] theorem nat.cast_with_bot : ∀ (n : ℕ),
  @coe ℕ (with_bot ℕ) (@coe_to_lift _ _ nat.cast_coe) n = n
| 0     := rfl
| (n+1) := by rw [with_bot.coe_add, nat.cast_add, nat.cast_with_bot n]; refl

instance nat.subsingleton_ring_hom {R : Type*} [non_assoc_semiring R] : subsingleton (ℕ →+* R) :=
⟨ring_hom.ext_nat⟩

namespace with_top
variables {α : Type*}

variables [has_zero α] [has_one α] [has_add α]

@[simp, norm_cast] lemma coe_nat : ∀(n : nat), ((n : α) : with_top α) = n
| 0     := rfl
| (n+1) := by { push_cast, rw [coe_nat n] }

@[simp] lemma nat_ne_top (n : nat) : (n : with_top α) ≠ ⊤ :=
by { rw [←coe_nat n], apply coe_ne_top }

@[simp] lemma top_ne_nat (n : nat) : (⊤ : with_top α) ≠ n :=
by { rw [←coe_nat n], apply top_ne_coe }

lemma add_one_le_of_lt {i n : with_top ℕ} (h : i < n) : i + 1 ≤ n :=
begin
  cases n, { exact le_top },
  cases i, { exact (not_le_of_lt h le_top).elim },
  exact with_top.coe_le_coe.2 (with_top.coe_lt_coe.1 h)
end

lemma one_le_iff_pos {n : with_top ℕ} : 1 ≤ n ↔ 0 < n :=
⟨lt_of_lt_of_le (coe_lt_coe.mpr zero_lt_one),
  λ h, by simpa only [zero_add] using add_one_le_of_lt h⟩

@[elab_as_eliminator]
lemma nat_induction {P : with_top ℕ → Prop} (a : with_top ℕ)
  (h0 : P 0) (hsuc : ∀n:ℕ, P n → P n.succ) (htop : (∀n : ℕ, P n) → P ⊤) : P a :=
begin
  have A : ∀n:ℕ, P n := λ n, nat.rec_on n h0 hsuc,
  cases a,
  { exact htop A },
  { exact A a }
end

end with_top

namespace pi

variables {α β : Type*}

lemma nat_apply [has_zero β] [has_one β] [has_add β] :
  ∀ (n : ℕ) (a : α), (n : α → β) a = n
| 0     a := rfl
| (n+1) a := by rw [nat.cast_succ, nat.cast_succ, add_apply, nat_apply, one_apply]

@[simp] lemma coe_nat [has_zero β] [has_one β] [has_add β] (n : ℕ) :
  (n : α → β) = λ _, n :=
by { ext, rw pi.nat_apply }

end pi


import data.fintype data.nat.modeq data.fintype data.set.finite data.nat.prime set_theory.cardinal tactic.norm_num
universe u
variable α : Type u
local attribute [instance,priority 0] classical.prop_decidable
noncomputable theory

open fintype
instance fintype_subtype_of_fintype (α : Type u) (p : α → Prop) [fintype α] : fintype {a // p a}:=begin
  cases _inst_1,
  let s := finset.filter p elems,
  have : ∀ a : α, a ∈ s ↔ p a,
    assume a,simp[s],split,
    exact λ h,h.right,
    exact λ h, ⟨complete a, h⟩,
  exact set.fintype_of_finset s this,
end

lemma fintype_of_injective {α β : Type u} {f : α → β} [fintype β] (h: function.injective f) : fintype α := begin
  unfold function.injective at h,
  have h₁: cardinal.mk α ≤ cardinal.mk β,
    split,split,swap,exact f,exact h,
  have h₂:= cardinal.fintype_card β,
  have h₃:= cardinal.nat_lt_omega (card β),rw h₂ at h₁,
  have h₄ :=lt_of_le_of_lt h₁ h₃,
  rw cardinal.lt_omega_iff_fintype at h₄,
  exact classical.choice h₄,
end

theorem nodup_pair : ∀ a b : α, a ≠ b → list.nodup [a, b] := by simp [list.nodup]

def pair_finset (a b : α) (h : a ≠ b) : finset α := ⟨[a, b], nodup_pair α a b h⟩

theorem involution_parity {α : Type u} {f : α → α} [fintype α] : (∀ x : α, f x ≠ x) → (∀ x : α, f (f x) = x) → 2 ∣ card α := begin
 assume hs hf,
 let s := λ (a : α), pair_finset α a (f a) (hs a).symm,
 have : ∀ u : finset α,  (∀ x : α, x ∈ u → f x ∈ u) → 2 ∣ finset.card u,
  assume u,
  apply finset.strong_induction_on u,
  assume u ht hu,
  cases classical.em (u = finset.empty),
  rw h,simp [finset.card,finset.empty],
  have := finset.exists_mem_of_ne_empty h,
  cases this with x hx,
  let t₁ := s x,
  let t₂ := @set.finite.to_finset α {x | x ∉ t₁ ∧ x ∈ u} ⟨fintype_subtype_of_fintype _ _ ⟩,
  have h2t₂:∀ x : α, x ∈ u → (x ∉ t₁ ↔ x ∈ t₂),
   simp [t₂],assume x hx,exact ⟨λ h,⟨h,hx⟩,λ h,h.left⟩,
  have hxt₁ : x ∈ t₁,
   simp[t₁,s],simp[pair_finset],
  have hfxt₁ : f x ∈ t₁,
   simp[t₁,s,pair_finset],
  have ht₂u : t₂ ⊂ u,
   unfold has_ssubset.ssubset,
   rw finset.subset_iff,
   split, simp[t₂],
   rw [finset.subset_iff,classical.not_forall],
   existsi x,
   rw not_imp,split, exact hx,
   have:=iff.mpr not_not hxt₁,
   exact iff.mp (iff_false_left this) (h2t₂ x hx),
  have h2t₂:(∀ (x : α), x ∈ t₂ → f x ∈ t₂),
   simp[t₂],
   assume x₁ hx₁ hx₁u,split,
   assume hfx₁,
   simp[t₁,s,pair_finset] at hx₁ hfx₁,
   cases hfx₁,
   have := hf x₁,rw hfx₁ at this,
   simp [this.symm] at hx₁,trivial,
   have:=hf x,rw ←hfx₁ at this,
   have j:=hf x₁, rw j at this,
   simp [this] at hx₁, trivial,
   exact hu x₁ hx₁u,
  have:= ht t₂ ht₂u h2t₂,
  have huc : u = insert (f x) (insert x t₂),
   rw finset.ext,
   assume a,split,simp [t₂],
   cases classical.em (a ∈ t₁),
   simp [t₁,s,pair_finset] at h_1,
   assume h_2,
   cases h_1,simp[h_1],
   simp[h_1],simp[h_1],
   assume h, simp[h],
   simp[t₂],assume h,
   cases h,rwa h_1,
   cases h_1,
   rw h_1,exact hu x hx,
   exact h_1.right,
  have hxt₂ : x ∉ t₂,
   simp[t₂],assume h,
   exact absurd hxt₁ h,
  have hfxt₂ : f x ∉ insert x t₂,
   simp[t₂],assume h,
   cases h,
   exact absurd h_1 (hs x),
   exact absurd hfxt₁ h_1.left,
  rw huc,
  rw [finset.card_insert_of_not_mem hfxt₂,finset.card_insert_of_not_mem hxt₂],
  simp,exact iff.mp (nat.dvd_add_iff_right this) (by simp),
 unfold card finset.univ, cases _inst_1,
 have helems: (∀ (x : α), x ∈ elems → f x ∈ elems) := λ x hx, complete (f x),
 have := this elems helems,simp [this],
end

variables (p : ℕ) (hp : nat.prime p) (hp1 : p ≡ 1 [MOD 4])

open int

def S : set (ℕ × ℕ × ℕ) := {x | ((x.1) * (x.1) + 4 * x.2.1 * x.2.2 = ↑p) ∧ 0 < x.1 ∧ 0 < x.2.1 ∧ 0 < x.2.2}

instance fintype_S : fintype (S p) := begin
  have i1 := prod.fintype (fin (p+1)) (fin (p+1)),

  have i := prod.fintype (fin(p+1)) (fin(p+1) × (fin(p+1))),clear i1,
  have hv : ∀ v : ℕ × ℕ × ℕ, v ∈ S p → v.1 < p + 1 ∧ v.2.1 < p + 1 ∧ v.2.2 < (p+1) := λ ⟨x, y, z⟩,begin
    assume h, simp [S] at h,simp,split,
    suffices : x ≤ p,
      exact nat.lt_succ_of_le this,
    cases x,exact absurd h.right.left dec_trivial,rw ←h.left,
    rw [nat.mul_succ,add_comm (nat.succ x * x),add_assoc],
    exact nat.le_add_right _ _,split,
    suffices : y ≤ p,
      exact nat.lt_succ_of_le this,
    cases z,exact absurd h.right.right.right dec_trivial,
    rw [←h.left,nat.mul_succ,nat.succ_mul 3 y,←add_assoc,←add_assoc],
    exact nat.le_add_left _ _,
    suffices : z ≤ p,
      exact nat.lt_succ_of_le this,
    rw [mul_right_comm 4] at h,
    cases y,exact absurd h.right.right.left dec_trivial,
    rw [←h.left,nat.mul_succ,nat.succ_mul 3 z,←add_assoc,←add_assoc],
    exact nat.le_add_left _ _,
  end,
  let f : S p → fin (p+1) × fin (p+1) × fin (p+1) := λ v,⟨⟨v.val.1, (hv v.val v.property).left⟩, ⟨v.val.2.1, (hv v.val v.property).right.left⟩, ⟨v.val.2.2, (hv v.val v.property).right.right⟩⟩,
  have hf : function.injective f,
    assume a b,cases a with a ha, cases b with b hb,
    cases a with a₁ a₂,cases a₂ with a₂ a₃,
    cases b with b₁ b₂,cases b₂ with b₂ b₃,
    simp [f],assume h1 h2 h3,
    have h1 : (⟨a₁, _⟩ : fin (p+1)).val = (⟨b₁, _⟩ : fin (p+1)).val,rw h1,simp at h1,
    have h2 : (⟨a₂, _⟩ : fin (p+1)).val = (⟨b₂, _⟩ : fin (p+1)).val,rw h2,simp at h2,
    have h3 : (⟨a₃, _⟩ : fin (p+1)).val = (⟨b₃, _⟩ : fin (p+1)).val,rw h3,simp at h3,
    simp[h1,h2,h3],
  exact fintype_of_injective hf,
end

def f₁ : (ℕ × ℕ × ℕ) → (ℕ × ℕ × ℕ) := λ ⟨x, y, z⟩, (x, z, y)
def f₂ : (ℕ × ℕ × ℕ) → (ℕ × ℕ × ℕ) := λ ⟨x, y, z⟩, if x + z < y then (x + 2 * z, z, int.nat_abs ((↑y:ℤ) - ↑x - ↑z)) else (if 2 * y < x then (int.nat_abs (↑x - (2:ℤ) * ↑y), int.nat_abs (↑x - ↑y + ↑z), y) else (int.nat_abs (2 * ↑y - ↑x), y, int.nat_abs(x - y + z)))
lemma f₁_S : ∀ x : (ℕ × ℕ × ℕ), x ∈ S p → f₁ x ∈ S p := λ ⟨x, y, z⟩, begin
 simp[S,f₁],rw mul_assoc 4, rw[mul_comm y, ←mul_assoc],assume h hx0 hy0 hz0,exact ⟨h,hx0,hz0,hy0⟩,
end
lemma f₁_invo_on_S : ∀ x : (ℕ × ℕ × ℕ), x ∈ S p → f₁ (f₁ x) = x := λ ⟨x, y, z⟩, by simp[f₁]
lemma nat.sub_sub' (a:ℕ){ b c : ℕ} : c ≤ b → b ≤ a → a - (b - c) = (a - b) + c := begin
  assume h h₁,rw [←int.coe_nat_eq_coe_nat_iff,int.coe_nat_add,int.coe_nat_sub,int.coe_nat_sub,int.coe_nat_sub],simp,
  assumption,assumption,exact le_trans (nat.sub_le b c) h₁,
end

lemma prime_not_square {n :ℕ} : ¬ nat.prime (n^2):=begin
  assume hn,
  unfold nat.pow nat.prime at hn,simp at hn,
  have := hn.right n (dvd_mul_left n n),
  cases this,rw this at hn, simp at hn,
  exact absurd hn dec_trivial,rw ← this at hn,
  have h1 : (↑n:ℤ)≠0, rw ←int.coe_nat_zero,
   assume h, have:=int.coe_nat_inj h,rw this at hn, exact absurd hn.left dec_trivial,
   rw [←int.coe_nat_eq_coe_nat_iff,int.coe_nat_mul] at this,
  have := eq_one_of_mul_eq_self_left h1 this.symm,
  rw ←int.coe_nat_one at this, have:=int.coe_nat_inj this,rw this at hn,
  exact absurd hn.left dec_trivial,
end
lemma eq_one_of_mul_eq_self : ∀ a b :ℕ, a > 0 → a * b = a → b = 1:=begin
  assume a b ha hab,cases b,simp at hab,rw ←hab at ha,exact absurd ha dec_trivial,
  cases b,reflexivity,rw nat.mul_succ at hab,
  have :a * nat.succ b + a - a = a -a,rw hab,
  rw [nat.add_sub_cancel,nat.sub_self] at this,
  have:=nat.eq_zero_of_mul_eq_zero this,cases this,
  rw this_1 at ha,exact absurd ha dec_trivial,
  rw this_1,
end

lemma f₂_S (hp : nat.prime p) (hp1 : p ≡ 1 [MOD 4]) : ∀ x : (ℕ × ℕ × ℕ), x ∈ S p → f₂ x ∈ S p := λ ⟨x, y, z⟩, begin
  unfold f₂ S,assume h,simp at h,
  have gx : -(2 * ((↑x:ℤ) * ↑y)) + (-(2 * (↑x * ↑y))) = - (4 * ((↑x:ℤ) * ↑y)),
    rw [←neg_add,←mul_add (2:ℤ)],
    have : (↑x * ↑y + ↑x * ↑y:ℤ) = 2 * (↑x * ↑y),
      rw [(dec_trivial : (2:ℤ) = 1 + 1),add_mul,one_mul],
    rw [this,←mul_assoc,(dec_trivial : (2:ℤ) * 2 = 4)],

  cases classical.em (x + z < y),
  simp[h_1],split,rw ←h.left,
  have hx : (x + 2 * z) * (x + 2 * z) = x * x + 4 * x * z + 4 * z * z,
    rw[mul_add,add_mul,add_mul],simp[mul_comm,mul_assoc,mul_left_comm],
    rw [(dec_trivial : 2 * 2 = 4),← add_assoc,←mul_assoc x,←add_mul],
    have : x * z + x * z = x * z * 2,rw [nat.mul_succ,mul_one],
    rw this,rw [mul_assoc(x * z),(dec_trivial : 2 * 2 = 4),mul_assoc],

  rw hx,rw [←neg_add,←int.coe_nat_add,←sub_eq_add_neg,←int.coe_nat_sub (le_of_lt h_1),nat_abs_of_nat],
  rw [←nat.sub_sub],

  rw [nat.mul_sub_left_distrib,nat.mul_sub_left_distrib],
  simp[mul_comm,mul_assoc,mul_left_comm],rw[add_comm (z *(z *4)),eq_comm,←add_assoc,←@nat.sub_eq_iff_eq_add _ (z * (z*4)),add_comm (x * (z * 4)),←@nat.sub_eq_iff_eq_add _ (x * (z*4)),nat.sub_sub,nat.sub_sub,add_comm],
  rw ←nat.mul_sub_right_distrib,rw mul_le_mul_right (show z * 4 > 0, from mul_pos h.right.right.right dec_trivial),rw nat.le_sub_right_iff_add_le,exact le_of_lt h_1,
  exact le_of_lt (lt_of_le_of_lt (nat.le_add_left z x) h_1),
  rw mul_le_mul_right,exact le_of_lt (lt_of_le_of_lt (nat.le_add_left z x) h_1),
  exact mul_pos h.right.right.right dec_trivial,split,
  exact lt_of_lt_of_le h.right.left (nat.le_add_right _ _),split,
  exact h.right.right.right,
  have := nat.sub_pos_of_lt h_1,
  rwa [←neg_add,←int.coe_nat_add,←sub_eq_add_neg,←int.coe_nat_sub (le_of_lt h_1),nat_abs_of_nat],
  simp [h_1],
  have hxzy : 0 < ((↑x + (↑z + -↑y)): ℤ),
    rw ←add_assoc, rw ←sub_lt_iff,simp,rw[←int.coe_nat_add,int.coe_nat_lt],cases (lt_or_eq_of_le (le_of_not_gt h_1)),
    assumption,rw h_2 at h,
    have : p= (x + 2 * z)^2,simp [nat.pow],
      rw[add_mul,mul_add,mul_add],rw ←h.left,
      simp,rw [mul_add,add_mul],
      have : 2 * z * (2 * z) = 4 * z * z,
        rw [mul_left_comm,←mul_assoc,←mul_assoc,(dec_trivial : 2 * 2 = 4)],rw this,
      rw ←add_assoc,
      have : x * (2 * z) + 2 * z * x = 4 * x * z,
        rw [mul_left_comm], rw mul_comm x,rw ←mul_assoc, rw ←mul_add,
        have: x + x = 2 * x,rw nat.succ_mul,simp,
        rw this,rw mul_left_comm,rw[←mul_assoc,←mul_assoc, (dec_trivial : 2 * 2 = 4)],rw mul_right_comm,
      rw this,
    rw this at hp,exact absurd hp prime_not_square,
  cases classical.em (2 * y < x),
  have hx2y : 0 < (↑x + -(2 * ↑y): ℤ),
    rw ←sub_lt_iff,simp,have :(2:ℤ) = ↑(2:ℕ),simp,exact dec_trivial,
    rw [this,←int.coe_nat_mul,int.coe_nat_lt],exact h_2,
  simp [h_2],
  split,rw ←h.left,
  rw [←int.coe_nat_eq_coe_nat_iff,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_mul],
  have h_11 := le_of_not_gt h_1,
  rw nat_abs_of_nonneg (int.le_of_lt hxzy),rw nat_abs_of_nonneg (int.le_of_lt hx2y),
  rw [mul_add,mul_add,mul_add,add_mul,add_mul,add_mul,add_mul],have : (4:ℤ) = ↑(4 : ℕ),simp,exact_dec_trivial, rw ←this,
  rw [←add_assoc (↑x * ↑x + -(2 * ↑y) * ↑x:ℤ)],
  simp[mul_comm,mul_assoc,mul_left_comm],

  rw [←add_assoc,gx,neg_add_cancel_left,←mul_assoc (2:ℤ),(dec_trivial : (2:ℤ)*2=4),neg_add_self,add_zero],
  rw [←int.coe_nat_lt,←int.coe_nat_lt,int.coe_nat_zero],
  rw nat_abs_of_nonneg (int.le_of_lt hxzy),rw nat_abs_of_nonneg (int.le_of_lt hx2y),simp [hx2y,hxzy],exact h.right.right.left,

  simp[h_1,h_2,h.right.right.left],
  rw [←int.coe_nat_lt,←int.coe_nat_lt,int.coe_nat_zero],rw nat_abs_of_nonneg (int.le_of_lt hxzy),simp[hxzy],
  have hx2y :0 < (-↑x + 2 * ↑y:ℤ),
    rw add_comm,rw ←sub_lt_iff,simp,
    cases lt_or_eq_of_le (le_of_not_gt h_2),have : ↑(2:ℕ) = (2:ℤ), simp,exact dec_trivial,
    rw ←this,rwa [←int.coe_nat_mul,int.coe_nat_lt],
    rw [h_3,mul_left_comm,←mul_assoc,←mul_assoc, (dec_trivial : 2 * 2 = 4), ←mul_add,mul_assoc] at h,
    have:=dvd_mul_right 4 (y * (y + z)),rw ←nat.modeq.modeq_zero_iff at this,rw h.left at this,
    have := this.symm.trans hp1, exact absurd this dec_trivial,
  rw [←int.coe_nat_lt,int.coe_nat_zero],rw nat_abs_of_nonneg (int.le_of_lt hx2y),
  simp[hx2y],
  rw[←int.coe_nat_eq_coe_nat_iff,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_mul],
  rw [nat_abs_of_nonneg (int.le_of_lt hxzy),nat_abs_of_nonneg (int.le_of_lt hx2y)],
  rw (dec_trivial : ↑4 = (4: ℤ )),
  rw [← h.left,int.coe_nat_add,int.coe_nat_mul,int.coe_nat_mul,int.coe_nat_mul,mul_add,mul_add,mul_add,add_mul,add_mul],
  have : (2:ℤ) * (↑y: ℤ) * (2 * ↑y)  = 4 * ↑y * ↑y,
    rw [mul_left_comm, ←mul_assoc, ←mul_assoc, (dec_trivial : (2:ℤ) * 2 = 4)],
  rw this,
  have : (2:ℤ) * ↑y * -↑x + (-↑x * (2 * ↑y)) = -(4 * ↑x * ↑y),
    simp[mul_comm,mul_assoc,mul_left_comm],rw [←neg_add,←mul_add],
    have : (↑x : ℤ) * ↑ y + ↑x * ↑y = 2 * (↑x * ↑y),
      rw [←one_mul ((↑x:ℤ) * ↑y),←add_mul, (dec_trivial : (1:ℤ) + 1 = 2)],
      simp,
    rw [this,←mul_assoc,(dec_trivial : (2:ℤ) * 2 = 4)],
  rw [add_assoc (-(↑x:ℤ) * -↑x),←add_assoc ((2:ℤ) * ↑y * -↑x),this,←add_assoc ( (4:ℤ) * ↑y * ↑x)],rw ←(dec_trivial : (4 :ℤ)= ↑(4:ℕ) ),
  simp[mul_comm,mul_assoc,mul_left_comm],rw [add_comm ((4:ℤ) * (↑y * ↑z)),add_neg_cancel_left],
end
lemma f₂_invo_on_S : ∀ x : (ℕ × ℕ × ℕ), x ∈ S p → f₂ (f₂ x) = x:= λ⟨x,y,z⟩,begin
  assume h,unfold f₂, simp,simp [S] at h,
  cases classical.em (x + z < y),
  simp[h_1],unfold f₂._match_1,
  cases classical.em (x + 2 * z + nat_abs (↑y + (-↑x + -↑z)) < z),
  simp [h_2],
  rw [←neg_add,←int.coe_nat_add,←sub_eq_add_neg,←int.coe_nat_sub (le_of_lt h_1),nat_abs_of_nat] at *,
  exfalso,
  rw [nat.succ_mul,one_mul,add_left_comm] at h_2,simp only [add_assoc] at h_2,
  exact not_lt_of_ge (nat.le_add_right z (x + (z + (y - (x + z))))) h_2,
  simp[h_2],simp[h.right.left],rw [(dec_trivial : (1:ℤ)+1 =2),add_neg_self,add_zero,nat_abs_of_nat],simp [(rfl:x=x)],

  rw [←neg_add,←int.coe_nat_add,←sub_eq_add_neg,←int.coe_nat_sub (le_of_lt h_1),nat_abs_of_nat,int.coe_nat_sub (le_of_lt h_1),int.coe_nat_add],
  rw [(dec_trivial : (2:ℤ)=1+1),add_mul,one_mul,add_assoc (↑z:ℤ),add_neg_cancel_left,sub_eq_add_neg,add_comm (↑y:ℤ),←add_assoc (↑x:ℤ),add_neg_cancel_left,nat_abs_of_nat],
  simp[h_1],
  have h_11:=le_of_not_gt h_1,
  cases classical.em (2 * y < x),
  simp[h_2],unfold f₂._match_1,
  have h_3 : nat_abs (↑x + -(2 * ↑y)) + y < nat_abs (↑x + (↑z + -↑y)),
    rw[←sub_eq_add_neg,(dec_trivial : (2:ℤ)= ↑2),←int.coe_nat_mul,←int.coe_nat_sub (le_of_lt h_2),nat_abs_of_nat,←sub_eq_add_neg,add_sub,←int.coe_nat_add,←int.coe_nat_sub h_11,nat_abs_of_nat,←nat.sub_add_comm(le_of_lt h_2),nat.succ_mul,one_mul,←nat.sub_sub,nat.add_sub_cancel,nat.lt_sub_left_iff_add_lt h_11,←nat.add_sub_assoc,nat.add_sub_cancel_left],
    rw lt_add_iff_pos_right,exact h.right.right.right,
    rw [nat.succ_mul,one_mul] at h_2,
    exact le_trans (nat.le_add_left y y) (le_of_lt h_2),
  simp[h_3],
  rw[←sub_eq_add_neg,(dec_trivial : (2:ℤ)= ↑2),←int.coe_nat_mul,←int.coe_nat_sub (le_of_lt h_2),nat_abs_of_nat,←nat.add_sub_assoc (le_of_lt h_2),nat.add_sub_cancel_left],simp[(rfl:x=x)],
  rw [←sub_eq_add_neg (↑z:ℤ),←add_sub_assoc,←int.coe_nat_add,←int.coe_nat_sub h_11,nat_abs_of_nat,int.coe_nat_sub,nat.succ_mul,one_mul,int.coe_nat_add,int.coe_nat_sub h_11,int.coe_nat_add],simp,
  rw[add_comm,add_assoc],simp,exact le_of_lt h_2,simp[h_2],
  unfold f₂._match_1,
  have h_21:=le_of_not_gt h_2,
  have h_211 : x ≤ y + y,
    rwa [nat.succ_mul,one_mul]at h_21,
  rw[←sub_eq_add_neg,(dec_trivial : (2:ℤ)= ↑2),←int.coe_nat_mul,←int.coe_nat_sub h_21,nat_abs_of_nat,←sub_eq_add_neg,←add_sub_assoc,←int.coe_nat_add,←int.coe_nat_sub h_11,nat_abs_of_nat,nat.succ_mul,one_mul,←nat.add_sub_assoc h_11,←nat.sub_add_comm h_211,add_comm x,←add_assoc,nat.add_sub_cancel,add_right_comm,nat.add_sub_cancel],
  simp[not_lt_of_ge (nat.le_add_right y z)],simp[not_lt_of_ge (nat.sub_le (y+y) x)],
  rw[int.coe_nat_sub h_211,int.coe_nat_add,int.coe_nat_sub h_11],simp,rw [add_comm((↑z:ℤ)), add_neg_cancel_left,nat_abs_of_nat],
end
lemma f₂_fixed_point (hp : nat.prime p) (hp1 : p ≡ 1 [MOD 4]) : ∃! x : (ℕ × ℕ × ℕ), x ∈ S p ∧ f₂ x = x := begin

  existsi (1,1,(p/4)),simp [S],unfold nat.modeq at hp1,simp[(dec_trivial:1%4=1)] at hp1,
  have hp₁:=nat.mod_add_div p 4,rw hp1 at hp₁,simp[hp₁],
  simp[(dec_trivial : 0<1)],
  have : 0 < p / 4,
    apply by_contradiction,
    assume h,have h₁:=nat.eq_zero_of_le_zero (le_of_not_gt h),simp[h₁] at hp₁,rw ←hp₁ at hp,
    exact absurd (nat.prime.gt_one hp) dec_trivial,
  simp[this],unfold f₂,
  have : ¬(1 + p / 4 < 1),
    rw [nat.one_add],assume h,
    have:=nat.lt_of_succ_lt_succ h,
    exact not_lt_of_ge (nat.zero_le (p/4)) this,
  simp[this],
  simp[(dec_trivial:¬2<1)],
  simp[(dec_trivial:nat_abs (2 + -1) = 1)],
  assume x y,cases y with y z,simp,
  assume h hx hy hz,
  unfold f₂._match_1,
  assume hb,
  cases classical.em (x + z < y),
  simp[h_1] at hb,rw ←add_zero x at hb,
  have:=add_left_cancel hb.left,
  rw [nat.succ_mul,one_mul] at this,
  have:=nat.eq_zero_of_add_eq_zero this,rw this.left at hz,
  exact absurd hz dec_trivial,simp[h_1] at hb,
  cases classical.em (2 * y < x),
  simp [h_2] at hb,
  rw [(dec_trivial : (2:ℤ) = ↑2),←int.coe_nat_mul,←sub_eq_add_neg,←int.coe_nat_sub (le_of_lt h_2),nat_abs_of_nat] at hb,
  rw nat.sub_eq_iff_eq_add (le_of_lt h_2) at hb,
  rw [←add_zero x] at hb,
  have:=add_left_cancel hb.left,
  rw [nat.succ_mul,one_mul] at this,
  have:=nat.eq_zero_of_add_eq_zero this.symm,rw this.left at hy,
  exact absurd hy dec_trivial,
  simp[h_2] at hb,
  have h_3 := le_of_not_gt h_2,
  rw [(dec_trivial : (2:ℤ) = ↑2),←int.coe_nat_mul,←sub_eq_add_neg,←int.coe_nat_sub h_3,nat_abs_of_nat] at hb,
  rw nat.sub_eq_iff_eq_add h_3 at hb,
  have hyx : y=x,
    have : 2 * y = 2 * x,
      rw [nat.succ_mul 1 x,one_mul] , exact hb.left,
    have : (2 * y) / 2 = (2 * x) / 2,
      rw this,
    rwa [nat.mul_div_cancel_left _ (dec_trivial:2>0),nat.mul_div_cancel_left _ (dec_trivial:2>0)] at this,
  rw [hyx, mul_comm 4,mul_assoc,←mul_add] at h,
  have:=dvd_mul_right x (x + 4 * z),rw h at this,have:=hp.right x this,
  cases this,rw hyx, simp[this_1],rw this_1 at h,simp at h,rw ←hp₁ at h,simp at h,
  have : (4*z)/4 = (4*(p/4)/4),
    rw h,
  rwa [nat.mul_div_cancel_left _ (dec_trivial:4>0),nat.mul_div_cancel_left _ (dec_trivial:4>0)] at this,
  rw this_1 at h,
  exfalso,
  have:=eq_one_of_mul_eq_self p (p+4*z) (nat.prime.pos hp) h,
  have h:= nat.le_add_right p (4*z),rw this at h,
  exact absurd h (not_le_of_gt (nat.prime.gt_one hp)),
end
theorem fermat_sum_two_squares {p : ℕ} : nat.prime p → p ≡ 1 [MOD 4] → ∃ a b : ℕ, a^2 + b^2 = p := begin
  assume hp hp1,have : card (S p) ≡ 1 [MOD 2],
  cases (f₂_fixed_point p hp hp1) with x hx,
  let s := {y : (ℕ × ℕ × ℕ) | y ≠ x ∧ y ∈ S p},
  have is : fintype s,
    let f : {y : (ℕ × ℕ × ℕ) | y ≠ x ∧ y ∈ S p} → S p := λ y, ⟨y,begin cases y,simp at y_property,simp[subtype.coe_mk],exact y_property.right,end⟩,
    have : function.injective f,
      assume a b,simp[f],cases a, cases b,simp [subtype.coe_mk],
    simp[s],
    exact fintype_of_injective this,
  have hx₁:(x ∈ S p ∧ f₂ x = x) ∧ ∀ (y : ℕ × ℕ × ℕ), ( y ∈ S p ∧ f₂ y = y) → y = x := hx,clear hx,
  let f₂' : {y : (ℕ × ℕ × ℕ) | y ≠ x ∧ y ∈ S p} → {y : (ℕ × ℕ × ℕ) | y ≠ x ∧ y ∈ S p} := λ y, ⟨f₂ y,begin simp,split,
    intro,have:= hx₁.left.right,rw ←a at this,cases y,
    simp only [subtype.coe_mk] at *,simp at y_property,
    have t₁:= f₂_invo_on_S p y_val y_property.right,rw [←this,t₁] at a,exact y_property.left a,
    cases y,simp at y_property,
    simp[subtype.coe_mk],exact f₂_S p hp hp1 y_val y_property.right,
      end⟩,
    have hf₁1: ∀ y : ↥{y : ℕ × ℕ × ℕ | y ≠ x ∧ y ∈ S p}, f₂' y ≠ y,
      assume y,
      cases y,simp[subtype.coe_mk],simp at y_property,assume hy,
      exact y_property.left (hx₁.right y_val ⟨y_property.right, hy⟩),
    have hf₁2: ∀ y : ↥{y : ℕ × ℕ × ℕ | y ≠ x ∧ y ∈ S p}, f₂' (f₂' y) = y,
      assume y,cases y, simp[subtype.coe_mk,f₂'],
      exact f₂_invo_on_S p y_val y_property.right,
    have := involution_parity hf₁1 hf₁2,
    have hx₂ : x ∉ {y : ℕ × ℕ × ℕ | y ≠ x ∧ y ∈ S p},
      simp,
    have i : set.finite s := ⟨is⟩,
    let i₁ := set.finite.to_finset i,
    have hx₂ : x ∉ i₁, simp [i₁],
    have hi₁:=finset.card_insert_of_not_mem hx₂,
    have hi₁2 : ∀ y :  ℕ × ℕ × ℕ , y ∈ i₁ ↔ y ∈ s,assume y,
      simp [i₁],
    have h := set.card_fintype_of_finset' i₁ hi₁2,
    rw ←h at hi₁,
    have h₂: ∀ y : ℕ × ℕ × ℕ, y ∈ insert x i₁ ↔ y ∈ S p,assume y,simp,
      split,
      assume h,cases h,
      rw h_1, exact hx₁.left.left,
      exact h_1.right,
      assume h,
      cases classical.em (y=x),
      exact or.inl h_1,
      exact or.inr ⟨h_1,h⟩,
    rw ←set.card_fintype_of_finset' _ h₂ at hi₁,rw hi₁,
    suffices h : card ↥s ≡ 0 [MOD 2],
    exact nat.modeq.modeq_add h (nat.modeq.refl 1),
    rw nat.modeq.modeq_zero_iff,simp[s],
    exact this,
  let f₁' : (S p) →  S p := λ y, ⟨f₁ (↑y : ℕ × ℕ × ℕ),begin cases y,simp [subtype.coe_mk],
    exact f₁_S p y_val y_property,
  end⟩,
  have hf₁_invo : ∀ y : S p, f₁' (f₁' y) = y,
    assume y, cases y,
    simp [f₁'],exact f₁_invo_on_S p y_val y_property,
  have : ∃ y : S p, f₁' y = y,
    apply by_contradiction,
    assume h, rw not_exists at h,
    have h₃:=involution_parity h hf₁_invo,
    rw ←nat.modeq.modeq_zero_iff at h₃,
    have:=this.symm.trans h₃,
    simp[nat.modeq,(dec_trivial : ¬1%2=0)] at this,
    trivial,
  cases this with x hx,
  cases x with x hx₁,
  cases x with x y,
  cases y with y z,
  simp [S] at hx₁,
  existsi [x, 2*y],
  unfold nat.pow,
  simp [f₁',f₁] at hx,
  rw [←hx₁.left,hx.left],
  simp,rw [mul_left_comm (2*y),←mul_assoc,←mul_assoc,(dec_trivial : 2 * 2 = 4)],
end
#print axioms fermat_sum_two_squares


import .list_as_k_tuple linear_algebra.affine_space.basic
import linear_algebra.basis
import .affine_coordinate_space
import data.real.basic

open list
open vecl

namespace aff_fr

universes u v w

variables
    -- (id : ℕ)
    (X : Type u)
    (K : Type v)
    (V : Type w)
    (n : ℕ)
    (k : K)
    (ι : Type*)
    (s : finset ι)
    (g : ι → K)
    (v : ι → V)
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]
    [is_basis K v]
    [affine_space V X]

/-
An affine frame comprises an origin point
and a basis for the vector space.
-/
structure affine_frame  :=
(origin : X)
(basis : ι → V)
(proof_is_basis : is_basis K basis)

#check affine_frame
/-
mutual inductive affine_coordinate_frame, aff_coord_pt, aff_coord_vec
with affine_coordinate_frame : Type
| std_frame
| gen_frame
    (origin : aff_coord_pt)
    (basis : ι → aff_coord_vec)
    (proof_is_basis : is_basis K basis)
with aff_coord_pt : affine_coordinate_frame X K V ι →  Type
| mk (tuple : aff_pt_coord_tuple K n)
with aff_coord_vec : affine_coordinate_frame X K V ι → Type
| mk (tuple : aff_vec_coord_tuple K n)
-/

structure aff_coord_pt (fr : affine_frame X K V ι) extends aff_pt_coord_tuple K n :=
   -- (tuple : aff_pt_coord_tuple K n)
   mk ::

structure aff_coord_vec (fr : affine_frame X K V ι) extends aff_vec_coord_tuple K n  :=
   -- (tuple : aff_vec_coord_tuple K n)
   mk ::
/-
def affine_coordinate_frame_origin (frame : affine_coordinate_frame X K V ι) :=
match frame with
| std_frame := _
| gen_frame o b pf := o
end

def frame_basis : affine_frame X K V ι → (ι → V) :=
| (affine_frame.std_frame origin) := basis
| (affine_frame.gen_frame origin _ _) := origin
-/

variables
    (fr : affine_frame X K V ι)
    (cv1 cv2 : aff_coord_vec X K V n ι fr)
    (cp1 cp2 : aff_coord_pt  X K V n ι fr)

/-
-- lemmas so that the following operations are well-defined
/-- the length of the sum of two length n+1 vectors is n+1 -/
lemma aff_not_nil : x.1 ≠ [] :=
begin
intro h,
have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
have len_x_nil : length x.1 = length nil := by rw h,
have len_fixed : length nil = n + 1 := eq.trans (eq.symm len_x_nil) x.2,
have bad : 0 = n + 1 := eq.trans (eq.symm len_nil) len_fixed,
contradiction,
end

lemma aff_cons : ∃ x_hd : K, ∃ x_tl : list K, x.1 = x_hd :: x_tl :=
begin
cases x,
cases x_l,
{
    have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
    have bad := eq.trans (eq.symm len_nil) x_len_fixed,
    contradiction
},
{
    apply exists.intro x_l_hd,
    apply exists.intro x_l_tl,
    exact rfl
}
end

/-- head is compatible with addition -/
lemma head_sum : head x.1 + head y.1 = head (ladd x.1 y.1) :=
begin
cases x,
cases y,
cases x_l,
    have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
    have bad := eq.trans (eq.symm len_nil) x_len_fixed,
    contradiction,
cases y_l,
    have f : 0 ≠ n + 1 := ne.symm (nat.succ_ne_zero n),
    have bad := eq.trans (eq.symm len_nil) y_len_fixed,
    contradiction,
have head_xh : head (x_l_hd :: x_l_tl) = x_l_hd := rfl,
have head_yh : head (y_l_hd :: y_l_tl) = y_l_hd := rfl,
rw head_xh at x_fst_zero,
rw head_yh at y_fst_zero,
simp [x_fst_zero, y_fst_zero, add_cons_cons 0 0 x_l_tl y_l_tl],
end

/-- the head of the sum of two vectors is 0 -/
lemma sum_fst_fixed : head (ladd x.1 y.1) = 0 :=
    by simp only [eq.symm (head_sum K n x y), x.3, y.3]; exact add_zero 0

/-- the length of the zero vector is n+1 -/
lemma len_zero : length (zero_vector K n) = n + 1 :=
begin
induction n with n',
refl,
{
have h₃ : nat.succ (n' + 1) = nat.succ n' + 1 := rfl,
have h₄ : length (zero_vector K (nat.succ n')) = nat.succ (n' + 1) :=
    by {rw eq.symm n_ih, refl},
rw eq.symm h₃,
exact h₄,
}
end

/-- the head of the zero vector is zero -/
lemma head_zero : head (zero_vector K n) = 0 := by {cases n, refl, refl}

lemma vec_len_neg : length (vecl_neg x.1) = n + 1 := by {simp only [len_neg], exact x.2}

lemma head_neg_0 : head (vecl_neg x.1) = 0 :=
begin
cases x,
cases x_l,
contradiction,
rw neg_cons x_l_hd x_l_tl,
have head_xh : head (x_l_hd :: x_l_tl) = x_l_hd := rfl,
have head_0 : head (0 :: vecl_neg x_l_tl) = 0 := rfl,
rw head_xh at x_fst_zero,
simp only [x_fst_zero, neg_zero, head_0],
end

-/
def vec_add_coord : aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr :=
    λ x y, ⟨⟨ladd x.1.l y.1.l, list_sum_fixed K n x.1 y.1, sum_fst_fixed K n x.1 y.1⟩⟩
def vec_zero_coord : aff_coord_vec X K V n ι fr := ⟨⟨zero_vector K n, len_zero K n, head_zero K n⟩⟩
def vec_neg_coord : aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr
| ⟨⟨l, len, fst⟩⟩ := ⟨⟨vecl_neg l, vec_len_neg K n ⟨l, len, fst⟩, head_neg_0 K n ⟨l, len, fst⟩⟩⟩

/-! ### type class instances for the abelian group operations -/
instance : has_add (aff_coord_vec X K V n ι fr) := ⟨vec_add_coord X K V n ι fr⟩
instance : has_zero (aff_coord_vec X K V n ι fr) := ⟨vec_zero_coord X K V n ι fr⟩
instance : has_neg (aff_coord_vec X K V n ι fr) := ⟨vec_neg_coord X K V n ι fr⟩
@[ext]
def vec_scalar_coord : K → aff_coord_vec X K V n ι fr → aff_coord_vec X K V n ι fr :=
    λ a x, ⟨⟨scalar_mul a x.1.1, trans (scale_len a x.1.1) x.1.2, sorry⟩⟩
/-! ### Type class instance for abelian group -/
instance aff_comm_group_coord : add_comm_group (aff_coord_vec X K V n ι fr) :=
begin
    sorry
end
instance : has_scalar K (aff_coord_vec X K V n ι fr) := ⟨vec_scalar_coord X K V n ι fr⟩

/-
lemma vec_one_smul_coord : (1 : K) • cv1 = cv1 :=
begin
cases cv1,

ext,
split,
intros,
dsimp only [has_scalar.smul, vec_scalar] at a_1,
rw one_smul_cons at a_1,
exact a_1,

intros,
dsimp only [has_scalar.smul, vec_scalar],
rw one_smul_cons,
exact a_1,
end
-/
lemma vec_mul_smul_coord : ∀ g h : K, ∀ x : aff_coord_vec X K V n ι fr, (g * h) • x = g • h • x := sorry

instance : mul_action K (aff_coord_vec X K V n ι fr) := ⟨sorry, vec_mul_smul_coord X K V n ι fr⟩

instance : distrib_mul_action K (aff_coord_vec X K V n ι fr) :=
    sorry
instance aff_semimod_coord : semimodule K (aff_coord_vec X K V n ι fr)
    --[distrib_mul_action K (aff_coord_vec X K V n ι fr)]
    :=
    -- extremely odd that this doesnt work....
    ⟨sorry, sorry⟩

def aff_group_action_coord : (aff_coord_vec X K V n ι fr) → (aff_coord_pt X K V n ι fr) → (aff_coord_pt X K V n ι fr) :=
    λ x y, ⟨⟨ladd x.1.1 y.1.1, sorry, sorry⟩⟩

def aff_group_sub_coord : (aff_coord_pt X K V n ι fr) → (aff_coord_pt X K V n ι fr) → (aff_coord_vec X K V n ι fr) :=
    λ x y, ⟨⟨ladd x.1.1 (vecl_neg y.1.1), sorry, sorry⟩⟩

instance : has_vadd (aff_coord_vec X K V n ι fr) (aff_coord_pt X K V n ι fr) := ⟨aff_group_action_coord X K V n ι fr⟩

instance : has_vsub (aff_coord_vec X K V n ι fr) (aff_coord_pt X K V n ι fr) := ⟨aff_group_sub_coord X K V n ι fr⟩

instance : add_action (aff_coord_vec X K V n ι fr) (aff_coord_pt X K V n ι fr) := sorry--⟨aff_group_action K n, aff_zero_sadd K n, aff_add_sadd K n⟩

/-
We need proof that given a frame f,
⟨ aff_coord_pt f, aff_coord_vec f⟩ is
an affine space,
-/

/-

def vecptadd := r3_der2_pt1 +ᵥ r3_der2_vec2 --expected : pass
def vecptsub := r3_der2_pt1 -ᵥ r3_der2_vec2 --expected : pass
def ptvecsub := r3_der2_vec2 -ᵥ r3_der2_pt1 -- expected : pass
-/
def pt_plus_vec
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]
    {fr : affine_frame X K V ι} :
    (aff_coord_pt X K V n ι fr) →
    (aff_coord_vec X K V n ι fr) →
    (aff_coord_pt X K V n ι fr)
| p v := aff_group_action_coord X K V n ι fr v p

notation
 pt +ᵥ v := pt_plus_vec pt v

def pt_minus_vec
    {X : Type u}
    {K : Type v}
    {V : Type w}
    {n : ℕ}
    {ι : Type*}
    [inhabited K]
    [field K]
    [add_comm_group V]
    [module K V]
    [vector_space K V]
    [affine_space V X]
    {fr : affine_frame X K V ι} :
    (aff_coord_pt X K V n ι fr) →
    (aff_coord_vec X K V n ι fr) →
    (aff_coord_pt X K V n ι fr)
| p v := aff_group_action_coord X K V n ι fr (vec_neg_coord X K V n ι fr v) p
.
notation
 pt -ᵥ v := pt_minus_vec pt v

def prf : affine_space (aff_coord_vec X K V n ι fr) (aff_coord_pt  X K V n ι fr) := sorry

instance afc : affine_space
    (aff_coord_vec X K V n ι fr)
    (aff_coord_pt  X K V n ι fr) :=
    prf X K V n ι fr

/-
KEEP?
-/

/-
-/

/-
Code to manufacture a standard basis for a given affine space.
-/
abbreviation zero := zero_vector K n

def list.to_basis_vec : fin n → list K := λ x, (zero K n).update_nth (x.1 + 1) 1

lemma len_basis_vec_fixed (x : fin n) : (list.to_basis_vec K n x).length = n + 1 := sorry

lemma head_basis_vec_fixed (x : fin n) : (list.to_basis_vec K n x).head = 0 := sorry

def std_basis : fin n → aff_vec_coord_tuple K n :=
λ x, ⟨list.to_basis_vec K n x, len_basis_vec_fixed K n x, head_basis_vec_fixed K n x⟩

lemma std_is_basis : is_basis K (std_basis K n) := sorry

def aff_coord_space_std_frame :
    affine_frame (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) (fin n) :=
        ⟨pt_zero K n, std_basis K n, std_is_basis K n⟩

--affine_frame (aff_coord_pt fr_n) K (aff_coord_pt fr_n) (iota)

def aff_tuple_frame
    :=
    affine_frame
        (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) (fin n)

def aff_tuple_framed_pt (f : aff_tuple_frame K n) :=
    aff_coord_pt (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) n (fin n) f

def aff_tuple_framed_vec (f : aff_tuple_frame K n) :=
    aff_coord_vec (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) n (fin n) f

instance a1 (fr : aff_tuple_frame K n): has_add (aff_tuple_framed_vec K n fr) := sorry
instance a2 (fr : aff_tuple_frame K n): has_zero (aff_tuple_framed_vec K n fr) := sorry
instance a3 (fr : aff_tuple_frame K n): has_neg (aff_tuple_framed_vec K n fr) := sorry
instance a4 (fr : aff_tuple_frame K n): add_comm_group (aff_tuple_framed_vec K n fr) := sorry
instance a5 (fr : aff_tuple_frame K n) : has_scalar K (aff_tuple_framed_vec K n fr) := sorry
instance a6 (fr : aff_tuple_frame K n) : mul_action K (aff_tuple_framed_vec K n fr) :=
    ⟨sorry, sorry⟩
instance a7 (fr : aff_tuple_frame K n) : distrib_mul_action K (aff_tuple_framed_vec K n fr) :=
    sorry
instance a8 (fr : aff_tuple_frame K n) : semimodule K (aff_tuple_framed_vec K n fr)
    := ⟨sorry, sorry⟩
instance a9 (fr : aff_tuple_frame K n)  : has_vadd (aff_tuple_framed_vec K n fr) (aff_tuple_framed_pt K n fr) := sorry
instance a10 (fr : aff_tuple_frame K n)  : has_vsub (aff_tuple_framed_vec K n fr) (aff_tuple_framed_pt K n fr) := sorry
instance a11 (fr : aff_tuple_frame K n)  : add_action (aff_tuple_framed_vec K n fr) (aff_tuple_framed_pt K n fr) := sorry--⟨aff_group_action K n, aff_zero_sadd K n, aff_add_sadd K n⟩
instance a12 (fr : aff_tuple_frame K n)  : affine_space
    (aff_tuple_framed_vec K n fr)
    (aff_tuple_framed_pt K n fr) :=
    sorry

inductive fr_type (t : Type) : Type → Type
| fr1 : fr_type t

def aff_tuple_framed_frame
    (f : aff_tuple_frame K n)
    :=
    affine_frame
        (aff_tuple_framed_pt K n f) K (aff_tuple_framed_vec K n f) (fin n)

def aff_quasi_framed_pt
    {f : aff_tuple_frame K n}
    (fr : aff_tuple_framed_frame K n f) :=
    aff_coord_pt (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) n (fin n) f

def aff_quasi_framed_vec
    {f : aff_tuple_frame K n}
    (fr : aff_tuple_framed_frame K n f) :=
    aff_coord_vec (aff_pt_coord_tuple K n) K (aff_vec_coord_tuple K n) n (fin n) f

instance a21 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): has_add (aff_quasi_framed_vec K n fr) := sorry
instance a22 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): has_zero (aff_quasi_framed_vec K n fr)  := sorry
instance a23 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): has_neg (aff_quasi_framed_vec K n fr)  := sorry
instance a24 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): add_comm_group (aff_quasi_framed_vec K n fr) := sorry
instance a25 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): has_scalar K (aff_quasi_framed_vec K n fr) := sorry
instance a26 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f) : mul_action K (aff_quasi_framed_vec K n fr) :=
    ⟨sorry, sorry⟩
instance a27 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): distrib_mul_action K (aff_quasi_framed_vec K n fr) :=
    sorry
instance a28 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f) : semimodule K (aff_quasi_framed_vec K n fr)
    := ⟨sorry, sorry⟩
instance a29 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f) : has_vadd (aff_quasi_framed_vec K n fr) (aff_quasi_framed_pt K n fr) := sorry
instance a210 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f) : has_vsub (aff_quasi_framed_vec K n fr) (aff_quasi_framed_pt K n fr) := sorry
instance a211 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f) : add_action (aff_quasi_framed_vec K n fr) (aff_quasi_framed_pt K n fr) := sorry--⟨aff_group_action K n, aff_zero_sadd K n, aff_add_sadd K n⟩
instance a212 {f : aff_tuple_frame K n} (fr : aff_tuple_framed_frame K n f): affine_space
    (aff_quasi_framed_vec K n fr)
    (aff_quasi_framed_pt K n fr) :=
    sorry

def aff_quasi_frame

end aff_fr


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

! This file was ported from Lean 3 source module topology.algebra.module.locally_convex
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Convex.Topology

/-!
# Locally convex topological modules

A `locally_convex_space` is a topological semimodule over an ordered semiring in which any point
admits a neighborhood basis made of convex sets, or equivalently, in which convex neighborhoods of
a point form a neighborhood basis at that point.

In a module, this is equivalent to `0` satisfying such properties.

## Main results

- `locally_convex_space_iff_zero` : in a module, local convexity at zero gives
  local convexity everywhere
- `seminorm.locally_convex_space` : a topology generated by a family of seminorms is locally convex
- `normed_space.locally_convex_space` : a normed space is locally convex

## TODO

- define a structure `locally_convex_filter_basis`, extending `module_filter_basis`, for filter
  bases generating a locally convex topology

-/

open TopologicalSpace Filter Set

open Topology Pointwise

section Semimodule

/-- A `locally_convex_space` is a topological semimodule over an ordered semiring in which convex
neighborhoods of a point form a neighborhood basis at that point. -/
class LocallyConvexSpace (𝕜 E : Type _) [OrderedSemiring 𝕜] [AddCommMonoid E] [Module 𝕜 E]
  [TopologicalSpace E] : Prop where
  convex_basis : ∀ x : E, (𝓝 x).HasBasis (fun s : Set E => s ∈ 𝓝 x ∧ Convex 𝕜 s) id
#align locally_convex_space LocallyConvexSpace

variable (𝕜 E : Type _) [OrderedSemiring 𝕜] [AddCommMonoid E] [Module 𝕜 E] [TopologicalSpace E]

theorem locallyConvexSpace_iff :
    LocallyConvexSpace 𝕜 E ↔ ∀ x : E, (𝓝 x).HasBasis (fun s : Set E => s ∈ 𝓝 x ∧ Convex 𝕜 s) id :=
  ⟨@LocallyConvexSpace.convex_basis _ _ _ _ _ _, LocallyConvexSpace.mk⟩
#align locally_convex_space_iff locallyConvexSpace_iff

theorem LocallyConvexSpace.ofBases {ι : Type _} (b : E → ι → Set E) (p : E → ι → Prop)
    (hbasis : ∀ x : E, (𝓝 x).HasBasis (p x) (b x)) (hconvex : ∀ x i, p x i → Convex 𝕜 (b x i)) :
    LocallyConvexSpace 𝕜 E :=
  ⟨fun x =>
    (hbasis x).to_hasBasis
      (fun i hi => ⟨b x i, ⟨⟨(hbasis x).mem_of_mem hi, hconvex x i hi⟩, le_refl (b x i)⟩⟩)
      fun s hs =>
      ⟨(hbasis x).index s hs.1, ⟨(hbasis x).property_index hs.1, (hbasis x).set_index_subset hs.1⟩⟩⟩
#align locally_convex_space.of_bases LocallyConvexSpace.ofBases

theorem LocallyConvexSpace.convex_basis_zero [LocallyConvexSpace 𝕜 E] :
    (𝓝 0 : Filter E).HasBasis (fun s => s ∈ (𝓝 0 : Filter E) ∧ Convex 𝕜 s) id :=
  LocallyConvexSpace.convex_basis 0
#align locally_convex_space.convex_basis_zero LocallyConvexSpace.convex_basis_zero

theorem locallyConvexSpace_iff_exists_convex_subset :
    LocallyConvexSpace 𝕜 E ↔ ∀ x : E, ∀ U ∈ 𝓝 x, ∃ S ∈ 𝓝 x, Convex 𝕜 S ∧ S ⊆ U :=
  (locallyConvexSpace_iff 𝕜 E).trans (forall_congr' fun x => hasBasis_self)
#align locally_convex_space_iff_exists_convex_subset locallyConvexSpace_iff_exists_convex_subset

end Semimodule

section Module

variable (𝕜 E : Type _) [OrderedSemiring 𝕜] [AddCommGroup E] [Module 𝕜 E] [TopologicalSpace E]
  [TopologicalAddGroup E]

theorem LocallyConvexSpace.ofBasisZero {ι : Type _} (b : ι → Set E) (p : ι → Prop)
    (hbasis : (𝓝 0).HasBasis p b) (hconvex : ∀ i, p i → Convex 𝕜 (b i)) : LocallyConvexSpace 𝕜 E :=
  by
  refine'
    LocallyConvexSpace.ofBases 𝕜 E (fun (x : E) (i : ι) => (· + ·) x '' b i) (fun _ => p)
      (fun x => _) fun x i hi => (hconvex i hi).translate x
  rw [← map_add_left_nhds_zero]
  exact hbasis.map _
#align locally_convex_space.of_basis_zero LocallyConvexSpace.ofBasisZero

theorem locallyConvexSpace_iff_zero :
    LocallyConvexSpace 𝕜 E ↔
      (𝓝 0 : Filter E).HasBasis (fun s : Set E => s ∈ (𝓝 0 : Filter E) ∧ Convex 𝕜 s) id :=
  ⟨fun h => @LocallyConvexSpace.convex_basis _ _ _ _ _ _ h 0, fun h =>
    LocallyConvexSpace.ofBasisZero 𝕜 E _ _ h fun s => And.right⟩
#align locally_convex_space_iff_zero locallyConvexSpace_iff_zero

theorem locallyConvexSpace_iff_exists_convex_subset_zero :
    LocallyConvexSpace 𝕜 E ↔ ∀ U ∈ (𝓝 0 : Filter E), ∃ S ∈ (𝓝 0 : Filter E), Convex 𝕜 S ∧ S ⊆ U :=
  (locallyConvexSpace_iff_zero 𝕜 E).trans hasBasis_self
#align locally_convex_space_iff_exists_convex_subset_zero locallyConvexSpace_iff_exists_convex_subset_zero

-- see Note [lower instance priority]
instance (priority := 100) LocallyConvexSpace.to_locallyConnectedSpace [Module ℝ E]
    [ContinuousSMul ℝ E] [LocallyConvexSpace ℝ E] : LocallyConnectedSpace E :=
  locallyConnectedSpace_of_connected_bases _ _
    (fun x => @LocallyConvexSpace.convex_basis ℝ _ _ _ _ _ _ x) fun x s hs => hs.2.IsPreconnected
#align locally_convex_space.to_locally_connected_space LocallyConvexSpace.to_locallyConnectedSpace

end Module

section LinearOrderedField

variable (𝕜 E : Type _) [LinearOrderedField 𝕜] [AddCommGroup E] [Module 𝕜 E] [TopologicalSpace E]
  [TopologicalAddGroup E] [ContinuousConstSMul 𝕜 E]

theorem LocallyConvexSpace.convex_open_basis_zero [LocallyConvexSpace 𝕜 E] :
    (𝓝 0 : Filter E).HasBasis (fun s => (0 : E) ∈ s ∧ IsOpen s ∧ Convex 𝕜 s) id :=
  (LocallyConvexSpace.convex_basis_zero 𝕜 E).to_hasBasis
    (fun s hs =>
      ⟨interior s, ⟨mem_interior_iff_mem_nhds.mpr hs.1, isOpen_interior, hs.2.interior⟩,
        interior_subset⟩)
    fun s hs => ⟨s, ⟨hs.2.1.mem_nhds hs.1, hs.2.2⟩, subset_rfl⟩
#align locally_convex_space.convex_open_basis_zero LocallyConvexSpace.convex_open_basis_zero

variable {𝕜 E}

/-- In a locally convex space, if `s`, `t` are disjoint convex sets, `s` is compact and `t` is
closed, then we can find open disjoint convex sets containing them. -/
theorem Disjoint.exists_open_convexes [LocallyConvexSpace 𝕜 E] {s t : Set E} (disj : Disjoint s t)
    (hs₁ : Convex 𝕜 s) (hs₂ : IsCompact s) (ht₁ : Convex 𝕜 t) (ht₂ : IsClosed t) :
    ∃ u v, IsOpen u ∧ IsOpen v ∧ Convex 𝕜 u ∧ Convex 𝕜 v ∧ s ⊆ u ∧ t ⊆ v ∧ Disjoint u v :=
  by
  letI : UniformSpace E := TopologicalAddGroup.toUniformSpace E
  haveI : UniformAddGroup E := comm_topologicalAddGroup_is_uniform
  have := (LocallyConvexSpace.convex_open_basis_zero 𝕜 E).comap fun x : E × E => x.2 - x.1
  rw [← uniformity_eq_comap_nhds_zero] at this
  rcases disj.exists_uniform_thickening_of_basis this hs₂ ht₂ with ⟨V, ⟨hV0, hVopen, hVconvex⟩, hV⟩
  refine'
    ⟨s + V, t + V, hVopen.add_left, hVopen.add_left, hs₁.add hVconvex, ht₁.add hVconvex,
      subset_add_left _ hV0, subset_add_left _ hV0, _⟩
  simp_rw [← Union_add_left_image, image_add_left]
  simp_rw [UniformSpace.ball, ← preimage_comp, sub_eq_neg_add] at hV
  exact hV
#align disjoint.exists_open_convexes Disjoint.exists_open_convexes

end LinearOrderedField

section LatticeOps

variable {ι : Sort _} {𝕜 E F : Type _} [OrderedSemiring 𝕜] [AddCommMonoid E] [Module 𝕜 E]
  [AddCommMonoid F] [Module 𝕜 F]

theorem locallyConvexSpaceInf {ts : Set (TopologicalSpace E)}
    (h : ∀ t ∈ ts, @LocallyConvexSpace 𝕜 E _ _ _ t) : @LocallyConvexSpace 𝕜 E _ _ _ (infₛ ts) :=
  by
  letI : TopologicalSpace E := Inf ts
  refine'
    LocallyConvexSpace.ofBases 𝕜 E (fun x => fun If : Set ts × (ts → Set E) => ⋂ i ∈ If.1, If.2 i)
      (fun x => fun If : Set ts × (ts → Set E) =>
        If.1.Finite ∧ ∀ i ∈ If.1, If.2 i ∈ @nhds _ (↑i) x ∧ Convex 𝕜 (If.2 i))
      (fun x => _) fun x If hif => convex_interᵢ fun i => convex_interᵢ fun hi => (hif.2 i hi).2
  rw [nhds_infₛ, ← infᵢ_subtype'']
  exact has_basis_infi' fun i : ts => (@locallyConvexSpace_iff 𝕜 E _ _ _ ↑i).mp (h (↑i) i.2) x
#align locally_convex_space_Inf locallyConvexSpaceInf

theorem locallyConvexSpaceInfi {ts' : ι → TopologicalSpace E}
    (h' : ∀ i, @LocallyConvexSpace 𝕜 E _ _ _ (ts' i)) :
    @LocallyConvexSpace 𝕜 E _ _ _ (⨅ i, ts' i) :=
  by
  refine' locallyConvexSpaceInf _
  rwa [forall_range_iff]
#align locally_convex_space_infi locallyConvexSpaceInfi

/- warning: locally_convex_space_inf clashes with locally_convex_space_Inf -> locallyConvexSpaceInf
Case conversion may be inaccurate. Consider using '#align locally_convex_space_inf locallyConvexSpaceInfₓ'. -/
#print locallyConvexSpaceInf /-
theorem locallyConvexSpaceInf {t₁ t₂ : TopologicalSpace E} (h₁ : @LocallyConvexSpace 𝕜 E _ _ _ t₁)
    (h₂ : @LocallyConvexSpace 𝕜 E _ _ _ t₂) : @LocallyConvexSpace 𝕜 E _ _ _ (t₁ ⊓ t₂) :=
  by
  rw [inf_eq_infᵢ]
  refine' locallyConvexSpaceInfi fun b => _
  cases b <;> assumption
#align locally_convex_space_inf locallyConvexSpaceInf
-/

theorem locallyConvexSpaceInduced {t : TopologicalSpace F} [LocallyConvexSpace 𝕜 F]
    (f : E →ₗ[𝕜] F) : @LocallyConvexSpace 𝕜 E _ _ _ (t.induced f) :=
  by
  letI : TopologicalSpace E := t.induced f
  refine'
    LocallyConvexSpace.ofBases 𝕜 E (fun x => preimage f)
      (fun x => fun s : Set F => s ∈ 𝓝 (f x) ∧ Convex 𝕜 s) (fun x => _) fun x s ⟨_, hs⟩ =>
      hs.linear_preimage f
  rw [nhds_induced]
  exact (LocallyConvexSpace.convex_basis <| f x).comap f
#align locally_convex_space_induced locallyConvexSpaceInduced

instance {ι : Type _} {X : ι → Type _} [∀ i, AddCommMonoid (X i)] [∀ i, TopologicalSpace (X i)]
    [∀ i, Module 𝕜 (X i)] [∀ i, LocallyConvexSpace 𝕜 (X i)] : LocallyConvexSpace 𝕜 (∀ i, X i) :=
  locallyConvexSpaceInfi fun i => locallyConvexSpaceInduced (LinearMap.proj i)

instance [TopologicalSpace E] [TopologicalSpace F] [LocallyConvexSpace 𝕜 E]
    [LocallyConvexSpace 𝕜 F] : LocallyConvexSpace 𝕜 (E × F) :=
  locallyConvexSpaceInf (locallyConvexSpaceInduced (LinearMap.fst _ _ _))
    (locallyConvexSpaceInduced (LinearMap.snd _ _ _))

end LatticeOps