import field_theory.adjoin
import linear_algebra.finite_dimensional
import linear_algebra.basic
import data.set.finite
import field_theory.tower
import algebra.gcd_monoid
import field_theory.splitting_field
import field_theory.separable

notation K`⟮`:std.prec.max_plus α`⟯` := field.adjoin K (@singleton _ _ set.has_singleton α)
notation K`⟮`:std.prec.max_plus α`,`l:(foldr `, ` (h t, set.insert h t) {α}) `⟯` := field.adjoin K l

noncomputable theory
local attribute [instance, priority 100] classical.prop_decidable

/- Some stupid lemmas used below. Maybe some of them are already in mathlib? -/

-- This should go into field_theory/subfield eventually probably
lemma is_subfield.pow_mem {K : Type*} [field K] {a : K} {n : ℤ} {s : set K} [is_subfield s] (h : a ∈ s) : a ^ n ∈ s :=
begin
    by_cases hn : n ≥ 0,
    {   lift n to ℕ using hn,
        exact is_submonoid.pow_mem h, },
    {   rw [(show n = (-1)*(-n), by ring), fpow_mul, fpow_neg a, fpow_one],
        lift -n to ℕ using (show -n ≥ 0, by linarith),
        exact is_submonoid.pow_mem (is_subfield.inv_mem h), },
end

-- Is this really not in mathlib?
-- If M is an algebra over a field F and x is a nonzero element of F then x as an element of M is also nonzero.
-- lemma ne_zero_of_ne_zero (F M : Type*) [field F] [comm_semiring M] [nontrivial M] [algebra F M]
--     {x : F} (hx : x ≠ 0) : algebra_map F M x ≠ 0 :=
-- begin
--     revert hx,
--     contrapose!,
--     intro h,
--     rw ← (algebra_map F M).map_zero at h,
--     exact (algebra_map F M).injective h,
-- end

namespace polynomial

variables (F : Type*) [field F]

lemma gcd_eval_zero (f g : polynomial F) (α : F) (hf : f.eval α = 0) (hg : g.eval α = 0) : (euclidean_domain.gcd f g).eval α = 0 :=
begin
    rw euclidean_domain.gcd_eq_gcd_ab f g,
    rw [polynomial.eval_add,polynomial.eval_mul,polynomial.eval_mul,hf,hg,zero_mul,zero_mul,zero_add],
end

variables {E : Type*} [field E] [algebra F E]

lemma gcd_root_left (f g : polynomial F) (α : E) (hα : (euclidean_domain.gcd f g).eval₂ (algebra_map F E) α = 0) :
f.eval₂ (algebra_map F E) α = 0 :=
begin
    cases euclidean_domain.gcd_dvd_left f g with p hp,
    rw [hp,polynomial.eval₂_mul,hα,zero_mul],
end

lemma gcd_root_right (f g : polynomial F) (α : E) (hα : (euclidean_domain.gcd f g).eval₂ (algebra_map F E) α = 0) :
g.eval₂ (algebra_map F E) α = 0 :=
begin
    cases euclidean_domain.gcd_dvd_right f g with p hp,
    rw [hp,polynomial.eval₂_mul,hα,zero_mul],
end

end polynomial

/- Proof of the primitive element theorem. -/

open finite_dimensional

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

/-- Trivial case of the primitive element theorem. -/
lemma primitive_element_trivial (F_eq_E : set.range (algebra_map F E) = ⊤) :
    ∃ α : E, F⟮α⟯ = ⊤ :=
begin
    use 0,
    ext,
    split,
    { exact λ _, algebra.mem_top, },
    { obtain ⟨x, rfl⟩ := (show x ∈ set.range (algebra_map F E), by simp only [*]),
      exact λ _, F⟮0⟯.algebra_map_mem x, },
end

/- Primitive element theorem for finite fields. -/

-- Replaces earlier messy proof, courtesy of Aaron Anderson & Markus Himmel on zulip
/-- A finite dimensional vector space over a finite field is finite. -/
def finite_of_findim_over_finite [fintype F] [hE : finite_dimensional F E] : fintype E :=
    module.fintype_of_fintype (classical.some_spec (finite_dimensional.exists_is_basis_finset F E) : _)

/-- Primitive element theorem assuming E is finite. -/
lemma primitive_element_fin_aux [fintype E] : ∃ α : E, F⟮α⟯ = ⊤ :=
begin
    obtain ⟨α, hα⟩ := is_cyclic.exists_generator (units E),
    use α,
    ext,
    refine ⟨λ _, algebra.mem_top, λ _, _⟩,
    by_cases hx : x = 0,
    { rw hx,
      exact F⟮α.val⟯.zero_mem, },
    { obtain ⟨n, hn⟩ := set.mem_range.mp (hα (units.mk0 x hx)),
      rw (show x = α^n, by norm_cast; simp *),
      exact is_subfield.pow_mem (show α.val ∈ (F⟮α.val⟯ : set E), from field.mem_adjoin_simple_self F α.val),
    },
end

/-- Primitive element theorem for finite dimensional extension of a finite field. -/
theorem primitive_element_fin [fintype F] [hfd : finite_dimensional F E] :
    ∃ α : E, F⟮α⟯ = ⊤ :=
begin
    haveI : fintype E := finite_of_findim_over_finite F,
    exact primitive_element_fin_aux F,
end

end

/- Primitive element theorem for infinite fields. -/

section
variables {F : Type*} [field F] {E : Type*} [field E] (ϕ : F →+* E)

lemma primitive_element_two_aux (α β : E) {f g : polynomial F} [F_inf : infinite F] (hf : f ≠ 0) (hg : g ≠ 0) (f_monic : polynomial.monic f) (g_monic : polynomial.monic g) :
    ∃ c : F, ∀ (α' ∈ (f.map ϕ).roots) (β' ∈ (g.map ϕ).roots), β' ≠ β → ϕ c ≠ -(α' - α)/(β' - β) :=
begin
    let sf := (f.map ϕ).roots,
    let sg := (g.map ϕ).roots,
    let s := {c : E | ∃ (α' ∈ sf) (β' ∈ sg), β' ≠ β ∧ c = -(α' - α)/(β' - β)},
    let s' := ϕ⁻¹' s,
    let r : E → E → E := λ α' β', -(α' - α)/(β' - β),
    have hr : ∀ c ∈ s, ∃ α' β', ((α' ∈ sf) ∧ (β' ∈ sg)) ∧ r α' β' = c :=
    begin
        intros c hc,
        rw set.mem_set_of_eq at hc,
        tauto,
    end,
    have s_fin : s.finite :=
    begin
        refine (set.finite.image (λ z : E × E, r z.1 z.2) (set.finite_mem_finset (sf.product sg))).subset _,
        simpa only [set.subset_def, set.mem_image, prod.exists, finset.mem_product] using hr,
    end,
    have s'_fin : s'.finite := s_fin.preimage ((ring_hom.injective ϕ).inj_on (⇑ϕ ⁻¹' s)),
    obtain ⟨c, hc⟩ := infinite.exists_not_mem_finset s'_fin.to_finset,
    rw [set.finite.mem_to_finset, set.mem_preimage, set.mem_set_of_eq] at hc,
    push_neg at hc,
    exact ⟨c, hc⟩,
end

lemma primitive_element_two_inf_key_aux {β : F} {h : polynomial F} (h_ne_zero : h ≠ 0) (h_sep : h.separable)
(h_root : h.eval β = 0) (h_splits : polynomial.splits ϕ h) (h_roots : ∀ x ∈ (h.map ϕ).roots, x = ϕ β) :
h = (polynomial.C (polynomial.leading_coeff h)) * (polynomial.X - polynomial.C β) :=
begin
    have h_map_separable : (h.map ϕ).separable :=
    begin
        apply polynomial.separable.map,
        exact h_sep,
    end,
    rw polynomial.splits_iff_exists_multiset at h_splits,
    cases h_splits with s hs,
    have s_elements : ∀ x ∈ s, x = ϕ β :=
    begin
        intros x hx,
        have is_root : x ∈ (h.map ϕ).roots,
        rw polynomial.mem_roots,
        dsimp[polynomial.is_root],
        rw polynomial.eval_map,
        rw polynomial.eval₂_eq_eval_map,
        rw hs,
        rw polynomial.eval_mul,
        cases multiset.exists_cons_of_mem hx with y hy,
        rw hy,
        rw multiset.map_cons,
        simp only [polynomial.eval_X, multiset.prod_cons, polynomial.eval_C, zero_mul, polynomial.eval_mul, polynomial.eval_sub, mul_zero, sub_self],
        exact polynomial.map_ne_zero h_ne_zero,
        exact h_roots x is_root,
    end,
    replace s_elements : ∀ x ∈ multiset.map (λ (a : E), polynomial.X - polynomial.C a) s, x = polynomial.X - polynomial.C (ϕ β) :=
    begin
        intros x hx,
        rw multiset.mem_map at hx,
        cases hx with a ha,
        specialize s_elements a ha.1,
        rw s_elements at ha,
        exact ha.2.symm,
    end,
    replace s_elements := multiset.eq_repeat_of_mem s_elements,
    rw s_elements at hs,
    rw multiset.prod_repeat at hs,
    rw multiset.card_map at hs,
    rw hs at h_map_separable,
    have hf : ¬is_unit (polynomial.X - polynomial.C (ϕ β)) :=
    begin
        rw polynomial.is_unit_iff_degree_eq_zero,
        rw polynomial.degree_X_sub_C,
        exact dec_trivial,
    end,
    have map_injective := polynomial.map_injective ϕ ϕ.injective,
    have hn : s.card ≠ 0 :=
    begin
        intro hs_card,
        rw hs_card at hs,
        rw pow_zero at hs,
        rw mul_one at hs,
        rw ←polynomial.map_C at hs,
        replace hs := map_injective hs,
        rw hs at h_root,
        rw polynomial.eval_C at h_root,
        rw polynomial.leading_coeff_eq_zero at h_root,
        exact h_ne_zero h_root,
    end,
    rw (polynomial.separable.of_pow hf hn (polynomial.separable.of_mul_right h_map_separable)).2 at hs,
    rw pow_one at hs,
    apply map_injective,
    rw hs,
    rw polynomial.map_mul,
    rw polynomial.map_C,
    rw polynomial.map_sub,
    rw polynomial.map_X,
    rw polynomial.map_C,
end

end

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]

lemma primitive_element_two_inf_key (α β : E) [F_sep : is_separable F E]
    (F_inf : infinite F) : ∃ c : F, β ∈ F⟮α + (algebra_map F E) c * β⟯ :=
begin
    rcases F_sep α with ⟨hα, hf⟩,
    rcases F_sep β with ⟨hβ, hg⟩,
    let f := minimal_polynomial hα,
    let g := minimal_polynomial hβ,
    let f_E := f.map (algebra_map F E),
    let g_E := g.map (algebra_map F E),
    let E' := polynomial.splitting_field g_E,
    let ιFE := algebra_map F E,
    let ιEE' := algebra_map E E',
    let ιFE' := ιEE'.comp(ιFE),
    have key := primitive_element_two_aux ιFE' (ιEE' α) (ιEE' β) (minimal_polynomial.ne_zero hα) (minimal_polynomial.ne_zero hβ) (minimal_polynomial.monic hα) (minimal_polynomial.monic hβ),
    cases key with c hc,
    use c,
    let γ := α+(ιFE c)*β,
    let f' := f_E.comp(polynomial.C γ-(polynomial.C (ιFE c)) * (polynomial.X)),
    let h := euclidean_domain.gcd f' g_E,
    have h_sep : h.separable :=
    begin
        have div := euclidean_domain.gcd_dvd_right f' g_E,
        cases div with p mul,
        dsimp[←h] at mul,
        apply polynomial.separable.of_mul_left,
        rw ←mul,
        exact polynomial.separable.map hg,
    end,
    have h_ne_zero : h ≠ 0 :=
    begin
        intro h_eq_zero,
        rw euclidean_domain.gcd_eq_zero_iff at h_eq_zero,
        apply polynomial.map_monic_ne_zero (minimal_polynomial.monic hβ) h_eq_zero.2,
    end,
    have h_map_separable : (h.map ιEE').separable :=
    begin
        apply polynomial.separable.map,
        exact h_sep,
    end,
    have h_root : h.eval β = 0 :=
    begin
        apply polynomial.gcd_eval_zero,
        rw [polynomial.eval_comp,polynomial.eval_sub,polynomial.eval_mul,polynomial.eval_C,polynomial.eval_C,polynomial.eval_X,add_sub_cancel],
        rw [polynomial.eval_map,←polynomial.aeval_def,minimal_polynomial.aeval],
        rw [polynomial.eval_map,←polynomial.aeval_def,minimal_polynomial.aeval],
    end,
    have h_splits : polynomial.splits (algebra_map E E') h :=
        polynomial.splits_of_splits_of_dvd (algebra_map E E') (polynomial.map_ne_zero (minimal_polynomial.ne_zero hβ)) (polynomial.splitting_field.splits g_E) (euclidean_domain.gcd_dvd_right f' g_E),
    have h_roots : ∀ x ∈ (h.map ιEE').roots, x = algebra_map E E' β :=
    begin
        intros x hx,
        rw polynomial.mem_roots at hx,
        dsimp[polynomial.is_root] at hx,
        rw polynomial.eval_map at hx,
        have f_root : f'.eval₂ (algebra_map E E') x = 0 := polynomial.gcd_root_left E f' g_E x hx,
        simp only [polynomial.eval₂_comp,polynomial.eval₂_map,polynomial.eval₂_sub,polynomial.eval₂_mul,polynomial.eval₂_C,polynomial.eval₂_X] at f_root,
        replace f_root : _ ∈ (f.map ιFE').roots,
        rw polynomial.mem_roots,
        dsimp[polynomial.is_root],
        rw polynomial.eval_map,
        exact f_root,
        exact polynomial.map_ne_zero (minimal_polynomial.ne_zero hα),
        specialize hc _ f_root,
        have g_root : g_E.eval₂ (algebra_map E E') x = 0 := polynomial.gcd_root_right E f' g_E x hx,
        simp only [polynomial.eval₂_map] at g_root,
        replace g_root : _ ∈ (g.map ιFE').roots,
        rw polynomial.mem_roots,
        dsimp[polynomial.is_root],
        rw polynomial.eval_map,
        exact g_root,
        exact polynomial.map_ne_zero (minimal_polynomial.ne_zero hβ),
        specialize hc _ g_root,
        by_contradiction,
        specialize hc a,
        apply hc,
        dsimp[ιEE'],
        rw[neg_sub,ring_hom.map_add,←sub_add,←sub_sub,sub_self,zero_sub,neg_add_eq_sub,ring_hom.map_mul,←mul_sub],
        symmetry,
        apply mul_div_cancel,
        rw sub_ne_zero,
        exact a,
        exact polynomial.map_ne_zero h_ne_zero,
    end,
    replace key := primitive_element_two_inf_key_aux ιEE' h_ne_zero h_sep h_root h_splits h_roots,
    let f_Fγ := (f.map(algebra_map F F⟮γ⟯)).comp(polynomial.C (field.adjoin_simple.gen F γ)-(polynomial.C ↑c) * (polynomial.X)),
    let g_Fγ := g.map(algebra_map F F⟮γ⟯),
    have composition2 : (algebra_map F⟮γ⟯ E).comp(algebra_map F F⟮γ⟯) = algebra_map F E := by ext;refl,
    have f_map : f_Fγ.map(algebra_map F⟮γ⟯ E) = f' :=
    begin
        dsimp[f_Fγ,f',f_E],
        rw ←composition2,
        rw ←polynomial.map_map,
        set p := f.map(algebra_map F F⟮γ⟯),
        dsimp[←p],
        erw polynomial.map_comp (algebra_map F⟮γ⟯ E) p (polynomial.C (field.adjoin_simple.gen F γ)-(polynomial.C ↑c) * (polynomial.X)),
        rw [polynomial.map_sub,polynomial.map_C,field.adjoin_simple.algebra_map_gen,polynomial.map_mul,polynomial.map_C,polynomial.map_X],
        refl,
    end,
    have g_map : g_Fγ.map(algebra_map F⟮γ⟯ E) = g_E :=
    begin
        rw polynomial.map_map,
        rw composition2,
    end,
    dsimp[h] at key,
    rw [←f_map,←g_map] at key,
    have swap : euclidean_domain.gcd (f_Fγ.map(algebra_map F⟮γ⟯ E)) (g_Fγ.map(algebra_map F⟮γ⟯ E)) = (euclidean_domain.gcd f_Fγ g_Fγ).map(algebra_map F⟮γ⟯ E),
    convert polynomial.gcd_map (algebra_map F⟮γ⟯ E),
    rw swap at key,
    set p := euclidean_domain.gcd f_Fγ g_Fγ,
    set k := (p.map(algebra_map F⟮γ⟯ E)).leading_coeff,
    dsimp[←k] at key,
    rw mul_sub at key,
    rw ←polynomial.C_mul at key,
    have coeff0 : algebra_map F⟮γ⟯ E (p.coeff 0) = -(k*β) :=
        by erw [←polynomial.coeff_map,key, polynomial.coeff_sub, polynomial.coeff_C_mul, polynomial.coeff_C_zero, polynomial.coeff_X_zero, mul_zero, zero_sub]; refl,
    have coeff1 : algebra_map F⟮γ⟯ E (p.coeff 1) = k :=
    begin
        erw [←polynomial.coeff_map,key,polynomial.coeff_sub,polynomial.coeff_mul_X,polynomial.coeff_C_zero,polynomial.coeff_C],
        change k - 0 = k,
        rw sub_zero,
    end,
    have k_ne_zero : k≠0 :=
    begin
        intro k_eq_zero,
        rw [polynomial.leading_coeff_eq_zero,←polynomial.map_zero (algebra_map F⟮γ⟯ E)] at k_eq_zero,
        replace k_eq_zero := polynomial.map_injective (algebra_map F⟮γ⟯ E) (algebra_map F⟮γ⟯ E).injective k_eq_zero,
        rw euclidean_domain.gcd_eq_zero_iff at k_eq_zero,
        apply polynomial.map_monic_ne_zero (minimal_polynomial.monic hβ) k_eq_zero.2,
    end,
    have last_step : β = algebra_map F⟮γ⟯ E (-p.coeff 0 / p.coeff 1) :=
        by rw [division_def,ring_hom.map_mul,ring_hom.map_neg,ring_hom.map_inv,coeff0,coeff1,neg_neg,mul_comm,←mul_assoc,inv_mul_cancel k_ne_zero,one_mul],
    change β = ↑(-p.coeff 0 / p.coeff 1) at last_step,
    change β ∈ F⟮γ⟯,
    rw last_step,
    exact subtype.mem (-p.coeff 0 / p.coeff 1),
end

/-- Primitive element theorem for adjoining two elements to an infinite field. -/
lemma primitive_element_two_inf (α β : E) (F_sep : is_separable F E)
    (F_inf : infinite F) :  ∃ γ : E, F⟮α, β⟯ = F⟮γ⟯ :=
begin
    obtain ⟨c, β_in_Fγ⟩ := primitive_element_two_inf_key α β F_inf,
    let c' := algebra_map F E c,
    let γ := α + c'*β,
    have γ_in_Fγ : γ ∈ (F⟮γ⟯ : set E) := sorry, --field.mem_adjoin_simple_self F γ,
    have c_in_Fγ : c' ∈ (F⟮γ⟯ : set E) := field.adjoin.algebra_map_mem F {γ} c,
    have cβ_in_Fγ : c'*β ∈ (F⟮γ⟯ : set E) := is_submonoid.mul_mem c_in_Fγ β_in_Fγ,
    have α_in_Fγ : α ∈ (F⟮γ⟯ : set E) := by rw (show α = γ - c'*β, by simp *);
        exact is_add_subgroup.sub_mem F⟮γ⟯ γ (c'*β) γ_in_Fγ cβ_in_Fγ,
    have αβ_in_Fγ : set.insert α (set.insert β ∅) ⊆ (F⟮γ⟯ : set E) := λ x hx, by cases hx; cases hx; cases hx; assumption,
    have Fαβ_sub_Fγ : (F⟮α, β⟯ : set E) ⊆ (F⟮γ⟯ : set E) := (field.adjoin_subset_iff F (set.insert α (set.insert β ∅))).mp αβ_in_Fγ,
    have α_in_Fαβ : α ∈ F⟮α, β⟯ := field.subset_adjoin F (set.insert α (set.insert β ∅)) (set.mem_insert α (set.insert β ∅)),
    have β_in_Fαβ : β ∈ F⟮α, β⟯ := field.subset_adjoin F (set.insert α (set.insert β ∅)) (set.mem_insert_of_mem α (set.mem_insert β ∅)),
    have c_in_Fαβ : c' ∈ (F⟮α, β⟯ : set E) := field.adjoin.algebra_map_mem F (set.insert α (set.insert β ∅)) c,
    have cβ_in_Fαβ : c'*β ∈ (F⟮α, β⟯ : set E) := is_submonoid.mul_mem c_in_Fαβ β_in_Fαβ,
    have γ_in_Fαβ : γ ∈ (F⟮α, β⟯ : set E) := is_add_submonoid.add_mem α_in_Fαβ cβ_in_Fαβ,
    have : set.insert γ ∅ ⊆ F⟮α, β⟯ := λ x hx, by cases hx; cases hx; assumption,
    have Fγ_sub_Fαβ : (F⟮γ⟯ : set E) ⊆ (F⟮α, β⟯ : set E) := (field.adjoin_subset_iff F (set.insert γ ∅)).mp this,
    use γ, ext, exact ⟨λ hx, Fαβ_sub_Fγ hx, λ hx, Fγ_sub_Fαβ hx⟩,
end

universe u

/-- Primitive element theorem for infinite fields. -/
theorem primitive_element_inf (F E : Type u) [field F] [field E] [algebra F E] (F_sep : is_separable F E) (F_findim: finite_dimensional F E)
    (F_inf : infinite F) (n : ℕ) (hn : findim F E = n) : ∃ α : E, F⟮α⟯ = ⊤ :=
begin
    tactic.unfreeze_local_instances,
    revert F,
    apply n.strong_induction_on,
    clear n,
    intros n ih F hF hFE F_sep F_findim F_inf hn,
    by_cases F_neq_E : set.range (algebra_map F E) = (⊤ : set E),
    {   exact primitive_element_trivial F F_neq_E, },
    {   have : ∃ α : E, α ∉ set.range (algebra_map F E) :=
        begin
            revert F_neq_E,
            contrapose!,
            exact λ h, set.ext (λ x, ⟨λ _, dec_trivial, λ _, h x⟩),
        end,
        rcases this with ⟨α, hα⟩,
        by_cases h : F⟮α⟯ = ⊤,
        {   exact ⟨α, h⟩,   },
        {   have Fα_findim : finite_dimensional F⟮α⟯ E := sorry, --adjoin_findim_of_findim F α,
            have Fα_le_n : findim F⟮α⟯ E < n := sorry, --by rw ← hn; exact adjoin_dim_lt F hα,
            have Fα_inf : infinite F⟮α⟯ := sorry, --adjoin_inf_of_inf F {α} F_inf,
            have Fα_sep : is_separable F⟮α⟯ E := sorry, --adjoin.separable F (set.insert α ∅),
            obtain ⟨β, hβ⟩ := ih (findim F⟮α⟯ E) Fα_le_n F⟮α⟯ Fα_sep Fα_findim Fα_inf rfl,
            obtain ⟨γ, hγ⟩ := primitive_element_two_inf α β F_sep F_inf,
            -- rw [field.adjoin_simple_adjoin_simple, hγ] at hβ,
            sorry, --exact ⟨γ, hβ⟩,
        },
    },
end

/- Actual primitive element theorem. -/

/-- Primitive element theorem in same universe. -/
theorem primitive_element_aux (F E : Type u) [field F] [field E] [algebra F E]
(F_sep : is_separable F E)  (F_findim : finite_dimensional F E) :
    (∃ α : E, F⟮α⟯ = ⊤) :=
begin
    by_cases F_finite : nonempty (fintype F),
    exact nonempty.elim F_finite (λ h : fintype F, @primitive_element_fin F _ E _ _ h F_findim),
    exact primitive_element_inf F E F_sep F_findim (not_nonempty_fintype.mp F_finite) (findim F E) rfl,
end

/-- Primitive element theorem in different universes. -/
theorem primitive_element (F_sep : is_separable F E)  (F_findim : finite_dimensional F E) :
    (∃ α : E, F⟮α⟯ = ⊤) :=
begin
    set F' := set.range (algebra_map F E) with hF',
    have F'_sep : is_separable F' E := sorry,--inclusion.separable F_sep,
    have F'_findim : finite_dimensional F' E := sorry, --inclusion.finite_dimensional F_findim,
    obtain ⟨α, hα⟩ := primitive_element_aux F' E F'_sep F'_findim,
    sorry,
    -- exact ⟨α, by simp only [*, adjoin_equals_adjoin_range]⟩,
end


axioms (𝕋 : Type) (D K : 𝕋) (app : 𝕋 → 𝕋 → 𝕋)
infixl `⬝`:60 := app
variables {x y z : 𝕋}
axioms (r_D : D⬝x⬝y⬝z = y⬝z⬝(x⬝z)) (r_K : K⬝y⬝z = y)

example : D⬝y⬝x = D⬝(K⬝x)⬝D⬝y :=
  begin
    calc D⬝y⬝x = D⬝y⬝x       : rfl
           ... = D⬝y⬝(K⬝x⬝y) : by conv {to_lhs, rw ←@r_K x y} --why is the "conv to_lhs" necessary?
           ... = D⬝(K⬝x)⬝D⬝y : by rw ←r_D
    ,
  end

example : D⬝y⬝x = D⬝y⬝(K⬝x⬝y) :=
  begin
    conv {to_lhs, rw ←@r_K x y},
  end


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import analysis.inner_product_space.basic
import measure_theory.integral.set_integral

/-! # `L^2` space

If `E` is an inner product space over `𝕜` (`ℝ` or `ℂ`), then `Lp E 2 μ` (defined in `lp_space.lean`)
is also an inner product space, with inner product defined as `inner f g = ∫ a, ⟪f a, g a⟫ ∂μ`.

### Main results

* `mem_L1_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  belongs to `Lp 𝕜 1 μ`.
* `integrable_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  is integrable.
* `L2.inner_product_space` : `Lp E 2 μ` is an inner product space.

-/

noncomputable theory
open topological_space measure_theory measure_theory.Lp
open_locale nnreal ennreal measure_theory

namespace measure_theory

section

variables {α F : Type*} {m : measurable_space α} {μ : measure α} [normed_group F]

lemma mem_ℒp.integrable_sq {f : α → ℝ} (h : mem_ℒp f 2 μ) :
  integrable (λ x, (f x)^2) μ :=
by simpa [real.norm_eq_abs, ← mem_ℒp_one_iff_integrable]
  using h.norm_rpow ennreal.two_ne_zero ennreal.two_ne_top

lemma mem_ℒp_two_iff_integrable_sq_norm {f : α → F} (hf : ae_strongly_measurable f μ) :
  mem_ℒp f 2 μ ↔ integrable (λ x, ∥f x∥^2) μ :=
begin
  rw ← mem_ℒp_one_iff_integrable,
  convert (mem_ℒp_norm_rpow_iff hf ennreal.two_ne_zero ennreal.two_ne_top).symm,
  { simp },
  { rw [div_eq_mul_inv, ennreal.mul_inv_cancel ennreal.two_ne_zero ennreal.two_ne_top] }
end

lemma mem_ℒp_two_iff_integrable_sq {f : α → ℝ} (hf : ae_strongly_measurable f μ) :
  mem_ℒp f 2 μ ↔ integrable (λ x, (f x)^2) μ :=
begin
  convert mem_ℒp_two_iff_integrable_sq_norm hf,
  ext x,
  simp [real.norm_eq_abs],
end

end

namespace L2

variables {α E F 𝕜 : Type*} [is_R_or_C 𝕜] [measurable_space α] {μ : measure α}
  [inner_product_space 𝕜 E] [normed_group F]

local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

lemma snorm_rpow_two_norm_lt_top (f : Lp F 2 μ) : snorm (λ x, ∥f x∥ ^ (2 : ℝ)) 1 μ < ∞ :=
begin
  have h_two : ennreal.of_real (2 : ℝ) = 2, by simp [zero_le_one],
  rw [snorm_norm_rpow f zero_lt_two, one_mul, h_two],
  exact ennreal.rpow_lt_top_of_nonneg zero_le_two (Lp.snorm_ne_top f),
end

lemma snorm_inner_lt_top (f g : α →₂[μ] E) : snorm (λ (x : α), ⟪f x, g x⟫) 1 μ < ∞ :=
begin
  have h : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ ∥f x∥ * ∥g x∥, from λ x, abs_inner_le_norm _ _,
  have h' : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ is_R_or_C.abs (∥f x∥^2 + ∥g x∥^2),
  { refine λ x, le_trans (h x) _,
    rw [is_R_or_C.abs_to_real, abs_eq_self.mpr],
    swap, { exact add_nonneg (by simp) (by simp), },
    refine le_trans _ (half_le_self (add_nonneg (sq_nonneg _) (sq_nonneg _))),
    refine (le_div_iff (@zero_lt_two ℝ _ _)).mpr ((le_of_eq _).trans (two_mul_le_add_sq _ _)),
    ring, },
  simp_rw [← is_R_or_C.norm_eq_abs, ← real.rpow_nat_cast] at h',
  refine (snorm_mono_ae (ae_of_all _ h')).trans_lt ((snorm_add_le _ _ le_rfl).trans_lt _),
  { exact ((Lp.ae_strongly_measurable f).norm.ae_measurable.pow_const _).ae_strongly_measurable },
  { exact ((Lp.ae_strongly_measurable g).norm.ae_measurable.pow_const _).ae_strongly_measurable },
  simp only [nat.cast_bit0, ennreal.add_lt_top, nat.cast_one],
  exact ⟨snorm_rpow_two_norm_lt_top f, snorm_rpow_two_norm_lt_top g⟩,
end

section inner_product_space
open_locale complex_conjugate

include 𝕜

instance : has_inner 𝕜 (α →₂[μ] E) := ⟨λ f g, ∫ a, ⟪f a, g a⟫ ∂μ⟩

lemma inner_def (f g : α →₂[μ] E) : ⟪f, g⟫ = ∫ a : α, ⟪f a, g a⟫ ∂μ := rfl

lemma integral_inner_eq_sq_snorm (f : α →₂[μ] E) :
  ∫ a, ⟪f a, f a⟫ ∂μ = ennreal.to_real ∫⁻ a, (∥f a∥₊ : ℝ≥0∞) ^ (2:ℝ) ∂μ :=
begin
  simp_rw inner_self_eq_norm_sq_to_K,
  norm_cast,
  rw integral_eq_lintegral_of_nonneg_ae,
  rotate,
  { exact filter.eventually_of_forall (λ x, sq_nonneg _), },
  { exact ((Lp.ae_strongly_measurable f).norm.ae_measurable.pow_const _).ae_strongly_measurable },
  congr,
  ext1 x,
  have h_two : (2 : ℝ) = ((2 : ℕ) : ℝ), by simp,
  rw [← real.rpow_nat_cast _ 2, ← h_two,
    ← ennreal.of_real_rpow_of_nonneg (norm_nonneg _) zero_le_two, of_real_norm_eq_coe_nnnorm],
  norm_cast,
end

private lemma norm_sq_eq_inner' (f : α →₂[μ] E) : ∥f∥ ^ 2 = is_R_or_C.re ⟪f, f⟫ :=
begin
  have h_two : (2 : ℝ≥0∞).to_real = 2 := by simp,
  rw [inner_def, integral_inner_eq_sq_snorm, norm_def, ← ennreal.to_real_pow, is_R_or_C.of_real_re,
    ennreal.to_real_eq_to_real (ennreal.pow_ne_top (Lp.snorm_ne_top f)) _],
  { rw [←ennreal.rpow_nat_cast, snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top, snorm',
      ← ennreal.rpow_mul, one_div, h_two],
    simp, },
  { refine (lintegral_rpow_nnnorm_lt_top_of_snorm'_lt_top zero_lt_two _).ne,
    rw [← h_two, ← snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top],
    exact Lp.snorm_lt_top f, },
end

lemma mem_L1_inner (f g : α →₂[μ] E) :
  ae_eq_fun.mk (λ x, ⟪f x, g x⟫)
    ((Lp.ae_strongly_measurable f).inner (Lp.ae_strongly_measurable g)) ∈ Lp 𝕜 1 μ :=
by { simp_rw [mem_Lp_iff_snorm_lt_top, snorm_ae_eq_fun], exact snorm_inner_lt_top f g, }

lemma integrable_inner (f g : α →₂[μ] E) : integrable (λ x : α, ⟪f x, g x⟫) μ :=
(integrable_congr (ae_eq_fun.coe_fn_mk (λ x, ⟪f x, g x⟫)
    ((Lp.ae_strongly_measurable f).inner (Lp.ae_strongly_measurable g)))).mp
  (ae_eq_fun.integrable_iff_mem_L1.mpr (mem_L1_inner f g))

private lemma add_left' (f f' g : α →₂[μ] E) : ⟪f + f', g⟫ = inner f g + inner f' g :=
begin
  simp_rw [inner_def, ← integral_add (integrable_inner f g) (integrable_inner f' g),
    ←inner_add_left],
  refine integral_congr_ae ((coe_fn_add f f').mono (λ x hx, _)),
  congr,
  rwa pi.add_apply at hx,
end

private

instance inner_product_space : inner_product_space 𝕜 (α →₂[μ] E) :=
{ norm_sq_eq_inner := norm_sq_eq_inner',
  conj_sym := λ _ _, by simp_rw [inner_def, ← integral_conj, inner_conj_sym],
  add_left := add_left',
  smul_left := smul_left', }

end inner_product_space

section indicator_const_Lp

variables (𝕜) {s : set α}

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs c` and `f` is
equal to the integral of the inner product over `s`: `∫ x in s, ⟪c, f x⟫ ∂μ`. -/
lemma inner_indicator_const_Lp_eq_set_integral_inner (f : Lp E 2 μ) (hs : measurable_set s) (c : E)
  (hμs : μ s ≠ ∞) :
  (⟪indicator_const_Lp 2 hs hμs c, f⟫ : 𝕜) = ∫ x in s, ⟪c, f x⟫ ∂μ :=
begin
  rw [inner_def, ← integral_add_compl hs (L2.integrable_inner _ f)],
  have h_left : ∫ x in s, ⟪(indicator_const_Lp 2 hs hμs c) x, f x⟫ ∂μ = ∫ x in s, ⟪c, f x⟫ ∂μ,
  { suffices h_ae_eq : ∀ᵐ x ∂μ, x ∈ s → ⟪indicator_const_Lp 2 hs hμs c x, f x⟫ = ⟪c, f x⟫,
      from set_integral_congr_ae hs h_ae_eq,
    have h_indicator : ∀ᵐ (x : α) ∂μ, x ∈ s → (indicator_const_Lp 2 hs hμs c x) = c,
      from indicator_const_Lp_coe_fn_mem,
    refine h_indicator.mono (λ x hx hxs, _),
    congr,
    exact hx hxs, },
  have h_right : ∫ x in sᶜ, ⟪(indicator_const_Lp 2 hs hμs c) x, f x⟫ ∂μ = 0,
  { suffices h_ae_eq : ∀ᵐ x ∂μ, x ∉ s → ⟪indicator_const_Lp 2 hs hμs c x, f x⟫ = 0,
    { simp_rw ← set.mem_compl_iff at h_ae_eq,
      suffices h_int_zero : ∫ x in sᶜ, inner (indicator_const_Lp 2 hs hμs c x) (f x) ∂μ
        = ∫ x in sᶜ, (0 : 𝕜) ∂μ,
      { rw h_int_zero,
        simp, },
      exact set_integral_congr_ae hs.compl h_ae_eq, },
    have h_indicator : ∀ᵐ (x : α) ∂μ, x ∉ s → (indicator_const_Lp 2 hs hμs c x) = 0,
      from indicator_const_Lp_coe_fn_nmem,
    refine h_indicator.mono (λ x hx hxs, _),
    rw hx hxs,
    exact inner_zero_left, },
  rw [h_left, h_right, add_zero],
end

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs c` and `f` is
equal to the inner product of the constant `c` and the integral of `f` over `s`. -/
lemma inner_indicator_const_Lp_eq_inner_set_integral [complete_space E] [normed_space ℝ E]
  (hs : measurable_set s) (hμs : μ s ≠ ∞) (c : E) (f : Lp E 2 μ) :
  (⟪indicator_const_Lp 2 hs hμs c, f⟫ : 𝕜) = ⟪c, ∫ x in s, f x ∂μ⟫ :=
by rw [← integral_inner (integrable_on_Lp_of_measure_ne_top f fact_one_le_two_ennreal.elim hμs),
    L2.inner_indicator_const_Lp_eq_set_integral_inner]

variables {𝕜}

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs (1 : 𝕜)` and
a real or complex function `f` is equal to the integral of `f` over `s`. -/
lemma inner_indicator_const_Lp_one (hs : measurable_set s) (hμs : μ s ≠ ∞) (f : Lp 𝕜 2 μ) :
  ⟪indicator_const_Lp 2 hs hμs (1 : 𝕜), f⟫ = ∫ x in s, f x ∂μ :=
by { rw L2.inner_indicator_const_Lp_eq_inner_set_integral 𝕜 hs hμs (1 : 𝕜) f, simp, }

end indicator_const_Lp

end L2

section inner_continuous

variables {α : Type*} [topological_space α] [measure_space α] [borel_space α] {𝕜 : Type*}
  [is_R_or_C 𝕜]
variables (μ : measure α) [is_finite_measure μ]

open_locale bounded_continuous_function complex_conjugate

local notation `⟪`x`, `y`⟫` := @inner 𝕜 (α →₂[μ] 𝕜) _ x y

/-- For bounded continuous functions `f`, `g` on a finite-measure topological space `α`, the L^2
inner product is the integral of their pointwise inner product. -/
lemma bounded_continuous_function.inner_to_Lp (f g : α →ᵇ 𝕜) :
  ⟪bounded_continuous_function.to_Lp 2 μ 𝕜 f, bounded_continuous_function.to_Lp 2 μ 𝕜 g⟫
  = ∫ x, conj (f x) * g x ∂μ :=
begin
  apply integral_congr_ae,
  have hf_ae := f.coe_fn_to_Lp μ,
  have hg_ae := g.coe_fn_to_Lp μ,
  filter_upwards [hf_ae, hg_ae] with _ hf hg,
  rw [hf, hg],
  simp
end

variables [compact_space α]

/-- For continuous functions `f`, `g` on a compact, finite-measure topological space `α`, the L^2
inner product is the integral of their pointwise inner product. -/
lemma continuous_map.inner_to_Lp (f g : C(α, 𝕜)) :
  ⟪continuous_map.to_Lp 2 μ 𝕜 f, continuous_map.to_Lp 2 μ 𝕜 g⟫
  = ∫ x, conj (f x) * g x ∂μ :=
begin
  apply integral_congr_ae,
  have hf_ae := f.coe_fn_to_Lp μ,
  have hg_ae := g.coe_fn_to_Lp μ,
  filter_upwards [hf_ae, hg_ae] with _ hf hg,
  rw [hf, hg],
  simp
end

end inner_continuous

end measure_theory


-- https://proofwiki.org/wiki/Axiom_of_Choice_Implies_Zorn%27s_Lemma/Proof_1

universe u

instance set.partial_order {α} : partial_order (set α) :=
{ le := (⊆),
  le_refl := λ A z, id,
  le_trans := λ A B C hab hbc z hz, hbc (hab hz),
  le_antisymm := λ A B hab hba, funext $ λ z, propext ⟨@hab z, @hba z⟩ }

local attribute [instance] classical.prop_decidable

namespace zorn

variables {α : Type u} (r : α → α → Prop)

inductive trichotomy (A B) : Prop
| inl (H : r A B) : trichotomy
| eq (H : A = B) : trichotomy
| inr (H : r B A) : trichotomy

theorem trichotomy.symm {r : α → α → Prop} {A B}
  (H : trichotomy r A B) :
  trichotomy r B A :=
trichotomy.cases_on H trichotomy.inr (λ H, trichotomy.eq r H.symm) trichotomy.inl

def chains : set (set α) :=
{ C | ∀ A ∈ C, ∀ B ∈ C, trichotomy r A B }

theorem chains.empty : ∅ ∈ chains r :=
λ _, false.elim

theorem chains.insert {C x} (H1 : C ∈ chains r) (H2 : ∀ y ∈ C, trichotomy r x y) :
  insert x C ∈ chains r :=
λ A HA B HB, or.cases_on HA
  (assume HA : A = x, or.cases_on HB
    (assume HB : B = x, trichotomy.eq r $ HA.trans HB.symm)
    (assume HB : B ∈ C, HA.symm ▸ H2 B HB))
  (assume HA : A ∈ C, or.cases_on HB
    (assume HB : B = x, trichotomy.symm $ HB.symm ▸ H2 A HA)
    (assume HB : B ∈ C, H1 A HA B HB))

theorem chains.union {C} (H1 : C ⊆ chains r) (H2 : C ∈ @chains (set α) (⊆)) :
  { A | ∃ t ∈ C, A ∈ t } ∈ chains r :=
λ A ⟨t, ht1, ht2⟩ B ⟨u, hu1, hu2⟩, trichotomy.cases_on (H2 t ht1 u hu1)
  (λ H3, (H1 hu1) _ (H3 ht2) _ hu2)
  (λ H3, (H1 ht1) A ht2 B (H3.symm ▸ hu2))
  (λ H3, (H1 ht1) _ ht2 _ (H3 hu2))

def extensions (A) : set α :=
{ x | insert x A ∈ chains r }

noncomputable def succ (A : set α) : set α :=
if H : ∃ x, x ∈ extensions r A \ A then insert (classical.some H) A else A

@[elab_as_eliminator] noncomputable def succ.rec {C : set α → set α → Sort*}
  (H1 : ∀ A, ∀ x ∈ extensions r A \ A, C A (insert x A))
  (H2 : ∀ A, extensions r A ⊆ A → C A A)
  (A : set α) : C A (succ r A) :=
if H : ∃ x, x ∈ extensions r A \ A then
  have succ r A = insert (classical.some H) A, from dif_pos H,
  eq.drec_on this.symm $ H1 _ (classical.some H) (classical.some_spec H)
else
  have succ r A = A, from dif_neg H,
  eq.drec_on this.symm $ H2 A $ λ z hz1,
  classical.by_contradiction $ λ hz2, H ⟨z, hz1, hz2⟩

@[elab_as_eliminator] noncomputable def succ.rec_on {C : set α → set α → Sort*}
  (A : set α)
  (H1 : ∀ A, ∀ x ∈ extensions r A \ A, C A (insert x A))
  (H2 : ∀ A, extensions r A ⊆ A → C A A) :
  C A (succ r A) :=
succ.rec r H1 H2 A

theorem succ.mem (A : set α) (x) (H1 : insert x A ∈ chains r) (H2 : x ∉ A) :
  ∃ x, x ∈ extensions r A ∧ x ∉ A ∧ succ r A = insert x A :=
have H : ∃ x, x ∈ extensions r A \ A := ⟨x, H1, H2⟩,
⟨_, and.assoc.1 ⟨classical.some_spec H, dif_pos H⟩⟩

theorem succ.cases (A : set α) :
  (∃ x, x ∉ A ∧ x ∈ extensions r A ∧ succ r A = insert x A) ∨ succ r A = A :=
@succ.rec_on α _ (λ t u, (∃ x, x ∉ t ∧ x ∈ extensions r t ∧ u = insert x t) ∨ u = t) A
  (λ A x hx, or.inl ⟨x, hx.2, hx.1, rfl⟩) (λ _ _, or.inr rfl)

theorem succ.subset {A : set α} : A ⊆ succ r A :=
succ.rec_on r A
  (λ t A H, show t ⊆ insert A t, from λ z, or.inr)
  (λ t H z, id)

theorem chains.succ {A : set α} : A ∈ chains r → succ r A ∈ chains r :=
@succ.rec_on α _ (λ t u, t ∈ chains r → u ∈ chains r) A
  (λ t X HX H, HX.1) (λ _ _, id)

theorem succ.eq_or_eq_of_subset_of_subset (A : set α) :
  ∀ B, A ⊆ B → B ⊆ succ r A → A = B ∨ B = succ r A :=
@succ.rec_on α _ (λ t u, ∀ B, t ⊆ B → B ⊆ u → t = B ∨ B = u) A
  (λ A x hx B HAB HBA, classical.by_cases
    (assume h : x ∈ B, or.inr $ le_antisymm HBA $ λ z hz, or.cases_on hz
      (λ hz1, hz1.symm ▸ h) (@HAB z))
    (assume h : x ∉ B, or.inl $ le_antisymm HAB $ λ z hz, or.cases_on (HBA hz)
      (λ hz1, false.elim $ h $ hz1 ▸ hz) id))
  (λ _ _ _ HBC HCB, or.inl $ le_antisymm HBC HCB)

inductive tower : set (set α)
| succ  : ∀ {A}, tower A → tower (succ r A)
| chain : ∀ {C}, C ⊆ chains r → C ∈ @chains (set α) (⊆) →
    (∀ A ∈ C, tower A) → tower { A | ∃ t ∈ C, A ∈ t }

theorem tower.empty : ∅ ∈ tower r :=
have H : { A | ∃ t ∈ (∅ : set (set α)), A ∈ t } = ∅,
  from le_antisymm (λ _ ⟨_, H, _⟩, H) (λ _, false.elim),
H ▸ tower.chain (λ _, false.elim) (λ _, false.elim) (λ _, false.elim)

theorem tower.subset_chains : tower r ⊆ chains r :=
λ A HA, tower.rec_on HA
  (λ A HA, chains.succ r)
  (λ C HC1 HC2 HC3 ih, chains.union r HC1 HC2)

/-- TLDR: proof by heavy induction -/
theorem tower.chains : tower r ∈ @chains (set α) (⊆) :=
λ A HA, tower.rec_on HA
  (λ C HC ih1 A HA, suffices A ⊆ C ∨ succ r C ⊆ A,
    from or.cases_on this (λ h, trichotomy.inr $ λ z hz, succ.subset r $ h hz) trichotomy.inl,
    tower.rec_on HA
      (λ A HA ih2, or.cases_on ih2
        (assume h1 : A ⊆ C, trichotomy.cases_on (ih1 (succ r A) (tower.succ HA))
          (assume h2 : C ⊆ succ r A, or.cases_on (succ.eq_or_eq_of_subset_of_subset r A C h1 h2)
            (assume h3 : A = C, or.inr $ λ _, h3 ▸ id)
            (assume h3 : C = succ r A, or.inl $ λ _, h3 ▸ id))
          (assume h2 : C = succ r A, or.inl $ λ _, h2 ▸ id)
          or.inl)
        (assume h1 : succ r C ⊆ A, or.inr $ λ z hz, succ.subset r $ h1 hz))
      (λ D HD1 HD2 HD3 ih2, trichotomy.cases_on (ih1 _ (tower.chain HD1 HD2 HD3))
        (λ h1, have H1 : C ⊆ {A : α | ∃ (t : set α) (H : t ∈ D), A ∈ t} ∩ succ r C,
            from λ z hz, ⟨h1 hz, succ.subset r hz⟩,
          have H2 : {A : α | ∃ (t : set α) (H : t ∈ D), A ∈ t} ∩ succ r C ⊆ succ r C,
            from λ _, and.right,
          or.cases_on (succ.eq_or_eq_of_subset_of_subset r _ _ H1 H2)
            (λ h2, or.cases_on (succ.cases r C)
              (λ ⟨x, hx1, hx2, hx3⟩, or.inl $ λ z ⟨t, ht1, ht2⟩,
                or.cases_on (ih2 t ht1) (λ h3, h3 ht2)
                  (λ h3, have H3 : x ∈ succ r C, from hx3.symm ▸ or.inl rfl,
                    false.elim $ hx1 $ h2.symm ▸ ⟨⟨t, ht1, h3 H3⟩, H3⟩))
              (λ h3, h3.symm ▸ or.inr h1))
            (λ h2, or.inr $ h2 ▸ λ _, and.left))
        (λ h1, or.inl $ λ _, h1 ▸ id)
        or.inl))
  (λ C HC1 HC2 HC3 ih B HB, classical.by_cases
      (assume h : ∃ A ∈ C, B ⊆ A, let ⟨A, HA1, HA2⟩ := h in
        trichotomy.inr $ λ z hz, ⟨A, HA1, HA2 hz⟩)
      (assume h : ¬∃ A ∈ C, B ⊆ A, trichotomy.inl $ λ z ⟨t, ht1, ht2⟩,
        trichotomy.cases_on (ih t ht1 B HB)
          (assume H : t ⊆ B, H ht2)
          (assume H : t = B, H ▸ ht2)
          (assume H : B ⊆ t, false.elim $ h ⟨t, ht1, H⟩)))

def fixed : set α :=
{A : α | ∃ t ∈ tower r, A ∈ t}

theorem fixed.tower : fixed r ∈ tower r :=
tower.chain (tower.subset_chains r) (tower.chains r) (λ A, id)

theorem fixed.succ_tower : succ r (fixed r) ∈ tower r :=
tower.succ (fixed.tower r)

theorem fixed.fixed : succ r (fixed r) = fixed r :=
le_antisymm (λ z hz, ⟨succ r (fixed r), fixed.succ_tower r, hz⟩) $
λ z hz, succ.subset r hz

theorem fixed.chains : fixed r ∈ chains r :=
chains.union r (tower.subset_chains r) (tower.chains r)

theorem zorn.aux {M} (HM : ∀ x ∈ fixed r, r x M)
  (trans : ∀ {a b c}, r a b → r b c → r a c) :
  ∀ A, r M A → r A M :=
λ A HA, HM A (classical.by_contradiction $ λ H,
  let ⟨y, hy1, hy2, hy3⟩ := succ.mem r (fixed r) A
    (chains.insert r (fixed.chains r) $ λ y hy,
    trichotomy.inr $ trans (HM y hy) HA) H in
  hy2 $ (fixed.fixed r) ▸ hy3.symm ▸ or.inl rfl)

theorem zorn [HN : nonempty α] [partial_order α]
  (H : ∀ C ∈ @chains α (≤), ∀ y ∈ C, ∃ M, ∀ x ∈ C, x ≤ M) :
  ∃ M : α, ∀ A, M ≤ A → M = A :=
nonempty.elim HN $ λ X,
let ⟨x, hx1, hx2, hx3⟩ := succ.mem (≤) ∅ X
  (chains.insert (≤) (chains.empty (≤)) (λ _, false.elim)) id in
let ⟨M, HM⟩ := H (fixed (≤)) (fixed.chains (≤)) x
  ⟨insert x ∅, hx3 ▸ tower.succ (tower.empty (≤)), or.inl rfl⟩ in
⟨M, λ A HA, le_antisymm HA $
zorn.aux (≤) HM (λ _ _ _, le_trans) A HA⟩

end zorn