universe u

structure Ring :=
  (R           : Type u)
  (ring_struct : (R → R → R) × (R → R → R) × R × R)
  (ring_axioms : ( (∀ (x y z : R), ring_struct.1 x (ring_struct.1 y z)
                                 = ring_struct.1 (ring_struct.1 x y) z)
                 ∧ (∀ (x y : R),   ring_struct.1 x y = ring_struct.1 y x)
                 ∧ (∀ (x : R),     ring_struct.1 x ring_struct.2.2.1
                                 = x)
                 ∧ (∀ (x : R),
                    ∃ (x' : R),    ring_struct.1 x x'
                                 = ring_struct.2.2.1))
                 ∧
                (( (∀ (x y z : R), ring_struct.2.1 x (ring_struct.2.1 y z)
                                 = ring_struct.2.1 (ring_struct.2.1 x y) z)
                 ∧ (∀ (x : R),     ring_struct.2.1 x ring_struct.2.2.2
                                 = x)
                 ∧ (∀ (x : R),     ring_struct.2.1 ring_struct.2.2.2 x
                                 = x))
                 ∧
                 ( (∀ (x y z : R), ring_struct.2.1 x (ring_struct.1 y z)
                                 = ring_struct.1 (ring_struct.2.1 x y)
                                                 (ring_struct.2.1 x z))
                 ∧ (∀ (x y z : R), ring_struct.2.1 (ring_struct.1 x y) z
                                 = ring_struct.1 (ring_struct.2.1 x z)
                                                 (ring_struct.2.1 y z)))))

def plus {R : Ring} :=
  R.ring_struct.1
local infixr ` + ` : 80 := plus

def mult {R : Ring} :=
  R.ring_struct.2.1
local infixr ` * ` : 80 := mult

def zero {R : Ring} :=
  R.ring_struct.2.2.1

def one {R : Ring} :=
  R.ring_struct.2.2.2

def group_under_addition {R : Ring} :=
  R.ring_axioms.1

def monoid_under_multiplication {R : Ring} :=
  R.ring_axioms.2.1

def distributivity_laws {R : Ring} :=
  R.ring_axioms.2.2

structure Ideal (R : Ring) :=
  (I : set R.R)
  (ideal_axioms : (   I zero
                   ∧ (∀ (x y : R.R), I x → I y → I (x + y))
                   ∧ (∀ (x x' : R.R), (x + x') = zero
                                     → I x → I x'))
                   ∧
                   ( (∀ (x y : R.R), I x → I (x * y))
                   ∧ (∀ (x y : R.R), I x → I (y * x))))

def subgroup_under_addition {R : Ring} (I : Ideal R) :=
  I.ideal_axioms.1

def multiplication_conditions {R : Ring} (I : Ideal R) :=
  I.ideal_axioms.2

def min_ideal {R : Ring} (IS : set (Ideal R)) : Ideal R :=
  {
   I := {x | ∀ (Id : Ideal R), Id ∈ IS → x ∈ Id.I},
   ideal_axioms :=
     begin
      split,
      split,
      intros Id hId,
      exact Id.ideal_axioms.1.1,
      split,
      intros x y hx hy,
      intros Id hId,
      specialize hx Id hId,
      specialize hy Id hId,
      exact Id.ideal_axioms.1.2.1 x y hx hy,
      intros x x' hxx' hx Id hId,
      specialize hx Id hId,
      exact Id.ideal_axioms.1.2.2 x x' hxx' hx,
      split,
      intros x y hx Id hId,
      specialize hx Id hId,
      exact Id.ideal_axioms.2.1 x y hx,
      intros x y hx Id hId,
      specialize hx Id hId,
      exact Id.ideal_axioms.2.2 x y hx,
     end
  }

def mult_set {R : Ring} (I I' : Ideal R) : set (Ideal R) :=
  {Id | ∀ (x y : R.R), x ∈ I.I → y ∈ I'.I → (x * y) ∈ Id.I}

def Ideal_mult {R : Ring} (I I' : Ideal R) : Ideal R :=
  min_ideal (mult_set I I')
local infixr ` ⨂ ` : 80 := Ideal_mult

lemma assoc_p {R : Ring} : ∀ (x y z : R.R), x + (y + z) = (x + y) + z :=
 begin
  intros x y z,
  exact group_under_addition.1 x y z,
 end

lemma comm_p {R : Ring} : ∀ (x y : R.R), x + y = y + x :=
 begin
  intros x y,
  exact group_under_addition.2.1 x y,
 end

lemma inv_p {R : Ring} : ∀ (x : R.R), ∃ (x' : R.R), x + x' = zero :=
 begin
  intro x,
  exact group_under_addition.2.2.2 x,
 end

lemma newt_p_1 {R : Ring} : ∀ (x : R.R), x = x + zero :=
 begin
  intro x,
  symmetry,
  exact group_under_addition.2.2.1 x,
 end

lemma inv_unique {R : Ring} : ∀ (x y z : R.R), ((x + y = zero) ∧ (x + z = zero)) → y = z :=
 begin
  intros x y z h,
  cases h with hy hz,
  calc
   y     = y + zero : by exact newt_p_1 y
     ... = y + (x + z) : by rw hz
     ... = y + x + z : by rw assoc_p y x z
     ... = (y + x) + z : by rw ← assoc_p y x z
     ... = (x + y) + z : by rw comm_p y x
     ... = zero + z : by rw ← hy
     ... = z + zero : by exact comm_p zero z
     ... = z : by { symmetry, exact newt_p_1 z },
 end

def Ideal_plus {R : Ring} (I I' : Ideal R) : Ideal R :=
  {
   I := {z | ∃ (x y : R.R), x ∈ I.I ∧ y ∈ I'.I ∧ z = x + y},
   ideal_axioms :=
    begin
     split,
     split,
     existsi zero,
     existsi zero,
     split,
     exact I.ideal_axioms.1.1,
     split,
     exact I'.ideal_axioms.1.1,
     symmetry,
     exact group_under_addition.2.2.1 zero,
     split,
     intros x y hx hy,
     cases hx with x' hx,
     cases hx with y' hx,
     cases hy with x'' hy,
     cases hy with y'' hy,
     cases hx with hx' hx,
     cases hx with hy' hx,
     cases hy with hx'' hy,
     cases hy with hy'' hy,
     existsi (x' + x''),
     existsi (y' + y''),
     split,
     exact I.ideal_axioms.1.2.1 x' x'' hx' hx'',
     split,
     exact I'.ideal_axioms.1.2.1 y' y'' hy' hy'',
     rw hx,
     rw hy,
     rw ← assoc_p,
     rw assoc_p y' x'' y'',
     rw comm_p y' x'',
     rw ← assoc_p x'' y' y'',
     rw assoc_p,
     intros x x' hxx' hx,
     cases hx with y hx,
     cases hx with y' hx,
     cases hx with hy hx,
     cases hx with hy' hx,
     have H : ∃ (a : R.R), y + a = zero,
     exact inv_p y,
     cases H with a Ha,
     have H : ∃ (a' : R.R), y' + a' = zero,
     exact inv_p y',
     cases H with a' Ha',
     have H : x + (a + a') = zero,
     rw hx,
     rw ← assoc_p,
     rw comm_p a a',
     rw assoc_p y' a' a,
     rw Ha',
     rw assoc_p,
     rw ← newt_p_1 y,
     exact Ha,
     have H' : x' = (a + a'),
     apply inv_unique x,
     split,
     exact hxx',
     exact H,
     existsi a,
     existsi a',
     split,
     exact (subgroup_under_addition I).2.2 y a Ha hy,
     split,
     exact (subgroup_under_addition I').2.2 y' a' Ha' hy',
     exact H',
     split,
     intros x y hx,
     cases hx with x' hx,
     cases hx with y' hx,
     cases hx with hx' hx,
     cases hx with hy' hx,
     existsi (x' * y),
     existsi (y' * y),
     split,
     exact (multiplication_conditions I).1 x' y hx',
     split,
     exact (multiplication_conditions I').1 y' y hy',
     rw hx,
     exact distributivity_laws.2 x' y' y,
     intros x y hx,
     cases hx with x' hx,
     cases hx with y' hx,
     cases hx with hx' hx,
     cases hx with hy' hx,
     existsi (y * x'),
     existsi (y * y'),
     split,
     exact (multiplication_conditions I).2 x' y hx',
     split,
     exact (multiplication_conditions I').2 y' y hy',
     rw hx,
     exact distributivity_laws.1 y x' y',
    end
  }
local infixr ` ⨁ ` : 80 := Ideal_plus
 -- next, want to define is_semiring property!

structure is_semiring (X : Type u) :=
  (plus : X → X → X)
  (mult : X → X → X)
  (zero' : X)
  (one'  : X)
  (plus_assoc : ∀ (x y z : X), plus x (plus y z) = plus (plus x y) z)
  (plus_comm  : ∀ (x y : X),   plus x y = plus y x)
  (plus_ident : ∀ (x : X),     plus x zero' = x)
  (mult_assoc : ∀ (x y z : X), mult x (mult y z) = mult (mult x y) z)
  (mult_liden : ∀ (x : X),     mult one' x = x)
  (mult_riden : ∀ (x : X),     mult x one' = x)
  (lm_distrib : ∀ (x y z : X), mult x (plus y z) = plus (mult x y) (mult x z))
  (rm_distrib : ∀ (x y z : X), mult (plus x y) z = plus (mult x z) (mult y z))
  (zero_lanni : ∀ (x : X),     mult zero' x = zero')
  (zero_ranni : ∀ (x : X),     mult x zero' = zero')

-- let's gooo!

lemma distribby_l {R : Ring} : ∀ (x y z : R.R), x * (y + z) = (x * y) + (x * z) :=
 begin
  intros x y z,
  exact distributivity_laws.1 x y z,
 end

lemma distribby_r {R : Ring} : ∀ (x y z : R.R), (x + y) * z = (x * z) + (y * z) :=
 begin
  intros x y z,
  exact distributivity_laws.2 x y z,
 end

lemma zero_left_annihilates {R : Ring} : ∀ (x : R.R), (zero * x) = zero :=
 begin
  intro x,
  have t : zero * x = (zero * x) + (zero * x),
  {
   calc
    zero * x     = (zero + zero) * x : by rw ← newt_p_1 zero
             ... = (zero * x) + (zero * x) : by exact distribby_r zero zero x,
  },
  symmetry,
  have t' : ∃ (c : R.R), (zero * x) + c = zero,
  { exact inv_p (zero * x), },
  cases t' with c hc,
  calc
   zero     = (zero * x) + c : by { symmetry, exact hc }
        ... = ((zero * x) + (zero * x)) + c : by rw ← t
        ... = (zero * x) + ((zero * x) + c) : by rw assoc_p (zero * x) (zero * x) c
        ... = (zero * x) + zero             : by rw hc
        ... = (zero * x)                    : by { symmetry, exact newt_p_1 (zero * x) },
 end

lemma zero_right_annihilates {R : Ring} : ∀ (x : R.R), (x * zero) = zero :=
 begin
  intro x,
  have t : x * zero = (x * zero) + (x * zero),
  {
   calc
    x * zero     = x * (zero + zero) : by rw ← newt_p_1 zero
             ... = (x * zero) + (x * zero) : by exact distribby_l x zero zero,
  },
  symmetry,
  have t' : ∃ (c : R.R), (x * zero) + c = zero,
  { exact inv_p (x * zero), },
  cases t' with c hc,
  calc
   zero     = (x * zero) + c : by { symmetry, exact hc }
        ... = ((x * zero) + (x * zero)) + c : by rw ← t
        ... = (x * zero) + ((x * zero) + c) : by rw assoc_p (x * zero) (x * zero) c
        ... = (x * zero) + zero             : by rw hc
        ... = (x * zero)                    : by { symmetry, exact newt_p_1 (x * zero) },
 end

def Ideal_zero (R : Ring) : Ideal R :=
  {
            I := {x | x = zero},
            ideal_axioms :=
             begin
              split,
              split,
              exact rfl,
              split,
              intros x y hx hy,
              have t : x = zero,
              exact hx,
              rw t,
              have t' : y = zero,
              exact hy,
              rw t',
              rw ← newt_p_1 zero,
              exact rfl,
              intros x x' hxx' hx,
              have k : x = zero,
              exact hx,
              rw k at hxx',
              rw comm_p zero x' at hxx',
              rw ← newt_p_1 x' at hxx',
              exact hxx',
              split,
              intros x y hx,
              have H : x = zero,
              exact hx,
              rw H,
              rw zero_left_annihilates y,
              exact rfl,
              intros x y hx,
              have h : x = zero,
              exact hx,
              rw h,
              rw zero_right_annihilates y,
              exact rfl,
             end
           }

lemma s {R : Ring} : ∀ (x : R.R), x ∈ (Ideal_zero R).I → x = zero :=
 begin
  intros x hx,
  exact hx,
 end

lemma ideal_equality_condition {R : Ring} : ∀ (I I' : Ideal R), I.I = I'.I → I = I' :=
 begin
  intros I I' h,
  have t : (I.I zero ∧ (∀ (x y : R.R), I.I x → I.I y → I.I (x + y))
                   ∧ (∀ (x x' : R.R), (x + x') = zero → I.I x → I.I x'))
                   ∧
                   ((∀ (x y : R.R), I.I x → I.I (x * y))
                   ∧ (∀ (x y : R.R), I.I x → I.I (y * x)))
           ↔
           (I'.I zero ∧ (∀ (x y : R.R), x ∈ I'.I → I'.I y → I'.I (x + y))
                   ∧ (∀ (x x' : R.R), (x + x') = zero → I'.I x → I'.I x'))
                   ∧
                   ((∀ (x y : R.R), I'.I x → I'.I (x * y))
                   ∧ (∀ (x y : R.R), I'.I x → I'.I (y * x))),
  split,
  intro H,
  rw ← h,
  exact H,
  intro H,
  rw h,
  exact H,
  have t' : ((I.I zero ∧ (∀ (x y : R.R), I.I x → I.I y → I.I (x + y))
                   ∧ (∀ (x x' : R.R), (x + x') = zero → I.I x → I.I x'))
                   ∧
                   ((∀ (x y : R.R), I.I x → I.I (x * y))
                   ∧ (∀ (x y : R.R), I.I x → I.I (y * x))))
           =
           ((I'.I zero ∧ (∀ (x y : R.R), x ∈ I'.I → I'.I y → I'.I (x + y))
                   ∧ (∀ (x x' : R.R), (x + x') = zero → I'.I x → I'.I x'))
                   ∧
                   ((∀ (x y : R.R), I'.I x → I'.I (x * y))
                   ∧ (∀ (x y : R.R), I'.I x → I'.I (y * x)))),
  apply propext,
  exact t,
  cases I, -- had to search through zulip chat to finish proof of this lemma from here
  cases I', -- all credit to Kenny Lau message in new members 12.11 pm 23rd May
  congr,   -- i think that possibly i've defined ideals in an overcomplicated way, with the axioms
  exact h, -- all as one block, but possibly doing it differently would have meant more congr-ing
 end

def Ideal_one {R : Ring} : Ideal R :=
  {
   I := λ x, true,
   ideal_axioms :=
    begin
     simp,
     intros x x',
     cc,
    end
  }

lemma self_mult_set {R : Ring} (I : Ideal R) : ∀ (I' : Ideal R), I ∈ (mult_set I I') :=
 begin
  intro I',
  intros x y hx hy,
  exact (multiplication_conditions I).1 x y hx,
 end

lemma self_mult_set' {R : Ring} (I : Ideal R) : ∀ (I' : Ideal R), I ∈ (mult_set I' I) :=
 begin
  intro I',
  intros x y hx hy,
  exact (multiplication_conditions I).2 y x hy,
 end

lemma newt_m_r {R : Ring} : ∀ (x : R.R), (x * one) = x :=
 begin
  intro x,
  exact monoid_under_multiplication.2.1 x,
 end

lemma newt_m_l {R : Ring} : ∀ (x : R.R), (one * x) = x :=
 begin
  intro x,
  exact monoid_under_multiplication.2.2 x,
 end

lemma Ideal_has_zero {R : Ring} : ∀ (I : Ideal R), zero ∈ I.I :=
 begin
  intro I,
  exact (subgroup_under_addition I).1,
 end

def sum_num {R : Ring} (f : ℕ → R.R) : ℕ → R.R
 | 0 := f 0
 | (nat.succ n) := (f (nat.succ n)) + (sum_num n)

def sum_sum_num {R : Ring} (nx : ℕ) (fx fy : ℕ → R.R) : ℕ → R.R
 | 0 := fx 0
 | (nat.succ n) := if n < nx then (fx (nat.succ n) + sum_num fx n)
                   else (fy (nat.succ n - nat.succ nx) + sum_sum_num n)

lemma silly : ∀ n : ℕ, ¬ n < n :=
begin
 intro n,
 induction n with n hn,
 intro hz,
 cases hz with r hr,
 intro h,
 apply hn,
 have t : nat.add n 1 < nat.add n 1,
 exact h,
 exact nat.lt_of_succ_lt_succ h,
end

lemma hateful {R : Ring} (fx fy : ℕ → R.R) : ∀ n : ℕ, sum_sum_num n fx fy n = sum_num fx n :=
 begin
  intro n,
  induction n with n hn,
  exact rfl,
  have t : n < nat.succ n,
  exact nat.lt_succ_self n,
  have t' : sum_sum_num (nat.succ n) fx fy (nat.succ n) = ite (n < nat.succ n) (fx (nat.succ n) + sum_num fx n) (fy (nat.succ n - nat.succ (nat.succ n)) + sum_sum_num (nat.succ n) fx fy n),
  exact rfl,
  have t'' : sum_sum_num (nat.succ n) fx fy (nat.succ n) = fx (nat.succ n) + sum_num fx n,
  simp [t, t'],
  rw t'',
  exact rfl,
 end

lemma add_succ_commute : ∀ (m n : ℕ), nat.add m (nat.succ n) = nat.succ (nat.add m n) :=
begin
 intros m n,
 exact rfl,
end

lemma add_succ_commute' : ∀ (m n : ℕ), nat.add (nat.succ m) n = nat.succ (nat.add m n) :=
begin
 intros m n,
 exact nat.succ_add m n,
end

lemma nexting : ∀ (m n : ℕ), m < nat.succ (nat.add m n) :=
begin
 intros m n,
 apply nat.lt_succ_of_le,
 induction n with n hn,
 have t : nat.add m 0 = m,
 exact nat.add_zero m,
 apply nat.le_of_eq,
 rw t,
 rw add_succ_commute m n,
 apply nat.le_of_lt,
 apply nat.lt_succ_of_le,
 exact hn,
end

lemma nexting' : ∀ (m n : ℕ), ¬ nat.succ (nat.add m n) < m :=
begin
 intros m n h,
 have h' := nexting m n,
 have h'' := silly m,
 apply h'',
 exact nat.lt_trans h' h,
end

lemma snarl : ∀ (m n : ℕ), nat.succ (nat.add m n) - m = nat.succ n :=
begin
 intros m n,
 induction n with n hn,
 have t : nat.add m 0 = m,
 exact nat.add_zero m,
 rw t,
 have t' : 1 = nat.succ (m - m),
 rw nat.sub_self m,
 rw nat.succ_sub,
 symmetry,
 exact t',
 apply le_of_eq,
 exact rfl,
 rw add_succ_commute m n,
 rw ← hn,
 apply nat.succ_sub,
 apply nat.le_of_lt,
 exact nexting m n,
end

lemma sum_sum_num_is_sum {R : Ring} (nx ny : ℕ) (fx fy : ℕ → R.R) :
  (sum_sum_num nx fx fy) (nat.succ (nat.add nx ny)) = (sum_num fx nx) + (sum_num fy ny) :=
  begin
   induction ny with ny indhy,
   have t : nat.add nx 0 = nx,
   { exact nat.add_zero nx, },
   rw t,
   have t' : sum_sum_num nx fx fy (nat.succ nx) = ite (nx < nx) (fx (nat.succ nx) + sum_num fx nx) (fy (nat.succ nx - nat.succ nx) + sum_sum_num nx fx fy nx),
   exact rfl,
   have t'' : ¬ nx < nx,
   exact silly nx,
   have t''' : sum_sum_num nx fx fy (nat.succ nx) = fy (nat.succ nx - nat.succ nx) + sum_sum_num nx fx fy nx,
   simp [t', t''],
   rw t''',
   have t'''' : nat.succ nx - nat.succ nx = 0,
   simp,
   exact nat.sub_self nx,
   rw t'''',
   rw comm_p,
   rw hateful fx fy nx,
   exact rfl,
   rw add_succ_commute nx ny,
   have t := nexting' nx ny,
   have t' : sum_sum_num nx fx fy (nat.succ (nat.succ (nat.add nx ny))) = ite (nat.succ (nat.add nx ny) < nx) (fx (nat.succ (nat.succ (nat.add nx ny))) + sum_num fx (nat.succ (nat.add nx ny))) (fy (nat.succ (nat.succ (nat.add nx ny)) - nat.succ nx) + sum_sum_num nx fx fy (nat.succ (nat.add nx ny))),
   exact rfl,
   simp [t, t'],
   rw indhy,
   rw snarl nx ny,
   rw comm_p (sum_num fx nx) (sum_num fy ny),
   rw comm_p (sum_num fx nx) (sum_num fy (nat.succ ny)),
   rw assoc_p,
   exact rfl,
  end

def sum_fun {R : Ring} (nx : ℕ) (fx fy : ℕ → R.R) : ℕ → R.R
 | 0 := fx 0
 | (nat.succ n) := if n < nx then fx (nat.succ n)
                   else fy (nat.succ n - nat.succ nx)

lemma simple_decidability : ∀ m n : ℕ, n < m ∨ ¬ (n < m) :=
begin
 intros m n,
 have t : n ≤ m ∨ m ≤ n,
 exact nat.le_total,
 cases t,
 have t' : n = m ∨ n < m,
 exact nat.eq_or_lt_of_le t,
 cases t',
 right,
 rw t',
 exact nat.lt_irrefl m,
 left,
 exact t',
 right,
 have t' : m = n ∨ m < n,
 exact nat.eq_or_lt_of_le t,
 cases t',
 rw t',
 exact nat.lt_irrefl n,
 intro h,
 apply nat.lt_irrefl m,
 exact nat.lt_trans t' h,
end

lemma sum_fxes {R : Ring} (nx : ℕ) (fx fy : ℕ → R.R) :
∀ n : ℕ, (n < nx) → sum_sum_num nx fx fy n = sum_num fx n :=
begin
 intros n hn,
 induction n with n indh,
 exact rfl,
 have t : n < nx,
 apply nat.lt_of_succ_lt,
 exact hn,
 specialize indh t,
 have t' : sum_sum_num nx fx fy (nat.succ n) = ite (n < nx) (fx (nat.succ n) + sum_num fx n) (fy (nat.succ n - nat.succ nx) + sum_sum_num nx fx fy n),
 exact rfl,
 have t'' : sum_sum_num nx fx fy (nat.succ n) = fx (nat.succ n) + sum_num fx n,
 simp [t, t'],
 rw t'',
 exact rfl,
end

lemma sum_proof {R : Ring} (nx : ℕ) (fx fy : ℕ → R.R) :
∀ (n : ℕ), (sum_num (sum_fun nx fx fy) n = sum_sum_num nx fx fy n) :=
begin
 intro n,
 induction n with n indh,
 exact rfl,
 have hn : (n < nx) ∨ ¬ (n < nx),
 exact simple_decidability nx n,
 cases hn,
 have t : sum_num (sum_fun nx fx fy) (nat.succ n) = (sum_fun nx fx fy (nat.succ n)) + (sum_num (sum_fun nx fx fy) n),
 exact rfl,
 rw t,
 have t' : sum_fun nx fx fy (nat.succ n) = ite (n < nx) (fx (nat.succ n)) (fy (nat.succ n - nat.succ nx)),
 exact rfl,
 have t'' : sum_fun nx fx fy (nat.succ n) = fx (nat.succ n),
 simp [t', hn],
 rw t'',
 rw indh,
 rw sum_fxes nx fx fy n,
 have h : sum_sum_num nx fx fy (nat.succ n) = ite (n < nx) (fx (nat.succ n) + sum_num fx n) (fy (nat.succ n - nat.succ nx) + (sum_sum_num nx fx fy n)),
 exact rfl,
 have h' : sum_sum_num nx fx fy (nat.succ n) = fx (nat.succ n) + sum_num fx n,
 simp [hn, h],
 rw h',
 exact hn,
 have t : sum_num (sum_fun nx fx fy) (nat.succ n) = (sum_fun nx fx fy (nat.succ n)) + sum_num (sum_fun nx fx fy) n,
 exact rfl,
 rw t,
 have h : sum_sum_num nx fx fy (nat.succ n) = ite (n < nx) (fx (nat.succ n) + sum_num fx n) (fy (nat.succ n - nat.succ nx) + sum_sum_num nx fx fy n),
 exact rfl,
 have h' : sum_sum_num nx fx fy (nat.succ n) = fy (nat.succ n - nat.succ nx) + sum_sum_num nx fx fy n,
 simp [hn, h],
 rw h',
 have t' : sum_fun nx fx fy (nat.succ n) = ite (n < nx) (fx (nat.succ n)) (fy (nat.succ n - nat.succ nx)),
 exact rfl,
 have t'' : sum_fun nx fx fy (nat.succ n) = fy (nat.succ n - nat.succ nx),
 simp [hn, t'],
 rw t'',
 rw indh,
end

lemma assoc_m {R : Ring} : ∀ x y z : R.R, x * y * z = (x * y) * z :=
begin
 intros x y z,
 exact monoid_under_multiplication.1 x y z,
end

lemma negative_one {R : Ring} : ∀ x y : R.R, one + x = zero → (y + (x * y) = zero) :=
begin
 intros x y hx,
 have t : y = one * y,
 symmetry,
 exact newt_m_l y,
 rw t,
 rw assoc_m,
 rw newt_m_r x,
 rw ← distribby_r,
 rw hx,
 rw zero_left_annihilates y,
end

def mul_fun {R : Ring} (m : R.R) (f : ℕ → R.R) : ℕ → R.R :=
 λ n, (m * (f n))

def mul_fun' {R : Ring} (m : R.R) (f : ℕ → R.R) : ℕ → R.R :=
 λ n, ((f n) * m)

lemma mul_proof {R : Ring} (y : R.R) (f : ℕ → R.R) :
 ∀ n : ℕ, y * (sum_num f n) = sum_num (mul_fun y f) n :=
 begin
  intro n,
  induction n with n hn,
  exact rfl,
  have t : sum_num (mul_fun y f) (nat.succ n) = mul_fun y f (nat.succ n) + (sum_num (mul_fun y f) n),
  exact rfl,
  rw t,
  rw ← hn,
  have t' : mul_fun y f (nat.succ n) = y * f (nat.succ n),
  exact rfl,
  rw t',
  rw ← distribby_l y (f (nat.succ n)) (sum_num f n),
  exact rfl,
 end

lemma mul_proof' {R : Ring} (y : R.R) (f : ℕ → R.R) :
 ∀ n : ℕ, (sum_num f n) * y = sum_num (mul_fun' y f) n :=
 begin
  intro n,
  induction n with n hn,
  exact rfl,
  have t : sum_num (mul_fun' y f) (nat.succ n) = mul_fun' y f (nat.succ n) + (sum_num (mul_fun' y f) n),
  exact rfl,
  rw t,
  rw ← hn,
  have t' : mul_fun' y f (nat.succ n) = (f (nat.succ n)) * y,
  exact rfl,
  rw t',
  rw ← distribby_r,
  exact rfl,
 end

def set_num {R : Ring} (X : set R.R) (H : ∃ x : R.R, x ∈ X) : Ideal R :=
 {
  I := {p | ∃ n : ℕ, ∃ f : ℕ → R.R, (p = (sum_num f n) ∧
                                      (∀ n : ℕ, ∃ x ∈ X, ∃ y z : R.R,
                                       f n = y * x * z))},
  ideal_axioms :=
   begin
    split,
    split,
    existsi 0,
    cases H with x H,
    existsi λ n, zero * x,
    split,
    rw zero_left_annihilates,
    refl,
    intro n,
    existsi x,
    existsi H,
    existsi zero,
    existsi zero,
    rw zero_right_annihilates x,
    rw zero_left_annihilates,
    rw zero_left_annihilates zero,
    split,
    intros x y,
    intros hx hy,
    cases hx with nx hx,
    cases hx with fx hx,
    cases hx with eqx hx,
    cases hy with ny hy,
    cases hy with fy hy,
    cases hy with eqy hy,
    existsi nat.succ (nat.add nx ny),
    existsi sum_fun nx fx fy,
    split,
    rw eqx,
    rw eqy,
    symmetry,
    rw sum_proof nx fx fy (nat.succ (nat.add nx ny)),
    exact sum_sum_num_is_sum nx ny fx fy,
    intro n,
    induction n with n indh,
    specialize hx 0,
    cases hx with x hx,
    cases hx with H hx,
    cases hx with y hx,
    existsi x,
    existsi H,
    existsi y,
    exact hx,
    have dec := simple_decidability nx n,
    have t : sum_fun nx fx fy (nat.succ n) = ite (n < nx) (fx (nat.succ n)) (fy (nat.succ n - nat.succ nx)),
    exact rfl,
    cases dec,
    have t' : sum_fun nx fx fy (nat.succ n) = fx (nat.succ n),
    simp [t, dec],
    rw t',
    specialize hx (nat.succ n),
    exact hx,
    have t' : sum_fun nx fx fy (nat.succ n) = fy (nat.succ n - nat.succ nx),
    simp [t, dec],
    rw t',
    specialize hy (nat.succ n - nat.succ nx),
    exact hy,
    intros x x' hxx' hx,
    cases hx with nx hx,
    cases hx with fx hx,
    cases hx with eqx hx,
    existsi nx,
    have none : ∃ o : R.R, one + o = zero,
    exact inv_p one,
    cases none with o none,
    existsi mul_fun o fx,
    split,
    rw ← mul_proof o fx nx,
    apply inv_unique x,
    split,
    exact hxx',
    rw eqx,
    apply negative_one,
    exact none,
    intro n,
    specialize hx n,
    have t : mul_fun o fx n = o * (fx n),
    exact rfl,
    rw t,
    cases hx with x'' hx,
    cases hx with H hx,
    cases hx with y hx,
    cases hx with z hx,
    existsi x'',
    existsi H,
    existsi o * y,
    existsi z,
    rw ← assoc_m,
    rw ← hx,
    split,
    intros x y hx,
    cases hx with nx hx,
    cases hx with fx hx,
    cases hx with eqx hx,
    existsi nx,
    existsi mul_fun' y fx,
    split,
    rw eqx,
    exact mul_proof' y fx nx,
    intro n,
    specialize hx n,
    have t : mul_fun' y fx n = (fx n) * y,
    exact rfl,
    rw t,
    cases hx with x' hx,
    cases hx with H hx,
    cases hx with y' hx,
    cases hx with z hx,
    existsi x',
    existsi H,
    existsi y',
    existsi z * y,
    rw assoc_m x' z y,
    rw assoc_m y' (x' * z) y,
    rw hx,
    intros x y hx,
    cases hx with nx hx,
    cases hx with fx hx,
    cases hx with eqx hx,
    existsi nx,
    existsi mul_fun y fx,
    split,
    rw eqx,
    exact mul_proof y fx nx,
    intro n,
    specialize hx n,
    cases hx with x' hx,
    cases hx with H' hx,
    cases hx with y' hx,
    cases hx with z hx,
    existsi x',
    existsi H',
    have t : mul_fun y fx n = y * (fx n),
    exact rfl,
    rw t,
    existsi y * y',
    existsi z,
    rw ← assoc_m y y' (x' * z),
    rw hx,
   end,
 }

lemma set_num_inclusion {R : Ring} (X : set R.R) (H : (∃ (x' : R.R), x' ∈ X)) :
 ∀ x : R.R, x ∈ X → x ∈ (set_num X H).I :=
begin
 intros x hx,
 existsi 0,
 existsi λ n, x,
 split,
 exact rfl,
 intro n,
 existsi x,
 existsi hx,
 existsi one,
 existsi one,
 have t : (λ (n : ℕ), x) n = x,
 exact rfl,
 rw t,
 rw newt_m_r,
 rw newt_m_l,
end

def set_mult {R : Ring} (I I' : Ideal R) : set R.R :=
 {z | ∃ x ∈ I.I, ∃ y ∈ I'.I, z = x * y}

lemma nonempty_set_mult {R : Ring} (I I' : Ideal R) : ∃ x : R.R, x ∈ set_mult I I' :=
begin
 existsi zero,
 existsi zero,
 existsi (subgroup_under_addition I).1,
 existsi zero,
 existsi (subgroup_under_addition I').1,
 rw zero_left_annihilates,
end

lemma set_mult_mult_set {R : Ring} (I I' : Ideal R) :
 (set_num (set_mult I I') (nonempty_set_mult I I')) ∈ mult_set I I' :=
 begin
  intros x y hx hy,
  apply set_num_inclusion (set_mult I I') (nonempty_set_mult I I') (x * y),
  existsi x,
  existsi hx,
  existsi y,
  existsi hy,
  exact rfl,
 end

lemma fin_sum_member_condition {R : Ring} (I : Ideal R) (f : ℕ → R.R) (m : ℕ) :
(∀ n : ℕ, (f n) ∈ I.I) → (sum_num f m) ∈ I.I :=
begin
 intro hn,
 induction m with m indh,
 specialize hn 0,
 exact hn,
 have t : sum_num f (nat.succ m) = f (nat.succ m) + sum_num f m,
 exact rfl,
 rw t,
 apply (subgroup_under_addition I).2.1,
 exact hn (nat.succ m),
 exact indh,
end

theorem ideal_semirings {R : Ring} : is_semiring (Ideal R) :=
  {
   plus := Ideal_plus,
   mult := Ideal_mult,
   zero' := Ideal_zero R,
   one'  := Ideal_one,
   plus_assoc :=
   begin
    intros x y w,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hz,
    cases hz with x' hz,
    cases hz with y' hz,
    cases hz with hx' hz,
    cases hz with hy' hz,
    cases hy' with x'' hy',
    cases hy' with y'' hy',
    cases hy' with hx'' hy',
    cases hy' with hy'' hy',
    rw hy' at hz,
    existsi (x' + x''),
    existsi y'',
    split,
    existsi x',
    existsi x'',
    split,
    exact hx',
    split,
    exact hx'',
    exact rfl,
    simp [hy'', hz],
    exact assoc_p x' x'' y'',
    intro hz,
    cases hz with x' hz,
    cases hz with y' hz,
    cases hz with hx' hz,
    cases hz with hy' hz,
    cases hx' with x'' hx',
    cases hx' with y'' hx',
    cases hx' with hx'' hx',
    cases hx' with hy'' hx',
    rw hx' at hz,
    rw ← assoc_p at hz,
    existsi x'',
    existsi (y'' + y'),
    split,
    exact hx'',
    split,
    existsi y'',
    existsi y',
    simp [hy'', hy'],
    exact hz,
   end,
   plus_comm  :=
   begin
    intros x y,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hz,
    cases hz with x' hz,
    cases hz with y' hz,
    cases hz with hx' hz,
    cases hz with hy' hz,
    existsi y',
    existsi x',
    split,
    exact hy',
    split,
    exact hx',
    rw comm_p y' x',
    assumption,
    intro hz,
    cases hz with y' hz,
    cases hz with x' hz,
    cases hz with hy' hz,
    cases hz with hx' hz,
    existsi x',
    existsi y',
    split,
    exact hx',
    split,
    exact hy',
    rw comm_p x' y',
    exact hz,
   end,
   plus_ident :=
   begin
    intro x,
    have t : (x ⨁ Ideal_zero R).I = {z : R.R | ∃ (x' y' : R.R), x' ∈ x.I ∧ y' ∈ (Ideal_zero R).I
                                                             ∧ z = (x' + y')},
    exact rfl,
    have t' : {z : R.R | ∃ (x' y' : R.R), x' ∈ x.I ∧ y' ∈ (Ideal_zero R).I ∧ z = (x' + y')} = x.I,
    apply funext,
    intro r,
    apply propext,
    split,
    intro H,
    cases H with x' H,
    cases H with y' H,
    cases H with Hx' H,
    cases H with Hy' H,
    have t'' : y' = zero,
    apply s,
    exact Hy',
    rw t'' at H,
    rw ← newt_p_1 x' at H,
    rw H,
    exact Hx',
    intro Hr,
    existsi r,
    existsi zero,
    split,
    exact Hr,
    split,
    exact rfl,
    rw ← newt_p_1 r,
    have t'' : (x ⨁ Ideal_zero R).I = x.I,
    rw t,
    exact t',
    apply ideal_equality_condition,
    exact t'',
   end,
   mult_assoc :=
   begin
    intros w y z,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hx,
    specialize hx (set_num (set_mult w (y ⨂ z)) (nonempty_set_mult w (y ⨂ z)))
                  (set_mult_mult_set w (y ⨂ z)),
    have hx' := hx,
    cases hx with nx hx,
    cases hx with fx hx,
    cases hx with eqx hx,
    rw eqx,
    apply fin_sum_member_condition ((w ⨂ y) ⨂ z) fx nx,
    intro n,
    specialize hx n,
    intro I,
    intro hI,
    cases hx with x' hx,
    cases hx with H hx,
    cases H with y' H,
    cases H with hy' H,
    cases H with y'' H,
    cases H with hy'' H,
    specialize hy'' (set_num (set_mult y z) (nonempty_set_mult y z))
                    (set_mult_mult_set y z),
    cases hx with p hx,
    cases hx with q hx,
    rw hx,
    apply (multiplication_conditions I).2,
    apply (multiplication_conditions I).1,
    cases hy'' with ny'' hy'',
    cases hy'' with fy'' hy'',
    cases hy'' with eqy'' hy'',
    rw eqy'' at H,
    rw mul_proof y' fy'' ny'' at H,
    rw H,
    apply fin_sum_member_condition I (mul_fun y' fy'') ny'',
    intro nrxr,
    specialize hy'' nrxr,
    cases hy'' with xy'' hy'',
    cases hy'' with Hy'' hy'',
    cases hy'' with yy'' hy'',
    cases hy'' with zy'' hy'',
    have t : mul_fun y' fy'' nrxr = y' * (fy'' nrxr),
    exact rfl,
    rw t,
    rw hy'',
    cases Hy'' with y₀ Hy'',
    cases Hy'' with Hy₀ Hy'',
    cases Hy'' with y₁ Hy'',
    cases Hy'' with Hy₁ Hy'',
    rw Hy'',
    rw ← assoc_m,
    rw assoc_m y' yy'' (y₀ * y₁ * zy''),
    rw assoc_m (y' * yy'') y₀ (y₁ * zy''),
    specialize hI ((y' * yy'') * y₀) (y₁ * zy''),
    have t' : (y' * yy'') * y₀ ∈ (w ⨂ y).I,
    intros I' hI',
    specialize hI' (y' * yy'') y₀,
    apply hI',
    apply (multiplication_conditions w).1,
    exact hy',
    exact Hy₀,
    specialize hI t',
    apply hI,
    apply (multiplication_conditions z).1,
    exact Hy₁, -- end of part one
    intro hx,
    specialize hx (set_num (set_mult (w ⨂ y) z) (nonempty_set_mult (w ⨂ y) z))
                  (set_mult_mult_set (w ⨂ y) z),
    cases hx with nx hx,
    cases hx with fx hx,
    cases hx with eqx hx,
    rw eqx,
    apply fin_sum_member_condition (w ⨂ y ⨂ z) fx nx,
    intro n,
    specialize hx n,
    intros I hI,
    cases hx with x' hx,
    cases hx with H hx,
    cases H with y' H,
    cases H with hy' H,
    cases H with y'' H,
    cases H with hy'' H,
    specialize hy' (set_num (set_mult w y) (nonempty_set_mult w y))
                   (set_mult_mult_set w y),
    cases hx with p hx,
    cases hx with q hx,
    rw hx,
    apply (multiplication_conditions I).2,
    apply (multiplication_conditions I).1,
    cases hy' with ny' hy',
    cases hy' with fy' hy',
    cases hy' with eqy' hy',
    rw eqy' at H,
    rw mul_proof' y'' fy' ny' at H,
    rw H,
    apply fin_sum_member_condition I (mul_fun' y'' fy') ny',
    intro nrxr,
    specialize hy' nrxr,
    cases hy' with xy' hy',
    cases hy' with Hy' hy',
    cases hy' with yy' hy',
    cases hy' with zy' hy',
    have t : mul_fun' y'' fy' nrxr = (fy' nrxr) * y'',
    exact rfl,
    rw t,
    rw hy',
    cases Hy' with y₀ Hy',
    cases Hy' with Hy₀ Hy',
    cases Hy' with y₁ Hy',
    cases Hy' with Hy₁ Hy',
    rw Hy',
    rw ← assoc_m y₀ y₁ zy',
    rw assoc_m yy' y₀ (y₁ * zy'),
    rw ← assoc_m,
    specialize hI (yy' * y₀) ((y₁ * zy') * y''),
    apply hI,
    apply (multiplication_conditions w).2,
    exact Hy₀,
    intros I' hI',
    specialize hI' (y₁ * zy') y'',
    apply hI',
    apply (multiplication_conditions y).1,
    exact Hy₁,
    exact hy'',
   end,
   mult_liden :=
   begin
    intro x,
    apply ideal_equality_condition,
    apply funext,
    intro x',
    apply propext,
    split,
    intro H,
    specialize H x,
    apply H,
    exact self_mult_set' x Ideal_one,
    intros H I',
    intro HI',
    specialize HI' one x',
    rw ← newt_m_l x',
    apply HI',
    have t : true,
    cc,
    exact t,
    exact H,
   end,
   mult_riden :=
   begin
    intro I,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hx,
    exact hx I (self_mult_set I Ideal_one),
    intros hx I' hI',
    specialize hI' x one,
    rw ← newt_m_r x,
    apply hI',
    exact hx,
    have t : true,
    cc,
    exact t,
   end,
   lm_distrib :=
   begin
    intros w y z,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hx,
    specialize hx ((w ⨂ y) ⨁ (w ⨂ z)),
    apply hx,
    intros x' y' hx' hy',
    cases hy' with x'' hy',
    cases hy' with y'' hy',
    cases hy' with hx'' hy',
    cases hy' with hy'' hy',
    rw hy',
    rw distribby_l x' x'' y'',
    existsi x' * x'',
    existsi x' * y'',
    split,
    intros I' hI',
    specialize hI' x' x'',
    apply hI',
    exact hx',
    apply hx'',
    split,
    intros I' hI',
    specialize hI' x' y'',
    apply hI',
    exact hx',
    exact hy'',
    exact rfl,
    intro H,
    cases H with x' H,
    cases H with y' H,
    cases H with Hx' H,
    cases H with Hy' H,
    specialize Hx' (w ⨂ y ⨁ z),
    specialize Hy' (w ⨂ y ⨁ z),
    rw H,
    apply (subgroup_under_addition (w ⨂ y ⨁ z)).2.1 x' y',
    apply Hx',
    intros x'' y'' hx'' hy'',
    intros I' hI',
    specialize hI' x'' y'' hx'',
    apply hI',
    existsi y'',
    existsi zero,
    split,
    exact hy'',
    split,
    exact Ideal_has_zero z,
    exact newt_p_1 y'',
    apply Hy',
    intros x'' y'' hx'' hy'' I' hI',
    specialize hI' x'' y'' hx'',
    apply hI',
    existsi zero,
    existsi y'',
    split,
    exact Ideal_has_zero y,
    split,
    exact hy'',
    rw comm_p zero y'',
    exact newt_p_1 y'',
   end,
   rm_distrib :=
   begin
    intros w y z,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hx,
    specialize hx ((w ⨂ z) ⨁ (y ⨂ z)),
    apply hx,
    intros x' y' hx' hy',
    cases hx' with wx' hx',
    cases hx' with yx' hx',
    cases hx' with hwx' hx',
    cases hx' with hyx' hx',
    rw hx',
    rw distribby_r wx' yx' y',
    existsi wx' * y',
    existsi yx' * y',
    split,
    intros I hI,
    exact hI wx' y' hwx' hy',
    split,
    intros I hI,
    exact hI yx' y' hyx' hy',
    exact rfl,
    intro hx,
    cases hx with x' hx,
    cases hx with y' hx,
    cases hx with hx' hx,
    cases hx with hy' hx,
    specialize hx' ((w ⨁ y) ⨂ z),
    specialize hy' ((w ⨁ y) ⨂ z),
    rw hx,
    apply (subgroup_under_addition ((w ⨁ y) ⨂ z)).2.1 x' y',
    apply hx',
    intros x'' y'' hx'' hy'',
    intros I hI,
    specialize hI x'' y'',
    apply hI,
    existsi x'',
    existsi zero,
    split,
    exact hx'',
    split,
    exact Ideal_has_zero y,
    exact newt_p_1 x'',
    exact hy'',
    apply hy',
    intros x'' y'' hx'' hy'' I hI,
    specialize hI x'' y'',
    apply hI,
    existsi zero,
    existsi x'',
    split,
    exact Ideal_has_zero w,
    split,
    exact hx'',
    rw comm_p,
    exact newt_p_1 x'',
    exact hy'',
   end,
   zero_lanni :=
   begin
    intro I,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hx,
    exact hx (Ideal_zero R) (self_mult_set (Ideal_zero R) I),
    intro hx,
    have t : x = zero,
    exact hx,
    rw t,
    exact Ideal_has_zero (Ideal_zero R ⨂ I),
   end,
   zero_ranni :=
   begin
    intro I,
    apply ideal_equality_condition,
    funext,
    apply propext,
    split,
    intro hx,
    exact hx (Ideal_zero R) (self_mult_set' (Ideal_zero R) I),
    intro hx,
    have t : x = zero,
    exact hx,
    rw t,
    exact Ideal_has_zero (I ⨂ Ideal_zero R),
   end
  }

lemma idempotent_ideals {R : Ring} (I : Ideal R) : I ⨁ I = I :=
begin
 apply ideal_equality_condition,
 funext,
 apply propext,
 split,
 intro hz,
 cases hz with zx hz,
 cases hz with zy hz,
 cases hz with hzx hz,
 cases hz with hzy hz,
 rw hz,
 exact (subgroup_under_addition I).2.1 zx zy hzx hzy,
 intro hz,
 existsi z,
 existsi zero,
 split,
 exact hz,
 split,
 exact Ideal_has_zero I,
 rw ← newt_p_1 z,
end


namespace hidden
inductive bool : Type
| ff : bool
| tt : bool

open hidden.bool

def band (b1 b2 : bool) : bool :=
bool.cases_on b1 ff b2

def bnot (b1 : bool) : bool :=
bool.cases_on b1 tt ff

def bor (b1 b2 : bool) : bool :=
bool.cases_on b1 b2 tt

theorem band_comm (b1 b2 : bool) : band b1 b2 = band b2 b1 :=
begin
    cases b1; cases b2; apply rfl
end

theorem bor_comm (b1 b2 : bool) : bor b1 b2 = bor b2 b1 :=
begin
    cases b1; cases b2; apply rfl
end

theorem band_assoc (a b c : bool) : band (band a b) c = band a (band b c) :=
begin
    cases a; cases b; cases c; apply rfl
end

theorem de_morgan (a b : bool) : bnot (band a b) = bor (bnot a) (bnot b) :=
begin
    cases a; cases b; apply rfl
end

end hidden


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

import algebra.order.ring.defs

/-!
# Lemmas for `linarith`

This file contains auxiliary lemmas that `linarith` uses to construct proofs.
If you find yourself looking for a theorem here, you might be in the wrong place.
-/

namespace linarith

lemma zero_lt_one {α} [ordered_semiring α] [nontrivial α] : (0 : α) < 1 := zero_lt_one

lemma eq_of_eq_of_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b = 0) : a + b = 0 :=
by simp *

lemma le_of_eq_of_le {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b ≤ 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_eq_of_lt {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b < 0) : a + b < 0 :=
by simp *

lemma le_of_le_of_eq {α} [ordered_semiring α] {a b : α} (ha : a ≤ 0) (hb : b = 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_lt_of_eq {α} [ordered_semiring α] {a b : α} (ha : a < 0) (hb : b = 0) : a + b < 0 :=
by simp *

lemma mul_neg {α} [strict_ordered_ring α] {a b : α} (ha : a < 0) (hb : 0 < b) : b * a < 0 :=
have (-b)*a > 0, from mul_pos_of_neg_of_neg (neg_neg_of_pos hb) ha,
neg_of_neg_pos (by simpa)

lemma mul_nonpos {α} [ordered_ring α] {a b : α} (ha : a ≤ 0) (hb : 0 < b) : b * a ≤ 0 :=
have (-b)*a ≥ 0, from mul_nonneg_of_nonpos_of_nonpos (le_of_lt (neg_neg_of_pos hb)) ha,
by simpa

-- used alongside `mul_neg` and `mul_nonpos`, so has the same argument pattern for uniformity
@[nolint unused_arguments]
lemma mul_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : 0 < b) : b * a = 0 :=
by simp *

lemma eq_of_not_lt_of_not_gt {α} [linear_order α] (a b : α) (h1 : ¬ a < b) (h2 : ¬ b < a) : a = b :=
le_antisymm (le_of_not_gt h2) (le_of_not_gt h1)

-- used in the `nlinarith` normalization steps. The `_` argument is for uniformity.
@[nolint unused_arguments]
lemma mul_zero_eq {α} {R : α → α → Prop} [semiring α] {a b : α} (_ : R a 0) (h : b = 0) :
  a * b = 0 :=
by simp [h]

-- used in the `nlinarith` normalization steps. The `_` argument is for uniformity.
@[nolint unused_arguments]
lemma zero_mul_eq {α} {R : α → α → Prop} [semiring α] {a b : α} (h : a = 0) (_ : R b 0) :
  a * b = 0 :=
by simp [h]

end linarith


--universe u

--instance complete_graph_adj_decidable (V : Type u) [decidable_eq V] :
--#exit
/-
Copyright (c) 2020 Aaron Anderson, Jalex Stark, Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Aaron Anderson, Jalex Stark, Kyle Miller.
-/
import data.fintype.basic
import sym2
import tactic

open finset
-- noncomputable theory

/-!
# Simple graphs
This module defines simple graphs on a vertex type `V` as an
irreflexive symmetric relation.
There is a basic API for locally finite graphs and for graphs with
finitely many vertices.
## Main definitions
* `simple_graph` is a structure for symmetric, irreflexive relations
* `neighbor_set` is the `set` of vertices adjacent to a given vertex
* `neighbor_finset` is the `finset` of vertices adjacent to a given vertex,
   if `neighbor_set` is finite
## Implementation notes
* A locally finite graph is one with instances `∀ v, fintype (G.neighbor_set v)`.
* Given instances `decidable_rel G.adj` and `fintype V`, then the graph
is locally finite, too.
TODO: This is the simplest notion of an unoriented graph.  This should
eventually fit into a more complete combinatorics hierarchy which
includes multigraphs and directed graphs.  We begin with simple graphs
in order to start learning what the combinatorics hierarchy should
look like.
TODO: Part of this would include defining, for example, subgraphs of a
simple graph.
-/

universe u
variables (V : Type u)
/--
A simple graph is an irreflexive symmetric relation `adj` on a vertex type `V`.
The relation describes which pairs of vertices are adjacent.
There is exactly one edge for every pair of adjacent edges;
see `simple_graph.E` for the corresponding type of edges.
Note: The type of the relation is given as `V → set V` rather than
`V → V → Prop` so that, given vertices `v` and `w`, then `w ∈ G.adj v`
works as another way to write `G.adj v w`.  Otherwise Lean cannot find
a `has_mem` instance.
-/
@[ext] structure simple_graph :=
(adj : V → V → Prop)
(sym : symmetric adj . obviously)
(loopless : irreflexive adj . obviously)
--(unique_edges : edge set not multiset?)
namespace simple_graph

-- notation for adj
-- class has_splodge (α : Sort*) := { bigcirc : α → α → Prop }
-- instance (α : Type u) [simple_graph α] : has_splodge α :=
-- { bigcirc := @simple_graph.adj α _inst_1 }

-- why can't I use exotic unicode in infix notation?
-- binding power and associativity sent to default values
--infix `◯`:37 := has_splodge.bigcirc
notation v ` ◯⦃`:37 G `⦄ `:37 w := G.adj v w

def adj_ne {X : Type u} (G : simple_graph X) (v w : X)
  (h : v ◯⦃G⦄ w) : v ≠ w :=
begin
  rintro rfl,
  apply G.loopless v h,
end

/--
The complete graph on a type `V` is the simple graph with all pairs of distinct vertices adjacent.
-/
variables {V} (G : simple_graph V)

def complete_graph : simple_graph V :=
{ adj := ne }

def empty : simple_graph V :=
{ adj := λ _ _, false}

-- @[simp] lemma empty_adj (v u : V) : (@empty V).adj v u ↔ false := by tidy

instance : inhabited (simple_graph V) := ⟨@complete_graph V⟩

instance complete_graph_adj_decidable (V : Type u) [decidable_eq V] :
  decidable_rel (@complete_graph V).adj :=
by { dsimp [complete_graph], apply_instance }

-- variables {V} (G : simple_graph V)

/-- `G.neighbor_set v` is the set of vertices adjacent to `v` in `G`. -/
def neighbor_set (v : V) : set V := set_of (G.adj v)

lemma ne_of_edge {a b : V} (hab : G.adj a b) : a ≠ b :=
by { rintro rfl, exact G.loopless a hab }

/--
The edges of G consist of the unordered pairs of vertices related by
`G.adj`.  It is given as a subtype of the symmetric square.
-/
def E : Type u := {x : sym2 V // x ∈ sym2.from_rel G.sym}

@[ext] theorem E.ext {a b : E G} : a.1 = b.1 → a = b :=
by { cases a, cases b, simp }

@[ext] theorem E.ext_iff (a b : E G) : a = b ↔ a.1 = b.1 :=
⟨λ h, by cases h; refl, E.ext G⟩

/-- Allows us to refer to a vertex being a member of an edge. -/
instance has_mem : has_mem V G.E := { mem := λ v e, v ∈ e.val }

/-- Construct an edge from its endpoints. -/
def edge_of_adj {v w : V} (h : G.adj v w) : G.E := ⟨⟦(v,w)⟧, by simp [h]⟩

lemma edge_eq_edge_of_adj (e : G.E):
  ∃ v w, ∃ (h : v ◯⦃G⦄ w), e = G.edge_of_adj h :=
begin
    cases e,
    rcases e_val,
    cases e_val with v w,
    rcases e_property with ⟨⟨v', w'⟩, h'⟩,
    use [v', w'],
    use h'.1,
    apply subtype.eq,
    exact h'.2.symm,
end

lemma edge_eq_edge_of_adj_iff (e : G.E) {v w} (h : G.adj v w) :
  e = G.edge_of_adj h ↔ v ∈ e ∧ w ∈ e :=
begin
  cases e with e he,
  rcases e with ⟨v', w'⟩,
--  change v' ◯⦃G⦄ w' at he,
  split,
  { intro H,
    cases G with adj symm loopless,
    dsimp at symm loopless h he,
    unfold edge_of_adj at H,
    rw H,
    unfold has_mem.mem sym2.mem,
    simp,
    split,
    use w, use v,
    apply quotient.exact,
    -- how the fuck
    exact sym2.eq_swap },
  { rintro ⟨hv,hw⟩,
    cases hv with v hv,
    cases hw with w hw,
    ext,
    apply sym2.eq_iff.2,
    cases sym2.eq_iff.1 hv;
    cases sym2.eq_iff.1 hw; try {cc},
    replace h := adj_ne _ _ _ h,
    cc,
    clear hv hw,
    cases he with he h3 h4,
    set he := adj_ne _ _ _ h3.1,
    rcases h_1 with ⟨rfl, rfl⟩,
    rcases h_2 with ⟨rfl, rfl⟩,
    replace h := adj_ne _ _ _ h,
    cases h rfl }
end

@[simp]
lemma mem_of_adj {v w : V} (h : G.adj v w) :
  v ∈ G.edge_of_adj h := sym2.mk_has_mem v w

@[simp]
lemma mem_of_adj_right {v w : V} (h : G.adj v w) :
  w ∈ G.edge_of_adj h := sym2.mk_has_mem_right v w

lemma adj_iff_exists_edge {v w : V} (hne : v ≠ w) :
G.adj v w ↔ ∃ (e : G.E), v ∈ e ∧ w ∈ e :=
begin
  split, { intro, use ⟦(v,w)⟧, use (v,w), use a, refine ⟨(G.mem_of_adj _), (G.mem_of_adj_right _)⟩,
  exact a, exact a },
  rintro ⟨e, ⟨w', hve⟩, ⟨v', hew⟩⟩,
  have : e.val = ⟦(v,w)⟧, { rw [hve, sym2.eq_iff] at hew ⊢, cc },
  have key := e.property, rwa this at key,
  cases key,
  cases key_h with vw h,
  cases quotient.exact h,
  exact vw,
  apply G.sym,
  exact vw,
end

lemma empty_edge (e : (@empty V).E) : false := by tidy

lemma edge_eq_iff (e d : G.E) : e = d ↔ ∃ u, ∃ v ≠ u, u ∈ e ∧ u ∈ d ∧ v ∈ e ∧ v ∈ d :=
begin
 split,
 { rintro rfl, rcases G.edge_eq_edge_of_adj e with ⟨u, v, h, rfl⟩,
  use [u, v], have := G.ne_of_edge h, simp; cc,
 },
 rintro ⟨u, v, h, _⟩,
 have : G.adj v u, rw G.adj_iff_exists_edge h, use e, tauto,
 transitivity G.edge_of_adj this,
 { rw edge_eq_edge_of_adj_iff, tauto },
 { symmetry, rw edge_eq_edge_of_adj_iff, tauto },
end

@[ext]
lemma edge_eq_iff' (e d : G.E) : e = d ↔ ∀ u, u ∈ e ↔ u ∈ d :=
begin
  split, { rintro rfl, simp },
  intro h, rw edge_eq_iff,
  rcases G.edge_eq_edge_of_adj e with ⟨u, v, h_adj, rfl⟩,
  use [u, v],
  have := G.ne_of_edge h_adj, simp only [← h], simp; tauto,
end

variables {G}

/-- Given an edge and one vertex incident on it, construct the other one. -/
noncomputable def E.other (e : G.E) {v : V} (h : v ∈ e) : V :=
by { have : v ∈ e.val, apply h, exact this.other }

lemma E.other_mem (e : G.E) {v : V} (h : v ∈ e) : e.other h ∈ e :=
begin
  change sym2.mem.other h ∈ e.val, have := sym2.mem_other_spec h,
  convert sym2.mk_has_mem_right _ _; tauto,
end

lemma E.other_ne (e : G.E) {v : V} (h : v ∈ e) : e.other h ≠ v :=
begin
  have key := e.property,
  erw [← sym2.mem_other_spec h, sym2.eq_swap] at key,
  cases key with vw hvw,
  cases hvw with h1 h2,
  cases vw with v w,
  unfold E.other,
  cases quotient.exact h2 with AA BB,
  apply G.ne_of_edge,
  convert h1,
  symmetry,
  apply G.ne_of_edge,
  convert h1
end

lemma E.mem_iff (e : G.E) {v : V} (h : v ∈ e) (u : V) :
  u ∈ e ↔ u = v ∨ u = e.other h :=
begin
  convert sym2.mem_iff using 1,
  erw sym2.mem_other_spec h, refl,
end

lemma E.eq_other_iff (e : G.E) {v : V} (h : v ∈ e) (u : V) :
 u = e.other h ↔ u ≠ v ∧ u ∈ e :=
begin
  split, { rintro rfl, refine ⟨ E.other_ne _ _, E.other_mem _ _⟩ },
  rintro ⟨huv, hu⟩,
  rw e.mem_iff h at hu, tauto,
end
attribute [irreducible] E.other

instance E.inhabited [inhabited {p : V × V | G.adj p.1 p.2}] : inhabited G.E :=
⟨begin
  rcases inhabited.default {p : V × V | G.adj p.1 p.2} with ⟨⟨x, y⟩, h⟩,
  use ⟦(x, y)⟧, rwa sym2.from_rel_prop,
end⟩

instance edges_fintype [decidable_eq V] [fintype V] [decidable_rel G.adj] :
  fintype G.E := subtype.fintype _

section classical
open_locale classical
noncomputable theory

theorem E.exists_non_canonical_directed_structure (e : G.E) :
(∃ v w : V, e.val = sym2.mk v w) :=
begin
  cases e with e he,
  let vw := quotient.out e,
  use [vw.1, vw.2],
  change _ = quotient.mk (prod.mk vw.fst vw.snd),
  dsimp,
  convert (quotient.out_eq e).symm,
  show _ = vw,
  generalize : vw = k,
  cases k, refl,
end

theorem E.exists_noncanonical_ordered_pair (e : G.E) :
(∃ vw : V × V, e.val = quotient.mk vw) :=
begin
  rcases E.exists_non_canonical_directed_structure e with ⟨v, w, h⟩,
  use (v,w),
  exact h
end

noncomputable def E.first (e : G.E) : V := (classical.some
  (E.exists_noncanonical_ordered_pair e)).1

noncomputable def E.second (e : G.E) : V := (classical.some
  (E.exists_noncanonical_ordered_pair e)).2

theorem mk_first_second (e : G.E) : e.val = ⟦(E.first e, E.second e)⟧ :=
begin
  have h := classical.some_spec
  (E.exists_noncanonical_ordered_pair e),
  rw h,
  cases e with e he,
  congr',
  ext,
  dsimp,
  refl,refl
end

theorem first_second_rel (e : G.E) : G.adj (e.first) e.second :=
begin
  have := mk_first_second e,
  cases e with e he,
  dsimp at this,
  rw this at he,
  cases he,
  cases he_h with h1 h2,
  cases quotient.exact h2,
  exact h1,
  apply G.sym,
  exact h1
end

-- e = ⟦(E.first e, E.second e)⟧ but I don't need this yet
-- because graphs are not directed yet

def E.nonempty (e : G.E) : ∃ v : V, v ∈ e :=
begin
  rcases E.exists_non_canonical_directed_structure e
    with ⟨v, w, h⟩,
  use v,
  cases e with e he,
  dsimp at *,
  subst h,
  use w,
  simp, refl
end

def E.some (e : G.E) : V :=
classical.some (E.nonempty e)

lemma E.some_spec (e : G.E) : e.some ∈ e :=
classical.some_spec (E.nonempty e)

/-! # counting edges so let V be finite now -/

variables [fintype V]

def E_finset  (G : simple_graph V) : finset $ V × V :=
finset.filter (λ x, G.adj x.1 x.2) univ

def foo (G : simple_graph V) : fin 2 × G.E ≃
  {x : V × V // x ∈ G.E_finset.val} :=
{ to_fun := λ be, if be.1 = 0 then ⟨(be.2.some, be.2.other be.2.some_spec),
  by
    { suffices : G.adj be.2.some (be.2.other be.2.some_spec), simpa [E_finset],
     rw adj_iff_exists_edge, refine ⟨ be.2, be.2.some_spec, _⟩, apply be.2.other_mem,
     symmetry, apply be.2.other_ne },
⟩
     else ⟨(be.2.other be.2.some_spec, be.2.some), by
     { suffices : G.adj (be.2.other be.2.some_spec) _, simpa [E_finset],
     rw adj_iff_exists_edge, { refine ⟨ be.2, _, be.2.some_spec⟩, apply be.2.other_mem },
     simp [be.2.other_ne] },
     ⟩,
  inv_fun := sorry,
  left_inv := sorry,
  right_inv := sorry }

lemma E_finset_spec [decidable_eq V] [fintype V] [decidable_rel G.adj] :
2 * fintype.card G.E = finset.card G.E_finset :=
begin
  -- transitivity 2 * finset.card _, ring,
  have : fintype.card (fin 2) = 2, { tidy },
  rw [← this, ← fintype.card_prod],
  rw ← fintype.card_of_finset, swap, { intro, refl },
  convert fintype.of_equiv_card _,
  sorry
  -- symmetry, refine equiv.of_bijective _ _,
  -- rintro ⟨b, e⟩,
  -- refine if b = 0
  --   then ⟨(e.some, e.other e.some_spec), _⟩
  --   else ⟨(e.other e.some_spec, e.some), _⟩,
  -- { suffices : G.adj e.some (e.other e.some_spec), simpa [E_finset],
  --   rw adj_iff_exists_edge, refine ⟨ e, e.some_spec, _⟩, apply e.other_mem,
  --   symmetry, apply e.other_ne },
  -- { suffices : G.adj (e.other e.some_spec) _, simpa [E_finset],
  --   rw adj_iff_exists_edge, { refine ⟨ e, _, e.some_spec⟩, apply e.other_mem },
  --   simp [e.other_ne] },
  -- -- proof it's bijective
  -- split,
  -- sorry,
  -- -- refine ⟨_, _⟩,
  -- -- intros x y h,
  -- -- by_cases hxy : x.1 = y.1,
  -- -- ext, any_goals { simp [hxy] },
  -- -- dsimp at h, by_cases hy : y.1 = 0,
end
variables (G)

def card_edges : ℕ := fintype.card G.E

@[simp] lemma empty_card_edges : (@empty V).card_edges = 0 :=
by { dsimp [card_edges], rw fintype.card_eq_zero_iff, tidy }

@[simp] lemma card_edges_eq_zero_iff :
  G.card_edges = 0 ↔ G = empty :=
begin
  split, swap, { rintro rfl, simp },
  intro h, dsimp [card_edges] at h,
  ext, simp only [empty, iff_false], contrapose! h,
  rw [← nat.pos_iff_ne_zero, fintype.card_pos_iff],
  apply nonempty.intro, exact G.edge_of_adj h,
end

lemma empty_iff_not_edge : G = empty ↔ G.E → false :=
begin
  split, { rintro rfl, apply empty_edge },
  intro h, ext u v, suffices : ¬ G.adj u v, { tidy },
  intro he, have e := G.edge_of_adj he, exact h e,
end

def inhabited_of_ne_empty (h : G ≠ empty) : inhabited G.E :=
begin
  suffices : nonempty G.E, { letI := this, inhabit G.E, assumption },
  refine fintype.card_pos_iff.mp _, contrapose! h,
  erw [le_zero_iff_eq, card_edges_eq_zero_iff] at h, exact h,
end
end classical

attribute [irreducible] E

@[simp] lemma irrefl {v : V} : ¬G.adj v v := G.loopless v

@[symm] lemma edge_symm (u v : V) : G.adj u v ↔ G.adj v u :=
by split; apply G.sym

@[simp] lemma mem_neighbor_set (v w : V) : w ∈ G.neighbor_set v ↔ G.adj v w :=
by tauto

section finite_at

/-!
## Finiteness at a vertex
This section contains definitions and lemmas concerning vertices that
have finitely many adjacent vertices.  We denote this condition by
`fintype (G.neighbor_set v)`.
We define `G.neighbor_finset v` to be the `finset` version of `G.neighbor_set v`.
Use `neighbor_finset_eq_filter` to rewrite this definition as a `filter`.
-/

variables (v : V) [fintype (G.neighbor_set v)]
variables (G)
/--
`G.neighbors v` is the `finset` version of `G.adj v` in case `G` is
locally finite at `v`.
-/
def neighbor_finset : finset V := (G.neighbor_set v).to_finset

@[simp] lemma mem_neighbor_finset (w : V) :
  w ∈ G.neighbor_finset v ↔ G.adj v w :=
by simp [neighbor_finset]

/--
`G.degree v` is the number of vertices adjacent to `v`.
-/
def degree : ℕ := (G.neighbor_finset v).card

@[simp]
lemma card_neighbor_set_eq_degree : fintype.card (G.neighbor_set v) = G.degree v :=
by simp [degree, neighbor_finset]

end finite_at

section locally_finite

variables (G) [∀ (v : V), fintype (G.neighbor_set v)]
/--
A regular graph is a locally finite graph such that every vertex has the same degree.
-/
def regular_graph (d : ℕ) : Prop := ∀ (v : V), G.degree v = d

end locally_finite

section finite

variables [fintype V]

instance neighbor_set_fintype [decidable_rel G.adj] (v : V) : fintype (G.neighbor_set v) :=
  @subtype.fintype _ _ (by {simp_rw mem_neighbor_set, apply_instance}) _

lemma neighbor_finset_eq_filter {v : V} [decidable_rel G.adj] :
  G.neighbor_finset v = finset.univ.filter (G.adj v) :=
by { ext, simp }

@[simp]
lemma complete_graph_degree [decidable_eq V] (v : V) :
  (@complete_graph V).degree v = fintype.card V - 1 :=
begin
  convert univ.card.pred_eq_sub_one,
  erw [degree, neighbor_finset_eq_filter, filter_ne, card_erase_of_mem (mem_univ v)],
end

lemma complete_graph_is_regular [decidable_eq V] :
  (@complete_graph V).regular_graph (fintype.card V - 1) :=
by { intro v, simp }

end finite

end simple_graph


import category_theory.comma
import algebra.category.CommRing
import .global
import .ideals
import .Omega
import data.opposite
import ring_theory.ideals
import  .src.sieve
import  .src.grothendieck
open category_theory
open opposite
universes u
local notation `Ring` := CommRing.{u}
local notation `Aff`  := Ringᵒᵖ
local notation `Set` :=  Type u

--- The goals is to define Zariski topology on Aff := Ringᵒᵖ
--- We use the definition on Topos theory !
--- Starting we ideal lemma

namespace ideals
lemma set_image_S_subset_set_image_span_S (A B : Ring )(f : A ⟶ B) (S : set A) :
set.image f S ⊆  set.image f (ideal.span S) :=
begin
    apply set.image_subset,
    exact ideal.subset_span ,
end

lemma ideal.map_span_eq_span_image(A B : Ring )(f : A ⟶ B) (S : set A):
    ideal.span (set.image f S) = ideal.map f (ideal.span S) :=
begin
    apply le_antisymm,
    exact ideal.span_mono (set_image_S_subset_set_image_span_S A B f S),
    exact ideal.map_le_iff_le_comap.2 (ideal.span_le.2 (set.image_subset_iff.1 (ideal.subset_span))),
end

-- idée
-- Profiter de ⊤

lemma top_ideal_map (A B : Ring)(f : A ⟶ B)(S : set A) :
ideal.span S = ⊤ → ideal.span (set.image f S) = ⊤ := λ certif,
begin
    rw ideal.map_span_eq_span_image,
    rw certif,
    exact ideal.map_top f,
end

lemma one_ideal_map {A  B : Ring}(f : A ⟶ B)(S : set A) :
(1 : A) ∈ ideal.span S → (1 : B) ∈ ideal.span( set.image f S) := λ P, begin
have hyp : f 1  ∈ ideal.span (set.image f S),
        rw ideal.map_span_eq_span_image,
        apply ideal.mem_map_of_mem,
        exact P,
    rw  f.map_one at hyp,
    assumption,
end
end ideals
open ideals

namespace Pre_sieves
structure Presieves (X : Aff) :=
(S : set (X.unop))
(co_maximality : (1 : X.unop) ∈ ideal.span S)

@[ext] lemma ext (X : Aff) (P Q : Presieves X) : P.S = Q.S → P = Q  :=
    begin
        intros h1,
        cases P,
        cases Q,
        congr ; try { assumption },
    end
def pull_back{X Y : Aff}(f : Y ⟶ X) : Presieves(X) → Presieves(Y)  := λ P, begin
 exact {S := set.image f.unop P.S, co_maximality := one_ideal_map f.unop P.S P.co_maximality},
 end
lemma pull_back_ext {X Y : Aff}(f : Y ⟶ X)(P : Presieves X): (pull_back f P).S = set.image f.unop P.S := rfl
/-
Test for a Presieves to be eq to pull-back.
-/
theorem pull_back_eq {X Y : Aff}(f : Y ⟶ X)(P : Presieves X)(Q_Y : Presieves Y) :
        pull_back f P = Q_Y ↔ set.image f.unop P.S = Q_Y.S :=
    begin
        split,
        intros, subst a, rw pull_back_ext,
            intros, apply ext, rw pull_back_ext, assumption,
    end
/-
    Direct image of a presieves.
-/
lemma inverse_image_ideal (A B : Ring)(f : A ⟶ B)(S : set B) :
    ideal.span (set.preimage f S) ≤  ideal.comap f (ideal.span S) :=
    begin
        rw ideal.span_le,   -- span S \leq I ↔  S ≤ I
        apply set.preimage_mono ideal.subset_span,
    end

def direct_image (X Y : Aff) (P : Presieves Y) (h : Y ⟶ X) : Presieves(X) :=
begin
    -- inverse image
    -- h : R(X) ⟶ R(Y)  and P : set R(Y) with 1 ∈ ideal.span P.S
    -- i take :  P' := { comap h S }
    have hyp : (1 : X.unop) ∈ ideal.span (set.preimage h.unop (ideal.span(P.S))),
        apply ideal.subset_span,
        rw  set.mem_preimage,
    have F : (has_hom.hom.unop h) 1 = (1 : Y.unop),
        exact h.unop.map_one,
    have j : (1 : Y.unop) ∈ ideal.span P.S,
        exact P.co_maximality,
    rw ← F at j,
    assumption,
    have hyp2 : (ideal.span (set.preimage h.unop (ideal.span(P.S))) : set X.unop) = set.preimage h.unop (ideal.span(P.S)),

    -- exact {S := set.preimage h.unop P.S, co_maximality := hyp},
end
end  Pre_sieves

open Pre_sieves
def sieves_of (X : Aff) (P : Presieves X) :=
{ f : over X |∃ s : P.S, ∃ u : unop f.left,  ((f.hom s.val * u ) : unop f.left ) = 1 }

-- Ici le plus simple va être de faire appel à units !
--
lemma mem_sieves (X : Aff) (P : Presieves X)(f : over X) : (
∃ s : P.S, ∃ u : unop f.left, ((f.hom s.val * u ) : unop f.left ) = 1) →   f ∈ (sieves_of X P) := λ hyp, hyp

lemma sieves_mem {X : Aff} {P : Presieves X}{f : over X} : f ∈ (sieves_of X P) →
(∃ s : P.S,∃ u : unop f.left, ((f.hom s.val * u ) : unop f.left ) = 1) := λ hyp,hyp

def subs (X : Aff) (P : Presieves X) :
∀ (f : over X) (hyp : f ∈ (sieves_of X P)) (Z : Aff) (g : Z ⟶ f.left),
 (over.mk (g ≫ f.hom)) ∈ (sieves_of X P) :=
begin
    intros, apply mem_sieves, rw over.mk_hom, rcases hyp with ⟨s,u, hyp_su⟩, use s, use g u,
    show  g.unop( f.hom(s.val)) * g.unop (u) = (1 : unop Z),
        rw ← g.unop.map_mul (f.hom s.val) u,rw hyp_su,
        exact g.unop.map_one,
end

def Aff_sieves (X : Aff )(P : Presieves X) : sieve(X) := {arrows := sieves_of X P,subs := subs X P}
def Aff_sieves_arrow (X : Aff )(P : Presieves X) : (Aff_sieves X P).arrows = sieves_of X P := rfl

/-
Fondamental theorem  : le faire mieux avec Aff_sieves !
-/
theorem pull_back_stability{X Y: Aff}(h : Y ⟶ X) (S : Presieves X)(f : over Y) :
 (over.mk (f.hom ≫ h)) ∈ Aff_sieves X S  →  f ∈ (Aff_sieves Y (pull_back h S))  :=
λ fh_hyp, begin
    rcases  sieves_mem  fh_hyp with s,
    apply mem_sieves,
    use h.unop s,
        rw pull_back_ext,
        exact set.mem_image_of_mem h.unop s.property,
    exact h_1,
end
theorem pull_back_stability'{X Y: Aff}(h : Y ⟶ X) (S : Presieves X)(f : over Y) :
  f ∈ (Aff_sieves Y (pull_back h S)) → (over.mk (f.hom ≫ h)) ∈ Aff_sieves X S :=
λ fh_hyp, begin
    rcases  sieves_mem  fh_hyp with hs,
    apply mem_sieves,
    cases  set.mem_image_iff_bex.1 hs.property with s hyp_s,
    use s,
    rcases hyp_s with hyp_hs,
    exact hyp_hs,
    rcases hyp_s with hyp_hs,
    rw ← hyp_s_h at h_1,
    exact h_1,
end
/-
Zariski
-/

def Zariski_topology( X : Aff)  :=  {S : sieve X | ∃ P : Presieves X, S = Aff_sieves X P}

lemma mem_Zariski ( X : Aff) (S : sieve X) :
S ∈ Zariski_topology( X) →  ∃  P : Presieves X, S = Aff_sieves X P := λ SS,
begin
cases SS with a t,
use a,
exact t,
end
lemma mem_Zariski_ ( X : Aff) (S : sieve X) : (∃  P : Presieves X, S = Aff_sieves X P) →
S ∈ Zariski_topology( X)  := λ hyp, hyp

def Zariski_of (X : Aff) : Presieves X → Zariski_topology(X) := λ S,begin
use Aff_sieves X S,
unfold Zariski_topology,
split,
show Aff_sieves X S = Aff_sieves X S,
    exact rfl,
end
-- But : prouver que Zariski Topology is grothendieck topology !
-- Il nous faut parler du sieves max
def max'(X : Aff) : sieve X := Zariski_of (X) ({S := {(1 : unop X)}, co_maximality :=
begin
    apply ideal.subset_span,
    exact set.mem_singleton 1,
end  })
lemma max_is_max(X : Aff) :  max'(X) = ⊤ := begin
    ext f,
    split,intros, trivial,
    intros hyp, apply mem_sieves, use 1,exact set.mem_singleton 1,use 1,rw mul_one,
    exact f.hom.unop.map_one,
end

lemma pull_back_comp (X Y : Aff) (P : Presieves X) (h : Y ⟶ X) :
    sieve.pullback (Aff_sieves X P) h = Aff_sieves Y (pull_back h P) :=
begin
    ext f,
    split,
        intros hyp,apply pull_back_stability, rw ← sieve.pullback_def2 h,exact hyp,
        intros, show f ∈ sieve.pullback (Aff_sieves X P) h,
                    rw sieve.pullback_def2 h, apply pull_back_stability',exact a,
end

#print grothendieck
def stab'  (X Y : Aff) (S ∈ Zariski_topology X) (h : Y ⟶ X) :
            sieve.pullback S h ∈ Zariski_topology(Y) :=
    begin
        apply mem_Zariski_ Y,
        cases H with P Hyp,
        use pull_back h P,
        subst Hyp ,
        exact pull_back_comp X Y P h ,
    end
-- il nous faut étudier un peu les choses !
-- Par exemple l'hypothèse :  (f : over X),  sieve.pullback R f.fom ∈ Zariski(f.left)
--    f :  Z    →  X, il existe  (S(Z) set Z) tel que sieve.pullback R f.hom = Ring sieve S(Z)
--     g Z' → Z, g f ∈ R ↔  ∃ s_Z  g s_Z inversible

def trans' (X : Aff)(S ∈ Zariski_topology X)(R : sieve X) : (∀(f : over X), f ∈ S →
sieve.pullback R f.hom ∈  Zariski_topology(f.left)) → (R ∈ Zariski_topology(X)) :=
begin
 sorry,
end


import M4R.Algebra.Ring.Ideal

namespace M4R
  open Monoid CommMonoid Group NCSemiring Semiring

  namespace QuotientRing

    def QRel [Ring α] (I : Ideal α) (a b : α) : Prop := -a + b ∈ I
    theorem QRel.refl [Ring α] (I : Ideal α) (a : α) : QRel I a a := by
      simp only [QRel]; rw [neg_add]; exact I.has_zero
    theorem QRel.symm [Ring α] (I : Ideal α) {a b : α} : QRel I a b → QRel I b a := by
      simp only [QRel]; intro h
      rw [←neg_neg a, ←neg_add_distrib]
      exact I.neg_closed h
    theorem QRel.trans [Ring α] (I : Ideal α) {a b c : α} : QRel I a b → QRel I b c → QRel I a c := by
      simp only [QRel]; intro h₁ h₂
      have := I.add_closed h₁ h₂
      rw [add_assoc, ←add_assoc b, add_neg, zero_add] at this
      exact this

    instance QEquivalence [Ring α] (I : Ideal α) : Equivalence (QRel I) where
      refl  := QRel.refl I
      symm  := QRel.symm I
      trans := QRel.trans I

    instance QSetoid [Ring α] (I : Ideal α) : Setoid α where
      r := QRel I
      iseqv := QEquivalence I

    def QClass [Ring α] (I : Ideal α) : Type _ := Quotient (QSetoid I)

    def toQuotient [Ring α] (I : Ideal α) (a : α) : QClass I := @Quotient.mk α (QSetoid I) a

    theorem toQuotient.def₁ [Ring α] (I : Ideal α) (a : α) : @Quotient.mk α (QSetoid I) a = toQuotient I a := rfl
    theorem toQuotient.def₂ [Ring α] (I : Ideal α) (a : α) : @Quot.mk α (QSetoid I).r a = toQuotient I a := rfl

    theorem QClass.equiv [Ring α] (I : Ideal α) : ∀ a b : α, toQuotient I a = toQuotient I b ↔ -a + b ∈ I := fun a b =>
      ⟨@Quotient.exact α (QSetoid I) a b, @Quotient.sound α (QSetoid I) a b⟩

    def QuotAdd [Ring α] (I : Ideal α) : QClass I → QClass I → QClass I :=
      Function.Quotient.map₂ (QRel I) (QRel I) (QRel I)
        (QRel.refl I) (QRel.refl I) (· + ·) (fun a₁ a₂ b₁ b₂ ha hb => by
          simp only [QRel] at *
          rw [neg_add_distrib, add_comm (-b₁), add_assoc, ←add_assoc (-b₁), add_comm (-b₁), add_assoc, ←add_assoc]
          exact I.add_closed ha hb)

    def QuotNeg [Ring α] (I : Ideal α) : QClass I → QClass I :=
      Function.Quotient.map (QRel I) (QRel I) (- ·)
        (fun x y hxy => by
          simp only [QRel] at *; rw [←neg_add_distrib, add_comm]; exact I.neg_closed hxy)

    def QuotMul [Ring α] (I : Ideal α) : QClass I → QClass I → QClass I :=
      Function.Quotient.map₂ (QRel I) (QRel I) (QRel I)
        (QRel.refl I) (QRel.refl I) (· * ·) (fun a₁ a₂ b₁ b₂ ha hb => by
          simp only [QRel] at *
          have := I.add_closed (I.mul_closed b₁ ha) (I.mul_closed a₂ hb)
          rw [mul_distrib_left, mul_distrib_left, NCRing.mul_neg, mul_comm, mul_comm b₁, add_assoc,
            ←add_assoc (a₂ * b₁), NCRing.mul_neg, add_neg, zero_add] at this; exact this)
  end QuotientRing

  open QuotientRing

  instance QuotientRing {α : Type _} [Ring α] (I : Ideal α) : Ring (QClass I) := Ring.construct
    {
      zero := toQuotient I 0
      one  := toQuotient I 1
      add  := QuotAdd I
      neg  := QuotNeg I
      mul  := QuotMul I
      add_zero := by
        apply Quot.ind; intros; apply Quot.sound; simp only [QRel]
        rw [add_zero, neg_add]; exact I.has_zero
      add_assoc := by
        apply Function.Quotient.ind₃; intros; apply Quot.sound; simp only [QRel]
        rw [add_assoc, neg_add]; exact I.has_zero
      add_neg := by
        apply Quot.ind; intros; apply Quot.sound; simp only [QRel]
        rw [add_neg, neg_add]; exact I.has_zero
      add_comm := by
        apply Function.Quotient.ind₂; intro a _; apply Quot.sound; simp only [QRel]
        rw [add_comm a, neg_add]; exact I.has_zero
      mul_one := by
        apply Quot.ind; intros; apply Quot.sound; simp only [QRel]
        rw [mul_one, neg_add]; exact I.has_zero
      mul_assoc := by
        apply Function.Quotient.ind₃; intros; apply Quot.sound; simp only [QRel]
        rw [mul_assoc, neg_add]; exact I.has_zero
      mul_distrib_left := by
        apply Function.Quotient.ind₃; intros; apply Quot.sound; simp only [QRel]
        rw [mul_distrib_left, neg_add]; exact I.has_zero
      mul_comm := by
        apply Function.Quotient.ind₂; intros; apply Quot.sound; simp only [QRel]
        rw [mul_comm, neg_add]; exact I.has_zero
    }

  namespace QuotientRing

    theorem non_zero [Ring α] {I : Ideal α} {a : α} : toQuotient I a ≠ 0 ↔ a ∉ I :=
      ⟨by intro hI ha; apply hI; apply Quot.sound; simp only [Setoid.r, QRel]; rw [add_zero]; exact I.neg_closed ha,
      by
        intro ha hI; apply ha; have := @Quotient.exact α (QSetoid I) _ _ hI
        simp only [HasEquiv.Equiv, Setoid.r, QRel] at this; rw [add_zero] at this; rw [←neg_neg a]
        exact I.neg_closed this⟩

    theorem is_zero [Ring α] {I : Ideal α} {a : α} : toQuotient I a = 0 ↔ a ∈ I :=
      not_iff_not.mp non_zero

    protected theorem trivial_zero [Ring α] (x : QClass (1 : Ideal α)) : x = 0 :=
      @Quot.ind _ _ (· = (0 : QClass 1)) (fun _ => is_zero.mpr trivial) x

    theorem preserve_pow_nat [Ring α] (I : Ideal α) (a : α) (n : Nat) : (toQuotient I a) ^ n = toQuotient I (a ^ n) := by
      induction n with
      | zero      => rfl
      | succ n ih => rw [pow_nat_succ, pow_nat_succ, ih]; rfl

    def natural_hom [Ring α] (I : Ideal α) : α →ᵣ₁ QClass I where
      hom           := toQuotient I
      preserve_zero := rfl
      preserve_add  := fun _ _ => rfl
      preserve_neg  := fun _ => rfl
      preserve_one  := rfl
      preserve_mul  := fun _ _ => rfl

    theorem natural_hom.def [Ring α] (I : Ideal α) (a : α) : toQuotient I a = natural_hom I a := rfl

    theorem natural_hom.surjective [Ring α] (I : Ideal α) : Function.surjective (natural_hom I).hom :=
      @Quot.ind _ _ (fun x : QClass I => ∃ y, natural_hom I y = x) (fun y => ⟨y, rfl⟩)

    theorem natural_hom.kernel [Ring α] {I : Ideal α} {x : α} : natural_hom I x = 0 ↔ x ∈ I :=
      ⟨fun h => zero_add x ▸ neg_zero ▸ (QClass.equiv I 0 x).mp h.symm,
      fun hx => ((QClass.equiv I 0 x).mpr (neg_zero.symm ▸ (zero_add x).symm ▸ hx)).symm⟩

    open Ideal

    theorem natural_hom.extension_add_I [Ring α] (I J : Ideal α) :
      extension (natural_hom I) (I + J) = extension (natural_hom I).hom J :=
        congrArg from_set (Set.ext.mp fun x => ⟨fun ⟨y, ⟨i, hi, j, hj, hij⟩, hyx⟩ =>
          ⟨j, hj, by rw [←hyx, ←hij, (natural_hom I).preserve_add, natural_hom.kernel.mpr hi, zero_add]⟩,
        fun ⟨y, hy, hyx⟩ => ⟨y, Ideal.add.subset' I J hy, hyx⟩⟩)

    theorem quotient_contraction_contains [Ring α] {I : Ideal α} (J : Ideal (QClass I)) : I ⊆ contractionᵣ₁ (natural_hom I) J :=
      fun x hx => (natural_hom.kernel.mpr hx ▸ J.has_zero : natural_hom I x ∈ J)

    theorem quotient_extension_contraction [Ring α] {I J : Ideal α} (h : I ⊆ J) :
      contractionᵣ₁ (natural_hom I) (extension (natural_hom I) J) = J :=
        Ideal.antisymm (fun x hx =>
          from_set.induction (fun y => ∀ x : α, natural_hom I x = y → x ∈ J) hx
            (fun x hx => h (natural_hom.kernel.mp hx))
            (fun x ⟨z, hz, hzx⟩ y hyx => by
              rw [←zero_add y, ←add_neg z, add_assoc]
              exact J.add_closed hz (h ((QClass.equiv I z y).mp (hyx ▸ hzx : natural_hom I z = natural_hom I y))))
            (fun x y hx hy z hz => by
              let ⟨x', hx'⟩ := natural_hom.surjective I x
              let ⟨y', hy'⟩ := natural_hom.surjective I y
              rw [←hx', ←hy'] at hz
              have := J.add_closed (J.add_closed (hx x' hx') (hy y' hy')) (h ((QClass.equiv I (x' + y') z).mp hz.symm))
              rw [←add_assoc, add_neg, zero_add] at this
              exact this)
            (fun x y hy z hz => by
              let ⟨x', hx'⟩ := natural_hom.surjective I x
              let ⟨y', hy'⟩ := natural_hom.surjective I y
              rw [←hx', ←hy'] at hz
              have := J.add_closed (J.mul_closed x' (hy y' hy')) (h ((QClass.equiv I (x' * y') z).mp hz.symm))
              rw [←add_assoc, add_neg, zero_add] at this
              exact this) x rfl) (extension_contraction _ J)

    theorem quotient_extension_injective [Ring α] {I J K : Ideal α} (h : extension (natural_hom I) J = extension (natural_hom I).hom K) :
      J + I = K + I := by
        have := congrArg (contractionᵣ₁ (natural_hom I)) h
        rw [←natural_hom.extension_add_I I J, quotient_extension_contraction (Ideal.add.subset I J), Ideal.add.comm I J,
          ←natural_hom.extension_add_I I K, quotient_extension_contraction (Ideal.add.subset I K), Ideal.add.comm I K] at this
        exact this

    theorem quotient_extension_subsetneq [Ring α] {I J K : Ideal α} (hIJ : I ⊆ J) (hJK : J ⊊ K) : extension (natural_hom I) J ⊊ extension (natural_hom I).hom K :=
      Ideal.subsetneq.mpr ⟨extension.subset _ hJK.left, fun h => absurd (((add.of_subset hIJ).symm.trans (quotient_extension_injective h)).trans
        (add.of_subset (Subset.trans hIJ hJK.left))) (Ideal.subsetneq.mp hJK).right⟩

    theorem quotient_contraction_injective [Ring α] {I : Ideal α} : Function.injective (contractionᵣ₁ (natural_hom I)) :=
      contraction_injective_of_surjective _ (natural_hom.surjective I)

    theorem quotient_extension_proper [Ring α] {I : Ideal α} {J : Ideal α} (hIJ : I ⊆ J) (hJ : J.proper_ideal) : (extension (natural_hom I).hom J).proper_ideal :=
      fun h => absurd (((add.of_subset hIJ).symm.trans (quotient_extension_injective (extension_unit_of_surjective (natural_hom.surjective I) ▸ h))).trans
        (add.of_subset (in_unit_ideal I))) hJ

    theorem quotient_extension_unit [Ring α] {I : Ideal α} {J : Ideal α} (hIJ : I ⊆ J) (hJ : extension (natural_hom I).hom J = 1) : J = 1 :=
      Classical.byContradiction fun h => absurd hJ (quotient_extension_proper hIJ h)

    theorem quotient_extension_zero [Ring α] {I J : Ideal α} : extension (natural_hom I).hom J = 0 ↔ J ⊆ I :=
      Iff.trans Ideal.extension_zero ⟨fun h x hx => natural_hom.kernel.mp (h hx),
        fun h x hx => natural_hom.kernel.mpr (h hx)⟩

    abbrev quotient_zero.inv_map [Ring α] : QClass (0 : Ideal α) → α :=
      Quot.lift id (fun x y h => by
        have := congrArg (x + ·) h
        simp only [←add_assoc, add_neg, zero_add, add_zero] at this
        exact this.symm)

    theorem quotient_zero_iso (α : Type _) [Ring α] : α ≅ᵣ QClass (0 : Ideal α) where
      toRMulMap       := (natural_hom 0).toRMulMap
      inv             := quotient_zero.inv_map
      left_inv        := fun x => @Quot.ind _ _ (fun y : QClass 0 => ∀ x, y = natural_hom 0 x →
        quotient_zero.inv_map y = x) (fun _ _ h => h ▸ rfl) (natural_hom 0 x) x rfl
      right_inv       := @Quot.ind _ _ (fun x : QClass 0 => natural_hom 0 (quotient_zero.inv_map x) = x)
        (fun _ => rfl)

    abbrev sub_quotient_hom.map [Ring α] {I J : Ideal α} (hIJ : I ⊆ J) : QClass I → QClass J :=
      Quot.lift (natural_hom J) fun x y h => (QClass.equiv J x y).mpr (hIJ h)

    def sub_quotient_hom [Ring α] {I J : Ideal α} (hIJ : I ⊆ J) : QClass I →ᵣ₁ QClass J where
      hom           := sub_quotient_hom.map hIJ
      preserve_zero := rfl
      preserve_add  := @Quotient.ind₂ _ _ (QSetoid I) (QSetoid I) (fun x y : QClass I =>
        sub_quotient_hom.map hIJ (x + y) = sub_quotient_hom.map hIJ x  + sub_quotient_hom.map hIJ y)
        fun _ _ => rfl
      preserve_neg  := Quot.ind fun _ => rfl
      preserve_one  := rfl
      preserve_mul  := @Quotient.ind₂ _ _ (QSetoid I) (QSetoid I) (fun x y : QClass I =>
        sub_quotient_hom.map hIJ (x * y) = sub_quotient_hom.map hIJ x  * sub_quotient_hom.map hIJ y)
        fun _ _ => rfl

    theorem sub_quotient_hom.surjective [Ring α] {I J : Ideal α} (hIJ : I ⊆ J) :
      Function.surjective (sub_quotient_hom hIJ).hom :=
        @Quot.ind _ _ (fun x : QClass J => ∃ y, sub_quotient_hom hIJ y = x)
          fun x => ⟨natural_hom I x, rfl⟩

    theorem sub_quotient_hom.def [Ring α] {I J : Ideal α} (hIJ : I ⊆ J) (x : α) :
      sub_quotient_hom hIJ (natural_hom I x) = natural_hom J x := rfl

    theorem sub_quotient_hom.kernel [Ring α] {I J : Ideal α} (hIJ : I ⊆ J) :
      (sub_quotient_hom hIJ).kernel.subset = (extension (natural_hom I) J).subset :=
        Set.ext.mp fun x =>
          ⟨@Quot.ind _ _ (fun x : QClass I => x ∈ (sub_quotient_hom hIJ).kernel.subset → x ∈ (extension (natural_hom I) J).subset)
            (fun x hx => from_set.contains_mem ⟨x, natural_hom.kernel.mp (sub_quotient_hom.def hIJ _ ▸ hx), rfl⟩) x,
          @Quot.ind _ _ (fun x : QClass I => x ∈ (extension (natural_hom I) J).subset → x ∈ (sub_quotient_hom hIJ).kernel.subset)
            (fun x hx => by
              rw [extension_eq_image_of_surjective_mul_closed (natural_hom I).toRMulMap (natural_hom.surjective I) J] at hx
              let ⟨y, hy₁, hy₂⟩ := hx
              have := J.add_closed hy₁ (hIJ ((QClass.equiv I y x).mp hy₂))
              rw [←add_assoc, add_neg, zero_add] at this
              exact natural_hom.kernel.mpr this) x⟩

    open NCRing
    variable [Ring α] (I : Ideal α) (a : α)

    abbrev ideal_quotient_map.map : QClass (ideal_quotient I a) → QClass I :=
      Quot.lift (fun x => natural_hom I (a * x)) fun x y h =>
        (QClass.equiv I _ _).mpr (mul_neg a x ▸ mul_distrib_left a (-x) y ▸ h)
    theorem ideal_quotient_map.map_def [Ring α] (I : Ideal α) (a x : α) :
      ideal_quotient_map.map I a (natural_hom (ideal_quotient I a) x) = natural_hom I (a * x) := rfl

    def ideal_quotient_map : QClass (ideal_quotient I a) →₋ QClass I where
      hom           := ideal_quotient_map.map I a
      preserve_zero := @Quot.ind _ _ (fun x : QClass (ideal_quotient I a) => x = 0 → ideal_quotient_map.map I a x = 0)
        (fun x hx => natural_hom.kernel.mpr (natural_hom.kernel.mp hx : x ∈ ideal_quotient I a))
        (0 : QClass (ideal_quotient I a)) rfl
      preserve_add  := @Quotient.ind₂ _ _ (QSetoid (ideal_quotient I a)) (QSetoid (ideal_quotient I a))
          (fun x y : QClass (ideal_quotient I a) => ideal_quotient_map.map I a (x + y) =
            ideal_quotient_map.map I a x + ideal_quotient_map.map I a y) (fun _ _ => by
              simp only [toQuotient.def₁, natural_hom.def, ideal_quotient_map.map_def,
                ←(natural_hom I).preserve_add, ←mul_distrib_left]; rfl)
      preserve_neg  := Quot.ind (fun x => by
          simp only [toQuotient.def₂, natural_hom.def, ideal_quotient_map.map_def,
            ←(natural_hom I).preserve_neg, ←mul_neg]; rfl)

    theorem ideal_quotient_map.def [Ring α] (I : Ideal α) (a x : α) :
      ideal_quotient_map I a (natural_hom (ideal_quotient I a) x) = natural_hom I (a * x) := rfl

    theorem ideal_quotient_map.preserve_mul_right : preserve_mul_right (ideal_quotient_map I a).toMHomomorphism :=
      fun x y => @Quotient.ind₂ _ _ (QSetoid (ideal_quotient I a)) (QSetoid (ideal_quotient I a))
        (fun x y : QClass (ideal_quotient I a) => ∃ c : QClass I, ideal_quotient_map I a (x * y) =
        c * ideal_quotient_map I a y) (fun x y => ⟨natural_hom I x, (by rw [mul_left_comm, (natural_hom I).preserve_mul] :
          natural_hom I (a * (x * y)) = natural_hom I x * natural_hom I (a * y))⟩) x y

    theorem ideal_quotient_map.injective : Function.injective (ideal_quotient_map I a).hom :=
      @Quotient.ind₂ _ _ (QSetoid (ideal_quotient I a)) (QSetoid (ideal_quotient I a))
        (fun x y : QClass (ideal_quotient I a) => ideal_quotient_map I a x = ideal_quotient_map I a y → x = y)
        (fun x y h => (QClass.equiv _ _ _).mpr (mul_distrib_left _ _ _ ▸ mul_neg _ _ ▸
          (QClass.equiv _ _ _).mp h : a * (-x + y) ∈ I))

    theorem ideal_quotient_map.extension_eq_image : ∀ J, (extension (ideal_quotient_map I a) J).subset =
      Function.image' (ideal_quotient_map I a).hom J.subset :=
        extension_eq_image_of_left_surjective (ideal_quotient_map I a)
          (@Quotient.ind₂ _ _ (QSetoid I) (QSetoid (ideal_quotient I a)) (fun (x : QClass I)
            (y' : QClass (ideal_quotient I a)) => ∃ x', ideal_quotient_map I a (x' * y') = x * ideal_quotient_map I a y')
            (fun x y' => ⟨natural_hom (ideal_quotient I a) x, by
              simp only [toQuotient.def₁, natural_hom.def, ideal_quotient_map.def]
              rw [←(natural_hom I).preserve_mul, mul_left_comm]; rfl⟩))

    theorem ideal_quotient_map.extension_contraction_eq : ∀ J, contraction (ideal_quotient_map.preserve_mul_right I a)
      (extension (ideal_quotient_map I a).hom J) = J :=
        extension_contraction_eq_of_injective_eq_image (ideal_quotient_map.preserve_mul_right I a)
          (ideal_quotient_map.injective I a) (ideal_quotient_map.extension_eq_image I a)

    theorem ideal_quotient_map.extension_injective : Function.injective (extension (ideal_quotient_map I a).hom) :=
      extension_injective_of_extension_contraction (ideal_quotient_map.preserve_mul_right I a)
        (ideal_quotient_map.extension_contraction_eq I a)

    theorem ideal_quotient_map.image : (ideal_quotient_map I a).image.subset = (principal (natural_hom I a)).subset :=
      Set.ext.mp fun x => ⟨fun ⟨y, hy⟩ => hy ▸ @Quot.ind _ _ (fun y : QClass (ideal_quotient I a) => ideal_quotient_map I a y ∈ principal (natural_hom I a))
        (fun y => ⟨natural_hom I y, by rw [toQuotient.def₂, natural_hom.def, ideal_quotient_map.def, (natural_hom I).preserve_mul]⟩) y,
        fun ⟨y, hy⟩ => hy ▸ @Quot.ind _ _ (fun y : QClass I => natural_hom I a * y ∈ (ideal_quotient_map I a).image.subset) (fun y =>
          ⟨natural_hom (ideal_quotient I a) y, by rw [toQuotient.def₂, natural_hom.def, ←(natural_hom I).preserve_mul, ←ideal_quotient_map.def]⟩) y⟩

    private abbrev sub_kernel_lift [Ring β] (f : α →ᵣ β) {I : Ideal α} (hI : I ⊆ f.kernel_ideal) : QClass I → β :=
      fun x => Quot.lift f.hom (fun a b (h : _ ∈ _) => by
        have : _ = _ := hI h
        rw [f.preserve_add, f.preserve_neg, sub_right, zero_add] at this
        exact neg_inj this) x

    def quotient_sub_kernel [Ring β] (f : α →ᵣ β) {I : Ideal α} (hI : I ⊆ f.kernel_ideal) : QClass I →ᵣ β := {
      hom := sub_kernel_lift f hI
      preserve_zero := @Quot.ind _ _ (fun x : QClass I => x = 0 → sub_kernel_lift f hI x = 0)
        (fun x hx => hI (natural_hom.kernel.mp hx)) _ rfl
      preserve_add := @Quotient.ind₂ _ _ (QSetoid I) (QSetoid I) (fun x y : QClass I => sub_kernel_lift f hI (x + y) =
        sub_kernel_lift f hI x + sub_kernel_lift f hI y) f.preserve_add
      preserve_neg := @Quot.ind _ _ (fun x : QClass I => sub_kernel_lift f hI (-x) = -sub_kernel_lift f hI x) f.preserve_neg
      preserve_mul := @Quotient.ind₂ _ _ (QSetoid I) (QSetoid I) (fun x y : QClass I => sub_kernel_lift f hI (x * y) =
        sub_kernel_lift f hI x * sub_kernel_lift f hI y) f.preserve_mul
    }

    def quotient_kernel [Ring β] (f : α →ᵣ β) : QClass f.kernel_ideal →ᵣ β := quotient_sub_kernel f (Subset.refl _)

    theorem quotient_kernel_injective [Ring β] (f : α →ᵣ β) : Function.injective (quotient_kernel f).hom :=
      @Quotient.ind₂ _ _ (QSetoid f.kernel_ideal) (QSetoid f.kernel_ideal) (fun x y : QClass f.kernel_ideal =>
        quotient_kernel f x = quotient_kernel f y → x = y) fun x y (h : f x = f y) => (QClass.equiv _ x y).mpr
          (by rw [f.preserve_add, f.preserve_neg, h, neg_add] : f _ = 0)

    theorem chinese_remainder_theorem (I J : Ideal α) (hIJ : Ideal.coprime I J) :
      QClass (I ∩ J) ≅ᵣ QClass I × QClass J :=
        let f : α →ᵣ QClass I × QClass J := {
          hom := fun x => (natural_hom I x, natural_hom J x)
          preserve_zero := rfl
          preserve_add := fun _ _ => rfl
          preserve_neg := fun _ => rfl
          preserve_mul := fun _ _ => rfl
        }
        have : I ∩ J = f.kernel_ideal := Ideal.ext'.mpr fun x =>
          ⟨fun hx => (by rw [←natural_hom.kernel.mpr hx.left, ←natural_hom.kernel.mpr hx.right] : f x = (0, 0)),
          fun hx => ⟨natural_hom.kernel.mp (Prod.mk.inj hx).left, natural_hom.kernel.mp (Prod.mk.inj hx).right⟩⟩
        this ▸ RIsomorphism.of_bijection (quotient_kernel f) ⟨quotient_kernel_injective f,
          fun (x, y) => let ⟨i, hi, j, hj, hij⟩ := is_unit_ideal.mp hIJ; @Quotient.ind₂ _ _ (QSetoid I) (QSetoid J)
            (fun (x : QClass I) (y : QClass J) => ∃ a : QClass f.kernel_ideal, quotient_kernel f a = (x, y))
              (fun x y => ⟨natural_hom _ (x * j + y * i),
                have : ∀ (x y i j : α) (I : Ideal α), i + j = 1 → i ∈ I → natural_hom I (x * j + y * i) = natural_hom I x :=
                  fun x y i j I hij hi => (QClass.equiv _ _ _).mpr (by
                    rw [(sub_right.mp (add_comm i j ▸ hij) : j = 1 + -i), mul_distrib_left, mul_one, mul_neg_swap, add_assoc,
                    ←mul_distrib_right, neg_add_distrib, add_assoc, neg_add, add_zero, ←neg_mul]; exact I.mul_closed _ hi)
                Prod.mk.injEq _ _ _ _ ▸ ⟨this x y i j I hij hi, add_comm _ _ ▸ this y x j i J (add_comm i j ▸ hij) hj⟩⟩) x y⟩

  end QuotientRing
end M4R


/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Johannes Hölzl

Defines the Liminf/Limsup of a function taking values in a conditionally complete lattice, with
respect to an arbitrary filter.

We define `f.Limsup` (`f.Liminf`) where `f` is a filter taking values in a conditionally complete
lattice. `f.Limsup` is the smallest element `a` such that, eventually, `u ≤ a` (and vice versa for
`f.Liminf`). To work with the Limsup along a function `u` use `(f.map u).Limsup`.

Usually, one defines the Limsup as `Inf (Sup s)` where the Inf is taken over all sets in the filter.
For instance, in ℕ along a function `u`, this is `Inf_n (Sup_{k ≥ n} u k)` (and the latter quantity
decreases with `n`, so this is in fact a limit.). There is however a difficulty: it is well possible
that `u` is not bounded on the whole space, only eventually (think of `Limsup (λx, 1/x)` on ℝ. Then
there is no guarantee that the quantity above really decreases (the value of the `Sup` beforehand is
not really well defined, as one can not use ∞), so that the Inf could be anything. So one can not
use this `Inf Sup ...` definition in conditionally complete lattices, and one has to use the
following less tractable definition.

In conditionally complete lattices, the definition is only useful for filters which are eventually
bounded above (otherwise, the Limsup would morally be +∞, which does not belong to the space) and
which are frequently bounded below (otherwise, the Limsup would morally be -∞, which is not in the
space either). We start with definitions of these concepts for arbitrary filters, before turning to
the definitions of Limsup and Liminf.

In complete lattices, however, it coincides with the `Inf Sup` definition.

We use cLimsup in theorems in conditionally complete lattices, and Limsup for the corresponding
theorems in complete lattices (usually with less assumptions).

-/

import order.filter order.conditionally_complete_lattice order.bounds
open lattice filter set

variables {α : Type*} {β : Type*}
namespace filter

section relation

/-- `f.is_bounded (≺)`: the filter `f` is eventually bounded w.r.t. the relation `≺`, i.e.
eventually, it is bounded by some uniform bound.
`r` will be usually instantiated with `≤` or `≥`. -/
def is_bounded (r : α → α → Prop) (f : filter α) := ∃b, {x | r x b} ∈ f.sets

def is_bounded_under (r : α → α → Prop) (f : filter β) (u : β → α) := (f.map u).is_bounded r

variables {r : α → α → Prop} {f g : filter α}

/-- `f` is eventually bounded if and only if, there exists an admissible set on which it is
bounded. -/
lemma is_bounded_iff : f.is_bounded r ↔ (∃s∈f.sets, ∃b, s ⊆ {x | r x b}) :=
iff.intro
  (assume ⟨b, hb⟩, ⟨{a | r a b}, hb, b, subset.refl _⟩)
  (assume ⟨s, hs, b, hb⟩, ⟨b, mem_sets_of_superset hs hb⟩)

/-- A bounded function `u` is in particular eventually bounded. -/
lemma is_bounded_under_of {f : filter β} {u : β → α} :
  (∃b, ∀x, r (u x) b) → f.is_bounded_under r u
| ⟨b, hb⟩ := ⟨b, show {x | r (u x) b} ∈ f.sets, from univ_mem_sets' hb⟩

lemma is_bounded_bot : is_bounded r ⊥ ↔ nonempty α :=
by simp [is_bounded, exists_true_iff_nonempty]

lemma is_bounded_top : is_bounded r ⊤ ↔ (∃t, ∀x, r x t) :=
by simp [is_bounded, eq_univ_iff_forall]

lemma is_bounded_principal (s : set α) : is_bounded r (principal s) ↔ (∃t, ∀x∈s, r x t) :=
by simp [is_bounded, subset_def]

lemma is_bounded_sup [is_trans α r] (hr : ∀b₁ b₂, ∃b, r b₁ b ∧ r b₂ b) :
  is_bounded r f → is_bounded r g → is_bounded r (f ⊔ g)
| ⟨b₁, h₁⟩ ⟨b₂, h₂⟩ := let ⟨b, rb₁b, rb₂b⟩ := hr b₁ b₂ in
  ⟨b, mem_sup_sets.2 ⟨
    mem_sets_of_superset h₁ $ assume x rxb₁, show r x b, from trans rxb₁ rb₁b,
    mem_sets_of_superset h₂ $ assume x rxb₂, show r x b, from trans rxb₂ rb₂b⟩⟩

lemma is_bounded_of_le (h : f ≤ g) : is_bounded r g → is_bounded r f
| ⟨b, hb⟩ := ⟨b, h hb⟩

lemma is_bounded_under_of_is_bounded {q : β → β → Prop} {u : α → β}
  (hf : ∀a₀ a₁, r a₀ a₁ → q (u a₀) (u a₁)) : f.is_bounded r → f.is_bounded_under q u
| ⟨b, h⟩ := ⟨u b, show {x : α | q (u x) (u b)} ∈ f.sets, from mem_sets_of_superset h $ assume a, hf _ _⟩

/-- `is_cobounded (≺) f` states that filter `f` is not tend to infinite w.r.t. `≺`. This is also
called frequently bounded. Will be usually instantiated with `≤` or `≥`.

There is a subtlety in this definition: we want `f.is_cobounded` to hold for any `f` in the case of
complete lattices. This will be relevant to deduce theorems on complete lattices from their
versions on conditionally complete lattices with additional assumptions. We have to be careful in
the edge case of the trivial filter containing the empty set: the other natural definition
  `¬ ∀a, {n | a ≤ n} ∈ f.sets`
would not work as well in this case.
-/
def is_cobounded (r : α → α → Prop) (f : filter α) := ∃b, ∀a, {x | r x a} ∈ f.sets → r b a

def is_cobounded_under (r : α → α → Prop) (f : filter β) (u : β → α) := (f.map u).is_cobounded r

/-- To check that a filter is frequently bounded, it suffices to have a witness
which bounds `f` at some point for every admissible set.

This is only an implication, as the other direction is wrong for the trivial filter.-/
lemma is_cobounded.mk [is_trans α r] (a : α) (h : ∀s∈f.sets, ∃x∈s, r a x) : f.is_cobounded r :=
⟨a, assume y s, let ⟨x, h₁, h₂⟩ := h _ s in trans h₂ h₁⟩

/-- A filter which is eventually bounded is in particular frequently bounded (in the opposite
direction). At least if the filter is not trivial. -/
lemma is_cobounded_of_is_bounded [is_trans α r] (hf : f ≠ ⊥) :
  f.is_bounded r → f.is_cobounded (flip r)
| ⟨a, ha⟩ := ⟨a, assume b hb,
  have {x : α | r x a ∧ r b x} ∈ f.sets, from inter_mem_sets ha hb,
  let ⟨x, rxa, rbx⟩ := inhabited_of_mem_sets hf this in
  show r b a, from trans rbx rxa⟩

lemma is_cobounded_bot : is_cobounded r ⊥ ↔ (∃b, ∀x, r b x) :=
by simp [is_cobounded]

lemma is_cobounded_top : is_cobounded r ⊤ ↔ nonempty α :=
by simp [is_cobounded, eq_univ_iff_forall, exists_true_iff_nonempty] {contextual := tt}

lemma is_cobounded_principal (s : set α) :
  (principal s).is_cobounded r↔ (∃b, ∀a, (∀x∈s, r x a) → r b a) :=
by simp [is_cobounded, subset_def]

lemma is_cobounded_of_le (h : f ≤ g) : f.is_cobounded r → g.is_cobounded r
| ⟨b, hb⟩ := ⟨b, assume a ha, hb a (h ha)⟩

end relation

instance is_trans_le [preorder α] : is_trans α (≤) := ⟨assume a b c, le_trans⟩
instance is_trans_ge [preorder α] : is_trans α (≥) := ⟨assume a b c h₁ h₂, le_trans h₂ h₁⟩

lemma is_cobounded_le_of_bot [order_bot α] {f : filter α} : f.is_cobounded (≤) :=
⟨⊥, assume a h, bot_le⟩
lemma is_cobounded_ge_of_top [order_top α] {f : filter α} : f.is_cobounded (≥) :=
⟨⊤, assume a h, le_top⟩
lemma is_bounded_le_of_top [order_top α] {f : filter α} : f.is_bounded (≤) :=
⟨⊤, univ_mem_sets' $ assume a, le_top⟩
lemma is_bounded_ge_of_bot [order_bot α] {f : filter α} : f.is_bounded (≥) :=
⟨⊥, univ_mem_sets' $ assume a, bot_le⟩

lemma is_bounded_under_sup [semilattice_sup α] {f : filter β} {u v : β → α} :
  f.is_bounded_under (≤) u → f.is_bounded_under (≤) v → f.is_bounded_under (≤) (λa, u a ⊔ v a)
| ⟨bu, (hu : {x | u x ≤ bu} ∈ f.sets)⟩ ⟨bv, (hv : {x | v x ≤ bv} ∈ f.sets)⟩ :=
  ⟨bu ⊔ bv, show {x | u x ⊔ v x ≤ bu ⊔ bv} ∈ f.sets,
    by filter_upwards [hu, hv] assume x, sup_le_sup⟩

lemma is_bounded_under_inf [semilattice_inf α] {f : filter β} {u v : β → α} :
  f.is_bounded_under (≥) u → f.is_bounded_under (≥) v → f.is_bounded_under (≥) (λa, u a ⊓ v a)
| ⟨bu, (hu : {x | u x ≥ bu} ∈ f.sets)⟩ ⟨bv, (hv : {x | v x ≥ bv} ∈ f.sets)⟩ :=
  ⟨bu ⊓ bv, show {x | u x ⊓ v x ≥ bu ⊓ bv} ∈ f.sets,
    by filter_upwards [hu, hv] assume x, inf_le_inf⟩

meta def is_bounded_default : tactic unit :=
tactic.applyc ``is_cobounded_le_of_bot <|>
tactic.applyc ``is_cobounded_ge_of_top <|>
tactic.applyc ``is_bounded_le_of_top <|>
tactic.applyc ``is_bounded_ge_of_bot

section conditionally_complete_lattice
variables [conditionally_complete_lattice α]

def Limsup (f : filter α) : α := Inf {a | {n | n ≤ a} ∈ f.sets}
def Liminf (f : filter α) : α := Sup {a | {n | a ≤ n} ∈ f.sets}

def limsup (f : filter β) (u : β → α) : α := (f.map u).Limsup
def liminf (f : filter β) (u : β → α) : α := (f.map u).Liminf

section
variables {f : filter β} {u : β → α}
theorem limsup_eq : f.limsup u = Inf {a:α | {n | u n ≤ a} ∈ f.sets} := rfl
theorem liminf_eq : f.liminf u = Sup {a:α | {n | a ≤ u n} ∈ f.sets} := rfl
end

theorem Limsup_le_of_le {f : filter α} {a} :
  f.is_cobounded (≤) → {n | n ≤ a} ∈ f.sets → f.Limsup ≤ a := cInf_le
theorem le_Liminf_of_le {f : filter α} {a} :
   f.is_cobounded (≥) → {n | a ≤ n} ∈ f.sets → a ≤ f.Liminf := le_cSup

theorem le_Limsup_of_le {f : filter α} {a}
  (hf : f.is_bounded (≤)) (h : ∀b, {n : α | n ≤ b} ∈ f.sets → a ≤ b) : a ≤ f.Limsup :=
le_cInf (ne_empty_iff_exists_mem.2 hf) h

theorem Liminf_le_of_le {f : filter α} {a}
  (hf : f.is_bounded (≥)) (h : ∀b, {n : α | b ≤ n} ∈ f.sets → b ≤ a) : f.Liminf ≤ a :=
cSup_le (ne_empty_iff_exists_mem.2 hf) h

theorem Liminf_le_Limsup {f : filter α}
  (hf : f ≠ ⊥) (h₁ : f.is_bounded (≤)) (h₂ : f.is_bounded (≥)) : f.Liminf ≤ f.Limsup :=
Liminf_le_of_le h₂ $ assume a₀ ha₀, le_Limsup_of_le h₁ $ assume a₁ ha₁, show a₀ ≤ a₁, from
  have {b | a₀ ≤ b ∧ b ≤ a₁} ∈ f.sets, from inter_mem_sets ha₀ ha₁,
  let ⟨b, hb₀, hb₁⟩ := inhabited_of_mem_sets hf this in
  le_trans hb₀ hb₁

lemma Liminf_le_Liminf {f g : filter α}
  (hf : f.is_bounded (≥) . is_bounded_default) (hg : g.is_cobounded (≥) . is_bounded_default)
  (h : ∀a, {n : α | a ≤ n} ∈ f.sets → {n : α | a ≤ n} ∈ g.sets) : f.Liminf ≤ g.Liminf :=
let ⟨a, ha⟩ := hf in cSup_le_cSup hg (ne_empty_of_mem ha) h

lemma Limsup_le_Limsup {f g : filter α}
  (hf : f.is_cobounded (≤) . is_bounded_default) (hg : g.is_bounded (≤) . is_bounded_default)
  (h : ∀a, {n : α | n ≤ a} ∈ g.sets → {n : α | n ≤ a} ∈ f.sets) : f.Limsup ≤ g.Limsup :=
let ⟨a, ha⟩ := hg in cInf_le_cInf hf (ne_empty_of_mem ha) h

lemma Limsup_le_Limsup_of_le {f g : filter α} (h : f ≤ g)
  (hf : f.is_cobounded (≤) . is_bounded_default) (hg : g.is_bounded (≤) . is_bounded_default) :
  f.Limsup ≤ g.Limsup :=
Limsup_le_Limsup hf hg (assume a ha, h ha)

lemma Liminf_le_Liminf_of_le {f g : filter α} (h : g ≤ f)
  (hf : f.is_bounded (≥) . is_bounded_default) (hg : g.is_cobounded (≥) . is_bounded_default) :
  f.Liminf ≤ g.Liminf :=
Liminf_le_Liminf hf hg (assume a ha, h ha)

lemma limsup_le_limsup [conditionally_complete_lattice β] {f : filter α} {u v : α → β}
  (h : {a | u a ≤ v a} ∈ f.sets)
  (hu : f.is_cobounded_under (≤) u . is_bounded_default)
  (hv : f.is_bounded_under (≤) v . is_bounded_default) :
  f.limsup u ≤ f.limsup v :=
Limsup_le_Limsup hu hv $ assume b (hb : {a | v a ≤ b} ∈ f.sets), show {a | u a ≤ b} ∈ f.sets,
  by filter_upwards [h, hb] assume a, le_trans

lemma liminf_le_liminf [conditionally_complete_lattice β] {f : filter α} {u v : α → β}
  (h : {a | u a ≤ v a} ∈ f.sets)
  (hu : f.is_bounded_under (≥) u . is_bounded_default)
  (hv : f.is_cobounded_under (≥) v . is_bounded_default) :
  f.liminf u ≤ f.liminf v :=
Liminf_le_Liminf hu hv $ assume b (hb : {a | b ≤ u a} ∈ f.sets), show {a | b ≤ v a} ∈ f.sets,
  by filter_upwards [hb, h] assume a, le_trans

theorem Limsup_principal {s : set α} (h : bdd_above s) (hs : s ≠ ∅) :
  (principal s).Limsup = Sup s :=
by simp [Limsup]; exact cInf_lower_bounds_eq_cSup h hs

theorem Liminf_principal {s : set α} (h : bdd_below s) (hs : s ≠ ∅) :
  (principal s).Liminf = Inf s :=
by simp [Liminf]; exact cSup_upper_bounds_eq_cInf h hs

end conditionally_complete_lattice

section complete_lattice
variables [complete_lattice α]

@[simp] theorem Limsup_bot : (⊥ : filter α).Limsup = ⊥ :=
bot_unique $ Inf_le $ by simp

@[simp] theorem Liminf_bot : (⊥ : filter α).Liminf = ⊤ :=
top_unique $ le_Sup $ by simp

@[simp] theorem Limsup_top : (⊤ : filter α).Limsup = ⊤ :=
top_unique $ le_Inf $
  by simp [eq_univ_iff_forall]; exact assume b hb, (top_unique $ hb _)

@[simp] theorem Liminf_top : (⊤ : filter α).Liminf = ⊥ :=
bot_unique $ Sup_le $
  by simp [eq_univ_iff_forall]; exact assume b hb, (bot_unique $ hb _)

theorem Limsup_eq_infi_Sup {f : filter α} : f.Limsup = ⨅s∈f.sets, Sup s :=
le_antisymm
  (le_infi $ assume s, le_infi $ assume hs, Inf_le $ show {n : α | n ≤ Sup s} ∈ f.sets,
    by filter_upwards [hs] assume a, le_Sup)
  (le_Inf $ assume a (ha : {n : α | n ≤ a} ∈ f.sets),
    infi_le_of_le _ $ infi_le_of_le ha $ Sup_le $ assume b, id)

/-- In a complete lattice, the limsup of a function is the infimum over sets `s` in the filter
of the supremum of the function over `s` -/
theorem limsup_eq_infi_supr {f : filter β} {u : β → α} : f.limsup u = ⨅s∈f.sets, ⨆a∈s, u a :=
calc f.limsup u = ⨅s∈(f.map u).sets, Sup s : Limsup_eq_infi_Sup
  ... = ⨅s∈f.sets, ⨆a∈s, u a :
    le_antisymm
      (le_infi $ assume s, le_infi $ assume hs,
        infi_le_of_le (u '' s) $ infi_le_of_le (image_mem_map hs) $ le_of_eq Sup_image)
      (le_infi $ assume s, le_infi $ assume (hs : u ⁻¹' s ∈ f.sets),
        infi_le_of_le _ $ infi_le_of_le hs $ supr_le $ assume a, supr_le $ assume ha, le_Sup ha)

theorem Liminf_eq_supr_Inf {f : filter α} : f.Liminf = ⨆s∈f.sets, Inf s :=
le_antisymm
  (Sup_le $ assume a (ha : {n : α | a ≤ n} ∈ f.sets),
    le_supr_of_le _ $ le_supr_of_le ha $ le_Inf $ assume b, id)
  (supr_le $ assume s, supr_le $ assume hs, le_Sup $ show {n : α | Inf s ≤ n} ∈ f.sets,
    by filter_upwards [hs] assume a, Inf_le)

/-- In a complete lattice, the liminf of a function is the infimum over sets `s` in the filter
of the supremum of the function over `s` -/
theorem liminf_eq_supr_infi {f : filter β} {u : β → α} : f.liminf u = ⨆s∈f.sets, ⨅a∈s, u a :=
calc f.liminf u = ⨆s∈(f.map u).sets, Inf s : Liminf_eq_supr_Inf
  ... = ⨆s∈f.sets, ⨅a∈s, u a :
    le_antisymm
      (supr_le $ assume s, supr_le $ assume (hs : u ⁻¹' s ∈ f.sets),
        le_supr_of_le _ $ le_supr_of_le hs $ le_infi $ assume a, le_infi $ assume ha, Inf_le ha)
      (supr_le $ assume s, supr_le $ assume hs,
        le_supr_of_le (u '' s) $ le_supr_of_le (image_mem_map hs) $ ge_of_eq Inf_image)

end complete_lattice

end filter


import game.max.level03 -- hide

open_locale classical -- hide

noncomputable theory -- hide

namespace xena -- hide

/-
# Chapter 4 : Max and abs

## Level 4

`le_max_right` is the statement that `b ≤ max a b`. There's a short
proof using what we've already done.
-/

/- Hint :
Why not start with `rw max_comm`?
-/

/- Lemma
For any real numbers $a$ and $b$, we have $b\leq\max(a,b).$
-/

theorem le_max_right (a b : ℝ) : b ≤ max a b :=
begin
  rw max_comm,
  apply le_max_left,
end

end xena --hide


lemma one_pow (m : mynat) : (1 : mynat) ^ m = 1 :=
begin
induction m with k Pk,
exact pow_zero 1,
rw pow_succ,
rw Pk,
exact one_mul 1,
end


import data.finset
import data.finsupp
import algebra.big_operators.order

namespace finset

section to_list

variables {α : Type*} {β : Type*} {γ : Type*}
/-- Produce a list of the elements in the finite set using choice. -/
@[reducible] noncomputable def to_list (s : finset α) : list α := s.1.to_list

lemma nodup_to_list (s : finset α) : s.to_list.nodup :=
by { rw [to_list, ←multiset.coe_nodup, multiset.coe_to_list], exact s.nodup }

@[simp] lemma mem_to_list {a : α} (s : finset α) : a ∈ s.to_list ↔ a ∈ s :=
by { rw [to_list, ←multiset.mem_coe, multiset.coe_to_list], exact iff.rfl }

@[simp] lemma length_to_list (s : finset α) : s.to_list.length = s.card :=
by { rw [to_list, ←multiset.coe_card, multiset.coe_to_list], refl }

@[simp] lemma to_list_empty : (∅ : finset α).to_list = [] :=
by simp [to_list]

@[simp, norm_cast]
lemma coe_to_list (s : finset α) : (s.to_list : multiset α) = s.val :=
by { classical, ext, simp }

@[simp] lemma to_list_to_finset [decidable_eq α] (s : finset α) : s.to_list.to_finset = s :=
by { ext, simp }

@[to_additive] lemma prod_to_list [comm_monoid β]
  (s : finset α) (f : α → β) :
  (list.map f s.to_list).prod = finset.prod s f :=
begin
  delta finset.prod,
  rw [← multiset.coe_prod, ← multiset.coe_map, finset.coe_to_list],
end

lemma to_list_cons {a : α} {s : finset α} (h : a ∉ s) : (cons a s h).to_list ~ a :: s.to_list :=
(list.perm_ext (nodup_to_list _) (by simp [h, nodup_to_list s])).2 $
  λ x, by simp only [list.mem_cons_iff, finset.mem_to_list, finset.mem_cons]

lemma to_list_insert [decidable_eq α] {a : α} {s : finset α} (h : a ∉ s) :
  (insert a s).to_list ~ a :: s.to_list :=
cons_eq_insert _ _ h ▸ to_list_cons _

end to_list

lemma filter_mem_set_of_subset_set {α} {s : set α} [decidable_pred (λ x, x ∈ s)]
  {fs : finset α} (h : ↑fs ⊆ s) :
  filter (λ x, x ∈ s) fs = fs :=
begin
  ext x,
  split,
  { apply filter_subset },
  { intro hmem, rw mem_filter, exact ⟨ hmem , h hmem ⟩ },
end

end finset

namespace finsupp

lemma le_sum {σ : Type*}
  (f : σ →₀ ℕ) (x : σ) :
  f x ≤ f.support.sum f :=
dite (f x = 0)
(λ h, by simp [h])
(λ h, finset.single_le_sum (λ s hs, nat.zero_le _) (finsupp.mem_support_iff.2 h))

end finsupp