/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import field_theory.finite data.zmod.basic algebra.pi_instances

open function finset nat finite_field zmodp

namespace zmodp

variables {p q : ℕ} (hp : nat.prime p) (hq : nat.prime q)

@[simp] lemma card_units_zmodp : fintype.card (units (zmodp p hp)) = p - 1 :=
by rw [card_units, card_zmodp]

theorem fermat_little {p : ℕ} (hp : nat.prime p) {a : zmodp p hp} (ha : a ≠ 0) : a ^ (p - 1) = 1 :=
by rw [← units.mk0_val ha, ← @units.coe_one (zmodp p hp), ← units.coe_pow, ← units.ext_iff,
    ← card_units_zmodp hp, pow_card_eq_one]

lemma euler_criterion_units {x : units (zmodp p hp)} :
  (∃ y : units (zmodp p hp), y ^ 2 = x) ↔ x ^ (p / 2) = 1 :=
hp.eq_two_or_odd.elim
  (λ h, by subst h; revert x; exact dec_trivial)
  (λ hp1, let ⟨g, hg⟩ := is_cyclic.exists_generator (units (zmodp p hp)) in
    let ⟨n, hn⟩ := show x ∈ powers g, from (powers_eq_gpowers g).symm ▸ hg x in
    ⟨λ ⟨y, hy⟩, by rw [← hy, ← pow_mul, two_mul_odd_div_two hp1,
        ← card_units_zmodp hp, pow_card_eq_one],
    λ hx, have 2 * (p / 2) ∣ n * (p / 2),
        by rw [two_mul_odd_div_two hp1, ← card_units_zmodp hp, ← order_of_eq_card_of_forall_mem_gpowers hg];
        exact order_of_dvd_of_pow_eq_one (by rwa [pow_mul, hn]),
      let ⟨m, hm⟩ := dvd_of_mul_dvd_mul_right (nat.div_pos hp.ge_two dec_trivial) this in
      ⟨g ^ m, by rwa [← pow_mul, mul_comm, ← hm]⟩⟩)

lemma euler_criterion {a : zmodp p hp} (ha : a ≠ 0) :
  (∃ y : zmodp p hp, y ^ 2 = a) ↔ a ^ (p / 2) = 1 :=
⟨λ ⟨y, hy⟩,
  have hy0 : y ≠ 0, from λ h, by simp [h, _root_.zero_pow (succ_pos 1)] at hy; cc,
  by simpa using (units.ext_iff.1 $ (euler_criterion_units hp).1 ⟨units.mk0 _ hy0, show _ = units.mk0 _ ha,
    by rw [units.ext_iff]; simpa⟩),
λ h, let ⟨y, hy⟩ := (euler_criterion_units hp).2 (show units.mk0 _ ha ^ (p / 2) = 1, by simpa [units.ext_iff]) in
  ⟨y, by simpa [units.ext_iff] using hy⟩⟩

lemma exists_pow_two_eq_neg_one_iff_mod_four_ne_three :
  (∃ y : zmodp p hp, y ^ 2 = -1) ↔ p % 4 ≠ 3 :=
have (-1 : zmodp p hp) ≠ 0, from mt neg_eq_zero.1 one_ne_zero,
hp.eq_two_or_odd.elim (λ hp, by subst hp; exact dec_trivial)
  (λ hp1, (mod_two_eq_zero_or_one (p / 2)).elim
    (λ hp2, begin
      rw [euler_criterion hp this, neg_one_pow_eq_pow_mod_two, hp2, _root_.pow_zero,
        eq_self_iff_true, true_iff],
      assume h,
      rw [← nat.mod_mul_right_div_self, show 2 * 2 = 4, from rfl, h] at hp2,
      exact absurd hp2 dec_trivial,
    end)
    (λ hp2, begin
      rw [euler_criterion hp this, neg_one_pow_eq_pow_mod_two, hp2, _root_.pow_one,
        iff_false_intro (zmodp.ne_neg_self hp hp1 one_ne_zero).symm, false_iff,
        not_not],
      rw [← nat.mod_mul_right_div_self, show 2 * 2 = 4, from rfl] at hp2,
      rw [← nat.mod_mul_left_mod _ 2, show 2 * 2 = 4, from rfl] at hp1,
      have hp4 : p % 4 < 4, from nat.mod_lt _ dec_trivial,
      revert hp1 hp2, revert hp4,
      generalize : p % 4 = k,
      revert k, exact dec_trivial
    end))

lemma pow_div_two_eq_neg_one_or_one {a : zmodp p hp} (ha : a ≠ 0) : a ^ (p / 2) = 1 ∨ a ^ (p / 2) = -1 :=
hp.eq_two_or_odd.elim
  (λ h, by revert a ha; subst h; exact dec_trivial)
  (λ hp1, by rw [← mul_self_eq_one_iff, ← _root_.pow_add, ← two_mul, two_mul_odd_div_two hp1];
    exact fermat_little hp ha)

@[simp] lemma wilsons_lemma {p : ℕ} (hp : nat.prime p) : (fact (p - 1) : zmodp p hp) = -1 :=
begin
  rw [← finset.prod_range_id_eq_fact, ← @units.coe_one (zmodp p hp), ← units.coe_neg,
    ← @prod_univ_units_id_eq_neg_one (zmodp p hp),
    ← prod_hom (coe : units (zmodp p hp) → zmodp p hp),
    ← prod_hom (coe : ℕ → zmodp p hp)],
  exact eq.symm (prod_bij
    (λ a _, (a : zmodp p hp).1) (λ a ha, mem_erase.2
      ⟨λ h, units.coe_ne_zero a $ fin.eq_of_veq h,
      by rw [mem_range, ← succ_sub hp.pos, succ_sub_one]; exact a.1.2⟩)
    (λ a _, by simp) (λ _ _ _ _, units.ext_iff.2 ∘ fin.eq_of_veq)
    (λ b hb,
      have b ≠ 0 ∧ b < p, by rwa [mem_erase, mem_range, ← succ_sub hp.pos, succ_sub_one] at hb,
      ⟨units.mk0 _ (show (b : zmodp p hp) ≠ 0, from fin.ne_of_vne $
        by rw [zmod.val_cast_nat, ← @nat.cast_zero (zmodp p hp), zmod.val_cast_nat];
        simp [mod_eq_of_lt this.2, this.1]), mem_univ _,
      by simp [val_cast_of_lt hp this.2]⟩))
end

@[simp] lemma prod_range_prime_erase_zero {p : ℕ} (hp : nat.prime p) :
  ((range p).erase 0).prod (λ x, (x : zmodp p hp)) = -1 :=
by conv in (range p) { rw [← succ_sub_one p, succ_sub hp.pos] };
  rw [prod_hom (coe : ℕ → zmodp p hp),
    finset.prod_range_id_eq_fact, wilsons_lemma]

end zmodp

namespace quadratic_reciprocity_aux

variables {p q : ℕ} (hp : nat.prime p) (hq : nat.prime q) (hp1 : p % 2 = 1) (hq1 : q % 2 = 1)
  (hpq : p ≠ q)

include hp hq hp1 hq1 hpq

lemma filter_range_p_mul_q_div_two_eq :
  (range ((p * q) / 2).succ).filter (coprime p) =
  (range (q / 2)).bind (λ x, (erase (range p) 0).image (+ p * x))
  ∪ (erase (range (succ (p / 2))) 0).image (+ q / 2 * p) :=
finset.ext.2 $ λ x,
⟨λ h, have hxp0 : x % p ≠ 0, by rw [ne.def, ← dvd_iff_mod_eq_zero, ← hp.coprime_iff_not_dvd];
    exact (mem_filter.1 h).2,
  mem_union.2 $ or_iff_not_imp_right.2 (λ h₁, mem_bind.2
  ⟨x / p, mem_range.2 $ nat.div_lt_of_lt_mul (by_contradiction
    (λ h₂,
      let ⟨c, hc⟩ := le_iff_exists_add.1 (le_of_not_gt h₂) in
      have hcp : c ≤ p / 2, from @nat.le_of_add_le_add_left (p * (q / 2)) _ _
        (by rw [← hc, ← odd_mul_odd_div_two hp1 hq1]; exact le_of_lt_succ (mem_range.1 (mem_filter.1 h).1)),
      h₁ $ mem_image.2 ⟨c, mem_erase.2 ⟨λ h, hxp0 $ by simp [h, hc],
            mem_range.2 $ lt_succ_of_le $ hcp⟩, by rw hc; simp [mul_comm]⟩)),
    mem_image.2 ⟨x % p, mem_erase.2 $
      by rw [ne.def, ← dvd_iff_mod_eq_zero, ← hp.coprime_iff_not_dvd, mem_range];
      exact ⟨(mem_filter.1 h).2, mod_lt _ hp.pos⟩, nat.mod_add_div _ _⟩⟩),
λ h, mem_filter.2 $
  (mem_union.1 h).elim
  (λ h, let ⟨m, hm₁, hm₂⟩ := mem_bind.1 h in
    let ⟨k, hk₁, hk₂⟩ := mem_image.1 hm₂ in
    ⟨mem_range.2 $ hk₂ ▸ (mul_lt_mul_left (show 0 < 2, from dec_trivial)).1 begin
      rw [mul_succ, two_mul_odd_div_two (nat.odd_mul_odd hp1 hq1), mul_add],
      clear _let_match _let_match,
      exact calc 2 * k + 2 * (p * m) < 2 * p + 2 * (p * m) :
        add_lt_add_right ((mul_lt_mul_left dec_trivial).2 (by simp at hk₁; tauto)) _
      ... = 2 * (p * (m + 1)) : by simp [mul_add, mul_assoc, mul_comm, mul_left_comm]
      ... ≤ 2 * (p * (q / 2)) : (mul_le_mul_left (show 0 < 2, from dec_trivial)).2
        ((mul_le_mul_left hp.pos).2 $ succ_le_of_lt $ mem_range.1 hm₁)
      ... ≤ _ : by rw [mul_left_comm, two_mul_odd_div_two hq1, nat.mul_sub_left_distrib,
            ← nat.sub_add_comm (mul_pos hp.pos hq.pos), add_succ, succ_eq_add_one, nat.add_sub_cancel];
          exact le_trans (nat.sub_le_self _ _) (nat.le_add_right _ _),
    end,
  by rw [nat.prime.coprime_iff_not_dvd hp, ← hk₂, ← nat.dvd_add_iff_left (dvd_mul_right _ _),
       dvd_iff_mod_eq_zero, mod_eq_of_lt]; clear _let_match _let_match; simp at hk₁; tauto⟩)
  (λ h, let ⟨m, hm₁, hm₂⟩ := mem_image.1 h in ⟨mem_range.2 $ hm₂ ▸ begin
    refine (mul_lt_mul_left (show 0 < 2, from  dec_trivial)).1 _,
    rw [mul_succ, two_mul_odd_div_two (nat.odd_mul_odd hp1 hq1), mul_add, ← mul_assoc 2, two_mul_odd_div_two hq1],
    exact calc 2 * m + (q - 1) * p ≤ 2 * (p / 2) + (q - 1) * p :
      add_le_add_right ((mul_le_mul_left dec_trivial).2 (le_of_lt_succ (mem_range.1 (by simp * at *)))) _
    ... < _ : begin rw [two_mul_odd_div_two hp1, nat.mul_sub_right_distrib, one_mul],
        rw [← nat.sub_add_comm hp.pos, nat.add_sub_cancel' (le_mul_of_ge_one_left' (nat.zero_le _) hq.pos), mul_comm],
        exact lt_add_of_pos_right _ dec_trivial
      end,
  end,
  by rw [hp.coprime_iff_not_dvd, dvd_iff_mod_eq_zero, ← hm₂, nat.add_mul_mod_self_right, mod_eq_of_lt
      (lt_of_lt_of_le _ (nat.div_lt_self hp.pos (show 1 < 2, from dec_trivial)))];
    simp at hm₁; clear _let_match; tauto⟩)⟩

lemma prod_filter_range_p_mul_q_div_two_eq :
  (range (q / 2)).prod (λ n, ((range p).erase 0).prod (+ p * n)) *
  ((range (p / 2).succ).erase 0).prod (+ (q / 2) * p) =
  ((range ((p * q) / 2).succ).filter (coprime p)).prod (λ x, x) :=
calc (range (q / 2)).prod (λ n, ((range p).erase 0).prod (+ p * n)) *
  ((range (p / 2).succ).erase 0).prod (+ (q / 2) * p)
    = (range (q / 2)).prod (λ n, (((range p).erase 0).image (+ p * n)).prod (λ x, x)) *
  (((range (p / 2).succ).erase 0).image (+ (q / 2) * p)).prod (λ x, x) :
  by simp only [prod_image (λ _ _ _ _ h, add_right_cancel h)]; refl
... = ((range (q / 2)).bind (λ x, (erase (range p) 0).image (+ p * x))
         ∪ (erase (range (succ (p / 2))) 0).image (+ q / 2 * p)).prod (λ x, x) :
  have h₁ : finset.bind (range (q / 2)) (λ x, ((range p).erase 0).image (+ p * x)) ∩
      image (+ q / 2 * p) (erase (range (succ (p / 2))) 0) = ∅ :=
    eq_empty_iff_forall_not_mem.2 $ λ x, begin
      suffices : ∀ a, a ≠ 0 → a ≤ p / 2 → a + q / 2 * p = x → ∀ b, b < q / 2 →
        ∀ c, c ≠ 0 → c < p → ¬c + p * b = x,
      { simpa [lt_succ_iff] },
      assume a ha0 hap ha b hbq c hc0 hcp hc,
      rw mul_comm at ha,
      rw [← ((nat.div_mod_unique hp.pos).2 ⟨hc, hcp⟩).1,
        ← ((nat.div_mod_unique hp.pos).2 ⟨ha, lt_of_le_of_lt hap
        (nat.div_lt_self hp.pos dec_trivial)⟩).1] at hbq,
      exact lt_irrefl _ hbq
    end,
  have h₂ : ∀ x, x ∈ range (q / 2) → ∀ y, y ∈ range (q / 2) → x ≠ y →
      (erase (range p) 0).image (+ p * x) ∩ image (+ p * y) (erase (range p) 0) = ∅ :=
    λ x hx y hy hxy, begin
      suffices : ∀ z a, a ≠ 0 → a < p → a + p * x = z → ∀ b, b ≠ 0 → b < p → b + p * y ≠ z,
      { simpa [finset.ext] },
      assume z a ha0 hap ha b hb0 hbp hb,
      have : (a + p * x) / p = (b + p * y) / p,
      { rw [ha, hb] },
      rw [nat.add_mul_div_left _ _ hp.pos, nat.add_mul_div_left _ _ hp.pos,
        (nat.div_eq_zero_iff hp.pos).2 hap, (nat.div_eq_zero_iff hp.pos).2 hbp] at this,
      simpa [hxy]
    end,
  by rw [prod_union h₁, prod_bind h₂]
... = (((range ((p * q) / 2).succ)).filter (coprime p)).prod (λ x, x) :
  prod_congr (filter_range_p_mul_q_div_two_eq hp hq hp1 hq1 hpq).symm (λ _ _, rfl)

lemma prod_filter_range_p_mul_q_div_two_mod_p_eq :
  ((((range ((p * q) / 2).succ).filter (coprime p)).prod (λ x, x) : ℕ) : zmodp p hp)
  = (-1) ^ (q / 2) * ((range (p / 2).succ).erase 0).prod (λ x, x) :=
begin
  rw [← prod_filter_range_p_mul_q_div_two_eq hp hq hp1 hq1 hpq, nat.cast_mul,
    ← prod_hom (coe : ℕ → zmodp p hp),
    ← prod_hom (coe : ℕ → zmodp p hp)],
  conv in ((finset.prod (erase (range p) 0) _ : ℕ) : zmodp p hp)
  { rw ← prod_hom (coe : ℕ → zmodp p hp) },
  simp
end

lemma prod_filter_range_p_mul_q_not_coprime_eq :
  (((((range ((p * q) / 2).succ).filter (coprime p)).filter
  (λ x, ¬ coprime q x)).prod (λ x, x) : ℕ) : zmodp p hp) =
  q ^ (p / 2) * ((range (p / 2).succ).erase 0).prod (λ x, x) :=
have hcard : ((range (p / 2).succ).erase 0).card = p / 2 :=
  by rw [card_erase_of_mem (mem_range.2 (succ_pos _)), card_range, pred_succ],
begin
  conv in ((q : zmodp p hp) ^ (p / 2)) { rw ← hcard },
  rw [← prod_const, ← prod_mul_distrib, ← prod_hom (coe : ℕ → zmodp p hp)],
  exact eq.symm (prod_bij (λ a _, a * q)
    (λ a ha,
      have ha' : a ≤ p / 2 ∧ a > 0,
        by simp [nat.pos_iff_ne_zero, lt_succ_iff] at *; tauto,
      mem_filter.2 ⟨mem_filter.2 ⟨mem_range.2 $ lt_succ_of_le $
        (calc a * q ≤ q * (p / 2) :
            by rw mul_comm; exact mul_le_mul_left _ ha'.1
          ... ≤ _ : by rw [mul_comm p, odd_mul_odd_div_two hq1 hp1];
              exact nat.le_add_right _ _),
        by rw [hp.coprime_iff_not_dvd, hp.dvd_mul, not_or_distrib];
          refine ⟨λ hpa, not_le_of_gt (show p / 2 < p, from nat.div_lt_self hp.pos dec_trivial)
            (le_trans (le_of_dvd ha'.2 hpa) ha'.1), by rwa [← hp.coprime_iff_not_dvd, coprime_primes hp hq]⟩⟩,
      by simp [hq.coprime_iff_not_dvd]⟩)
    (by simp [mul_comm])
    (by simp [nat.mul_right_inj hq.pos])
    (λ b hb, have hb' : (b ≤ p * q / 2 ∧ coprime p b) ∧ q ∣ b,
        by simpa [hq.coprime_iff_not_dvd, lt_succ_iff] using hb,
      have hb0 : b > 0, from nat.pos_of_ne_zero (λ hb0, by simpa [hb0, hp.coprime_iff_not_dvd] using hb'),
      ⟨b / q, mem_erase.2 ⟨nat.pos_iff_ne_zero.1 (nat.div_pos (le_of_dvd hb0 hb'.2) hq.pos),
        mem_range.2 $ lt_succ_of_le $
          by rw [mul_comm, odd_mul_odd_div_two hq1 hp1] at hb';
          have := @nat.div_le_div_right _ _ hb'.1.1 q;
          rwa [add_comm, nat.add_mul_div_left _ _ hq.pos,
      ((nat.div_eq_zero_iff hq.pos).2 (nat.div_lt_self hq.pos (lt_succ_self _))), zero_add] at this⟩,
        by rw nat.div_mul_cancel hb'.2⟩))
end

lemma prod_range_p_mul_q_filter_coprime_mod_p (hq : nat.prime q) (hp1 : p % 2 = 1) (hq1 : q % 2 = 1) (hpq : p ≠ q) :
  ((((range ((p * q) / 2).succ).filter (coprime (p * q))).prod (λ x, x) : ℕ) : zmodp p hp) =
  (-1) ^ (q / 2) * q ^ (p / 2) :=
have hq0 : (q : zmodp p hp) ≠ 0, by rwa [← nat.cast_zero, ne.def, zmodp.eq_iff_modeq_nat, nat.modeq.modeq_zero_iff,
  ← hp.coprime_iff_not_dvd, coprime_primes hp hq],
(domain.mul_right_inj
  (show (q ^ (p / 2) * ((range (p / 2).succ).erase 0).prod (λ x, x) : zmodp p hp) ≠ 0,
    from mul_ne_zero
      (pow_ne_zero _ hq0)
        (suffices h : ∀ (x : ℕ), ¬x = 0 → x ≤ p / 2 → ¬(x : zmodp p hp) = 0,
            by simpa [prod_eq_zero_iff, lt_succ_iff],
          assume x hx0 hxp,
          by rwa [← @nat.cast_zero (zmodp p hp), zmodp.eq_iff_modeq_nat, nat.modeq,
            zero_mod, mod_eq_of_lt (lt_of_le_of_lt hxp (nat.div_lt_self hp.pos (lt_succ_self _)))]))).1 $
have h₁ : (range (succ (p * q / 2))).filter (coprime (p * q)) ∩
      filter (λ x, ¬coprime q x) (filter (coprime p) (range (succ (p * q / 2)))) = ∅,
  by have := @coprime.coprime_mul_left p q; simp [finset.ext, *] at * {contextual := tt},
calc ((((range ((p * q) / 2).succ).filter (coprime (p * q))).prod (λ x, x) : ℕ) : zmodp p hp)
     * (q ^ (p / 2) * ((range (p / 2).succ).erase 0).prod (λ x, x) : zmodp p hp)
   = (((range (succ (p * q / 2))).filter (coprime (p * q)) ∪
     filter (λ x, ¬coprime q x) (filter (coprime p) (range (succ (p * q / 2))))).prod (λ x, x) : ℕ) :
  by rw [← prod_filter_range_p_mul_q_not_coprime_eq hp hq hp1 hq1 hpq, ← nat.cast_mul, ← prod_union h₁]
... = (((range ((p * q) / 2).succ).filter (coprime p)).prod (λ x, x) : ℕ) :
  congr_arg coe (prod_congr (by simp [finset.ext, coprime_mul_iff_left]; tauto) (λ _ _, rfl))
... = _ : by rw [prod_filter_range_p_mul_q_div_two_mod_p_eq hp hq hp1 hq1 hpq];
  cases zmodp.pow_div_two_eq_neg_one_or_one hp hq0; simp [h, _root_.pow_succ]

lemma card_range_p_mul_q_filter_not_coprime :
  card (filter (λ x, ¬coprime p x) (range (succ (p * q / 2)))) = (q / 2).succ :=
calc card (filter (λ x, ¬coprime p x) (range (succ (p * q / 2))))
    = card ((range (q / 2).succ).image (* p)) :
  congr_arg card $ finset.ext.2 $ λ x, begin
    rw [mem_filter, mem_range, hp.coprime_iff_not_dvd, not_not, mem_image],
    exact ⟨λ ⟨h, ⟨m, hm⟩⟩, ⟨m, mem_range.2 (lt_of_mul_lt_mul_left
        (by rw ← hm; exact lt_of_lt_of_le h (by rw [succ_le_iff, mul_succ,
            odd_mul_odd_div_two hp1 hq1];
          exact add_lt_add_left (div_lt_self hp.pos (lt_succ_self 1)) _))
        (nat.zero_le p)), hm.symm ▸ mul_comm m p⟩,
      λ ⟨m, hm₁, hm₂⟩, ⟨lt_succ_of_le (by rw [← hm₂, odd_mul_odd_div_two hp1 hq1];
        exact le_trans (by rw mul_comm; exact mul_le_mul_left _
          (le_of_lt_succ (mem_range.1 hm₁))) (le_add_right _ _)),
        by simp [hm₂.symm]⟩⟩
  end
... = _ : by rw [card_image_of_injective _ (λ _ _ h, (nat.mul_right_inj hp.pos).1 h), card_range]

lemma prod_filter_range_p_mul_q_div_two_eq_prod_product :
  ((range ((p * q) / 2).succ).filter (coprime (p * q))).prod
    (λ x, if (x : zmodp q hq).1 ≤ q / 2 then ((x : zmodp p hp), (x : zmodp q hq))
      else -((x : zmodp p hp), (x : zmodp q hq))) =
  (((range p).erase 0).product ((range (q / 2).succ).erase 0)).prod
    (λ x, ((x.1 : zmodp p hp), (x.2 : zmodp q hq))) :=
have hpqpnat : (((⟨p * q, mul_pos hp.pos hq.pos⟩ : ℕ+) : ℕ) : ℤ) = (p * q : ℤ), by simp,
have hpqpnat' : ((⟨p * q, mul_pos hp.pos hq.pos⟩ : ℕ+) : ℕ) = p * q, by simp,
have hpq1 : ((⟨p * q, mul_pos hp.pos hq.pos⟩ : ℕ+) : ℕ) % 2 = 1,
  from nat.odd_mul_odd hp1 hq1,
have hpq1' : p * q > 1, from one_lt_mul hp.pos hq.gt_one,
have hhq0 : ∀ a : ℕ, coprime q a → a ≠ 0,
  from λ a, imp_not_comm.1 $ by simp [hq.coprime_iff_not_dvd] {contextual := tt},
have hpq0 : 0 < p * q / 2, from nat.div_pos (succ_le_of_lt $ one_lt_mul hp.pos hq.gt_one) dec_trivial,
have hinj : ∀ a₁ a₂ : ℕ,
    a₁ ∈ (range (p * q / 2).succ).filter (coprime (p * q)) →
    a₂ ∈ (range (p * q / 2).succ).filter (coprime (p * q)) →
    (if (a₁ : zmodp q hq).1 ≤ q / 2 then ((a₁ : zmodp p hp).1, (a₁ : zmodp q hq).1)
      else ((-a₁ : zmodp p hp).1, (-a₁ : zmodp q hq).1)) =
    (if (a₂ : zmodp q hq).1 ≤ q / 2 then ((a₂ : zmodp p hp).1, (a₂ : zmodp q hq).1)
      else ((-a₂ : zmodp p hp).1, (-a₂ : zmodp q hq).1)) → a₁ = a₂,
  from λ a b ha hb h,
    have ha' : a ≤ (p * q) / 2 ∧ coprime (p * q) a,
      by simpa [lt_succ_iff] using ha,
    have hapq' : a < ((⟨p * q, mul_pos hp.pos hq.pos⟩ : ℕ+) : ℕ) :=
      lt_of_le_of_lt ha'.1 (div_lt_self (mul_pos hp.pos hq.pos) dec_trivial),
    have hb' : b ≤ (p * q) / 2 ∧ coprime (p * q) b,
      by simpa [lt_succ_iff, coprime_mul_iff_left] using hb,
    have hbpq' : b < ((⟨p * q, mul_pos hp.pos hq.pos⟩ : ℕ+) : ℕ) :=
      lt_of_le_of_lt hb'.1 (div_lt_self (mul_pos hp.pos hq.pos) dec_trivial),
    have val_inj : ∀ {p : ℕ} (hp : nat.prime p) (x y : zmodp p hp), x.val = y.val ↔ x = y,
      from λ _ _ _ _, ⟨fin.eq_of_veq, fin.veq_of_eq⟩,
    have hbpq0 : (b : zmod (⟨p * q, mul_pos hp.pos hq.pos⟩)) ≠ 0,
      by rw [ne.def, zmod.eq_zero_iff_dvd_nat];
        exact λ h, not_coprime_of_dvd_of_dvd hpq1' (dvd_refl (p * q)) h hb'.2,
    have habneg : ¬((a : zmodp p hp) = -b ∧ (a : zmodp q hq) = -b),
      begin
        rw [← int.cast_coe_nat a, ← int.cast_coe_nat b, ← int.cast_coe_nat a, ← int.cast_coe_nat b,
          ← int.cast_neg, ← int.cast_neg, zmodp.eq_iff_modeq_int, zmodp.eq_iff_modeq_int,
          @int.modeq.modeq_and_modeq_iff_modeq_mul _ _ p q ((coprime_primes hp hq).2 hpq), ← hpqpnat,
          ← zmod.eq_iff_modeq_int, int.cast_coe_nat, int.cast_neg, int.cast_coe_nat],
        assume h,
        rw [← hpqpnat', ← zmod.val_cast_of_lt hbpq', zmod.le_div_two_iff_lt_neg hpq1 hbpq0,
          ← h, zmod.val_cast_of_lt hapq', ← not_le] at hb',
        exact hb'.1 ha'.1,
      end,
    have habneg' : ¬((-a : zmodp p hp) = b ∧ (-a : zmodp q hq) = b),
      by rwa [← neg_inj', neg_neg, ← @neg_inj' _ _ (-a : zmodp q hq), neg_neg],
    suffices (a : zmodp p hp) = b ∧ (a : zmodp q hq) = b,
      by rw [← mod_eq_of_lt hapq', ← mod_eq_of_lt hbpq'];
        rwa [zmodp.eq_iff_modeq_nat, zmodp.eq_iff_modeq_nat,
          nat.modeq.modeq_and_modeq_iff_modeq_mul ((coprime_primes hp hq).2 hpq)] at this,
    by split_ifs at h; simp * at *,
have hmem : ∀ a : ℕ,
    a ∈ (range (p * q / 2).succ).filter (coprime (p * q)) →
    (if (a : zmodp q hq).1 ≤ q / 2 then ((a : zmodp p hp).1, (a : zmodp q hq).1)
      else ((-a : zmodp p hp).1, (-a : zmodp q hq).1)) ∈
      ((range p).erase 0).product ((range (succ (q / 2))).erase 0),
  from λ x, have hxp : ∀ {p : ℕ} (hp : nat.prime p), (x : zmodp p hp).val = 0 ↔ p ∣ x,
    from λ p hp, by rw [zmodp.val_cast_nat, nat.dvd_iff_mod_eq_zero],
  have hxpneg : ∀ {p : ℕ} (hp : nat.prime p), (-x : zmodp p hp).val = 0 ↔ p ∣ x,
    from λ p hp, by rw [← int.cast_coe_nat x, ← int.cast_neg, ← int.coe_nat_inj',
      zmodp.coe_val_cast_int, int.coe_nat_zero, ← int.dvd_iff_mod_eq_zero, dvd_neg, int.coe_nat_dvd],
  have hxplt : (x : zmodp p hp).val < p := (x : zmodp p hp).2,
  have hxpltneg : (-x : zmodp p hp).val < p := (-x : zmodp p hp).2,
  have hneglt : ¬(x : zmodp q hq).val ≤ q / 2 → (x : zmodp q hq) ≠ 0 → (-x : zmodp q hq).val ≤ q / 2,
    from λ hx₁ hx0, by rwa [zmodp.le_div_two_iff_lt_neg hq hq1 hx0, not_lt] at hx₁,
  by split_ifs;
    simp [zmodp.eq_zero_iff_dvd_nat hq, (x : zmodp p hp).2, coprime_mul_iff_left,
      lt_succ_iff, h, *, hp.coprime_iff_not_dvd,
      hq.coprime_iff_not_dvd, (x : zmodp p hp).2, (-x : zmodp p hp).2] {contextual := tt},
prod_bij (λ x _, if (x : zmodp q hq).1 ≤ (q / 2) then ((x : zmodp p hp).val, (x : zmodp q hq).val)
      else ((-x : zmodp p hp).val, (-x : zmodp q hq).val))
  hmem
  (λ a ha, by split_ifs; simp [*, prod.ext_iff] at *)
  hinj
  (surj_on_of_inj_on_of_card_le _ hmem hinj
    (@nat.le_of_add_le_add_right (q / 2 + (p / 2).succ) _ _
      (calc card (finset.product (erase (range p) 0) (erase (range (succ (q / 2))) 0)) + (q / 2 + (p / 2).succ)
            = (p * q) / 2 + 1 :
          by rw [card_product, card_erase_of_mem (mem_range.2 hp.pos), card_erase_of_mem (mem_range.2 (succ_pos _)),
            card_range, card_range, pred_succ, ← add_assoc, ← succ_mul, succ_pred_eq_of_pos hp.pos,
            odd_mul_odd_div_two hp1 hq1, add_succ]
        ... = card (range (p * q / 2).succ) : by rw card_range
        ... = card ((range (p * q / 2).succ).filter (coprime (p * q)) ∪
                    ((range (p * q / 2).succ).filter (λ x, ¬coprime p x)).erase 0 ∪
                    (range (p * q / 2).succ).filter (λ x, ¬coprime q x)) :
          congr_arg card (by simp [finset.ext, coprime_mul_iff_left]; tauto)
        ... ≤ card ((range (p * q / 2).succ).filter (coprime (p * q))) +
              card (((range (p * q / 2).succ).filter (λ x, ¬coprime p x)).erase 0) +
              card ((range (p * q / 2).succ).filter (λ x, ¬coprime q x)) :
          le_trans (card_union_le _ _) (add_le_add_right (card_union_le _ _) _)
        ... = _ : by rw [card_erase_of_mem, card_range_p_mul_q_filter_not_coprime hp hq hp1 hq1 hpq,
              mul_comm p q, card_range_p_mul_q_filter_not_coprime hq hp hq1 hp1 hpq.symm, pred_succ,
              add_assoc];
            simp [range_succ, hp.coprime_iff_not_dvd, hpq0])))

lemma prod_range_div_two_erase_zero :
  ((range (p / 2).succ).erase 0).prod (λ x, (x : zmodp p hp)) ^ 2 * (-1) ^ (p / 2) = -1 :=
have hcard : card (erase (range (succ (p / 2))) 0) = p / 2,
  by rw [card_erase_of_mem (mem_range.2 (succ_pos _)), card_range, pred_succ],
have hp2 : p / 2 < p, from div_lt_self hp.pos dec_trivial,
have h₁ : (range (p / 2).succ).erase 0 = ((range p).erase 0).filter (λ x, (x : zmodp p hp).val ≤ p / 2) :=
  finset.ext.2 (λ a,
  ⟨λ h, mem_filter.2 $ by rw [mem_erase, mem_range, lt_succ_iff] at h;
    exact ⟨mem_erase.2 ⟨h.1, mem_range.2 (lt_of_le_of_lt h.2 hp2)⟩,
      by rw zmodp.val_cast_of_lt hp (lt_of_le_of_lt h.2 hp2); exact h.2⟩,
  λ h, mem_erase.2 ⟨by simp at h; tauto,
    by rw [mem_filter, mem_erase, mem_range] at h;
    rw [mem_range, lt_succ_iff, ← zmodp.val_cast_of_lt hp h.1.2]; exact h.2⟩⟩),
have hmem : ∀ x ∈ (range (p / 2).succ).erase 0, x ≠ 0 ∧ x ≤ p / 2,
  from λ x hx, by simpa [lt_succ_iff] using hx,
have hmemv : ∀ x ∈ (range (p / 2).succ).erase 0, (x : zmodp p hp).val = x,
  from λ x hx, zmodp.val_cast_of_lt hp (lt_of_le_of_lt (hmem x hx).2 hp2),
have hmem0 : ∀ x ∈ (range (p / 2).succ).erase 0, (x : zmodp p hp) ≠ 0,
  from λ x hx, fin.ne_of_vne $ by simp [hmemv x hx, (hmem x hx).1],
have hmem0' : ∀ x ∈ (range (p / 2).succ).erase 0, (-x : zmodp p hp) ≠ 0,
  from λ x hx, neg_ne_zero.2 (hmem0 x hx),
have h₂ : ((range (p / 2).succ).erase 0).prod (λ x : ℕ, (x : zmodp p hp) * -1) =
    (((range p).erase 0).filter (λ x : ℕ, ¬(x : zmodp p hp).val ≤ p / 2)).prod (λ x, (x : zmodp p hp)) :=
  prod_bij (λ a _, (-a : zmodp p hp).1)
    (λ a ha,  mem_filter.2 ⟨mem_erase.2 ⟨fin.vne_of_ne (hmem0' a ha), mem_range.2 (-a : zmodp p hp).2⟩,
        by simp [zmodp.le_div_two_iff_lt_neg hp hp1 (hmem0' a ha), hmemv a ha, (hmem a ha).2]; tauto⟩)
    (by simp)
    (λ a₁ a₂ ha₁ ha₂ h,
      by rw [← hmemv a₁ ha₁, ← hmemv a₂ ha₂]; exact fin.veq_of_eq (by rw neg_inj (fin.eq_of_veq h)))
    (λ b hb,
      have hb' : (b ≠ 0 ∧ b < p) ∧ (¬(b : zmodp p hp).1 ≤ p / 2), by simpa using hb,
      have hbv : (b : zmodp p hp).1 = b, from zmodp.val_cast_of_lt hp hb'.1.2,
      have hb0 : (b : zmodp p hp) ≠ 0, from fin.ne_of_vne $ by simp [hbv, hb'.1.1],
    ⟨(-b : zmodp p hp).1, mem_erase.2 ⟨fin.vne_of_ne (neg_ne_zero.2 hb0 : _),
      mem_range.2 $ lt_succ_of_le $ by rw [← not_lt, ← zmodp.le_div_two_iff_lt_neg hp hp1 hb0]; exact hb'.2⟩,
      by simp [hbv]⟩),
calc ((((range (p / 2).succ).erase 0).prod (λ x, (x : zmodp p hp)) ^ 2)) * (-1) ^ (p / 2) =
  ((range (p / 2).succ).erase 0).prod (λ x, (x : zmodp p hp)) *
  ((range (p / 2).succ).erase 0).prod (λ x, (x : zmodp p hp) * -1) :
  by rw prod_mul_distrib; simp [_root_.pow_two, hcard, mul_assoc]
... = (((range p).erase 0).filter (λ x : ℕ, (x : zmodp p hp).val ≤ p / 2)).prod (λ x, (x : zmodp p hp)) *
    (((range p).erase 0).filter (λ x : ℕ, ¬(x : zmodp p hp).val ≤ p / 2)).prod (λ x, (x : zmodp p hp)) :
  by rw [h₂, h₁]
... = ((range p).erase 0).prod (λ x, (x : zmodp p hp)) :
  begin
    rw ← prod_union,
    { exact finset.prod_congr (by simp [finset.ext, -not_lt, -not_le]; tauto) (λ _ _, rfl) },
    { simp [finset.ext, -not_lt, - not_le]; tauto }
  end
... = -1 : by simp

lemma range_p_product_range_q_div_two_prod :
  (((range p).erase 0).product ((range (q / 2).succ).erase 0)).prod
    (λ x, ((x.1 : zmodp p hp), (x.2 : zmodp q hq))) =
  ((-1) ^ (q / 2), (-1) ^ (p / 2) * (-1) ^ (p / 2 * (q / 2))) :=
have hcard : card (erase (range (succ (q / 2))) 0) = q / 2,
  by rw [card_erase_of_mem (mem_range.2 (succ_pos _)), card_range, pred_succ],
have finset.prod (erase (range (succ (q / 2))) 0) (λ x : ℕ, (x : zmodp q hq)) ^ 2 = -((-1 : zmodp q hq) ^ (q / 2)),
  from (domain.mul_right_inj (show (-1 : zmodp q hq) ^ (q / 2) ≠ 0, from pow_ne_zero _ (neg_ne_zero.2 zero_ne_one.symm))).1 $
  by rw [prod_range_div_two_erase_zero hq hp hq1 hp1 hpq.symm, ← neg_mul_eq_neg_mul, ← _root_.pow_add, ← two_mul,
    pow_mul, _root_.pow_two]; simp,
have finset.prod (erase (range (succ (q / 2))) 0) (λ x, (x : zmodp q hq)) ^ card (erase (range p) 0) =
  (- 1) ^ (p / 2) * ((-1) ^ (p / 2 * (q / 2))),
 by rw [card_erase_of_mem (mem_range.2 hp.pos), card_range, pred_eq_sub_one,
   ← two_mul_odd_div_two hp1, pow_mul, this, mul_comm (p / 2), pow_mul, ← _root_.mul_pow]; simp,
by simp [prod_product, (prod_mk_prod _ _ _).symm, prod_pow, prod_nat_pow, prod_const, *,
  zmodp.prod_range_prime_erase_zero hp]

lemma prod_range_p_mul_q_div_two_ite_eq :
  ((range ((p * q) / 2).succ).filter (coprime (p * q))).prod
  (λ x, if (x : zmodp q hq).1 ≤ (q / 2) then ((x : zmodp p hp), (x : zmodp q hq))
    else -((x : zmodp p hp), (x : zmodp q hq))) =
  ((range ((p * q) / 2).succ).filter (coprime (p * q))).prod (λ x, if (x : zmodp q hq).1 ≤ q / 2 then 1 else -1) *
  ((-1) ^ (q / 2) * q ^ (p / 2), (-1) ^ (p / 2) * p ^ (q / 2)) :=
calc ((range ((p * q) / 2).succ).filter (coprime (p * q))).prod
  (λ x, if (x : zmodp q hq).1 ≤ (q / 2) then ((x : zmodp p hp), (x : zmodp q hq))
    else -((x : zmodp p hp), (x : zmodp q hq))) =
  ((range ((p * q) / 2).succ).filter (coprime (p * q))).prod
  (λ x, (if (x : zmodp q hq).1 ≤ (q / 2) then 1 else -1) * ((x : zmodp p hp), (x : zmodp q hq))) :
  prod_congr rfl (λ _ _, by split_ifs; simp)
... = _ : by rw [prod_mul_distrib, ← prod_mk_prod,
    prod_hom (coe : ℕ → zmodp p hp),
    prod_range_p_mul_q_filter_coprime_mod_p hp hq hp1 hq1 hpq,
    prod_hom (coe : ℕ → zmodp q hq),
    mul_comm p q, prod_range_p_mul_q_filter_coprime_mod_p hq hp hq1 hp1 hpq.symm]

end quadratic_reciprocity_aux

open quadratic_reciprocity_aux

variables {p q : ℕ} (hp : nat.prime p) (hq : nat.prime q)

namespace zmodp

def legendre_sym (a p : ℕ) (hp : nat.prime p) : ℤ :=
if (a : zmodp p hp) = 0 then 0 else if ∃ b : zmodp p hp, b ^ 2 = a then 1 else -1

lemma legendre_sym_eq_pow (a p : ℕ) (hp : nat.prime p) : (legendre_sym a p hp : zmodp p hp) = (a ^ (p / 2)) :=
if ha : (a : zmodp p hp) = 0 then by simp [*, legendre_sym, _root_.zero_pow (nat.div_pos hp.ge_two (succ_pos 1))]
else
(nat.prime.eq_two_or_odd hp).elim
  (λ hp2, begin subst hp2,
    suffices : ∀ a : zmodp 2 nat.prime_two,
      (((ite (a = 0) 0 (ite (∃ (b : zmodp 2 hp), b ^ 2 = a) 1 (-1))) : ℤ) : zmodp 2 nat.prime_two) = a ^ (2 / 2),
    { exact this a },
    exact dec_trivial,
   end)
  (λ hp1, have _ := euler_criterion hp ha,
    have (-1 : zmodp p hp) ≠ 1, from (ne_neg_self hp hp1 zero_ne_one.symm).symm,
    by cases zmodp.pow_div_two_eq_neg_one_or_one hp ha; simp [legendre_sym, *] at *)

lemma legendre_sym_eq_one_or_neg_one (a : ℕ) (hp : nat.prime p) (ha : (a : zmodp p hp) ≠ 0) :
  legendre_sym a p hp = -1 ∨ legendre_sym a p hp = 1 :=
by unfold legendre_sym; split_ifs; simp * at *

theorem quadratic_reciprocity (hp : nat.prime p) (hq : nat.prime q) (hp1 : p % 2 = 1) (hq1 : q % 2 = 1) (hpq : p ≠ q) :
  legendre_sym p q hq * legendre_sym q p hp = (-1) ^ ((p / 2) * (q / 2)) :=
have hneg_one_or_one : ((range (p * q / 2).succ).filter (coprime (p * q))).prod
    (λ (x : ℕ), if (x : zmodp q hq).val ≤ q / 2 then (1 : zmodp p hp × zmodp q hq) else -1) = 1 ∨
    ((range (p * q / 2).succ).filter (coprime (p * q))).prod
    (λ (x : ℕ), if (x : zmodp q hq).val ≤ q / 2 then (1 : zmodp p hp × zmodp q hq) else -1) = -1 :=
  finset.induction_on ((range (p * q / 2).succ).filter (coprime (p * q))) (or.inl rfl)
    (λ a s h, by simp [prod_insert h]; split_ifs; finish),
have h : (((-1) ^ (q / 2), (-1) ^ (p / 2) * (-1) ^ (p / 2 * (q / 2))) : zmodp p hp × zmodp q hq) =
    ((-1) ^ (q / 2) * q ^ (p / 2), (-1) ^ (p / 2) * p ^ (q / 2)) ∨
    (((-1) ^ (q / 2), (-1) ^ (p / 2) * (-1) ^ (p / 2 * (q / 2))) : zmodp p hp × zmodp q hq) =
    - ((-1) ^ (q / 2) * q ^ (p / 2), (-1) ^ (p / 2) * p ^ (q / 2)) :=
  begin
    have := prod_filter_range_p_mul_q_div_two_eq_prod_product hp hq hp1 hq1 hpq,
    rw [prod_range_p_mul_q_div_two_ite_eq hp hq hp1 hq1 hpq,
      range_p_product_range_q_div_two_prod hp hq hp1 hq1 hpq] at this,
    cases hneg_one_or_one with h h; simp * at *
  end,
begin
  have := ne_neg_self hp hp1 one_ne_zero,
  have := ne_neg_self hq hq1 one_ne_zero,
  generalize hnp : (-1 : ℤ) ^ (p / 2) = np,
  have hnpp : (-1 : zmodp q hq) ^ (p / 2) = np, by simp [hnp.symm],
  generalize hnq : (-1 : ℤ) ^ (q / 2) = nq,
  have hnqp : (-1 : zmodp p hp) ^ (q / 2) = nq, by simp [hnq.symm],
  have hnqq : (-1 : zmodp q hq) ^ (q / 2) = nq, by simp [hnq.symm],
  cases legendre_sym_eq_one_or_neg_one q hp (zmodp.prime_ne_zero hp hq hpq);
  cases legendre_sym_eq_one_or_neg_one p hq (zmodp.prime_ne_zero hq hp hpq.symm);
  cases @neg_one_pow_eq_or ℤ _ (p / 2);
  cases @neg_one_pow_eq_or ℤ _ (q / 2);
  simp [*, pow_mul, (legendre_sym_eq_pow p q hq).symm, (legendre_sym_eq_pow q p hp).symm, prod.ext_iff] at *;
  cc
end

lemma exists_pow_two_eq_prime_iff_of_mod_four_eq_one (hp1 : p % 4 = 1) (hq1 : q % 2 = 1) :
  (∃ a : zmodp p hp, a ^ 2 = q) ↔ ∃ b : zmodp q hq, b ^ 2 = p :=
if hpq : p = q then by subst hpq else
have h1 : ((p / 2) * (q / 2)) % 2 = 0,
  from (dvd_iff_mod_eq_zero _ _).1
    (dvd_mul_of_dvd_left ((dvd_iff_mod_eq_zero _ _).2 $
    by rw [← mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hp1]; refl) _),
begin
  have := quadratic_reciprocity hp hq (odd_of_mod_four_eq_one hp1) hq1 hpq,
  rw [neg_one_pow_eq_pow_mod_two, h1, legendre_sym, legendre_sym,
    if_neg (zmodp.prime_ne_zero hp hq hpq),
    if_neg (zmodp.prime_ne_zero hq hp (ne.symm hpq))] at this,
  split_ifs at this; simp *; contradiction
end

lemma exists_pow_two_eq_prime_iff_of_mod_four_eq_three (hp3 : p % 4 = 3)
  (hq3 : q % 4 = 3) (hpq : p ≠ q) : (∃ a : zmodp p hp, a ^ 2 = q) ↔ ¬∃ b : zmodp q hq, b ^ 2 = p :=
have h1 : ((p / 2) * (q / 2)) % 2 = 1,
  from nat.odd_mul_odd
    (by rw [← mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hp3]; refl)
    (by rw [← mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hq3]; refl),
begin
  have := quadratic_reciprocity hp hq (odd_of_mod_four_eq_three hp3)
    (odd_of_mod_four_eq_three hq3) hpq,
  rw [neg_one_pow_eq_pow_mod_two, h1, legendre_sym, legendre_sym,
    if_neg (zmodp.prime_ne_zero hp hq hpq),
    if_neg (zmodp.prime_ne_zero hq hp hpq.symm)] at this,
  split_ifs at this; simp *; contradiction
end

end zmodp


/-
Copyright (c) 2015 Joseph Hua. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Hua

! This file was ported from Lean 3 source module data.W.constructions
! leanprover-community/mathlib commit e46da4e335b8671848ac711ccb34b42538c0d800
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.W.Basic

/-!
# Examples of W-types

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

We take the view of W types as inductive types.
Given `α : Type` and `β : α → Type`, the W type determined by this data, `W_type β`, is the
inductively with constructors from `α` and arities of each constructor `a : α` given by `β a`.

This file contains `nat` and `list` as examples of W types.

## Main results
* `W_type.equiv_nat`: the construction of the naturals as a W-type is equivalent
  to `nat`
* `W_type.equiv_list`: the construction of lists on a type `γ` as a W-type is equivalent to
  `list γ`
-/

universe u v

namespace WType

section Nat

#print WType.Natα /-
/-- The constructors for the naturals -/
inductive Natα : Type
  | zero : nat_α
  | succ : nat_α
#align W_type.nat_α WType.Natα
-/

instance : Inhabited Natα :=
  ⟨Natα.zero⟩

#print WType.Natβ /-
/-- The arity of the constructors for the naturals, `zero` takes no arguments, `succ` takes one -/
def Natβ : Natα → Type
  | nat_α.zero => Empty
  | nat_α.succ => Unit
#align W_type.nat_β WType.Natβ
-/

instance : Inhabited (Natβ Natα.succ) :=
  ⟨()⟩

#print WType.ofNat /-
/-- The isomorphism from the naturals to its corresponding `W_type` -/
@[simp]
def ofNat : ℕ → WType Natβ
  | Nat.zero => ⟨Natα.zero, Empty.elim⟩
  | Nat.succ n => ⟨Natα.succ, fun _ => of_nat n⟩
#align W_type.of_nat WType.ofNat
-/

#print WType.toNat /-
/-- The isomorphism from the `W_type` of the naturals to the naturals -/
@[simp]
def toNat : WType Natβ → ℕ
  | WType.mk nat_α.zero f => 0
  | WType.mk nat_α.succ f => (to_nat (f ())).succ
#align W_type.to_nat WType.toNat
-/

#print WType.leftInverse_nat /-
theorem leftInverse_nat : Function.LeftInverse ofNat toNat
  | WType.mk nat_α.zero f => by
    simp
    tidy
  | WType.mk nat_α.succ f => by
    simp
    tidy
#align W_type.left_inv_nat WType.leftInverse_nat
-/

#print WType.rightInverse_nat /-
theorem rightInverse_nat : Function.RightInverse ofNat toNat
  | Nat.zero => rfl
  | Nat.succ n => by rw [of_nat, to_nat, right_inv_nat n]
#align W_type.right_inv_nat WType.rightInverse_nat
-/

#print WType.equivNat /-
/-- The naturals are equivalent to their associated `W_type` -/
def equivNat : WType Natβ ≃ ℕ where
  toFun := toNat
  invFun := ofNat
  left_inv := leftInverse_nat
  right_inv := rightInverse_nat
#align W_type.equiv_nat WType.equivNat
-/

open Sum PUnit

#print WType.NatαEquivPUnitSumPUnit /-
/-- `W_type.nat_α` is equivalent to `punit ⊕ punit`.
This is useful when considering the associated polynomial endofunctor.
-/
@[simps]
def NatαEquivPUnitSumPUnit : Natα ≃ Sum PUnit.{u + 1} PUnit
    where
  toFun c :=
    match c with
    | nat_α.zero => inl unit
    | nat_α.succ => inr unit
  invFun b :=
    match b with
    | inl x => Natα.zero
    | inr x => Natα.succ
  left_inv c :=
    match c with
    | nat_α.zero => rfl
    | nat_α.succ => rfl
  right_inv b :=
    match b with
    | inl star => rfl
    | inr star => rfl
#align W_type.nat_α_equiv_punit_sum_punit WType.NatαEquivPUnitSumPUnit
-/

end Nat

section List

variable (γ : Type u)

#print WType.Listα /-
/-- The constructors for lists.
There is "one constructor `cons x` for each `x : γ`",
since we view `list γ` as
```
| nil : list γ
| cons x₀ : list γ → list γ
| cons x₁ : list γ → list γ
|   ⋮      γ many times
```
-/
inductive Listα : Type u
  | nil : list_α
  | cons : γ → list_α
#align W_type.list_α WType.Listα
-/

instance : Inhabited (Listα γ) :=
  ⟨Listα.nil⟩

#print WType.Listβ /-
/-- The arities of each constructor for lists, `nil` takes no arguments, `cons hd` takes one -/
def Listβ : Listα γ → Type u
  | list_α.nil => PEmpty
  | list_α.cons hd => PUnit
#align W_type.list_β WType.Listβ
-/

instance (hd : γ) : Inhabited (Listβ γ (Listα.cons hd)) :=
  ⟨PUnit.unit⟩

#print WType.ofList /-
/-- The isomorphism from lists to the `W_type` construction of lists -/
@[simp]
def ofList : List γ → WType (Listβ γ)
  | List.nil => ⟨Listα.nil, PEmpty.elim⟩
  | List.cons hd tl => ⟨Listα.cons hd, fun _ => of_list tl⟩
#align W_type.of_list WType.ofList
-/

#print WType.toList /-
/-- The isomorphism from the `W_type` construction of lists to lists -/
@[simp]
def toList : WType (Listβ γ) → List γ
  | WType.mk list_α.nil f => []
  | WType.mk (list_α.cons hd) f => hd :: to_list (f PUnit.unit)
#align W_type.to_list WType.toList
-/

#print WType.leftInverse_list /-
theorem leftInverse_list : Function.LeftInverse (ofList γ) (toList _)
  | WType.mk list_α.nil f => by
    simp
    tidy
  | WType.mk (list_α.cons x) f => by
    simp
    tidy
#align W_type.left_inv_list WType.leftInverse_list
-/

#print WType.rightInverse_list /-
theorem rightInverse_list : Function.RightInverse (ofList γ) (toList _)
  | List.nil => rfl
  | List.cons hd tl => by simp [right_inv_list tl]
#align W_type.right_inv_list WType.rightInverse_list
-/

#print WType.equivList /-
/-- Lists are equivalent to their associated `W_type` -/
def equivList : WType (Listβ γ) ≃ List γ
    where
  toFun := toList _
  invFun := ofList _
  left_inv := leftInverse_list _
  right_inv := rightInverse_list _
#align W_type.equiv_list WType.equivList
-/

#print WType.ListαEquivPUnitSum /-
/-- `W_type.list_α` is equivalent to `γ` with an extra point.
This is useful when considering the associated polynomial endofunctor
-/
def ListαEquivPUnitSum : Listα γ ≃ Sum PUnit.{v + 1} γ
    where
  toFun c :=
    match c with
    | list_α.nil => Sum.inl PUnit.unit
    | list_α.cons x => Sum.inr x
  invFun := Sum.elim (fun _ => Listα.nil) fun x => Listα.cons x
  left_inv c :=
    match c with
    | list_α.nil => rfl
    | list_α.cons x => rfl
  right_inv x :=
    match x with
    | Sum.inl PUnit.unit => rfl
    | Sum.inr x => rfl
#align W_type.list_α_equiv_punit_sum WType.ListαEquivPUnitSum
-/

end List

end WType


import order.bounded_lattice
import order.order_iso
import order.complete_lattice

open lattice

variables {α β : Type} [bounded_lattice α] [bounded_lattice β]

@[simp]
def preserves_meet (f : α → β) := ∀ a₁ a₂, f(a₁ ⊓ a₂) = f(a₁) ⊓ f(a₂)
@[simp]
def preserves_join (f : α → β) := ∀ a₁ a₂, f(a₁ ⊔ a₂) = f(a₁) ⊔ f(a₂)

variables (f : α → β)

-- Any homomorphism that preserves the meet on a lattice preserves the ≤
theorem homo_preserves_lt_1 (h₁ : preserves_meet f) :
  ∀ a₁ a₂, a₁ ≤ a₂ → f(a₁) ≤ f(a₂) :=
begin
  intros;
  have h₃ : a₁ = a₁ ⊓ a₂ := eq.symm (inf_of_le_left a);
  rw [h₃, h₁];
  exact inf_le_right
end

-- Any injective homorphism that preserves the meet on a lattice resepects ≤ in the preimage
theorem homo_preserves_lt_2 (h₀ : function.injective f) (h₁ : preserves_meet f) :
  ∀ a₁ a₂, f(a₁) ≤ f(a₂) → a₁ ≤ a₂ :=
begin
  intros;
  have h₃ : f(a₁) = f(a₁) ⊓ f(a₂) := eq.symm (inf_of_le_left a);
  have h₄ : f(a₁) = f(a₁ ⊓ a₂) := (by rw h₁ a₁ a₂; apply h₃);
  have h₅ : a₁ = a₁ ⊓ a₂ := h₀ h₄;
  exact le_of_inf_eq (eq.symm h₅)
end

-- A bounded lattice homomorphism is a morphism preserving meet, join, top and bottom
class is_lattice_hom :=
  (preserves_meet : preserves_meet f)
  (preserves_join : preserves_join f)
  (preserves_top : f ⊤ = ⊤)
  (preserves_bot : f ⊥ = ⊥)

variables {γ δ : Type} [bounded_lattice γ] [bounded_lattice δ] (g : ((≤) : γ → γ → Prop)  ≃o ((≤) : δ → δ → Prop))

theorem order_isom_preserves_bot : g ⊥ = ⊥ :=
begin
  intros,
  rw eq_bot_iff,
  let p := (order_iso.to_equiv g).inv_fun ⊥,
  have h : ⊥ ≤ p := bot_le,
  have i : g ⊥ ≤ g p := (iff.elim_left (order_iso.ord g)) h,
  have j : g p = ⊥ := calc
   g p = g.to_equiv.to_fun ((g.to_equiv).inv_fun ⊥) : by simp
   ... = ⊥ : by rw (order_iso.to_equiv g).right_inv ⊥
   ,
  rw eq.symm j,
  assumption
end

theorem order_isom_preserves_top : g ⊤ = ⊤  :=
begin
  intros,
  rw eq_top_iff,
  let p := (order_iso.to_equiv g).inv_fun ⊤,
  have h : ⊤ ≥ p := le_top,
  have i : g ⊤ ≥ g p := (iff.elim_left (order_iso.ord g)) h,
  have j : g p = ⊤ := calc
   g p = g.to_equiv.to_fun ((g.to_equiv).inv_fun ⊤) : by simp
   ... = ⊤ : by rw (order_iso.to_equiv g).right_inv ⊤
   ,
  rw eq.symm j,
  assumption
end

lemma lem_1 (a₁ a₂ : γ) (g : ((≤) : γ → γ → Prop)  ≃o ((≤) : δ → δ → Prop)) : g (a₁ ⊓ a₂) ≤ g a₁ ⊓ g a₂ :=
begin
  have h₁ : g (a₁ ⊓ a₂) ≤ g a₁ := iff.elim_left (order_iso.ord g) inf_le_left,
  have h₂ : g (a₁ ⊓ a₂) ≤ g a₂ := iff.elim_left (order_iso.ord g) inf_le_right,
  exact (iff.elim_right le_inf_iff) ⟨ h₁ , h₂ ⟩,
end

theorem order_isom_preserves_meet : preserves_meet g :=
begin
  dunfold preserves_meet,
  intros,
  let g' := g.symm,
  have i₁ : g (a₁ ⊓ a₂) ≤ g a₁ ⊓ g a₂ := lem_1 _ _ _,
  have i₂ : g' (g a₁ ⊓ g a₂) ≤ (g' (g a₁)) ⊓ (g' (g a₂)) := lem_1 _ _ _,
  have j : a₁ ⊓ a₂ = (g.symm (g a₁)) ⊓ (g' (g a₂)) := by repeat { rw g.symm_apply_apply },
  have i₃ : g' (g a₁ ⊓ g a₂) ≤ a₁ ⊓ a₂ := (by rw j; exact i₂),
  have i₄ : g a₁ ⊓ g a₂ ≤ g (a₁ ⊓ a₂) := calc
    g a₁ ⊓ g a₂ = g (g' (g a₁ ⊓ g a₂)) : by rw g.apply_symm_apply
            ... ≤ g (a₁ ⊓ a₂) : (iff.elim_left (@order_iso.ord γ δ _ _ g _ _)) i₃
  ,
  exact le_antisymm i₁ i₄
end

lemma lem_2 (a₁ a₂ : γ) (g : ((≤) : γ → γ → Prop)  ≃o ((≤) : δ → δ → Prop)) : g (a₁ ⊔ a₂) ≥ g a₁ ⊔ g a₂ :=
begin
  have h₁ : g (a₁ ⊔ a₂) ≥ g a₁ := iff.elim_left (order_iso.ord g) le_sup_left,
  have h₂ : g (a₁ ⊔ a₂) ≥ g a₂ := iff.elim_left (order_iso.ord g) le_sup_right,
  exact (iff.elim_right sup_le_iff) ⟨ h₁ , h₂ ⟩,
end

theorem order_isom_preserves_join : preserves_join g :=
begin
  dunfold preserves_join,
  intros,
  let g' := g.symm,
  have i₁ : g (a₁ ⊔ a₂) ≥ g a₁ ⊔ g a₂ := lem_2 _ _ _,
  have i₂ : g' (g a₁ ⊔ g a₂) ≥ (g' (g a₁)) ⊔ (g' (g a₂)) := lem_2 _ _ _,
  have j : a₁ ⊔ a₂ = (g.symm (g a₁)) ⊔ (g' (g a₂)) := by repeat { rw g.symm_apply_apply },
  have i₃ : g' (g a₁ ⊔ g a₂) ≥ a₁ ⊔ a₂ := (by rw j; exact i₂),
  have i₄ : g a₁ ⊔ g a₂ ≥ g (a₁ ⊔ a₂) := calc
    g a₁ ⊔ g a₂ = g (g' (g a₁ ⊔ g a₂)) : by rw g.apply_symm_apply
            ... ≥ g (a₁ ⊔ a₂) : (iff.elim_left (@order_iso.ord γ δ _ _ g _ _)) i₃
  ,
  exact le_antisymm i₄ i₁
end

theorem order_isom_preserves_lt (a₁ a₂ : γ) (g : ((≤) : γ → γ → Prop)  ≃o ((≤) : δ → δ → Prop)) : a₁ < a₂ → g a₁ < g a₂ :=
begin
  intros,
  have h : g a₁ ≤ g a₂ := (order_iso.ord g).elim_left (le_of_lt a),
  apply lt_of_le_of_ne,
  assumption,
  simp,
  have i := equiv.injective (g.to_equiv),
  intro,
  have q : a₁ = a₂ := i a_1,
  exact not_lt_of_ge (ge_of_eq q) a
end

instance order_is_is_lattice_hom : is_lattice_hom g := {
  preserves_meet := @order_isom_preserves_meet _ _ _ _ g,
  preserves_join := @order_isom_preserves_join _ _ _ _ g,
  preserves_top := @order_isom_preserves_top _ _ _ _ g,
  preserves_bot := @order_isom_preserves_bot _ _ _ _ g
}

variable (A : α)

/- TODO This is stronger than needed.  We can just let α be an order_bot and a lattice. -/
instance : bounded_lattice (subtype (λ a, a ≤ A)) := {
  inf := λ x y, ⟨(x : α) ⊓ (y : α), le_trans inf_le_left x.property ⟩,
  sup := λ x y, ⟨(x : α) ⊔ (y : α), sup_le_iff.elim_right ⟨ x.property, y.property ⟩ ⟩,
  le_sup_left := λ a b, @le_sup_left α _ a b,
  le_sup_right := λ a b, @le_sup_right α _ a b,
  sup_le := λ a b c h₁ h₂, (@sup_le_iff α _ _ _ _).elim_right ⟨ h₁ , h₂ ⟩,
  inf_le_left := λ a b, @inf_le_left α _ a b,
  inf_le_right := λ a b, @inf_le_right α _ a b,
  le_inf := λ a b c h₁ h₂, (@le_inf_iff α _ _ _ _).elim_right ⟨ h₁ , h₂ ⟩  ,
  top := ⟨ A , le_refl A ⟩ ,
  le_top := λ a, a.property ,
  bot := ⟨ ⊥ , bounded_lattice.bot_le A ⟩,
  bot_le := λ a, @bot_le α _ a ,
  ..subtype.partial_order _
}

/-- A maximal element is a last element before the top -/
def maximal {α : Type} [order_top α] : α → Prop := λ x, x ≠ ⊤ ∧ ∀ y > x, y = ⊤

/-- A minimal element is a first element after the bottom -/
def minimal {α : Type} [order_bot α] : α → Prop := λ x, x ≠ ⊥ ∧ ∀ y < x, y = ⊥

theorem eq_top_of_meet_of_distinct_maximals (a₁ a₂ : α) (h₁ : maximal a₁) (h₂ : maximal a₂) (h_neq : a₁ ≠ a₂) : a₁ ⊔ a₂ = ⊤ :=
begin
  cases lt_or_eq_of_le (@le_sup_right _ _ a₁ a₂) ,
    exact h₂.elim_right _ h,
  have a₁_le : a₁ ≤ a₂ := le_of_sup_eq h.symm,
  cases lt_or_eq_of_le a₁_le,
    have q :=  h₁.elim_right _ h_1,
    have r :=  h₂.elim_left,
    contradiction,
  rw [h_1, sup_idem],
  contradiction
end


import data.polynomial linear_algebra.multivariate_polynomial
import ring_theory.ideals data.nat.choose order.zorn
import algebra.module
open set
open ring
open polynomial
universes u
section
variables {σ : Type*} [decidable_linear_order σ]

-- '.sort' makes list
def multiset.lex (m1 m2 : multiset σ) : Prop :=
  m1.sort (≥) ≤ m2.sort (≥)

instance (m1 m2 : multiset σ) : decidable (multiset.lex m1 m2) :=
  by unfold multiset.lex; apply_instance

-- example : linear_order (list σ) := by apply_instance

lemma multiset.sort_ext {m1 m2 : multiset σ} : m1 = m2 ↔ m1.sort(≥) = m2.sort(≥) :=
iff.intro
  (sorry)
  (assume h,
   multiset.ext.2 sorry)

def multiset.lex_is_total (σ) [decidable_linear_order σ]: decidable_linear_order (multiset σ) :=
{ le := multiset.lex,
  le_refl := λ m, le_refl _,
  le_trans := λ m1 m2 m3 h1 h2, le_trans h1 h2,
  le_antisymm := λ m1 m2 h1 h2, multiset.sort_ext.2 (le_antisymm h1 h2),
  le_total := λ m1 m2, le_total _ _,
  decidable_le := λ _ _, by apply_instance
}
end

local attribute [instance, priority 10000] multiset.lex_is_total

-- example (σ) [decidable_linear_order σ]:
-- ∀ a b : σ , decidable (a ≤ b) :=--decidable_rel ((≤) : multiset σ → multiset σ → Prop) :=
--  by apply_instance

def my_mvpolynomial (σ : Type*) (α: Type*) [comm_semiring α]: Type* :=
  finsupp (multiset σ) α

variables {α : Type} {σ : Type*} [decidable_linear_order σ] [discrete_linear_ordered_field α]

--to mame * between my_mvpolynomials
instance : comm_ring (my_mvpolynomial σ α):=
  finsupp.to_comm_ring

example : linear_order (multiset σ) := by apply_instance
example : partial_order (multiset σ) := by apply_instance

def my_mvpolynomial.coef (pol : my_mvpolynomial σ α): multiset σ -> α :=
  pol.to_fun

--DEGREE of MONOMIAL
def monomial_degree (ms: multiset σ) : ℕ :=
  multiset.card ms

def my_mvpolynomial.leading_mon (pol: my_mvpolynomial σ α ) : option (multiset σ) :=
  (finsupp.support pol).max

def degree_LM (pol: my_mvpolynomial σ α) : ℕ :=
  monomial_degree ((my_mvpolynomial.leading_mon pol).iget)

def is_zero (pol : my_mvpolynomial σ α) : bool :=
  pol = 0

def zero_ideal := ([0]: list (my_mvpolynomial σ α))

--variables (polt1 polt2: my_mvpolynomial σ α)

def my_mvpolynomial.leading_coef (pol: my_mvpolynomial σ α): α :=
  match (my_mvpolynomial.leading_mon pol) with
  | some ms := pol.coef ms
  | none := 0
end

-----LEADING TERM
def my_mvpolynomial.l_t (pol: my_mvpolynomial σ α ) : my_mvpolynomial σ α :=
  finsupp.single (my_mvpolynomial.leading_mon pol).iget (my_mvpolynomial.leading_coef pol)

--Representation of the polynomial
def my_mvpolynomial.repr [has_repr σ] [has_repr α] (p : my_mvpolynomial σ α) : string :=
  if p = 0 then "0" else ((finsupp.support p).sort multiset.lex).foldr
  (λ ms s, let coef := p.to_fun ms in
  s ++ (if (coef ≥ 0 ∧ s.length > 0) then " +" ++ repr coef else " " ++ repr coef) ++ repr ms ) ""

instance [has_repr σ] [has_repr α] : has_repr (my_mvpolynomial σ α) :=
  ⟨my_mvpolynomial.repr⟩

--used in for LCM of monomials
def multiset.add_repeats (ms: multiset σ) (aa : σ) (n: nat) : multiset σ :=
  (multiset.repeat aa n) + ms

#check @multiset.add_repeats
#eval multiset.add_repeats ({} : multiset ℕ) 2 5

--finds LCM of LM1 LM2, outputs in diff order
--for every x add to {} the max repetitions from m1 m2
def multiset.mon_LCM (m1 m2 : multiset σ) : multiset σ :=
  ((m1.to_finset) ∪ (m2.to_finset)).fold multiset.add ({})
  (λ x, multiset.add_repeats ({} : multiset σ) x (max (multiset.count x m1) (multiset.count x m2)))

#check multiset.mon_LCM
#eval multiset.mon_LCM ({3,3,2} : multiset ℕ) ({2,2, 8} : multiset ℕ)

def example_pol: my_mvpolynomial ℕ ℚ :=
  finsupp.single {1,3} 1 -
  finsupp.single {2,2} 1

--representation
#eval example_pol
#eval my_mvpolynomial.leading_coef example_pol
#eval my_mvpolynomial.leading_mon example_pol
#eval my_mvpolynomial.l_t example_pol

--define polyniomial examples
def f1: my_mvpolynomial ℕ ℚ :=
  finsupp.single {3,3,2} 1 -
  finsupp.single {} 1

def f2: my_mvpolynomial ℕ ℚ :=
  finsupp.single {3,2,2} 1 -
  finsupp.single {3} 1

def f3: my_mvpolynomial ℕ ℚ :=
  finsupp.single {3,3} 1 -
  finsupp.single {2} 1

def f4: my_mvpolynomial ℕ ℚ :=
  finsupp.single {2,2} 1 -
  finsupp.single {} 1

def g1: my_mvpolynomial ℕ ℚ :=
  finsupp.single {3,3} 1 +
  finsupp.single {3,2,2} 1

def g2: my_mvpolynomial ℕ ℚ :=
  finsupp.single {3,3} 1 -
  finsupp.single {2,2,2} 1

def g3: my_mvpolynomial ℕ ℚ :=
  finsupp.single {2,2,2} 1 -
  finsupp.single {2,2} 1

def g4: my_mvpolynomial ℕ ℚ :=
  finsupp.single {3,2,2} 1 +
  finsupp.single {2,2} 1

--LCM(LM1, LM2) / LM1
def s_monomial_l (pol1 pol2: my_mvpolynomial σ α): multiset σ :=
  let lmp1 := (my_mvpolynomial.leading_mon pol1).iget in
  (multiset.mon_LCM lmp1 (my_mvpolynomial.leading_mon pol2).iget) - lmp1

#eval f1
#eval my_mvpolynomial.leading_coef f1
#eval my_mvpolynomial.leading_mon f1
#eval my_mvpolynomial.l_t f1
#eval s_monomial_l f1 f2
#eval s_monomial_l f1 f3
#eval s_monomial_l f2 f3

--LCM(LM1, LM2) / LM2
def s_monomial_r (pol1 pol2: my_mvpolynomial σ α): multiset σ :=
  let lmp2 := (my_mvpolynomial.leading_mon pol2).iget in
  (multiset.mon_LCM (my_mvpolynomial.leading_mon pol1).iget lmp2) - lmp2

#eval my_mvpolynomial.leading_mon f2
#eval multiset.mon_LCM (my_mvpolynomial.leading_mon f1).iget (my_mvpolynomial.leading_mon f2).iget
#eval s_monomial_r f1 f2
#eval s_monomial_r f1 f3
#eval s_monomial_r f2 f3

--(LCM(LM1, LM2) / LT1) * 1
--(take monomaial and coef and make poly) * pol1
def s_polynomial_l (pol1 pol2: my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  (finsupp.single (s_monomial_l pol1 pol2) (1 / (my_mvpolynomial.leading_coef pol1))) * pol1

#eval s_polynomial_l f1 f2
#eval s_polynomial_l f1 f3
#eval s_polynomial_l f2 f3

--(LCM(LM1, LM2) / LT2) * 2
def s_polynomial_r (pol1 pol2: my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  (finsupp.single (s_monomial_r pol1 pol2) (1 / (my_mvpolynomial.leading_coef pol2))) * pol2

#eval s_polynomial_r f1 f2
#eval s_polynomial_r f1 f3
#eval s_polynomial_r f2 f3

-- S-Pol
-- S(pol1,pol2) = s_polynomial_l - s_polynomial_r
def s_polynomial (pol1 pol2: my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  (s_polynomial_l pol1 pol2) - (s_polynomial_r pol1 pol2)

#eval s_polynomial f1 f2
#eval s_polynomial f1 f3
#eval s_polynomial f2 f3

--pol2 = num, pol1 = den
--gives which mon from pol2 can be divided with lm(pol1)
def divide_witness (pol_d pol_n : my_mvpolynomial σ α) : option (multiset σ) :=
  let lmp1 := (my_mvpolynomial.leading_mon pol_d).iget in
  list.find (λ s2, ∀ s ∈ lmp1, (lmp1).count s ≤ (s2: multiset σ).count s) ((finsupp.support pol_n).sort multiset.lex)

--make multiset from divide_witness a polynomial
def divide_witness_pol (pol_d pol_n : my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  match divide_witness pol_d pol_n with
  | some ms := finsupp.single ms (pol_n.to_fun ms)
  | none := 0
end

-- n/d, q = 0, r = n,
--while divides tt, t = (C(r) / LC(d)) * (M(r) / LM(d))
--              q = q + t,
--              r = r - t * d

def find_pol_t (pol_r pol_d: my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  let dw := (divide_witness pol_d pol_r).iget in
  finsupp.single (dw - (my_mvpolynomial.leading_mon pol_d).iget)
  ((divide_witness_pol pol_d pol_r).coef dw / my_mvpolynomial.leading_coef pol_d)

--pol_n = pol_d * q + r -> pol_n/pol_d = q + (r / pol_d)
def find_new_q (pol_r pol_d pol_q: my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  (pol_q + find_pol_t pol_r pol_d)

def find_new_r (pol_r pol_d: my_mvpolynomial σ α) : my_mvpolynomial σ α :=
  pol_r - (find_pol_t pol_r pol_d) * pol_d

-- def smaller (pp1 pp2: my_mvpolynomial σ α) : bool :=
--   (((pp1.leading_mon α σ).iget).sort (≥) < ((pp2.leading_mon _ _).iget).sort (≥))

-- #eval smaller _ _ f1 f2

variables (σ α)
def wf_rel : (Σ' n : my_mvpolynomial σ α, list(my_mvpolynomial σ α)) →
(Σ' n : my_mvpolynomial σ α , list (my_mvpolynomial σ α)) → Prop :=
  λ m1 m2,
  ((m2.1.leading_mon).iget).sort (≥) < ((m1.1.leading_mon).iget).sort (≥)

#check wf_rel _ _
-- #check @well_founded _

lemma wf_rel_wf : well_founded (wf_rel α σ) := sorry

variables {σ α}
def long_div: my_mvpolynomial σ α -> list (my_mvpolynomial σ α) -> my_mvpolynomial σ α
| pol_n (h::t) :=
    have h1 : wf_rel α σ ⟨find_new_r pol_n h, h::t⟩ ⟨pol_n, h::t⟩, from sorry,
    have h2 : wf_rel α σ ⟨pol_n, t⟩ ⟨pol_n, h::t⟩, from sorry,
    if (divide_witness h pol_n) = none then long_div pol_n t
    else long_div (find_new_r pol_n h) (h::t)
| pol_n [] := pol_n
using_well_founded {rel_tac := λ α σ, `[exact ⟨wf_rel α σ, wf_rel_wf α σ⟩], dec_tac := `[assumption]}

#eval long_div (s_polynomial f1 f2) [f1,f2]
#eval long_div (s_polynomial f2 f2) [f1,f2,f3,f4]
#eval long_div (s_polynomial f3 f3) [f1,f2,f3,f4]
#eval long_div (s_polynomial f4 f4) [f1,f2,f3,f4]
#eval long_div (s_polynomial f1 f3) [f1,f2,f3]
#eval long_div (s_polynomial f1 f3) [f1,f2,f3]
#eval long_div (s_polynomial f2 f3) [f1,f2,f3]
#eval long_div (s_polynomial f2 f4) [f1,f2,f3,f4]
#eval long_div (s_polynomial f3 f4) [f1,f2,f3,f4]
#eval long_div (0) [f1,f2,f3,f4]

------------------------------- Definition Ideal.----------------------
-- A subset I ⊂ k[x1, . . . , xn] is an ideal if it satisfies:
-- (i) 0 ∈ I .
-- (ii) If f, g ∈ I , then f + g ∈ I .
-- (iii) If f ∈ I and h ∈ k[x1, . . . , xn], then h f ∈ I .

------------------------------------- Lemma -----------------------------
-- If f1, . . . , fs polynomials in k[x1, . . . , xn], then ⟨f1, . . . , fs⟩ is an ideal of
-- k[x1, . . . , xn]. We call ⟨f1,...,fs⟩ the ideal generated by f1,...,fs

--a basis G = {g1,...,gt} for I ≠ pol_zero  is a gb if ∀ pairs i ≠ j the remainder of S(gi, gt) / G (use my long_div) == 0
def bb_criterion (basis: list (my_mvpolynomial σ α)) : bool :=
  ∀ x ∈ basis, ∀ y ∈ basis, x ≠ y -> (long_div (s_polynomial x y) (basis) = 0)

--let I a pol ideal ≠ 0. then a gb for I can be constructed in a finite n of steps by the alg:
--1 input is an I = <f1, ... ,fs>
--2 output a GB, G = (g1, . . . , gt) for I , with F ⊂ G
--3 take input, F = (f1,...,fs). ∀ pairs i ≠ j, if remainder of S_pol is ≠ 0, add it to F

--check case where s_pol = 0, also should be r = 0
-- G := F
-- REPEAT
-- G := G
-- FOR each pair {p,q}, p 	= q in G DO
-- S := S(p,q)G
-- IF S 	= 0 THEN G := G ∪ {S}
-- UNTIL G = G

-- def smaller (pp1 pp2: my_mvpolynomial σ α) : bool :=
--   (((pp1.leading_mon _ _).iget).sort (≥) ≤ ((pp2.leading_mon _ _).iget).sort (≥))

--every nonzero ideal I ⊂ k[x1, . . . , xn] has a Groebner basis
--(h: my_ideal ≠ zero_ideal α σ)

meta def bb_alg_ax: list(my_mvpolynomial σ α) -> list (my_mvpolynomial σ α)
| [] := []
| (h::t) :=
    ((h::t) : list (my_mvpolynomial σ α)).foldr(λ p l,
    (((h::t): list (my_mvpolynomial σ α)).foldr(λ p1 l1,
    let remainder := (long_div (s_polynomial p p1) (h::t)) in
        if (remainder ≠ 0 ∧ remainder ∉ ((h::t) : list (my_mvpolynomial σ α)))
          then bb_alg_ax ((h::t) ++ [remainder])
        else l1))
    (l))
    (h::t)

meta def bb_alg: list(my_mvpolynomial σ α) -> list (my_mvpolynomial σ α)
| [] := []
| [zero_ideal] := []
| (h::t) :=
  bb_alg_ax (h::t)

#eval bb_alg [f1, f2]
#eval bb_alg [g1,g2,g3]
#eval bb_criterion [f1,f2,f3,f4]
#eval bb_criterion [f1,f2]
#eval bb_criterion [g1,g2,g3,g4]


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module geometry.manifold.bump_function
! leanprover-community/mathlib commit b018406ad2f2a73223a3a9e198ccae61e6f05318
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Calculus.BumpFunctionFindim
import Mathbin.Geometry.Manifold.ContMdiff

/-!
# Smooth bump functions on a smooth manifold

In this file we define `smooth_bump_function I c` to be a bundled smooth "bump" function centered at
`c`. It is a structure that consists of two real numbers `0 < r < R` with small enough `R`. We
define a coercion to function for this type, and for `f : smooth_bump_function I c`, the function
`⇑f` written in the extended chart at `c` has the following properties:

* `f x = 1` in the closed ball of radius `f.r` centered at `c`;
* `f x = 0` outside of the ball of radius `f.R` centered at `c`;
* `0 ≤ f x ≤ 1` for all `x`.

The actual statements involve (pre)images under `ext_chart_at I f` and are given as lemmas in the
`smooth_bump_function` namespace.

## Tags

manifold, smooth bump function
-/

universe uE uF uH uM

variable {E : Type uE} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
  {H : Type uH} [TopologicalSpace H] (I : ModelWithCorners ℝ E H) {M : Type uM} [TopologicalSpace M]
  [ChartedSpace H M] [SmoothManifoldWithCorners I M]

open Function Filter FiniteDimensional Set Metric

open Topology Manifold Classical Filter BigOperators

noncomputable section

/-!
### Smooth bump function

In this section we define a structure for a bundled smooth bump function and prove its properties.
-/

/-- Given a smooth manifold modelled on a finite dimensional space `E`,
`f : smooth_bump_function I M` is a smooth function on `M` such that in the extended chart `e` at
`f.c`:

* `f x = 1` in the closed ball of radius `f.r` centered at `f.c`;
* `f x = 0` outside of the ball of radius `f.R` centered at `f.c`;
* `0 ≤ f x ≤ 1` for all `x`.

The structure contains data required to construct a function with these properties. The function is
available as `⇑f` or `f x`. Formal statements of the properties listed above involve some
(pre)images under `ext_chart_at I f.c` and are given as lemmas in the `smooth_bump_function`
namespace. -/
structure SmoothBumpFunction (c : M) extends ContDiffBump (extChartAt I c c) where
  closedBall_subset : closedBall (extChartAt I c c) R ∩ range I ⊆ (extChartAt I c).target
#align smooth_bump_function SmoothBumpFunction

variable {M}

namespace SmoothBumpFunction

variable {c : M} (f : SmoothBumpFunction I c) {x : M} {I}

/-- The function defined by `f : smooth_bump_function c`. Use automatic coercion to function
instead. -/
def toFun : M → ℝ :=
  indicator (chartAt H c).source (f.toContDiffBump ∘ extChartAt I c)
#align smooth_bump_function.to_fun SmoothBumpFunction.toFun

instance : CoeFun (SmoothBumpFunction I c) fun _ => M → ℝ :=
  ⟨toFun⟩

theorem coe_def : ⇑f = indicator (chartAt H c).source (f.toContDiffBump ∘ extChartAt I c) :=
  rfl
#align smooth_bump_function.coe_def SmoothBumpFunction.coe_def

theorem r_pos : 0 < f.r :=
  f.toContDiffBump.r_pos
#align smooth_bump_function.R_pos SmoothBumpFunction.r_pos

theorem ball_subset : ball (extChartAt I c c) f.r ∩ range I ⊆ (extChartAt I c).target :=
  Subset.trans (inter_subset_inter_left _ ball_subset_closedBall) f.closedBall_subset
#align smooth_bump_function.ball_subset SmoothBumpFunction.ball_subset

theorem eqOn_source : EqOn f (f.toContDiffBump ∘ extChartAt I c) (chartAt H c).source :=
  eqOn_indicator
#align smooth_bump_function.eq_on_source SmoothBumpFunction.eqOn_source

theorem eventuallyEq_of_mem_source (hx : x ∈ (chartAt H c).source) :
    f =ᶠ[𝓝 x] f.toContDiffBump ∘ extChartAt I c :=
  f.EqOnSource.eventuallyEq_of_mem <| IsOpen.mem_nhds (chartAt H c).open_source hx
#align smooth_bump_function.eventually_eq_of_mem_source SmoothBumpFunction.eventuallyEq_of_mem_source

theorem one_of_dist_le (hs : x ∈ (chartAt H c).source)
    (hd : dist (extChartAt I c x) (extChartAt I c c) ≤ f.R) : f x = 1 := by
  simp only [f.eq_on_source hs, (· ∘ ·), f.to_cont_diff_bump.one_of_mem_closed_ball hd]
#align smooth_bump_function.one_of_dist_le SmoothBumpFunction.one_of_dist_le

theorem support_eq_inter_preimage :
    support f = (chartAt H c).source ∩ extChartAt I c ⁻¹' ball (extChartAt I c c) f.r := by
  rw [coe_def, support_indicator, (· ∘ ·), support_comp_eq_preimage, ← extChartAt_source I, ←
    (extChartAt I c).symm_image_target_inter_eq', ← (extChartAt I c).symm_image_target_inter_eq',
    f.to_cont_diff_bump.support_eq]
#align smooth_bump_function.support_eq_inter_preimage SmoothBumpFunction.support_eq_inter_preimage

theorem isOpen_support : IsOpen (support f) :=
  by
  rw [support_eq_inter_preimage]
  exact isOpen_extChartAt_preimage I c is_open_ball
#align smooth_bump_function.is_open_support SmoothBumpFunction.isOpen_support

theorem support_eq_symm_image :
    support f = (extChartAt I c).symm '' (ball (extChartAt I c c) f.r ∩ range I) :=
  by
  rw [f.support_eq_inter_preimage, ← extChartAt_source I, ←
    (extChartAt I c).symm_image_target_inter_eq', inter_comm]
  congr 1 with y
  exact
    and_congr_right_iff.2 fun hy =>
      ⟨fun h => extChartAt_target_subset_range _ _ h, fun h => f.ball_subset ⟨hy, h⟩⟩
#align smooth_bump_function.support_eq_symm_image SmoothBumpFunction.support_eq_symm_image

theorem support_subset_source : support f ⊆ (chartAt H c).source :=
  by
  rw [f.support_eq_inter_preimage, ← extChartAt_source I]
  exact inter_subset_left _ _
#align smooth_bump_function.support_subset_source SmoothBumpFunction.support_subset_source

theorem image_eq_inter_preimage_of_subset_support {s : Set M} (hs : s ⊆ support f) :
    extChartAt I c '' s =
      closedBall (extChartAt I c c) f.r ∩ range I ∩ (extChartAt I c).symm ⁻¹' s :=
  by
  rw [support_eq_inter_preimage, subset_inter_iff, ← extChartAt_source I, ← image_subset_iff] at hs
  cases' hs with hse hsf
  apply subset.antisymm
  · refine' subset_inter (subset_inter (subset.trans hsf ball_subset_closed_ball) _) _
    · rintro _ ⟨x, -, rfl⟩
      exact mem_range_self _
    · rw [(extChartAt I c).image_eq_target_inter_inv_preimage hse]
      exact inter_subset_right _ _
  · refine' subset.trans (inter_subset_inter_left _ f.closed_ball_subset) _
    rw [(extChartAt I c).image_eq_target_inter_inv_preimage hse]
#align smooth_bump_function.image_eq_inter_preimage_of_subset_support SmoothBumpFunction.image_eq_inter_preimage_of_subset_support

theorem mem_Icc : f x ∈ Icc (0 : ℝ) 1 :=
  by
  have : f x = 0 ∨ f x = _ := indicator_eq_zero_or_self _ _ _
  cases this <;> rw [this]
  exacts[left_mem_Icc.2 zero_le_one, ⟨f.to_cont_diff_bump.nonneg, f.to_cont_diff_bump.le_one⟩]
#align smooth_bump_function.mem_Icc SmoothBumpFunction.mem_Icc

theorem nonneg : 0 ≤ f x :=
  f.mem_Icc.1
#align smooth_bump_function.nonneg SmoothBumpFunction.nonneg

theorem le_one : f x ≤ 1 :=
  f.mem_Icc.2
#align smooth_bump_function.le_one SmoothBumpFunction.le_one

theorem eventuallyEq_one_of_dist_lt (hs : x ∈ (chartAt H c).source)
    (hd : dist (extChartAt I c x) (extChartAt I c c) < f.R) : f =ᶠ[𝓝 x] 1 :=
  by
  filter_upwards [IsOpen.mem_nhds (isOpen_extChartAt_preimage I c is_open_ball) ⟨hs, hd⟩]
  rintro z ⟨hzs, hzd : _ < _⟩
  exact f.one_of_dist_le hzs hzd.le
#align smooth_bump_function.eventually_eq_one_of_dist_lt SmoothBumpFunction.eventuallyEq_one_of_dist_lt

theorem eventuallyEq_one : f =ᶠ[𝓝 c] 1 :=
  f.eventuallyEq_one_of_dist_lt (mem_chart_source _ _) <|
    by
    rw [dist_self]
    exact f.r_pos
#align smooth_bump_function.eventually_eq_one SmoothBumpFunction.eventuallyEq_one

@[simp]
theorem eq_one : f c = 1 :=
  f.eventuallyEq_one.eq_of_nhds
#align smooth_bump_function.eq_one SmoothBumpFunction.eq_one

theorem support_mem_nhds : support f ∈ 𝓝 c :=
  f.eventuallyEq_one.mono fun x hx => by
    rw [hx]
    exact one_ne_zero
#align smooth_bump_function.support_mem_nhds SmoothBumpFunction.support_mem_nhds

theorem tsupport_mem_nhds : tsupport f ∈ 𝓝 c :=
  mem_of_superset f.support_mem_nhds subset_closure
#align smooth_bump_function.tsupport_mem_nhds SmoothBumpFunction.tsupport_mem_nhds

theorem c_mem_support : c ∈ support f :=
  mem_of_mem_nhds f.support_mem_nhds
#align smooth_bump_function.c_mem_support SmoothBumpFunction.c_mem_support

theorem nonempty_support : (support f).Nonempty :=
  ⟨c, f.c_mem_support⟩
#align smooth_bump_function.nonempty_support SmoothBumpFunction.nonempty_support

theorem isCompact_symm_image_closedBall :
    IsCompact ((extChartAt I c).symm '' (closedBall (extChartAt I c c) f.r ∩ range I)) :=
  ((isCompact_closedBall _ _).inter_right I.closed_range).image_of_continuousOn <|
    (continuousOn_extChartAt_symm _ _).mono f.closedBall_subset
#align smooth_bump_function.is_compact_symm_image_closed_ball SmoothBumpFunction.isCompact_symm_image_closedBall

/-- Given a smooth bump function `f : smooth_bump_function I c`, the closed ball of radius `f.R` is
known to include the support of `f`. These closed balls (in the model normed space `E`) intersected
with `set.range I` form a basis of `𝓝[range I] (ext_chart_at I c c)`. -/
theorem nhdsWithin_range_basis :
    (𝓝[range I] extChartAt I c c).HasBasis (fun f : SmoothBumpFunction I c => True) fun f =>
      closedBall (extChartAt I c c) f.r ∩ range I :=
  by
  refine'
    ((nhdsWithin_hasBasis nhds_basis_closed_ball _).restrict_subset
          (extChartAt_target_mem_nhdsWithin _ _)).to_has_basis'
      _ _
  · rintro R ⟨hR0, hsub⟩
    exact ⟨⟨⟨R / 2, R, half_pos hR0, half_lt_self hR0⟩, hsub⟩, trivial, subset.rfl⟩
  ·
    exact fun f _ =>
      inter_mem (mem_nhdsWithin_of_mem_nhds <| closed_ball_mem_nhds _ f.r_pos) self_mem_nhdsWithin
#align smooth_bump_function.nhds_within_range_basis SmoothBumpFunction.nhdsWithin_range_basis

theorem isClosed_image_of_isClosed {s : Set M} (hsc : IsClosed s) (hs : s ⊆ support f) :
    IsClosed (extChartAt I c '' s) :=
  by
  rw [f.image_eq_inter_preimage_of_subset_support hs]
  refine'
    ContinuousOn.preimage_closed_of_closed
      ((continuousOn_extChartAt_symm _ _).mono f.closed_ball_subset) _ hsc
  exact IsClosed.inter is_closed_ball I.closed_range
#align smooth_bump_function.is_closed_image_of_is_closed SmoothBumpFunction.isClosed_image_of_isClosed

/-- If `f` is a smooth bump function and `s` closed subset of the support of `f` (i.e., of the open
ball of radius `f.R`), then there exists `0 < r < f.R` such that `s` is a subset of the open ball of
radius `r`. Formally, `s ⊆ e.source ∩ e ⁻¹' (ball (e c) r)`, where `e = ext_chart_at I c`. -/
theorem exists_r_pos_lt_subset_ball {s : Set M} (hsc : IsClosed s) (hs : s ⊆ support f) :
    ∃ (r : _)(hr : r ∈ Ioo 0 f.r),
      s ⊆ (chartAt H c).source ∩ extChartAt I c ⁻¹' ball (extChartAt I c c) r :=
  by
  set e := extChartAt I c
  have : IsClosed (e '' s) := f.is_closed_image_of_is_closed hsc hs
  rw [support_eq_inter_preimage, subset_inter_iff, ← image_subset_iff] at hs
  rcases exists_pos_lt_subset_ball f.R_pos this hs.2 with ⟨r, hrR, hr⟩
  exact ⟨r, hrR, subset_inter hs.1 (image_subset_iff.1 hr)⟩
#align smooth_bump_function.exists_r_pos_lt_subset_ball SmoothBumpFunction.exists_r_pos_lt_subset_ball

/-- Replace `r` with another value in the interval `(0, f.R)`. -/
def updateR (r : ℝ) (hr : r ∈ Ioo 0 f.r) : SmoothBumpFunction I c :=
  ⟨⟨r, f.r, hr.1, hr.2⟩, f.closedBall_subset⟩
#align smooth_bump_function.update_r SmoothBumpFunction.updateR

@[simp]
theorem updateR_r {r : ℝ} (hr : r ∈ Ioo 0 f.r) : (f.updateR r hr).r = f.r :=
  rfl
#align smooth_bump_function.update_r_R SmoothBumpFunction.updateR_r

/- warning: smooth_bump_function.update_r_r clashes with smooth_bump_function.update_r_R -> SmoothBumpFunction.updateR_r
warning: smooth_bump_function.update_r_r -> SmoothBumpFunction.updateR_r is a dubious translation:
lean 3 declaration is
  forall {E : Type.{u1}} [_inst_1 : NormedAddCommGroup.{u1} E] [_inst_2 : NormedSpace.{0, u1} Real E Real.normedField (NormedAddCommGroup.toSeminormedAddCommGroup.{u1} E _inst_1)] [_inst_3 : FiniteDimensional.{0, u1} Real E Real.divisionRing (NormedAddCommGroup.toAddCommGroup.{u1} E _inst_1) (NormedSpace.toModule.{0, u1} Real E Real.normedField (NormedAddCommGroup.toSeminormedAddCommGroup.{u1} E _inst_1) _inst_2)] {H : Type.{u2}} [_inst_4 : TopologicalSpace.{u2} H] {I : ModelWithCorners.{0, u1, u2} Real (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) E _inst_1 _inst_2 H _inst_4} {M : Type.{u3}} [_inst_5 : TopologicalSpace.{u3} M] [_inst_6 : ChartedSpace.{u2, u3} H _inst_4 M _inst_5] [_inst_7 : SmoothManifoldWithCorners.{0, u1, u2, u3} Real (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) E _inst_1 _inst_2 H _inst_4 I M _inst_5 _inst_6] {c : M} (f : SmoothBumpFunction.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c) {r : Real} (hr : Membership.Mem.{0, 0} Real (Set.{0} Real) (Set.hasMem.{0} Real) r (Set.Ioo.{0} Real Real.preorder (OfNat.ofNat.{0} Real 0 (OfNat.mk.{0} Real 0 (Zero.zero.{0} Real Real.hasZero))) (ContDiffBump.r.{u1} E (coeFn.{max (succ u3) (succ u1), max (succ u3) (succ u1)} (LocalEquiv.{u3, u1} M E) (fun (_x : LocalEquiv.{u3, u1} M E) => M -> E) (LocalEquiv.hasCoeToFun.{u3, u1} M E) (extChartAt.{0, u1, u3, u2} Real E M H (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) _inst_1 _inst_2 _inst_4 _inst_5 I _inst_6 c) c) (SmoothBumpFunction.toContDiffBump.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c f)))), Eq.{1} Real (ContDiffBump.r.{u1} E (coeFn.{max (succ u3) (succ u1), max (succ u3) (succ u1)} (LocalEquiv.{u3, u1} M E) (fun (_x : LocalEquiv.{u3, u1} M E) => M -> E) (LocalEquiv.hasCoeToFun.{u3, u1} M E) (extChartAt.{0, u1, u3, u2} Real E M H (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) _inst_1 _inst_2 _inst_4 _inst_5 I _inst_6 c) c) (SmoothBumpFunction.toContDiffBump.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c (SmoothBumpFunction.updateR.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c f r hr))) r
but is expected to have type
  forall {E : Type.{u1}} [_inst_1 : NormedAddCommGroup.{u1} E] [_inst_2 : NormedSpace.{0, u1} Real E Real.normedField (NormedAddCommGroup.toSeminormedAddCommGroup.{u1} E _inst_1)] [_inst_3 : FiniteDimensional.{0, u1} Real E Real.divisionRing (NormedAddCommGroup.toAddCommGroup.{u1} E _inst_1) (NormedSpace.toModule.{0, u1} Real E Real.normedField (NormedAddCommGroup.toSeminormedAddCommGroup.{u1} E _inst_1) _inst_2)] {H : Type.{u2}} [_inst_4 : TopologicalSpace.{u2} H] {I : ModelWithCorners.{0, u1, u2} Real (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) E _inst_1 _inst_2 H _inst_4} {M : Type.{u3}} [_inst_5 : TopologicalSpace.{u3} M] [_inst_6 : ChartedSpace.{u2, u3} H _inst_4 M _inst_5] [_inst_7 : SmoothManifoldWithCorners.{0, u1, u2, u3} Real (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) E _inst_1 _inst_2 H _inst_4 I M _inst_5 _inst_6] {c : M} (f : SmoothBumpFunction.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c) {r : Real} (hr : Membership.Mem.{0, 0} Real (Set.{0} Real) (Set.hasMem.{0} Real) r (Set.Ioo.{0} Real Real.preorder (OfNat.ofNat.{0} Real 0 (OfNat.mk.{0} Real 0 (Zero.zero.{0} Real Real.hasZero))) (ContDiffBump.r.{u1} E (coeFn.{max (succ u3) (succ u1), max (succ u3) (succ u1)} (LocalEquiv.{u3, u1} M E) (fun (_x : LocalEquiv.{u3, u1} M E) => M -> E) (LocalEquiv.hasCoeToFun.{u3, u1} M E) (extChartAt.{0, u1, u3, u2} Real E M H (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) _inst_1 _inst_2 _inst_4 _inst_5 I _inst_6 c) c) (SmoothBumpFunction.toContDiffBump.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c f)))), Eq.{1} Real (ContDiffBump.r.{u1} E (coeFn.{max (succ u3) (succ u1), max (succ u3) (succ u1)} (LocalEquiv.{u3, u1} M E) (fun (_x : LocalEquiv.{u3, u1} M E) => M -> E) (LocalEquiv.hasCoeToFun.{u3, u1} M E) (extChartAt.{0, u1, u3, u2} Real E M H (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) _inst_1 _inst_2 _inst_4 _inst_5 I _inst_6 c) c) (SmoothBumpFunction.toContDiffBump.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c (SmoothBumpFunction.updateR.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c f r hr))) (ContDiffBump.r.{u1} E (coeFn.{max (succ u3) (succ u1), max (succ u3) (succ u1)} (LocalEquiv.{u3, u1} M E) (fun (_x : LocalEquiv.{u3, u1} M E) => M -> E) (LocalEquiv.hasCoeToFun.{u3, u1} M E) (extChartAt.{0, u1, u3, u2} Real E M H (DenselyNormedField.toNontriviallyNormedField.{0} Real Real.denselyNormedField) _inst_1 _inst_2 _inst_4 _inst_5 I _inst_6 c) c) (SmoothBumpFunction.toContDiffBump.{u1, u2, u3} E _inst_1 _inst_2 _inst_3 H _inst_4 I M _inst_5 _inst_6 _inst_7 c f))
Case conversion may be inaccurate. Consider using '#align smooth_bump_function.update_r_r SmoothBumpFunction.updateR_rₓ'. -/
@[simp]
theorem updateR_r {r : ℝ} (hr : r ∈ Ioo 0 f.r) : (f.updateR r hr).R = r :=
  rfl
#align smooth_bump_function.update_r_r SmoothBumpFunction.updateR_r

@[simp]
theorem support_updateR {r : ℝ} (hr : r ∈ Ioo 0 f.r) : support (f.updateR r hr) = support f := by
  simp only [support_eq_inter_preimage, update_r_R]
#align smooth_bump_function.support_update_r SmoothBumpFunction.support_updateR

instance : Inhabited (SmoothBumpFunction I c) :=
  Classical.inhabited_of_nonempty nhdsWithin_range_basis.Nonempty

variable [T2Space M]

theorem isClosed_symm_image_closedBall :
    IsClosed ((extChartAt I c).symm '' (closedBall (extChartAt I c c) f.r ∩ range I)) :=
  f.isCompact_symm_image_closedBall.IsClosed
#align smooth_bump_function.is_closed_symm_image_closed_ball SmoothBumpFunction.isClosed_symm_image_closedBall

theorem tsupport_subset_symm_image_closedBall :
    tsupport f ⊆ (extChartAt I c).symm '' (closedBall (extChartAt I c c) f.r ∩ range I) :=
  by
  rw [tsupport, support_eq_symm_image]
  exact
    closure_minimal (image_subset _ <| inter_subset_inter_left _ ball_subset_closed_ball)
      f.is_closed_symm_image_closed_ball
#align smooth_bump_function.tsupport_subset_symm_image_closed_ball SmoothBumpFunction.tsupport_subset_symm_image_closedBall

theorem tsupport_subset_extChartAt_source : tsupport f ⊆ (extChartAt I c).source :=
  calc
    tsupport f ⊆ (extChartAt I c).symm '' (closedBall (extChartAt I c c) f.r ∩ range I) :=
      f.tsupport_subset_symm_image_closedBall
    _ ⊆ (extChartAt I c).symm '' (extChartAt I c).target := (image_subset _ f.closedBall_subset)
    _ = (extChartAt I c).source := (extChartAt I c).symm_image_target_eq_source

#align smooth_bump_function.tsupport_subset_ext_chart_at_source SmoothBumpFunction.tsupport_subset_extChartAt_source

theorem tsupport_subset_chartAt_source : tsupport f ⊆ (chartAt H c).source := by
  simpa only [extChartAt_source] using f.tsupport_subset_ext_chart_at_source
#align smooth_bump_function.tsupport_subset_chart_at_source SmoothBumpFunction.tsupport_subset_chartAt_source

protected theorem hasCompactSupport : HasCompactSupport f :=
  isCompact_of_isClosed_subset f.isCompact_symm_image_closedBall isClosed_closure
    f.tsupport_subset_symm_image_closedBall
#align smooth_bump_function.has_compact_support SmoothBumpFunction.hasCompactSupport

variable (I c)

/-- The closures of supports of smooth bump functions centered at `c` form a basis of `𝓝 c`.
In other words, each of these closures is a neighborhood of `c` and each neighborhood of `c`
includes `tsupport f` for some `f : smooth_bump_function I c`. -/
theorem nhds_basis_tsupport :
    (𝓝 c).HasBasis (fun f : SmoothBumpFunction I c => True) fun f => tsupport f :=
  by
  have :
    (𝓝 c).HasBasis (fun f : SmoothBumpFunction I c => True) fun f =>
      (extChartAt I c).symm '' (closed_ball (extChartAt I c c) f.r ∩ range I) :=
    by
    rw [← map_extChartAt_symm_nhdsWithin_range I c]
    exact nhds_within_range_basis.map _
  refine'
    this.to_has_basis' (fun f hf => ⟨f, trivial, f.tsupport_subset_symm_image_closedBall⟩)
      fun f _ => f.tsupport_mem_nhds
#align smooth_bump_function.nhds_basis_tsupport SmoothBumpFunction.nhds_basis_tsupport

variable {c}

/-- Given `s ∈ 𝓝 c`, the supports of smooth bump functions `f : smooth_bump_function I c` such that
`tsupport f ⊆ s` form a basis of `𝓝 c`.  In other words, each of these supports is a
neighborhood of `c` and each neighborhood of `c` includes `support f` for some `f :
smooth_bump_function I c` such that `tsupport f ⊆ s`. -/
theorem nhds_basis_support {s : Set M} (hs : s ∈ 𝓝 c) :
    (𝓝 c).HasBasis (fun f : SmoothBumpFunction I c => tsupport f ⊆ s) fun f => support f :=
  ((nhds_basis_tsupport I c).restrict_subset hs).to_has_basis'
    (fun f hf => ⟨f, hf.2, subset_closure⟩) fun f hf => f.support_mem_nhds
#align smooth_bump_function.nhds_basis_support SmoothBumpFunction.nhds_basis_support

variable [SmoothManifoldWithCorners I M] {I}

/-- A smooth bump function is infinitely smooth. -/
protected theorem smooth : Smooth I 𝓘(ℝ) f :=
  by
  refine' contMdiff_of_support fun x hx => _
  have : x ∈ (chart_at H c).source := f.tsupport_subset_chart_at_source hx
  refine'
    ContMdiffAt.congr_of_eventuallyEq _
      (f.eq_on_source.eventually_eq_of_mem <| IsOpen.mem_nhds (chart_at _ _).open_source this)
  exact f.to_cont_diff_bump.cont_diff_at.cont_mdiff_at.comp _ (contMdiffAt_ext_chart_at' this)
#align smooth_bump_function.smooth SmoothBumpFunction.smooth

protected theorem smoothAt {x} : SmoothAt I 𝓘(ℝ) f x :=
  f.smooth.SmoothAt
#align smooth_bump_function.smooth_at SmoothBumpFunction.smoothAt

protected theorem continuous : Continuous f :=
  f.smooth.Continuous
#align smooth_bump_function.continuous SmoothBumpFunction.continuous

/-- If `f : smooth_bump_function I c` is a smooth bump function and `g : M → G` is a function smooth
on the source of the chart at `c`, then `f • g` is smooth on the whole manifold. -/
theorem smooth_smul {G} [NormedAddCommGroup G] [NormedSpace ℝ G] {g : M → G}
    (hg : SmoothOn I 𝓘(ℝ, G) g (chartAt H c).source) : Smooth I 𝓘(ℝ, G) fun x => f x • g x :=
  by
  apply contMdiff_of_support fun x hx => _
  have : x ∈ (chart_at H c).source
  calc
    x ∈ tsupport fun x => f x • g x := hx
    _ ⊆ tsupport f := (tsupport_smul_subset_left _ _)
    _ ⊆ (chart_at _ c).source := f.tsupport_subset_chart_at_source

  exact
    f.smooth_at.smul ((hg _ this).ContMdiffAt <| IsOpen.mem_nhds (chart_at _ _).open_source this)
#align smooth_bump_function.smooth_smul SmoothBumpFunction.smooth_smul

end SmoothBumpFunction


import algebra.field
import algebra.char_zero
import algebra.char_p
import gtm106.naive_plane
import gtm106.weierstrass_equation.basic
import gtm106.weierstrass_equation.linear_change_of_variable
import gtm106.weierstrass_equation.models_by_characteristic
import myhelper.mypoly.char_and_perfect
import tactic

namespace weierstrass_equation

/--
`Prop` that a Weierstrass equation is singular with singular point `(0,0)`.
-/
def is_singular_model
{K : Type*} [comm_ring K] (E : weierstrass_equation K) :=
E.a3 = 0 ∧ E.a4 = 0 ∧ E.a6 = 0

@[simp]
lemma c4_of_singular_model {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_singular_model) :
E.c4 = E.b2^2 :=
begin
  simp [c4, b2, b4, h.1, h.2.1],
end

@[simp]
lemma disc_of_singular_model {K : Type*} [comm_ring K]
(E : weierstrass_equation K) (h : E.is_singular_model) :
E.disc = 0 :=
begin
  simp [disc, b2, b4, b6, b8, h.1, h.2.1, h.2.2],
end

lemma has_singular_model
{K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K) (hP : E.affine_point_singular P) :
∃ C : linear_change_of_variable K, (C.change_curve E).is_singular_model
∧ (C.change_affine_point P) = ⟨ 0, 0 ⟩ :=
begin
  let C : linear_change_of_variable K := ⟨ 1, P.x, 0, P.y, by simp ⟩,
  use C,
  rw C.preserve_affine_singular_point E at hP,
  set E' := C.change_curve E with hE', clear_value E',
  set P' := C.change_affine_point P with hP', clear_value P',
  simp [linear_change_of_variable.change_affine_point] at hP',
  split, {
    simp [affine_plane_point.ext_iff] at hP',
    simp [affine_point_singular,
      affine_point_on_curve,
      eval_at_affine_point,
      eval_dx_at_affine_point,
      eval_dy_at_affine_point,
      hP'.1, hP'.2, zero_pow] at hP,
    exact ⟨ hP.2.2, hP.2.1, hP.1 ⟩,
  },
  exact hP',
end

/--
If a Weierstrass equation has non-zero discriminant,
then it does not have rational singular point.
-/
lemma disc_non_zero_implies_non_singular
{K : Type*} [field K] (E : weierstrass_equation K) :
E.non_singular' → E.non_singular :=
begin
  contrapose,
  rw E.singular_iff_has_affine_singular_point,
  rintros ⟨ P, hP ⟩,
  rcases E.has_singular_model P hP with ⟨ C, h2, h3 ⟩,
  rw C.preserve_non_singular',
  set E' : weierstrass_equation K := C.change_curve E, clear_value E',
  simp [non_singular', h2],
end

lemma non_singular_implies_disc_non_zero.char_2_case
{K : Type*} [field K] (E : weierstrass_equation K)
(hperfect : (ring_char K = 2 ∨ ring_char K = 3) ∧ E.c4 = 0 → my_perfect_field K)
(hchar2 : ring_char K = 2) :
E.non_singular → E.non_singular' :=
begin
  rcases E.have_model_of_char_2 hchar2 with ⟨ hj, C, ha1, ha3, ha4 ⟩ | ⟨ hj, C, ha1, ha2 ⟩, {
    rw [C.preserve_non_singular E, C.preserve_non_singular' E,
      non_singular_iff_affine_non_singular],
    set E' := C.change_curve E with hE, clear_value E',
    intros hsmooth hdisc,
    rw E'.disc_of_model_of_char_2_j_non_zero ⟨ ha1, ha3, ha4 ⟩ hchar2 at hdisc,
    let P : affine_plane_point K := ⟨ 0, 0 ⟩,
    have hP : E'.affine_point_on_curve P := by {
      simp [affine_point_on_curve,
        eval_at_affine_point,
        ha1, ha3, ha4, hdisc],
    },
    replace hsmooth := (hsmooth P hP).2,
    simp [eval_dx_at_affine_point,
      eval_dy_at_affine_point,
      ha1, ha3, ha4] at hsmooth,
    exact hsmooth,
  }, {
    replace hperfect : nth_power_surjective K 2 := by {
      have hc4 := (C.change_curve E).c4_of_model_of_char_2_j_zero ⟨ ha1, ha2 ⟩ hchar2,
      simp at hc4,
      simp [hchar2, hc4, my_perfect_field] at hperfect,
      exact hperfect,
    },
    rw [C.preserve_non_singular E, C.preserve_non_singular' E,
      non_singular_iff_affine_non_singular],
    set E' := C.change_curve E with hE, clear_value E',
    intros hsmooth hdisc,
    simp [E'.disc_of_model_of_char_2_j_zero ⟨ ha1, ha2 ⟩ hchar2] at hdisc,
    cases hperfect E'.a4 with x hx,
    cases hperfect (x^3+E'.a4*x+E'.a6) with y hy,
    have hP : E'.affine_point_on_curve ⟨ x, y ⟩ := by {
      simp [affine_point_on_curve,
        eval_at_affine_point,
        ha1, ha2, hdisc, hy],
      ring,
    },
    replace hsmooth := (hsmooth _ hP).2,
    simp [eval_dx_at_affine_point,
      eval_dy_at_affine_point,
      ha1, ha2, hdisc, hx] at hsmooth,
    ring_nf at hsmooth,
    ring_char2 at hsmooth,
    exact hsmooth,
  },
end

lemma non_singular_implies_disc_non_zero.char_neq_2_case
{K : Type*} [field K] (E : weierstrass_equation K)
(hperfect : (ring_char K = 2 ∨ ring_char K = 3) ∧ E.c4 = 0 → my_perfect_field K)
(hchar2 : ring_char K ≠ 2) :
E.non_singular → E.non_singular' :=
begin
  rcases E.have_model_of_char_neq_2 hchar2 with ⟨ C, ha1, ha3 ⟩,
  rw [C.preserve_non_singular E, C.preserve_non_singular' E,
    non_singular_iff_affine_non_singular],
  set E' := C.change_curve E with hE, clear_value E',
  intros hsmooth hdisc,
  let f : monic_cubic_poly K := ⟨ E'.a2, E'.a4, E'.a6 ⟩,
  have hdisc' : E'.disc = 16*f.disc := by {
    rw E'.disc_of_model_of_char_neq_2 ⟨ ha1, ha3 ⟩,
    unfold monic_cubic_poly.disc,
    ring,
  },
  have h16 := power_of_prime_neq_char_is_non_zero K 16 2 4 (by norm_num) (by norm_num) hchar2,
  norm_num at h16,
  simp [hdisc, h16] at hdisc',
  replace hperfect : ring_char K = 2 ∨ (ring_char K = 3 ∧ f.a = 0) → my_perfect_field K := by {
    by_cases hchar3 : ring_char K = 3, {
      intro h,
      simp [hchar2, hchar3] at h,
      replace h : E'.c4 = 0 := by {
        rw [E'.c4_of_model_of_char_neq_2 ⟨ ha1, ha3 ⟩, h],
        ring_char3,
      },
      simp [hE] at h,
      simp [hchar3, h] at hperfect,
      exact hperfect,
    },
    simp [hchar2, hchar3],
  },
  rcases f.disc_zero_implies_has_multiple_root hperfect hdisc' with ⟨ x, h1, h2 ⟩,
  replace h1 := calc x^3
  = -E'.a2*x^2 - E'.a4*x - E'.a6 + f.eval_at x : by { simp [monic_cubic_poly.eval_at], }
  ... = -E'.a2*x^2 - E'.a4*x - E'.a6 : by { simp [h1], },
  replace h2 := calc 3*x^2 = -2*E'.a2*x - E'.a4 + f.eval_dx_at x : by { simp [monic_cubic_poly.eval_dx_at], }
  ... = -2*E'.a2*x - E'.a4 : by { simp [h2], },
  let P := affine_plane_point.mk x 0,
  have hP : E'.affine_point_on_curve P := by {
    simp [affine_point_on_curve,
      eval_at_affine_point,
      h1, ha1, ha3], ring,
  },
  replace hsmooth := (hsmooth P hP).2,
  simp [eval_dx_at_affine_point,
    eval_dy_at_affine_point,
    h2, ha1, ha3] at hsmooth,
  exact hsmooth,
end

/--
If a Weierstrass equation has no rational singular point,
under the assumption that the field is not of characteristic 2 or 3, or is perfect,
the Weierstrass equation is of non-zero discriminant.

NOTE: When the field is of characteristic 2 or 3, the singular point
may be defined over a finite inseparable extension.
-/
lemma non_singular_implies_disc_non_zero
{K : Type*} [field K] (E : weierstrass_equation K)
(hperfect : (ring_char K = 2 ∨ ring_char K = 3) ∧ E.c4 = 0 → my_perfect_field K) :
E.non_singular → E.non_singular' :=
begin
  by_cases hchar2 : ring_char K = 2, {
    exact non_singular_implies_disc_non_zero.char_2_case E hperfect hchar2,
  },
  exact non_singular_implies_disc_non_zero.char_neq_2_case E hperfect hchar2,
end

/--
A Weierstrass equation has at most one singular point.
-/
lemma at_most_one_singular_point
{K : Type*} [field K] (E : weierstrass_equation K) (P P' : affine_plane_point K)
(hP : E.affine_point_singular P) (hP' : E.affine_point_singular P') : P = P' :=
begin
  rcases E.has_singular_model P hP with ⟨ C, hsing, h0 ⟩,
  rw ← linear_change_of_variable.change_affine_point.id P,
  rw ← linear_change_of_variable.change_affine_point.id P',
  rw ← C.inv_comp,
  repeat { rw ← linear_change_of_variable.change_affine_point.comp },
  rw C.preserve_affine_singular_point E _ at hP hP',
  set Q := C.change_affine_point P, clear_value Q,
  set Q' := C.change_affine_point P', clear_value Q',
  set E' := C.change_curve E, clear_value E',
  congr,
  simp [h0, affine_plane_point.ext_iff],
  simp [affine_point_singular,
    affine_point_on_curve,
    eval_at_affine_point,
    eval_dx_at_affine_point,
    eval_dy_at_affine_point,
    hsing.1, hsing.2.1, hsing.2.2] at hP',
  rcases hP' with ⟨ h1, h2, h3 ⟩,
  by_cases hx : Q'.x = 0, {
    simp [hx, zero_pow] at h1,
    exact ⟨ hx.symm, h1.symm ⟩,
  },
  exfalso,
  have h4 := calc Q'.x * (E'.a1 * Q'.y - 2 * E'.a2 * Q'.x)
  = 6 * (Q'.y ^ 2 + E'.a1 * Q'.x * Q'.y - Q'.x ^ 3 - E'.a2 * Q'.x ^ 2)
  - 2 * Q'.x * (E'.a1 * Q'.y - 3 * Q'.x ^ 2 - 2 * E'.a2 * Q'.x)
  - 3 * Q'.y * (2 * Q'.y + E'.a1 * Q'.x) : by ring
  ... = 0 : by { rw [h1, h2, h3], ring, },
  simp [hx] at h4,
  have hchar3 := calc 3 * Q'.x ^ 2 = (E'.a1 * Q'.y - 2 * E'.a2 * Q'.x)
  - (E'.a1 * Q'.y - 3 * Q'.x ^ 2 - 2 * E'.a2 * Q'.x) : by ring
  ... = 0 : by { rw [h2, h4], ring, },
  simp [hx] at hchar3,
  replace h3 := calc Q'.y = Q'.y + (2 * Q'.y + E'.a1 * Q'.x) : by { simp [h3], }
  ... = E'.a1 * Q'.x : by { ring_nf, simp [hchar3], },
  replace h4 := calc Q'.x * (E'.a1 ^ 2 + (1 - 3) * E'.a2)
  = E'.a1 * Q'.y - 2 * E'.a2 * Q'.x : by { rw h3, ring, }
  ... = 0 : h4,
  simp [hchar3, hx] at h4,
  replace h4 := calc E'.a2 = -E'.a1 ^ 2 + (E'.a1 ^ 2 + E'.a2) : by ring
  ... = -E'.a1 ^ 2 : by { rw h4, ring, },
  rw [h3, h4] at h1,
  replace h1 := calc (3 * E'.a1^2 - Q'.x) * Q'.x ^ 2
  = (E'.a1 * Q'.x) ^ 2 + E'.a1 * Q'.x * (E'.a1 * Q'.x) - Q'.x ^ 3 - -E'.a1 ^ 2 * Q'.x ^ 2 : by ring
  ... = 0 : h1,
  simp [hchar3, hx] at h1,
  exact h1,
end

lemma singular_implies_has_node_or_cusp
{K : Type*} [field K] (E : weierstrass_equation K) :
¬ E.non_singular → (¬ E.has_node ↔ E.has_cusp) :=
begin
  rw E.singular_iff_has_affine_singular_point,
  rintros ⟨ P, hP ⟩,
  have hP' := E.singular_point_is_node_or_cusp P hP,
  split, {
    intro h,
    unfold has_node at h,
    push_neg at h,
    replace hP' := hP'.1 (h P),
    exact ⟨ P, hP' ⟩,
  },
  rintros ⟨ P1, h1 ⟩ ⟨ P2, h2 ⟩,
  have := E.at_most_one_singular_point P1 P h1.1 hP,
  rw this at h1,
  have := E.at_most_one_singular_point P2 P h2.1 hP,
  rw this at h2,
  finish,
end

/--
If a Weierstrass equation has a rational node,
then its discriminant is zero and `c4` is not zero.
-/
lemma has_node_implies_disc_zero_c4_non_zero
{K : Type*} [field K] (E : weierstrass_equation K) :
E.has_node → E.has_node' :=
begin
  rintros ⟨ P, hP, hH ⟩,
  rcases E.has_singular_model P hP with ⟨ C, h2, h3 ⟩,
  replace hH : (E.eval_hessian_at_affine_point P)/C.u^2 ≠ 0 := by {
    field_simp [hH],
  },
  rw ← C.eval_hessian_at_affine_point E P at hH,
  rw C.preserve_has_node' E,
  rw C.preserve_affine_singular_point E P at hP,
  set E' := C.change_curve E, clear_value E',
  set P' := C.change_affine_point P, clear_value P',
  have h := mt E'.disc_non_zero_implies_non_singular,
  rw E'.singular_iff_has_affine_singular_point at h,
  replace h := h ⟨ P', hP ⟩,
  simp [non_singular'] at h,
  use h,
  simp [affine_plane_point.ext_iff] at h3,
  simp [eval_hessian_at_affine_point, h3.1] at hH,
  simp [c4, b4, h2.1, h2.2.1, hH],
end

/--
If a Weierstrass equation has a rational cusp,
then its discriminant is zero and `c4` is also zero.
-/
lemma has_cusp_implies_disc_zero_c4_zero
{K : Type*} [field K] (E : weierstrass_equation K) :
E.has_cusp → E.has_cusp' :=
begin
  rintros ⟨ P, hP, hH ⟩,
  rcases E.has_singular_model P hP with ⟨ C, h2, h3 ⟩,
  replace hH : (E.eval_hessian_at_affine_point P)/C.u^2 = 0 := by {
    field_simp [hH],
  },
  rw ← C.eval_hessian_at_affine_point E P at hH,
  rw C.preserve_has_cusp' E,
  rw C.preserve_affine_singular_point E P at hP,
  set E' := C.change_curve E, clear_value E',
  set P' := C.change_affine_point P, clear_value P',
  have h := mt E'.disc_non_zero_implies_non_singular,
  rw E'.singular_iff_has_affine_singular_point at h,
  replace h := h ⟨ P', hP ⟩,
  simp [non_singular'] at h,
  use h,
  simp [affine_plane_point.ext_iff] at h3,
  simp [eval_hessian_at_affine_point, h3.1] at hH,
  simp [c4, b4, h2.1, h2.2.1, hH],
end

/--
If a Weierstrass is of discriminant zero and `c4` non-zero,
then it has a rational node.
-/
lemma disc_zero_c4_non_zero_implies_has_node
{K : Type*} [field K] (E : weierstrass_equation K) :
E.has_node' → E.has_node :=
begin
  rintros ⟨ hdisc, hc4 ⟩,
  have hperfect : (ring_char K = 2 ∨ ring_char K = 3) ∧ E.c4 = 0 → my_perfect_field K := by {
    simp [hc4],
  },
  have hsing := mt (E.non_singular_implies_disc_non_zero hperfect),
  rw E.singular_iff_has_affine_singular_point at hsing,
  simp [non_singular', hdisc] at hsing,
  rcases hsing with ⟨ P, hP ⟩,
  rcases E.has_singular_model P hP with ⟨ C, h2, h3 ⟩,
  rw C.preserve_has_node E,
  rw C.preserve_affine_singular_point E P at hP,
  set E' := C.change_curve E with hE', clear_value E',
  set P' := C.change_affine_point P with hP', clear_value P',
  replace hc4 : E'.c4 ≠ 0 := by {
    simp [hE', hc4],
  },
  simp [h2] at hc4,
  simp [affine_plane_point.ext_iff] at h3,
  use [P', hP],
  simp [eval_hessian_at_affine_point, h3.1, hc4],
end

/--
If a Weierstrass is of discriminant zero and `c4` zero,
under the assumption that the field is not of characteristic 2 or 3, or is perfect,
it has a rational cusp.
-/
lemma disc_zero_c4_zero_implies_has_cusp
{K : Type*} [field K] (E : weierstrass_equation K)
(hperfect : ring_char K = 2 ∨ ring_char K = 3 → my_perfect_field K):
E.has_cusp' → E.has_cusp :=
begin
  rintros ⟨ hdisc, hc4 ⟩,
  replace hperfect : (ring_char K = 2 ∨ ring_char K = 3) ∧ E.c4 = 0 → my_perfect_field K := by {
    intro h,
    exact hperfect h.1,
  },
  have hsing := mt (E.non_singular_implies_disc_non_zero hperfect),
  rw E.singular_iff_has_affine_singular_point at hsing,
  simp [non_singular', hdisc] at hsing,
  rcases hsing with ⟨ P, hP ⟩,
  rcases E.has_singular_model P hP with ⟨ C, h2, h3 ⟩,
  rw C.preserve_has_cusp E,
  rw C.preserve_affine_singular_point E P at hP,
  set E' := C.change_curve E with hE', clear_value E',
  set P' := C.change_affine_point P with hP', clear_value P',
  replace hc4 : E'.c4 = 0 := by {
    simp [hE', hc4],
  },
  simp [h2] at hc4,
  simp [affine_plane_point.ext_iff] at h3,
  use [P', hP],
  simp [eval_hessian_at_affine_point, h3.1, hc4],
end

end weierstrass_equation


/-
Copyright © 2021 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import tactic.basic
import algebra.module.basic

/-!
# Bundle
Basic data structure to implement fiber bundles, vector bundles (maybe fibrations?), etc. This file
should contain all possible results that do not involve any topology.

We represent a bundle `E` over a base space `B` as a dependent type `E : B → Type*`.

We provide a type synonym of `Σ x, E x` as `bundle.total_space E`, to be able to endow it with
a topology which is not the disjoint union topology `sigma.topological_space`. In general, the
constructions of fiber bundles we will make will be of this form.

## Main Definitions

* `bundle.total_space` the total space of a bundle.
* `bundle.total_space.proj` the projection from the total space to the base space.
* `bundle.total_space_mk` the constructor for the total space.

## References
- https://en.wikipedia.org/wiki/Bundle_(mathematics)
-/

namespace bundle

variables {B : Type*} (E : B → Type*)

/--
`bundle.total_space E` is the total space of the bundle `Σ x, E x`.
This type synonym is used to avoid conflicts with general sigma types.
-/
def total_space := Σ x, E x

instance [inhabited B] [inhabited (E default)] :
  inhabited (total_space E) := ⟨⟨default, default⟩⟩

variables {E}

/-- `bundle.total_space.proj` is the canonical projection `bundle.total_space E → B` from the
total space to the base space. -/
@[simp, reducible] def total_space.proj : total_space E → B := sigma.fst

/-- Constructor for the total space of a bundle. -/
@[simp, reducible] def total_space_mk (b : B) (a : E b) :
  bundle.total_space E := ⟨b, a⟩

lemma total_space.proj_mk {x : B} {y : E x} : (total_space_mk x y).proj = x :=
rfl

lemma sigma_mk_eq_total_space_mk {x : B} {y : E x} : sigma.mk x y = total_space_mk x y :=
rfl

lemma total_space.mk_cast {x x' : B} (h : x = x') (b : E x) :
  total_space_mk x' (cast (congr_arg E h) b) = total_space_mk x b :=
by { subst h, refl }

lemma total_space.eta (z : total_space E) :
  total_space_mk z.proj z.2 = z :=
sigma.eta z

instance {x : B} : has_coe_t (E x) (total_space E) := ⟨total_space_mk x⟩

@[simp] lemma coe_fst (x : B) (v : E x) : (v : total_space E).fst = x := rfl
@[simp] lemma coe_snd {x : B} {y : E x} : (y : total_space E).snd = y := rfl

lemma to_total_space_coe {x : B} (v : E x) : (v : total_space E) = total_space_mk x v := rfl

-- notation for the direct sum of two bundles over the same base
notation E₁ `×ᵇ`:100 E₂ := λ x, E₁ x × E₂ x

/-- `bundle.trivial B F` is the trivial bundle over `B` of fiber `F`. -/
def trivial (B : Type*) (F : Type*) : B → Type* := function.const B F

instance {F : Type*} [inhabited F] {b : B} : inhabited (bundle.trivial B F b) := ⟨(default : F)⟩

/-- The trivial bundle, unlike other bundles, has a canonical projection on the fiber. -/
def trivial.proj_snd (B : Type*) (F : Type*) : total_space (bundle.trivial B F) → F := sigma.snd

section pullback

variable {B' : Type*}

/-- The pullback of a bundle `E` over a base `B` under a map `f : B' → B`, denoted by `pullback f E`
or `f *ᵖ E`,  is the bundle over `B'` whose fiber over `b'` is `E (f b')`. -/
@[nolint has_inhabited_instance] def pullback (f : B' → B) (E : B → Type*) := λ x, E (f x)

notation f ` *ᵖ ` E := pullback f E

/-- Natural embedding of the total space of `f *ᵖ E` into `B' × total_space E`. -/
@[simp] def pullback_total_space_embedding (f : B' → B) :
  total_space (f *ᵖ E) → B' × total_space E :=
λ z, (z.proj, total_space_mk (f z.proj) z.2)

/-- The base map `f : B' → B` lifts to a canonical map on the total spaces. -/
def pullback.lift (f : B' → B) : total_space (f *ᵖ E) → total_space E :=
λ z, total_space_mk (f z.proj) z.2

@[simp] lemma pullback.proj_lift (f : B' → B) (x : total_space (f *ᵖ E)) :
  (pullback.lift f x).proj = f x.1 :=
rfl

@[simp] lemma pullback.lift_mk (f : B' → B) (x : B') (y : E (f x)) :
  pullback.lift f (total_space_mk x y) = total_space_mk (f x) y :=
rfl

lemma pullback_total_space_embedding_snd (f : B' → B) (x : total_space (f *ᵖ E)) :
  (pullback_total_space_embedding f x).2 = pullback.lift f x :=
rfl

end pullback

section fiber_structures

variable [∀ x, add_comm_monoid (E x)]

@[simp] lemma coe_snd_map_apply (x : B) (v w : E x) :
  (↑(v + w) : total_space E).snd = (v : total_space E).snd + (w : total_space E).snd := rfl

variables (R : Type*) [semiring R] [∀ x, module R (E x)]

@[simp]

end fiber_structures

section trivial_instances

variables {F : Type*} {R : Type*} [semiring R] (b : B)

instance [add_comm_monoid F] : add_comm_monoid (bundle.trivial B F b) := ‹add_comm_monoid F›
instance [add_comm_group F] : add_comm_group (bundle.trivial B F b) := ‹add_comm_group F›
instance [add_comm_monoid F] [module R F] : module R (bundle.trivial B F b) := ‹module R F›

end trivial_instances

end bundle