/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/
import linear_algebra.multilinear.basis
import linear_algebra.matrix.reindex
import ring_theory.algebra_tower
import tactic.field_simp
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.matrix.basis

/-!
# Determinant of families of vectors

This file defines the determinant of an endomorphism, and of a family of vectors
with respect to some basis. For the determinant of a matrix, see the file
`linear_algebra.matrix.determinant`.

## Main definitions

In the list below, and in all this file, `R` is a commutative ring (semiring
is sometimes enough), `M` and its variations are `R`-modules, `ι`, `κ`, `n` and `m` are finite
types used for indexing.

 * `basis.det`: the determinant of a family of vectors with respect to a basis,
   as a multilinear map
 * `linear_map.det`: the determinant of an endomorphism `f : End R M` as a
   multiplicative homomorphism (if `M` does not have a finite `R`-basis, the
   result is `1` instead)
 * `linear_equiv.det`: the determinant of an isomorphism `f : M ≃ₗ[R] M` as a
   multiplicative homomorphism (if `M` does not have a finite `R`-basis, the
   result is `1` instead)

## Tags

basis, det, determinant
-/

noncomputable theory

open_locale big_operators
open_locale matrix

open linear_map
open submodule

universes u v w

open linear_map matrix set function

variables {R : Type*} [comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]
variables {M' : Type*} [add_comm_group M'] [module R M']
variables {ι : Type*} [decidable_eq ι] [fintype ι]
variables (e : basis ι R M)

section conjugate

variables {A : Type*} [comm_ring A]
variables {m n : Type*} [fintype m] [fintype n]

/-- If `R^m` and `R^n` are linearly equivalent, then `m` and `n` are also equivalent. -/
def equiv_of_pi_lequiv_pi {R : Type*} [comm_ring R] [nontrivial R]
  (e : (m → R) ≃ₗ[R] (n → R)) : m ≃ n :=
basis.index_equiv (basis.of_equiv_fun e.symm) (pi.basis_fun _ _)

namespace matrix

/-- If `M` and `M'` are each other's inverse matrices, they are square matrices up to
equivalence of types. -/
def index_equiv_of_inv [nontrivial A] [decidable_eq m] [decidable_eq n]
  {M : matrix m n A} {M' : matrix n m A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  m ≃ n :=
equiv_of_pi_lequiv_pi (to_lin'_of_inv hMM' hM'M)

lemma det_comm [decidable_eq n] (M N : matrix n n A) : det (M ⬝ N) = det (N ⬝ M) :=
by rw [det_mul, det_mul, mul_comm]

/-- If there exists a two-sided inverse `M'` for `M` (indexed differently),
then `det (N ⬝ M) = det (M ⬝ N)`. -/
lemma det_comm' [decidable_eq m] [decidable_eq n]
  {M : matrix n m A} {N : matrix m n A} {M' : matrix m n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  det (M ⬝ N) = det (N ⬝ M) :=
begin
  nontriviality A,
  -- Although `m` and `n` are different a priori, we will show they have the same cardinality.
  -- This turns the problem into one for square matrices, which is easy.
  let e := index_equiv_of_inv hMM' hM'M,
  rw [← det_minor_equiv_self e, ← minor_mul_equiv _ _ _ (equiv.refl n) _, det_comm,
    minor_mul_equiv, equiv.coe_refl, minor_id_id]
end

/-- If `M'` is a two-sided inverse for `M` (indexed differently), `det (M ⬝ N ⬝ M') = det N`.

See `matrix.det_conj` and `matrix.det_conj'` for the case when `M' = M⁻¹` or vice versa. -/
lemma det_conj_of_mul_eq_one [decidable_eq m] [decidable_eq n]
  {M : matrix m n A} {M' : matrix n m A} {N : matrix n n A}
  (hMM' : M ⬝ M' = 1) (hM'M : M' ⬝ M = 1) :
  det (M ⬝ N ⬝ M') = det N :=
by rw [← det_comm' hM'M hMM', ← matrix.mul_assoc, hM'M, matrix.one_mul]

end matrix

end conjugate

namespace linear_map

/-! ### Determinant of a linear map -/

variables {A : Type*} [comm_ring A] [module A M]
variables {κ : Type*} [fintype κ]

/-- The determinant of `linear_map.to_matrix` does not depend on the choice of basis. -/
lemma det_to_matrix_eq_det_to_matrix [decidable_eq κ]
  (b : basis ι A M) (c : basis κ A M) (f : M →ₗ[A] M) :
  det (linear_map.to_matrix b b f) = det (linear_map.to_matrix c c f) :=
by rw [← linear_map_to_matrix_mul_basis_to_matrix c b c,
       ← basis_to_matrix_mul_linear_map_to_matrix b c b,
       matrix.det_conj_of_mul_eq_one]; rw [basis.to_matrix_mul_to_matrix, basis.to_matrix_self]

/-- The determinant of an endomorphism given a basis.

See `linear_map.det` for a version that populates the basis non-computably.

Although the `trunc (basis ι A M)` parameter makes it slightly more convenient to switch bases,
there is no good way to generalize over universe parameters, so we can't fully state in `det_aux`'s
type that it does not depend on the choice of basis. Instead you can use the `det_aux_def'` lemma,
or avoid mentioning a basis at all using `linear_map.det`.
-/
def det_aux : trunc (basis ι A M) → (M →ₗ[A] M) →* A :=
trunc.lift
  (λ b : basis ι A M,
    (det_monoid_hom).comp (to_matrix_alg_equiv b : (M →ₗ[A] M) →* matrix ι ι A))
  (λ b c, monoid_hom.ext $ det_to_matrix_eq_det_to_matrix b c)

/-- Unfold lemma for `det_aux`.

See also `det_aux_def'` which allows you to vary the basis.
-/
lemma det_aux_def (b : basis ι A M) (f : M →ₗ[A] M) :
  linear_map.det_aux (trunc.mk b) f = matrix.det (linear_map.to_matrix b b f) :=
rfl

-- Discourage the elaborator from unfolding `det_aux` and producing a huge term.
attribute [irreducible] linear_map.det_aux

lemma det_aux_def' {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (tb : trunc $ basis ι A M) (b' : basis ι' A M) (f : M →ₗ[A] M) :
  linear_map.det_aux tb f = matrix.det (linear_map.to_matrix b' b' f) :=
by { apply trunc.induction_on tb, intro b, rw [det_aux_def, det_to_matrix_eq_det_to_matrix b b'] }

@[simp]
lemma det_aux_id (b : trunc $ basis ι A M) : linear_map.det_aux b (linear_map.id) = 1 :=
(linear_map.det_aux b).map_one

@[simp]
lemma det_aux_comp (b : trunc $ basis ι A M) (f g : M →ₗ[A] M) :
  linear_map.det_aux b (f.comp g) = linear_map.det_aux b f * linear_map.det_aux b g :=
(linear_map.det_aux b).map_mul f g

section
open_locale classical

-- Discourage the elaborator from unfolding `det` and producing a huge term by marking it
-- as irreducible.
/-- The determinant of an endomorphism independent of basis.

If there is no finite basis on `M`, the result is `1` instead.
-/
@[irreducible] protected def det : (M →ₗ[A] M) →* A :=
if H : ∃ (s : finset M), nonempty (basis s A M)
then linear_map.det_aux (trunc.mk H.some_spec.some)
else 1

lemma coe_det [decidable_eq M] : ⇑(linear_map.det : (M →ₗ[A] M) →* A) =
  if H : ∃ (s : finset M), nonempty (basis s A M)
  then linear_map.det_aux (trunc.mk H.some_spec.some)
  else 1 :=
by { ext, unfold linear_map.det,
     split_ifs,
     { congr }, -- use the correct `decidable_eq` instance
     refl }

end

-- Auxiliary lemma, the `simp` normal form goes in the other direction
-- (using `linear_map.det_to_matrix`)
lemma det_eq_det_to_matrix_of_finset [decidable_eq M]
  {s : finset M} (b : basis s A M) (f : M →ₗ[A] M) :
  f.det = matrix.det (linear_map.to_matrix b b f) :=
have ∃ (s : finset M), nonempty (basis s A M),
from ⟨s, ⟨b⟩⟩,
by rw [linear_map.coe_det, dif_pos, det_aux_def' _ b]; assumption

@[simp] lemma det_to_matrix
  (b : basis ι A M) (f : M →ₗ[A] M) :
  matrix.det (to_matrix b b f) = f.det :=
by { haveI := classical.dec_eq M,
     rw [det_eq_det_to_matrix_of_finset b.reindex_finset_range, det_to_matrix_eq_det_to_matrix b] }

@[simp] lemma det_to_matrix' {ι : Type*} [fintype ι] [decidable_eq ι]
  (f : (ι → A) →ₗ[A] (ι → A)) :
  det f.to_matrix' = f.det :=
by simp [← to_matrix_eq_to_matrix']

/-- To show `P f.det` it suffices to consider `P (to_matrix _ _ f).det` and `P 1`. -/
@[elab_as_eliminator]
lemma det_cases [decidable_eq M] {P : A → Prop} (f : M →ₗ[A] M)
  (hb : ∀ (s : finset M) (b : basis s A M), P (to_matrix b b f).det) (h1 : P 1) :
  P f.det :=
begin
  unfold linear_map.det,
  split_ifs with h,
  { convert hb _ h.some_spec.some,
    apply det_aux_def' },
  { exact h1 }
end

@[simp]
lemma det_comp (f g : M →ₗ[A] M) : (f.comp g).det = f.det * g.det :=
linear_map.det.map_mul f g

@[simp]
lemma det_id : (linear_map.id : M →ₗ[A] M).det = 1 :=
linear_map.det.map_one

/-- Multiplying a map by a scalar `c` multiplies its determinant by `c ^ dim M`. -/
@[simp] lemma det_smul {𝕜 : Type*} [field 𝕜] {M : Type*} [add_comm_group M] [module 𝕜 M]
  (c : 𝕜) (f : M →ₗ[𝕜] M) :
  linear_map.det (c • f) = c ^ (finite_dimensional.finrank 𝕜 M) * linear_map.det f :=
begin
  by_cases H : ∃ (s : finset M), nonempty (basis s 𝕜 M),
  { haveI : finite_dimensional 𝕜 M,
    { rcases H with ⟨s, ⟨hs⟩⟩, exact finite_dimensional.of_finset_basis hs },
    simp only [← det_to_matrix (finite_dimensional.fin_basis 𝕜 M), linear_equiv.map_smul,
              fintype.card_fin, det_smul] },
  { classical,
    have : finite_dimensional.finrank 𝕜 M = 0 := finrank_eq_zero_of_not_exists_basis H,
    simp [coe_det, H, this] }
end

lemma det_zero' {ι : Type*} [fintype ι] [nonempty ι] (b : basis ι A M) :
  linear_map.det (0 : M →ₗ[A] M) = 0 :=
by { haveI := classical.dec_eq ι,
     rw [← det_to_matrix b, linear_equiv.map_zero, det_zero],
     assumption }

/-- In a finite-dimensional vector space, the zero map has determinant `1` in dimension `0`,
and `0` otherwise. We give a formula that also works in infinite dimension, where we define
the determinant to be `1`. -/
@[simp] lemma det_zero {𝕜 : Type*} [field 𝕜] {M : Type*} [add_comm_group M] [module 𝕜 M] :
  linear_map.det (0 : M →ₗ[𝕜] M) = (0 : 𝕜) ^ (finite_dimensional.finrank 𝕜 M) :=
by simp only [← zero_smul 𝕜 (1 : M →ₗ[𝕜] M), det_smul, mul_one, monoid_hom.map_one]

/-- Conjugating a linear map by a linear equiv does not change its determinant. -/
@[simp] lemma det_conj {N : Type*} [add_comm_group N] [module A N]
  (f : M →ₗ[A] M) (e : M ≃ₗ[A] N) :
  linear_map.det ((e : M →ₗ[A] N) ∘ₗ (f ∘ₗ (e.symm : N →ₗ[A] M))) = linear_map.det f :=
begin
  classical,
  by_cases H : ∃ (s : finset M), nonempty (basis s A M),
  { rcases H with ⟨s, ⟨b⟩⟩,
    rw [← det_to_matrix b f, ← det_to_matrix (b.map e), to_matrix_comp (b.map e) b (b.map e),
        to_matrix_comp (b.map e) b b, ← matrix.mul_assoc, matrix.det_conj_of_mul_eq_one],
    { rw [← to_matrix_comp, linear_equiv.comp_coe, e.symm_trans_self,
          linear_equiv.refl_to_linear_map, to_matrix_id] },
    { rw [← to_matrix_comp, linear_equiv.comp_coe, e.self_trans_symm,
          linear_equiv.refl_to_linear_map, to_matrix_id] } },
  { have H' : ¬ (∃ (t : finset N), nonempty (basis t A N)),
    { contrapose! H,
      rcases H with ⟨s, ⟨b⟩⟩,
      exact ⟨_, ⟨(b.map e.symm).reindex_finset_range⟩⟩ },
    simp only [coe_det, H, H', pi.one_apply, dif_neg, not_false_iff] }
end

/-- If a linear map is invertible, so is its determinant. -/
lemma is_unit_det {A : Type*} [comm_ring A] [module A M]
  (f : M →ₗ[A] M) (hf : is_unit f) : is_unit f.det :=
begin
  obtain ⟨g, hg⟩ : ∃ g, f.comp g = 1 := hf.exists_right_inv,
  have : linear_map.det f * linear_map.det g = 1,
    by simp only [← linear_map.det_comp, hg, monoid_hom.map_one],
  exact is_unit_of_mul_eq_one _ _ this,
end

/-- If a linear map has determinant different from `1`, then the space is finite-dimensional. -/

/-- If the determinant of a map vanishes, then the map is not onto. -/
lemma range_lt_top_of_det_eq_zero {𝕜 : Type*} [field 𝕜] [module 𝕜 M]
  {f : M →ₗ[𝕜] M} (hf : f.det = 0) : f.range < ⊤ :=
begin
  haveI : finite_dimensional 𝕜 M, by simp [f.finite_dimensional_of_det_ne_one, hf],
  contrapose hf,
  simp only [lt_top_iff_ne_top, not_not, ← is_unit_iff_range_eq_top] at hf,
  exact is_unit_iff_ne_zero.1 (f.is_unit_det hf)
end

/-- If the determinant of a map vanishes, then the map is not injective. -/
lemma bot_lt_ker_of_det_eq_zero {𝕜 : Type*} [field 𝕜] [module 𝕜 M]
  {f : M →ₗ[𝕜] M} (hf : f.det = 0) : ⊥ < f.ker :=
begin
  haveI : finite_dimensional 𝕜 M, by simp [f.finite_dimensional_of_det_ne_one, hf],
  contrapose hf,
  simp only [bot_lt_iff_ne_bot, not_not, ← is_unit_iff_ker_eq_bot] at hf,
  exact is_unit_iff_ne_zero.1 (f.is_unit_det hf)
end

end linear_map

namespace linear_equiv

/-- On a `linear_equiv`, the domain of `linear_map.det` can be promoted to `Rˣ`. -/
protected def det : (M ≃ₗ[R] M) →* Rˣ :=
(units.map (linear_map.det : (M →ₗ[R] M) →* R)).comp
  (linear_map.general_linear_group.general_linear_equiv R M).symm.to_monoid_hom

@[simp] lemma coe_det (f : M ≃ₗ[R] M) : ↑f.det = linear_map.det (f : M →ₗ[R] M) := rfl
@[simp] lemma coe_inv_det (f : M ≃ₗ[R] M) : ↑(f.det⁻¹) = linear_map.det (f.symm : M →ₗ[R] M) := rfl

@[simp] lemma det_refl : (linear_equiv.refl R M).det = 1 := units.ext $ linear_map.det_id

@[simp] lemma det_trans (f g : M ≃ₗ[R] M) : (f.trans g).det = g.det * f.det := map_mul _ g f

@[simp] lemma det_symm (f : M ≃ₗ[R] M) : f.symm.det = f.det⁻¹ := map_inv _ f

/-- Conjugating a linear equiv by a linear equiv does not change its determinant. -/
@[simp] lemma det_conj (f : M ≃ₗ[R] M) (e : M ≃ₗ[R] M') :
  ((e.symm.trans f).trans e).det = f.det :=
by rw [←units.eq_iff, coe_det, coe_det, ←comp_coe, ←comp_coe, linear_map.det_conj]

end linear_equiv

/-- The determinants of a `linear_equiv` and its inverse multiply to 1. -/
@[simp] lemma linear_equiv.det_mul_det_symm {A : Type*} [comm_ring A] [module A M]
  (f : M ≃ₗ[A] M) : (f : M →ₗ[A] M).det * (f.symm : M →ₗ[A] M).det = 1 :=
by simp [←linear_map.det_comp]

/-- The determinants of a `linear_equiv` and its inverse multiply to 1. -/
@[simp] lemma linear_equiv.det_symm_mul_det {A : Type*} [comm_ring A] [module A M]
  (f : M ≃ₗ[A] M) : (f.symm : M →ₗ[A] M).det * (f : M →ₗ[A] M).det = 1 :=
by simp [←linear_map.det_comp]

-- Cannot be stated using `linear_map.det` because `f` is not an endomorphism.
lemma linear_equiv.is_unit_det (f : M ≃ₗ[R] M') (v : basis ι R M) (v' : basis ι R M') :
  is_unit (linear_map.to_matrix v v' f).det :=
begin
  apply is_unit_det_of_left_inverse,
  simpa using (linear_map.to_matrix_comp v v' v f.symm f).symm
end

/-- Specialization of `linear_equiv.is_unit_det` -/
lemma linear_equiv.is_unit_det' {A : Type*} [comm_ring A] [module A M]
  (f : M ≃ₗ[A] M) : is_unit (linear_map.det (f : M →ₗ[A] M)) :=
is_unit_of_mul_eq_one _ _ f.det_mul_det_symm

/-- The determinant of `f.symm` is the inverse of that of `f` when `f` is a linear equiv. -/
lemma linear_equiv.det_coe_symm {𝕜 : Type*} [field 𝕜] [module 𝕜 M]
  (f : M ≃ₗ[𝕜] M) : (f.symm : M →ₗ[𝕜] M).det = (f : M →ₗ[𝕜] M).det ⁻¹ :=
by field_simp [is_unit.ne_zero f.is_unit_det']

/-- Builds a linear equivalence from a linear map whose determinant in some bases is a unit. -/
@[simps]
def linear_equiv.of_is_unit_det {f : M →ₗ[R] M'} {v : basis ι R M} {v' : basis ι R M'}
  (h : is_unit (linear_map.to_matrix v v' f).det) : M ≃ₗ[R] M' :=
{ to_fun := f,
  map_add' := f.map_add,
  map_smul' := f.map_smul,
  inv_fun := to_lin v' v (to_matrix v v' f)⁻¹,
  left_inv := λ x,
    calc to_lin v' v (to_matrix v v' f)⁻¹ (f x)
        = to_lin v v ((to_matrix v v' f)⁻¹ ⬝ to_matrix v v' f) x :
      by { rw [to_lin_mul v v' v, to_lin_to_matrix, linear_map.comp_apply] }
    ... = x : by simp [h],
  right_inv := λ x,
    calc f (to_lin v' v (to_matrix v v' f)⁻¹ x)
        = to_lin v' v' (to_matrix v v' f ⬝ (to_matrix v v' f)⁻¹) x :
      by { rw [to_lin_mul v' v v', linear_map.comp_apply, to_lin_to_matrix v v'] }
    ... = x : by simp [h] }

@[simp] lemma linear_equiv.coe_of_is_unit_det {f : M →ₗ[R] M'} {v : basis ι R M} {v' : basis ι R M'}
  (h : is_unit (linear_map.to_matrix v v' f).det) :
  (linear_equiv.of_is_unit_det h : M →ₗ[R] M') = f :=
by { ext x, refl }

/-- Builds a linear equivalence from a linear map on a finite-dimensional vector space whose
determinant is nonzero. -/
@[reducible] def linear_map.equiv_of_det_ne_zero
  {𝕜 : Type*} [field 𝕜] {M : Type*} [add_comm_group M] [module 𝕜 M]
  [finite_dimensional 𝕜 M] (f : M →ₗ[𝕜] M) (hf : linear_map.det f ≠ 0) :
  M ≃ₗ[𝕜] M :=
have is_unit (linear_map.to_matrix (finite_dimensional.fin_basis 𝕜 M)
  (finite_dimensional.fin_basis 𝕜 M) f).det :=
    by simp only [linear_map.det_to_matrix, is_unit_iff_ne_zero.2 hf],
linear_equiv.of_is_unit_det this

/-- The determinant of a family of vectors with respect to some basis, as an alternating
multilinear map. -/
def basis.det : alternating_map R M R ι :=
{ to_fun := λ v, det (e.to_matrix v),
  map_add' := begin
    intros v i x y,
    simp only [e.to_matrix_update, linear_equiv.map_add],
    apply det_update_column_add
  end,
  map_smul' := begin
    intros u i c x,
    simp only [e.to_matrix_update, algebra.id.smul_eq_mul, linear_equiv.map_smul],
    apply det_update_column_smul
  end,
  map_eq_zero_of_eq' := begin
    intros v i j h hij,
    rw [←function.update_eq_self i v, h, ←det_transpose, e.to_matrix_update,
        ←update_row_transpose, ←e.to_matrix_transpose_apply],
    apply det_zero_of_row_eq hij,
    rw [update_row_ne hij.symm, update_row_self],
  end }

lemma basis.det_apply (v : ι → M) : e.det v = det (e.to_matrix v) := rfl

lemma basis.det_self : e.det e = 1 :=
by simp [e.det_apply]

/-- `basis.det` is not the zero map. -/
lemma basis.det_ne_zero [nontrivial R] : e.det ≠ 0 :=
λ h, by simpa [h] using e.det_self

lemma is_basis_iff_det {v : ι → M} :
  linear_independent R v ∧ span R (set.range v) = ⊤ ↔ is_unit (e.det v) :=
begin
  split,
  { rintro ⟨hli, hspan⟩,
    set v' := basis.mk hli hspan with v'_eq,
    rw e.det_apply,
    convert linear_equiv.is_unit_det (linear_equiv.refl _ _) v' e using 2,
    ext i j,
    simp },
  { intro h,
    rw [basis.det_apply, basis.to_matrix_eq_to_matrix_constr] at h,
    set v' := basis.map e (linear_equiv.of_is_unit_det h) with v'_def,
    have : ⇑ v' = v,
    { ext i, rw [v'_def, basis.map_apply, linear_equiv.of_is_unit_det_apply, e.constr_basis] },
    rw ← this,
    exact ⟨v'.linear_independent, v'.span_eq⟩ },
end

lemma basis.is_unit_det (e' : basis ι R M) : is_unit (e.det e') :=
(is_basis_iff_det e).mp ⟨e'.linear_independent, e'.span_eq⟩

/-- Any alternating map to `R` where `ι` has the cardinality of a basis equals the determinant
map with respect to that basis, multiplied by the value of that alternating map on that basis. -/
lemma alternating_map.eq_smul_basis_det (f : alternating_map R M R ι) : f = f e • e.det :=
begin
  refine basis.ext_alternating e (λ i h, _),
  let σ : equiv.perm ι := equiv.of_bijective i (fintype.injective_iff_bijective.1 h),
  change f (e ∘ σ) = (f e • e.det) (e ∘ σ),
  simp [alternating_map.map_perm, basis.det_self]
end

@[simp] lemma alternating_map.map_basis_eq_zero_iff (f : alternating_map R M R ι) :
  f e = 0 ↔ f = 0 :=
⟨λ h, by simpa [h] using f.eq_smul_basis_det e, λ h, h.symm ▸ alternating_map.zero_apply _⟩

lemma alternating_map.map_basis_ne_zero_iff (f : alternating_map R M R ι) :
  f e ≠ 0 ↔ f ≠ 0 :=
not_congr $ f.map_basis_eq_zero_iff e

variables {A : Type*} [comm_ring A] [module A M]

@[simp] lemma basis.det_comp (e : basis ι A M) (f : M →ₗ[A] M) (v : ι → M) :
  e.det (f ∘ v) = f.det * e.det v :=
by { rw [basis.det_apply, basis.det_apply, ← f.det_to_matrix e, ← matrix.det_mul,
         e.to_matrix_eq_to_matrix_constr (f ∘ v), e.to_matrix_eq_to_matrix_constr v,
         ← to_matrix_comp, e.constr_comp] }

lemma basis.det_reindex {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (b : basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
  (b.reindex e).det v = b.det (v ∘ e) :=
by rw [basis.det_apply, basis.to_matrix_reindex', det_reindex_alg_equiv, basis.det_apply]

lemma basis.det_reindex_symm {ι' : Type*} [fintype ι'] [decidable_eq ι']
  (b : basis ι R M) (v : ι → M) (e : ι' ≃ ι) :
  (b.reindex e.symm).det (v ∘ e) = b.det v :=
by rw [basis.det_reindex, function.comp.assoc, e.self_comp_symm, function.comp.right_id]

@[simp]
lemma basis.det_map (b : basis ι R M) (f : M ≃ₗ[R] M') (v : ι → M') :
  (b.map f).det v = b.det (f.symm ∘ v) :=
by { rw [basis.det_apply, basis.to_matrix_map, basis.det_apply] }

lemma basis.det_map' (b : basis ι R M) (f : M ≃ₗ[R] M') :
  (b.map f).det = b.det.comp_linear_map f.symm :=
alternating_map.ext $ b.det_map f

@[simp] lemma pi.basis_fun_det : (pi.basis_fun R ι).det = matrix.det_row_alternating :=
begin
  ext M,
  rw [basis.det_apply, basis.coe_pi_basis_fun.to_matrix_eq_transpose, det_transpose],
end

/-- If we fix a background basis `e`, then for any other basis `v`, we can characterise the
coordinates provided by `v` in terms of determinants relative to `e`. -/
lemma basis.det_smul_mk_coord_eq_det_update {v : ι → M}
  (hli : linear_independent R v) (hsp : span R (range v) = ⊤) (i : ι) :
  (e.det v) • (basis.mk hli hsp).coord i = e.det.to_multilinear_map.to_linear_map v i :=
begin
  apply (basis.mk hli hsp).ext,
  intros k,
  rcases eq_or_ne k i with rfl | hik;
  simp only [algebra.id.smul_eq_mul, basis.coe_mk, linear_map.smul_apply, linear_map.coe_mk,
    multilinear_map.to_linear_map_apply],
  { rw [basis.mk_coord_apply_eq, mul_one, update_eq_self], congr, },
  { rw [basis.mk_coord_apply_ne hik, mul_zero, eq_comm],
    exact e.det.map_eq_zero_of_eq _ (by simp [hik, function.update_apply]) hik, },
end

/-- The determinant of a basis constructed by `units_smul` is the product of the given units. -/
@[simp] lemma basis.det_units_smul (w : ι → Rˣ) : e.det (e.units_smul w) = ∏ i, w i :=
by simp [basis.det_apply]

/-- The determinant of a basis constructed by `is_unit_smul` is the product of the given units. -/
@[simp] lemma basis.det_is_unit_smul {w : ι → R} (hw : ∀ i, is_unit (w i)) :
  e.det (e.is_unit_smul hw) = ∏ i, w i :=
e.det_units_smul _


import o_minimal.definable

-- Definability of algebraic operations on definable types.

namespace o_minimal

variables {R : Type*} (S : struc R)
variables {X : Type*} [has_coordinates R X] [is_definable S X]
variables {Y : Type*} [has_coordinates R Y] [is_definable S Y]

variables (X)

class is_definable_add [has_add X] : Prop :=
(definable_add : def_fun S (λ p : X × X, p.1 + p.2))

@[to_additive]
class is_definable_mul [has_mul X] : Prop :=
(definable_mul : def_fun S (λ p : X × X, p.1 * p.2))

variables {X S}

section has_mul

variables [has_mul X] [is_definable_mul S X]

@[to_additive]
lemma definable_mul : def_fun S (λ p : X × X, p.1 * p.2) :=
is_definable_mul.definable_mul

@[to_additive]
lemma definable.mul {f : Y → X} (hf : def_fun S f) {g : Y → X} (hg : def_fun S g) :
  def_fun S (λ y, f y * g y) :=
definable_mul.comp (hf.prod' hg)

end has_mul

section monoid

variables [monoid X] [is_definable_mul S X]

@[to_additive]
lemma definable_one : def_val S (1 : X) :=
begin
  suffices : {(1 : X)} = {x | ∀ y, x * y = y},
  { unfold def_val,
    rw this,
    refine def_set.forall _,
    apply_instance,             -- TODO: Huh?
    exact def_set_eq definable_mul def_fun.snd },
  ext x,
  split; intro h,
  { cases h,
    intro y,
    apply one_mul },
  { simpa using h 1 }
end

end monoid

-- TODO: theorem: in a group OR group_with_zero,
-- the inverse is definable if multiplication is.

end o_minimal


example (P Q F : Type) : (P → Q) → ((Q → F) → (P → F)) :=
begin
intros g f p,
exact f(g(p)),
end


/-
Copyright (c) 2015 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Squareovers
-/

import .square

universe u
hott_theory

namespace hott
open eq hott.equiv hott.is_equiv hott.sigma

namespace eq

  -- we give the argument B explicitly, because Lean would find (λa, B a) by itself, which
  -- makes the type uglier (of course the two terms are definitionally equal)
  inductive squareover {A : Type _} (B : A → Type _) {a₀₀ : A} {b₀₀ : B a₀₀} :
    Π{a₂₀ a₀₂ a₂₂ : A}
     {p₁₀ : a₀₀ = a₂₀} {p₁₂ : a₀₂ = a₂₂} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂}
     (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁)
     {b₂₀ : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂}
     (q₁₀ : b₀₀ =[p₁₀; B] b₂₀) (q₁₂ : b₀₂ =[p₁₂; B] b₂₂)
     (q₀₁ : b₀₀ =[p₀₁; B] b₀₂) (q₂₁ : b₂₀ =[p₂₁; B] b₂₂),
     Type _
  | idsquareo : squareover ids idpo idpo idpo idpo

  variables {A : Type _} {A' : Type _} {B : A → Type _}
            {a a' a'' a₀₀ a₂₀ a₄₀ a₀₂ a₂₂ a₂₄ a₀₄ a₄₂ a₄₄ : A}
            /-a₀₀-/ {p₁₀ : a₀₀ = a₂₀} /-a₂₀-/ {p₃₀ : a₂₀ = a₄₀} /-a₄₀-/
       {p₀₁ : a₀₀ = a₀₂} /-s₁₁-/ {p₂₁ : a₂₀ = a₂₂} /-s₃₁-/ {p₄₁ : a₄₀ = a₄₂}
            /-a₀₂-/ {p₁₂ : a₀₂ = a₂₂} /-a₂₂-/ {p₃₂ : a₂₂ = a₄₂} /-a₄₂-/
       {p₀₃ : a₀₂ = a₀₄} /-s₁₃-/ {p₂₃ : a₂₂ = a₂₄} /-s₃₃-/ {p₄₃ : a₄₂ = a₄₄}
            /-a₀₄-/ {p₁₄ : a₀₄ = a₂₄} /-a₂₄-/ {p₃₄ : a₂₄ = a₄₄} /-a₄₄-/
            {s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁} {s₃₁ : square p₃₀ p₃₂ p₂₁ p₄₁}
            {s₁₃ : square p₁₂ p₁₄ p₀₃ p₂₃} {s₃₃ : square p₃₂ p₃₄ p₂₃ p₄₃}

            {b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₄₀ : B a₄₀}
            {b₀₂ : B a₀₂} {b₂₂ : B a₂₂} {b₄₂ : B a₄₂}
            {b₀₄ : B a₀₄} {b₂₄ : B a₂₄} {b₄₄ : B a₄₄}
            /-b₀₀-/ {q₁₀ : b₀₀ =[p₁₀] b₂₀} /-b₂₀-/ {q₃₀ : b₂₀ =[p₃₀] b₄₀} /-b₄₀-/
   {q₀₁ : b₀₀ =[p₀₁] b₀₂} /-t₁₁-/ {q₂₁ : b₂₀ =[p₂₁] b₂₂} /-t₃₁-/ {q₄₁ : b₄₀ =[p₄₁] b₄₂}
            /-b₀₂-/ {q₁₂ : b₀₂ =[p₁₂] b₂₂} /-b₂₂-/ {q₃₂ : b₂₂ =[p₃₂] b₄₂} /-b₄₂-/
   {q₀₃ : b₀₂ =[p₀₃] b₀₄} /-t₁₃-/ {q₂₃ : b₂₂ =[p₂₃] b₂₄} /-t₃₃-/ {q₄₃ : b₄₂ =[p₄₃] b₄₄}
            /-b₀₄-/ {q₁₄ : b₀₄ =[p₁₄] b₂₄} /-b₂₄-/ {q₃₄ : b₂₄ =[p₃₄] b₄₄} /-b₄₄-/

  @[hott] def squareo := @squareover A B a₀₀
  @[hott, reducible] def idsquareo (b₀₀ : B a₀₀) := @squareover.idsquareo A B a₀₀ b₀₀
  @[hott, reducible] def idso                    := @squareover.idsquareo A B a₀₀ b₀₀

  @[hott] def apds (f : Πa, B a) (s : square p₁₀ p₁₂ p₀₁ p₂₁)
    : squareover B s (apd f p₁₀) (apd f p₁₂) (apd f p₀₁) (apd f p₂₁) :=
  by induction s; constructor

  @[hott] def vrflo : squareover B vrfl q₁₀ q₁₀ idpo idpo :=
  by induction q₁₀; exact idso

  @[hott] def hrflo : squareover B hrfl idpo idpo q₁₀ q₁₀ :=
  by induction q₁₀; exact idso

  @[hott] def vdeg_squareover {p₁₀'} {s : p₁₀ = p₁₀'} {q₁₀' : b₀₀ =[p₁₀'] b₂₀}
    (r : change_path s q₁₀ = q₁₀')
    : squareover B (vdeg_square s) q₁₀ q₁₀' idpo idpo :=
  by induction s; induction r; exact vrflo

  @[hott] def hdeg_squareover {p₀₁'} {s : p₀₁ = p₀₁'} {q₀₁' : b₀₀ =[p₀₁'] b₀₂}
    (r : change_path s q₀₁ = q₀₁')
    : squareover B (hdeg_square s) idpo idpo q₀₁ q₀₁' :=
  by induction s; induction r; exact hrflo

  @[hott] def hconcato
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (t₃₁ : squareover B s₃₁ q₃₀ q₃₂ q₂₁ q₄₁)
    : squareover B (hconcat s₁₁ s₃₁) (q₁₀ ⬝o q₃₀) (q₁₂ ⬝o q₃₂) q₀₁ q₄₁ :=
  by induction t₃₁; exact t₁₁

  @[hott] def vconcato
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (t₁₃ : squareover B s₁₃ q₁₂ q₁₄ q₀₃ q₂₃)
    : squareover B (vconcat s₁₁ s₁₃) q₁₀ q₁₄ (q₀₁ ⬝o q₀₃) (q₂₁ ⬝o q₂₃) :=
  by induction t₁₃; exact t₁₁

  @[hott] def hinverseo (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B (hinverse s₁₁) q₁₀⁻¹ᵒ q₁₂⁻¹ᵒ q₂₁ q₀₁ :=
  by induction t₁₁; constructor

  @[hott] def vinverseo (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B (vinverse s₁₁) q₁₂ q₁₀ q₀₁⁻¹ᵒ q₂₁⁻¹ᵒ :=
  by induction t₁₁; constructor

  @[hott] def eq_vconcato {q : b₀₀ =[p₁₀] b₂₀}
    (r : q = q₁₀) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) : squareover B s₁₁ q q₁₂ q₀₁ q₂₁ :=
  by induction r; exact t₁₁

  @[hott] def vconcato_eq {q : b₀₂ =[p₁₂] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : q₁₂ = q) : squareover B s₁₁ q₁₀ q q₀₁ q₂₁ :=
  by induction r; exact t₁₁

  @[hott] def eq_hconcato {q : b₀₀ =[p₀₁] b₀₂}
    (r : q = q₀₁) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) : squareover B s₁₁ q₁₀ q₁₂ q q₂₁ :=
  by induction r; exact t₁₁

  @[hott] def hconcato_eq {q : b₂₀ =[p₂₁] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : q₂₁ = q) : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q :=
  by induction r; exact t₁₁

  @[hott] def pathover_vconcato {p : a₀₀ = a₂₀} {sp : p = p₁₀} {q : b₀₀ =[p] b₂₀}
    (r : change_path sp q = q₁₀) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B (sp ⬝pv s₁₁) q q₁₂ q₀₁ q₂₁ :=
  by induction sp; induction r; exact t₁₁

  @[hott] def vconcato_pathover {p : a₀₂ = a₂₂} {sp : p₁₂ = p} {q : b₀₂ =[p] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₁₂ = q)
    : squareover B (s₁₁ ⬝vp sp) q₁₀ q q₀₁ q₂₁ :=
  by induction sp; induction r; exact t₁₁

  @[hott] def pathover_hconcato {p : a₀₀ = a₀₂} {sp : p = p₀₁} {q : b₀₀ =[p] b₀₂}
    (r : change_path sp q = q₀₁) (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
    squareover B (sp ⬝ph s₁₁) q₁₀ q₁₂ q q₂₁ :=
  by induction sp; induction r; exact t₁₁

  @[hott] def hconcato_pathover {p : a₂₀ = a₂₂} {sp : p₂₁ = p} {q : b₂₀ =[p] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) (r : change_path sp q₂₁ = q) :
    squareover B (s₁₁ ⬝hp sp) q₁₀ q₁₂ q₀₁ q :=
  by induction sp; induction r; exact t₁₁

  infix ` ⬝ho `:69 := hconcato --type using \tr
  infix ` ⬝vo `:70 := vconcato --type using \tr
  infix ` ⬝hop `:72 := hconcato_eq --type using \tr
  infix ` ⬝vop `:74 := vconcato_eq --type using \tr
  infix ` ⬝pho `:71 := eq_hconcato --type using \tr
  infix ` ⬝pvo `:73 := eq_vconcato --type using \tr

  @[hott] def square_of_squareover (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
    square (con_tr p₁₀ p₂₁ b₀₀ ⬝ ap (λa : B a₂₀, p₂₁ ▸ a) (tr_eq_of_pathover q₁₀))
           (tr_eq_of_pathover q₁₂)
           (transport2 _ (eq_of_square s₁₁) b₀₀ ⬝ con_tr _ _ _ ⬝ ap (λa : B a₀₂, p₁₂ ▸ a) (tr_eq_of_pathover q₀₁))
           (tr_eq_of_pathover q₂₁) :=
  by induction t₁₁; constructor

  variable (B)
  @[hott] def square_of_squareover_ids {b₀₀ b₀₂ b₂₀ b₂₂ : B a}
    {t : b₀₀ = b₂₀} {b : b₀₂ = b₂₂} {l : b₀₀ = b₀₂} {r : b₂₀ = b₂₂}
    (so : squareover B ids (pathover_idp_of_eq B t)
                           (pathover_idp_of_eq B b)
                           (pathover_idp_of_eq B l)
                           (pathover_idp_of_eq B r)) : square t b l r :=
  begin
    let H := square_of_squareover so, hsimp at H,
    exact whisker_square (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _)
                         (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _)
                         (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _)
                         (to_right_inv (pathover_equiv_tr_eq (refl a) _ _) _) H
  end

  @[hott] def squareover_ids_of_square {b₀₀ b₀₂ b₂₀ b₂₂ : B a}
    {t : b₀₀ = b₂₀} {b : b₀₂ = b₂₂} {l : b₀₀ = b₀₂} {r : b₂₀ = b₂₂} (q : square t b l r)
    : squareover B ids (pathover_idp_of_eq B t)
                       (pathover_idp_of_eq B b)
                       (pathover_idp_of_eq B l)
                       (pathover_idp_of_eq B r) :=
  by induction q; constructor

  -- relating pathovers to squareovers
  variable {B}
  @[hott] def pathover_of_squareover' (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : q₁₀ ⬝o q₂₁ =[eq_of_square s₁₁; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂ :=
  by induction t₁₁; constructor

  @[hott] def pathover_of_squareover {s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂}
    (t₁₁ : squareover B (square_of_eq s) q₁₀ q₁₂ q₀₁ q₂₁)
    : q₁₀ ⬝o q₂₁ =[s; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂ :=
  begin
    revert s t₁₁,
    refine equiv_rect' (square_equiv_eq p₁₀ p₁₂ p₀₁ p₂₁)⁻¹ᵉ
      (λa b, squareover B b q₁₀ q₁₂ q₀₁ q₂₁ → q₁₀ ⬝o q₂₁ =[a; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂) _,
    intro s, exact pathover_of_squareover'
  end

  @[hott] def squareover_of_pathover {s : p₁₀ ⬝ p₂₁ = p₀₁ ⬝ p₁₂}
    (r : q₁₀ ⬝o q₂₁ =[s; λp, b₀₀ =[p] b₂₂] q₀₁ ⬝o q₁₂) :
    squareover B (square_of_eq s) q₁₀ q₁₂ q₀₁ q₂₁ :=
  by induction q₁₂; hsimp at r; induction r; induction q₁₀; induction q₂₁; constructor

  @[hott] def pathover_top_of_squareover (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : q₁₀ =[eq_top_of_square s₁₁; λp, b₀₀ =[p] b₂₀] q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ :=
  by induction t₁₁; constructor

  @[hott] def squareover_of_pathover_top {s : p₁₀ = p₀₁ ⬝ p₁₂ ⬝ p₂₁⁻¹}
  (r : q₁₀ =[s; λp, b₀₀ =[p] b₂₀] q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ)
    : squareover B (square_of_eq_top s) q₁₀ q₁₂ q₀₁ q₂₁ :=
  by induction q₂₁; induction q₁₂; dsimp at r; induction r; induction q₁₀; constructor

  @[hott] def pathover_of_hdeg_squareover {p₀₁' : a₀₀ = a₀₂} {r : p₀₁ = p₀₁'} {q₀₁' : b₀₀ =[p₀₁'] b₀₂}
    (t : squareover B (hdeg_square r) idpo idpo q₀₁ q₀₁') : q₀₁ =[r; λp, b₀₀ =[p] b₀₂] q₀₁' :=
  by induction r; induction q₀₁'; exact (pathover_of_squareover' t)⁻¹ᵒ

  @[hott] def pathover_of_vdeg_squareover {p₁₀' : a₀₀ = a₂₀} {r : p₁₀ = p₁₀'} {q₁₀' : b₀₀ =[p₁₀'] b₂₀}
    (t : squareover B (vdeg_square r) q₁₀ q₁₀' idpo idpo) : q₁₀ =[r; λp, b₀₀ =[p] b₂₀] q₁₀' :=
  by induction r; induction q₁₀'; exact pathover_of_squareover' t

  @[hott] def squareover_of_eq_top (r : change_path (eq_top_of_square s₁₁) q₁₀ = q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ)
    : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁ :=
  begin
    induction s₁₁, revert q₁₂ q₁₀ r,
    refine idp_rec_on q₂₁ _, clear q₂₁,
    intro q₁₂,
    refine idp_rec_on q₁₂ _, clear q₁₂,
    dsimp, intros,
    induction r, eapply idp_rec_on q₁₀,
    constructor
  end

  @[hott] def eq_top_of_squareover (r : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : change_path (eq_top_of_square s₁₁) q₁₀ = q₀₁ ⬝o q₁₂ ⬝o q₂₁⁻¹ᵒ :=
  by induction r; reflexivity

  @[hott] def change_square {s₁₁'} (p : s₁₁ = s₁₁') (r : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁)
    : squareover B s₁₁' q₁₀ q₁₂ q₀₁ q₂₁ :=
  by induction p; exact r -- in Lean 2 defined using transport

  @[hott] lemma eq_of_vdeg_squareover {q₁₀' : b₀₀ =[p₁₀] b₂₀}
    (p : squareover B vrfl q₁₀ q₁₀' idpo idpo) : q₁₀ = q₁₀' :=
  begin
    let H := square_of_squareover p,
    induction p₁₀,
    hsimp at H,
    let H' := eq_of_vdeg_square H,
    exact eq_of_fn_eq_fn (pathover_equiv_tr_eq _ _ _) H'
  end

  /- A version of eq_pathover where the type of the equality also varies -/
  @[hott] lemma eq_pathover_dep {f g : Πa, B a} {p : a = a'} {q : f a = g a}
    {r : f a' = g a'} (s : squareover B hrfl (pathover_idp_of_eq B q) (pathover_idp_of_eq B r)
                                             (apd f p) (apd g p)) : q =[p; λx, f x = g x] r :=
  begin
    induction p, apply pathover_idp_of_eq, apply eq_of_vdeg_square, exact square_of_squareover_ids _ s
  end

  /- charcaterization of pathovers in pathovers -/
  -- in this version the fibration (B) of the pathover does not depend on the variable (a)
   @[hott] lemma pathover_pathover {a' a₂' : A'} {p : a' = a₂'} {f g : A' → A}
    {b : Πa, B (f a)} {b₂ : Πa, B (g a)} {q : Π(a' : A'), f a' = g a'}
    (r : b a' =[q a'; B] b₂ a')
    (r₂ : b a₂' =[q a₂'; B] b₂ a₂')
    (s : squareover B (natural_square q p) r r₂
                      (pathover_ap B f (apd b p)) (pathover_ap B g (apd b₂ p))) :
    r =[p; λa, b a =[q a; B] b₂ a] r₂ :=
  begin
    induction p, apply pathover_idp_of_eq, apply eq_of_vdeg_squareover, exact s
  end

  @[hott] def squareover_change_path_left {p₀₁' : a₀₀ = a₀₂} (r : p₀₁' = p₀₁)
    {q₀₁ : b₀₀ =[p₀₁'] b₀₂} (t : squareover B (r ⬝ph s₁₁) q₁₀ q₁₂ q₀₁ q₂₁)
  : squareover B s₁₁ q₁₀ q₁₂ (change_path r q₀₁) q₂₁ :=
  by induction r; exact t

  @[hott] def squareover_change_path_right {p₂₁' : a₂₀ = a₂₂} (r : p₂₁' = p₂₁)
    {q₂₁ : b₂₀ =[p₂₁'] b₂₂} (t : squareover B (s₁₁ ⬝hp r⁻¹) q₁₀ q₁₂ q₀₁ q₂₁)
  : squareover B s₁₁ q₁₀ q₁₂ q₀₁ (change_path r q₂₁) :=
  by induction r; exact t

  @[hott] def squareover_change_path_right' {p₂₁' : a₂₀ = a₂₂} (r : p₂₁ = p₂₁')
    {q₂₁ : b₂₀ =[p₂₁'] b₂₂} (t : squareover B (s₁₁ ⬝hp r) q₁₀ q₁₂ q₀₁ q₂₁)
  : squareover B s₁₁ q₁₀ q₁₂ q₀₁ (change_path r⁻¹ q₂₁) :=
  by induction r; exact t

  /- You can construct a square in a sigma-type by giving a squareover -/
  @[hott] def square_dpair_eq_dpair {a₀₀ a₂₀ a₀₂ a₂₂ : A}
    {p₁₀ : a₀₀ = a₂₀} {p₀₁ : a₀₀ = a₀₂} {p₂₁ : a₂₀ = a₂₂} {p₁₂ : a₀₂ = a₂₂}
    (s₁₁ : square p₁₀ p₁₂ p₀₁ p₂₁) {b₀₀ : B a₀₀} {b₂₀ : B a₂₀} {b₀₂ : B a₀₂} {b₂₂ : B a₂₂}
    {q₁₀ : b₀₀ =[p₁₀] b₂₀} {q₀₁ : b₀₀ =[p₀₁] b₀₂} {q₂₁ : b₂₀ =[p₂₁] b₂₂} {q₁₂ : b₀₂ =[p₁₂] b₂₂}
    (t₁₁ : squareover B s₁₁ q₁₀ q₁₂ q₀₁ q₂₁) :
    square (sigma.dpair_eq_dpair p₁₀ q₁₀) (dpair_eq_dpair p₁₂ q₁₂)
           (dpair_eq_dpair p₀₁ q₀₁) (dpair_eq_dpair p₂₁ q₂₁) :=
  by induction t₁₁; constructor

  @[hott] lemma sigma_square {v₀₀ v₂₀ v₀₂ v₂₂ : Σa, B a}
    {p₁₀ : v₀₀ = v₂₀} {p₀₁ : v₀₀ = v₀₂} {p₂₁ : v₂₀ = v₂₂} {p₁₂ : v₀₂ = v₂₂}
    (s₁₁ : square p₁₀..1 p₁₂..1 p₀₁..1 p₂₁..1)
    (t₁₁ : squareover B s₁₁ p₁₀..2 p₁₂..2 p₀₁..2 p₂₁..2) : square p₁₀ p₁₂ p₀₁ p₂₁ :=
  begin
    induction v₀₀, induction v₂₀, induction v₀₂, induction v₂₂,
    rwr [(sigma_eq_eta p₁₀)⁻¹, (sigma_eq_eta p₀₁)⁻¹, (sigma_eq_eta p₁₂)⁻¹, (sigma_eq_eta p₂₁)⁻¹],
    exact square_dpair_eq_dpair s₁₁ t₁₁
  end

end eq
end hott


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