import misc.set

universes u

open set
open subtype
open classical

/-
  These are the definations assocated with zorns lemma that I want the rest of
  the project to see.
-/

@[reducible]
def is_chain {P : Type u} [partial_order P] (A : set P) : Prop
  := ∀ a b : P , a ∈ A ∧ b ∈ A → a ≤ b ∨ b ≤ a

theorem every_pair_is_bounded_in_chain {P : Type u} [partial_order P] {A : set P} (hA : is_chain A)
  : ∀ {a b}, a ∈ A ∧ b ∈ A → ∃ c, c ∈ A ∧ (a ≤ c ∧ b ≤ c) :=
begin
  intros a b hab,
  cases (hA a b hab),
  existsi b,
  exact ⟨and.right hab,h,le_refl b⟩,
  existsi a,
  exact ⟨and.left hab,le_refl a,h⟩,
end

@[reducible]
def maximal_element {P : Type u} [partial_order P] (m : P) : Prop := ∀ a : P, m ≤ a → a = m

@[reducible]
def bounds_subset {P : Type u} [partial_order P] (A : set P) (m : P) : Prop
  := ∀ a : P, a ∈ A → a ≤ m

@[reducible]
def all_chains_bounded (P : Type u) [partial_order P] : Prop := ∀ A : set P, is_chain A → ∃ ma : P , bounds_subset A ma

@[reducible]
def strict_upper_bounds {P : Type u} [partial_order P] (C: set P) : set P := λ p : P, p ∉ C ∧ (∀ c : P, c ∈ C → c ≤ p)

@[reducible]
def has_min {P : Type u} [partial_order P] (S : set P) : Prop := ∃ l : P, l ∈ S ∧ ∀ a : P, a ∈ S → l ≤ a

@[reducible]
def is_min {P : Type u} [partial_order P] (S : set P) (l : P) : Prop := l ∈ S ∧ ∀ a : P, a ∈ S → l ≤ a

/- You could make this defintion more constructive by making well ordered sets a data structure, consisting of :
  a subset S of P,
  a proof S is a chain,
  a function min : noempty subsets of S → P
  a proof that min sends S' to the minimum element of S'.
-/

@[reducible]
def well_ordered {P : Type u} [partial_order P] (S : set P) : Prop := is_chain S ∧ ∀ S' : set P, S' ⊆ S → S' ≠ ∅ → has_min S'

@[reducible]
def initial_segment {P : Type u} [partial_order P] (S : set P) (a : P) : set P := λ x, x ∈ S ∧ x ≠ a ∧ x ≤ a

/-
  Some helpful results about well ordered sets.
-/

noncomputable def min {P : Type u} [partial_order P] {S : set P} (hwo : well_ordered S) (S' : set P)
  (hS' : S' ⊆ S) (nS' : S' ≠ ∅) : P := some ((and.right hwo) S' hS' nS')

theorem min_property {P : Type u} [partial_order P] {S : set P} (hwo : well_ordered S) {S' : set P} (hS' : S' ⊆ S) (nS' : S' ≠ ∅)
  : (min hwo S' hS' nS') ∈ S' ∧ ∀ a : P, a ∈ S' → (min hwo S' hS' nS') ≤ a := some_spec ((and.right hwo) S' hS' nS')

theorem min_unquie {P : Type u} [partial_order P] {S : set P} (hwo : well_ordered S) (S' : set P) (hS' : S' ⊆ S) (nS' : S' ≠ ∅)
  : ∀ l : P, (l ∈ S' ∧ ∀ a : P, a ∈ S' → l ≤ a) → l = min hwo S' hS' nS' :=
begin
  intros l hl,
  apply le_antisymm,
  apply and.right hl,
  exact and.left (min_property hwo hS' nS'),
  apply and.right (min_property hwo hS' nS'),
  exact and.left hl,
end

theorem min_of_complement {P: Type u} [partial_order P] {A : set P} {B : set P} {x : P} (hx : x ∈ A \ B ∧ ∀ a, a ∈ A \ B → x ≤ a)
  : ∀ {a}, a ∈ A → a ≠ x → a ≤ x → a ∈ B :=
begin
  intros a hainA nax halessx,
  by_contradiction,
  apply nax,
  apply le_antisymm,
  exact halessx,
  apply and.right hx,
  split,
  exact hainA,
  exact h,
end

theorem min_of_subset_greater {P: Type u} [partial_order P] {A B: set P} {mA mB : P} (hAB : B ⊆ A) (hmB : is_min B mB) (hmA : is_min A mA) : mA ≤ mB :=
begin
  apply and.right hmA,
  apply hAB,
  exact and.left hmB,
end

lemma subset_of_chain_is_chain {P :Type u} [partial_order P] {S : set P} (hS : is_chain S) {S' : set P} (hS' : S' ⊆ S) : is_chain S' :=
begin
  intros a b hab,
  have h : a ∈ S ∧ b ∈ S,
  split,
  exact hS' (and.left hab),
  exact hS' (and.right hab),
  apply hS,
  exact h,
end

lemma negation_of_le {P :Type u} [partial_order P] {S : set P} (hS : is_chain S) {a b : P} (hab : a ∈ S ∧ b ∈ S)  : ¬ (a ≤ b) → b ≤ a ∧ a ≠ b :=
begin
  intro h1,
  cases (hS a b hab),
  apply false.elim,
  apply h1,
  exact h,
  split,
  exact h,
  intro ab,
  rw ab at h1,
  apply h1,
  apply le_refl,
end

lemma subset_of_well_ordered_well_ordered {P :Type u} [partial_order P] {S : set P} (hS : well_ordered S) {S' : set P} (hS' : S' ⊆ S) : well_ordered S' :=
begin
  split,
  exact subset_of_chain_is_chain (and.left hS) hS',
  intros U hUinS' nU,
  have hUinS : U ⊆ S,
  apply subset_transitive,
  exact hUinS',
  exact hS',
  apply (and.right hS),
  exact hUinS,
  exact nU,
end

/-
  Some helpful results about initial segments.
-/

theorem initial_segment_chain {P : Type u} [partial_order P] {S : set P} {a : P} (hwo : well_ordered S): is_chain (initial_segment S a) :=
begin
  intros p q hpq,
  cases hpq with hp hq,
  cases hp with pinS,
  cases hq with qinS,
  cases hwo with h,
  exact h p q ⟨pinS,qinS⟩,
end

theorem initial_segment_subset {P : Type u} [partial_order P] (S : set P) (a : P) : initial_segment S a ⊆ S :=
begin
  intros x hx,
  cases hx,
  exact hx_left,
end

theorem initial_segment_preserves_order {P : Type u} [partial_order P] (S : set P) {a b : P} (halessb : a ≤ b) : initial_segment S a ⊆ initial_segment S b :=
begin
  intros x hx,
  cases hx,
  split,
  exact hx_left,
  split,
  intro h,
  rw h at hx_right,
  cases hx_right with h1 h2,
  apply h1,
  apply le_antisymm,
  exact h2,
  exact halessb,
  apply le_trans,
  exact and.right hx_right,
  exact halessb,
end

lemma not_maximal_element_strictly_greater {P :Type u} [partial_order P] : ∀ p : P, ¬ maximal_element p → ∃ m : P, p ≤ m ∧ p ≠ m :=
begin
  intros p hp,
  by_contradiction h1,
  suffices hrd : maximal_element p,
  exact hp hrd,
  intros q hq,
  symmetry,
  by_contradiction h2,
  apply h1,
  existsi q,
  exact ⟨hq,h2⟩,
end

private lemma all_chains_bounded_implies_SUBs_non_empty_when_no_me {P : Type u} [partial_order P]
  (hcb : all_chains_bounded P) (hno_me : ∀ p : P, ¬ (maximal_element p))
  : ∀ C : set P, is_chain C → ∃ p : P, p ∈ strict_upper_bounds C :=
begin
  intros C hC,
  let h_C_bounded := hcb C hC,
  let y := some h_C_bounded,
  let hy : bounds_subset C y := some_spec h_C_bounded,
  cases em (y ∈ C),
  let hy_not_me := hno_me y,
  let m := some (not_maximal_element_strictly_greater y hy_not_me),
  let hm : y ≤ m ∧ y ≠ m := some_spec (not_maximal_element_strictly_greater y hy_not_me),
  have hmninC : m ∉ C,
  intro hcon,
  apply and.right hm,
  apply le_antisymm,
  exact and.left hm,
  exact hy m hcon,
  existsi m,
  split,
  exact hmninC,
  intros c hc,
  let hcley : c ≤ y := hy c hc,
  apply le_trans hcley,
  exact and.left hm,
  existsi y,
  split,
  exact h,
  exact hy,
end

/-
  The following stuff is useing the conforming_set
-/

@[reducible]
private def conforming_set {P: Type u} [partial_order P] (hcb : all_chains_bounded P) (hno_me : ∀ p : P, ¬ (maximal_element p))
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  (hf : choice_function f) (A : set P) := ∃ hA : well_ordered A, ∀ {a : P}, a ∈ A → a = f ⟨strict_upper_bounds (initial_segment A a), all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me (initial_segment A a) (initial_segment_chain  hA)⟩

private lemma conforming_set_well_ordered {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} : conforming_set hcb hno_me hf A → well_ordered A := λ h, some h

private lemma conforming_set_chain {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} : conforming_set hcb hno_me hf A → is_chain A := λ h, and.left (conforming_set_well_ordered h)

@[reducible]
private def conforming_set_extension {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) : set P := λ a : P, a ∈ A
  ∨ a = f ⟨strict_upper_bounds A, all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me A  (and.left (some hA))⟩

private lemma conforming_set_extension_well_ordered {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) : well_ordered (conforming_set_extension hA) :=
begin
  let hdata := hf ⟨strict_upper_bounds A,_⟩,
  let hAwo := some hA,
  split,
  intros a b hab,
  cases hab with ha hb,
  cases ha,
  cases hb,
  exact (and.left hAwo) a b ⟨ha,hb⟩,
  rw ← hb at hdata,
  cases hdata with hbnotinA hbboundsA,
  left,
  exact hbboundsA a ha,
  cases hb,
  rw ← ha at hdata,
  cases hdata with hanotinA haboundsA,
  right,
  exact haboundsA b hb,
  left,
  rw ha,
  rw hb,
  intros S hS nS,
  cases em (A ∩ S = ∅) with hinter,
  existsi f ⟨strict_upper_bounds A, _⟩,
  split,
  by_contradiction,
  have ab : S = ∅,
    apply subset_antisymmetric,
    split,
    intros x hx,
    cases hS hx with hx1,
    let hcontra : x ∈ A ∩ S := ⟨hx1,hx⟩,
    rw hinter at hcontra,
    exact hcontra,
    rw h_1 at hx,
    exact false.elim (h hx),
    exact empty_set_subset,
  exact nS ab,
  intros a ha,
  cases hS ha,
  let h₁ : a ∈ A ∩ S := ⟨h,ha⟩,
  rw hinter at h₁,
  exact false.elim h₁,
  rw h,
  existsi min hAwo (A ∩ S) intersection_in_set  h,
  split,
  exact and.right (and.left (min_property hAwo intersection_in_set h)),
  intros a ha,
  cases em (a ∈ A),
  apply and.right (min_property hAwo intersection_in_set h),
  exact ⟨h_1,ha⟩,
  cases hS ha with h_3,
  exact false.elim (h_1 h_3),
  rw h_2,
  cases hf ⟨strict_upper_bounds A,_⟩ with notinA boundsA,
  apply boundsA,
  apply @intersection_in_set P A S,
  exact and.left (min_property hAwo intersection_in_set h),
end

private lemma conforming_set_extension_initial_segments_by_elms_in_set {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) : ∀ {a}, a ∈ A → initial_segment (conforming_set_extension hA) a = initial_segment A a :=
begin
  intros a hainA,
  apply subset_antisymmetric,
  split,
  intros b hb,
  cases hb with hbinex h,
  cases h with nba hblessa,
  cases hbinex,
  exact ⟨hbinex,⟨nba,hblessa⟩⟩,
  apply false.elim,
  apply nba,
  apply le_antisymm,
  exact hblessa,
  cases hf ⟨strict_upper_bounds A,_⟩,
  rw ← hbinex at right,
  apply right,
  exact hainA,
  intros b hb,
  split,
  left,
  exact and.left hb,
  cases hb,
  exact hb_right,
end

private lemma initial_segment_by_extension {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) : initial_segment (conforming_set_extension hA) (f ⟨strict_upper_bounds A, all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me A  (and.left (some hA))⟩) = A :=
begin
  apply subset_antisymmetric,
  split,
  intros h hb,
  cases hb with hbinex hb,
  cases hb with nb hless,
  cases hbinex,
  exact hbinex,
  apply false.elim,
  apply nb,
  exact hbinex,
  intros b hb,
  split,
  left,
  exact hb,
  cases hf ⟨strict_upper_bounds A,_⟩,
  split,
  intros ab,
  rw ← ab at left,
  apply left,
  exact hb,
  apply right b,
  exact hb,
end

private lemma conforming_set_extension_initial_segments_by_extension {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) : initial_segment (conforming_set_extension hA) (f ⟨strict_upper_bounds A, all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me A  (and.left (some hA))⟩) = A :=
begin
  apply subset_antisymmetric,
  split,
  intros a ha,
  cases ha with hainex ha,
  cases ha with na haless,
  cases hainex,
  exact hainex,
  cases hf ⟨strict_upper_bounds A,_⟩,
  apply false.elim,
  apply na,
  exact hainex,
  apply all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me,
  apply conforming_set_chain,
  exact hA,
  intros a ha,
  split,
  left,
  exact ha,
  cases hf ⟨strict_upper_bounds A,_⟩,
  split,
  intro ab,
  rw ab at ha,
  apply left,
  exact ha,
  apply right,
  exact ha,
end

/-
  Most of this lemma is fighting the type checker to acknowledge that the previous 3 lemmas
  give the result.
-/

private lemma conforming_set_extension_conforming_set {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) : conforming_set hcb hno_me hf (conforming_set_extension hA) :=
begin
  split,
  intros a ha,
  have n₁ : ∃ b, b ∈ strict_upper_bounds (initial_segment (conforming_set_extension hA) a),
    apply all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me,
    apply initial_segment_chain,
    apply conforming_set_extension_well_ordered,
  let α₁ : {S : set P //  ∃ x : P, x ∈ S} := ⟨strict_upper_bounds (initial_segment (conforming_set_extension hA) a),n₁⟩,
  have hval1 : α₁.val =  strict_upper_bounds (initial_segment (conforming_set_extension hA) a) := rfl,
  have trv₁ : f ⟨strict_upper_bounds (initial_segment (conforming_set_extension hA) a), _⟩ = f α₁ := rfl,
  have n₂ : ∃ b, b ∈ strict_upper_bounds (initial_segment A a),
    apply all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me,
    apply initial_segment_chain,
    apply conforming_set_well_ordered hA,
  let α₂ : {S : set P //  ∃ x : P, x ∈ S} := ⟨strict_upper_bounds (initial_segment A a), n₂⟩,
  have hval2 : α₂.val = strict_upper_bounds (initial_segment A a) := rfl,
  have trv₂ : f ⟨strict_upper_bounds (initial_segment A a), _⟩ = f α₂ := rfl,
  have n₃ : ∃ b, b ∈ strict_upper_bounds A,
    apply all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me,
    apply conforming_set_chain hA,
  let α₃ : {S : set P //  ∃ x : P, x ∈ S} := ⟨ strict_upper_bounds A,n₃⟩,
  have hval3 : α₃.val = strict_upper_bounds A := rfl,
  have trv₃ : f ⟨strict_upper_bounds A,_⟩ = f α₃ := rfl,
  cases ha,
  have hα1α2 : α₁ = α₂,
    apply val_injective,
    rw [hval1, hval2, conforming_set_extension_initial_segments_by_elms_in_set hA ha],
  rw [trv₁,hα1α2,← trv₂],
  apply some_spec hA,
  exact ha,
  have hα1α3 : α₁ = α₃,
    apply val_injective,
    rw [hval1, hval3, ha, initial_segment_by_extension hA],
  rw [trv₁,hα1α3,← trv₃,ha],
  exact conforming_set_extension_well_ordered hA,
end

private lemma half_csisocs {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) {B : set P}  (hB : conforming_set hcb hno_me hf B) (nAminusB : A \ B ≠ ∅ ) : ∃ a, B = initial_segment A a :=
begin
  let x := min (conforming_set_well_ordered hA) (A \ B) (difference_in_numerator A B) nAminusB,
  have hx : x ∈ A \ B ∧ ∀ a, a ∈ A \ B → x ≤ a := min_property (conforming_set_well_ordered hA) (difference_in_numerator A B) nAminusB,
  existsi x,
  apply subset_antisymmetric,
  rw and_comm,
  split,
  intros a hainIx,
  apply min_of_complement hx,
  exact and.left hainIx,
  exact and.left (and.right hainIx),
  exact and.right(and.right hainIx),
  apply empty_diff_implies_subset,
  by_contradiction,
  let y := min (conforming_set_well_ordered hB) (B \ (initial_segment A x)) (difference_in_numerator B (initial_segment A x)) h,
  have hy : y ∈ B \ (initial_segment A x) ∧ ∀ a, a ∈ B \ (initial_segment A x) → y ≤ a := min_property _ _ _,
  have hIByinIAx : initial_segment B y ⊆ initial_segment A x,
    intros u hu,
    apply min_of_complement hy,
    exact and.left hu,
    exact and.left (and.right hu),
    exact and.right (and.right hu),
  have bound_test : ∀ {u v : P}, u ∈ initial_segment B y → v ∈ A → v ≠ u → v ≤ u → v ∈ initial_segment B y,
    intros u v hu hv nvu hvlessu,
    have hvinB : v ∈ B,
    apply min_of_complement hx,
    exact hv,
    intro ab,
    apply nvu,
    apply le_antisymm,
    exact hvlessu,
    rw ab,
    exact and.right (and.right (hIByinIAx hu)),
    apply le_trans,
    exact hvlessu,
    exact and.right (and.right (hIByinIAx hu)),
    split,
    exact hvinB,
    split,
    intro ab,
    apply nvu,
    apply le_antisymm,
    exact hvlessu,
    rw ab,
    exact and.right (and.right hu),
    apply le_trans,
    exact hvlessu,
    exact and.right (and.right hu),
  have hbz : A \ (initial_segment B y) ≠ ∅,
    have hbzsub : A \ B ⊆ A \ (initial_segment B y),
      apply diff_by_subset_superset,
      apply initial_segment_subset,
      intro ab,
    rw ab at hbzsub,
    exact hbzsub (some_spec (not_empty_set_has_element nAminusB)),
  let z := min (conforming_set_well_ordered hA) (A \ (initial_segment B y)) (difference_in_numerator A (initial_segment B y)) hbz,
  have hz : z ∈ A \ (initial_segment B y) ∧ ∀ a, a ∈ A \ (initial_segment B y) → z ≤ a := min_property _ _ _,
  have hzlessx : z ≤ x,
    apply and.right hz,
    apply diff_by_subset_superset,
    exact hIByinIAx,
    split,
    exact and.left (and.left hx),
    intro ab,
    cases ab,
    exact and.left ab_right rfl,
  have hAxinAz : initial_segment A z ⊆ initial_segment A x,
    apply initial_segment_preserves_order,
    exact hzlessx,
  have hrw : initial_segment B y = initial_segment A z,
    symmetry,
    apply subset_antisymmetric,
    split,
    intros α hα,
    cases hα with hα₁ hα₂,
    cases hα₂ with hα₂ hα₃,
    apply min_of_complement hz,
    exact hα₁,
    exact hα₂,
    exact hα₃,
    intros β hβ,
    cases hβ with hβ₁ hβ₂,
    cases hβ₂ with hβ₂ hβ₃,
    split,
    apply initial_segment_subset,
    apply min_of_complement hy,
    exact hβ₁,
    exact hβ₂,
    exact hβ₃,
    split,
    by_contradiction,
    apply and.right (and.left hz),
    rw ← h,
    exact ⟨hβ₁,⟨hβ₂,hβ₃⟩⟩,
    by_contradiction,
    have h1 : z ≤ β ∧ β ≠ z,
      apply negation_of_le,
      apply conforming_set_chain,
      exact hA,
    split,
    apply initial_segment_subset,
    apply min_of_complement hy,
    exact hβ₁,
    exact hβ₂,
    exact hβ₃,
    exact and.left (and.left hz),
    exact h,
    apply and.right (and.left hz),
    apply bound_test,
    exact ⟨hβ₁,⟨hβ₂,hβ₃⟩⟩,
    exact and.left (and.left hz),
    intro h2,
    rw h2 at h1,
    apply and.right h1,
    refl,
    exact and.left h1,
  have hyisz : y = z,
    let α₁ := subtype.mk (strict_upper_bounds (initial_segment B y)) (all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me (initial_segment B y) (initial_segment_chain  (some hB))),
    let α₂ := subtype.mk (strict_upper_bounds (initial_segment A z)) (all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me (initial_segment A z) (initial_segment_chain  (some hA))),
    let hy1 : y = f α₁ := (some_spec hB) (and.left (and.left hy)),
    let hz1 : z = f α₂ := (some_spec hA) (and.left (and.left hz)),
    have hrw1 : α₁ = α₂,
      apply val_injective,
      have trv₁ : α₁.val = strict_upper_bounds (initial_segment B y) := rfl,
      have trv₂ : α₂.val = strict_upper_bounds (initial_segment A z) := rfl,
      rw hrw at trv₁,
      rw ← trv₁ at trv₂,
      symmetry,
      exact trv₂,
    rw [hrw1,← hz1] at hy1,
    exact hy1,
  apply and.right (and.left hy),
  rw hyisz,
  split,
  exact and.left (and.left hz),
  split,
  intro ab,
  rw ab at hyisz,
  apply and.right (and.left hx),
  rw ← hyisz,
  exact and.left (and.left hy),
  exact hzlessx,
end

private lemma conforming_sets_overlap_and_is {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {A : set P} (hA : conforming_set hcb hno_me hf A) {B : set P} (hB : conforming_set hcb hno_me hf B) (nAB : A ≠ B) : (∃ a, A = initial_segment B a) ∨ (∃ a, B = initial_segment A a) :=
begin
  cases (not_equal_in_terms_of_comp nAB),
  right,
  apply half_csisocs,
  exact hA,
  exact hB,
  exact h,
  left,
  apply half_csisocs,
  exact hB,
  exact hA,
  exact h,
end

@[reducible]
private def union_of_conforming_sets {P: Type u} [partial_order P] (hcb : all_chains_bounded P) (hno_me : ∀ p : P, ¬ (maximal_element p))
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  (hf : choice_function f) : set P := λ p : P, ∃ A : set P, p ∈ A ∧ (conforming_set hcb hno_me hf A)

private lemma le_test_for_being_in_conforming_set {P: Type u} [partial_order P] {hcb : all_chains_bounded P} {hno_me : ∀ p : P, ¬ (maximal_element p)}
  {f : {S : set P //  ∃ p : P, p ∈ S} → P}
  {hf : choice_function f} {C : set P} (hC : conforming_set hcb hno_me hf C) {x : P} {hxinC : x ∈ C} : ∀ {y}, y ∈ union_of_conforming_sets hcb hno_me hf → y ≤ x → y ∈ C :=
begin
  intros y hyinuoc hylessx,
  cases hyinuoc with Cy hCy,
  cases hCy with hyinCy hCy,
  by_cases C = Cy,
  rw ← h at hyinCy,
  exact hyinCy,
  cases (conforming_sets_overlap_and_is hC hCy h) with h1,
  let a := some h1,
  have hCis : C = initial_segment Cy a := some_spec h1,
  rw hCis at hxinC,
  rw hCis,
  cases hxinC,
  cases hxinC_right with hxnota hxlessa,
  split,
  exact hyinCy,
  split,
  intro ab,
  apply hxnota,
  rw ← ab,
  rw ← ab at hxlessa,
  apply le_antisymm,
  exact hxlessa,
  exact hylessx,
  apply le_trans,
  exact hylessx,
  exact hxlessa,
  rw some_spec h_1 at hyinCy,
  exact and.left hyinCy,
end

private lemma union_of_conforming_sets_well_ordered {P: Type u} [po:partial_order P] (hcb : all_chains_bounded P) (hno_me : ∀ p : P, ¬ (maximal_element p))
  {f : {S : set P //  ∃ p : P, p ∈ S} → P} (hf : choice_function f) : well_ordered (union_of_conforming_sets hcb hno_me hf) :=
begin
  have uoc_chain : is_chain (union_of_conforming_sets hcb hno_me hf),
    intros a b hab,
    cases hab with ha hb,
    cases ha with Ca hCa,
    cases hCa with hainCa hCa,
    cases hb with Cb hCb,
    cases hCb with hbinCb hCb,
    cases em (Ca = Cb) with h,
    apply and.left (some (hCb)),
    rw h at hainCa,
    exact ⟨hainCa,hbinCb⟩,
    have h1 := conforming_sets_overlap_and_is hCa hCb h,
    cases h1,
    apply and.left (some hCb),
    have h2 := some_spec h1,
    rw h2 at hainCa,
    split,
    apply initial_segment_subset,
    exact hainCa,
    exact hbinCb,
    apply and.left (some hCa),
    have h2 := some_spec h1,
    rw h2 at hbinCb,
    split,
    exact hainCa,
    apply initial_segment_subset,
    exact hbinCb,
  split,
  exact uoc_chain,
  intros S hS nS,
  let x := some (not_empty_set_has_element nS),
  have hx : x ∈ S := some_spec (not_empty_set_has_element nS),
  cases hS hx with Cx hCx,
  cases hCx with hxinCx hCx,
  have nCxS : Cx ∩ S ≠ ∅,
    let h2 : x ∈ Cx ∩ S := ⟨hxinCx, hx⟩,
    intro ab,
    rw ab at h2,
    exact h2,
  existsi (min (conforming_set_well_ordered hCx) (Cx ∩ S) (intersection_in_set) nCxS),
  let min_prop := min_property (conforming_set_well_ordered hCx) (intersection_in_set) nCxS,
  split,
  apply intersection_in_set,
  rw @intersection_commuative P S Cx,
  exact and.left (min_prop),
  intros a hainS,
  have sub : x ≤ a ∨ a ≤ x,
    apply uoc_chain,
    split,
    apply hS,
    exact hx,
    apply hS,
    exact hainS,
  cases sub,
  apply le_trans,
  apply and.right min_prop,
  exact ⟨hxinCx,hx⟩,
  exact sub,
  have hainCx : a ∈ Cx,
    apply le_test_for_being_in_conforming_set,
    exact hCx,
    exact hxinCx,
    apply hS,
    exact hainS,
    exact sub,
  apply and.right min_prop,
  exact ⟨hainCx,hainS⟩,
end

private lemma union_of_conforming_sets_conforming_sets {P: Type u} [partial_order P] (hcb : all_chains_bounded P) (hno_me : ∀ p : P, ¬ (maximal_element p))
  {f : {S : set P //  ∃ p : P, p ∈ S} → P} (hf : choice_function f) : conforming_set hcb hno_me hf (union_of_conforming_sets hcb hno_me hf) :=
begin
  split,
  intros a hainuoc,
  let Ca := some hainuoc,
  have hCa : a ∈ Ca ∧ conforming_set hcb hno_me hf Ca := some_spec hainuoc,
  cases hCa with hainCa hCa,
  have hrw : initial_segment (union_of_conforming_sets hcb hno_me hf) a = initial_segment Ca a,
    apply subset_antisymmetric,
    split,
    intros b hb,
    split,
    apply le_test_for_being_in_conforming_set,
    exact hCa,
    exact hainCa,
    apply initial_segment_subset,
    exact hb,
    exact and.right (and.right hb),
    exact and.right hb,
    intros b hb,
    cases hb with hbinCa hb,
    split,
    existsi Ca,
    exact ⟨hbinCa,hCa⟩,
    exact hb,
  have n₁ : ∃ b, b ∈ strict_upper_bounds (initial_segment (union_of_conforming_sets hcb hno_me hf) a),
    apply all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me,
    apply initial_segment_chain,
    apply union_of_conforming_sets_well_ordered,
  let α₁ : {S : set P //  ∃ x : P, x ∈ S} := ⟨strict_upper_bounds (initial_segment (union_of_conforming_sets hcb hno_me hf) a),n₁⟩,
  have hval1 : α₁.val = strict_upper_bounds (initial_segment (union_of_conforming_sets hcb hno_me hf) a) := rfl,
  have trv₁ : f ⟨strict_upper_bounds (initial_segment (union_of_conforming_sets hcb hno_me hf) a),n₁⟩ = f α₁ := rfl,
  have n₂ : ∃ b, b ∈ strict_upper_bounds (initial_segment Ca a),
    apply all_chains_bounded_implies_SUBs_non_empty_when_no_me hcb hno_me,
    apply initial_segment_chain,
    exact conforming_set_well_ordered hCa,
  let α₂ : {S : set P //  ∃ x : P, x ∈ S} := ⟨strict_upper_bounds (initial_segment Ca a),n₂⟩,
  have hval2 : α₂.val = strict_upper_bounds (initial_segment Ca a) := rfl,
  have trv₂ : f ⟨strict_upper_bounds (initial_segment Ca a),n₂⟩ = f α₂ := rfl,
  have hα₁α₂ : α₁ = α₂,
    apply val_injective,
    rw [hval1,hval2,hrw],
  rw [trv₁,hα₁α₂,← trv₂],
  apply some_spec hCa,
  exact hainCa,
  apply union_of_conforming_sets_well_ordered,
end

theorem zorns_lemma {P : Type u} [po:partial_order P] : all_chains_bounded P → ∃ m : P, maximal_element m :=
begin
  intro hcb,
  by_contradiction raw_hno_me,
  let hno_me := forall_not_of_not_exists raw_hno_me,
  let f := some (@there_is_choice_function P),
  let hf : choice_function f := some_spec there_is_choice_function,
  let uoc : set P := union_of_conforming_sets hcb hno_me hf,
  let huoc : conforming_set hcb hno_me  hf uoc := union_of_conforming_sets_conforming_sets hcb hno_me hf,
  let exuoc : set P := conforming_set_extension huoc,
  let hexuoc : conforming_set hcb hno_me hf exuoc := conforming_set_extension_conforming_set huoc,
  let a := f ⟨strict_upper_bounds uoc,_⟩,
  let ha : a ∈ strict_upper_bounds uoc := hf ⟨strict_upper_bounds uoc,_⟩,
  have hainex : a ∈ exuoc,
    right,
    refl,
  have hainuoc : a ∈ uoc,
    existsi exuoc,
    split,
    exact hainex,
    exact hexuoc,
  exact (and.left ha) hainuoc,
end


import algebra.ring

variables {α : Type*} [comm_ring α]

local attribute [simp] mul_comm mul_assoc mul_left_comm
local attribute [simp] add_assoc add_comm add_left_comm

example (x y z : α) : (x - x) * y + z = z :=
begin simp end

example (x y z w : α) : x * y + z * w * x = x * w * z + y * x :=
by simp

def f (m n : ℕ) : ℕ := m + n + m

example {m n : ℕ} (h : n = 1) (h' : 0 = m) : (f m n) = n :=
by simp [h, h'.symm, f]


-- Seq num 1
import Ensembles_et_applications
import compute
section course
namespace ensembles_et_applications
namespace exercices
namespace injectivite_surjectivite_composition

open set

set_option trace.simp_lemmas true
set_option trace.simplify true
set_option trace.debug true

@[simp]
lemma sing_rw {X : Type} {x: X}: sing x = {x} :=
begin
  refl,
end

variables (X Y: Type) (A: set X) (f: X → Y) (x: X)

example : f '' (sing x) = sing (f x) :=
begin
  repeat {rw sing},
  -- simp_rw sing_rw, --> erreur
  -- simp only [sing_rw],
  exact definitions.applications.theorem.image_singleton,
end

example (e: ℝ) (e_pos: e >0) : (2*e >0) :=
begin
  norm_num,
end
example (e: ℝ) (e_pos: e >0) : (e/(2:ℝ) >0) :=
begin
  norm_num,
end

example
 (X: Type) (Y: Type) (Z: Type) (f: X→Y) (g: Y→Z) (H1: @injective X Y f ) (H2: @injective Y Z g )  :
 @injective X Z (@composition X Y Z g f)  :=
begin
rw ensembles_et_applications.definitions.applications.definition.injectivite, intro x, no_meta_vars,
targets_analysis,
all_goals {hypo_analysis},
end
end injectivite_surjectivite_composition
end exercices
end ensembles_et_applications
end course


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

import field_theory.normal
import field_theory.is_alg_closed.algebraic_closure

/-!
# Normal closures

Let L/K be a finite field extension. The normal closure N/L of L/K is a finite extension
N/L such that N/K is normal and which is informally "the smallest extension with this property".
More formally we could say that if M/L is algebraic and M/K is normal then there exists
a morphism of K-algebras `N →ₐ[K] M`. Note that this morphism may not be unique, and
indeed `N` is only defined up to a non-unique isomorphism in general.

## Main Definitions

- `normal_closure K L` where `L` is a field extension of the field `K`, of finite degree.
-/

--universe u

section field_range

/- def alg_hom.field_range {F K L : Type*} [field F] [field K] [field L] [algebra F K]
  [algebra F L] (φ : K →ₐ[F] L) : intermediate_field F L :=
{ ..φ.range,
  ..φ.to_ring_hom.field_range } -/

/-- Restrict the codomain of a alg_hom `f` to `f.range`.

This is the bundled version of `set.range_factorization`. -/
@[reducible] def alg_hom.field_range_restrict {F K L : Type*} [field F] [field K] [field L] [algebra F K]
  [algebra F L] (φ : K →ₐ[F] L) : K →ₐ[F] φ.field_range :=
φ.cod_restrict φ.range φ.mem_range_self

end field_range

/- section inclusion

noncomputable lemma intermediate_field.inclusion {K L : Type*} [field K] [field L] [algebra K L]
  {S T : intermediate_field K L} (h : S ≤ T) : (↥S →ₐ[K] ↥T) :=
{ to_fun := set.inclusion h,
  map_one' := rfl,
  map_add' := λ _ _, rfl,
  map_mul' := λ _ _, rfl,
  map_zero' := rfl,
  commutes' := λ _, rfl }

end inclusion -/

variables (K L : Type*) [field K] [field L] [algebra K L]

noncomputable! def normal_closure : intermediate_field K (algebraic_closure L) :=
supr (λ φ : (L →ₐ[K] algebraic_closure L), φ.field_range)

namespace normal_closure

lemma le_closure : (is_scalar_tower.to_alg_hom K L (algebraic_closure L)).field_range ≤
  normal_closure K L :=
le_supr _ _

noncomputable instance : algebra L (normal_closure K L) := ring_hom.to_algebra
((intermediate_field.inclusion (le_closure K L)).comp
  ((is_scalar_tower.to_alg_hom K L (algebraic_closure L)).field_range_restrict))

lemma is_normal (h : algebra.is_algebraic K L) : normal K (normal_closure K L) := sorry

lemma is_algebraic (h : algebra.is_algebraic K L) : algebra.is_algebraic K (normal_closure K L) :=
sorry

instance : is_scalar_tower K L (normal_closure K L) := sorry

lemma is_finite_dimensional [finite_dimensional K L] : finite_dimensional K (normal_closure K L) :=
sorry

end normal_closure


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

import group_theory.monoid_localization
import ring_theory.localization.basic

/-!
# Localized Module

Given a commutative ring `R`, a multiplicative subset `S ⊆ R` and an `R`-module `M`, we can localize
`M` by `S`. This gives us a `localization S`-module.

## Main definitions

* `localized_module.r` : the equivalence relation defining this localization, namely
  `(m, s) ≈ (m', s')` if and only if if there is some `u : S` such that `u • s' • m = u • s • m'`.
* `localized_module M S` : the localized module by `S`.
* `localized_module.mk`  : the canonical map sending `(m, s) : M × S ↦ m/s : localized_module M S`
* `localized_module.lift_on` : any well defined function `f : M × S → α` respecting `r` descents to
  a function `localized_module M S → α`
* `localized_module.lift_on₂` : any well defined function `f : M × S → M × S → α` respecting `r`
  descents to a function `localized_module M S → localized_module M S`
* `localized_module.mk_add_mk` : in the localized module
  `mk m s + mk m' s' = mk (s' • m + s • m') (s * s')`
* `localized_module.mk_smul_mk` : in the localized module, for any `r : R`, `s t : S`, `m : M`,
  we have `mk r s • mk m t = mk (r • m) (s * t)` where `mk r s : localization S` is localized ring
  by `S`.
* `localized_module.is_module` : `localized_module M S` is a `localization S`-module.

-/

namespace localized_module

universes u v

variables {R : Type u} [comm_semiring R] (M : Type v) [add_comm_monoid M] [module R M]
variables (S : submonoid R)

/--The equivalence relation on `M × S` where `(m1, s1) ≈ (m2, s2)` if and only if
for some (u : S), u * (s2 • m1 - s1 • m2) = 0-/
def r (p1 p2 : M × S) : Prop :=
match p1, p2 with
| ⟨m1, s1⟩, ⟨m2, s2⟩ := ∃ (u : S), u • s1 • m2 = u • s2 • m1
end

lemma r.is_equiv : is_equiv _ (r M S) :=
{ refl := λ ⟨m, s⟩, ⟨1, by rw [one_smul]⟩,
  trans := λ ⟨m1, s1⟩ ⟨m2, s2⟩ ⟨m3, s3⟩ ⟨u1, hu1⟩ ⟨u2, hu2⟩, begin
    use u1 * u2 * s2,
    rw calc (u1 * u2 * s2) • s1 • m3
        = (u1 * u2 * s2 * s1) • m3 : by simp only [mul_smul]
    ... = (u1 * s1 * (u2 * s2)) • m3 : by congr' 1; ext; simp only [submonoid.coe_mul]; ring
    ... = (u1 * s1) • u2 • s2 • m3 : by simp only [mul_smul]
    ... = (u1 * s1) • u2 • s3 • m2 : by rw [hu2]
    ... = (u1 * s1 * (u2 * s3)) • m2 : by simp only [mul_smul]
    ... = (u2 * s3 * (u1 * s1)) • m2 : by congr' 1; ext; simp only [submonoid.coe_mul]; ring
    ... = (u2 * s3) • u1 • s1 • m2 : by simp only [mul_smul]
    ... = (u2 * s3) • u1 • s2 • m1 : by rw [hu1]
    ... = ((u2 * s3) * u1 * s2) • m1 : by simp only [mul_smul],
    rw [← mul_smul],
    congr' 1,
    ext,
    simp only [submonoid.coe_mul],
    ring
  end,
  symm := λ ⟨m1, s1⟩ ⟨m2, s2⟩ ⟨u, hu⟩, ⟨u, hu.symm⟩ }

instance r.setoid : setoid (M × S) :=
{ r := r M S,
  iseqv := ⟨(r.is_equiv M S).refl, (r.is_equiv M S).symm, (r.is_equiv M S).trans⟩ }

/--
If `S` is a multiplicative subset of a ring `R` and `M` an `R`-module, then
we can localize `M` by `S`.
-/
@[nolint has_inhabited_instance]
def _root_.localized_module : Type (max u v) := quotient (r.setoid M S)

section
variables {M S}

/--The canonical map sending `(m, s) ↦ m/s`-/
def mk (m : M) (s : S) : localized_module M S :=
quotient.mk ⟨m, s⟩

lemma mk_eq {m m' : M} {s s' : S} : mk m s = mk m' s' ↔ ∃ (u : S), u • s • m' = u • s' • m :=
quotient.eq

@[elab_as_eliminator]
lemma induction_on {β : localized_module M S → Prop} (h : ∀ (m : M) (s : S), β (mk m s)) :
  ∀ (x : localized_module M S), β x := λ x,
begin
  induction x using quotient.induction_on,
  rcases x with ⟨m, s⟩,
  exact h m s,
end

@[elab_as_eliminator]
lemma induction_on₂ {β : localized_module M S → localized_module M S → Prop}
  (h : ∀ (m m' : M) (s s' : S), β (mk m s) (mk m' s')) : ∀ x y, β x y := λ x y,
begin
  induction x using quotient.induction_on,
  induction y using quotient.induction_on,
  rcases ⟨x, y⟩ with ⟨⟨m, s⟩, ⟨m', s'⟩⟩,
  convert h m m' s s',
end

/--If `f : M × S → α` respects the equivalence relation `localized_module.r`, then
`f` descents to a map `localized_module M S → α`.
-/
def lift_on {α : Type*} (x : localized_module M S) (f : M × S → α)
  (wd : ∀ (p p' : M × S) (h1 : p ≈ p'), f p = f p') : α :=
quotient.lift_on x f wd

lemma lift_on_mk {α : Type*} {f : M × S → α}
  (wd : ∀ (p p' : M × S) (h1 : p ≈ p'), f p = f p')
  (m : M) (s : S) :
  lift_on (mk m s) f wd = f ⟨m, s⟩ :=
by convert quotient.lift_on_mk f wd ⟨m, s⟩

/--If `f : M × S → M × S → α` respects the equivalence relation `localized_module.r`, then
`f` descents to a map `localized_module M S → localized_module M S → α`.
-/
def lift_on₂ {α : Type*} (x y : localized_module M S) (f : (M × S) → (M × S) → α)
  (wd : ∀ (p q p' q' : M × S) (h1 : p ≈ p') (h2 : q ≈ q'), f p q = f p' q') : α :=
quotient.lift_on₂ x y f wd

lemma lift_on₂_mk {α : Type*} (f : (M × S) → (M × S) → α)
  (wd : ∀ (p q p' q' : M × S) (h1 : p ≈ p') (h2 : q ≈ q'), f p q = f p' q')
  (m m' : M) (s s' : S) :
  lift_on₂ (mk m s) (mk m' s') f wd = f ⟨m, s⟩ ⟨m', s'⟩ :=
by convert quotient.lift_on₂_mk f wd _ _

instance : has_zero (localized_module M S) := ⟨mk 0 1⟩
lemma zero_mk (s : S) : mk (0 : M) s = 0 :=
mk_eq.mpr ⟨1, by rw [one_smul, smul_zero, smul_zero, one_smul]⟩

instance : has_add (localized_module M S) :=
{ add := λ p1 p2, lift_on₂ p1 p2 (λ x y, mk (y.2 • x.1 + x.2 • y.1) (x.2 * y.2)) $
    λ ⟨m1, s1⟩ ⟨m2, s2⟩ ⟨m1', s1'⟩ ⟨m2', s2'⟩ ⟨u1, hu1⟩ ⟨u2, hu2⟩, mk_eq.mpr ⟨u1 * u2, begin
      calc (u1 * u2) • (s1 * s2) • (s2' • m1' + s1' • m2')
          = (u1 * u2) • (s1 * s2) • s2' • m1' + (u1 * u2) • (s1 * s2) • s1' • m2'
          : by simp only [smul_add]
      ... = (u1 * u2 * (s1 * s2) * s2') • m1' + (u1 * u2 * (s1 * s2) * s1') • m2'
          : by simp only [mul_smul]
      ... = ((u2 * s2 * s2') * (u1 * s1)) • m1' + (u1 * u2 * (s1 * s2) * s1') • m2'
          : by congr' 2; ext; simp only [submonoid.coe_mul]; ring
      ... = (u2 * s2 * s2') • u1 • s1 • m1' + (u1 * u2 * (s1 * s2) * s1') • m2'
          : by simp only [mul_smul]
      ... = (u2 * s2 * s2') • u1 • s1' • m1 + (u1 * u2 * (s1 * s2) * s1') • m2' : by rw [hu1]
      ... = ((u2 * s2 * s2') * u1 * s1') • m1 + (u1 * u2 * (s1 * s2) * s1') • m2'
          : by simp only [mul_smul]
      ... = ((u1 * u2) * (s1' * s2') * s2) • m1 + (u1 * u2 * (s1 * s2) * s1') • m2'
          : by congr' 2; ext; simp only [submonoid.coe_mul]; ring
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + (u1 * u2 * (s1 * s2) * s1') • m2'
          : by congr' 1; simp [mul_smul]
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + ((u1 * s1 * s1') * (u2 * s2)) • m2'
          : by congr' 2; ext; simp only [submonoid.coe_mul]; ring
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + (u1 * s1 * s1') • u2 • s2 • m2'
          : by simp [mul_smul]
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + (u1 * s1 * s1') • u2 • s2' • m2 : by rw [hu2]
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + ((u1 * s1 * s1') * (u2 * s2')) • m2
          : by simp [mul_smul]
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + ((u1 * u2) * (s1' * s2') * s1) • m2
          : by congr' 2; ext; simp only [submonoid.coe_mul]; ring
      ... = (u1 * u2) • (s1' • s2') • s2 • m1 + (u1 * u2) • (s1' • s2') • s1 • m2
          : by simp [mul_smul]
      ... = (u1 * u2) • (s1' * s2') • (s2 • m1 + s1 • m2) : by simp [smul_add],
    end⟩ }

lemma mk_add_mk {m1 m2 : M} {s1 s2 : S} :
  mk m1 s1 + mk m2 s2 = mk (s2 • m1 + s1 • m2) (s1 * s2) :=
mk_eq.mpr $ ⟨1, by dsimp only; rw [one_smul]⟩

lemma mk_zero (s : S) : mk (0 : M) s = 0 :=
mk_eq.mpr ⟨1, by simp only [smul_zero]⟩

lemma add_assoc' (x y z : localized_module M S) :
  x + y + z = x + (y + z) :=
begin
  induction x using localized_module.induction_on with mx sx,
  induction y using localized_module.induction_on with my sy,
  induction z using localized_module.induction_on with mz sz,
  simp [mk_add_mk],
  refine mk_eq.mpr ⟨1, _⟩,
  rw [one_smul, one_smul],
  congr' 1,
  { rw [mul_assoc] },
  { rw [mul_comm, add_assoc, mul_smul, mul_smul, ←mul_smul sx sz, mul_comm, mul_smul], },
end

lemma add_comm' (x y : localized_module M S) :
  x + y = y + x :=
localized_module.induction_on₂ (λ m m' s s', by rw [mk_add_mk, mk_add_mk, add_comm, mul_comm]) x y

lemma zero_add' (x : localized_module M S) : 0 + x = x :=
induction_on (λ m s, by rw [← zero_mk s, mk_add_mk, smul_zero, zero_add, mk_eq];
  exact ⟨1, by rw [one_smul, mul_smul, one_smul]⟩) x

lemma add_zero' (x : localized_module M S) : x + 0 = x :=
induction_on (λ m s, by rw [← zero_mk s, mk_add_mk, smul_zero, add_zero, mk_eq];
  exact ⟨1, by rw [one_smul, mul_smul, one_smul]⟩) x

instance has_nat_scalar : has_scalar ℕ (localized_module M S) :=
{ smul := λ n, nat.rec_on n (λ x, 0) (λ m f x, x + f x) }

lemma nsmul_zero' (x : localized_module M S) : (0 : ℕ) • x = 0 :=
localized_module.induction_on (λ _ _, rfl) x
lemma nsmul_succ' (n : ℕ) (x : localized_module M S) :
  n.succ • x = x + n • x :=
localized_module.induction_on (λ _ _, rfl) x

instance : add_comm_monoid (localized_module M S) :=
{ add := (+),
  add_assoc := add_assoc',
  zero := 0,
  zero_add := zero_add',
  add_zero := add_zero',
  nsmul := (•),
  nsmul_zero' := nsmul_zero',
  nsmul_succ' := nsmul_succ',
  add_comm := add_comm' }

instance : has_scalar (localization S) (localized_module M S) :=
{ smul := λ f x, localization.lift_on f (λ r s, lift_on x (λ p, mk (r • p.1) (s * p.2))
    begin
      rintros ⟨m1, t1⟩ ⟨m2, t2⟩ ⟨u, h⟩,
      refine mk_eq.mpr ⟨u, _⟩,
      dsimp only,
      calc u • (s * t1) • r • m2
          = ((u : R) * (s * t1) * r) • m2 : by simp only [mul_smul]; congr
      ... = ((s : R) * r * (u * t1)) • m2 : by congr' 1; ring
      ... = ((s : R) * r) • u • t1 • m2 : by simp only [mul_smul]; congr
      ... = ((s : R) * r) • u • t2 • m1 : by rw [h]
      ... = ((s : R) * r * (u * t2)) • m1 : by simp only [mul_smul]; congr
      ... = ((u : R) * (s * t2) * r) • m1 : by congr' 1; ring
      ... = u • (s * t2) • r • m1 : by simp only [mul_smul]; congr,
    end) begin
      induction x using localized_module.induction_on with m t,
      rintros r r' s s' h,
      dsimp only,
      rw [lift_on_mk, lift_on_mk],
      rw localization.r_iff_exists at h,
      rcases h with ⟨u, eq1⟩,
      rw mk_eq,
      simp only at eq1 ⊢,
      refine ⟨u, _⟩,
      calc u • (s * t) • r' • m
          = ((u : R) * (s * t) * r') • m : by simp only [mul_smul]; congr
      ... = ((t : R) * (r' * s * u)) • m : by congr' 1; ring
      ... = ((t : R) * (r * s' * u)) • m : by rw [eq1]
      ... = ((u : R) * (s' * t) * r) • m : by congr' 1; ring
      ... = u • (s' * t) • r • m : by simp only [mul_smul]; congr,
    end }

lemma mk_smul_mk (r : R) (m : M) (s t : S) :
  localization.mk r s • mk m t = mk (r • m) (s * t) :=
begin
  unfold has_scalar.smul,
  rw [localization.lift_on_mk, lift_on_mk],
end

lemma one_smul' (m : localized_module M S) :
  (1 : localization S) • m = m :=
begin
  induction m using localized_module.induction_on with m s,
  rw [← localization.mk_one, mk_smul_mk, one_smul, one_mul],
end

lemma mul_smul' (x y : localization S) (m : localized_module M S) :
  (x * y) • m = x • y • m :=
begin
  induction x using localization.induction_on with data,
  induction y using localization.induction_on with data',
  rcases ⟨data, data'⟩ with ⟨⟨r, s⟩, ⟨r', s'⟩⟩,

  induction m using localized_module.induction_on with m t,
  rw [localization.mk_mul, mk_smul_mk, mk_smul_mk, mk_smul_mk, mul_smul, mul_assoc],
end

lemma smul_add' (x : localization S) (y z : localized_module M S) :
  x • (y + z) = x • y + x • z :=
begin
  induction x using localization.induction_on with data,
  rcases data with ⟨r, u⟩,
  induction y using localized_module.induction_on with m s,
  induction z using localized_module.induction_on with n t,
  dsimp only,
  rw [mk_smul_mk, mk_smul_mk, mk_add_mk, mk_smul_mk, mk_add_mk],
  refine mk_eq.mpr _,
  refine ⟨1, _⟩,
  rw [one_smul, one_smul],
  calc (u * (s * t)) • ((u * t) • r • m + (u * s) • r • n)
      = (u * (s * t)) • (u * t) • r • m + (u * (s * t)) • (u * s) • r • n : by rw [smul_add]
  ... = ((u : R) * (s * t) * (u * t) * r) • m + ((u : R) * (s * t) * (u * s) * r) • n
      : by simp only [mul_smul]; congr
  ... = ((u : R) * s * (u * t) * r * t) • m + ((u : R) * s * (u * t) * r * s) • n
      : by congr' 2; ring
  ... = ((u : R) * s * (u * t)) • r • t • m + (u * s * (u * t)) • r • s • n
      : by simp only [mul_smul]; congr
  ... = (u * s * (u * t)) • r • (t • m + s • n) : by simp [smul_add]; congr,
end

lemma smul_zero' (x : localization S) :
  x • (0 : localized_module M S) = 0 :=
begin
  induction x using localization.induction_on with data,
  rcases data with ⟨r, s⟩,
  rw [←zero_mk s, mk_smul_mk, smul_zero, zero_mk, zero_mk],
end

lemma add_smul' (x y : localization S) (z : localized_module M S) :
  (x + y) • z = x • z + y • z :=
begin
  induction x using localization.induction_on with datax,
  induction y using localization.induction_on with datay,
  induction z using localized_module.induction_on with m t,
  rcases ⟨datax, datay⟩ with ⟨⟨r, s⟩, ⟨r', s'⟩⟩,
  rw [localization.add_mk, mk_smul_mk, mk_smul_mk, mk_smul_mk, mk_add_mk],
  refine mk_eq.mpr ⟨1, _⟩,
  rw [one_smul, one_smul],
  dsimp only,
  calc (s * s' * t) • ((s' * t) • r • m + (s * t) • r' • m)
      = (s * s' * t) • (s' * t) • r • m + (s * s' * t) • (s * t) • r' • m : by rw [smul_add]
  ... = ((s : R) * s' * t * (s' * t) * r) • m + ((s : R) * s' * t * (s * t) * r') • m
      : by simp only [mul_smul]; congr
  ... = ((s : R) * t * (s' * t) * s * r') • m + ((s : R) * t * (s' * t) * s' * r) • m
      : by rw add_comm; congr' 2; ring
  ... = (((s : R) * t * (s' * t) * s * r') + ((s : R) * t * (s' * t) * s' * r)) • m
      : by rw add_smul
  ... = ((s : R) * t * (s' * t) * (s * r' + s' * r)) • m : by congr' 2 ; ring
  ... = (s * t * (s' * t)) • ((s : R) * r' + (s' : R) * r) • m : by simp only [mul_smul]; congr
  ... = (s * t * (s' * t)) • ((s : R) * r' + (s' : R) * r) • m : by simp [add_smul]; congr,
end

lemma zero_smul' (x : localized_module M S) :
  (0 : localization S) • x = 0 :=
begin
  induction x using localized_module.induction_on with m s,
  rw [← localization.mk_zero s, mk_smul_mk, zero_smul, zero_mk],
end

instance is_module : module (localization S) (localized_module M S) :=
{ smul := (•),
  one_smul := one_smul',
  mul_smul := mul_smul',
  smul_add := smul_add',
  smul_zero := smul_zero',
  add_smul := add_smul',
  zero_smul := zero_smul' }

end

end localized_module

namespace localized_module

universes u v

variables {R : Type u} [comm_semiring R] (M : Type v) [add_comm_group M] [module R M]
variables (S : submonoid R)

instance : has_neg (localized_module M S) :=
⟨λ x, localized_module.lift_on x (λ p, mk (-p.1) p.2) $ λ ⟨m, s⟩ ⟨n, t⟩ ⟨u, hu⟩,
    mk_eq.mpr ⟨u, by simp only [smul_neg, hu]⟩⟩

lemma neg_mk (m : M) (s : S) : - mk m s = mk (-m) s := rfl

instance : add_comm_group (localized_module M S) :=
{ neg := λ x, localized_module.lift_on x (λ p, mk (-p.1) p.2) $ λ ⟨m, s⟩ ⟨n, t⟩ ⟨u, hu⟩,
    mk_eq.mpr ⟨u, by simp only [smul_neg, hu]⟩,
  add_left_neg := λ x, begin
    induction x using localized_module.induction_on with m s,
    rw [neg_mk, mk_add_mk, smul_neg, add_left_neg, mk_zero],
  end,
  ..(_ : add_comm_monoid (localized_module M S))}

end localized_module


import render.ArrayExtra
import render.NatExtra
import render.Algebra

def Function.leftInverse (g : β → α) (f : α → β) : Prop := ∀ x, g (f x) = x
def Function.rightInverse (g : β → α) (f : α → β) : Prop := Function.leftInverse f g

structure Equiv (α : Sort u) (β : Sort v) where
    toFun : α → β
    invFun : β → α
    leftInv : Function.leftInverse invFun toFun
    rightInv : Function.rightInverse invFun toFun

infix:25 " ≃ " => Equiv

def Equiv.symm (f : α ≃ β) : β ≃ α where
    toFun := f.invFun
    invFun := f.toFun
    leftInv := f.rightInv
    rightInv := f.leftInv

/-- An equivalence "is" a function. -/
instance : CoeFun (α ≃ β) (λ _ => α → β) where
    coe := Equiv.toFun

/-- A finite type with a specific enumeration. -/
class Enumerable (α : Type u) where
    card : Nat
    enum : α ≃ Fin card

instance : Enumerable (Fin n) where
    card := n
    enum := { toFun := id
              invFun := id
              leftInv := λ _ => rfl
              rightInv := λ _ => rfl }

section CartesianProduct

theorem cartEncodeProp {i j m n : Nat} (hi : i < m) (hj : j < n) : i * n + j < m * n := by
    cases m with
    | zero => apply False.elim; exact Nat.notLtZero _ hi
    | succ m => {
        rw Nat.succMul;
        exact Nat.ltOfLeOfLt (Nat.addLeAddRight (Nat.mulLeMulRight _ (Nat.leOfLtSucc hi)) _) (Nat.addLtAddLeft hj _)
    }

def cartDecode {n m : Nat} : Fin (n * m) → Fin n × Fin m
| ⟨k, h⟩ =>
    (⟨k / m, Nat.div_lt_of_lt_mul h⟩,
     ⟨k % m, Nat.modLt _ (by { cases m; apply False.elim; rw Nat.mulZero at h; exact Nat.notLtZero _ h; apply Nat.succPos})⟩)

instance [Enumerable α] [Enumerable β] : Enumerable (α × β) where
    card := Enumerable.card α * Enumerable.card β
    enum := {
        toFun := λ (a, b) =>
            let ⟨i, hi⟩ := Enumerable.enum a
            let ⟨j, hj⟩ := Enumerable.enum b
            ⟨i * Enumerable.card β + j, cartEncodeProp hi hj⟩
        invFun := λ n =>
            let (i, j) := cartDecode n
            (Enumerable.enum.symm i, Enumerable.enum.symm j)
        leftInv := sorry
        rightInv := sorry
    }

end CartesianProduct

instance : Enumerable Bool where
    card := 2
    enum := {
        toFun := fun
        | false => 0
        | true => 1
        invFun := fun
        | ⟨0, _⟩ => false
        | ⟨1, _⟩ => true
        | ⟨n+2, h⟩ => False.elim (Nat.notSuccLeZero _ (Nat.leOfSuccLeSucc (Nat.leOfSuccLeSucc h)))
        leftInv := by
            intro
            | true => rfl
            | false => rfl
        rightInv := by
            intro
            | ⟨0, _⟩ => rfl
            | ⟨1, _⟩ => rfl
            | ⟨n+2, h⟩ => exact False.elim (Nat.notSuccLeZero _ (Nat.leOfSuccLeSucc (Nat.leOfSuccLeSucc h)))
    }

instance : Enumerable Empty where
    card := 0
    enum := {
        toFun := fun t => nomatch t
        invFun := fun
        | ⟨n, h⟩ => False.elim (Nat.notSuccLeZero _ h)
        leftInv := fun t => nomatch t
        rightInv := fun t => nomatch t
    }

def Enumerable.listOf.aux (α : Type u) [Enumerable α] : Nat -> Nat -> List α
| lo, 0 => []
| lo, (left+1) =>
    if h : lo < Enumerable.card α then
        Enumerable.enum.symm ⟨lo, h⟩ :: aux α (lo + 1) left
    else [] -- Shouldn't happen, but makes the definition easy.

/-- Create a list of every term in the Enumerable type in order. -/
def Enumerable.listOf (α : Type u) [Enumerable α] : List α :=
    Enumerable.listOf.aux α 0 (Enumerable.card α)

structure Vec (ι : Type u) [Enumerable ι] (α : Type v) where
    array : Array α
    hasSize : array.size = Enumerable.card ι

namespace Vec
variable {ι : Type _} [Enumerable ι]

def fill (a : α) : Vec ι α where
    array := Array.mkArray (Enumerable.card ι) a
    hasSize := Array.sizeMkArrayEq ..

def empty [Inhabited α] : Vec ι α :=
    fill Inhabited.default

@[inline] def translateIdx (v : Vec ι α) (i : ι) : Fin v.array.size :=
    let ⟨n, h⟩ := Enumerable.enum i
    ⟨n, by rw v.hasSize; exact h⟩

/-- Get the value associated to a particular index. -/
@[inline] def get (v : Vec ι α) (i : ι) : α :=
    v.array.get (v.translateIdx i)

/-- support `v[i]` notation. -/
@[inline] def getOp (self : Vec ι α) (idx : ι) : α := self.get idx

/-- Set the value associated to a particular index. -/
@[inline] def set (v : Vec ι α) (i : ι) (a : α) : Vec ι α where
    array := v.array.set (v.translateIdx i) a
    hasSize := by rw [Array.sizeSetEq, v.hasSize]

@[inline] def forIn {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Vec ι α) (b : β) (f : α → β → m (ForInStep β)) : m β :=
    as.array.forIn b f

def pure (x : α) : Vec ι α := fill x

@[inline] def of (f : ι → α) : Vec ι α where
    array := do
        let mut a := Array.empty
        for i in Enumerable.listOf ι do
            a := a.push $ f i
        return a
    hasSize := sorry -- need to define differently to be able to easily prove this

macro "vec" xs:Lean.explicitBinders " => " b:term : term => Lean.expandExplicitBinders `Vec.of xs b

def reindex (v : Vec ι α) (ι' : Type _) [Enumerable ι'] (h : Enumerable.card ι = Enumerable.card ι') : Vec ι' α where
    array := v.array
    hasSize := by rw [←h, v.hasSize]

def bind [Enumerable κ] (f : α → Vec κ β) (v : Vec ι α) : Vec (ι × κ) β where
    array := Id.run <| Array.foldlM (λ w a => w ++ (f a).array) Array.empty v.array
    hasSize := sorry

@[inline]
def map (v : Vec ι α) (f : α → β) : Vec ι β where
    array := v.array.map f
    hasSize := sorry

@[inline]
def map₂ (v : Vec ι α) (w : Vec ι β) (f : α → β → γ) : Vec ι γ where
    array := Array.map₂ f v.array w.array (by { rw [v.hasSize, ← w.hasSize] })
    hasSize := sorry

instance [Enumerable ι] [Add α] : Add (Vec ι α) where
    add v w := Vec.map₂ v w (. + .)
instance [Enumerable ι] [Sub α] : Sub (Vec ι α) where
    sub v w := Vec.map₂ v w (. - .)
instance [Enumerable ι] [Mul α] : Mul (Vec ι α) where
    mul v w := Vec.map₂ v w (. * .)
instance [Enumerable ι] [Div α] : Div (Vec ι α) where
    div v w := Vec.map₂ v w (. / .)
instance [Enumerable ι] [Neg α] : Neg (Vec ι α) where
    neg v := Vec.map v (- .)

-- Scalar multiplication
instance [Enumerable ι] [Mul α] : HMul α (Vec ι α) (Vec ι α) where
    hMul c v := v.map (c * .)
-- Scalar division
instance [Enumerable ι] [Div α] : HDiv (Vec ι α) α (Vec ι α) where
    hDiv v c := v.map (. / c)
-- Zero vector
instance [Enumerable ι] [Zero α] : Zero (Vec ι α) where
    zero := vec i => 0

def lengthSquared [Add α] [Mul α] [Zero α] (v : Vec ι α) : α :=
    Id.run <| v.array.foldlM (λ x a => x + a * a) 0

def length (v : Vec ι Float) : Float := Float.sqrt <| v.lengthSquared

def normalized (v : Vec ι Float) : Vec ι Float := v / v.length

def dot [Add α] [Mul α] [Zero α] (v w : Vec ι α) : α :=
    Id.run <| Array.foldlM₂ (λ x a b => x + a * b) 0 v.array w.array (by { rw [v.hasSize, ← w.hasSize] })

end Vec

theorem List.toArraySizeEq (x : List α) : x.toArray.size = x.length := sorry

def List.toDenseVec (x : List α) : Vec (Fin x.length) α where
    array := x.toArray
    hasSize := List.toArraySizeEq ..

syntax "![" sepBy(term, ", ") "]" : term

macro_rules
  | `(![ $elems,* ]) => `(List.toDenseVec [ $elems,* ])

instance [Repr α] [Enumerable ι] : Repr (Vec ι α) where
    reprPrec v _ :=
        if v.array.size == 0 then
            "![]"
        else
            Std.Format.bracketFill "![" (@Std.Format.joinSep _ ⟨repr⟩ (v.array.toList) ("," ++ Std.Format.line)) "]"

example : Vec (Fin 3) Nat := ![2,22,222]

abbrev Vec3 (α : Type _) := Vec (Fin 3) α

namespace Vec3

def mk (x y z : α) : Vec3 α where
    array := #[x, y, z]
    hasSize := rfl

@[inline] def x (v : Vec3 α) : α := v[⟨0, rfl⟩]
@[inline] def y (v : Vec3 α) : α := v[⟨1, rfl⟩]
@[inline] def z (v : Vec3 α) : α := v[⟨2, rfl⟩]

def cross [Sub α] [Mul α] (v w : Vec3 α) : Vec3 α :=
    ![v.y*w.z - v.z*w.y, v.z*w.x - v.x*w.z, v.x*w.y - v.y*w.x]

end Vec3

inductive ColorChannel
| R | G | B

open ColorChannel

instance : Enumerable ColorChannel where
    card := 3
    enum := {
        toFun := fun
        | R => 0
        | G => 1
        | B => 2
        invFun := fun
        | ⟨0, _⟩ => R
        | ⟨1, _⟩ => G
        | ⟨2, _⟩ => B
        | ⟨n+3, h⟩ => False.elim (Nat.notSuccLeZero _ (Nat.leOfSuccLeSucc (Nat.leOfSuccLeSucc (Nat.leOfSuccLeSucc h))))
        leftInv := by
            intro
            | R => rfl
            | G => rfl
            | B => rfl
        rightInv := by
            intro
            | ⟨0, _⟩ => rfl
            | ⟨1, _⟩ => rfl
            | ⟨2, _⟩ => rfl
            | ⟨n+3, h⟩ => exact False.elim (Nat.notSuccLeZero _ (Nat.leOfSuccLeSucc (Nat.leOfSuccLeSucc (Nat.leOfSuccLeSucc h))))
    }

abbrev Color α := Vec ColorChannel α

def Color.mk (r g b : α) : Color α where
    array := #[r, g, b]
    hasSize := rfl

namespace Color

@[inline] def r (v : Color α) : α := v[R]
@[inline] def g (v : Color α) : α := v[G]
@[inline] def b (v : Color α) : α := v[B]

end Color


example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
    intro h,
    cases h.right with hq hr,
      show (p ∧ q) ∨ (p ∧ r), from
        or.inl ⟨h.left, hq⟩,
      show (p ∧ q) ∨ (p ∧ r), from
        or.inr ⟨h.left, hr⟩,
    intro h,
    cases h with hpq hpr,
      show p ∧ (q ∨ r), from
        ⟨hpq.left, or.inl hpq.right⟩,
      show p ∧ (q ∨ r), from
        ⟨hpr.left, or.inr hpr.right⟩
end


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_263
  (y : ℝ)
  (h₀ : 0 ≤ 19 + 3 * y)
  (h₁ : real.sqrt (19 + 3 * y) = 7) :
  y = 10 :=
begin
  revert y h₀ h₁,
  intros x hx,
  rw real.sqrt_eq_iff_sq_eq hx,
  swap,
  norm_num,
  intro h,
  nlinarith,
end


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

/--
For how many positive integer values of $x$ is the sum $x^2+4x+4$ less than 20?
Answer: $2$.
Proof:
Note that since we can only use positive integers for $x$, the minimum will be x = 1.
Testing x = 2, we get $2^2 + 4\\cdot 2 + 4 = 16$.
Since $3^2 - 2^2 = 5$, we know that only $x = 1,2$ will work, thus, answer is $\\boxed{2}$.
--/
theorem mathd_algebra_405
  (x : ℕ)
  (h₀ : 0 < x)
  (h₁ : x^2 + 4 * x + 4 < 20) :
  x = 1 ∨ x = 2 :=
begin
  cases lt_trichotomy x 1 with h₂ h₂,
  { left, nlinarith },
  cases h₂,
  { simp * at * },
  right,
  nlinarith [h₁, h₂, 0],
end


import tactic
import data.nat.prime_norm_num
import number_theory.prime_counting

namespace nat
open_locale nat

example : prime 3 :=
begin
  norm_num,
end

example : list.filter prime [0,1,2,3,4,5,6,7,8,9,10] = [2,3,5,7] :=
begin
  unfold list.filter,
  norm_num,
end

example : list.filter prime [2,4] = [2,4] :=
begin
  unfold list.filter,
  norm_num,
end

example : list.countp prime [2,3,5,7] = 4 :=
begin
  unfold list.countp,
end

lemma adjoin_range {n : ℕ} : ∀ l, list.range_core n l = (list.range_core n list.nil) ++ l :=
begin
  induction n with k hk; intros a,
  { refl, },
  { dsimp [list.range_core],
    rw [hk [k], hk (k :: a), list.append_assoc, list.append_right_inj, list.singleton_append], },
end

lemma countp_singleton {α : Type} {p : α → Prop} [decidable_eq α] [decidable_pred p] (a : α) :
list.countp p [a] = ite (p a) 1 0 := rfl

lemma countp_range {n : ℕ} {p : ℕ → Prop} [decidable_pred p] :
list.countp p (list.range n.succ) = (ite (p n) 1 0) + list.countp p (list.range n) :=
begin
  dsimp [list.range],
  simp only [list.range_core, adjoin_range [n], list.countp_append, add_comm, add_left_cancel_iff],
  refl,
end

-- Benchmark: 14.2s, very slow
set_option profiler true
example {n : ℕ} : π 200 = 46 :=
begin
  rw [prime_counting, prime_counting', count],
  repeat { rw countp_range, norm_num1, simp only [if_false, if_true, zero_add], },
  rw [list.range_zero, list.countp_nil],
end

-- Benchmark: 949ms, quite fast
example {n : ℕ} : π 200 = 46 :=
begin
  rw [prime_counting, prime_counting', count],
  dsimp [list.range, list.range_core, list.countp],
  norm_num,
end

-- Benchmark: 949ms, quite fast
example {n : ℕ} : π 1000 = 168 :=
begin
  rw [prime_counting, prime_counting', count],
  dsimp [list.range, list.range_core, list.countp],
  norm_num,
end

end nat


import tactic
import combinatorics.simple_graph.connectivity

namespace simple_graph

/--
 A graph is connected if its vertex set is non-empty,
 and there exists a path between any two vertices.
-/
def is_connected {V : Type} (G : simple_graph V) : Prop :=
  nonempty V ∧ ∀ u v : V, ∃ p : G.walk u v, p.is_path

/-- Graph isomorphisms preserve walks -/
def graph_iso.walk {V W : Type} {G : simple_graph V} {H : simple_graph W}
  (e : G ≃g H) : Π {a b : V}, G.walk a b → H.walk (e(a)) (e(b))
| _ _ simple_graph.walk.nil := walk.nil
| _ _ (simple_graph.walk.cons hGadj Gwalk) :=
  walk.cons (e.map_adj_iff.mpr hGadj) (graph_iso.walk Gwalk)

/-- Graph isomorphisms preserve connectedness -/
lemma graph_iso.connected {V W : Type} {G : simple_graph V} {H : simple_graph W}
  (e : G ≃g H) (hG : is_connected G) : is_connected H :=
begin
  rw is_connected at *,
  cases hG with hG_non_empty hG_has_walk,
  split, {
    use e(hG_non_empty.some),
  }, {
    intros x y,
    set a := e.symm x,
    set b := e.symm y,
    specialize hG_has_walk a b,
    cases hG_has_walk with Gwalk hp,
    set Hwalk := graph_iso.walk e Gwalk,
    -- rewrite (⇑e a) into x
    rw rel_iso.apply_symm_apply at Hwalk,
    -- rewrite (⇑e b) into y
    rw rel_iso.apply_symm_apply at Hwalk,
    -- Create a path from the walk
    classical,
    set p := (simple_graph.walk.to_path Hwalk),
    use p,
    -- p.2 is the field which has the proof that p is a path
    exact p.2,
  },
end

namespace box_product

/--
For non-empty simple graphs G and H, the box product graph G□H is the graph
with vertex set V_G × V_H, where the edge relation is given by
(g₂, h₁)E(g₂, h₂) ↔ (h₁ = h₂ ∧ g₁Eg₂) ∨ (g₁ = g₂ ∧ h₁Eh₂)
-/
def box_product {V W : Type} (G : simple_graph V) (H : simple_graph W) :
  simple_graph (V × W) :=
{
  -- a b : V × W;
  -- `.1` corresponds to an element of G `.2` corresponds to an element of H
  adj := λ (a b), (a.2 = b.2 ∧ G.adj a.1 b.1) ∨ (a.1 = b.1 ∧ H.adj a.2 b.2),
  symm := begin
    intros a b,
    simp only,
    intro h,
    cases h with hg hh, {
      -- First handle the reflexivity of edge relation on G
      left,
      cases hg with hconst Gadj,
      exact ⟨hconst.symm, Gadj.symm⟩,
    }, {
      -- Second handle the reflexivity of edge relation on H
      right,
      cases hh with gconst Hadj,
      exact ⟨gconst.symm, Hadj.symm⟩,
    },
  end,
  loopless := begin
    rw irreflexive,
    intro v,
    simp only [irrefl],
    rw [and_false, and_false, or_self, not_false_iff],
    trivial,
  end
}

/- Define the binary operator □ (typed with ``\square``) which gives the box
 - product of two graphs. Mark precedence as 70 to be above a graph morphism. -/
infix ` □ `:70 := box_product

def is_box_product {V W : Type} (B : simple_graph (V × W)) (G : simple_graph V) (H : simple_graph W) : Prop :=
  ∀ x y : V×W, B.adj x y ↔ ((x.2=y.2 ∧ G.adj x.1 y.1) ∨ (x.1=y.1 ∧ H.adj x.2 y.2))

lemma box_product_is_box_product {V W : Type} (G : simple_graph V) (H : simple_graph W) :
  is_box_product (G□H) G H :=
begin
  intros x y,
  refl,
end

/-- The adjacency relation of the box product when vetices are in terms of V and W -/
lemma box_adj_rel {V W : Type} {a b : V} {x y : W} {G : simple_graph V} {H : simple_graph W} :
  (G□H).adj (a, x) (b, y) ↔ (x = y ∧ G.adj a b) ∨ (a = b ∧ H.adj x y) :=
begin
  refl,
end

/-- The adjacency relation of the box product when vetices are in terms of V×W -/
lemma box_adj_rel_prod {V W : Type} {a b : V×W} {G : simple_graph V} {H : simple_graph W} :
  (G□H).adj a b ↔ (a.snd = b.snd ∧ G.adj a.fst b.fst) ∨ (a.fst = b.fst ∧ H.adj a.snd b.snd) :=
begin
  refl,
end

/-- Proof that the two different agency relations are equivalent -/
lemma box_adj_rels_equiv {V W : Type} {v w : V×W}
  {G : simple_graph V} {H : simple_graph W} :
  (G□H).adj (v.fst, v.snd) (w.fst, w.snd) ↔ (G□H).adj v w :=
begin
  refl,
end

/-- The box product is commutative up to isomorphism -/
def box_product_comm {V W : Type} (G : simple_graph V) (H : simple_graph W) :
  G□H ≃g H□G :=
{
  to_equiv := equiv.prod_comm V W,
  map_rel_iff' := begin
    intros a b,
    split, {
      rw [box_adj_rel_prod, equiv.prod_comm_apply, prod.snd_swap, prod.fst_swap],
      intro hHGadj,
      cases hHGadj with hHadj hGadj, {
        right,
        exact hHadj,
      },{
        left,
        exact hGadj,
      },
    }, {
      intro hHGadj,
      rw [box_adj_rel_prod, equiv.prod_comm_apply, prod.snd_swap, prod.fst_swap],
      cases hHGadj with hGadj hHadj, {
        right,
        exact hGadj,
      }, {
        left, exact hHadj,
      }
    }
  end,
}

/-- The box product is associative up to isomorphism -/
def box_product_assoc {U V W : Type} (G : simple_graph U) (H : simple_graph V)
  (K : simple_graph W) : (G□H)□K ≃g G□(H□K) :=
{
  to_equiv := equiv.prod_assoc U V W,
  map_rel_iff' := begin
    intros a b,
    rw [equiv.prod_assoc_apply, box_adj_rel_prod, equiv.prod_assoc_apply, prod.mk.inj_iff],
    split, {
      intro h,
      cases h with hBGadj hBHK, {
        left,
        rcases hBGadj with ⟨⟨eq_b, eq_c⟩, hGadj⟩,
        exact ⟨eq_c, or.inl ⟨eq_b, hGadj⟩⟩,
      }, {
        rcases hBHK with ⟨eq_a, hBHKadj⟩,
        dsimp at *,
        cases hBHKadj with hBHadj hBKadj, {
          left,
          dsimp only at hBHadj,
          cases hBHadj with eq_c hHadj,
          exact ⟨eq_c, or.inr ⟨eq_a, hHadj⟩⟩,
        }, {
          right,
          simp only at hBKadj,
          cases hBKadj with eq_b hKadj,
          exact ⟨prod.ext eq_a eq_b, hKadj⟩,
        },
      },
    }, {
      intro h,
      rw box_adj_rel_prod at *,
      simp only,
      cases h with hBGH hBKadj, {
        cases hBGH with eq_c hGHadj,
        cases hGHadj with hGadj hHadj, {
          left,
          cases hGadj with eq_b hG,
          rw [eq_b, eq_self_iff_true, true_and],
          exact ⟨eq_c, hG⟩,
        }, {
          cases hHadj with eq_a hH,
          right,
          split, {
            exact eq_a,
          }, {
            left,
            exact ⟨eq_c, hH⟩,
          }
        },
      }, {
        right,
        cases hBKadj with eq_a_and_b hKadj,
        rw [eq_a_and_b, eq_self_iff_true, true_and],
        simp only [irrefl, and_false, eq_self_iff_true, true_and, false_or],
        exact hKadj,
      },
    },
  end
}

/- Adjacency relations to move between the simple graph and the box product -/
lemma adj_lhs_equiv {V W : Type} {a b : V} {y : W} {G : simple_graph V}
  {H : simple_graph W} : G.adj a b ↔ (G□H).adj (a, y) (b, y) :=
begin
  split, {
    -- Lift from G to G□H
    intro hGadj,
    left,
    rw [eq_self_iff_true, true_and],
    exact hGadj,
  }, {
    -- Projection from G□H to G
    intro hGHadj,
    cases hGHadj with hGB hHB, {
      exact hGB.2,
    }, {
      -- H is a simple graph so there is no edge between w and w
      -- This is the condition irrefel,
      -- and_false simplifies the hyp as if one side of an AND
      -- is false than the prop is false
      simp only [irrefl, and_false] at hHB,
      exfalso,
      exact hHB,
    }
  }
end

lemma adj_rhs_equiv {V W : Type} {a b : W} {x : V} {G : simple_graph V}
  {H : simple_graph W} : H.adj a b ↔ (G□H).adj (x, a) (x, b) :=
begin
  split, {
    -- Lift from H to G□H
    intro hHadj,
    right,
    rw [eq_self_iff_true, true_and],
    exact hHadj,
  }, {
    -- Projection from G□H to H
    intro hGHadj,
    cases hGHadj with hGB hHB, {
      simp only [irrefl] at hGB,
      rw and_false at hGB,
      exfalso,
      exact hGB,
    }, {
      exact hHB.2,
    },
  },
end

-- Lifts of walks from the simple graph to the box product
def lift_walk_lhs {V W : Type} {G : simple_graph V} {H : simple_graph W}
  (y : W) : Π {a b : V}, (G.walk a b) → (G□H).walk (a, y) (b, y)
| _ _ simple_graph.walk.nil := walk.nil
| a b (simple_graph.walk.cons hGadj Gwalk)
  := walk.cons (adj_lhs_equiv.mp hGadj) (lift_walk_lhs Gwalk)

def lift_walk_rhs {V W : Type} {G : simple_graph V} {H : simple_graph W}
  (x : V) : Π {a b : W}, (H.walk a b) → (G□H).walk (x, a) (x, b)
| _ _ simple_graph.walk.nil := walk.nil
| a b (simple_graph.walk.cons hHadj Hwalk)
  := walk.cons (adj_rhs_equiv.mp hHadj) (lift_walk_rhs Hwalk)

-- Project walks from the box product to the component graph
-- It is done by discarding components of the walk which move along an edge of
-- the graph that we are *not* projecting to.
-- Many thanks Kenny Lau for helping with this and figuring out the decidability criteria
def descend_walk_lhs {V W : Type} [decidable_eq V] [decidable_eq W]
  {G : simple_graph V} [decidable_rel G.adj]
  {H : simple_graph W} [decidable_rel H.adj]
  : Π {vw1 vw2 : V × W}, (G□H).walk vw1 vw2 → (G.walk vw1.1 vw2.1)
| _ _ simple_graph.walk.nil := walk.nil
| vw1 vw3 (simple_graph.walk.cons hGHadj p) :=
  or.by_cases hGHadj (λ hBG, walk.cons hBG.2 (descend_walk_lhs p))
  (λ hBH, show G.walk vw1.1 vw3.1, by rw hBH.1; exact descend_walk_lhs p)

def descend_walk_rhs {V W : Type} [decidable_eq V] [decidable_eq W]
  {G : simple_graph V} [decidable_rel G.adj]
  {H : simple_graph W} [decidable_rel H.adj]
  : Π {vw1 vw2 : V × W}, (G□H).walk vw1 vw2 → (H.walk vw1.2 vw2.2)
| _ _ simple_graph.walk.nil := walk.nil
| vw1 vw3 (simple_graph.walk.cons hGHadj p) :=
  or.by_cases hGHadj (λ hGB, show H.walk vw1.2 vw3.2, by rw hGB.1; exact descend_walk_rhs p)
  (λ hHB, walk.cons hHB.2 (descend_walk_rhs p))

/--
  The box product G□H is connected if G and H are connected
  The proof is to compose a lifted path of G with a lifted path of H
-/
lemma G_box_H_is_connected_if_G_H_connected {V W : Type} (G : simple_graph V)
  (H : simple_graph W) : G.is_connected ∧ H.is_connected → (G□H).is_connected :=
begin
  rintros ⟨⟨hG_not_empty, hG_has_path⟩, ⟨hH_not_empty, hH_has_path⟩⟩,
  split, {
    -- Proof that the vertex set of G□H is not empty
    rw nonempty_prod,
    exact ⟨hG_not_empty, hH_not_empty⟩,
  }, {
    -- Proof that there is a path from (g1, h1) to (g2, h2)
    rintros ⟨g1, h1⟩ ⟨g2, h2⟩,
    -- ∃ a path from g₁ to g₂
    specialize hG_has_path g1 g2,
    -- ∃ a path from h₁ to h₂
    specialize hH_has_path h1 h2,
    -- extract the walks
    cases hG_has_path with pg _,
    cases hH_has_path with ph _,
    -- lift the walk in G along the vertex h₁
    set wg := lift_walk_lhs h1 pg,
    -- lift the walk in H along the vertex g₂
    set wh := lift_walk_rhs g2 ph,
    -- Get a walk from (g₁, h₁) to (g₂, h₂)
    set w := walk.append wg wh,
    -- Fix decidability
    classical,
    -- Create a path from the walk
    set p := (simple_graph.walk.to_path w),
    use p,
    -- p.2 is the field which has the proof that p is a path
    exact p.2,
  }
end

lemma G_connected_if_G_box_H_connected {V W : Type}
  (G : simple_graph V) (H : simple_graph W) (hGH_connected: (G□H).is_connected) :
  G.is_connected :=
begin
  cases hGH_connected with hGH_not_empty hGH_has_path,
  rw nonempty_prod at hGH_not_empty,
  cases hGH_not_empty with hG_not_empty hH_not_empty,
  -- Refin goal by giving the proof that G is not empty
  refine ⟨hG_not_empty, _⟩,
  -- G has a path for all g₁ g2
  intros g1 g2,
  set h := hH_not_empty.some,
  specialize hGH_has_path (g1, h) (g2, h),
  cases hGH_has_path with GHw hGHw_p,
  classical,
  set w := descend_walk_lhs GHw,
  -- Create a path from the walk
  set p := (simple_graph.walk.to_path w),
  use p,
  -- p.2 is the field which has the proof that p is a path
  exact p.2,
end

lemma G_and_H_connected_if_G_box_H_connected {V W : Type}
  (G : simple_graph V) (H : simple_graph W) :
  (G□H).is_connected → G.is_connected ∧ H.is_connected :=
begin
  intros hGH_connected,
  split, {
    -- G is connected
    exact G_connected_if_G_box_H_connected G H hGH_connected,
  }, {
    -- H is connected
    -- Get that H□G is connected
    set hHG_connected := graph_iso.connected (box_product_comm G H) hGH_connected,
    exact G_connected_if_G_box_H_connected H G hHG_connected,
  },
end

theorem G_box_H_is_connected_iff_G_H_connected {V W : Type} (G : simple_graph V)
  (H : simple_graph W) : G.is_connected ∧ H.is_connected ↔ (G□H).is_connected :=
  ⟨G_box_H_is_connected_if_G_H_connected G H, G_and_H_connected_if_G_box_H_connected G H⟩

end box_product
end simple_graph