import tactic.find data.nat.prime algebra.group_power tactic.ring data.set.finite .disjoint_finset data.int.modeq
universes u v
variables {α : Type u} {β : Type v}

open nat finset equiv int.modeq nat int

local attribute [instance, priority 0] classical.prop_decidable

lemma int.mod_two_eq_zero_or_one (n : ℤ) : n % 2 = 0 ∨ n % 2 = 1 :=
have h : n % 2 < 2 := abs_of_nonneg (show (2 : ℤ) ≥ 0, from dec_trivial) ▸ int.mod_lt _ dec_trivial,
have h₁ : n % 2 ≥ 0 := int.mod_nonneg _ dec_trivial,
match (n % 2), h, h₁ with
| (0 : ℕ) := λ _ _, or.inl rfl
| (1 : ℕ) := λ _ _, or.inr rfl
| (k + 2 : ℕ) := λ h _, absurd h dec_trivial
| -[1+ a] := λ _ h₁, absurd h₁ dec_trivial
end

lemma nat.sub_le_self (a b : ℕ) : a - b ≤ a := nat.sub_le_sub_left _ (zero_le _)

lemma nat.div_mul_le (a) {b} (hb : 0 < b) : a / b * b ≤ a :=
have h : 0 + a / b * b ≤ a % b + a / b * b := add_le_add (zero_le _) (le_refl _),
by rwa [zero_add, mul_comm, nat.mod_add_div, mul_comm] at h

@[simp] lemma nat.mod_mod (n m : ℕ) : n % m % m = n % m :=
nat.cases_on m (by simp) (λ m, mod_eq_of_lt (mod_lt _ (succ_pos _)))

lemma int.coe_nat_nonneg (n : ℕ) : (0 : ℤ) ≤ n := int.coe_nat_le.2 (zero_le _)

lemma nat.mul_pow (a b n : ℕ) : (a * b) ^ n = a ^ n * b ^ n :=
by induction n; simp [*, nat.pow_succ, mul_comm, mul_assoc, mul_left_comm]

lemma nat.dvd_of_pow_dvd_pow : ∀ {a b n : ℕ}, 0 < n → a ^ n ∣ b ^ n → a ∣ b
| a 0     := λ n hn h, dvd_zero _
| a (b+1) := λ n hn h,
let d := nat.gcd a (b + 1) in
have hd : nat.gcd a (b + 1) = d := rfl,
match d, hd with
| 0 := λ hd, (eq_zero_of_gcd_eq_zero_right hd).symm ▸ dvd_zero _
| 1 := λ hd, begin
  have h₁ := coprime.eq_one_of_dvd (coprime.pow n n hd) h,
  have := pow_dvd_pow a hn,
  rw [nat.pow_one, h₁] at this,
  exact dvd.trans this (one_dvd _),
end
| (d+2) := λ hd,
have (b+1) / (d+2) < (b+1) := div_lt_self dec_trivial dec_trivial,
have ha : a = (d+2) * (a / (d+2)) :=
  by rw [← hd, nat.mul_div_cancel' (gcd_dvd_left _ _)],
have hb : (b+1) = (d+2) * ((b+1) / (d+2)) :=
  by rw [← hd, nat.mul_div_cancel' (gcd_dvd_right _ _)],
have a / (d+2) ∣ (b+1) / (d+2) := nat.dvd_of_pow_dvd_pow hn $ dvd_of_mul_dvd_mul_left
  (show (d + 2) ^ n > 0, from pos_pow_of_pos _ (dec_trivial))
  (by rwa [← nat.mul_pow, ← nat.mul_pow, ← ha, ← hb]),
by rw [ha, hb];
  exact mul_dvd_mul_left _ this
end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf psigma.snd⟩]}

@[simp] lemma int.mod_mod (a b : ℤ) : a % b % b = a % b :=
or.cases_on (classical.em (b = 0)) (by simp {contextual := tt})
(λ h, int.mod_abs (a % b) b ▸ int.mod_eq_of_lt (int.mod_nonneg _ h) (int.mod_lt _ h))

lemma nat.pow_two (n : ℕ) : n ^ 2 = n * n := by simp [nat.pow_succ, nat.pow_zero]

lemma nat.cast_div [division_ring α] [char_zero α] {n m : ℕ} (h : n ∣ m) (hn : n ≠ 0) :
    ((m / n : ℕ) : α) = (m : α) / n :=
eq.symm ((div_eq_iff_mul_eq (by rwa nat.cast_ne_zero)).2 (by rw [← nat.cast_mul, nat.div_mul_cancel h]))

lemma nat.cast_div_le [linear_ordered_field α] {n m : ℕ} (hm : 0 < m) : ((n / m : ℕ) : α) ≤ (n / m : α) :=
le_of_mul_le_mul_right
(calc ((n / m : ℕ) : α) * m ≤ n : by rw [← nat.cast_mul, nat.cast_le]; exact nat.div_mul_le _ hm
  ... =  (n / m : α) * m : (div_mul_cancel (n : α) (ne_of_lt (nat.cast_lt.2 hm)).symm).symm)
(nat.cast_lt.2 hm)

lemma nat.prime.eq_two_or_odd {p : ℕ} (hp : prime p) : p = 2 ∨ p % 2 = 1 :=
or.cases_on (nat.mod_two_eq_zero_or_one p)
  (λ h, or.inl (or.resolve_left (hp.2 _ (nat.dvd_of_mod_eq_zero h)) dec_trivial).symm)
  or.inr

lemma nat.prime.odd_iff_ge_three {p : ℕ} (hp : prime p) : p % 2 = 1 ↔ 3 ≤ p :=
⟨λ hpo, succ_le_of_lt (lt_of_le_of_ne hp.1 (λ h, by rw ← h at hpo; exact absurd hpo dec_trivial)),
λ hp3, or.cases_on (mod_two_eq_zero_or_one p)
  (λ h, or.cases_on (hp.2 _ (nat.dvd_of_mod_eq_zero h)) (λ h2, absurd h2 dec_trivial)
    (λ h1, by rw ← h1 at hp3; exact absurd hp3 dec_trivial)) id⟩

lemma int.cast_div [division_ring α] [char_zero α] {i j : ℤ} (h : j ∣ i) (hj : j ≠ 0) :
  ((i / j : ℤ) : α) = (i : α) / j :=
eq.symm ((div_eq_iff_mul_eq (by rwa int.cast_ne_zero)).2 (by rw [← int.cast_mul, int.div_mul_cancel h]))

lemma int.coe_nat_div (a b : ℕ) : ((a / b : ℕ) : ℤ) = (a : ℤ) / b := rfl

lemma int.add_div {i j : ℤ} (k : ℤ) (h : j ∣ i) (hk : j ≠ 0) :
  i / j + k / j = (i + k) / j :=
(domain.mul_left_inj hk).1
(let ⟨m, hm⟩ := exists_eq_mul_left_of_dvd h in
by rw [hm, mul_add, add_comm _ k, int.add_mul_div_right _ _ hk,
    int.mul_div_cancel _ hk, mul_add, add_comm])

lemma mul_self_mod_injective_of_le_half_prime {p : ℕ} (hp : prime p) (hpo : p % 2 = 1) : function.injective
  (λ a : fin (succ (p / 2)), (a.1 : ℕ) * a.1 % p) := λ a b (h : a.1 * a.1 ≡ b.1 * b.1 [MOD p]),
begin
  wlog h : a.1 ≤ b.1 using a b,
  { exact (this h.symm).symm },
  { have : ∀ i j : ℤ, i * i - j * j = (i - j) * (i + j) := λ i j, by ring,
    have h₃ : p ∣ b.val - a.val ∨ p ∣ b.val + a.val := by
      rwa [nat.modeq.modeq_iff_dvd, int.coe_nat_mul, int.coe_nat_mul, this, ← int.coe_nat_sub h_1,
        ← int.coe_nat_add, ← int.coe_nat_mul, int.coe_nat_dvd, hp.dvd_mul] at h,
    by_contra hab,
    have hab' := fin.vne_of_ne hab,
    cases h₃ with h₃ h₃,
    { have : p ≤ b.1 - a.1 := le_of_dvd (nat.pos_of_ne_zero (λ h₂, hab'
        (le_antisymm h_1 (nat.sub_eq_zero_iff_le.1 h₂)))) h₃,
      have : p < p :=
        calc p ≤ b.1 - a.1 : this
           ... ≤ b.1   : nat.sub_le_sub_left _ (zero_le _)
           ... ≤ p / 2 : le_of_lt_succ b.2
           ... < p     : nat.div_lt_self hp.pos (lt_succ_self _),
      exact lt_irrefl _ this },
    { have : 0 < b.1 + a.1,
      { cases a.1,
        exact nat.pos_of_ne_zero hab'.symm,
        exact succ_pos _ },
      have : p ≤ b.1 + a.1 := le_of_dvd this h₃,
      have : p < p :=
        calc p ≤ b.1 + a.1 : this
          ... ≤ p / 2 + p / 2 : add_le_add (le_of_lt_succ b.2) (le_of_lt_succ a.2)
          ... < p : by conv {to_rhs, rw [← nat.mod_add_div p 2, hpo, add_comm, two_mul]};
            exact lt_succ_self _,
      exact lt_irrefl _ this } }
end

lemma neg_mul_self_mod_add_one_injective_of_le_half_prime {p : ℕ} (hp : prime p) (hpo : p % 2 = 1) :
  function.injective (λ a : fin (succ (p / 2)), ((-(((a.1 : ℕ) * a.1) + 1 : ℕ) : ℤ) % p).to_nat) :=
λ ⟨x, hx⟩ ⟨y, hy⟩ (hxy : int.to_nat _ = int.to_nat _),
have hp0 : (p : ℤ) ≠ 0 := λ (h : (p : ℤ) = (0 : ℕ)),
    by have := hp.pos; rw int.coe_nat_inj h at this; exact lt_irrefl _ this,
begin
  rw [← int.coe_nat_eq_coe_nat_iff, int.to_nat_of_nonneg (int.mod_nonneg _ hp0),
      int.to_nat_of_nonneg (int.mod_nonneg _ hp0)] at hxy,
  have := int.dvd_of_mod_eq_zero (int.mod_eq_mod_iff_mod_sub_eq_zero.1 hxy),
  rw [sub_neg_eq_add, add_comm, ← sub_eq_add_neg] at this,
  exact mul_self_mod_injective_of_le_half_prime hp hpo
    (nat.modeq.modeq_add_cancel_right rfl (nat.modeq.modeq_iff_dvd.2 this)),
end

lemma modeq_two_square_self (a : ℤ) : a * a ≡ a [ZMOD 2] :=
or.cases_on (int.mod_two_eq_zero_or_one a)
  (λ h, have h' : a ≡ 0 [ZMOD 2] := h,
    ((show a * a ≡ 0 * 0 [ZMOD 2], from modeq_mul h' h').trans h'.symm))
  (λ h, @eq.subst _ (λ b, a * a ≡ b [ZMOD 2]) _ _ (mul_one a)
    (int.modeq.modeq_mul rfl h))

lemma sum_two_squares_of_sum_two_squares_two_mul {n a b : ℤ} (h : a * a + b * b = 2 * n) :
    ∃ c d : ℤ, c * c + d * d = n :=
have hs : a * a + b * b ≡ 0 [ZMOD 2] := int.modeq.modeq_zero_iff.2 (h.symm ▸ dvd_mul_right _ _),
have hadd : (2 : ℤ) ∣ a + b := int.modeq.modeq_zero_iff.1 (int.modeq.trans
    (int.modeq.modeq_add (modeq_two_square_self _).symm (modeq_two_square_self _).symm) hs),
have hsub : (2 : ℤ) ∣ a - b :=
begin
  have : a - b = (a + b) + 2 * -b := by ring,
  rw this,
  exact dvd_add hadd (dvd_mul_right _ _),
end,
have h2 : (2 : ℤ) ≠ 0 := by norm_num,
⟨(a + b) / 2, (a - b) / 2,
  (domain.mul_left_inj h2).1
    (calc 2 * (((a + b) / 2) * ((a + b) / 2) + (a - b) / 2 * ((a - b) / 2))
        = (a + b) * ((a + b) / 2) + (a - b) * ((a - b) / 2) :
          by rw [mul_add (2 : ℤ), ← mul_assoc, ← mul_assoc, int.mul_div_cancel' hadd,
           int.mul_div_cancel' hsub]
    ... = a * a + b * b :
      (domain.mul_right_inj h2).1
        (by simp only [add_mul, mul_assoc _ _ (2 : ℤ), int.div_mul_cancel hadd,
              int.div_mul_cancel hsub]; ring)
    ... = 2 * n : h ▸ by simp [nat.pow_succ, int.coe_nat_mul, int.coe_nat_add])⟩

open finset function

lemma surjective_of_injective_of_equiv [fintype α] {f : α → β} (e : α ≃ β)
    (hinj : injective f) : surjective f :=
by haveI : fintype β := fintype.of_equiv _ e; exact
λ x, have h₁ : image f univ = univ := eq_of_subset_of_card_le (subset_univ _)
  ((card_image_of_injective univ hinj).symm ▸ show fintype.card β ≤ fintype.card α,
    from fintype.card_congr e ▸ le_refl _),
have h₂ : x ∈ image f univ := h₁.symm ▸ mem_univ _,
exists_of_bex (mem_image.1 h₂)

lemma injective_of_surjective_of_equiv [fintype α] {f : α → β} (e : α ≃ β)
    (hsurj : surjective f) : injective f :=
by haveI : fintype β := fintype.of_equiv _ e; exact
injective_of_has_left_inverse ⟨surj_inv hsurj,
  left_inverse_of_surjective_of_right_inverse (surjective_of_injective_of_equiv
    e.symm (injective_surj_inv hsurj)) (right_inverse_surj_inv hsurj)⟩

lemma bla12 {p : ℕ} (hp : prime p) (hpo : p % 2 = 1) :
  ∃ a b : fin (succ (p / 2)), p ∣ a.1 * a.1 + b.1 * b.1 + 1 :=
have hp0 : (p : ℤ) ≠ 0 := (ne_of_lt (int.coe_nat_lt.2 hp.pos)).symm,
let s := image (λ a : fin (succ (p / 2)), a.val * a.val % p) univ in
let t := image (λ a : fin (succ (p / 2)),
  to_nat (-↑(a.val * a.val + 1) % ↑p)) univ in
have hs : card s = fintype.card _ := card_image_of_injective
  univ (mul_self_mod_injective_of_le_half_prime hp hpo),
have ht : card t = fintype.card _:= card_image_of_injective
  univ (neg_mul_self_mod_add_one_injective_of_le_half_prime hp hpo),
have hsp : s ⊆ range p :=
  λ x hx, let ⟨y, hy₁, hy₂⟩ := mem_image.1 hx in
  hy₂ ▸ mem_range.2 (mod_lt _ hp.pos),
have htp : t ⊆ range p :=
  λ x hx, let ⟨y, hy₁, hy₂⟩ := mem_image.1 hx in
  hy₂ ▸ mem_range.2 (int.coe_nat_lt.1 (by rw int.to_nat_of_nonneg (int.mod_nonneg _ hp0);
    exact int.mod_lt_of_pos _ (int.coe_nat_lt.2 hp.pos))),
have hd : ¬ finset.disjoint s t := λ h, begin
  have := card_le_of_subset (union_subset hsp htp),
  rw fintype.card_fin at hs ht,
  rw [card_disjoint_union h, hs, ht, card_range, ← two_mul, ← one_add, mul_add] at this,
  conv at this { to_rhs, rw [← nat.mod_add_div p 2] },
  exact not_lt_of_ge (le_of_add_le_add_right this) (mod_lt _ (succ_pos _)),
end,
let ⟨n, hn⟩ := classical.not_forall.1 hd in
begin
  rw [not_imp, not_imp] at hn,
  rcases (mem_image.1 hn.1  ) with ⟨a, _, ha⟩,
  rcases (mem_image.1 hn.2.1) with ⟨b, _, hb⟩,
  existsi [a, b],
  rw [← int.coe_nat_dvd, add_assoc, int.coe_nat_add, ← sub_neg_eq_add,
      int.dvd_iff_mod_eq_zero, ← int.mod_eq_mod_iff_mod_sub_eq_zero, ← int.coe_nat_mod,
      ← int.to_nat_of_nonneg (int.mod_nonneg _ hp0), hb, ha]
end

private def mod_sub_half (n m : ℤ) : ℤ := if ((n % m : ℤ) : ℚ) ≤ m / 2 then (n : ℤ) % m else n % m - m

private lemma mod_sub_half_modeq {n m : ℤ} (hm : 0 < m) : mod_sub_half n m ≡ n [ZMOD m] :=
or.cases_on (classical.em (((n % m : ℤ) : ℚ) ≤ m / 2)) (λ h, begin
  rw [mod_sub_half, if_pos h],
  exact int.mod_mod _ _,
end)
(λ h, begin
  rw [mod_sub_half, if_neg h],
  conv {to_rhs, skip, rw ← sub_zero (n : ℤ)},
  exact int.modeq.modeq_sub (int.mod_mod _ _) (int.modeq.modeq_zero_iff.2 (dvd_refl _)),
end)

private lemma mod_sub_half_square {n m : ℤ} (hm : 0 < m) : mod_sub_half n m * mod_sub_half n m ≡ n * n [ZMOD m] :=
int.modeq.modeq_mul (mod_sub_half_modeq hm) (mod_sub_half_modeq hm)

private lemma mod_sub_half_eq_zero {n m : ℤ} (hm : 0 < m) (h : mod_sub_half n m * mod_sub_half n m = 0) :
    n * n ≡ 0 [ZMOD (m * m)] :=
have h : _ := eq_zero_of_mul_self_eq_zero h,
modeq_zero_iff.2 (mul_dvd_mul
  (modeq_zero_iff.1 (h ▸ (mod_sub_half_modeq hm).symm))
  (modeq_zero_iff.1 (h ▸ (mod_sub_half_modeq hm).symm)))

private lemma mod_sub_half_le {n m : ℤ} (hm : 0 < m) : ((abs (mod_sub_half n m) : ℤ) : ℚ) ≤ m / 2 :=
have hm0 : (m : ℤ) ≠ 0 := (ne_of_lt hm).symm,
begin
  cases classical.em (((n % m : ℤ) : ℚ) ≤ m / 2) with h h,
  { rw [mod_sub_half, if_pos h,
      abs_of_nonneg (int.mod_nonneg (n : ℤ) hm0)],
    exact h },
  { have hmn : (n : ℤ) % m - m < 0 := sub_neg_of_lt (trans_rel_left _
      (int.mod_lt _ hm0) (abs_of_pos hm)),
    rw [mod_sub_half, if_neg h, abs_of_neg hmn, neg_sub, int.cast_sub,
      sub_le_iff_le_add, ← sub_le_iff_le_add', sub_half],
    exact le_of_lt (lt_of_not_ge h) }
end

private lemma mod_sub_half_square_le {n m : ℤ} (hm : 0 < m) :
  ((mod_sub_half n m * mod_sub_half n m : ℤ) : ℚ) ≤ ((m * m) / 4) :=
calc ((mod_sub_half n m * mod_sub_half n m : ℤ) : ℚ) =
  ((abs (mod_sub_half n m) : ℤ) : ℚ) * ((abs (mod_sub_half n m) : ℤ) : ℚ) :
          by rw [← int.cast_mul, ← abs_mul, abs_mul_self]
   ... ≤ (m / 2) * (m / 2) : mul_self_le_mul_self (int.cast_nonneg.2 (abs_nonneg _)) (mod_sub_half_le hm)
   ... = m * m / 4 : by rw [div_mul_div, (show (2 : ℚ) * 2 = 4, from rfl)]

private lemma mod_sub_half_lt_of_odd {n m : ℤ} (hm : 0 < m) (hmo : m % 2 = 1) :
  ((abs (mod_sub_half n m) : ℤ) : ℚ) < m / 2 :=
let h := (@int.cast_nonneg ℚ _ _).2 (abs_nonneg (mod_sub_half n m)) in
have h2 : (2 : ℚ) ≠ 0 := by norm_num,
lt_of_le_of_ne (mod_sub_half_le hm)
(λ h, begin
  rw [← domain.mul_left_inj h2, mul_div_cancel' _ h2, (show (2 : ℚ) = ((2 : ℤ) : ℚ), from rfl),
    ← int.cast_mul, int.cast_inj] at h,
  have h2m : 2 ∣ m := h ▸ dvd_mul_right _ _,
  exact absurd ((int.mod_eq_zero_of_dvd h2m).symm.trans hmo) dec_trivial
end)

lemma four_squares_mul_four_squares {α : Type*} [comm_ring α] (a b c d w x y z : α) :
  (a * a + b * b +  c * c + d * d)  * (w * w + x * x +  y * y + z * z)  =
  (a * x - w * b + (d * y - z * c)) * (a * x - w * b + (d * y - z * c)) +
  (a * y - w * c + (b * z - x * d)) * (a * y - w * c + (b * z - x * d)) +
  (a * z - w * d + (c * x - y * b)) * (a * z - w * d + (c * x - y * b)) +
  (a * w + b * x +  c * y + d * z)  * (a * w + b * x +  c * y + d * z)  :=
by ring

lemma dvd_mul_sub_add_mul_sub {m a b c d w x y z : ℤ}
  (haw : w ≡ a [ZMOD m]) (hbx : x ≡ b [ZMOD m])
  (hcy : y ≡ c [ZMOD m]) (hdz : z ≡ d [ZMOD m]) :
  m ∣ (a * x - w * b + (d * y - z * c)) :=
dvd_add (modeq_iff_dvd.1 (modeq_mul haw hbx.symm)) (modeq_iff_dvd.1 (modeq_mul hdz hcy.symm))

lemma int.even_add_even {a b : ℤ} (ha : a % 2 = 0) (hb : b % 2 = 0) : (a + b) % 2 = 0 :=
show a + b ≡ 0 + 0 [ZMOD 2], from int.modeq.modeq_add ha hb

lemma int.odd_add_odd {a b : ℤ} (ha : a % 2 = 1) (hb : b % 2 = 1) : (a + b) % 2 = 0 :=
show a + b ≡ 1 + 1 [ZMOD 2], from int.modeq.modeq_add ha hb

lemma even_sum_four_squares {n a b c d : ℤ}
  (H : a * a + b * b + c * c + d * d = 2 * n) :
  ∃ w x y z, w * w + x * x + y * y + z * z = 2 * n ∧
  w * w + x * x ≡ 0 [ZMOD 2] ∧ y * y + z * z ≡ 0 [ZMOD 2] :=
have h' : a * a + b * b + c * c + d * d ≡ 0 [ZMOD 2] :=
  modeq_zero_iff.2 (H.symm ▸ dvd_mul_right _ _),
or.cases_on (int.mod_two_eq_zero_or_one (a * a))
  (λ ha, or.cases_on (int.mod_two_eq_zero_or_one (b * b))
    (λ hb, ⟨a, b, c, d, H, int.even_add_even ha hb,
      modeq_add_cancel_left (show a * a + b * b ≡ 0 [ZMOD 2], from int.even_add_even ha hb)
        (int.modeq.trans (by simp) h')⟩)
    (λ hb, or.cases_on (int.mod_two_eq_zero_or_one (c * c))
      (λ hc, ⟨a, c, b, d, by simp [H.symm], int.even_add_even ha hc,
        modeq_add_cancel_left (show a * a + c * c ≡ 0 [ZMOD 2], from int.even_add_even ha hc)
          (int.modeq.trans (by simp) h')⟩)
      (λ hc, ⟨a, d, b, c, by simp [H.symm],
        modeq_add_cancel_left (show b * b + c * c ≡ 0 [ZMOD 2], from int.odd_add_odd hb hc)
          (int.modeq.trans (by simp) h'),
        int.odd_add_odd hb hc⟩)))
  (λ ha, or.cases_on (int.mod_two_eq_zero_or_one (b * b))
    (λ hb, or.cases_on (int.mod_two_eq_zero_or_one (c * c))
      (λ hc, ⟨b, c, a, d, by simp [H.symm], int.even_add_even hb hc,
        modeq_add_cancel_left (show b * b + c * c ≡ 0 [ZMOD 2], from int.even_add_even hb hc)
          (int.modeq.trans (by simp) h')⟩)
      (λ hc, ⟨a, c, b, d, by simp [H.symm], int.odd_add_odd ha hc,
        modeq_add_cancel_left (show a * a + c * c ≡ 0 [ZMOD 2], from int.odd_add_odd ha hc)
          (int.modeq.trans (by simp) h')⟩))
    (λ hb, ⟨a, b, c, d, by simp [H.symm], int.odd_add_odd ha hb,
      modeq_add_cancel_left (show a * a + b * b ≡ 0 [ZMOD 2], from int.odd_add_odd ha hb)
        (int.modeq.trans (by simp) h')⟩))

private lemma sum_four_squares_of_sum_four_squares_two_mul {n a b c d : ℤ}
  (h : a * a + b * b + c * c + d * d = 2 * n) :
  ∃ a' b' c' d', a' * a' + b' * b' + c' * c' + d' * d' = n :=
let ⟨a, b, c, d, h, hab, hcd⟩ := even_sum_four_squares h in
let ⟨k, hk⟩ := exists_eq_mul_right_of_dvd (modeq_zero_iff.1 hab) in
let ⟨l, hl⟩ := exists_eq_mul_right_of_dvd (modeq_zero_iff.1 hcd) in
let ⟨a', b', hab'⟩ := sum_two_squares_of_sum_two_squares_two_mul hk in
let ⟨c', d', hcd'⟩ := sum_two_squares_of_sum_two_squares_two_mul hl in
⟨a', b', c', d', (domain.mul_left_inj (show (2 : ℤ) ≠ 0, by norm_num)).1
  (h ▸ by rw [add_assoc, hab', hcd', mul_add, ← hk, ← hl, ← add_assoc])⟩

section odd_primes
variables {p : ℕ} (hp : prime p) (hpo : p % 2 = 1)
include hp hpo

lemma bla14 {p : ℕ} (hp : prime p) (hpo : p % 2 = 1) {a b : fin (succ (p / 2))} : a.1 * a.1 + b.1 * b.1 + 1 < p * p :=
have hf : ∀ {a : fin (succ (p / 2))}, (a.1 : ℚ) ≤ p / 2 := λ a,
  calc (a.1 : ℚ) ≤ ((p / 2 : ℕ) : ℚ) : nat.cast_le.2 (le_of_lt_succ a.2)
           ... ≤ (p / 2 : ℚ) : nat.cast_div_le dec_trivial,
have hp2 : 0 ≤ (p : ℚ) / 2 := div_nonneg (nat.cast_nonneg _) (by norm_num),
have h20 : (2 : ℚ) ≠ 0 := by norm_num,
(@nat.cast_lt ℚ _ _ _).1 $
calc ((a.1 * a.1 + b.1 * b.1 + 1 : ℕ) : ℚ) = (a.1 : ℚ) * a.1 + b.1 * b.1 + 1 :
      by simp [nat.cast_mul, nat.cast_add]
  ... ≤ (p / 2) * (p / 2) + (p / 2) * (p / 2) + 1 : add_le_add (add_le_add
      (mul_le_mul hf hf (nat.cast_nonneg _) hp2)
      (mul_le_mul hf hf (nat.cast_nonneg _) hp2)) (le_refl _)
  ... = ((p : ℚ) * p) / 2 + 1 : by rw [div_mul_div, div_add_div_same, ← mul_two, mul_div_mul_right _ h20 h20]
  ... < ((p * p : ℕ) : ℚ) : add_lt_of_lt_sub_left
    (begin
      rw [nat.cast_mul, sub_half, one_lt_div_iff_lt (show (0 : ℚ) < 2, by norm_num)],
      exact calc (2 : ℚ) < 3 * 3 : by norm_num
        ... ≤ (p : ℚ) * (p : ℚ) : mul_self_le_mul_self (by norm_num) (nat.cast_le.2 (hp.odd_iff_ge_three.1 hpo)),
    end)

private lemma exists_sum_four_squares_dvd_prime :
  ∃ (m : ℕ) (a b c d : ℤ), a * a + b * b + c * c + d * d = m * p ∧ m < p ∧ 0 < m :=
let ⟨a, b, hab⟩ := bla12 hp hpo in
  let ⟨m, hm⟩ := exists_eq_mul_left_of_dvd hab in
  ⟨m, a.1, b.1, 1, 0,
    by rw [← int.coe_nat_mul m, ← hm];
      simp,
    lt_of_mul_lt_mul_right
      (by rw ← hm; exact bla14 hp hpo)
      (nat.zero_le p),
    pos_of_mul_pos_right
    (by rw [← hm, add_assoc]; exact succ_pos _)
    (nat.zero_le p)⟩

private lemma sum_four_squares_odd_prime :
    ∃ a b c d : ℤ, a * a + b * b + c * c + d * d = p :=
let h := exists_sum_four_squares_dvd_prime hp hpo in
let m := nat.find h in
let ⟨a, b, c, d, (habcd : (_ : ℤ) = (↑m : ℤ) * p), (hmp : m < p), (hm0 : 0 < m)⟩ :=
    nat.find_spec h in
have hm0' : (0 : ℤ) < m := int.coe_nat_lt.2 hm0,
have h₂ : ∃ r : ℤ, mod_sub_half a m * mod_sub_half a m + mod_sub_half b m * mod_sub_half b m +
    mod_sub_half c m * mod_sub_half c m + mod_sub_half d m * mod_sub_half d m = m * r :=
  exists_eq_mul_right_of_dvd (modeq_zero_iff.1 $
    int.modeq.trans (show _ ≡ m * p [ZMOD m], from
      by rw ← habcd; exact modeq_add (modeq_add (modeq_add
      (mod_sub_half_square hm0') (mod_sub_half_square hm0')) (mod_sub_half_square hm0'))
      (mod_sub_half_square hm0'))
    (show (m : ℤ) * p ≡ 0 [ZMOD m], from modeq_zero_iff.2 (dvd_mul_right m p))),
let ⟨r', hr'⟩ := h₂ in
have hr0 : (0 : ℤ) ≤ r' := @nonneg_of_mul_nonneg_left _ _ (↑m : ℤ) r'
  (hr' ▸ add_nonneg (add_nonneg (add_nonneg (mul_self_nonneg _) (mul_self_nonneg _))
    (mul_self_nonneg _)) (mul_self_nonneg _))
  hm0',
let r := r'.nat_abs in
have hr : mod_sub_half a ↑m * mod_sub_half a ↑m + mod_sub_half b ↑m *
  mod_sub_half b ↑m + mod_sub_half c ↑m * mod_sub_half c ↑m +
  mod_sub_half d ↑m * mod_sub_half d ↑m = ((m * r : ℕ) : ℤ) :=
  show _ = ((_ * r'.nat_abs : ℕ) : ℤ), by rwa [int.coe_nat_mul, int.nat_abs_of_nonneg hr0],
have h₁ : m = 1 := classical.by_contradiction $ λ h₁,
  or.cases_on (mod_two_eq_zero_or_one m)
    (λ hm2, let ⟨k, hk⟩ := exists_eq_mul_right_of_dvd (dvd_of_mod_eq_zero hm2) in
      have hk0 : 0 < k := pos_of_mul_pos_left (show 0 < 2 * k, from hk ▸ hm0)
        (zero_le _),
      have hkm : k < m := hk.symm ▸ (lt_mul_iff_one_lt_left hk0).2 (lt_succ_self _),
      begin
        rw [hk, int.coe_nat_mul, mul_assoc] at habcd,
        rcases sum_four_squares_of_sum_four_squares_two_mul habcd with ⟨a', b', c', d', habcd'⟩,
        exact nat.find_min h hkm ⟨a', b', c', d', habcd', lt_trans hkm hmp, hk0⟩,
      end)
    (λ hm2, have hm2' : (m : ℤ) % (2 : ℕ) = 1 :=
        by rw [← int.coe_nat_mod, hm2, int.coe_nat_one],
      have add_quarters : ∀ q : ℚ, q = q / 4 + q / 4 + q / 4 + q / 4 := λ q,
        by rw [← (show ((2 : ℚ) * 2 = 4), by norm_num), ← div_div_eq_div_mul,
          add_halves, add_assoc, add_halves, add_halves],
      have hrm : r < m := lt_of_mul_lt_mul_left
        (begin
          rw [← int.coe_nat_lt, ← hr, ← @int.cast_lt ℚ],
          simp only [int.cast_add, int.cast_coe_nat, nat.cast_mul, nat.cast_add],
          rw [add_quarters ((m : ℚ) * m)],
          refine add_lt_add_of_lt_of_le (add_lt_add_of_lt_of_le
            (add_lt_add_of_lt_of_le _ (mod_sub_half_square_le hm0'))
            (mod_sub_half_square_le hm0')) (mod_sub_half_square_le hm0'),
          rw [← (show (2 : ℚ) * 2 = 4, by norm_num), ← div_mul_div, ← abs_mul_self, abs_mul, int.cast_mul],
          exact mul_self_lt_mul_self (int.cast_nonneg.2 (abs_nonneg _)) (mod_sub_half_lt_of_odd hm0' hm2'),
        end)
        (nat.zero_le m),
      have hmodeq : mod_sub_half a m * mod_sub_half a m + mod_sub_half b m * mod_sub_half b m
          + mod_sub_half c m * mod_sub_half c m + mod_sub_half d m * mod_sub_half d m ≡
          a * a + b * b + c * c + d * d [ZMOD m] :=
        modeq_add (modeq_add (modeq_add (mod_sub_half_square hm0') (mod_sub_half_square hm0'))
          (mod_sub_half_square hm0')) (mod_sub_half_square hm0'),
      have hdvd : (m : ℤ) ∣ a * a + b * b + c * c + d * d := habcd.symm ▸ dvd_mul_right _ _,
      have hdvd₁ : (m : ℤ) ∣ _ := modeq_zero_iff.1 ((modeq.trans hmodeq) (modeq_zero_iff.2 hdvd)),
      have hr0 : r ≠ 0 := λ h, begin
        rw [h, mul_zero, int.coe_nat_zero] at hr,
        simp only [int.nat_abs_mul_self.symm, (int.coe_nat_add _ _).symm] at hr,
        have hd := eq_zero_of_add_eq_zero (int.coe_nat_inj hr),
        have hc := eq_zero_of_add_eq_zero hd.1,
        have hab := eq_zero_of_add_eq_zero hc.1,
        simp only [(int.coe_nat_eq_coe_nat_iff _ _).symm, int.nat_abs_mul_self] at hab hc hd,
        have h : a * a + b * b + c * c + d * d ≡ 0 + 0 + 0 + 0 [ZMOD (m * m)] :=
          modeq_add (modeq_add (modeq_add (mod_sub_half_eq_zero hm0' hab.1)
            (mod_sub_half_eq_zero hm0' hab.2))
            (mod_sub_half_eq_zero hm0' hc.2)) (mod_sub_half_eq_zero hm0' hd.2),
        have : m ∣ p := dvd_of_mul_dvd_mul_left hm0
          (by rw [← int.coe_nat_dvd, int.coe_nat_mul, int.coe_nat_mul, ← habcd];
            exact modeq_zero_iff.1 h),
        cases hp.2 _ this with he he,
        { contradiction },
        { rw he at hmp,
          exact lt_irrefl _ hmp }
      end,
      have hk : _ := four_squares_mul_four_squares a b c d (mod_sub_half a m)
        (mod_sub_half b m) (mod_sub_half c m) (mod_sub_half d m),
      have ha : _ := @mod_sub_half_modeq a _ hm0',
      have hb : _ := @mod_sub_half_modeq b _ hm0',
      have hc : _ := @mod_sub_half_modeq c _ hm0',
      have hd : _ := @mod_sub_half_modeq d _ hm0',
      let ⟨a', ha'⟩ := exists_eq_mul_right_of_dvd
          (dvd_mul_sub_add_mul_sub ha hb hc hd) in
      let ⟨b', hb'⟩ := exists_eq_mul_right_of_dvd
          (dvd_mul_sub_add_mul_sub ha hc hd hb) in
      let ⟨c', hc'⟩ := exists_eq_mul_right_of_dvd
          (dvd_mul_sub_add_mul_sub ha hd hb hc) in
      have hm4 : ∀ i j : ℤ, (m : ℤ) * i * (m * j) = (m * m) * (i * j) :=
        λ i j, by simp [mul_comm, mul_assoc, mul_left_comm],
      begin
        rw [hr, habcd, ha', hb', hc', int.coe_nat_mul, hm4, hm4, hm4, hm4,
          ← mul_add, ← mul_add] at hk,
        have hk' := sub_eq_iff_eq_add'.2 hk,
        have hd₁ : (m : ℤ) * m ∣ ((a * mod_sub_half a ↑m + b * mod_sub_half b ↑m +
          c * mod_sub_half c ↑m + d * mod_sub_half d ↑m).nat_abs *
            (a * mod_sub_half a ↑m + b * mod_sub_half b ↑m +
            c * mod_sub_half c ↑m + d * mod_sub_half d ↑m).nat_abs : ℕ) :=
          by rw [int.nat_abs_mul_self, ← hk', ← mul_sub];
          exact dvd_mul_right _ _,
        have hd' : (m : ℤ) ∣ (a * mod_sub_half a ↑m + b * mod_sub_half b ↑m +
            c * mod_sub_half c ↑m + d * mod_sub_half d ↑m) :=
          dvd_nat_abs.1 (int.coe_nat_dvd.2 begin
            rw [← int.coe_nat_mul, ← nat.pow_two, ← nat.pow_two, int.coe_nat_dvd] at hd₁,
            exact nat.dvd_of_pow_dvd_pow dec_trivial hd₁,
          end),
        cases exists_eq_mul_right_of_dvd hd' with d' hd',
        have habcd' : a' * a' + b' * b' + c' * c' + d' * d' = ↑r * ↑p :=
          (domain.mul_left_inj (ne_of_lt (mul_pos hm0' hm0')).symm).1 begin
            rw [mul_comm (r : ℤ), hk, hd'],
            ring,
          end,
        exact nat.find_min h hrm ⟨a', b', c', d', habcd', lt_trans hrm hmp,
          nat.pos_of_ne_zero (λ h, by rw h at hr0; contradiction)⟩,
      end),
⟨a, b, c, d, by rw [habcd, h₁]; simp⟩

end odd_primes

lemma sum_four_squares_int : ∀ n : ℕ, ∃ a b c d : ℤ, a * a + b * b + c * c + d * d = n
| 0 := ⟨0, 0, 0, 0, rfl⟩
| 1 := ⟨1, 0, 0, 0, rfl⟩
| n@(k+2) :=
have hm : prime (min_fac n) := min_fac_prime dec_trivial,
have n / min_fac n < n := factors_lemma,
let ⟨a, b, c, d, h₁⟩ := show ∃ a b c d : ℤ, a * a + b * b + c * c + d * d = min_fac n,
  from or.cases_on hm.eq_two_or_odd
    (λ h2, h2.symm ▸ ⟨1, 1, 0, 0, rfl⟩)
    (sum_four_squares_odd_prime hm) in
let ⟨w, x, y, z, h₂⟩ := sum_four_squares_int (n / min_fac n) in
⟨a * x - w * b + (d * y - z * c),
 a * y - w * c + (b * z - x * d),
 a * z - w * d + (c * x - y * b),
 a * w + b * x +  c * y + d * z,
  by rw [← four_squares_mul_four_squares, h₁, h₂, ← int.coe_nat_mul,
      int.coe_nat_eq_coe_nat_iff, nat.mul_div_cancel' (min_fac_dvd _)]⟩

lemma sum_four_squares (n : ℕ) : ∃ a b c d : ℕ, a * a + b * b + c * c + d * d = n :=
let ⟨a, b, c, d, h⟩ := sum_four_squares_int n in
⟨a.nat_abs, b.nat_abs, c.nat_abs, d.nat_abs,
  int.coe_nat_inj (h ▸ by simp only [int.coe_nat_add, int.nat_abs_mul_self])⟩

#print axioms sum_four_squares


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.complete_lattice

/-!
# Completely distributive lattices and Boolean algebras

In this file there are definitions and an API for completely distributive lattices and completely
distributive Boolean algebras.

## Typeclasses

* `complete_distrib_lattice`: Completely distributive lattices: A complete lattice whose `⊓` and `⊔`
  distribute over `⨆` and `⨅` respectively.
* `complete_boolean_algebra`: Completely distributive Boolean algebra: A Boolean algebra whose `⊓`
  and `⊔` distribute over `⨆` and `⨅` respectively.
-/

set_option old_structure_cmd true

universes u v w
variables {α : Type u} {β : Type v} {ι : Sort w}

/-- A complete distributive lattice is a bit stronger than the name might
  suggest; perhaps completely distributive lattice is more descriptive,
  as this class includes a requirement that the lattice join
  distribute over *arbitrary* infima, and similarly for the dual. -/
class complete_distrib_lattice α extends complete_lattice α :=
(infi_sup_le_sup_Inf : ∀ a s, (⨅ b ∈ s, a ⊔ b) ≤ a ⊔ Inf s)
(inf_Sup_le_supr_inf : ∀ a s, a ⊓ Sup s ≤ (⨆ b ∈ s, a ⊓ b))

section complete_distrib_lattice
variables [complete_distrib_lattice α] {a b : α} {s t : set α}

instance : complete_distrib_lattice (order_dual α) :=
{ infi_sup_le_sup_Inf := complete_distrib_lattice.inf_Sup_le_supr_inf,
  inf_Sup_le_supr_inf := complete_distrib_lattice.infi_sup_le_sup_Inf,
  .. order_dual.complete_lattice α }

theorem sup_Inf_eq : a ⊔ Inf s = (⨅ b ∈ s, a ⊔ b) :=
sup_Inf_le_infi_sup.antisymm (complete_distrib_lattice.infi_sup_le_sup_Inf _ _)

theorem Inf_sup_eq : Inf s ⊔ b = (⨅ a ∈ s, a ⊔ b) :=
by simpa only [sup_comm] using @sup_Inf_eq α _ b s

theorem inf_Sup_eq : a ⊓ Sup s = (⨆ b ∈ s, a ⊓ b) :=
(complete_distrib_lattice.inf_Sup_le_supr_inf _ _).antisymm supr_inf_le_inf_Sup

theorem Sup_inf_eq : Sup s ⊓ b = (⨆ a ∈ s, a ⊓ b) :=
by simpa only [inf_comm] using @inf_Sup_eq α _ b s

theorem supr_inf_eq (f : ι → α) (a : α) : (⨆ i, f i) ⊓ a = ⨆ i, f i ⊓ a :=
by rw [supr, Sup_inf_eq, supr_range]

theorem inf_supr_eq (a : α) (f : ι → α) : a ⊓ (⨆ i, f i) = ⨆ i, a ⊓ f i :=
by simpa only [inf_comm] using supr_inf_eq f a

theorem infi_sup_eq (f : ι → α) (a : α) : (⨅ i, f i) ⊔ a = ⨅ i, f i ⊔ a :=
@supr_inf_eq (order_dual α) _ _ _ _

theorem sup_infi_eq (a : α) (f : ι → α) : a ⊔ (⨅ i, f i) = ⨅ i, a ⊔ f i :=
@inf_supr_eq (order_dual α) _ _ _ _

instance pi.complete_distrib_lattice {ι : Type*} {π : ι → Type*}
  [∀ i, complete_distrib_lattice (π i)] : complete_distrib_lattice (Π i, π i) :=
{ infi_sup_le_sup_Inf := λ a s i,
    by simp only [← sup_infi_eq, complete_lattice.Inf, Inf_apply, ←infi_subtype'', infi_apply,
      pi.sup_apply],
  inf_Sup_le_supr_inf := λ a s i,
    by simp only [complete_lattice.Sup, Sup_apply, supr_apply, pi.inf_apply, inf_supr_eq,
      ← supr_subtype''],
  .. pi.complete_lattice }

theorem Inf_sup_Inf : Inf s ⊔ Inf t = (⨅ p ∈ set.prod s t, (p : α × α).1 ⊔ p.2) :=
begin
  apply le_antisymm,
  { simp only [and_imp, prod.forall, le_infi_iff, set.mem_prod],
    intros a b ha hb,
    exact sup_le_sup (Inf_le ha) (Inf_le hb) },
  { have : ∀ a ∈ s, (⨅ p ∈ set.prod s t, (p : α × α).1 ⊔ p.2) ≤ a ⊔ Inf t,
    { rintro a ha,
      have : (⨅ p ∈ set.prod s t, ((p : α × α).1 : α) ⊔ p.2) ≤
             (⨅ p ∈ prod.mk a '' t, (p : α × α).1 ⊔ p.2),
      { apply infi_le_infi_of_subset,
        rintro ⟨x, y⟩,
        simp only [and_imp, set.mem_image, prod.mk.inj_iff, set.prod_mk_mem_set_prod_eq,
                   exists_imp_distrib],
        rintro x' x't ax x'y,
        rw [← x'y, ← ax],
        simp [ha, x't] },
      rw [infi_image] at this,
      simp only at this,
      rwa ← sup_Inf_eq at this },
    calc (⨅ p ∈ set.prod s t, (p : α × α).1 ⊔ p.2) ≤ (⨅ a ∈ s, a ⊔ Inf t) : by simp; exact this
       ... = Inf s ⊔ Inf t : Inf_sup_eq.symm }
end

theorem Sup_inf_Sup : Sup s ⊓ Sup t = (⨆ p ∈ set.prod s t, (p : α × α).1 ⊓ p.2) :=
@Inf_sup_Inf (order_dual α) _ _ _

lemma supr_disjoint_iff {f : ι → α} : disjoint (⨆ i, f i) a ↔ ∀ i, disjoint (f i) a :=
by simp only [disjoint_iff, supr_inf_eq, supr_eq_bot]

lemma disjoint_supr_iff {f : ι → α} : disjoint a (⨆ i, f i) ↔ ∀ i, disjoint a (f i) :=
by simpa only [disjoint.comm] using @supr_disjoint_iff _ _ _ a f

end complete_distrib_lattice

@[priority 100] -- see Note [lower instance priority]
instance complete_distrib_lattice.to_distrib_lattice [d : complete_distrib_lattice α] :
  distrib_lattice α :=
{ le_sup_inf := λ x y z, by rw [← Inf_pair, ← Inf_pair, sup_Inf_eq, ← Inf_image, set.image_pair],
  ..d }

/-- A complete Boolean algebra is a completely distributive Boolean algebra. -/
class complete_boolean_algebra α extends boolean_algebra α, complete_distrib_lattice α

instance pi.complete_boolean_algebra {ι : Type*} {π : ι → Type*}
  [∀ i, complete_boolean_algebra (π i)] : complete_boolean_algebra (Π i, π i) :=
{ .. pi.boolean_algebra, .. pi.complete_distrib_lattice }

instance Prop.complete_boolean_algebra : complete_boolean_algebra Prop :=
{ infi_sup_le_sup_Inf := λ p s, iff.mp $
    by simp only [forall_or_distrib_left, complete_lattice.Inf, infi_Prop_eq, sup_Prop_eq],
  inf_Sup_le_supr_inf := λ p s, iff.mp $
    by simp only [complete_lattice.Sup, exists_and_distrib_left, inf_Prop_eq, supr_Prop_eq],
  .. Prop.boolean_algebra, .. Prop.complete_lattice }

section complete_boolean_algebra
variables [complete_boolean_algebra α] {a b : α} {s : set α} {f : ι → α}

theorem compl_infi : (infi f)ᶜ = (⨆ i, (f i)ᶜ) :=
le_antisymm
  (compl_le_of_compl_le $ le_infi $ λ i, compl_le_of_compl_le $ le_supr (compl ∘ f) i)
  (supr_le $ λ i, compl_le_compl $ infi_le _ _)

theorem compl_supr : (supr f)ᶜ = (⨅ i, (f i)ᶜ) :=
compl_injective (by simp [compl_infi])

theorem compl_Inf : (Inf s)ᶜ = (⨆ i ∈ s, iᶜ) :=
by simp only [Inf_eq_infi, compl_infi]

theorem compl_Sup : (Sup s)ᶜ = (⨅ i ∈ s, iᶜ) :=
by simp only [Sup_eq_supr, compl_supr]

end complete_boolean_algebra


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

Extensional equality for functions, and a proof of function extensionality from quotients.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.quot
import Mathlib.Lean3Lib.init.logic

universes u v

namespace Mathlib

namespace function

protected def equiv {α : Sort u} {β : α → Sort v} (f₁ : (x : α) → β x) (f₂ : (x : α) → β x) :=
  ∀ (x : α), f₁ x = f₂ x

protected theorem equiv.refl {α : Sort u} {β : α → Sort v} (f : (x : α) → β x) :
    function.equiv f f :=
  fun (x : α) => rfl

protected theorem equiv.symm {α : Sort u} {β : α → Sort v} {f₁ : (x : α) → β x}
    {f₂ : (x : α) → β x} : function.equiv f₁ f₂ → function.equiv f₂ f₁ :=
  fun (h : function.equiv f₁ f₂) (x : α) => Eq.symm (h x)

protected theorem equiv.trans {α : Sort u} {β : α → Sort v} {f₁ : (x : α) → β x}
    {f₂ : (x : α) → β x} {f₃ : (x : α) → β x} :
    function.equiv f₁ f₂ → function.equiv f₂ f₃ → function.equiv f₁ f₃ :=
  fun (h₁ : function.equiv f₁ f₂) (h₂ : function.equiv f₂ f₃) (x : α) => Eq.trans (h₁ x) (h₂ x)

protected theorem equiv.is_equivalence (α : Sort u) (β : α → Sort v) : equivalence function.equiv :=
  mk_equivalence function.equiv equiv.refl equiv.symm equiv.trans

end function

theorem funext {α : Sort u} {β : α → Sort v} {f₁ : (x : α) → β x} {f₂ : (x : α) → β x}
    (h : ∀ (x : α), f₁ x = f₂ x) : f₁ = f₂ :=
  (fun (this : extfun_app (quotient.mk f₁) = extfun_app (quotient.mk f₂)) => this)
    (congr_arg extfun_app (quotient.sound h))

protected instance pi.subsingleton {α : Sort u} {β : α → Sort v} [∀ (a : α), subsingleton (β a)] :
    subsingleton ((a : α) → β a) :=
  subsingleton.intro
    fun (f₁ f₂ : (a : α) → β a) => funext fun (a : α) => subsingleton.elim (f₁ a) (f₂ a)

end Mathlib


import basic
import incidence_geometry

open incidence_geometry
open_locale classical

/-!
# Axiomas de orden

En este fichero se enuncian los axiomas de orden de la geometría euclídea plana y se definen
entidades y demuestran resultados que dependen de estos axiomas.

## Notaciones

- Se mantiene el uso de la relación de incidencia A ~ l.
- Se utiliza la notación local A * B * C para la relación de orden.

-/

/-- Geometría del orden, clase que engloba los axiomas para la relación de orden. -/
class order_geometry (Point Line : Type*) extends incidence_geometry Point Line :=
  (between: Point → Point → Point →  Prop)
  (notation A `*` B `*` C := between A B C)
  (B11 {A B C: Point} (h : A * B * C) : different3 A B C ∧ collinear Line A B C ∧ C * B * A)
  (B12 {A B C: Point} (h : A * B * C) : C * B * A)
  (B2 {A B : Point} (h : A ≠ B): ∃ C : Point, A * B * C)
  (B3 {A B C : Point} (h : collinear Line A B C): xor3 (A * B * C) (B * A * C) (A * C * B))
  (B4 {A B C D : Point} {l : Line} (h_non_collinear : ¬ collinear Line A B C)
      (hlABC : ¬ (A ~ l ∨ B ~ l ∨ C ~ l)) (hlD : D ~ l) (hADB : A * D * B)
      : xor (∃ E ,  E ~ l ∧ (A * E * C)) (∃ E, E ~ l ∧ (B * E * C)))

-- structure Triangle (Point : Type*) := (A B C : Point) (diff : different3 A B C)

-- instance (Point Line : Type) [order_geometry Point Line] : has_mem Point (Triangle Point) :=
--   ⟨λ P T,
--       P ∈ (Segment.mk T.A T.B T.diff.1)
--     ∨ P ∈ (Segment.mk T.A T.C T.diff.2.1)
--     ∨ P ∈ (Segment.mk T.B T.C T.diff.2.2)⟩

namespace order_geometry

variables {Point Line : Type*} [og : order_geometry Point Line]

local notation A `*` B `*` C := og.between A B C

lemma between_symm (A B C : Point) : (A * B * C) ↔ (C * B * A) :=
begin
  split,
  { intro h, exact og.B12 h },
  { intro h, exact og.B12 h },
end

/--
Los segmentos están implementados mediante estructuras determinadas por dos puntos distintos.
-/
structure Segment (Point : Type*) := (A B : Point) (diff : A ≠ B)

/--
Relación de pertenencia entre puntos y segmentos.
Un punto está en un segmento si coincide con uno de los extremos o está entre ellos.
-/
instance : has_mem Point (Segment Point) :=
⟨λ P S, P = S.A ∨ P = S.B ∨ (S.A * P * S.B)⟩

/--
Relación de intersección entre segmentos y líneas.
Un segmento se interseca con una línea si tienen un punto en común
TODO: Usar instancia de has_mem
-/
def segment_intersect_line (S : Segment Point) (l : Line) :=
∃ P : Point, (P = S.A ∨ P = S.B ∨ (S.A * P * S.B)) ∧ P ~ l

/--
Relación de estar del mismo lado del plano respecto de una línea.
Dos puntos externos a una línea están del mismo lado de la línea si el segmento que los
une no interseca a la línea.
-/
def plane_same_side (l: Line) (A B : outside_line_points Point l) :=
A = B ∨ (∃ h : ↑A ≠ ↑B, ¬ @segment_intersect_line Point Line og (Segment.mk A B h) l)

variable (Point)

/-- La relación de estar del mismo lado de una línea es reflexiva. -/
lemma plane_same_side_refl (l : Line) : reflexive (@plane_same_side Point Line og l) :=
begin
  intro P,
  left,
  refl,
end

/-- La relación de estar del mismo lado de una línea es simétrica. -/
lemma plane_same_side_symm (l : Line) : symmetric (@plane_same_side Point Line og l) :=
begin
  intros P Q h,
  cases h with h1 h2,
  { left, rw h1 },
  { cases h2 with h h2,
    right,
    use h.symm,
    rw segment_intersect_line at h2 ⊢,
    push_neg at h2 ⊢,
    intro A,
    specialize h2 A,
    rw between_symm,
    tauto },
end

-- /--
-- Lema útil para demostrar la transitividad de la relación de estar del mismo lado de una línea.
-- Se demuestra la transitividad para puntos no colineares.
-- -/
-- lemma plane_same_side_trans_noncollinear_case (l : Line) (A B C : outside_line_points Point l) (h: ¬ incidence_geometry.collinear Line (↑A:Point) ↑B ↑C) :
-- (plane_same_side l A B) → (plane_same_side l B C) → (plane_same_side l A C):=
-- begin
--   sorry
-- end

/--
La relación de estar del mismo lado de una línea es transitiva.
Esta es la propiedad más difícil de demostrar.
Para esto reducimos la demostración a dos casos:
- Tres puntos no colineares. Tratado en el lema anterior.
- Tres puntos colineares. Reducible mediante construcciones al caso anterior.
-/
lemma plane_same_side_trans (l : Line) : transitive (@plane_same_side Point Line og l) :=
begin
  intros A B C hAB hBC,
  cases hAB,
  { rw hAB, exact hBC },
  { cases hBC,
    { rw ← hBC, right, exact hAB },
    { cases hAB with hAneB hAB,
      cases hBC with hBneC hBC,
      by_cases hAC : A = C,
      { left, exact hAC },
      { right,
        let hAC' := (outside_line_points_lift_ne Point l A C).mp hAC,
        use hAC',
        rw segment_intersect_line at hAB hBC ⊢,
        push_neg at hAB hBC ⊢,
        rintros P (h1|h2|h3),
        { apply hAB P, left, exact h1 },
        { apply hBC P, right, left, exact h2 },
        { by_cases h_collinear : ¬ collinear Line (↑A: Point) ↑B ↑C,
          { /- Case 1 in Hartshorne -/
            by_contra hDl,
            rw [collinear_comm2, collinear_comm, collinear_comm2] at h_collinear,
            have hlABC : ¬ (↑A ~ l ∨ ↑C ~ l ∨ ↑B ~ l),
            { push_neg,
              split,
              { apply hAB (↑A : Point), left, exact rfl },
              { split,
                { apply hBC (↑C : Point), right, left, exact rfl },
                { apply hBC (↑B : Point), left, exact rfl }}},
            cases (B4 h_collinear hlABC hDl h3).or,
            { cases h with E h,
              apply (and_not_self (E ~ l)).mp,
              refine ⟨h.left, _⟩,
              apply hAB E,
              right, right,
              exact h.right },
            { cases h with E h,
              apply (and_not_self (E ~ l)).mp,
              refine ⟨h.left, _⟩,
              apply hBC E,
              right, right,
              apply B12,
              exact h.right },
            },
          { /- Case 2 in Hartshorne -/
            push_neg at h_collinear,
            cases h_collinear with m h,
            have hD : ∃ D : Point, D ~ l ∧ ¬ D ~ m, { sorry },
            cases hD with D hD,
            have hDA : D ≠ ↑A , { sorry },
            have hE : ∃ E : Point, D * ↑A * E, { cases (og.B2 hDA) with E hE, use E, exact hE },
            cases hE with E hE,
            have hDAE_collinear : collinear Line D A E, { exact (og.B11 hE).right.left },
            sorry }
          }}}},
end

/-- La relación de estar del mismo lado del plano respecto de una línea es transitiva. -/
theorem plane_same_side_equiv (l : Line) : equivalence (@plane_same_side Point Line og l) :=
⟨plane_same_side_refl Point l, plane_same_side_symm Point l, plane_same_side_trans Point l⟩

/-- Instancia de la clase setoid para la relación. -/
def PlaneSide.setoid [og : order_geometry Point Line] (l : Line) : setoid (outside_line_points Point l) :=
{ r := plane_same_side l, iseqv := plane_same_side_equiv Point l }
local attribute [instance] PlaneSide.setoid

/-- Conjunto cociente de los lados de una línea. -/
def PlaneSide [og : order_geometry Point Line] (l : Line) := quotient (PlaneSide.setoid Point l)
def PlaneSide.reduce [og : order_geometry Point Line] (l : Line) : outside_line_points Point l → PlaneSide Point l := quot.mk (plane_same_side l)
instance [og : order_geometry Point Line] (l : Line) : has_lift (outside_line_points Point l) (PlaneSide Point l) := ⟨PlaneSide.reduce Point l⟩
instance [og : order_geometry Point Line] (l : Line) : has_coe  (outside_line_points Point l) (PlaneSide Point l) := ⟨PlaneSide.reduce Point l⟩

/--
Teorema de separación del plano.
El enunciado original consiste en dos partes. La primera se corresponde con demostrar que la relación de estar
-/
theorem plane_separation (Point Line : Type*) [og : order_geometry Point Line] (l : Line) (A B : outside_line_points Point l) (hAB: A ≠ B):
  @segment_intersect_line Point Line og (Segment.mk A B ((outside_line_points_lift_ne Point l A B).mp hAB)) l ↔ ¬ A ≈ B :=
begin
  split,
  { rw segment_intersect_line,
    intro h,
    cases h with P hP,
    rcases hP with ⟨hP, hPl⟩,
    sorry },
  { sorry }
end

def line_points_different_to (Point : Type*) {Line : Type*} [incidence_geometry Point Line] (l: Line) (P : line_points Point l) := { A : Point | A ~ l ∧ A ≠ P }

def line_same_side (l: Line) (P : line_points Point l) (A B : line_points_different_to Point l P) :=
A = B ∨ (∃ h : ↑A ≠ ↑B, ¬ @segment_intersect_line Point Line og (Segment.mk A B h) l)

end order_geometry


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import order.lattice
import data.list.sort
import logic.equiv.fin
import logic.equiv.functor
import data.fintype.card
/-!
# Jordan-Hölder Theorem

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file proves the Jordan Hölder theorem for a `jordan_holder_lattice`, a class also defined in
this file. Examples of `jordan_holder_lattice` include `subgroup G` if `G` is a group, and
`submodule R M` if `M` is an `R`-module. Using this approach the theorem need not be proved
seperately for both groups and modules, the proof in this file can be applied to both.

## Main definitions
The main definitions in this file are `jordan_holder_lattice` and `composition_series`,
and the relation `equivalent` on `composition_series`

A `jordan_holder_lattice` is the class for which the Jordan Hölder theorem is proved. A
Jordan Hölder lattice is a lattice equipped with a notion of maximality, `is_maximal`, and a notion
of isomorphism of pairs `iso`. In the example of subgroups of a group, `is_maximal H K` means that
`H` is a maximal normal subgroup of `K`, and `iso (H₁, K₁) (H₂, K₂)` means that the quotient
`H₁ / K₁` is isomorphic to the quotient `H₂ / K₂`. `iso` must be symmetric and transitive and must
satisfy the second isomorphism theorem `iso (H, H ⊔ K) (H ⊓ K, K)`.

A `composition_series X` is a finite nonempty series of elements of the lattice `X` such that
each element is maximal inside the next. The length of a `composition_series X` is
one less than the number of elements in the series. Note that there is no stipulation
that a series start from the bottom of the lattice and finish at the top.
For a composition series `s`, `s.top` is the largest element of the series,
and `s.bot` is the least element.

Two `composition_series X`, `s₁` and `s₂` are equivalent if there is a bijection
`e : fin s₁.length ≃ fin s₂.length` such that for any `i`,
`iso (s₁ i, s₁ i.succ) (s₂ (e i), s₂ (e i.succ))`

## Main theorems

The main theorem is `composition_series.jordan_holder`, which says that if two composition
series have the same least element and the same largest element,
then they are `equivalent`.

## TODO

Provide instances of `jordan_holder_lattice` for both submodules and subgroups, and potentially
for modular lattices.

It is not entirely clear how this should be done. Possibly there should be no global instances
of `jordan_holder_lattice`, and the instances should only be defined locally in order to prove
the Jordan-Hölder theorem for modules/groups and the API should be transferred because many of the
theorems in this file will have stronger versions for modules. There will also need to be an API for
mapping composition series across homomorphisms. It is also probably possible to
provide an instance of `jordan_holder_lattice` for any `modular_lattice`, and in this case the
Jordan-Hölder theorem will say that there is a well defined notion of length of a modular lattice.
However an instance of `jordan_holder_lattice` for a modular lattice will not be able to contain
the correct notion of isomorphism for modules, so a separate instance for modules will still be
required and this will clash with the instance for modular lattices, and so at least one of these
instances should not be a global instance.
-/

universe u

open set

/--
A `jordan_holder_lattice` is the class for which the Jordan Hölder theorem is proved. A
Jordan Hölder lattice is a lattice equipped with a notion of maximality, `is_maximal`, and a notion
of isomorphism of pairs `iso`. In the example of subgroups of a group, `is_maximal H K` means that
`H` is a maximal normal subgroup of `K`, and `iso (H₁, K₁) (H₂, K₂)` means that the quotient
`H₁ / K₁` is isomorphic to the quotient `H₂ / K₂`. `iso` must be symmetric and transitive and must
satisfy the second isomorphism theorem `iso (H, H ⊔ K) (H ⊓ K, K)`.
Examples include `subgroup G` if `G` is a group, and `submodule R M` if `M` is an `R`-module.
-/
class jordan_holder_lattice (X : Type u) [lattice X] :=
(is_maximal : X → X → Prop)
(lt_of_is_maximal : ∀ {x y}, is_maximal x y → x < y)
(sup_eq_of_is_maximal : ∀ {x y z}, is_maximal x z → is_maximal y z →
  x ≠ y → x ⊔ y = z)
(is_maximal_inf_left_of_is_maximal_sup : ∀ {x y}, is_maximal x (x ⊔ y) → is_maximal y (x ⊔ y) →
  is_maximal (x ⊓ y) x)
(iso : (X × X) → (X × X) → Prop)
(iso_symm : ∀ {x y}, iso x y → iso y x)
(iso_trans : ∀ {x y z}, iso x y → iso y z → iso x z)
(second_iso : ∀ {x y}, is_maximal x (x ⊔ y) → iso (x, x ⊔ y) (x ⊓ y, y))

namespace jordan_holder_lattice

variables {X : Type u} [lattice X] [jordan_holder_lattice X]

lemma is_maximal_inf_right_of_is_maximal_sup {x y : X}
  (hxz : is_maximal x (x ⊔ y)) (hyz : is_maximal y (x ⊔ y)) :
  is_maximal (x ⊓ y) y :=
begin
  rw [inf_comm],
  rw [sup_comm] at hxz hyz,
  exact is_maximal_inf_left_of_is_maximal_sup hyz hxz
end

lemma second_iso_of_eq {x y a b : X} (hm : is_maximal x a) (ha : x ⊔ y = a) (hb : x ⊓ y = b) :
  iso (x, a) (b, y) :=
by substs a b; exact second_iso hm

lemma is_maximal.iso_refl {x y : X} (h : is_maximal x y) : iso (x, y) (x, y) :=
second_iso_of_eq h
  (sup_eq_right.2 (le_of_lt (lt_of_is_maximal h)))
  (inf_eq_left.2 (le_of_lt (lt_of_is_maximal h)))

end jordan_holder_lattice

open jordan_holder_lattice

attribute [symm] iso_symm
attribute [trans] iso_trans

/--
A `composition_series X` is a finite nonempty series of elements of a
`jordan_holder_lattice` such that each element is maximal inside the next. The length of a
`composition_series X` is one less than the number of elements in the series.
Note that there is no stipulation that a series start from the bottom of the lattice and finish at
the top. For a composition series `s`, `s.top` is the largest element of the series,
and `s.bot` is the least element.
-/
structure composition_series (X : Type u) [lattice X] [jordan_holder_lattice X] : Type u :=
(length : ℕ)
(series : fin (length + 1) → X)
(step' : ∀ i : fin length, is_maximal (series i.cast_succ) (series i.succ))

namespace composition_series

variables {X : Type u} [lattice X] [jordan_holder_lattice X]

instance : has_coe_to_fun (composition_series X) (λ x, fin (x.length + 1) → X) :=
{ coe := composition_series.series }

instance [inhabited X] : inhabited (composition_series X) :=
⟨{ length := 0,
   series := default,
   step' := λ x, x.elim0 }⟩

variables {X}

lemma step (s : composition_series X) : ∀ i : fin s.length,
  is_maximal (s i.cast_succ) (s i.succ) := s.step'

@[simp] lemma coe_fn_mk (length : ℕ) (series step) :
  (@composition_series.mk X _ _ length series step : fin length.succ → X) = series := rfl

theorem lt_succ (s : composition_series X) (i : fin s.length) :
  s i.cast_succ < s i.succ :=
lt_of_is_maximal (s.step _)

protected theorem strict_mono (s : composition_series X) : strict_mono s :=
fin.strict_mono_iff_lt_succ.2 s.lt_succ

protected theorem injective (s : composition_series X) : function.injective s :=
s.strict_mono.injective

@[simp] protected theorem inj (s : composition_series X) {i j : fin s.length.succ} :
  s i = s j ↔ i = j :=
s.injective.eq_iff

instance : has_mem X (composition_series X) :=
⟨λ x s, x ∈ set.range s⟩

lemma mem_def {x : X} {s : composition_series X} : x ∈ s ↔ x ∈ set.range s := iff.rfl

lemma total {s : composition_series X} {x y : X} (hx : x ∈ s) (hy : y ∈ s) : x ≤ y ∨ y ≤ x :=
begin
  rcases set.mem_range.1 hx with ⟨i, rfl⟩,
  rcases set.mem_range.1 hy with ⟨j, rfl⟩,
  rw [s.strict_mono.le_iff_le, s.strict_mono.le_iff_le],
  exact le_total i j
end

/-- The ordered `list X` of elements of a `composition_series X`. -/
def to_list (s : composition_series X) : list X := list.of_fn s

/-- Two `composition_series` are equal if they are the same length and
have the same `i`th element for every `i` -/
lemma ext_fun {s₁ s₂ : composition_series X}
  (hl : s₁.length = s₂.length)
  (h : ∀ i, s₁ i = s₂ (fin.cast (congr_arg nat.succ hl) i)) :
  s₁ = s₂ :=
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst hl,
  simpa [function.funext_iff] using h
end

@[simp] lemma length_to_list (s : composition_series X) : s.to_list.length = s.length + 1 :=
by rw [to_list, list.length_of_fn]

lemma to_list_ne_nil (s : composition_series X) : s.to_list ≠ [] :=
by rw [← list.length_pos_iff_ne_nil, length_to_list]; exact nat.succ_pos _

lemma to_list_injective : function.injective (@composition_series.to_list X _ _) :=
λ s₁ s₂ (h : list.of_fn s₁ = list.of_fn s₂),
have h₁ : s₁.length = s₂.length,
  from nat.succ_injective
    ((list.length_of_fn s₁).symm.trans $
      (congr_arg list.length h).trans $
      list.length_of_fn s₂),
have h₂ : ∀ i : fin s₁.length.succ, (s₁ i) = s₂ (fin.cast (congr_arg nat.succ h₁) i),
  begin
    assume i,
    rw [← list.nth_le_of_fn s₁ i, ← list.nth_le_of_fn s₂],
    simp [h]
  end,
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst h₁,
  simp only [heq_iff_eq, eq_self_iff_true, true_and],
  simp only [fin.cast_refl] at h₂,
  exact funext h₂
end

lemma chain'_to_list (s : composition_series X) :
  list.chain' is_maximal s.to_list :=
list.chain'_iff_nth_le.2
  begin
    assume i hi,
    simp only [to_list, list.nth_le_of_fn'],
    rw [length_to_list] at hi,
    exact s.step ⟨i, hi⟩
  end

lemma to_list_sorted (s : composition_series X) : s.to_list.sorted (<) :=
list.pairwise_iff_nth_le.2 (λ i j hi hij,
  begin
    dsimp [to_list],
    rw [list.nth_le_of_fn', list.nth_le_of_fn'],
    exact s.strict_mono hij
  end)

lemma to_list_nodup (s : composition_series X) : s.to_list.nodup :=
s.to_list_sorted.nodup

@[simp] lemma mem_to_list {s : composition_series X} {x : X} : x ∈ s.to_list ↔ x ∈ s :=
by rw [to_list, list.mem_of_fn, mem_def]

/-- Make a `composition_series X` from the ordered list of its elements. -/
def of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l) :
  composition_series X :=
{ length := l.length - 1,
  series := λ i, l.nth_le i begin
      conv_rhs { rw ← tsub_add_cancel_of_le (nat.succ_le_of_lt (list.length_pos_of_ne_nil hl)) },
      exact i.2
    end,
  step' := λ ⟨i, hi⟩, list.chain'_iff_nth_le.1 hc i hi }

lemma length_of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l) :
  (of_list l hl hc).length = l.length - 1 := rfl

lemma of_list_to_list (s : composition_series X) :
  of_list s.to_list s.to_list_ne_nil s.chain'_to_list = s :=
begin
  refine ext_fun _ _,
  { rw [length_of_list, length_to_list, nat.succ_sub_one] },
  { rintros ⟨i, hi⟩,
    dsimp [of_list, to_list],
    rw [list.nth_le_of_fn'] }
end

@[simp] lemma of_list_to_list' (s : composition_series X) :
  of_list s.to_list s.to_list_ne_nil s.chain'_to_list = s :=
of_list_to_list s

@[simp] lemma to_list_of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l)  :
  to_list (of_list l hl hc) = l :=
begin
  refine list.ext_le _ _,
  { rw [length_to_list, length_of_list,
      tsub_add_cancel_of_le (nat.succ_le_of_lt $ list.length_pos_of_ne_nil hl)] },
  { assume i hi hi',
    dsimp [of_list, to_list],
    rw [list.nth_le_of_fn'],
    refl }
end

/-- Two `composition_series` are equal if they have the same elements. See also `ext_fun`. -/
@[ext] lemma ext {s₁ s₂ : composition_series X} (h : ∀ x, x ∈ s₁ ↔ x ∈ s₂) : s₁ = s₂ :=
to_list_injective $ list.eq_of_perm_of_sorted
  (by classical; exact list.perm_of_nodup_nodup_to_finset_eq
    s₁.to_list_nodup
    s₂.to_list_nodup
    (finset.ext $ by simp *))
  s₁.to_list_sorted s₂.to_list_sorted

/-- The largest element of a `composition_series` -/
def top (s : composition_series X) : X := s (fin.last _)

lemma top_mem (s : composition_series X) : s.top ∈ s :=
mem_def.2 (set.mem_range.2 ⟨fin.last _, rfl⟩)

@[simp] lemma le_top {s : composition_series X} (i : fin (s.length + 1)) : s i ≤ s.top :=
s.strict_mono.monotone (fin.le_last _)

lemma le_top_of_mem {s : composition_series X} {x : X} (hx : x ∈ s) : x ≤ s.top :=
let ⟨i, hi⟩ := set.mem_range.2 hx in hi ▸ le_top _

/-- The smallest element of a `composition_series` -/
def bot (s : composition_series X) : X := s 0

lemma bot_mem (s : composition_series X) : s.bot ∈ s :=
mem_def.2 (set.mem_range.2 ⟨0, rfl⟩)

@[simp] lemma bot_le {s : composition_series X} (i : fin (s.length + 1)) : s.bot ≤ s i :=
s.strict_mono.monotone (fin.zero_le _)

lemma bot_le_of_mem {s : composition_series X} {x : X} (hx : x ∈ s) : s.bot ≤ x :=
let ⟨i, hi⟩ := set.mem_range.2 hx in hi ▸ bot_le _

lemma length_pos_of_mem_ne {s : composition_series X}
  {x y : X} (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y) :
  0 < s.length :=
let ⟨i, hi⟩ := hx, ⟨j, hj⟩ := hy in
have hij : i ≠ j, from mt s.inj.2 $ λ h, hxy (hi ▸ hj ▸ h),
hij.lt_or_lt.elim
  (λ hij, (lt_of_le_of_lt (zero_le i)
    (lt_of_lt_of_le hij (nat.le_of_lt_succ j.2))))
  (λ hji, (lt_of_le_of_lt (zero_le j)
    (lt_of_lt_of_le hji (nat.le_of_lt_succ i.2))))

lemma forall_mem_eq_of_length_eq_zero {s : composition_series X}
  (hs : s.length = 0) {x y} (hx : x ∈ s) (hy : y ∈ s) : x = y :=
by_contradiction (λ hxy, pos_iff_ne_zero.1 (length_pos_of_mem_ne hx hy hxy) hs)

/-- Remove the largest element from a `composition_series`. If the series `s`
has length zero, then `s.erase_top = s` -/
@[simps] def erase_top (s : composition_series X) : composition_series X :=
{ length := s.length - 1,
  series := λ i, s ⟨i, lt_of_lt_of_le i.2 (nat.succ_le_succ tsub_le_self)⟩,
  step' := λ i, begin
    have := s.step ⟨i, lt_of_lt_of_le i.2 tsub_le_self⟩,
    cases i,
    exact this
  end }

lemma top_erase_top (s : composition_series X) :
  s.erase_top.top = s ⟨s.length - 1, lt_of_le_of_lt tsub_le_self (nat.lt_succ_self _)⟩ :=
show s _ = s _, from congr_arg s
begin
  ext,
  simp only [erase_top_length, fin.coe_last, fin.coe_cast_succ, fin.coe_of_nat_eq_mod,
    fin.coe_mk, coe_coe]
end

lemma erase_top_top_le (s : composition_series X) : s.erase_top.top ≤ s.top :=
by simp [erase_top, top, s.strict_mono.le_iff_le, fin.le_iff_coe_le_coe, tsub_le_self]

@[simp] lemma bot_erase_top (s : composition_series X) : s.erase_top.bot = s.bot := rfl

lemma mem_erase_top_of_ne_of_mem {s : composition_series X} {x : X}
  (hx : x ≠ s.top) (hxs : x ∈ s) : x ∈ s.erase_top :=
begin
  rcases hxs with ⟨i, rfl⟩,
  have hi : (i : ℕ) < (s.length - 1).succ,
  { conv_rhs { rw [← nat.succ_sub (length_pos_of_mem_ne ⟨i, rfl⟩ s.top_mem hx),
      nat.succ_sub_one] },
    exact lt_of_le_of_ne
      (nat.le_of_lt_succ i.2)
      (by simpa [top, s.inj, fin.ext_iff] using hx) },
  refine ⟨i.cast_succ, _⟩,
  simp [fin.ext_iff, nat.mod_eq_of_lt hi]
end

lemma mem_erase_top {s : composition_series X} {x : X}
  (h : 0 < s.length) : x ∈ s.erase_top ↔ x ≠ s.top ∧ x ∈ s :=
begin
  simp only [mem_def],
  dsimp only [erase_top, coe_fn_mk],
  split,
  { rintros ⟨i, rfl⟩,
    have hi : (i : ℕ) < s.length,
    { conv_rhs { rw [← nat.succ_sub_one s.length, nat.succ_sub h] },
      exact i.2 },
    simp [top, fin.ext_iff, (ne_of_lt hi)] },
  { intro h,
    exact mem_erase_top_of_ne_of_mem h.1 h.2 }
end

lemma lt_top_of_mem_erase_top {s : composition_series X} {x : X} (h : 0 < s.length)
  (hx : x ∈ s.erase_top) : x < s.top :=
lt_of_le_of_ne
  (le_top_of_mem ((mem_erase_top h).1 hx).2)
  ((mem_erase_top h).1 hx).1

lemma is_maximal_erase_top_top {s : composition_series X} (h : 0 < s.length) :
  is_maximal s.erase_top.top s.top :=
have s.length - 1 + 1 = s.length,
  by conv_rhs { rw [← nat.succ_sub_one s.length] }; rw nat.succ_sub h,
begin
  rw [top_erase_top, top],
  convert s.step ⟨s.length - 1, nat.sub_lt h zero_lt_one⟩;
  ext; simp [this]
end

section fin_lemmas
-- TODO: move these to `vec_notation` and rename them to better describe their statement

variables {α : Type*} {m n : ℕ} (a : fin m.succ → α) (b : fin n.succ → α)

lemma append_cast_add_aux (i : fin m) :
  matrix.vec_append (nat.add_succ _ _).symm (a ∘ fin.cast_succ) b
    (fin.cast_add n i).cast_succ = a i.cast_succ :=
by { cases i, simp [matrix.vec_append_eq_ite, *] }

lemma append_succ_cast_add_aux (i : fin m) (h : a (fin.last _) = b 0) :
  matrix.vec_append (nat.add_succ _ _).symm (a ∘ fin.cast_succ) b
  (fin.cast_add n i).succ = a i.succ :=
begin
  cases i with i hi,
  simp only [matrix.vec_append_eq_ite, hi, fin.succ_mk, function.comp_app, fin.cast_succ_mk,
    fin.coe_mk, fin.cast_add_mk],
  split_ifs,
  { refl },
  { have : i + 1 = m, from le_antisymm hi (le_of_not_gt h_1),
    calc b ⟨i + 1 - m, by simp [this]⟩
        = b 0 : congr_arg b (by simp [fin.ext_iff, this])
    ... = a (fin.last _) : h.symm
    ... = _ : congr_arg a (by simp [fin.ext_iff, this]) }
end

lemma append_nat_add_aux (i : fin n) :
  matrix.vec_append (nat.add_succ _ _).symm (a ∘ fin.cast_succ) b
  (fin.nat_add m i).cast_succ = b i.cast_succ :=
begin
  cases i,
  simp only [matrix.vec_append_eq_ite, nat.not_lt_zero, fin.nat_add_mk, add_lt_iff_neg_left,
    add_tsub_cancel_left, dif_neg, fin.cast_succ_mk, not_false_iff, fin.coe_mk]
end

lemma append_succ_nat_add_aux (i : fin n) :
  matrix.vec_append (nat.add_succ _ _).symm (a ∘ fin.cast_succ) b
  (fin.nat_add m i).succ = b i.succ :=
begin
  cases i with i hi,
  simp only [matrix.vec_append_eq_ite, add_assoc, nat.not_lt_zero, fin.nat_add_mk,
    add_lt_iff_neg_left, add_tsub_cancel_left, fin.succ_mk, dif_neg, not_false_iff, fin.coe_mk]
end

end fin_lemmas

/-- Append two composition series `s₁` and `s₂` such that
the least element of `s₁` is the maximum element of `s₂`. -/
@[simps length] def append (s₁ s₂ : composition_series X)
  (h : s₁.top = s₂.bot) : composition_series X :=
{ length := s₁.length + s₂.length,
  series := matrix.vec_append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂,
  step' := λ i, begin
    refine fin.add_cases  _ _ i,
    { intro i,
      rw [append_succ_cast_add_aux _ _ _ h, append_cast_add_aux],
      exact s₁.step i },
    { intro i,
      rw [append_nat_add_aux, append_succ_nat_add_aux],
      exact s₂.step i }
  end }

lemma coe_append (s₁ s₂ : composition_series X) (h) :
  ⇑(s₁.append s₂ h) = matrix.vec_append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂ :=
rfl

@[simp] lemma append_cast_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₁.length) :
  append s₁ s₂ h (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
by rw [coe_append, append_cast_add_aux _ _ i]

@[simp] lemma append_succ_cast_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₁.length) :
  append s₁ s₂ h (fin.cast_add s₂.length i).succ = s₁ i.succ :=
by rw [coe_append, append_succ_cast_add_aux _ _ _ h]

@[simp] lemma append_nat_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₂.length) :
  append s₁ s₂ h (fin.nat_add s₁.length i).cast_succ = s₂ i.cast_succ :=
by rw [coe_append, append_nat_add_aux _ _ i]

@[simp] lemma append_succ_nat_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₂.length) :
  append s₁ s₂ h (fin.nat_add s₁.length i).succ = s₂ i.succ :=
by rw [coe_append, append_succ_nat_add_aux _ _ i]

/-- Add an element to the top of a `composition_series` -/
@[simps length] def snoc (s : composition_series X) (x : X)
  (hsat : is_maximal s.top x) : composition_series X :=
{ length := s.length + 1,
  series := fin.snoc s x,
  step' := λ i, begin
    refine fin.last_cases _ _ i,
    { rwa [fin.snoc_cast_succ, fin.succ_last, fin.snoc_last, ← top] },
    { intro i,
      rw [fin.snoc_cast_succ, ← fin.cast_succ_fin_succ, fin.snoc_cast_succ],
      exact s.step _ }
  end }

@[simp] lemma top_snoc (s : composition_series X) (x : X)
  (hsat : is_maximal s.top x) : (snoc s x hsat).top = x :=
fin.snoc_last _ _

@[simp] lemma snoc_last (s : composition_series X) (x : X) (hsat : is_maximal s.top x) :
  snoc s x hsat (fin.last (s.length + 1)) = x :=
fin.snoc_last _ _

@[simp] lemma snoc_cast_succ (s : composition_series X) (x : X) (hsat : is_maximal s.top x)
  (i : fin (s.length + 1)) : snoc s x hsat (i.cast_succ) = s i :=
fin.snoc_cast_succ _ _ _

@[simp] lemma bot_snoc (s : composition_series X) (x : X) (hsat : is_maximal s.top x) :
  (snoc s x hsat).bot = s.bot :=
by rw [bot, bot, ← snoc_cast_succ s _ _ 0, fin.cast_succ_zero]

lemma mem_snoc {s : composition_series X} {x y: X}
  {hsat : is_maximal s.top x} : y ∈ snoc s x hsat ↔ y ∈ s ∨ y = x :=
begin
  simp only [snoc, mem_def],
  split,
  { rintros ⟨i, rfl⟩,
    refine fin.last_cases _ (λ i, _) i,
    { right, simp },
    { left, simp } },
  { intro h,
    rcases h with ⟨i, rfl⟩ | rfl,
    { use i.cast_succ, simp },
    { use (fin.last _), simp } }
end

lemma eq_snoc_erase_top {s : composition_series X} (h : 0 < s.length) :
  s = snoc (erase_top s) s.top (is_maximal_erase_top_top h) :=
begin
  ext x,
  simp [mem_snoc, mem_erase_top h],
  by_cases h : x = s.top; simp [*, s.top_mem]
end

@[simp] lemma snoc_erase_top_top {s : composition_series X}
  (h : is_maximal s.erase_top.top s.top) : s.erase_top.snoc s.top h = s :=
have h : 0 < s.length,
  from nat.pos_of_ne_zero begin
    assume hs,
    refine ne_of_gt (lt_of_is_maximal h) _,
    simp [top, fin.ext_iff, hs]
  end,
(eq_snoc_erase_top h).symm

/-- Two `composition_series X`, `s₁` and `s₂` are equivalent if there is a bijection
`e : fin s₁.length ≃ fin s₂.length` such that for any `i`,
`iso (s₁ i) (s₁ i.succ) (s₂ (e i), s₂ (e i.succ))` -/
def equivalent (s₁ s₂ : composition_series X) : Prop :=
∃ f : fin s₁.length ≃ fin s₂.length,
  ∀ i : fin s₁.length,
    iso (s₁ i.cast_succ, s₁ i.succ)
    (s₂ (f i).cast_succ, s₂ (f i).succ)

namespace equivalent

@[refl] lemma refl (s : composition_series X) : equivalent s s :=
⟨equiv.refl _, λ _, (s.step _).iso_refl⟩

@[symm] lemma symm {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) :
  equivalent s₂ s₁ :=
⟨h.some.symm, λ i, iso_symm (by simpa using h.some_spec (h.some.symm i))⟩

@[trans] lemma trans {s₁ s₂ s₃ : composition_series X}
  (h₁ : equivalent s₁ s₂)
  (h₂ : equivalent s₂ s₃) :
  equivalent s₁ s₃ :=
⟨h₁.some.trans h₂.some, λ i, iso_trans (h₁.some_spec i) (h₂.some_spec (h₁.some i))⟩

lemma append
  {s₁ s₂ t₁ t₂ : composition_series X}
  (hs : s₁.top = s₂.bot)
  (ht : t₁.top = t₂.bot)
  (h₁ : equivalent s₁ t₁)
  (h₂ : equivalent s₂ t₂) :
  equivalent (append s₁ s₂ hs) (append t₁ t₂ ht) :=
let e : fin (s₁.length + s₂.length) ≃ fin (t₁.length + t₂.length) :=
  calc fin (s₁.length + s₂.length) ≃ fin s₁.length ⊕ fin s₂.length : fin_sum_fin_equiv.symm
  ... ≃ fin t₁.length ⊕ fin t₂.length : equiv.sum_congr h₁.some h₂.some
  ... ≃ fin (t₁.length + t₂.length) : fin_sum_fin_equiv in
⟨e, begin
  assume i,
  refine fin.add_cases _ _ i,
  { assume i,
    simpa [top, bot] using h₁.some_spec i },
  { assume i,
    simpa [top, bot] using h₂.some_spec i }
end⟩

protected lemma snoc
  {s₁ s₂ : composition_series X}
  {x₁ x₂ : X}
  {hsat₁ : is_maximal s₁.top x₁}
  {hsat₂ : is_maximal s₂.top x₂}
  (hequiv : equivalent s₁ s₂)
  (htop : iso (s₁.top, x₁) (s₂.top, x₂)) :
  equivalent (s₁.snoc x₁ hsat₁) (s₂.snoc x₂ hsat₂) :=
let e : fin s₁.length.succ ≃ fin s₂.length.succ :=
  calc fin (s₁.length + 1) ≃ option (fin s₁.length) : fin_succ_equiv_last
  ... ≃ option (fin s₂.length) : functor.map_equiv option hequiv.some
  ... ≃ fin (s₂.length + 1) : fin_succ_equiv_last.symm in
⟨e,  λ i, begin
  refine fin.last_cases _ _ i,
  { simpa [top] using htop },
  { assume i,
    simpa [fin.succ_cast_succ] using hequiv.some_spec i }
end⟩

lemma length_eq {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) : s₁.length = s₂.length :=
by simpa using fintype.card_congr h.some

lemma snoc_snoc_swap
  {s : composition_series X}
  {x₁ x₂ y₁ y₂ : X}
  {hsat₁ : is_maximal s.top x₁}
  {hsat₂ : is_maximal s.top x₂}
  {hsaty₁ : is_maximal (snoc s x₁ hsat₁).top y₁}
  {hsaty₂ : is_maximal (snoc s x₂ hsat₂).top y₂}
  (hr₁ : iso (s.top, x₁) (x₂, y₂))
  (hr₂ : iso (x₁, y₁) (s.top, x₂)) :
  equivalent
    (snoc (snoc s x₁ hsat₁) y₁ hsaty₁)
    (snoc (snoc s x₂ hsat₂) y₂ hsaty₂) :=
let e : fin (s.length + 1 + 1) ≃ fin (s.length + 1 + 1) :=
equiv.swap (fin.last _) (fin.cast_succ (fin.last _)) in
have h1 : ∀ {i : fin s.length},
  i.cast_succ.cast_succ ≠ (fin.last _).cast_succ,
  from λ _, ne_of_lt (by simp [fin.cast_succ_lt_last]),
have h2 : ∀ {i : fin s.length},
  i.cast_succ.cast_succ ≠ (fin.last _),
  from λ _, ne_of_lt (by simp [fin.cast_succ_lt_last]),
⟨e, begin
  intro i,
  dsimp only [e],
  refine fin.last_cases _ (λ i, _) i,
  { erw [equiv.swap_apply_left, snoc_cast_succ, snoc_last, fin.succ_last, snoc_last,
      snoc_cast_succ, snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
      fin.succ_last, snoc_last],
    exact hr₂ },
  { refine fin.last_cases _ (λ i, _) i,
    { erw [equiv.swap_apply_right, snoc_cast_succ, snoc_cast_succ,
        snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
        fin.succ_last, snoc_last, snoc_last, fin.succ_last, snoc_last],
      exact hr₁ },
    { erw [equiv.swap_apply_of_ne_of_ne h2 h1, snoc_cast_succ, snoc_cast_succ,
        snoc_cast_succ, snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
        fin.succ_cast_succ, snoc_cast_succ, snoc_cast_succ, snoc_cast_succ],
      exact (s.step i).iso_refl } }
end⟩

end equivalent

lemma length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁ : s₁.length = 0) : s₂.length = 0 :=
begin
  have : s₁.bot = s₁.top,
    from congr_arg s₁ (fin.ext (by simp [hs₁])),
  have : (fin.last s₂.length) = (0 : fin s₂.length.succ),
    from s₂.injective (hb.symm.trans (this.trans ht)).symm,
  simpa [fin.ext_iff]
end

lemma length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  0 < s₁.length → 0 < s₂.length :=
not_imp_not.1 begin
  simp only [pos_iff_ne_zero, ne.def, not_iff_not, not_not],
  exact length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb.symm ht.symm
end

lemma eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁0 : s₁.length = 0) :
  s₁ = s₂ :=
have ∀ x, x ∈ s₁ ↔ x = s₁.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero hs₁0 hx s₁.top_mem, λ hx, hx.symm ▸ s₁.top_mem⟩,
have ∀ x, x ∈ s₂ ↔ x = s₂.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero
      (length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hs₁0)
    hx s₂.top_mem, λ hx, hx.symm ▸ s₂.top_mem⟩,
by { ext, simp * }

/-- Given a `composition_series`, `s`, and an element `x`
such that `x` is maximal inside `s.top` there is a series, `t`,
such that `t.top = x`, `t.bot = s.bot`
and `snoc t s.top _` is equivalent to `s`. -/
lemma exists_top_eq_snoc_equivalant (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : s.bot ≤ x) :
  ∃ t : composition_series X, t.bot = s.bot ∧ t.length + 1 = s.length ∧
    ∃ htx : t.top = x, equivalent s (snoc t s.top (htx.symm ▸ hm)) :=
begin
  induction hn : s.length with n ih generalizing s x,
  { exact (ne_of_gt (lt_of_le_of_lt hb (lt_of_is_maximal hm))
      (forall_mem_eq_of_length_eq_zero hn s.top_mem s.bot_mem)).elim },
  { have h0s : 0 < s.length, from hn.symm ▸ nat.succ_pos _,
    by_cases hetx : s.erase_top.top = x,
    { use s.erase_top,
      simp [← hetx, hn] },
    { have imxs : is_maximal (x ⊓ s.erase_top.top) s.erase_top.top,
        from is_maximal_of_eq_inf x s.top rfl (ne.symm hetx) hm
          (is_maximal_erase_top_top h0s),
      have := ih _ _ imxs (le_inf (by simpa) (le_top_of_mem s.erase_top.bot_mem)) (by simp [hn]),
      rcases this with ⟨t, htb, htl, htt, hteqv⟩,
      have hmtx : is_maximal t.top x,
        from is_maximal_of_eq_inf s.erase_top.top s.top
          (by rw [inf_comm, htt]) hetx
          (is_maximal_erase_top_top h0s) hm,
      use snoc t x hmtx,
      refine ⟨by simp [htb], by simp [htl], by simp, _⟩,
      have : s.equivalent ((snoc t s.erase_top.top (htt.symm ▸ imxs)).snoc s.top
        (by simpa using is_maximal_erase_top_top h0s)),
      { conv_lhs { rw eq_snoc_erase_top h0s },
        exact equivalent.snoc hteqv
          (by simpa using (is_maximal_erase_top_top h0s).iso_refl) },
      refine this.trans _,
      refine equivalent.snoc_snoc_swap _ _,
      { exact iso_symm (second_iso_of_eq hm
          (sup_eq_of_is_maximal hm
            (is_maximal_erase_top_top h0s)
            (ne.symm hetx))
          htt.symm) },
      { exact second_iso_of_eq (is_maximal_erase_top_top h0s)
          (sup_eq_of_is_maximal
            (is_maximal_erase_top_top h0s)
            hm hetx)
          (by rw [inf_comm, htt]) } } }
end

/-- The **Jordan-Hölder** theorem, stated for any `jordan_holder_lattice`.
If two composition series start and finish at the same place, they are equivalent. -/
theorem jordan_holder (s₁ s₂ : composition_series X)
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  equivalent s₁ s₂ :=
begin
  induction hle : s₁.length with n ih generalizing s₁ s₂,
  { rw [eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hle] },
  { have h0s₂ : 0 < s₂.length,
      from length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos hb ht (hle.symm ▸ nat.succ_pos _),
    rcases exists_top_eq_snoc_equivalant s₁ s₂.erase_top.top
      (ht.symm ▸ is_maximal_erase_top_top h0s₂)
      (hb.symm ▸ s₂.bot_erase_top ▸ bot_le_of_mem (top_mem _)) with ⟨t, htb, htl, htt, hteq⟩,
    have := ih t s₂.erase_top (by simp [htb, ← hb]) htt (nat.succ_inj'.1 (htl.trans hle)),
    refine hteq.trans _,
    conv_rhs { rw [eq_snoc_erase_top h0s₂] },
    simp only [ht],
    exact equivalent.snoc this
      (by simp [htt, (is_maximal_erase_top_top h0s₂).iso_refl]) }
end

end composition_series


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Johan Commelin, Patrick Massot
-/

import ring_theory.valuation.basic
import ring_theory.ideal.quotient_operations

/-!
# The valuation on a quotient ring

The support of a valuation `v : valuation R Γ₀` is `supp v`. If `J` is an ideal of `R`
with `h : J ⊆ supp v` then the induced valuation
on R / J = `ideal.quotient J` is `on_quot v h`.

-/

namespace valuation

variables {R Γ₀ : Type*} [comm_ring R] [linear_ordered_comm_monoid_with_zero Γ₀]
variables (v : valuation R Γ₀)

/-- If `hJ : J ⊆ supp v` then `on_quot_val hJ` is the induced function on R/J as a function.
Note: it's just the function; the valuation is `on_quot hJ`. -/
def on_quot_val {J : ideal R} (hJ : J ≤ supp v) :
  R ⧸ J → Γ₀ :=
λ q, quotient.lift_on' q v $ λ a b h,
calc v a = v (b + -(-a + b)) : by simp
     ... = v b             :
      v.map_add_supp b $ (ideal.neg_mem_iff _).2 $ hJ $ quotient_add_group.left_rel_apply.mp h

/-- The extension of valuation v on R to valuation on R/J if J ⊆ supp v -/
def on_quot {J : ideal R} (hJ : J ≤ supp v) :
  valuation (R ⧸ J) Γ₀ :=
{ to_fun := v.on_quot_val hJ,
  map_zero' := v.map_zero,
  map_one'  := v.map_one,
  map_mul'  := λ xbar ybar, quotient.ind₂' v.map_mul xbar ybar,
  map_add_le_max'  := λ xbar ybar, quotient.ind₂' v.map_add xbar ybar }

@[simp] lemma on_quot_comap_eq {J : ideal R} (hJ : J ≤ supp v) :
  (v.on_quot hJ).comap (ideal.quotient.mk J) = v :=
ext $ λ r, rfl

lemma self_le_supp_comap (J : ideal R) (v : valuation (R ⧸ J) Γ₀) :
  J ≤ (v.comap (ideal.quotient.mk J)).supp :=
by { rw [comap_supp, ← ideal.map_le_iff_le_comap], simp }

@[simp] lemma comap_on_quot_eq (J : ideal R) (v : valuation (R ⧸ J) Γ₀) :
  (v.comap (ideal.quotient.mk J)).on_quot (v.self_le_supp_comap J) = v :=
ext $ by { rintro ⟨x⟩, refl }

/-- The quotient valuation on R/J has support supp(v)/J if J ⊆ supp v. -/
lemma supp_quot {J : ideal R} (hJ : J ≤ supp v) :
  supp (v.on_quot hJ) = (supp v).map (ideal.quotient.mk J) :=
begin
  apply le_antisymm,
  { rintro ⟨x⟩ hx,
    apply ideal.subset_span,
    exact ⟨x, hx, rfl⟩ },
  { rw ideal.map_le_iff_le_comap,
    intros x hx, exact hx }
end

lemma supp_quot_supp : supp (v.on_quot le_rfl) = 0 :=
by { rw supp_quot, exact ideal.map_quotient_self _ }

end valuation

namespace add_valuation

variables {R Γ₀ : Type*}
variables [comm_ring R] [linear_ordered_add_comm_monoid_with_top Γ₀]
variables (v : add_valuation R Γ₀)

local attribute [reducible] add_valuation

/-- If `hJ : J ⊆ supp v` then `on_quot_val hJ` is the induced function on R/J as a function.
Note: it's just the function; the valuation is `on_quot hJ`. -/
def on_quot_val {J : ideal R} (hJ : J ≤ supp v) : (R ⧸ J) → Γ₀ := v.on_quot_val hJ

/-- The extension of valuation v on R to valuation on R/J if J ⊆ supp v -/
def on_quot {J : ideal R} (hJ : J ≤ supp v) :
  add_valuation (R ⧸ J) Γ₀ :=
v.on_quot hJ

@[simp] lemma on_quot_comap_eq {J : ideal R} (hJ : J ≤ supp v) :
  (v.on_quot hJ).comap (ideal.quotient.mk J) = v :=
v.on_quot_comap_eq hJ

lemma comap_supp {S : Type*} [comm_ring S] (f : S →+* R) :
  supp (v.comap f) = ideal.comap f v.supp :=
v.comap_supp f

lemma self_le_supp_comap (J : ideal R) (v : add_valuation (R ⧸ J) Γ₀) :
  J ≤ (v.comap (ideal.quotient.mk J)).supp :=
v.self_le_supp_comap J

@[simp] lemma comap_on_quot_eq (J : ideal R) (v : add_valuation (R ⧸ J) Γ₀) :
  (v.comap (ideal.quotient.mk J)).on_quot (v.self_le_supp_comap J) = v :=
v.comap_on_quot_eq J

/-- The quotient valuation on R/J has support supp(v)/J if J ⊆ supp v. -/
lemma supp_quot {J : ideal R} (hJ : J ≤ supp v) :
  supp (v.on_quot hJ) = (supp v).map (ideal.quotient.mk J) :=
v.supp_quot hJ

lemma supp_quot_supp : supp (v.on_quot le_rfl) = 0 :=
v.supp_quot_supp

end add_valuation


import data.complex.basic data.real.cau_seq tactic.norm_num data.nat.basic tactic.ring algebra.archimedean
section a
open real nat is_absolute_value
noncomputable theory
local attribute [instance, priority 0] classical.prop_decidable

lemma pow_inv' {α : Type*} [discrete_field α] (a : α) (n : ℕ) : (monoid.pow a n)⁻¹ = monoid.pow a⁻¹ n := begin
  induction n with n' hi,
  simp!,
  simp!,rw [mul_inv',mul_comm,hi],
end

lemma pow_abs {α : Type*} [decidable_linear_ordered_comm_ring α] (a : α) (n : ℕ) : monoid.pow (abs a) n = abs (monoid.pow a n) := begin
  induction n with n' hi,
  simp!, simp!,rw [hi,abs_mul],
end

lemma pow_incrs_of_gt_one {α : Type*}  [linear_ordered_semiring α] {x : α} {n m : ℕ} : 1 < x → n < m → monoid.pow x n < monoid.pow x m := begin
  assume x1 nm,revert n,
  induction m with m' hi,assume n nm,
  exact absurd nm (not_lt_of_ge (zero_le n)),assume n nm,
  cases m' with m'',
  rw eq_zero_of_le_zero (le_of_lt_succ nm),simpa!,
  cases n with n',
  simp!, simp! at hi,
  rw ←one_mul (1 : α),
  exact mul_lt_mul x1 (le_of_lt (@hi 0 dec_trivial)) (by norm_num) (le_of_lt(lt_trans (by norm_num) x1)),
  have hi' := @hi n' (lt_of_succ_lt_succ nm),
  suffices : x * monoid.pow x n' < x * monoid.pow x (succ m''),
    simpa [monoid.pow],
  refine mul_lt_mul' (le_refl x) hi' _ (lt_trans (by norm_num) x1),
  clear hi hi' nm m'',
  induction n' with n'' hi,
  simp!,norm_num,
  simp!,exact mul_nonneg (le_of_lt (lt_trans (by norm_num) x1)) hi,
end

lemma pow_dcrs_of_lt_one_of_pos {α : Type*}  [discrete_linear_ordered_field α] {x : α} {n m : ℕ} : x < 1 → 0 < x → n < m → monoid.pow x m < monoid.pow x n := begin
  assume x1 x0 nm,rw [←inv_lt_inv,pow_inv',pow_inv'],
  have x11 : 1 < x⁻¹ ,rw lt_inv,simpa,{norm_num},exact x0,
  exact pow_incrs_of_gt_one x11 nm,
  exact pow_pos x0 _,exact pow_pos x0 _,
end

lemma pow_unbounded_of_gt_one {α : Type*} [discrete_linear_ordered_field α] [archimedean α] {x : α} (y : α) : 1 < x → ∃ n : ℕ, y < monoid.pow x n := begin
  assume x1,
  have : ∀ m : ℕ, (x - 1) * m < monoid.pow x m ∧ 1 ≤ monoid.pow x m,
    assume m, induction m with m' hi,
    simp,{norm_num},
    rw [←add_one,nat.cast_add,nat.cast_one], simp only [mul_add,monoid.pow],rw mul_one,
    have : x * monoid.pow x m' = monoid.pow x m' + (x - 1) * monoid.pow x m',
      rw add_comm,simp[mul_add,add_mul],
    rw this,split,
    refine add_lt_add_of_lt_of_le hi.left _,rw ←sub_pos at x1,
    have :=mul_le_mul (le_refl (x - 1)) hi.right (by norm_num) (le_of_lt x1),rwa mul_one at this,
    rw [←this, ←one_mul (1 : α)],
    exact mul_le_mul (le_of_lt x1) hi.right (by norm_num) (le_of_lt (lt_trans (by norm_num) x1)),
  cases exists_nat_gt (y / (x - 1)) with n hn,
  existsi n,rw [div_lt_iff,mul_comm] at hn,
  exact lt_trans hn (this n).left,rwa sub_pos,
end

-- defined myself rather than using finset.sum due to ease of inductive proofs. May have been better to define
-- using finset.sum and prove : series f (succ n) = series f n + f n
def series {α : Type*} [has_add α] [has_zero α] (f : ℕ → α) : ℕ → α
| 0        := 0
| (succ n) := series n + f n

lemma series_mul {α : Type*} [semiring α] (f : ℕ → α) (a : α) (n : ℕ) : a * series f n = series (λ m, a * f m) n := begin
  induction n with n' hi,
  simp!,simp!,rw [mul_add,hi],
end
lemma series_add {α : Type*} [add_comm_monoid α] (f g : ℕ → α) (n : ℕ) : series f n + series g n = series (λ m, f m + g m) n := begin
  induction n with n' hi,simp!,simp![hi],
end

lemma series_neg {α : Type*} [ring α] (f : ℕ → α) (n : ℕ) : -series f n = series (λ m, -f m) n := begin
  induction n with n' hi, simp!,simp![hi],
end

lemma geo_series_eq {α : Type*} [field α] (x : α) (n : ℕ) : x ≠ 1 → series (monoid.pow x) n = (1 - monoid.pow x n) / (1 - x) := begin
  assume x1,have x1' : 1 + -x ≠ 0,assume h,rw [eq_comm, ←sub_eq_iff_eq_add] at h,simp at h,trivial,
  induction n with n' hi,
  simp!,rw eq_div_iff_mul_eq,simpa,
  simp!,rw hi,simp, rw [add_mul,div_mul_cancel _ x1',mul_add],ring,simp [x1'],
end

lemma geo_series_cau {α : Type*} [discrete_linear_ordered_field α] [archimedean α] (x : α) : abs x < 1 → is_cau_seq abs (series (monoid.pow x)) := begin
  assume x1, have : series (monoid.pow x) = λ n,(1 - monoid.pow x n) / (1 - x),
    apply funext,assume n,refine geo_series_eq x n _ ,assume h, rw h at x1,exact absurd x1 (by norm_num),rw this,
  have absx : 0 < abs (1 - x),refine abs_pos_of_ne_zero _,assume h,rw sub_eq_zero_iff_eq at h,rw ←h at x1,
  have : ¬abs (1 : α) < 1,norm_num,trivial,simp at absx,
  cases classical.em (x = 0),rw h,simp[monoid.pow],assume ε ε0,existsi 1,assume j j1,simpa!,
  cases j,exact absurd j1 dec_trivial,simpa!,
  have x2: 1 < (abs x)⁻¹,rw lt_inv,simpa,{norm_num},exact abs_pos_of_ne_zero h,
  assume ε ε0,cases pow_unbounded_of_gt_one (2 / (ε * abs (1 - x))) x2 with i hi,
  rw [←pow_inv',lt_inv] at hi,
  existsi i,assume j ji,rw [inv_eq_one_div,div_div_eq_mul_div,one_mul,lt_div_iff (by norm_num : (0 : α) < 2)] at hi,
  rw [div_sub_div_same,abs_div,div_lt_iff],
  refine lt_of_le_of_lt _ hi,
  simp,
  refine le_trans (abs_add _ _) _,
  have : monoid.pow (abs x) i * 2 = monoid.pow (abs x) i + monoid.pow (abs x) i,ring,
  rw this,
  refine add_le_add _ _,rw ←pow_abs,
  rw [abs_neg,←pow_abs],
  cases lt_or_eq_of_le ji,
  exact le_of_lt (pow_dcrs_of_lt_one_of_pos x1 (abs_pos_of_ne_zero h) h_1),
  rw h_1,assumption,
  refine div_pos _ _,{norm_num},
  refine mul_pos ε0 _,simpa,
  exact pow_pos (abs_pos_of_ne_zero h) _,
end

lemma geo_series_const_cau {α : Type*} [discrete_linear_ordered_field α] [archimedean α] (a x : α) : abs x < 1 → is_cau_seq abs (series (λ n, a * monoid.pow x n)) := begin
  assume x1 ε ε0,
  cases classical.em (a = 0),
  existsi 0,intros,rw [←series_mul],induction j,simp!,assumption,rw h,simpa!,
  cases geo_series_cau x x1 (ε / abs a) (div_pos ε0 (abs_pos_of_ne_zero h)) with i hi,
  existsi i,assume j ji,rw [←series_mul,←series_mul,←mul_sub,abs_mul,mul_comm,←lt_div_iff],exact hi j ji,exact abs_pos_of_ne_zero h,
end

lemma series_cau_of_abv_le_cau {α : Type*} {β : Type*} [discrete_linear_ordered_field α] [ring β] {f : ℕ → β}
    {g : ℕ → α} {abv : β → α} [is_absolute_value abv] (n : ℕ) : (∀ m, n ≤ m → abv (f m) ≤ g m) →
    is_cau_seq abs (series g) → is_cau_seq abv (series f) := begin
  assume hm hg ε ε0,cases hg (ε / 2) (div_pos ε0 (by norm_num)) with i hi,
  existsi max n i,
  assume j ji,
  have hi₁ := hi j (le_trans (le_max_right n i) ji),
  have hi₂ := hi (max n i) (le_max_right n i),
  have sub_le := abs_sub_le (series g j) (series g i) (series g (max n i)),
  have := add_lt_add hi₁ hi₂,rw abs_sub (series g (max n i)) at this,
  have ε2 : ε / 2 + ε / 2 = ε,ring,
  rw ε2 at this,
  refine lt_of_le_of_lt _ this,
  refine le_trans _ sub_le,
  refine le_trans _ (le_abs_self _),
  generalize hk : j - max n i = k,clear this ε2 hi₂ hi₁ hi ε0 ε hg sub_le,
  rw nat.sub_eq_iff_eq_add ji at hk,rw hk, clear hk ji j,
  induction k with k' hi,simp,rw abv_zero abv,
  rw succ_add,unfold series,
  rw [add_comm,add_sub_assoc],
  refine le_trans (abv_add _ _ _) _,
  rw [add_comm (series g (k' + max n i)),add_sub_assoc],
  refine add_le_add _ _,
  refine hm _ _,rw ←zero_add n,refine add_le_add _ _,exact zero_le _,
  simp, exact le_max_left _ _,assumption,
end

-- The form of ratio test with  0 ≤ r < 1, and abv (f (succ m)) ≤ r * abv (f m) handled zero terms of series the best
lemma series_ratio_test {α : Type*} {β : Type*} [discrete_linear_ordered_field α]  [ring β]
    [archimedean α] {abv : β → α} [is_absolute_value abv] {f : ℕ → β} (n : ℕ) (r : α) :
    0 ≤ r → r < 1 → (∀ m, n ≤ m → abv (f (succ m)) ≤ r * abv (f m)) → is_cau_seq abv (series f)
  := begin
  assume r0 r1 h,
  refine series_cau_of_abv_le_cau (succ n) _ (geo_series_const_cau (abv (f (succ n)) * monoid.pow r⁻¹ (succ n)) r _),
  assume m mn,
  generalize hk : m - (succ n) = k,rw nat.sub_eq_iff_eq_add mn at hk,
  cases classical.em (r = 0) with r_zero r_pos,have m_pos := lt_of_lt_of_le (succ_pos n) mn,
  have := pred_le_pred mn,simp at this,
  have := h (pred m) this,simp[r_zero,succ_pred_eq_of_pos m_pos] at this,
  refine le_trans this _,refine mul_nonneg _ _,refine mul_nonneg (abv_nonneg _ _) (pow_nonneg (inv_nonneg.mpr r0) _),exact pow_nonneg r0 _,
  replace r_pos : 0 < r,cases lt_or_eq_of_le r0 with h h,exact h,exact absurd h.symm r_pos,
  revert m n,
  induction k with k' hi,assume m n h mn hk,
  rw [hk,zero_add,mul_right_comm,←pow_inv',←div_eq_mul_inv,mul_div_cancel],
  exact (ne_of_lt (pow_pos r_pos _)).symm,
  assume m n h mn hk,rw [hk,succ_add],
  have kn : k' + (succ n) ≥ (succ n), rw ←zero_add (succ n),refine add_le_add _ _,exact zero_le _,simp,
  replace hi := hi (k' + (succ n)) n h kn rfl,
  rw [(by simp!;ring : monoid.pow r (succ (k' + succ n)) = monoid.pow r (k' + succ n) * r),←mul_assoc],
  replace h := h (k' + succ n) (le_of_succ_le kn),rw mul_comm at h,
  exact le_trans h (mul_le_mul_of_nonneg_right hi r0),
  rwa abs_of_nonneg r0,
end
lemma series_cau_of_abv_cau {α : Type*} {β : Type*} [discrete_linear_ordered_field α] [ring β] {abv : β → α} {f : ℕ → β}
    [is_absolute_value abv] : is_cau_seq abs (series (λ n, abv (f n))) → is_cau_seq abv (series f) :=
   λ h, series_cau_of_abv_le_cau 0 (λ n h, le_refl _) h

lemma series_merten {α : Type*} {β : Type*} [discrete_linear_ordered_field α] [ring β] {a b : ℕ → β}
    {abv : β → α} [is_absolute_value abv] : is_cau_seq abv (series a) → is_cau_seq abs
    (series (λ n, abv (b n))) → ∀ ε > 0, ∃ i : ℕ, ∀ j ≥ i, abv (series a j * series b j -
    series (λ n, series(λ m, a m * b (n - m)) n) j) < ε := begin
  assume ε ε0,
  generalize hB : (λ k : ℕ, series b k) = B,
  generalize hA : (λ k : ℕ, series a k) = A,
  have : ∀ i : ℕ, series (λ n, series(λ m, a m * b (n - m)) n) i = series (λ n, a (i - n) * B i) i,
    assume i,
    induction i with i' hi,rw ←hB,simp!,
    unfold series,rw [hi,series_add],clear hi,
    induction i' with i₂,
    simp!,rw ←hB,simp!,

end
end a
open nat
lemma complex.exp_series_cau (z : ℂ) : is_cau_seq complex.abs (series (λ m, monoid.pow z m / fact m)) := begin
  cases exists_nat_gt (complex.abs z) with n hn,have n_pos : (0 : ℝ) < n := lt_of_le_of_lt (complex.abs_nonneg _) hn,
  refine series_ratio_test n (complex.abs z / n) _ _ _,exact div_nonneg_of_nonneg_of_pos (complex.abs_nonneg _) n_pos,rwa [div_lt_iff n_pos,one_mul],
  assume m mn,
  unfold monoid.pow fact,simp only [complex.abs_div,complex.abs_mul,div_eq_mul_inv,mul_inv',nat.cast_mul,complex.abs_inv],
  have : complex.abs z * complex.abs (monoid.pow z m) * ((complex.abs ↑(fact m))⁻¹ * (complex.abs ↑(succ m))⁻¹) = complex.abs z * complex.abs (monoid.pow z m) * (complex.abs ↑(fact m))⁻¹ * (complex.abs ↑(succ m))⁻¹,ring,rw this,
  have : complex.abs z * (↑n)⁻¹ * (complex.abs (monoid.pow z m) * (complex.abs ↑(fact m))⁻¹) = complex.abs z * complex.abs (monoid.pow z m) * (complex.abs ↑(fact m))⁻¹ * (↑n)⁻¹,ring,rw this,
  rw[(by simp : (succ m : ℂ) = ((succ m : ℝ) : ℂ)),complex.abs_of_nonneg],
  refine mul_le_mul_of_nonneg_left _ _,
  rw [inv_le_inv,nat.cast_le],exact le_succ_of_le mn,
  rw [←nat.cast_zero,nat.cast_lt],exact succ_pos _,exact n_pos,rw[←complex.abs_inv,←complex.abs_mul,←complex.abs_mul],
  exact complex.abs_nonneg _,rw[←nat.cast_zero,nat.cast_le],exact zero_le _,
end

def exp (z : ℂ) : ℂ := complex.lim (series (λ n, monoid.pow z n / fact n))

def sin (z : ℂ) : ℂ := (exp (⟨0, 1⟩ * z) - exp (-⟨0, 1⟩ * z)) / (2 * ⟨0, 1⟩)

def cos (z : ℂ) : ℂ := (exp (⟨0, 1⟩ * z) + exp (-⟨0, 1⟩ * z)) / 2

def tan (z : ℂ) : ℂ := sin z / cos z

def sinh (z : ℂ) : ℂ := (exp z - exp (-z)) / 2

def cosh (z : ℂ) : ℂ := (exp z + exp (-z)) / 2

def tanh (z : ℂ) : ℂ := sinh z / cosh z

lemma complex.re_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq complex.abs f) (z : ℂ) :
    cau_seq.const complex.abs z ≈ ⟨f, hf⟩ → cau_seq.const _root_.abs z.re ≈  ⟨(λ (n : ℕ), (f n).re),
    complex.is_cau_seq_re ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_re,←complex.add_re],
  exact lt_of_le_of_lt (complex.abs_re_le_abs _) hi,
end

lemma complex.im_const_equiv_of_const_equiv {f : ℕ → ℂ} (hf : is_cau_seq complex.abs f) (z : ℂ) :
    cau_seq.const complex.abs z ≈ ⟨f, hf⟩ → cau_seq.const _root_.abs z.im ≈  ⟨(λ (n : ℕ), (f n).im),
    complex.is_cau_seq_im ⟨f,hf⟩⟩ := begin
  assume h,assume ε ε0,cases h ε ε0 with i hi,existsi i,assume j ji,
  replace hi := hi j ji, simp at *, rw [←complex.neg_im,←complex.add_im],
  exact lt_of_le_of_lt (complex.abs_im_le_abs _) hi,
end

lemma complex.lim_const {f : ℕ → ℂ} (hf : is_cau_seq complex.abs f) (z : ℂ) : z = complex.lim f ↔
    cau_seq.const complex.abs z ≈ ⟨f, hf⟩ := begin
  split,have := complex.equiv_lim ⟨f, hf⟩,simp at this,
  assume h,rw h, exact setoid.symm this,assume h,
  unfold complex.lim,cases z with zre zim,simp,
  split, have := real.equiv_lim ⟨(λ (n : ℕ), (f n).re), complex.is_cau_seq_re ⟨f,hf⟩⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.re_const_equiv_of_const_equiv hf {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
  have := real.equiv_lim ⟨(λ (n : ℕ), (f n).im), complex.is_cau_seq_im ⟨f,hf⟩⟩,
  rw ←cau_seq.const_equiv,simp at this,
  have hf := complex.im_const_equiv_of_const_equiv hf {re := zre, im := zim} h,simp at hf,
  exact setoid.trans hf this,
end

lemma complex.lim_eq_lim_iff_equiv {f g : ℕ → ℂ} (hf : is_cau_seq complex.abs f)
    (hg : is_cau_seq complex.abs g) : complex.lim f = complex.lim g ↔ @has_equiv.equiv
    (cau_seq ℂ complex.abs) _ ⟨f, hf⟩ ⟨g, hg⟩ := begin
  have h₁:= complex.lim_const hg (complex.lim f),
  have h₂:= complex.lim_const hf (complex.lim g),
  split,assume h, simp * at *,
  exact setoid.trans (setoid.symm h₂) h₁,
  assume h,rw h₁,have := complex.equiv_lim ⟨f, hf⟩,simp at this,
  exact setoid.trans (setoid.symm this) h,
end

@[simp] lemma exp_zero : exp 0 = 1 := begin
  unfold exp,rw [eq_comm,complex.lim_const (complex.exp_series_cau 0)],
  assume ε ε0,existsi 1,assume j j1,
  induction j with j' hi,exact absurd j1 dec_trivial,
  cases j' with j₂,simpa!,replace hi := hi dec_trivial,simp! at *,assumption,
end