import number_theory.class_number_eq
import number_theory.ideal_norm

/-!
# Solving the Mordell equation

We solve the Mordell equation `y^2 = x^3 + d`, for `d ≤ -1`,
`d % 4 ∈ {2, 3}` and class number of `ℚ(√d)` not divisible by 3:

 * `mordell_d`: the Mordell equation `y^2 = x^3 + d` has solutions only if
    `d = -3m^2 ± 1` for some `m : ℕ`

## Intermediate results:
 * `gcd_lemma`: if `y^2 - d = x^3`, then `⟨y + √d⟩` and `⟨y - √d⟩` are coprime
    as ideals of `ℤ[√d]`

-/

open quad_ring
open_locale quad_ring

-- TODO list:
-- - maybe instead of using facts we can use implicit arguments?
--  e.g a lemma using dedekind_domain quad_ring can just assume that to make management of facts easier

section local_conditions
/-- There is no even x solution to `x^3 = y^2 - d`, if `d % 8 ∈ {2, 3, 5, 6, 7}`. -/
lemma x_odd_two_three_aux {x y : ℤ} {d : ℤ} (hd : ↑d ∈ ({2, 3, 5, 6, 7} : finset (zmod 8)))
  (h_eqn : y ^ 2 - d = x ^ 3) : ¬ even x :=
begin
  intro h,
  apply_fun (coe : ℤ → zmod 8) at h_eqn,
  rcases h with ⟨X, rfl⟩,
  push_cast at h_eqn,
  generalize_hyp : (y : zmod 8) = Y at h_eqn,
  generalize_hyp : (X : zmod 8) = XX at h_eqn,
  generalize_hyp : (d : zmod 8) = D at h_eqn hd,
  revert Y XX D,
  clear y d X,
  dec_trivial!
end

/-- There is no even x solution to `x^3 = y^2 - d`, if `d % 4 ∈ {2, 3}`. -/
lemma x_odd_two_three {x y : ℤ} {d : ℤ} (hd : d % 4 = 2 ∨ d % 4 = 3) (h_eqn : y ^ 2 - d = x ^ 3) :
  ¬ even x :=
begin
  refine x_odd_two_three_aux _ h_eqn,
  cases hd with hd hd;
  { rw [← euclidean_domain.div_add_mod d 4, hd],
    push_cast,
    generalize : (↑(d / 4) : zmod 8) = D,
    revert D,
    dec_trivial }
end

/-- There is no even solution to `x^3 = y^2 - d`, if `d % 4 = 3`. -/
lemma x_odd_three {x y : ℤ} {d : ℤ} (hd : d % 4 = 3) (h_eqn : y ^ 2 - d = x ^ 3) : ¬ even x :=
x_odd_two_three (or.inr hd) h_eqn

/-- There is no even solution to `x^3 = y^2 - d`, if `d % 4 = 2`. -/
lemma x_odd_two {x y : ℤ} {d : ℤ} (hd : d % 4 = 2) (h_eqn : y ^ 2 - d = x ^ 3) : ¬ even x :=
x_odd_two_three (or.inl hd) h_eqn

/-- There is no even solution to `x^3 = y^2 - d`, if `d % 8 = 5`. -/
lemma x_odd_five {x y : ℤ} {d : ℤ} (hd : d % 8 = 5) (h_eqn : y ^ 2 - d = x ^ 3) : ¬ even x :=
begin
  refine x_odd_two_three_aux _ h_eqn,
  rw [← euclidean_domain.div_add_mod d 8, hd],
  push_cast,
  generalize : (↑(d / 8) : zmod 8) = D,
  revert D,
  dec_trivial
end

end local_conditions

open ideal

lemma is_unit_of_dvd_four_mul_d_of_dvd_y_sq_sub_d {x y d : ℤ}
  [hd : fact (d % 8 = 5 ∨ d % 4 = 2 ∨ d % 4 = 3)] [hy : fact (squarefree d)]
  (h_eqn : y ^ 2 - d = x ^ 3)
  {n : ℤ} (hd4 : n ∣ d * 2 ^ 2) (hyd : n ∣ y ^ 2 - d) :
  is_unit n :=
begin
  -- Because the norm is coprime to 2, we conclude that it divides d and therefore it divides y.
  have h2 : is_coprime n 2,
  { refine (int.prime_two.coprime_iff_not_dvd.mpr _).symm,
    intros h,
    have : ¬ even (y ^ 2 - d),
    { have hodd : ¬ even x,
      { rcases hd.out with (hm|hm|hm),
        { exact x_odd_five hm h_eqn, },
        { exact x_odd_two hm h_eqn, },
        { exact x_odd_three hm h_eqn, } },
      simp only [h_eqn, hodd, not_false_iff, false_and] with parity_simps, },
    exact this (even_iff_two_dvd.mpr (h.trans hyd)) },
  have hd : n ∣ d := h2.pow_right.dvd_of_dvd_mul_right hd4,
  have hy : n ∣ y^2 := (dvd_sub_left hd).mp hyd,

  -- So it remains to show `d` and `y` are coprime.
  refine (is_coprime.pow_right _).is_unit_of_dvd' hd hy,
  -- We'll show that `(gcd d y)^2 ∣ d`, and since `d` is squarefree, conclude `gcd d y` is a unit.
  -- Here the original proof goes to `zmod (gcd |d| |y|)`. We avoid the absolute values and
  -- coercions into `zmod` by working only with divisibility.
  rw ← gcd_is_unit_iff,
  refine fact.out (squarefree d) _ _,
  -- `(gcd d y)^2 ∣ y^2`, so we can show it divides the difference, which is equal to `x^3`.
  rw [← pow_two, ← dvd_sub_right (pow_dvd_pow_of_dvd (gcd_dvd_right d y) _), h_eqn],
  -- `(gcd d y)^2 ∣ x^3` if `gcd d y` divides `x`.
  refine (pow_dvd_pow_of_dvd _ _).trans (pow_dvd_pow x (by norm_num)),
  -- Since `gcd d y` is squarefree, this is indeed the case because it divides `x^3 = y^2 - d`.
  rw [← unique_factorization_monoid.dvd_pow_iff_dvd_of_squarefree, ← h_eqn, dvd_sub_left],
  { exact (gcd_dvd_right d y).trans (dvd_pow_self _ (by norm_num)) },
  { exact gcd_dvd_left d y },
  { exact squarefree_gcd_of_squarefree_left (fact.out _) },
  { norm_num },
end

/--
The ideals (y + √d) and (y − √d) are relatively prime.
Based on the proof in Conrad, but generalised to any squarefree d ≅ 2,3 mod 4.
-/
lemma gcd_lemma {x y : ℤ} {d : ℤ} [fact $ d % 4 = 2 ∨ d % 4 = 3] [fact $ squarefree d]
  (h_eqn : y ^ 2 - d = x ^ 3) :
  gcd (ideal.span {⟨y, 1⟩} : ideal (quad_ring ℤ 0 d)) (ideal.span {⟨y, -1⟩}) = 1 :=
begin
  -- Let I and J be ⟨y + √d⟩ and ⟨y - √d⟩ respectively.
  set I := (ideal.span {⟨y, 1⟩} : ideal (quad_ring ℤ 0 d)),
  set J := (ideal.span {⟨y, -1⟩} : ideal (quad_ring ℤ 0 d)),
  -- We will show `gcd I J = I ⊔ J = 1` by showing its norm is a unit,
  -- because it divides both `d` and `y`, and those are coprime.
  rw [one_eq_top, ← ideal.abs_norm_eq_one_iff, ← int.is_unit_coe_nat],

  refine is_unit_of_dvd_four_mul_d_of_dvd_y_sq_sub_d h_eqn _ _,

  -- `(y + √d) - (y - √d) = 2 √d` is in the supremum, so the norms divide each other.
  { show (abs_norm (gcd I J) : ℤ) ∣ d * 2^2,
    have : gcd I J ∣ span ({⟨0, 2⟩} : set (quad_ring ℤ 0 d)),
    { rw [gcd_eq_sup, dvd_span_singleton],
      convert submodule.sub_mem_sup
        (submodule.mem_span_singleton_self _) (submodule.mem_span_singleton_self _) using 1,
      calc_tac },
    refine (int.coe_nat_dvd.mpr (map_dvd ideal.abs_norm this)).trans _,
    simp only [abs_norm_span_singleton, norm_eq, zero_mul, zero_add, zero_pow' 2 (by norm_num),
        zero_sub, int.nat_abs_neg, int.coe_nat_dvd_left] },
  -- Similarly `(y + √d)` is in the supremum, so the norms divide each other.
  { show ((gcd I J).abs_norm : ℤ) ∣ y^2 - d,
    refine (int.coe_nat_dvd.mpr (map_dvd ideal.abs_norm (gcd_dvd_left I J))).trans _,
    simp only [abs_norm_span_singleton, zero_mul, add_zero,
      norm_eq, one_pow, mul_one, int.coe_nat_dvd_left] },
end

lemma gcd_lemma' {x y : ℤ} {d : ℤ} (h8 : d % 8 = 5)
  [fact $ squarefree d] [fact $ ¬ is_square d] (h_eqn : y ^ 2 - d = x ^ 3) :
  by haveI : fact (d % 4 = 1) := fact.mk (by apply_fun (% 4) at h8; norm_num [int.mod_mod_of_dvd] at h8; assumption); exact
  gcd (ideal.span {⟨y - 1, 2⟩} : ideal (quad_ring ℤ 1 ((d - 1) / 4))) (ideal.span {⟨y + 1, -2⟩}) = 1 :=
begin
  haveI : fact (d % 4 = 1) := fact.mk (by apply_fun (% 4) at h8; norm_num [int.mod_mod_of_dvd] at h8; assumption),
  -- Let I and J be ⟨y - 1 + 2√d⟩ and ⟨y + 1 - 2√d⟩ respectively.
  set I := (ideal.span {⟨y - 1, 2⟩} : ideal (quad_ring ℤ 1 ((d - 1) / 4))),
  set J := (ideal.span {⟨y + 1, -2⟩} : ideal (quad_ring ℤ 1 ((d - 1) / 4))),
  -- We will show `gcd I J = I ⊔ J = 1` by showing its norm is a unit,
  -- because it divides both `d` and `y`, and those are coprime.
  rw [one_eq_top, ← abs_norm_eq_one_iff, ← int.is_unit_coe_nat],

  haveI := fact.mk h8,
  refine is_unit_of_dvd_four_mul_d_of_dvd_y_sq_sub_d h_eqn _ _,

  -- `(y - 1 + 2√d) - (y + 1 - 2√d) = -2 + 4 √d` is in the supremum, so the norms divide each other.
  { show (abs_norm (gcd I J) : ℤ) ∣ d * 2^2,
    have : gcd I J ∣ span ({⟨-2, 4⟩} : set (quad_ring ℤ 1 ((d - 1) / 4))),
    { rw [gcd_eq_sup, dvd_span_singleton],
      convert submodule.sub_mem_sup
        (submodule.mem_span_singleton_self _) (submodule.mem_span_singleton_self _) using 1,
      calc_tac },
    refine (int.coe_nat_dvd.mpr (map_dvd ideal.abs_norm this)).trans _,
    simp only [abs_norm_span_singleton, norm_eq, zero_mul, zero_add,
        zero_pow' 2 (by norm_num), zero_sub, int.nat_abs_neg, int.coe_nat_dvd_left,
        int.nat_abs, abs_norm_span_singleton, norm_eq, neg_sq, mul_neg,
        one_mul, neg_mul, int.nat_abs_dvd_iff_dvd],
    norm_num,
    rw show -4 - (d - 1) / 4 * 16 = -4 * (4 * ((d - 1) / 4) + 1), by ring,
    rw d_one_mod_four_fact,
    rw mul_comm,
    simp, },
  -- Similarly `(y - 1 + 2√d)` is in the supremum, so the norms divide each other.
  { show ((gcd I J).abs_norm : ℤ) ∣ y^2 - d,
    refine (int.coe_nat_dvd.mpr (map_dvd ideal.abs_norm (gcd_dvd_left I J))).trans _,
    simp only [abs_norm_span_singleton, norm_eq,
      int.coe_nat_dvd_left, one_mul, int.nat_abs_dvd_iff_dvd],
    ring_nf,
    rw [← neg_add', d_one_mod_four_fact, sub_eq_add_neg], },
end

open_locale non_zero_divisors

lemma factor_y_sq_sub_d (d : ℤ) (y : ℤ) :
  (y^2 - d : quad_ring ℤ 0 d) = ⟨y, 1⟩ * ⟨y, -1⟩ :=
by calc_tac

lemma factor_y_sq_sub_d_one (d : ℤ) [fact $ d % 4 = 1] (y : ℤ) :
  (y^2 - d : quad_ring ℤ 1 ((d - 1) / 4)) = ⟨y - 1, 2⟩ * ⟨y + 1, -2⟩ :=
by {calc_tac, rw [← neg_add', d_one_mod_four_fact, sub_eq_add_neg]}

/-- An integer solution to the Mordell equation `y^2 = x^3 + d`, if `¬(3 ∣ k(ℚ(√d)))`,
implies a third root of `y + √d` exists. -/
lemma exists_third_root_y_add_root (d : ℤ) (d' : ℚ) (hd : d ≤ -1)
  [fact (d % 4 = 2 ∨ d % 4 = 3)]
  [fact (squarefree d)]
  [hdd' : fact $ algebra_map ℤ ℚ d = d']
  [fact $ ¬ is_square d] [fact $ ¬ is_square d']
  (hcl : (number_field.class_number (quad_ring ℚ 0 d')).gcd 3 = 1)
  (x y : ℤ) (h_eqn : y ^ 2 = x ^ 3 + d) :
  ∃ z : ℤ[√d], z^3 = ⟨y, 1⟩ :=
begin
  rw nat.gcd_comm at hcl,
  rw ← sub_eq_iff_eq_add at h_eqn,
  have : (x^3 : quad_ring ℤ 0 d) = ⟨y, 1⟩ * ⟨y, -1⟩,
  { refine trans _ (factor_y_sq_sub_d d y),
    exact_mod_cast h_eqn.symm },
  -- Since `⟨y - √d⟩` and `⟨y + √d⟩` are coprime, and `⟨y - √d⟩⟨y + √d⟩ = ⟨x⟩^3`,
  -- we have a third root `I` of `⟨y + √d⟩`.
  obtain ⟨I, hI⟩ : ∃ I : ideal (quad_ring ℤ 0 d),
    (ideal.span {⟨y, 1⟩} : ideal (quad_ring ℤ 0 d)) = I ^ 3,
  { have unit_gcd : is_unit (gcd (span ({⟨y, 1⟩} : set (quad_ring ℤ 0 d))) (span {⟨y, -1⟩})),
    { simpa using gcd_lemma h_eqn, },
    refine exists_eq_pow_of_mul_eq_pow unit_gcd (show _ = (span ({x} : set ℤ[√d]))^3, from _),
    rw [ideal.span_singleton_mul_span_singleton, ideal.span_singleton_pow, this] },
  -- The class group does not contain an element of an element of order three,
  -- and `I^3 = ⟨y + √d⟩` is principal, so `I` is principal.
  obtain ⟨z, rfl⟩ : ∃ z, I = ideal.span {z},
  { have hIn : I ∈ (ideal ℤ[√d])⁰,
    { rw mem_non_zero_divisors_iff_ne_zero,
      rintro rfl,
      rw [zero_pow, ideal.zero_eq_bot, ideal.span_singleton_eq_bot, quad_ring.ext_iff] at hI,
      { simpa using hI },
      { norm_num } },
    suffices : class_group.mk0 ⟨I, hIn⟩ = 1,
    { exact ((class_group.mk0_eq_one_iff hIn).mp this).1 },
    -- In particular, `1 = I^3 = I^(gcd k(ℚ(√d)) 3) = I^1`.
    rw [← pow_one (class_group.mk0 _), ← hcl,
        number_field.class_number_eq (quad_ring ℤ 0 d) (quad_ring ℚ 0 d'),
        ← pow_gcd_card_eq_one_iff, ← map_pow, submonoid_class.mk_pow I hIn],
    refine (class_group.mk0_eq_one_iff _).mpr _,
    rw ← hI,
    exact span.submodule.is_principal },
  -- Therefore, we have ⟨z⟩^3 = ⟨y + √d⟩, so `z^3` and `y + √d` are equal up to units.
  rw [ideal.span_singleton_pow, ideal.span_singleton_eq_span_singleton] at hI,
  rcases hI with ⟨u, hu⟩,
  -- Every unit in `ℤ[√d]` has a third root, so we find a unit v with (z * v)^3 = y + √d.
  rcases units_quad_cubes hd u with ⟨v, rfl⟩,
  use z * ↑(v⁻¹),
  rw [mul_pow, ← hu, ← units.coe_pow, inv_pow, units.mul_inv_cancel_right]
end

/-- An integer solution to the Mordell equation `y^2 = x^3 + d`, if `¬(3 ∣ k(ℚ(√d)))`,
has `y = 3dm + m^3`, where `m : ℤ` is such that `m^2 = (-d ± 1)/3`. -/
theorem Mordell_d (d : ℤ) (d' : ℚ) (hd : d ≤ -1)
  [fact (d % 4 = 2 ∨ d % 4 = 3)]
  [fact (squarefree d)]
  [hdd' : fact $ algebra_map ℤ ℚ d = d']
  [fact $ ¬ is_square d']
  (hcl : (number_field.class_number ℚ(√d')).gcd 3 = 1)
  (x y : ℤ) (h_eqn : y ^ 2 = x ^ 3 + d) :
  ∃ m : ℤ, ((m : ℚ) ^ 2 = (1 - d) / 3 ∨ -(m : ℚ) ^ 2 = (1 + d) / 3) ∧ ↑y = m * (d * 3 + m ^ 2)
  :=
begin
  obtain ⟨⟨m, n⟩, h⟩ : ∃ z' : quad_ring ℤ 0 d, z' ^ 3 = (⟨y, 1⟩ : quad_ring ℤ 0 d) :=
    exists_third_root_y_add_root d d' hd hcl x y h_eqn,
  use m,
  clear' h_eqn,
  obtain ⟨hiy, hi⟩ := (quad_ring.ext_iff _ _).mp h,
  simp only [pow_succ, pow_zero, mul_b1, mul_b2, mul_one, mul_zero, add_zero] at hiy hi,
  rcases int.is_unit_eq_one_or (is_unit_of_mul_eq_one n (d * n ^ 2 + 3 * m ^ 2)
    (trans (by ring) hi)) with (rfl | rfl),
  { refine ⟨or.inl _, _⟩,
    { field_simp,
      norm_cast,
      exact eq_sub_iff_add_eq.mpr (trans (by ring) hi) },
    { norm_cast,
      exact trans hiy.symm (by ring) } },
  { simp only [one_mul, eq_self_iff_true, neg_one_sq, neg_mul, neg_add_rev, neg_neg,
      int.cast_id, eq_int_cast, nat.gcd_succ, set.mem_insert_iff, set.mem_singleton_iff] at *,
    refine ⟨or.inr _, _⟩,
    { field_simp,
      norm_cast,
      rw [eq_comm, ← eq_sub_iff_add_eq],
      exact trans hi.symm (by ring) },
    { exact trans hiy.symm (by ring) } },
end

lemma Mordell_contra {R : Type*} [comm_ring R] (d m : R)
  (hd : d = 1 - 3 * m ^ 2 ∨ d = - 1 - 3 * m ^ 2) :
  (m * (d * 3 + m ^ 2)) ^ 2 = (m ^ 2 - d) ^ 3 + d :=
by rcases hd with rfl | rfl; ring

-- local insolubility if:
-- (hd9 : ↑d ∈ ({0,2,3,4,5,6,8} : set (zmod 9)))
-- (hd3 : ↑d ∈ ({0,1} : set (zmod 3)))
theorem Mordell_minus5 (x y : ℤ) : ¬ y^2 = x^3 - 5 :=
begin
  haveI : fact ((-5 : ℤ) % 4 = 2 ∨ (-5 : ℤ) % 4 = 3) := fact.mk (or.inr (by norm_num)),
  haveI : fact (squarefree (-5 : ℤ)) := fact.mk (by norm_num [int.squarefree_iff_squarefree_nat_abs]),
  haveI : fact (algebra_map ℤ ℚ (-5 : ℤ) = -5) := fact.mk (by norm_num),
  haveI : fact (¬ is_square (-5 : ℚ)) := fact.mk (λ h, (by norm_num : ¬ (0 : ℚ) ≤ (-5)) h.nonneg), -- TODO should be easier
  intro h_eqn,
  obtain ⟨m, hm | hm, h⟩ := Mordell_d (-5) (-5) (by norm_num) (by norm_num [class_number_eq_five]) x y h_eqn,
  { norm_num at hm,
    norm_cast at hm,
    apply not_square_of_eq_two_or_three_mod_four (or.inl (show (2 % 4 : ℤ) = 2, by norm_num)),
    exact ⟨m, by simp [← hm, pow_two]⟩ },
  { cancel_denoms at hm,
    norm_cast at hm,
    apply_fun (coe : ℤ → zmod 5) at hm,
    push_cast at hm,
    revert hm,
    generalize' : (m : zmod 5) = M,
    revert M,
    dec_trivial, },
end

-- this will be an existence result
theorem Mordell_minus2 (x y : ℤ) (h_eqn : y^2 = x^3 - 2) : y = 5 ∨ y = -5 :=
begin
  haveI : fact ((-2 : ℤ) % 4 = 2 ∨ (-2 : ℤ) % 4 = 3) := fact.mk (or.inl (by norm_num)),
  haveI : fact (squarefree (-2 : ℤ)) := fact.mk (by norm_num [int.squarefree_iff_squarefree_nat_abs]),
  haveI : fact (algebra_map ℤ ℚ (-2 : ℤ) = -2) := fact.mk (by norm_num),
  haveI : fact (¬ is_square (-2 : ℚ)) := fact.mk (λ h, (by norm_num : ¬ (0 : ℚ) ≤ (-2)) h.nonneg), -- TODO should be easier
  obtain ⟨m, hm | hm, h⟩ := Mordell_d (-2) (-2) (by norm_num) (by norm_num [class_number_eq_two]) x y h_eqn,
  { norm_num at hm,
    norm_cast at hm,
    rcases hm with rfl | rfl;
    norm_num at h,
    exact or.inr h,
    exact or.inl h, },
  { cancel_denoms at hm,
    norm_cast at hm,
    apply_fun (coe : ℤ → zmod 4) at hm,
    push_cast at hm,
    revert hm,
    generalize' : (m : zmod 4) = M,
    revert M,
    dec_trivial, },
  -- { norm_num at hm, -- doesn't occur
  --   exfalso,
  --   apply_fun rat.denom at hm,
  --   norm_num at hm, -- TODO I think this entire computation should be in scope for norm_num
  --   simp at hm,
  --   rw denom_inv at hm,
  --   norm_num at hm,
  --   -- norm_num at hm,
  --   -- erw rat.denom_div_eq_of_coprime at hm,
  --   sorry, -- these goals are silly.
  --   sorry, },
end

theorem Mordell_minus6 (x y : ℤ) : ¬ y^2 = x^3 - 6 :=
begin
  haveI : fact ((-6 : ℤ) % 4 = 2 ∨ (-6 : ℤ) % 4 = 3) := fact.mk (or.inl (by norm_num)),
  haveI : fact (squarefree (-6 : ℤ)) := fact.mk (by norm_num [int.squarefree_iff_squarefree_nat_abs]),
  haveI : fact (algebra_map ℤ ℚ (-6 : ℤ) = -6) := fact.mk (by norm_num),
  haveI : fact (¬ is_square (-6 : ℚ)) := fact.mk (λ h, (by norm_num : ¬ (0 : ℚ) ≤ (-6)) h.nonneg), -- TODO should be easier
  intro h_eqn,
  obtain ⟨m, hm | hm, h⟩ := Mordell_d (-6) (-6) (by norm_num) (by norm_num [class_number_eq_six]) x y h_eqn,
  { cancel_denoms at hm,
    norm_cast at hm,
    apply_fun (coe : ℤ → zmod 8) at hm,
    push_cast at hm,
    revert hm,
    generalize' : (m : zmod 8) = M,
    revert M,
    dec_trivial, },
  { cancel_denoms at hm,
    norm_cast at hm,
    apply_fun (coe : ℤ → zmod 4) at hm,
    push_cast at hm,
    revert hm,
    generalize' : (m : zmod 4) = M,
    revert M,
    dec_trivial, }
end

theorem Mordell_minus1 (x y : ℤ) (h_eqn : y^2 = x^3 - 1) : y = 0 :=
begin
  haveI : fact ((-1 : ℤ) % 4 = 2 ∨ (-1 : ℤ) % 4 = 3) := fact.mk (or.inr (by norm_num)),
  haveI : fact (squarefree (-1 : ℤ)) := fact.mk (by norm_num [int.squarefree_iff_squarefree_nat_abs]),
  haveI : fact (algebra_map ℤ ℚ (-1 : ℤ) = -1) := fact.mk (by norm_num),
  haveI : fact (¬ is_square (-1 : ℚ)) := fact.mk (λ h, (by norm_num : ¬ (0 : ℚ) ≤ (-1)) h.nonneg), -- TODO should be easier
  obtain ⟨m, hm | hm, h⟩ := Mordell_d (-1) (-1) (by norm_num) (by norm_num [class_number_eq_one]) x y h_eqn,
  { cancel_denoms at hm,
    norm_cast at hm,
    apply_fun (coe : ℤ → zmod 4) at hm,
    push_cast at hm,
    revert hm,
    generalize' : (m : zmod 4) = M,
    revert M,
    dec_trivial, },
  { norm_num at hm,
    subst hm,
    assumption, },
end

theorem Mordell_minus13 (x y : ℤ) (h_eqn : y^2 = x^3 - 13) : y = 70 ∨ y = -70 :=
begin
  haveI : fact ((-13 : ℤ) % 4 = 2 ∨ (-13 : ℤ) % 4 = 3) := fact.mk (or.inr (by norm_num)),
  haveI : fact (squarefree (-13 : ℤ)) := fact.mk (by norm_num [int.squarefree_iff_squarefree_nat_abs]),
  haveI : fact (algebra_map ℤ ℚ (-13 : ℤ) = -13) := fact.mk (by norm_num),
  haveI : fact (¬ is_square (-13 : ℚ)) := fact.mk (λ h, (by norm_num : ¬ (0 : ℚ) ≤ (-13)) h.nonneg), -- TODO should be easier
  obtain ⟨m, hm | hm, h⟩ := Mordell_d (-13) (-13) (by norm_num) (by norm_num [class_number_eq_thirteen]) x y h_eqn,
  { cancel_denoms at hm,
    norm_cast at hm,
    apply_fun (coe : ℤ → zmod 4) at hm,
    push_cast at hm,
    revert hm,
    generalize' : (m : zmod 4) = M,
    revert M,
    dec_trivial, },
  { norm_num at hm,
    norm_cast at hm,
    have : m = -2 ∨ m = 2,
    { rw (show (4 : ℤ) = 2 ^ 2, by norm_num) at hm,
      rw sq_eq_sq_iff_eq_or_eq_neg at hm,
      exact hm.symm, },
    rcases this with rfl | rfl;
    norm_num at h; [left, right];
    assumption, },
end

#print axioms Mordell_minus1
#print axioms Mordell_minus2
#print axioms Mordell_minus5
#print axioms Mordell_minus6
#print axioms Mordell_minus13


-- import data.nat.prime
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.char
import myhelper.perfect
import myhelper.separable_closed
import tactic

namespace weierstrass_equation

/--
For any `j ∈ K` there exists a Weierstrass equation over `K`
which has non-zero discriminant and whose j-invariant equals `j`.
-/
lemma exists_j {K : Type*} [field K]
(j_ : K) : ∃ E : weierstrass_equation K,
E.non_singular' ∧ E.j = j_ :=
begin
  let E0 : weierstrass_equation K := ⟨ 0, 0, 1, 0, 0 ⟩,
  have hc4_0 : E0.c4 = 0 := by {
    simp [c4, b2, b4],
  },
  have hdisc_0 : E0.disc = -27 := by {
    simp [disc, b2, b4, b6, b8],
  },
  have hj_0 : E0.j = 0 := by {
    simp [j, hc4_0, hdisc_0],
  },
  let E1728 : weierstrass_equation K := ⟨ 0, 0, 0, 1, 0 ⟩,
  have hc4_1728 : E1728.c4 = -48 := by {
    simp [c4, b2, b4], norm_num,
  },
  have hdisc_1728 : E1728.disc = -64 := by {
    simp [disc, b2, b4, b6, b8], norm_num,
  },
  have hj_1728 : E1728.j = 1728 := by {
    simp [j, hc4_1728, hdisc_1728],
    by_cases hchar2 : ring_char K = 2, {
      ring_char2,
    },
    have h64 := power_of_prime_neq_char_is_non_zero K 64 2 6 (by norm_num) (by norm_num) hchar2,
    norm_num at h64,
    field_simp [h64], norm_num,
  },
  by_cases h0 : j_ = 0, {
    rw h0,
    by_cases hchar3 : ring_char K = 3, {
      use E1728,
      split, {
        simp [non_singular', hdisc_1728],
        ring_char3,
      },
      rw hj_1728,
      ring_char3,
    },
    use E0,
    split, {
      simp [non_singular', hdisc_0],
      have h27 := power_of_prime_neq_char_is_non_zero K 27 3 3 (by norm_num) (by norm_num) hchar3,
      norm_num at h27,
    },
    exact hj_0,
  },
  by_cases h1728 : j_ = 1728, {
    rw h1728,
    by_cases hchar2 : ring_char K = 2, {
      exfalso,
      ring_char2 at h1728,
      exact h0 h1728,
    },
    use E1728,
    split, {
      simp [non_singular', hdisc_1728],
      have h64 := power_of_prime_neq_char_is_non_zero K 64 2 6 (by norm_num) (by norm_num) hchar2,
      norm_num at h64,
    },
    exact hj_1728,
  },
  replace h1728 := sub_ne_zero.2 h1728,
  let E : weierstrass_equation K := ⟨ j_-1728, 0, 0, -36*(j_-1728)^3, -(j_-1728)^5 ⟩,
  have hc4 : E.c4 = j_ * (j_-1728)^3 := by {
    simp [c4, b2, b4],
    ring,
  },
  have hdisc : E.disc = j_^2 * (j_-1728)^9 := by {
    simp [disc, b2, b4, b6, b8],
    ring,
  },
  have hns : E.disc ≠ 0 := by {
    simp [hdisc, h0, h1728],
  },
  have hj : E.j = j_ := by {
    unfold j,
    field_simp [hns],
    rw [hc4, hdisc],
    ring,
  },
  exact ⟨ E, hns, hj ⟩,
end

lemma same_j_implies_isom'.char_2.solve_s_for_j_non_zero {K : Type*} [field K] (hsc : my_sep_closed K)
(E1 E1' : weierstrass_equation K)
(hchar2 : ring_char K = 2)
: ∃ s : K, s^2 + s + (E1.a2 + E1'.a2) = 0 :=
begin
  let f : polynomial K := polynomial.X^2 + polynomial.X + (polynomial.C (E1.a2 + E1'.a2)),
  have hdeg : f.degree ≠ 0 := by {
    let f1 : polynomial K := polynomial.X^2,
    let f2 : polynomial K := polynomial.X,
    let f3 : polynomial K := polynomial.C (E1.a2 + E1'.a2),
    have h1 : f1.degree = 2 := polynomial.degree_X_pow _,
    have h2 : f2.degree ≤ 1 := polynomial.degree_X_le,
    have h3 : f3.degree ≤ 0 := polynomial.degree_C_le,
    have h4 := calc (f2 + f3).degree ≤ max f2.degree f3.degree : polynomial.degree_add_le f2 f3
    ... ≤ max 1 0 : max_le_max h2 h3
    ... < f1.degree : by { rw h1, simp, norm_cast, norm_num, },
    calc f.degree = (f1 + (f2 + f3)).degree : by { congr' 1, rw ← add_assoc, }
    ... ≠ 0 : by {
      rw [polynomial.degree_add_eq_left_of_degree_lt h4, h1], norm_cast, norm_num,
    },
  },
  let f' : polynomial K := 1,
  have hf' : f' = f.derivative := by {
    have : f = (polynomial.C (1 : K)) * polynomial.X^2 + (polynomial.C (1 : K)) * polynomial.X^1 + (polynomial.C (E1.a2 + E1'.a2)) := by simp,
    rw this,
    repeat { rw polynomial.derivative_add },
    repeat { rw polynomial.derivative_C_mul_X_pow },
    rw polynomial.derivative_C,
    have : ((2 : ℕ) : K) = ((2 : ℤ) : K) := by { norm_cast, },
    rw this,
    have h := dvd_char_is_zero hchar2 2 (by norm_num), rw h, clear h,
    simp,
  },
  have hcop : is_coprime f f.derivative := by {
    rw ← hf',
    use [-1, f+1],
    rw [add_mul, mul_one, mul_one, ← add_assoc],
    ring,
  },
  cases hsc f hcop hdeg with s hs,
  simp at hs,
  exact ⟨ s, hs ⟩,
end

lemma same_j_implies_isom'.char_2.solve_s_for_j_zero {K : Type*} [field K] (hsc : my_sep_closed K)
(u : K)
(E1 E1' : weierstrass_equation K)
(hchar2 : ring_char K = 2)
(hns : E1.a3 ≠ 0)
: ∃ s : K, s^4 + E1.a3*s + (E1.a4 - u^4*E1'.a4) = 0 :=
begin
  let f : polynomial K := polynomial.X^4 + (polynomial.C E1.a3) * polynomial.X + (polynomial.C (E1.a4 - u^4*E1'.a4)),
  have hdeg : f.degree ≠ 0 := by {
    let f1 : polynomial K := polynomial.X^4,
    set! f2 : polynomial K := (polynomial.C E1.a3) * polynomial.X^1 with hf2, rw pow_one at hf2,
    let f3 : polynomial K := polynomial.C (E1.a4 - u^4*E1'.a4),
    have h1 : f1.degree = 4 := polynomial.degree_X_pow _,
    have h2 : f2.degree ≤ 1 := polynomial.degree_C_mul_X_pow_le _ _,
    have h3 : f3.degree ≤ 0 := polynomial.degree_C_le,
    have h4 := calc (f2 + f3).degree ≤ max f2.degree f3.degree : polynomial.degree_add_le f2 f3
    ... ≤ max 1 0 : max_le_max h2 h3
    ... < f1.degree : by { rw h1, simp, norm_cast, norm_num, },
    calc f.degree = (f1 + (f2 + f3)).degree : by { congr' 1, rw [← add_assoc, hf2], }
    ... ≠ 0 : by {
      rw [polynomial.degree_add_eq_left_of_degree_lt h4, h1], norm_cast, norm_num,
    },
  },
  let f' : polynomial K := polynomial.C E1.a3,
  have hf' : f' = f.derivative := by {
    have : f = (polynomial.C (1 : K)) *  polynomial.X^4 + (polynomial.C E1.a3) * polynomial.X^1 + (polynomial.C (E1.a4 - u^4*E1'.a4)) := by simp,
    rw this,
    repeat { rw polynomial.derivative_add },
    repeat { rw polynomial.derivative_C_mul_X_pow },
    rw polynomial.derivative_C,
    have : ((4 : ℕ) : K) = ((4 : ℤ) : K) := by { norm_cast, },
    rw this,
    have h := dvd_char_is_zero hchar2 4 (by norm_num), rw h, clear h,
    simp,
  },
  have hcop : is_coprime f f.derivative := by {
    rw ← hf',
    let a : polynomial K := -f',
    let b : polynomial K := f + polynomial.C (1/E1.a3),
    use [a, b],
    calc a * f + b * f'
    = (-f') * f + (f + polynomial.C (1/E1.a3)) * f' : rfl
    ... = polynomial.C (1/E1.a3) * f' : by ring
    ... = 1 : by {
      rw ← polynomial.C_mul,
      field_simp [hns],
    },
  },
  cases hsc f hcop hdeg with s hs,
  repeat {rw polynomial.eval₂_add at hs},
  rw [polynomial.eval₂_mul, polynomial.eval₂_X_pow, polynomial.eval₂_X] at hs,
  repeat {rw polynomial.eval₂_C at hs},
  simp at hs,
  exact ⟨ s, hs ⟩,
end

lemma same_j_implies_isom'.char_2.solve_t_for_j_zero {K : Type*} [field K] (hsc : my_sep_closed K)
(u s : K)
(E1 E1' : weierstrass_equation K)
(hchar2 : ring_char K = 2)
(hns : E1.a3 ≠ 0)
: ∃ t : K, t^2 + E1.a3*t + (s^6 + E1.a4*s^2 + E1.a6 - u^6*E1'.a6) = 0 :=
begin
  let f : polynomial K := polynomial.X^2 + (polynomial.C E1.a3) * polynomial.X + (polynomial.C (s^6 + E1.a4*s^2 + E1.a6 - u^6*E1'.a6)),
  have hdeg : f.degree ≠ 0 := by {
    let f1 : polynomial K := polynomial.X^2,
    set! f2 : polynomial K := (polynomial.C E1.a3) * polynomial.X^1 with hf2, rw pow_one at hf2,
    let f3 : polynomial K := polynomial.C (s^6 + E1.a4*s^2 + E1.a6 - u^6*E1'.a6),
    have h1 : f1.degree = 2 := polynomial.degree_X_pow _,
    have h2 : f2.degree ≤ 1 := polynomial.degree_C_mul_X_pow_le _ _,
    have h3 : f3.degree ≤ 0 := polynomial.degree_C_le,
    have h4 := calc (f2 + f3).degree ≤ max f2.degree f3.degree : polynomial.degree_add_le f2 f3
    ... ≤ max 1 0 : max_le_max h2 h3
    ... < f1.degree : by { rw h1, simp, norm_cast, norm_num, },
    calc f.degree = (f1 + (f2 + f3)).degree : by { congr' 1, rw [← add_assoc, hf2], }
    ... ≠ 0 : by {
      rw [polynomial.degree_add_eq_left_of_degree_lt h4, h1], norm_cast, norm_num,
    },
  },
  let f' : polynomial K := polynomial.C E1.a3,
  have hf' : f' = f.derivative := by {
    have : f = (polynomial.C (1 : K)) *  polynomial.X^2 + (polynomial.C E1.a3) * polynomial.X^1 + (polynomial.C (s^6 + E1.a4*s^2 + E1.a6 - u^6*E1'.a6)) := by simp,
    rw this,
    repeat { rw polynomial.derivative_add },
    repeat { rw polynomial.derivative_C_mul_X_pow },
    rw polynomial.derivative_C,
    have : ((2 : ℕ) : K) = ((2 : ℤ) : K) := by { norm_cast, },
    rw this,
    have h := dvd_char_is_zero hchar2 2 (by norm_num), rw h, clear h,
    simp,
  },
  have hcop : is_coprime f f.derivative := by {
    rw ← hf',
    let a : polynomial K := -f',
    let b : polynomial K := f + polynomial.C (1/E1.a3),
    use [a, b],
    calc a * f + b * f'
    = (-f') * f + (f + polynomial.C (1/E1.a3)) * f' : rfl
    ... = polynomial.C (1/E1.a3) * f' : by ring
    ... = 1 : by {
      rw ← polynomial.C_mul,
      field_simp [hns],
    },
  },
  cases hsc f hcop hdeg with t ht,
  repeat {rw polynomial.eval₂_add at ht},
  rw [polynomial.eval₂_mul, polynomial.eval₂_X_pow, polynomial.eval₂_X] at ht,
  repeat {rw polynomial.eval₂_C at ht},
  simp at ht,
  exact ⟨ t, ht ⟩,
end

lemma same_j_implies_isom'.char_2.j_non_zero {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (hmod : E.is_model_of_char_2_j_non_zero) (hmod' : E'.is_model_of_char_2_j_non_zero)
(h : E.a6 = E'.a6) (hj : E.a6 ≠ 0) (hj' : E'.a6 ≠ 0)
(hchar2 : ring_char K = 2)
: E.is_isom' E' :=
begin
  cases same_j_implies_isom'.char_2.solve_s_for_j_non_zero hsc E E' hchar2 with s hs,
  let C : linear_change_of_variable K := ⟨ 1, 0, s, 0, by simp ⟩,
  use C,
  simp [ext_iff, linear_change_of_variable.change_curve,
    hmod.1, hmod.2.1, hmod.2.2, hmod'.1, hmod'.2.1, hmod'.2.2, h],
  ring_char2,
  transitivity E.a2 - s - s ^ 2  + (s ^ 2 + s + (E.a2 + E'.a2)),
  { rw hs, ring, },
  rw ← sub_eq_zero,
  ring_char2,
end

lemma same_j_implies_isom'.char_2.j_zero {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (hmod : E.is_model_of_char_2_j_zero) (hmod' : E'.is_model_of_char_2_j_zero)
(hns : E.a3 ≠ 0) (hns' : E'.a3 ≠ 0)
(hchar2 : ring_char K = 2)
: E.is_isom' E' :=
begin
  cases sep_closed_implies_pow_surj K hsc 3 (by { rw hchar2, norm_num, }) (E.a3 / E'.a3) with u hu,
  cases same_j_implies_isom'.char_2.solve_s_for_j_zero hsc u E E' hchar2 hns with s hs,
  cases same_j_implies_isom'.char_2.solve_t_for_j_zero hsc u s E E' hchar2 hns with t ht,
  let C := linear_change_of_variable.mk u (s^2) s t (by {
    intro h, field_simp [h, hns'] at hu, exact hns hu.symm,
  }),
  use C,
  simp [ext_iff, linear_change_of_variable.change_curve,
    hmod.1, hmod.2, hmod'.1, hmod'.2, hu],
  ring_char2,
  split, { field_simp [hns, hns', mul_comm], },
  split, {
    field_simp [C.hu],
    transitivity E.a4 - s * E.a3 + s ^ 4 - (s ^ 4 + E.a3 * s + (E.a4 - u ^ 4 * E'.a4)),
    { rw hs, ring, },
    rw ← sub_eq_zero,
    ring_char2,
  },
  field_simp [C.hu],
  transitivity E.a6 + s ^ 2 * E.a4 + s ^ 6 - t * E.a3 - t ^ 2 - (t ^ 2 + E.a3 * t + (s ^ 6 + E.a4 * s ^ 2 + E.a6 - u ^ 6 * E'.a6)),
  { rw ht, ring, },
  rw ← sub_eq_zero,
  ring_char2,
end

lemma same_j_implies_isom'.char_2 {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (h : E.j = E'.j) (hns : E.non_singular') (hns' : E'.non_singular')
(hchar2 : ring_char K = 2)
: E.is_isom' E' :=
begin
  change E ≈ E',
  refine quotient.exact _,
  have hj0 : E.j = isom_class'.j ⟦E⟧ := by { simp [isom_class'.j], },
  have hj'0 : E'.j = isom_class'.j ⟦E'⟧ := by { simp [isom_class'.j], },
  rw [hj0, hj'0] at h,
  replace hns : isom_class'.non_singular' ⟦E⟧ := by { simp [isom_class'.non_singular', hns], },
  replace hns' : isom_class'.non_singular' ⟦E'⟧ := by { simp [isom_class'.non_singular', hns'], },
  rcases E.have_model_of_char_2 hchar2 with ⟨ hj, C, hmod ⟩ | ⟨ hj, C, hmod ⟩, {
    replace hj := hj hns,
    rcases E'.have_model_of_char_2 hchar2 with ⟨ hj', C', hmod' ⟩ | ⟨ hj', C', hmod' ⟩, {
      replace hj' := hj' hns',
      rw hj0 at hj,
      rw hj'0 at hj',
      set E1 := C.change_curve E with hE1, clear_value E1,
      set E1' := C'.change_curve E' with hE1', clear_value E1',
      replace hE1 : ⟦E⟧ = ⟦E1⟧ := quotient.sound (by { use C, exact hE1.symm, }),
      replace hE1' : ⟦E'⟧ = ⟦E1'⟧ := quotient.sound (by { use C', exact hE1'.symm, }),
      rw hE1 at *,
      rw hE1' at *,
      clear hE1 hE1' hj0 hj'0 C C' E E',
      refine quotient.sound _,
      simp [isom_class'.j, hmod, hmod', hchar2] at h hj hj',
      exact same_j_implies_isom'.char_2.j_non_zero hsc hmod hmod' h hj hj' hchar2,
    }, {
      exfalso, finish,
    },
  }, {
    rcases E'.have_model_of_char_2 hchar2 with ⟨ hj', C', hmod' ⟩ | ⟨ hj', C', hmod' ⟩, {
      exfalso, finish,
    }, {
      rw hj0 at hj,
      rw hj'0 at hj',
      set E1 := C.change_curve E with hE1, clear_value E1,
      set E1' := C'.change_curve E' with hE1', clear_value E1',
      replace hE1 : ⟦E⟧ = ⟦E1⟧ := quotient.sound (by { use C, exact hE1.symm, }),
      replace hE1' : ⟦E'⟧ = ⟦E1'⟧ := quotient.sound (by { use C', exact hE1'.symm, }),
      rw hE1 at *,
      rw hE1' at *,
      clear hE1 hE1' hj0 hj'0 C C' E E',
      refine quotient.sound _,
      simp [isom_class'.non_singular', non_singular', hmod, hmod', hchar2] at hns hns',
      exact same_j_implies_isom'.char_2.j_zero hsc hmod hmod' hns hns' hchar2,
    },
  },
end

lemma same_j_implies_isom'.char_3.solve_r_for_j_zero {K : Type*} [field K] (hsc : my_sep_closed K)
(u : K)
(E1 E1' : weierstrass_equation K)
(hchar3 : ring_char K = 3)
(hns : E1.a4 ≠ 0)
: ∃ r : K, r^3 + E1.a4*r + (E1.a6 - u^6*E1'.a6) = 0 :=
begin
  let f : polynomial K := polynomial.X^3 + (polynomial.C E1.a4) * polynomial.X + (polynomial.C (E1.a6 - u^6*E1'.a6)),
  have hdeg : f.degree ≠ 0 := by {
    let f1 : polynomial K := polynomial.X^3,
    set! f2 : polynomial K := (polynomial.C E1.a4) * polynomial.X^1 with hf2, rw pow_one at hf2,
    let f3 : polynomial K := polynomial.C (E1.a6 - u^6*E1'.a6),
    have h1 : f1.degree = 3 := polynomial.degree_X_pow _,
    have h2 : f2.degree ≤ 1 := polynomial.degree_C_mul_X_pow_le _ _,
    have h3 : f3.degree ≤ 0 := polynomial.degree_C_le,
    have h4 := calc (f2 + f3).degree ≤ max f2.degree f3.degree : polynomial.degree_add_le f2 f3
    ... ≤ max 1 0 : max_le_max h2 h3
    ... < f1.degree : by { rw h1, simp, norm_cast, norm_num, },
    calc f.degree = (f1 + (f2 + f3)).degree : by { congr' 1, rw [← add_assoc, hf2], }
    ... ≠ 0 : by {
      rw [polynomial.degree_add_eq_left_of_degree_lt h4, h1], norm_cast, norm_num,
    },
  },
  let f' : polynomial K := polynomial.C E1.a4,
  have hf' : f' = f.derivative := by {
    have : f = (polynomial.C (1 : K)) * polynomial.X^3 + (polynomial.C E1.a4) * polynomial.X^1 + (polynomial.C (E1.a6 - u^6*E1'.a6)) := by simp,
    rw this,
    repeat { rw polynomial.derivative_add },
    repeat { rw polynomial.derivative_C_mul_X_pow },
    rw polynomial.derivative_C,
    have : ((3 : ℕ) : K) = ((3 : ℤ) : K) := by { norm_cast, },
    rw this,
    have h := dvd_char_is_zero hchar3 3 (by norm_num), rw h, clear h,
    simp,
  },
  have hcop : is_coprime f f.derivative := by {
    rw ← hf',
    let a : polynomial K := -f',
    let b : polynomial K := f + polynomial.C (1/E1.a4),
    use [a, b],
    calc a * f + b * f'
    = (-f') * f + (f + polynomial.C (1/E1.a4)) * f' : rfl
    ... = polynomial.C (1/E1.a4) * f' : by ring
    ... = 1 : by {
      rw ← polynomial.C_mul,
      field_simp [hns],
    },
  },
  cases hsc f hcop hdeg with r hr,
  repeat {rw polynomial.eval₂_add at hr},
  rw [polynomial.eval₂_mul, polynomial.eval₂_X_pow, polynomial.eval₂_X] at hr,
  repeat {rw polynomial.eval₂_C at hr},
  simp at hr,
  exact ⟨ r, hr ⟩,
end

lemma same_j_implies_isom'.char_3.j_non_zero {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (hmod : E.is_model_of_char_3_j_non_zero) (hmod' : E'.is_model_of_char_3_j_non_zero)
(h : E.j = E'.j) (hj : E.j ≠ 0) (hj' : E'.j ≠ 0)
(hchar3 : ring_char K = 3)
: E.is_isom' E' :=
begin
  simp [hmod, hmod', hchar3] at h hj hj',
  push_neg at hj hj',
  cases sep_closed_implies_pow_surj K hsc 2 (by { rw hchar3, norm_num, }) (E.a2 / E'.a2) with u hu,
  let C := linear_change_of_variable.mk u 0 0 0 (by {
    intro h, field_simp [h, hj'.1] at hu, exact hj.1 hu.symm,
  }),
  use C,
  simp [ext_iff, linear_change_of_variable.change_curve,
    hmod.1, hmod.2.1, hmod.2.2, hmod'.1, hmod'.2.1, hmod'.2.2, hu],
  split,
  { field_simp [hj.1, hj'.1, mul_comm], },
  transitivity E.a6 / (u ^ 2) ^ 3,
  { congr' 1, ring, },
  rw hu,
  field_simp [hj.1, hj.2, hj'.1, hj'.2] at h ⊢,
  rw [mul_comm E.a6, mul_comm E'.a6, h],
end

lemma same_j_implies_isom'.char_3.j_zero {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (hmod : E.is_model_of_char_neq_2_and_3) (hmod' : E'.is_model_of_char_neq_2_and_3)
(hns : E.a4 ≠ 0) (hns' : E'.a4 ≠ 0)
(hchar3 : ring_char K = 3)
: E.is_isom' E' :=
begin
  cases sep_closed_implies_pow_surj K hsc 4 (by { rw hchar3, norm_num, }) (E.a4 / E'.a4) with u hu,
  cases same_j_implies_isom'.char_3.solve_r_for_j_zero hsc u E E' hchar3 hns with r hr,
  let C := linear_change_of_variable.mk u r 0 0 (by {
    intro h, field_simp [h, hns'] at hu, exact hns hu.symm,
  }),
  use C,
  simp [ext_iff, linear_change_of_variable.change_curve,
    hmod.1, hmod.2.1, hmod.2.2, hmod'.1, hmod'.2.1, hmod'.2.2, hu],
  ring_char3,
  split, { field_simp [hns, hns', mul_comm], },
  field_simp [C.hu],
  transitivity E.a6 + r * E.a4 + r ^ 3 - (r ^ 3 + E.a4 * r + (E.a6 - u ^ 6 * E'.a6)),
  { rw hr, ring, },
  rw ← sub_eq_zero,
  ring,
end

lemma same_j_implies_isom'.char_3 {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (h : E.j = E'.j) (hns : E.non_singular') (hns' : E'.non_singular')
(hchar3 : ring_char K = 3)
: E.is_isom' E' :=
begin
  change E ≈ E',
  refine quotient.exact _,
  have hj0 : E.j = isom_class'.j ⟦E⟧ := by { simp [isom_class'.j], },
  have hj'0 : E'.j = isom_class'.j ⟦E'⟧ := by { simp [isom_class'.j], },
  rw [hj0, hj'0] at h,
  replace hns : isom_class'.non_singular' ⟦E⟧ := by { simp [isom_class'.non_singular', hns], },
  replace hns' : isom_class'.non_singular' ⟦E'⟧ := by { simp [isom_class'.non_singular', hns'], },
  rcases E.have_model_of_char_3 hchar3 with ⟨ hj, C, hmod ⟩ | ⟨ hj, C, hmod ⟩, {
    replace hj := hj hns,
    rcases E'.have_model_of_char_3 hchar3 with ⟨ hj', C', hmod' ⟩ | ⟨ hj', C', hmod' ⟩, {
      replace hj' := hj' hns',
      rw hj0 at hj,
      rw hj'0 at hj',
      set E1 := C.change_curve E with hE1, clear_value E1,
      set E1' := C'.change_curve E' with hE1', clear_value E1',
      replace hE1 : ⟦E⟧ = ⟦E1⟧ := quotient.sound (by { use C, exact hE1.symm, }),
      replace hE1' : ⟦E'⟧ = ⟦E1'⟧ := quotient.sound (by { use C', exact hE1'.symm, }),
      rw hE1 at *,
      rw hE1' at *,
      clear hE1 hE1' hj0 hj'0 C C' E E',
      refine quotient.sound _,
      simp [isom_class'.j] at h hj hj',
      exact same_j_implies_isom'.char_3.j_non_zero hsc hmod hmod' h hj hj' hchar3,
    }, {
      exfalso, finish,
    },
  }, {
    rcases E'.have_model_of_char_3 hchar3 with ⟨ hj', C', hmod' ⟩ | ⟨ hj', C', hmod' ⟩, {
      exfalso, finish,
    }, {
      rw hj0 at hj,
      rw hj'0 at hj',
      set E1 := C.change_curve E with hE1, clear_value E1,
      set E1' := C'.change_curve E' with hE1', clear_value E1',
      replace hE1 : ⟦E⟧ = ⟦E1⟧ := quotient.sound (by { use C, exact hE1.symm, }),
      replace hE1' : ⟦E'⟧ = ⟦E1'⟧ := quotient.sound (by { use C', exact hE1'.symm, }),
      rw hE1 at *,
      rw hE1' at *,
      clear hE1 hE1' hj0 hj'0 C C' E E',
      refine quotient.sound _,
      simp [isom_class'.non_singular', non_singular', hmod, hmod', hchar3] at hns hns',
      exact same_j_implies_isom'.char_3.j_zero hsc hmod hmod' hns hns' hchar3,
    },
  },
end

/--
Non-singular Weierstrass equations with same j-invariant are isomorphic
over a separable closed field.
-/
lemma same_j_implies_isom' {K : Type*} [field K] (hsc : my_sep_closed K)
{E E' : weierstrass_equation K} (h : E.j = E'.j) (hns : E.non_singular') (hns' : E'.non_singular')
: E.is_isom' E' :=
begin
  by_cases hchar2 : ring_char K = 2, {
    exact same_j_implies_isom'.char_2 hsc h hns hns' hchar2,
  },
  by_cases hchar3 : ring_char K = 3, {
    exact same_j_implies_isom'.char_3 hsc h hns hns' hchar3,
  },
  have hcharndvd2 : ¬ ring_char K ∣ 2 := by {
    cases char_is_prime_or_zero' K with hh hh, {
      rw nat.prime_dvd_prime_iff_eq hh nat.prime_two, exact hchar2,
    },
    rw hh, norm_num,
  },
  have hcharndvd3 : ¬ ring_char K ∣ 3 := by {
    cases char_is_prime_or_zero' K with hh hh, {
      rw nat.prime_dvd_prime_iff_eq hh nat.prime_three, exact hchar3,
    },
    rw hh, norm_num,
  },
  have hcharndvd4 : ¬ ring_char K ∣ 4 := by {
    cases char_is_prime_or_zero' K with hh hh, {
      rw (calc 4 = 2*2 : by norm_num),
      exact nat.prime.not_dvd_mul hh hcharndvd2 hcharndvd2,
    },
    rw hh, norm_num,
  },
  have hcharndvd6 : ¬ ring_char K ∣ 6 := by {
    cases char_is_prime_or_zero' K with hh hh, {
      rw (calc 6 = 2*3 : by norm_num),
      exact nat.prime.not_dvd_mul hh hcharndvd2 hcharndvd3,
    },
    rw hh, norm_num,
  },
  change E ≈ E',
  refine quotient.exact _,
  replace h : isom_class'.j ⟦E⟧ = isom_class'.j ⟦E'⟧ := by { simp [isom_class'.j, h], },
  replace hns : isom_class'.non_singular' ⟦E⟧ := by { simp [isom_class'.non_singular', hns], },
  replace hns' : isom_class'.non_singular' ⟦E'⟧ := by { simp [isom_class'.non_singular', hns'], },
  rcases E.have_model_of_char_neq_2_and_3 hchar2 hchar3 with ⟨ C, hmod ⟩,
  rcases E'.have_model_of_char_neq_2_and_3 hchar2 hchar3 with ⟨ C', hmod' ⟩,
  set E1 := C.change_curve E with hE1, clear_value E1,
  set E1' := C'.change_curve E' with hE1', clear_value E1',
  replace hE1 : ⟦E⟧ = ⟦E1⟧ := quotient.sound (by { use C, exact hE1.symm, }),
  replace hE1' : ⟦E'⟧ = ⟦E1'⟧ := quotient.sound (by { use C', exact hE1'.symm, }),
  rw hE1 at *,
  rw hE1' at *,
  clear hE1 hE1' C C' E E',
  refine quotient.sound _,
  simp [isom_class'.non_singular', non_singular'] at hns hns',
  field_simp [isom_class'.j, j, hns, hns'] at h,
  simp [hmod, hmod'] at h,
  ring_exp at h,
  replace h := calc E1.a4 ^ 3 * E1'.a6 ^ 2 * 16^4 * 27^2
  = (E1.a4 ^ 3 * (E1'.a4 ^ 3 * 7077888) + E1.a4 ^ 3 * (E1'.a6 ^ 2 * 47775744)) - E1.a4 ^ 3 * (E1'.a4 ^ 3 * 7077888) : by ring
  ... = E1'.a4 ^ 3 * E1.a6 ^ 2 * 16^4 * 27^2 : by { rw h, ring, },
  have h4 := power_of_prime_neq_char_is_non_zero K 4 2 2 (by norm_num) (by norm_num) hchar2, norm_num at h4,
  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,
  have h27 := power_of_prime_neq_char_is_non_zero K 27 3 3 (by norm_num) (by norm_num) hchar3, norm_num at h27,
  field_simp [h16, h27] at h,
  rw E1.disc_of_model_of_char_neq_2_and_3 hmod at hns,
  rw E1'.disc_of_model_of_char_neq_2_and_3 hmod' at hns',
  by_cases ha4 : E1.a4 = 0, {
    rw ha4 at h hns,
    simp [zero_pow, h16, h27] at hns,
    simp [zero_pow, hns] at h,
    simp [h, zero_pow, h16, h27] at hns',
    cases sep_closed_implies_pow_surj K hsc 6 hcharndvd6 (E1.a6/E1'.a6) with u hu,
    let C := linear_change_of_variable.mk u 0 0 0 (by {
      intro h, rw h at hu, field_simp [zero_pow, hns'] at hu, exact hns hu.symm,
    }),
    use C,
    simp [ext_iff, linear_change_of_variable.change_curve,
      hmod.1, hmod.2.1, hmod.2.2, hmod'.1, hmod'.2.1, hmod'.2.2, ha4, h, hu],
    field_simp [zero_pow, hns], ring,
  },
  by_cases ha6 : E1.a6 = 0, {
    rw ha6 at h hns,
    simp [zero_pow, ha4] at h,
    simp [h, zero_pow, h4, h16] at hns',
    cases sep_closed_implies_pow_surj K hsc 4 hcharndvd4 (E1.a4/E1'.a4) with u hu,
    let C := linear_change_of_variable.mk u 0 0 0 (by {
      intro h, rw h at hu, field_simp [zero_pow, hns'] at hu, exact ha4 hu.symm,
    }),
    use C,
    simp [ext_iff, linear_change_of_variable.change_curve,
      hmod.1, hmod.2.1, hmod.2.2, hmod'.1, hmod'.2.1, hmod'.2.2, ha6, h, hu],
    field_simp [zero_pow, ha4], ring,
  },
  by_cases ha4' : E1'.a4 = 0, {
    exfalso,
    simp [ha4', zero_pow, ha4] at h,
    simp [ha4', h, zero_pow] at hns',
    exact hns',
  },
  by_cases ha6' : E1'.a6 = 0, {
    exfalso,
    simp [ha6', zero_pow, ha4', ha6] at h,
    exact h,
  },
  cases sep_closed_implies_pow_surj K hsc 2 hcharndvd2 ((E1.a6 / E1'.a6) / (E1.a4 / E1'.a4)) with u hu,
  have hu4 := calc u ^ 4 = (u ^ 2) ^ 2 : by ring
  ... = E1.a4 / E1'.a4 : by {
    rw hu,
    field_simp [zero_pow, ha4, ha6, ha4', ha6'],
    ring_exp,
    rw mul_comm (E1.a6 ^ 2) _,
    exact h.symm,
  },
  have hu6 := calc u ^ 6 = (u ^ 2) ^ 3 : by ring
  ... = E1.a6 / E1'.a6 : by {
    rw hu,
    field_simp [zero_pow, ha4, ha6, ha4', ha6'],
    calc (E1.a6 * E1'.a4) ^ 3 * E1'.a6
    = (E1'.a4 ^ 3 * E1.a6 ^ 2) * E1.a6 * E1'.a6 : by ring
    ... = (E1.a4 ^ 3 * E1'.a6 ^ 2) * E1.a6 * E1'.a6 : by rw h
    ... = E1.a6 * (E1'.a6 * E1.a4) ^ 3 : by ring,
  },
  let C := linear_change_of_variable.mk u 0 0 0 (by {
    intro h, rw h at hu, field_simp [zero_pow, ha4, ha6, ha4', ha6'] at hu, exact hu,
  }),
  use C,
  simp [ext_iff, linear_change_of_variable.change_curve,
    hmod.1, hmod.2.1, hmod.2.2, hmod'.1, hmod'.2.1, hmod'.2.2, hu4, hu6],
  field_simp [zero_pow, ha4, ha6], split; ring,
end

end weierstrass_equation


import data.fintype
import data.set.finite
import data.list.basic

universe u

@[reducible]
def all (α : Type u) : set α := λ _ : α, true

class has_upper_bound {α} [has_le α] (s : set α) :=
(ub : α) (h : ∀ x : α, s x → x ≤ ub)

instance upper_bound_eq {k : ℕ} : has_upper_bound (λ x, x = k) := ⟨k, by simp⟩

instance uper_bound_le {k : ℕ} : has_upper_bound (λ x, x ≤ k) := ⟨k, by simp⟩

instance uper_bound_lt {k : ℕ} : has_upper_bound (λ x, x < k) := ⟨k, by { intros x h, exact le_of_lt h }⟩

instance uper_bound_and_right {p q : ℕ → Prop} [r : has_upper_bound p] : has_upper_bound (λ x, q x ∧ p x) :=
⟨r.ub, by { intros x h, have rh := r.h, exact rh x h.2}⟩

instance uper_bound_and_left {p q : ℕ → Prop} [l : has_upper_bound p] : has_upper_bound (λ x, p x ∧ q x) :=
⟨l.ub, by { intros x h, have lh := l.h, exact lh x h.1}⟩

instance uper_bound_set_of {α} [has_le α] {p : α → Prop} [hub : has_upper_bound p]: has_upper_bound (set_of p) := hub

example : has_upper_bound.ub ( λ x , true ∧ x ≤ 2) = 2 := rfl
example : has_upper_bound.ub { n | (3 ∣ n ∨ true) ∧ n < 2} = 2 := rfl
example : has_upper_bound.ub { n | (3 ∣ n ∨ 5 ∣ n) ∧ n < 1000 } = 1000 := rfl

-- def set_sum (s : set ℕ) [fintype s] : ℕ
-- := list.sum $ multiset.sort (nat.le) s.to_finset.val

def set_sum (s : set ℕ) [decidable_pred s] [hub : has_upper_bound s] : ℕ :=
list.sum $ list.filter s $ list.iota hub.ub


/-
Copyright (c) 2018 Reid Barton All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison, David Wärn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes v u l u₂

namespace Mathlib

namespace category_theory

/-- A `groupoid` is a category such that all morphisms are isomorphisms. -/
class groupoid (obj : Type u)
extends category obj
where
  inv : {X Y : obj} → (X ⟶ Y) → (Y ⟶ X)
  inv_comp' : autoParam (∀ {X Y : obj} (f : X ⟶ Y), inv f ≫ f = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  comp_inv' : autoParam (∀ {X Y : obj} (f : X ⟶ Y), f ≫ inv f = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem groupoid.inv_comp {obj : Type u} [c : groupoid obj] {X : obj} {Y : obj} (f : X ⟶ Y) : groupoid.inv f ≫ f = 𝟙 := sorry

@[simp] theorem groupoid.comp_inv {obj : Type u} [c : groupoid obj] {X : obj} {Y : obj} (f : X ⟶ Y) : f ≫ groupoid.inv f = 𝟙 := sorry

/--
A `large_groupoid` is a groupoid
where the objects live in `Type (u+1)` while the morphisms live in `Type u`.
-/
/--
def large_groupoid (C : Type (u + 1)) :=
  groupoid C

A `small_groupoid` is a groupoid
where the objects and morphisms live in the same universe.
-/
def small_groupoid (C : Type u) :=
  groupoid C

protected instance is_iso.of_groupoid {C : Type u} [groupoid C] {X : C} {Y : C} (f : X ⟶ Y) : is_iso f :=
  is_iso.mk (groupoid.inv f)

/-- In a groupoid, isomorphisms are equivalent to morphisms. -/
def groupoid.iso_equiv_hom {C : Type u} [groupoid C] (X : C) (Y : C) : (X ≅ Y) ≃ (X ⟶ Y) :=
  equiv.mk iso.hom (fun (f : X ⟶ Y) => as_iso f) sorry sorry

/-- A category where every morphism `is_iso` is a groupoid. -/
def groupoid.of_is_iso {C : Type u} [category C] (all_is_iso : {X Y : C} → (f : X ⟶ Y) → is_iso f) : groupoid C :=
  groupoid.mk fun (X Y : C) (f : X ⟶ Y) => inv f

/-- A category where every morphism has a `trunc` retraction is computably a groupoid. -/
def groupoid.of_trunc_split_mono {C : Type u} [category C] (all_split_mono : {X Y : C} → (f : X ⟶ Y) → trunc (split_mono f)) : groupoid C :=
  groupoid.of_is_iso
    fun (X Y : C) (f : X ⟶ Y) =>
      trunc.rec_on_subsingleton (all_split_mono f)
        fun (a : split_mono f) =>
          trunc.rec_on_subsingleton (all_split_mono (retraction f))
            fun (a_1 : split_mono (retraction f)) => is_iso.of_mono_retraction

protected instance induced_category.groupoid {C : Type u} (D : Type u₂) [groupoid D] (F : C → D) : groupoid (induced_category D F) :=
  groupoid.mk fun (X Y : induced_category D F) (f : X ⟶ Y) => groupoid.inv f


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.action
import combinatorics.quiver
import group_theory.is_free_group
/-!
# The Nielsen-Schreier theorem

This file proves that a subgroup of a free group is itself free.

## Main result

- `subgroup_is_free_of_is_free H`: an instance saying that a subgroup of a free group is free.

## Proof overview

The proof is analogous to the proof using covering spaces and fundamental groups of graphs,
but we work directly with groupoids instead of topological spaces. Under this analogy,

- `is_free_groupoid G` corresponds to saying that a space is a graph.
- `End_mul_equiv_subgroup H` plays the role of replacing 'subgroup of fundamental group' with
  'fundamental group of covering space'.
- `action_groupoid_is_free G A` corresponds to the fact that a covering of a (single-vertex)
  graph is a graph.
- `End_is_free T` corresponds to the fact that, given a spanning tree `T` of a
  graph, its fundamental group is free (generated by loops from the complement of the tree).

## Implementation notes

Our definition of `is_free_groupoid` is nonstandard. Normally one would require that functors
`G ⥤ X` to any _groupoid_ `X` are given by graph homomorphisms from the generators, but we only
consider _groups_ `X`. This simplifies the argument since functor equality is complicated in
general, but simple for functors to single object categories.

## References

https://ncatlab.org/nlab/show/Nielsen-Schreier+theorem

## Tags

free group, free groupoid, Nielsen-Schreier

-/

noncomputable theory
open_locale classical
universes v u

open category_theory category_theory.action_category category_theory.single_obj quiver
  is_free_group as fgp

/-- `is_free_groupoid.generators G` is a type synonym for `G`. We think of this as
the vertices of the generating quiver of `G` when `G` is free. We can't use `G` directly,
since `G` already has a quiver instance from being a groupoid. -/
@[nolint unused_arguments has_inhabited_instance]
def is_free_groupoid.generators (G) [groupoid G] := G

/-- A groupoid `G` is free when we have the following data:
 - a quiver on `is_free_groupoid.generators G` (a type synonym for `G`)
 - a function `of` taking a generating arrow to a morphism in `G`
 - such that a functor from `G` to any group `X` is uniquely determined
   by assigning labels in `X` to the generating arrows.

   This definition is nonstandard. Normally one would require that functors `G ⥤ X`
   to any _groupoid_ `X` are given by graph homomorphisms from `generators`. -/
class is_free_groupoid (G) [groupoid.{v} G] :=
(quiver_generators : quiver.{v+1} (is_free_groupoid.generators G))
(of : Π {a b : is_free_groupoid.generators G}, (a ⟶ b) → ((show G, from a) ⟶ b))
(unique_lift : ∀ {X : Type v} [group X] (f : labelling (is_free_groupoid.generators G) X),
                ∃! F : G ⥤ single_obj X, ∀ a b (g : a ⟶ b),
                  F.map (of g) = f g)

namespace is_free_groupoid

attribute [instance] quiver_generators

/-- Two functors from a free groupoid to a group are equal when they agree on the generating
quiver. -/
@[ext]
lemma ext_functor {G} [groupoid.{v} G] [is_free_groupoid G] {X : Type v} [group X]
  (f g : G ⥤ single_obj X)
  (h : ∀ a b (e : a ⟶ b), f.map (of e) = g.map (of e)) :
  f = g :=
let ⟨_, _, u⟩ := @unique_lift G _ _ X _ (λ (a b : generators G) (e : a ⟶ b), g.map (of e)) in
trans (u _ h) (u _ (λ _ _ _, rfl)).symm

/-- An action groupoid over a free froup is free. More generally, one could show that the groupoid
of elements over a free groupoid is free, but this version is easier to prove and suffices for our
purposes.

Analogous to the fact that a covering space of a graph is a graph. (A free groupoid is like a graph,
and a groupoid of elements is like a covering space.) -/
instance action_groupoid_is_free {G A : Type u} [group G] [is_free_group G] [mul_action G A] :
  is_free_groupoid (action_category G A) :=
{ quiver_generators := ⟨λ a b, { e : fgp.generators G // fgp.of e • a.back = b.back }⟩,
  of := λ a b e, ⟨fgp.of e, e.property⟩,
  unique_lift := begin
    introsI X _ f,
    let f' : fgp.generators G → (A → X) ⋊[mul_aut_arrow] G :=
      λ e, ⟨λ b, @f ⟨(), _⟩ ⟨(), b⟩ ⟨e, smul_inv_smul _ b⟩, fgp.of e⟩,
    rcases fgp.unique_lift f' with ⟨F', hF', uF'⟩,
    refine ⟨uncurry F' _, _, _⟩,
    { suffices : semidirect_product.right_hom.comp F' = monoid_hom.id _,
      { exact monoid_hom.ext_iff.mp this },
      ext,
      rw [monoid_hom.comp_apply, hF'],
      refl },
    { rintros ⟨⟨⟩, a : A⟩ ⟨⟨⟩, b⟩ ⟨e, h : fgp.of e • a = b⟩,
      change (F' (fgp.of _)).left _ = _,
      rw hF',
      cases (inv_smul_eq_iff.mpr h.symm),
      refl },
    { intros E hE,
      have : curry E = F',
      { apply uF',
        intro e,
        ext,
        { convert hE _ _ _, refl },
        { refl } },
      apply functor.hext,
      { intro, apply unit.ext },
      { refine action_category.cases _, intros,
        simp only [←this, uncurry_map, curry_apply_left, coe_back, hom_of_pair.val] } },
  end }

namespace spanning_tree
/- In this section, we suppose we have a free groupoid with a spanning tree for its generating
quiver. The goal is to prove that the vertex group at the root is free. A picture to have in mind
is that we are 'pulling' the endpoints of all the edges of the quiver along the spanning tree to
the root. -/
variables {G : Type u} [groupoid.{u} G] [is_free_groupoid G]
  (T : wide_subquiver (symmetrify $ generators G)) [arborescence T]

/-- The root of `T`, except its type is `G` instead of the type synonym `T`. -/
private def root' : G := show T, from root T

/-- A path in the tree gives a hom, by composition. -/
-- this has to be marked noncomputable, see issue #451.
-- It might be nicer to define this in terms of `compose_path`
noncomputable def hom_of_path : Π {a : G}, path (root T) a → (root' T ⟶ a)
| _ path.nil := 𝟙 _
| a (path.cons p f) := hom_of_path p ≫ sum.rec_on f.val (λ e, of e) (λ e, inv (of e))

/-- For every vertex `a`, there is a canonical hom from the root, given by the path in the tree. -/
def tree_hom (a : G) : root' T ⟶ a := hom_of_path T (default _)

/-- Any path to `a` gives `tree_hom T a`, since paths in the tree are unique. -/
lemma tree_hom_eq {a : G} (p : path (root T) a) : tree_hom T a = hom_of_path T p :=
by rw [tree_hom, unique.default_eq]

@[simp] lemma tree_hom_root : tree_hom T (root' T) = 𝟙 _ :=
-- this should just be `tree_hom_eq T path.nil`, but Lean treats `hom_of_path` with suspicion.
trans (tree_hom_eq T path.nil) rfl

/-- Any hom in `G` can be made into a loop, by conjugating with `tree_hom`s. -/
def loop_of_hom {a b : G} (p : a ⟶ b) : End (root' T) :=
tree_hom T a ≫ p ≫ inv (tree_hom T b)

/-- Turning an edge in the spanning tree into a loop gives the indentity loop. -/
lemma loop_of_hom_eq_id {a b : generators G} (e ∈ wide_subquiver_symmetrify T a b) :
  loop_of_hom T (of e) = 𝟙 (root' T) :=
begin
  rw [loop_of_hom, ←category.assoc, is_iso.comp_inv_eq, category.id_comp],
  cases H,
  { rw [tree_hom_eq T (path.cons (default _) ⟨sum.inl e, H⟩), hom_of_path], refl },
  { rw [tree_hom_eq T (path.cons (default _) ⟨sum.inr e, H⟩), hom_of_path],
    simp only [is_iso.inv_hom_id, category.comp_id, category.assoc, tree_hom] }
end

/-- Since a hom gives a loop, any homomorphism from the vertex group at the root
    extends to a functor on the whole groupoid. -/
@[simps] def functor_of_monoid_hom {X} [monoid X] (f : End (root' T) →* X) :
  G ⥤ single_obj X :=
{ obj := λ _, (),
  map := λ a b p, f (loop_of_hom T p),
  map_id' := begin
    intro a,
    rw [loop_of_hom, category.id_comp, is_iso.hom_inv_id, ←End.one_def, f.map_one, id_as_one],
 end,
  map_comp' := begin
    intros,
    rw [comp_as_mul, ←f.map_mul],
    simp only [is_iso.inv_hom_id_assoc, loop_of_hom, End.mul_def, category.assoc]
  end }

/-- Given a free groupoid and an arborescence of its generating quiver, the vertex
    group at the root is freely generated by loops coming from generating arrows
    in the complement of the tree. -/
def End_is_free : is_free_group (End (root' T)) :=
{ generators := set.compl (wide_subquiver_equiv_set_total $ wide_subquiver_symmetrify T),
  of := λ e, loop_of_hom T (of e.val.hom),
  unique_lift' := begin
    introsI X _ f,
    let f' : labelling (generators G) X := λ a b e,
      if h : e ∈ wide_subquiver_symmetrify T a b then 1
      else f ⟨⟨a, b, e⟩, h⟩,
    rcases unique_lift f' with ⟨F', hF', uF'⟩,
    refine ⟨F'.map_End _, _, _⟩,
    { suffices : ∀ {x y} (q : x ⟶ y), F'.map (loop_of_hom T q) = (F'.map q : X),
      { rintro ⟨⟨a, b, e⟩, h⟩,
        rw [functor.map_End_apply, this, hF'],
        exact dif_neg h },
      intros,
      suffices : ∀ {a} (p : path (root' T) a), F'.map (hom_of_path T p) = 1,
      { simp only [this, tree_hom, comp_as_mul, inv_as_inv, loop_of_hom,
        one_inv, mul_one, one_mul, functor.map_inv, functor.map_comp] },
      intros a p, induction p with b c p e ih,
      { rw [hom_of_path, F'.map_id, id_as_one] },
      rw [hom_of_path, F'.map_comp, comp_as_mul, ih, mul_one],
      rcases e with ⟨e | e, eT⟩,
      { rw hF', exact dif_pos (or.inl eT) },
      { rw [F'.map_inv, inv_as_inv, inv_eq_one, hF'], exact dif_pos (or.inr eT) } },
    { intros E hE,
      ext,
      suffices : (functor_of_monoid_hom T E).map x = F'.map x,
      { simpa only [loop_of_hom, functor_of_monoid_hom_map, is_iso.inv_id, tree_hom_root,
          category.id_comp, category.comp_id] using this },
      congr,
      apply uF',
      intros a b e,
      change E (loop_of_hom T _) = dite _ _ _,
      split_ifs,
      { rw [loop_of_hom_eq_id T e h, ←End.one_def, E.map_one] },
      { exact hE ⟨⟨a, b, e⟩, h⟩ } }
  end }

end spanning_tree

/-- Another name for the identity function `G → G`, to help type checking. -/
private def symgen {G : Type u} [groupoid.{v} G] [is_free_groupoid G] :
  G → symmetrify (generators G) := id

/-- If there exists a morphism `a → b` in a free groupoid, then there also exists a zigzag
from `a` to `b` in the generating quiver. -/
lemma path_nonempty_of_hom {G} [groupoid.{u u} G] [is_free_groupoid G] {a b : G} :
  nonempty (a ⟶ b) → nonempty (path (symgen a) (symgen b)) :=
begin
  rintro ⟨p⟩,
  rw [←weakly_connected_component.eq, eq_comm, ←free_group.of_injective.eq_iff, ←mul_inv_eq_one],
  let X := free_group (weakly_connected_component $ symmetrify $ generators G),
  let f : G → X := λ g, free_group.of ↑(symgen g),
  let F : G ⥤ single_obj X := single_obj.difference_functor f,
  change F.map p = ((category_theory.functor.const G).obj ()).map p,
  congr, ext,
  rw [functor.const.obj_map, id_as_one, difference_functor_map, mul_inv_eq_one],
  apply congr_arg free_group.of,
  rw weakly_connected_component.eq,
  exact ⟨hom.to_path (sum.inr e)⟩,
end

/-- Given a connected free groupoid, its generating quiver is rooted-connected. -/
instance generators_connected (G) [groupoid.{u u} G] [is_connected G] [is_free_groupoid G]
  (r : G) : rooted_connected (symgen r) :=
⟨λ b, path_nonempty_of_hom (category_theory.nonempty_hom_of_connected_groupoid r b)⟩

/-- A vertex group in a free connected groupoid is free. With some work one could drop the
connectedness assumption, by looking at connected components. -/
instance End_is_free_of_connected_free {G} [groupoid G] [is_connected G] [is_free_groupoid G]
  (r : G) : is_free_group (End r) :=
spanning_tree.End_is_free $ geodesic_subtree (symgen r)

end is_free_groupoid

/-- The Nielsen-Schreier theorem: a subgroup of a free group is free. -/
instance subgroup_is_free_of_is_free {G : Type u} [group G] [is_free_group G]
  (H : subgroup G) : is_free_group H :=
is_free_group.of_mul_equiv (End_mul_equiv_subgroup H)


universe variables u v

namespace quot

section
  universe variables u_a u_b u_c
  variables {A : Type u_a} {B : Type u_b} {C : Type u_c}
  variables [s₁ : setoid A] [s₂ : setoid B]

  include s₁ s₂

  attribute [reducible, elab_as_eliminator]
  protected definition lift₂
     (f : A → B → C)(c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂)
     (q₁ : quotient s₁) (q₂ : quotient s₂) : C :=
  quot.lift
    (λ (a₁ : A), quot.lift (f a₁) (λ (a b : B), c a₁ a a₁ b (setoid.refl a₁)) q₂)
    (λ (a b : A) (H : a ≈ b),
       @quot.ind B s₂.r
         (λ (a_1 : quotient s₂),
            (quot.lift (f a) (λ (a_1 b : B), c a a_1 a b (setoid.refl a)) a_1)
            =
            (quot.lift (f b) (λ (a b_1 : B), c b a b b_1 (setoid.refl b)) a_1))
         (λ (a' : B), c a a' b a' H (setoid.refl a'))
         q₂)
    q₁

  attribute [reducible, elab_as_eliminator]
  protected definition lift_on₂ (q₁ : quotient s₁) (q₂ : quotient s₂) (f : A → B → C) (c : ∀ a₁ a₂ b₁ b₂, a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : C :=
quot.lift₂ f c q₁ q₂

  attribute [elab_as_eliminator]
  protected theorem induction_on₂ {C : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (H : ∀ a b, C ⟦a⟧ ⟦b⟧) : C q₁ q₂ :=
quot.ind (λ a₁, quot.ind (λ a₂, H a₁ a₂) q₂) q₁

  attribute [elab_as_eliminator]
  protected theorem induction_on₃
     [s₃ : setoid C]
     {D : quotient s₁ → quotient s₂ → quotient s₃ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) (H : ∀ a b c, D ⟦a⟧ ⟦b⟧ ⟦c⟧)
     : D q₁ q₂ q₃ :=
quot.ind (λ a₁, quot.ind (λ a₂, quot.ind (λ a₃, H a₁ a₂ a₃) q₃) q₂) q₁

end

  section exact
  variable {A : Type u}
  variable [s : setoid A]
  include s

  private definition rel (q₁ q₂ : quotient s) : Prop :=
  quot.lift_on₂ q₁ q₂
    (λ a₁ a₂, a₁ ≈ a₂)
    (λ a₁ a₂ b₁ b₂ a₁b₁ a₂b₂,
      propext (iff.intro
        (λ a₁a₂, setoid.trans (setoid.symm a₁b₁) (setoid.trans a₁a₂ a₂b₂))
        (λ b₁b₂, setoid.trans a₁b₁ (setoid.trans b₁b₂ (setoid.symm a₂b₂)))))

  local infix `~` := rel

  private lemma rel.refl : ∀ q : quotient s, q ~ q :=
  λ q, quot.induction_on q (λ a, setoid.refl a)

  private lemma eq_imp_rel {q₁ q₂ : quotient s} : q₁ = q₂ → q₁ ~ q₂ :=
  assume h, eq.rec_on h (rel.refl q₁)

  theorem exact' {a b : A} : ⟦a⟧ = ⟦b⟧ → a ≈ b :=
  assume h, eq_imp_rel h

  end exact

  section
  universe variables u_a u_b u_c
  variables {A : Type u_a} {B : Type u_b}
  variables [s₁ : setoid A] [s₂ : setoid B]
  include s₁ s₂

  attribute [reducible, elab_as_eliminator]
  protected definition rec_on_subsingleton₂
     {C : quotient s₁ → quotient s₂ → Type u_c} [H : ∀ a b, subsingleton (C ⟦a⟧ ⟦b⟧)]
     (q₁ : quotient s₁) (q₂ : quotient s₂) (f : Π a b, C ⟦a⟧ ⟦b⟧) : C q₁ q₂:=
  @quot.rec_on_subsingleton _ s₁.r (λ q, C q q₂) (λ a, quot.ind (λ b, H a b) q₂) q₁
    (λ a, @quot.rec_on_subsingleton _ s₂.r _ (H a) q₂ (λ b, f a b))

end

end quot


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.meta.rb_map
import Mathlib.tactic.ring
import Mathlib.tactic.linarith.lemmas
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# Datatypes for `linarith`

Some of the data structures here are used in multiple parts of the tactic.
We split them into their own file.

This file also contains a few convenient auxiliary functions.
-/

namespace linarith

/-- A shorthand for tracing when the `trace.linarith` option is set to true. -/
/--
A shorthand for tracing the types of a list of proof terms
when the `trace.linarith` option is set to true.
-/
/-! ### Linear expressions -/

/--
A linear expression is a list of pairs of variable indices and coefficients,
representing the sum of the products of each coefficient with its corresponding variable.

Some functions on `linexp` assume that `n : ℕ` occurs at most once as the first element of a pair,
and that the list is sorted in decreasing order of the first argument.
This is not enforced by the type but the operations here preserve it.
-/
def linexp := List (ℕ × ℤ)

namespace linexp

/--
Add two `linexp`s together componentwise.
Preserves sorting and uniqueness of the first argument.
-/
/-- `l.scale c` scales the values in `l` by `c` without modifying the order or keys. -/
def scale (c : ℤ) (l : linexp) : linexp :=
  ite (c = 0) [] (ite (c = 1) l (list.map (fun (_x : ℕ × ℤ) => sorry) l))

/--
`l.get n` returns the value in `l` associated with key `n`, if it exists, and `none` otherwise.
This function assumes that `l` is sorted in decreasing order of the first argument,
that is, it will return `none` as soon as it finds a key smaller than `n`.
-/
def get (n : ℕ) : linexp → Option ℤ := sorry

/--
`l.contains n` is true iff `n` is the first element of a pair in `l`.
-/
def contains (n : ℕ) : linexp → Bool := option.is_some ∘ get n

/--
`l.zfind n` returns the value associated with key `n` if there is one, and 0 otherwise.
-/
def zfind (n : ℕ) (l : linexp) : ℤ := sorry

/-- `l.vars` returns the list of variables that occur in `l`. -/
def vars (l : linexp) : List ℕ := list.map prod.fst l

/--
Defines a lex ordering on `linexp`. This function is performance critical.
-/
def cmp : linexp → linexp → ordering := sorry

end linexp

/-! ### Inequalities -/

/-- The three-element type `ineq` is used to represent the strength of a comparison between terms. -/
inductive ineq where
| eq : ineq
| le : ineq
| lt : ineq

namespace ineq

/--
`max R1 R2` computes the strength of the sum of two inequalities. If `t1 R1 0` and `t2 R2 0`,
then `t1 + t2 (max R1 R2) 0`.
-/
def max : ineq → ineq → ineq := sorry

/-- `ineq` is ordered `eq < le < lt`. -/
def cmp : ineq → ineq → ordering := sorry

/-- Prints an `ineq` as the corresponding infix symbol. -/
def to_string : ineq → string := sorry

/-- Finds the name of a multiplicative lemma corresponding to an inequality strength. -/
protected instance has_to_string : has_to_string ineq := has_to_string.mk to_string

end ineq

/-! ### Comparisons with 0 -/

/--
The main datatype for FM elimination.
Variables are represented by natural numbers, each of which has an integer coefficient.
Index 0 is reserved for constants, i.e. `coeffs.find 0` is the coefficient of 1.
The represented term is `coeffs.sum (λ ⟨k, v⟩, v * Var[k])`.
str determines the strength of the comparison -- is it < 0, ≤ 0, or = 0?
-/
structure comp where
  str : ineq
  coeffs : linexp

/-- `c.vars` returns the list of variables that appear in the linear expression contained in `c`. -/
def comp.vars : comp → List ℕ := linexp.vars ∘ comp.coeffs

/-- `comp.coeff_of c a` projects the coefficient of variable `a` out of `c`. -/
def comp.coeff_of (c : comp) (a : ℕ) : ℤ := linexp.zfind a (comp.coeffs c)

/-- `comp.scale c n` scales the coefficients of `c` by `n`. -/
def comp.scale (c : comp) (n : ℕ) : comp := comp.mk (comp.str c) (linexp.scale (↑n) (comp.coeffs c))

/--
`comp.add c1 c2` adds the expressions represented by `c1` and `c2`.
The coefficient of variable `a` in `c1.add c2`
is the sum of the coefficients of `a` in `c1` and `c2`.
 -/
/-- `comp` has a lex order. First the `ineq`s are compared, then the `coeff`s. -/
/--
A `comp` represents a contradiction if its expression has no coefficients and its strength is <,
that is, it represents the fact `0 < 0`.
 -/
/-! ### Parsing into linear form -/

/-! ### Control -/

/--
A preprocessor transforms a proof of a proposition into a proof of a different propositon.
The return type is `list expr`, since some preprocessing steps may create multiple new hypotheses,
and some may remove a hypothesis from the list.
A "no-op" preprocessor should return its input as a singleton list.
-/
/--
Some preprocessors need to examine the full list of hypotheses instead of working item by item.
As with `preprocessor`, the input to a `global_preprocessor` is replaced by, not added to, its output.
-/
/--
Some preprocessors perform branching case splits. A `branch` is used to track one of these case
splits. The first component, an `expr`, is the goal corresponding to this branch of the split,
given as a metavariable. The `list expr` component is the list of hypotheses for `linarith`
in this branch. Every `expr` in this list should be type correct in the context of the associated goal.
-/
/--
Some preprocessors perform branching case splits.
A `global_branching_preprocessor` produces a list of branches to run.
Each branch is independent, so hypotheses that appear in multiple branches should be duplicated.
The preprocessor is responsible for making sure that each branch contains the correct goal
metavariable.
-/
/--
A `preprocessor` lifts to a `global_preprocessor` by folding it over the input list.
-/
/--
A `global_preprocessor` lifts to a `global_branching_preprocessor` by producing only one branch.
-/
/--
`process pp l` runs `pp.transform` on `l` and returns the result,
tracing the result if `trace.linarith` is on.
-/
/--
A `certificate_oracle` is a function `produce_certificate : list comp → ℕ → tactic (rb_map ℕ ℕ)`.
`produce_certificate hyps max_var` tries to derive a contradiction from the comparisons in `hyps`
by eliminating all variables ≤ `max_var`.
If successful, it returns a map `coeff : ℕ → ℕ` as a certificate.
This map represents that we can find a contradiction by taking the sum  `∑ (coeff i) * hyps[i]`.

The default `certificate_oracle` used by `linarith` is `linarith.fourier_motzkin.produce_certificate`
-/
/-- A configuration object for `linarith`. -/
end Mathlib