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

import data.multiset.sort
import data.pnat.basic
import data.rat.order

import tactic.norm_num
import tactic.field_simp
import tactic.interval_cases

/-!
# The inequality `p⁻¹ + q⁻¹ + r⁻¹ > 1`

In this file we classify solutions to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`, for positive natural numbers `p`, `q`, and `r`.

The solutions are exactly of the form.
* `A' q r := {1,q,r}`
* `D' r := {2,2,r}`
* `E6 := {2,3,3}`, or `E7 := {2,3,4}`, or `E8 := {2,3,5}`

This inequality shows up in Lie theory,
in the classification of Dynkin diagrams, root systems, and semisimple Lie algebras.

## Main declarations

* `pqr.A' q r`, the multiset `{1,q,r}`
* `pqr.D' r`, the multiset `{2,2,r}`
* `pqr.E6`, the multiset `{2,3,3}`
* `pqr.E7`, the multiset `{2,3,4}`
* `pqr.E8`, the multiset `{2,3,5}`
* `pqr.classification`, the classification of solutions to `p⁻¹ + q⁻¹ + r⁻¹ > 1`

-/

namespace ADE_inequality

open multiset

/-- `A' q r := {1,q,r}` is a `multiset ℕ+`
that is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`. -/
def A' (q r : ℕ+) : multiset ℕ+ := {1,q,r}

/-- `A r := {1,1,r}` is a `multiset ℕ+`
that is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`.

These solutions are related to the Dynkin diagrams $A_r$. -/
def A  (r   : ℕ+) : multiset ℕ+ := A' 1 r

/-- `D' r := {2,2,r}` is a `multiset ℕ+`
that is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`.

These solutions are related to the Dynkin diagrams $D_{r+2}$. -/
def D' (r   : ℕ+) : multiset ℕ+ := {2,2,r}

/-- `E' r := {2,3,r}` is a `multiset ℕ+`.
For `r ∈ {3,4,5}` is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`.

These solutions are related to the Dynkin diagrams $E_{r+3}$. -/
def E' (r   : ℕ+) : multiset ℕ+ := {2,3,r}

/-- `E6 := {2,3,3}` is a `multiset ℕ+`
that is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`.

This solution is related to the Dynkin diagrams $E_6$. -/
def E6            : multiset ℕ+ := E' 3

/-- `E7 := {2,3,4}` is a `multiset ℕ+`
that is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`.

This solution is related to the Dynkin diagrams $E_7$. -/
def E7            : multiset ℕ+ := E' 4

/-- `E8 := {2,3,5}` is a `multiset ℕ+`
that is a solution to the inequality
`(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1`.

This solution is related to the Dynkin diagrams $E_8$. -/
def E8            : multiset ℕ+ := E' 5

/-- `sum_inv pqr` for a `pqr : multiset ℕ+` is the sum of the inverses
of the elements of `pqr`, as rational number.

The intended argument is a multiset `{p,q,r}` of cardinality `3`. -/
def sum_inv (pqr : multiset ℕ+) : ℚ :=
multiset.sum $ pqr.map $ λ x, x⁻¹

lemma sum_inv_pqr (p q r : ℕ+) : sum_inv {p,q,r} = p⁻¹ + q⁻¹ + r⁻¹ :=
by simp only [sum_inv, map_congr, coe_coe, add_zero, insert_eq_cons, add_assoc,
    singleton_eq_singleton, map_cons, sum_cons, map_zero, sum_zero]

/-- A multiset `pqr` of positive natural numbers is `admissible`
if it is equal to `A' q r`, or `D' r`, or one of `E6`, `E7`, or `E8`. -/
def admissible (pqr : multiset ℕ+) : Prop :=
  (∃ q r, A' q r = pqr) ∨ (∃ r, D' r = pqr) ∨ (E' 3 = pqr ∨ E' 4 = pqr ∨ E' 5 = pqr)

lemma admissible_A' (q r : ℕ+) : admissible (A' q r) := or.inl ⟨q, r, rfl⟩
lemma admissible_D' (n : ℕ+) : admissible (D' n) := or.inr $ or.inl ⟨n, rfl⟩

lemma admissible_E'3 : admissible (E' 3) := or.inr $ or.inr $ or.inl rfl
lemma admissible_E'4 : admissible (E' 4) := or.inr $ or.inr $ or.inr $ or.inl rfl
lemma admissible_E'5 : admissible (E' 5) := or.inr $ or.inr $ or.inr $ or.inr rfl

lemma admissible.one_lt_sum_inv {pqr : multiset ℕ+} :
  admissible pqr → 1 < sum_inv pqr :=
begin
  rw [admissible],
  rintro (⟨p', q', H⟩|⟨n, H⟩|H|H|H),
  { rw [← H, A', sum_inv_pqr, add_assoc],
    simp only [lt_add_iff_pos_right, pnat.one_coe, inv_one, nat.cast_one, coe_coe],
    apply add_pos; simp only [pnat.pos, nat.cast_pos, inv_pos] },
  { rw [← H, D', sum_inv_pqr],
    simp only [lt_add_iff_pos_right, pnat.one_coe, inv_one, nat.cast_one,
      coe_coe, pnat.coe_bit0, nat.cast_bit0],
    norm_num },
  all_goals { rw [← H, E', sum_inv_pqr], norm_num }
end

lemma lt_three {p q r : ℕ+} (hpq : p ≤ q) (hqr : q ≤ r) (H : 1 < sum_inv {p, q, r}) :
  p < 3 :=
begin
  have h3 : (0:ℚ) < 3, by norm_num,
  contrapose! H, rw sum_inv_pqr,
  have h3q := H.trans hpq,
  have h3r := h3q.trans hqr,
  calc (p⁻¹ + q⁻¹ + r⁻¹ : ℚ) ≤ 3⁻¹ + 3⁻¹ + 3⁻¹ : add_le_add (add_le_add _ _) _
  ... = 1 : by norm_num,
  all_goals { rw inv_le_inv _ h3; [assumption_mod_cast, norm_num] }
end

lemma lt_four {q r : ℕ+} (hqr : q ≤ r) (H : 1 < sum_inv {2, q, r}) :
  q < 4 :=
begin
  have h4 : (0:ℚ) < 4, by norm_num,
  contrapose! H, rw sum_inv_pqr,
  have h4r := H.trans hqr,
  simp only [pnat.coe_bit0, nat.cast_bit0, pnat.one_coe, nat.cast_one, coe_coe],
  calc (2⁻¹ + q⁻¹ + r⁻¹ : ℚ) ≤ 2⁻¹ + 4⁻¹ + 4⁻¹ : add_le_add (add_le_add le_rfl _) _
  ... = 1 : by norm_num,
  all_goals { rw inv_le_inv _ h4; [assumption_mod_cast, norm_num] }
end

lemma lt_six {r : ℕ+} (H : 1 < sum_inv {2, 3, r}) :
  r < 6 :=
begin
  have h6 : (0:ℚ) < 6, by norm_num,
  contrapose! H, rw sum_inv_pqr,
  simp only [pnat.coe_bit0, nat.cast_bit0, pnat.one_coe, nat.cast_bit1, nat.cast_one,
    pnat.coe_bit1, coe_coe],
  calc (2⁻¹ + 3⁻¹ + r⁻¹ : ℚ) ≤ 2⁻¹ + 3⁻¹ + 6⁻¹ : add_le_add (add_le_add le_rfl le_rfl) _
  ... = 1 : by norm_num,
  rw inv_le_inv _ h6; [assumption_mod_cast, norm_num]
end

lemma admissible_of_one_lt_sum_inv_aux' {p q r : ℕ+} (hpq : p ≤ q) (hqr : q ≤ r)
  (H : 1 < sum_inv {p,q,r}) :
  admissible {p,q,r} :=
begin
  have hp3 : p < 3 := lt_three hpq hqr H,
  interval_cases p,
  { exact admissible_A' q r },
  have hq4 : q < 4 := lt_four hqr H,
  interval_cases q,
  { exact admissible_D' r },
  have hr6 : r < 6 := lt_six H,
  interval_cases r,
  { exact admissible_E6 },
  { exact admissible_E7 },
  { exact admissible_E8 }
end

lemma admissible_of_one_lt_sum_inv_aux :
  ∀ {pqr : list ℕ+} (hs : pqr.sorted (≤)) (hl : pqr.length = 3) (H : 1 < sum_inv pqr),
    admissible pqr
| [p,q,r] hs hl H :=
begin
  obtain ⟨⟨hpq, -⟩, hqr⟩ : (p ≤ q ∧ p ≤ r) ∧ q ≤ r,
  simpa using hs,
  exact admissible_of_one_lt_sum_inv_aux' hpq hqr H,
end

lemma admissible_of_one_lt_sum_inv {p q r : ℕ+} (H : 1 < sum_inv {p,q,r}) :
  admissible {p,q,r} :=
begin
  simp only [admissible],
  let S := sort ((≤) : ℕ+ → ℕ+ → Prop) {p,q,r},
  have hS : S.sorted (≤) := sort_sorted _ _,
  have hpqr : ({p,q,r} : multiset ℕ+) = S := (sort_eq has_le.le {p, q, r}).symm,
  simp only [hpqr] at *,
  apply admissible_of_one_lt_sum_inv_aux hS _ H,
  simp only [singleton_eq_singleton, length_sort, insert_eq_cons, card_singleton,
    card_cons, card_zero],
end

/-- A multiset `{p,q,r}` of positive natural numbers
is a solution to `(p⁻¹ + q⁻¹ + r⁻¹ : ℚ) > 1` if and only if
it is `admissible` which means it is one of:

* `A' q r := {1,q,r}`
* `D' r := {2,2,r}`
* `E6 := {2,3,3}`, or `E7 := {2,3,4}`, or `E8 := {2,3,5}`
-/
lemma classification (p q r : ℕ+) :
  1 < sum_inv {p,q,r} ↔ admissible {p,q,r} :=
⟨admissible_of_one_lt_sum_inv, admissible.one_lt_sum_inv⟩

end ADE_inequality


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monoidal.category
import category_theory.adjunction.limits
import category_theory.adjunction.mates

/-!
# Closed monoidal categories

Define (right) closed objects and (right) closed monoidal categories.

## TODO
Some of the theorems proved about cartesian closed categories
should be generalised and moved to this file.
-/
universes v u u₂

namespace category_theory

open category monoidal_category

/-- An object `X` is (right) closed if `(X ⊗ -)` is a left adjoint. -/
-- Note that this class carries a particular choice of right adjoint,
-- (which is only unique up to isomorphism),
-- not merely the existence of such, and
-- so definitional properties of instances may be important.
class closed {C : Type u} [category.{v} C] [monoidal_category.{v} C] (X : C) :=
(is_adj : is_left_adjoint (tensor_left X))

/-- A monoidal category `C` is (right) monoidal closed if every object is (right) closed. -/
class monoidal_closed (C : Type u) [category.{v} C] [monoidal_category.{v} C] :=
(closed' : Π (X : C), closed X)

attribute [instance, priority 100] monoidal_closed.closed'

variables {C : Type u} [category.{v} C] [monoidal_category.{v} C]

/--
If `X` and `Y` are closed then `X ⊗ Y` is.
This isn't an instance because it's not usually how we want to construct internal homs,
we'll usually prove all objects are closed uniformly.
-/
def tensor_closed {X Y : C}
  (hX : closed X) (hY : closed Y) : closed (X ⊗ Y) :=
{ is_adj :=
  begin
    haveI := hX.is_adj,
    haveI := hY.is_adj,
    exact adjunction.left_adjoint_of_nat_iso (monoidal_category.tensor_left_tensor _ _).symm
  end }

/--
The unit object is always closed.
This isn't an instance because most of the time we'll prove closedness for all objects at once,
rather than just for this one.
-/
def unit_closed : closed (𝟙_ C) :=
{ is_adj :=
  { right := 𝟭 C,
    adj := adjunction.mk_of_hom_equiv
    { hom_equiv := λ X _,
      { to_fun := λ a, (left_unitor X).inv ≫ a,
        inv_fun := λ a, (left_unitor X).hom ≫ a,
        left_inv := by tidy,
        right_inv := by tidy },
      hom_equiv_naturality_left_symm' := λ X' X Y f g,
      by { dsimp, rw left_unitor_naturality_assoc } } } }

variables (A B : C) {X X' Y Y' Z : C}

variables [closed A]

/--
This is the internal hom `A ⟶[C] -`.
-/
def ihom : C ⥤ C :=
(@closed.is_adj _ _ _ A _).right

namespace ihom

/-- The adjunction between `A ⊗ -` and `A ⟹ -`. -/
def adjunction : tensor_left A ⊣ ihom A :=
closed.is_adj.adj

/-- The evaluation natural transformation. -/
def ev : ihom A ⋙ tensor_left A ⟶ 𝟭 C :=
(ihom.adjunction A).counit

/-- The coevaluation natural transformation. -/
def coev : 𝟭 C ⟶ tensor_left A ⋙ ihom A :=
(ihom.adjunction A).unit

@[simp] lemma ihom_adjunction_counit : (ihom.adjunction A).counit = ev A := rfl
@[simp] lemma ihom_adjunction_unit : (ihom.adjunction A).unit = coev A := rfl

@[simp, reassoc]
lemma ev_naturality {X Y : C} (f : X ⟶ Y) :
  ((𝟙 A) ⊗ ((ihom A).map f)) ≫ (ev A).app Y = (ev A).app X ≫ f :=
(ev A).naturality f

@[simp, reassoc]
lemma coev_naturality {X Y : C} (f : X ⟶ Y) :
  f ≫ (coev A).app Y = (coev A).app X ≫ (ihom A).map ((𝟙 A) ⊗ f) :=
(coev A).naturality f

notation A ` ⟶[`C`] ` B:10 := (@ihom C _ _ A _).obj B

@[simp, reassoc] lemma ev_coev :
  ((𝟙 A) ⊗ ((coev A).app B)) ≫ (ev A).app (A ⊗ B) = 𝟙 (A ⊗ B) :=
adjunction.left_triangle_components (ihom.adjunction A)

@[simp, reassoc] lemma coev_ev :
  (coev A).app (A ⟶[C] B) ≫ (ihom A).map ((ev A).app B) = 𝟙 (A ⟶[C] B) :=
adjunction.right_triangle_components (ihom.adjunction A)

end ihom

open category_theory.limits

instance : preserves_colimits (tensor_left A) :=
(ihom.adjunction A).left_adjoint_preserves_colimits

variables {A}

-- Wrap these in a namespace so we don't clash with the core versions.
namespace monoidal_closed

/-- Currying in a monoidal closed category. -/
def curry : (A ⊗ Y ⟶ X) → (Y ⟶ (A ⟶[C] X)) :=
(ihom.adjunction A).hom_equiv _ _
/-- Uncurrying in a monoidal closed category. -/
def uncurry : (Y ⟶ (A ⟶[C] X)) → (A ⊗ Y ⟶ X) :=
((ihom.adjunction A).hom_equiv _ _).symm

@[simp] lemma hom_equiv_apply_eq (f : A ⊗ Y ⟶ X) :
  (ihom.adjunction A).hom_equiv _ _ f = curry f := rfl
@[simp] lemma hom_equiv_symm_apply_eq (f : Y ⟶ (A ⟶[C] X)) :
  ((ihom.adjunction A).hom_equiv _ _).symm f = uncurry f := rfl

@[reassoc]
lemma curry_natural_left (f : X ⟶ X') (g : A ⊗ X' ⟶ Y) :
  curry (((𝟙 _) ⊗ f) ≫ g) = f ≫ curry g :=
adjunction.hom_equiv_naturality_left _ _ _

@[reassoc]
lemma curry_natural_right (f : A ⊗ X ⟶ Y) (g : Y ⟶ Y') :
  curry (f ≫ g) = curry f ≫ (ihom _).map g :=
adjunction.hom_equiv_naturality_right _ _ _

@[reassoc]
lemma uncurry_natural_right  (f : X ⟶ (A ⟶[C] Y)) (g : Y ⟶ Y') :
  uncurry (f ≫ (ihom _).map g) = uncurry f ≫ g :=
adjunction.hom_equiv_naturality_right_symm _ _ _

@[reassoc]
lemma uncurry_natural_left  (f : X ⟶ X') (g : X' ⟶ (A ⟶[C] Y)) :
  uncurry (f ≫ g) = ((𝟙 _) ⊗ f) ≫ uncurry g :=
adjunction.hom_equiv_naturality_left_symm _ _ _

@[simp]
lemma uncurry_curry (f : A ⊗ X ⟶ Y) : uncurry (curry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).left_inv f

@[simp]
lemma curry_uncurry (f : X ⟶ (A ⟶[C] Y)) : curry (uncurry f) = f :=
(closed.is_adj.adj.hom_equiv _ _).right_inv f

lemma curry_eq_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ (A ⟶[C] X)) :
  curry f = g ↔ f = uncurry g :=
adjunction.hom_equiv_apply_eq _ f g

lemma eq_curry_iff (f : A ⊗ Y ⟶ X) (g : Y ⟶ (A ⟶[C] X)) :
  g = curry f ↔ uncurry g = f :=
adjunction.eq_hom_equiv_apply _ f g

-- I don't think these two should be simp.
lemma uncurry_eq (g : Y ⟶ (A ⟶[C] X)) : uncurry g = ((𝟙 A) ⊗ g) ≫ (ihom.ev A).app X :=
adjunction.hom_equiv_counit _

lemma curry_eq (g : A ⊗ Y ⟶ X) : curry g = (ihom.coev A).app Y ≫ (ihom A).map g :=
adjunction.hom_equiv_unit _

lemma curry_injective : function.injective (curry : (A ⊗ Y ⟶ X) → (Y ⟶ (A ⟶[C] X))) :=
(closed.is_adj.adj.hom_equiv _ _).injective

lemma uncurry_injective : function.injective (uncurry : (Y ⟶ (A ⟶[C] X)) → (A ⊗ Y ⟶ X)) :=
(closed.is_adj.adj.hom_equiv _ _).symm.injective

variables (A X)

lemma uncurry_id_eq_ev : uncurry (𝟙 (A ⟶[C] X)) = (ihom.ev A).app X :=
by rw [uncurry_eq, tensor_id, id_comp]

lemma curry_id_eq_coev : curry (𝟙 _) = (ihom.coev A).app X :=
by { rw [curry_eq, (ihom A).map_id (A ⊗ _)], apply comp_id }

section pre

variables {A B} [closed B]

/-- Pre-compose an internal hom with an external hom. -/
def pre (f : B ⟶ A) : ihom A ⟶ ihom B :=
transfer_nat_trans_self (ihom.adjunction _) (ihom.adjunction _) ((tensoring_left C).map f)

lemma uncurry_pre (f : B ⟶ A) (X : C) :
  monoidal_closed.uncurry ((pre f).app X) = (f ⊗ 𝟙 _) ≫ (ihom.ev A).app X :=
by rw [uncurry_eq, id_tensor_pre_app_comp_ev]

lemma coev_app_comp_pre_app (f : B ⟶ A) :
  (ihom.coev A).app X ≫ (pre f).app (A ⊗ X) =
    (ihom.coev B).app X ≫ (ihom B).map (f ⊗ (𝟙 _)) :=
unit_transfer_nat_trans_self _ _ ((tensoring_left C).map f) X

@[simp]
lemma pre_id (A : C) [closed A] : pre (𝟙 A) = 𝟙 _ :=
by { simp only [pre, functor.map_id], dsimp, simp, }

@[simp]
lemma pre_map {A₁ A₂ A₃ : C} [closed A₁] [closed A₂] [closed A₃]
  (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) :
  pre (f ≫ g) = pre g ≫ pre f :=
by rw [pre, pre, pre, transfer_nat_trans_self_comp, (tensoring_left C).map_comp]

end pre

/-- The internal hom functor given by the monoidal closed structure. -/
def internal_hom [monoidal_closed C] : Cᵒᵖ ⥤ C ⥤ C :=
{ obj := λ X, ihom X.unop,
  map := λ X Y f, pre f.unop }

end monoidal_closed

end category_theory


import .induction
import principia.logic

namespace hidden
namespace oldint

open mynat
open oldint

variables {m n k : oldint}
variables {a b c : mynat}

def mul: oldint → oldint → oldint
| (of_nat m) (of_nat n) := of_nat (m * n)
| -[1+ m] (of_nat n)    := neg_of_nat (succ m * n)
| (of_nat m) -[1+ n]    := neg_of_nat (m * succ n)
| -[1+ m] -[1+ n]       := of_nat (succ m * succ n)

instance: has_mul oldint := ⟨mul⟩

@[simp]
theorem nat_nat_mul: (↑a : oldint) * ↑b = ↑(a * b) := rfl

@[simp]
theorem nat_neg_mul: ↑a * -[1+ b] = -(↑(a * succ b)) := rfl

@[simp]
theorem neg_nat_mul: -[1+ a] * ↑b = -(↑(succ a * b)) := rfl

@[simp]
theorem neg_neg_mul: -[1+ a] * -[1+ b] = ↑((succ a) * succ b) := rfl

-- Why is this rfl
theorem mul_zero : ∀ {m : oldint}, m * 0 = 0
| (of_nat a) := rfl
| -[1+ a] := rfl

-- But this isn't rfl???
theorem zero_mul : ∀ {m : oldint}, 0 * m = 0
| (of_nat a) :=
by rw [←zero_nat,←coe_nat_eq, nat_nat_mul, mynat.zero_mul]
| -[1+ a] :=
by rw [←zero_nat, nat_neg_mul, mynat.zero_mul, zero_nat, neg_zero]

theorem mul_one: ∀ {m : oldint}, m * 1 = m
| (of_nat a) := rfl
| -[1+ a] := rfl

theorem one_mul : ∀ {m: oldint}, 1 * m = m
| (of_nat a) :=
by rw [←one_nat, ←coe_nat_eq, nat_nat_mul, mynat.one_mul]
| -[1+ a] :=
by rw [←one_nat, nat_neg_mul, mynat.one_mul, neg_coe_succ]

-- Stupid but useful
private theorem one: 1 = succ 0 := one_eq_succ_zero.symm

theorem mul_neg_one: ∀ {m : oldint}, m * (-1) = -m
| (of_nat a) :=
by rw [neg_one, ←coe_nat_eq, nat_neg_mul, ←one, mynat.mul_one]
| -[1+ a] :=
by rw [neg_one, neg_neg_mul, ←one, mynat.mul_one, neg_neg_succ]

theorem neg_one_mul: ∀ {m : oldint}, (-1) * m = -m
| (of_nat a) :=
by rw [←coe_nat_eq, neg_one, neg_nat_mul, ←one, mynat.one_mul]
| -[1+ a] :=
by rw [neg_one, neg_neg_mul, ←one, mynat.one_mul, neg_neg_succ]

theorem mul_comm: ∀ {m n : oldint}, m * n = n * m
| (of_nat a) (of_nat b) :=
by rw [←coe_nat_eq, ←coe_nat_eq, nat_nat_mul, nat_nat_mul,
       mynat.mul_comm]
| (of_nat a) -[1+ b] :=
by rw [←coe_nat_eq, nat_neg_mul, neg_nat_mul, mynat.mul_comm]
| -[1+ a] (of_nat b) :=
by rw [←coe_nat_eq, nat_neg_mul, neg_nat_mul, mynat.mul_comm]
| -[1+ a] -[1+ b] :=
by rw [neg_neg_mul, neg_neg_mul, mynat.mul_comm]

instance mul_is_comm: is_commutative oldint mul := ⟨assume a b, mul_comm⟩

-- rfl is magic
-- This is a "helper" lemma for mul_assoc
private lemma mul_neg_nat: ∀ {m:oldint} {a:mynat}, m * -↑a = -(m * ↑a)
| (of_nat b) zero := rfl
| (of_nat b) (succ a) := rfl
| -[1+ b] zero := rfl
| -[1+ b] (succ a) :=
by rw [neg_coe_succ, neg_neg_mul, neg_nat_mul, neg_neg]

-- These are much simpler than the addition ones, mostly just repeatedly
-- using the basic rules.
theorem mul_assoc: ∀ {m n k : oldint}, m * n * k = m * (n * k)
| (of_nat a) (of_nat b) (of_nat c) :=
by repeat {rw nat_nat_mul <|> rw ←coe_nat_eq}; rw mynat.mul_assoc
| (of_nat a) (of_nat b) -[1+ c]    :=
by rw [←coe_nat_eq, ←coe_nat_eq, nat_nat_mul, nat_neg_mul, nat_neg_mul,
       mul_neg_nat, nat_nat_mul, mynat.mul_assoc]
| (of_nat a) -[1+ b]    (of_nat c) :=
by rw [←coe_nat_eq, ←coe_nat_eq, nat_neg_mul, neg_nat_mul, mul_comm,
       mul_neg_nat, mul_neg_nat, nat_nat_mul, nat_nat_mul,
       mynat.mul_comm, mynat.mul_assoc]
| (of_nat a) -[1+ b]    -[1+ c]    :=
by rw [←coe_nat_eq, nat_neg_mul, neg_neg_mul, nat_nat_mul, mul_comm,
       mul_neg_nat, neg_nat_mul, neg_neg, mynat.mul_comm,
       mynat.mul_assoc]
| -[1+ a]    (of_nat b) (of_nat c) :=
by rw [←coe_nat_eq, ←coe_nat_eq, nat_nat_mul, neg_nat_mul, mul_comm,
       mul_neg_nat, nat_nat_mul, neg_nat_mul, mynat.mul_comm,
       mynat.mul_assoc]
| -[1+ a]    (of_nat b) -[1+ c]    :=
by rw [←coe_nat_eq, neg_nat_mul, nat_neg_mul, mul_comm, mul_neg_nat,
       mul_neg_nat, neg_nat_mul, neg_nat_mul, neg_neg, neg_neg,
       mynat.mul_comm, mynat.mul_assoc]
| -[1+ a]    -[1+ b]    (of_nat c) :=
by rw [←coe_nat_eq, neg_neg_mul, neg_nat_mul, mul_neg_nat, neg_nat_mul,
       neg_neg, nat_nat_mul, mynat.mul_assoc]
| -[1+ a]    -[1+ b]    -[1+ c]    := by
rw [neg_neg_mul, neg_neg_mul, nat_neg_mul, neg_nat_mul, mynat.mul_assoc]

instance mul_is_assoc: is_associative oldint mul :=
⟨assume a b c, mul_assoc⟩

theorem mul_neg : m * (-n) = - (m * n) :=
by rw [←mul_neg_one, ←mul_assoc, ←@neg_one_mul (m*n), mul_comm]

theorem neg_mul : (-m) * n = - (m * n) :=
by rw [mul_comm, @mul_comm m, mul_neg]

-- TODO: Stupid name
theorem neg_times_neg : (-m) * (-n) = m * n :=
by rw [neg_mul, mul_neg, neg_neg]

-- Effectively succ_mul for oldints
private theorem add_one_mul : ∀ {m n : oldint}, (m + 1) * n = m * n + n
| (of_nat a) (of_nat b) :=
by rw [←coe_nat_eq, ←coe_nat_eq, ←one_nat, nat_nat_add, nat_nat_mul,
      nat_nat_mul, nat_nat_add, mynat.add_mul, mynat.one_mul]
| (of_nat a) -[1+ b] :=
by rw [←coe_nat_eq, nat_neg_mul, ←one_nat, nat_nat_add, nat_neg_mul,
       ←neg_cancel, neg_neg, neg_distr, neg_neg, neg_neg_succ,
       nat_nat_add, mynat.add_mul, mynat.one_mul]
| -[1+ a] (of_nat b) :=
by rw [←coe_nat_eq, ←neg_coe_succ, neg_mul, nat_nat_mul, succ_mul,
       ←nat_nat_add, neg_distr, add_assoc, neg_self_add, add_zero,
       ←add_one_succ, ←nat_nat_add, neg_distr, add_assoc, one_nat,
       neg_self_add, add_zero, neg_mul, nat_nat_mul]
| -[1+ a] -[1+ b] := by
  rw [←neg_coe_succ, ←neg_coe_succ, neg_times_neg, mul_neg, ←neg_mul,
      neg_distr, neg_neg, neg_one, nat_neg_add, sub_succ_succ,
      nat_sub_zero, nat_nat_mul, nat_nat_mul, succ_mul, ←nat_nat_add,
      add_assoc, self_neg_add, add_zero]

private theorem sub_one_mul : (m - 1) * n = m * n - n :=
begin
  rw [sub_add_neg, sub_add_neg, ←neg_cancel, ←neg_mul, neg_distr,
      neg_distr, ←neg_mul, neg_neg, neg_neg],
  from add_one_mul,
end

theorem mul_add : m * (n + k) = m * n + m * k :=
begin
  revert m,
  apply intduction, {
    repeat { rw [zero_mul] },
    rw zero_add,
  }, {
    assume m hi,
    rw [add_one_mul, add_one_mul, add_one_mul, hi],
    ac_refl,
  }, {
    assume m hi,
    rw [sub_one_mul, sub_one_mul, sub_one_mul, hi, sub_add_neg,
        neg_distr, sub_add_neg, sub_add_neg],
    ac_refl,
  },
end

theorem add_mul: (m + n) * k = m * k + n * k :=
by rw [mul_comm, @mul_comm m, @mul_comm n, mul_add]

theorem nzero_iff_succ_or_neg_succ:
m ≠ 0 ↔ ∃ a, m = ↑(succ a) ∨ m = -↑(succ a) :=
begin
  rw exists_or,
  split; assume h, {
    cases m, {
      left,
      cases m, {
        rw [zz, ←coe_nat_eq, zero_nat] at h,
        contradiction,
      }, {
        existsi m,
        rw ←coe_nat_eq,
      }
    }, {
      right,
      existsi m,
      rw neg_coe_succ,
    },
  }, {
    cases h, {
      cases h with a h,
      assume h0,
      rw [h, ←zero_nat, of_nat_cancel] at h0,
      from mynat.no_confusion h0,
    }, {
      cases h with a h,
      assume h0,
      rw [h, ←neg_zero, ←zero_nat, neg_cancel, of_nat_cancel] at h0,
      from mynat.no_confusion h0,
    },
  },
end

private lemma neq_iff_not_eq: m ≠ n ↔ ¬(m = n) :=
begin
  split; assume hneq heq, all_goals { contradiction },
end

private lemma succ_times_succ_nzero: (succ a) * (succ b) ≠ 0 :=
begin
  assume h,
  have hsan0 : succ a ≠ 0,
    assume h₁,
    from mynat.no_confusion h₁,
  have hsbn0 : succ b ≠ 0,
    assume h₁,
    from mynat.no_confusion h₁,
  from hsbn0 (mynat.mul_integral hsan0 h),
end

--∀ {m n : oldint},
theorem mul_integral: m * n = 0 → n = 0 ∨ m = 0 :=
begin
  assume h₁,
  by_cases (m = 0), {
    right, assumption,
  }, {
    rename h hm,
    by_cases (n = 0), {
      left, assumption,
    }, {
      rename h hn,
      rename h₁ h,
      exfalso,
      rw [←neq_iff_not_eq, nzero_iff_succ_or_neg_succ] at hn hm,
      cases hm with a ha,
      cases hn with b hb,
      cases ha; cases hb,
      all_goals { subst ha, subst hb, }, {
        rw [nat_nat_mul, ←zero_nat, of_nat_cancel] at h,
        from succ_times_succ_nzero h,
      }, {
        rw [mul_neg, nat_nat_mul, ←neg_zero, neg_cancel, ←zero_nat,
            of_nat_cancel] at h,
        from succ_times_succ_nzero h,
      }, {
        rw [neg_mul, nat_nat_mul, ←neg_zero, neg_cancel, ←zero_nat,
            of_nat_cancel] at h,
        from succ_times_succ_nzero h,
      }, {
        rw [neg_times_neg, nat_nat_mul, ←zero_nat, of_nat_cancel] at h,
        from succ_times_succ_nzero h,
      },
    },
  },
end

theorem mul_nonzero_nonzero : m * n ≠ 0 ↔ m ≠ 0 ∧ n ≠ 0 :=
begin
  split; assume h, {
    have : 0 = (0 : oldint) := rfl,
    split, all_goals {
      assume h0,
      subst h0,
    },
    rw zero_mul at h,
    contradiction,
    rw mul_zero at h,
    contradiction,
  }, {
    assume hmn0,
    cases mul_integral hmn0 with hn0 hm0,
      from h.right hn0,
    from h.left hm0,
  },
end

private lemma something_add_one (m : oldint): ∃ n, m = n + 1 :=
by existsi (m + (-1)); rw [add_assoc, neg_self_add, add_zero]

private lemma something_sub_one (m : oldint): ∃ n, m = n + -1 :=
by existsi (m + 1); rw [add_assoc, self_neg_add, add_zero]

-- This proof caused some big problems. What's actually going on here is I'm
-- using a DIY form of `generalizing` from the `induction` tactic.
-- The argument is precisely the same as the one used for mynat, which I used
-- for inspiration
theorem mul_cancel: m ≠ 0 → m * n = m * k → n = k :=
begin
  revert n,
  -- Shorthand, then I used `dsimp only [p]` to expand when needed
  let p : oldint → Prop := λ n : oldint, ∀ m k, m ≠ 0 → m * n = m * k → n = k,
  -- apply intduction (λ n, ∀ m k, m * n = m * k → n = k),
  have h0 : p 0, {
    intros a b,
    assume han0 h,
    rw [mul_zero] at h,
    cases mul_integral h.symm,
      symmetry, assumption,
    contradiction,
  },
  have hnext : ∀ n : oldint, p n → p (n + 1), {
    intro n,
    assume h,
    intros a b,
    cases something_add_one b with j hj,
    subst hj,
    rw [mul_add, mul_add, add_cancel, add_cancel],
    from h _ _,
  },
  have hprev : ∀ n : oldint, p n → p (n - 1), {
    intro n,
    assume h,
    intros a b,
    cases something_sub_one b with j hj,
    subst hj,
    rw [sub_add_neg, mul_add, mul_add, add_cancel, add_cancel],
    from h _ _,
  },
  have h := intduction p h0 hnext hprev,
  intro n,
  have := h n,
  from this m k,
end

-- Both probably just case work
theorem abs_eq_sign_self : ↑(abs m) = (sign m) * m := sorry

theorem sign_mult : sign (m * n) = sign m * sign n := sorry

theorem abs_distr: abs m * abs n = abs (m * n) :=
begin
  rw [←oldint.of_nat_cancel, ←nat_nat_mul],
  repeat { rw abs_eq_sign_self, },
  suffices : (sign m) * m * ((sign n) * n) = (sign m * sign n) * (m * n),
    rw [this, sign_mult],
  ac_refl,
end

theorem abs_distr_int: (↑(abs m): oldint) * ↑(abs n) = ↑(abs (m * n)) :=
begin
  rw nat_nat_mul,
  rw abs_distr,
end

end oldint
end hidden


variables (α : Type) (r : α → α → Prop)

variable refl_r : ∀ x, r x x
variable symm_r : ∀ {x y}, r x y → r y x
variable trans_r : ∀ {x y z}, r x y → r y z → r x z

example (a b c d : α) (hab : r a b) (hcb : r c b) (hcd : r c d) : r a d :=
  trans_r (trans_r hab (symm_r hcb)) hcd


theorem ex1 : a + b < b + 1 + a + c := by
  simp (config := { arith := true })

theorem ex2 : a + b < b + 1 + a + c := by
  simp_arith

theorem ex3 : a + (fun x => x) b < b + 1 + a + c := by
  simp_arith

theorem ex4 : a + (fun x => x) b < b + 1 + a + c := by
  simp_arith (config := { beta := false })
  trace_state
  simp_arith

theorem ex5 (h : a + d + b > b + 1 + (a + (c + c) + d)) : False := by
  simp_arith at h

#print ex5

theorem ex6 (p : Nat → Prop) (h : p (a + 1 + a + 2 + b)) : p (2*a + b + 3) := by
  simp_arith at h
  assumption

#print ex6


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import control.functor.multivariate
import data.pfunctor.univariate
import data.sigma

/-!
# Multivariate polynomial functors.

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

universes u v
open_locale mvfunctor

/--
multivariate polynomial functors
-/
structure mvpfunctor (n : ℕ) :=
(A : Type.{u}) (B : A → typevec.{u} n)

namespace mvpfunctor
open mvfunctor (liftp liftr)

variables {n m : ℕ} (P : mvpfunctor.{u} n)

/-- Applying `P` to an object of `Type` -/
def obj (α : typevec.{u} n) : Type u := Σ a : P.A, P.B a ⟹ α

/-- Applying `P` to a morphism of `Type` -/
def map {α β : typevec n} (f : α ⟹ β) : P.obj α → P.obj β :=
λ ⟨a, g⟩, ⟨a, typevec.comp f g⟩

instance : inhabited (mvpfunctor n) :=
⟨ ⟨default _, λ _, default _⟩ ⟩

instance obj.inhabited {α : typevec n} [inhabited P.A] [Π i, inhabited (α i)] :
  inhabited (P.obj α) :=
⟨ ⟨default _, λ _ _, default _⟩ ⟩

instance : mvfunctor P.obj :=
⟨@mvpfunctor.map n P⟩

theorem map_eq {α β : typevec n} (g : α ⟹ β) (a : P.A) (f : P.B a ⟹ α) :
  @mvfunctor.map _ P.obj _ _ _ g ⟨a, f⟩ = ⟨a, g ⊚ f⟩ :=
rfl

theorem id_map {α : typevec n} : ∀ x : P.obj α, typevec.id <$$> x = x
| ⟨a, g⟩ := rfl

theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) :
  ∀ x : P.obj α, (g ⊚ f) <$$> x = g <$$> (f <$$> x)
| ⟨a, h⟩ := rfl

instance : is_lawful_mvfunctor P.obj :=
{ id_map := @id_map _ P,
  comp_map := @comp_map _ P }

/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : mvpfunctor n :=
{ A := A, B := λ a i, pempty }

section const
variables (n) {A : Type u}  {α β : typevec.{u} n}

/-- Constructor for the constant functor -/
def const.mk (x : A) {α} : (const n A).obj α :=
⟨ x, λ i a, pempty.elim a ⟩

variables {n A}

/-- Destructor for the constant functor -/
def const.get (x : (const n A).obj α) : A :=
x.1

@[simp]
lemma const.get_map (f : α ⟹ β) (x : (const n A).obj α) :
  const.get (f <$$> x) = const.get x :=
by { cases x, refl }

@[simp]
lemma const.get_mk (x : A) : const.get (const.mk n x : (const n A).obj α) = x :=
by refl

@[simp]
lemma const.mk_get (x : (const n A).obj α) : const.mk n (const.get x) = x :=
by { cases x, dsimp [const.get,const.mk], congr' with _ ⟨ ⟩ }

end const

/-- Functor composition on polynomial functors -/
def comp (P : mvpfunctor.{u} n) (Q : fin2 n → mvpfunctor.{u} m) : mvpfunctor m :=
{ A := Σ a₂ : P.1, Π i, P.2 a₂ i → (Q i).1,
  B := λ a, λ i, Σ j (b : P.2 a.1 j), (Q j).2 (a.snd j b) i }

variables {P} {Q : fin2 n → mvpfunctor.{u} m} {α β : typevec.{u} m}

/-- Constructor for functor composition -/
def comp.mk (x : P.obj (λ i, (Q i).obj α)) : (comp P Q).obj α :=
⟨ ⟨ x.1, λ i a, (x.2 _ a).1  ⟩, λ i a, (x.snd a.fst (a.snd).fst).snd i (a.snd).snd ⟩

/-- Destructor for functor composition -/
def comp.get (x : (comp P Q).obj α) : P.obj (λ i, (Q i).obj α) :=
⟨ x.1.1, λ i a, ⟨x.fst.snd i a, λ (j : fin2 m) (b : (Q i).B _ j), x.snd j ⟨i, ⟨a, b⟩⟩⟩ ⟩

lemma comp.get_map (f : α ⟹ β) (x : (comp P Q).obj α) :
  comp.get (f <$$> x) = (λ i (x : (Q i).obj α), f <$$> x) <$$> comp.get x :=
by { cases x, refl }

@[simp]
lemma comp.get_mk (x : P.obj (λ i, (Q i).obj α)) : comp.get (comp.mk x) = x :=
begin
  cases x,
  simp! [comp.get,comp.mk],
end

@[simp]
lemma comp.mk_get (x : (comp P Q).obj α) : comp.mk (comp.get x) = x :=
begin
  cases x,
  dsimp [comp.get,comp.mk],
  ext : 2; intros, refl, refl,
  congr, ext1; intros; refl,
  ext : 2, congr, rcases x_1 with ⟨a,b,c⟩; refl
end

/-
lifting predicates and relations
-/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (x : P.obj α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i j, (f i j).val, _, λ i j, (f i j).property⟩,
    rw [←hy, h, map_eq], refl },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i j, ⟨f i j, pf i j⟩⟩,
  rw [xeq], reflexivity
end

theorem liftp_iff' {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (a : P.A) (f : P.B a ⟹ α) :
  @liftp.{u} _ P.obj _ α p ⟨a,f⟩ ↔ ∀ i x, p (f i x) :=
begin
  simp only [liftp_iff, sigma.mk.inj_iff]; split; intro,
  { casesm* [Exists _, _ ∧ _], subst_vars, assumption },
  repeat { constructor <|> assumption }
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : P.obj α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq], refl },
  rw [yeq], refl
end

open set mvfunctor

theorem supp_eq {α : typevec n} (a : P.A) (f : P.B a ⟹ α) (i) :
  @supp.{u} _ P.obj _ α  (⟨a,f⟩ : P.obj α) i = f i '' univ :=
begin
  ext, simp only [supp, image_univ, mem_range, mem_set_of_eq],
  split; intro h,
  { apply @h (λ i x, ∃ (y : P.B a i), f i y = x),
    rw liftp_iff', intros, refine ⟨_,rfl⟩ },
  { simp only [liftp_iff'], cases h, subst x,
    tauto }
end

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor
open typevec
variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop : mvpfunctor n :=
{ A := P.A, B := λ a, (P.B a).drop }

/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last : pfunctor :=
{ A := P.A, B := λ a, (P.B a).last }

/-- append arrows of a polynomial functor application -/
@[reducible] def append_contents {α : typevec n} {β : Type*}
    {a : P.A} (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.B a ⟹ α ::: β :=
split_fun f' f

end mvpfunctor


import  .Sup_fin data.finsupp order.lattice data.nat.cast .euclidean_domain unique_factorization_domain
import .to_finsupp .to_finset poly
universes u v w

noncomputable theory

open classical set function finsupp lattice

local attribute [instance] finsupp.to_comm_semiring
local attribute [instance] finsupp.to_semiring
local infix ^ := monoid.pow

namespace polynomial
local attribute [instance] prop_decidable
variables {α : Type u} {a a' a₁ a₂ : α} --{n m : ℕ} --do we want n and m?

--Formal derivatives

section semiring
variable [semiring α]

def derivative (p : polynomial α) : polynomial α :=
p.sum (λn a, nat.cases_on n 0 (λn, single n (a * (n + 1))))
-- TODO: the following form breaks derivative_single
-- p.sum (λn a, match n with 0 := 0 | n + 1 := single n (a * (n + 1)) end)

@[simp] lemma derivative_zero : derivative (0 : polynomial α) = 0 :=
finsupp.sum_zero_index

lemma derivative_single {n : ℕ} {a : α} :
  derivative (single n a) = nat.cases_on n 0 (λn, single n (a * (n + 1))) :=
finsupp.sum_single_index $ match n with 0 := rfl | n + 1 := by simp [derivative]; refl end

@[simp] lemma derivative_single_zero {a : α} : derivative (single 0 a) = 0 :=
derivative_single

@[simp] lemma derivative_single_one {n : ℕ} {a : α} :
  derivative (single (n + 1) a) = single n (a * (n + 1)) :=
derivative_single

@[simp] lemma derivative_C {a : α} : derivative (C a) = 0 :=
by simp [C]; refl

@[simp] lemma derivative_one : derivative (1 : polynomial α) = 0 :=
derivative_C

@[simp] lemma derivative_X : derivative (X : polynomial α) = 1 :=
by simp [X]; refl

@[simp] lemma derivative_add {f g : polynomial α} :
  derivative (f + g) = derivative f + derivative g :=
finsupp.sum_add_index
  (assume n, match n with 0 := rfl | n + 1 := by simp [derivative]; refl end)
  (assume n, match n with
    0     := assume b₁ b₂, (add_zero _).symm
  | n + 1 := assume b₁ b₂, begin rw [← nat.succ_eq_add_one], simp [add_mul] end end)

@[simp] lemma derivative_sum {β : Type w} {s : finset β} {f : β → polynomial α} :
  derivative (s.sum f) = s.sum (λb, derivative (f b)) :=
begin
  apply (finset.sum_hom derivative _ _).symm,
  exact derivative_zero,
  exact assume x y, derivative_add
end

lemma derivative_eq_zero_of_is_constant {p : polynomial α} : (is_constant p) → (derivative p = 0) :=
begin
  intro h1,
  rw [is_constant] at h1,
  rcases h1 with ⟨c, h2⟩,
  simp [h2],
end

--We need characteristic_zero for derivative_eq_zero -> is_constant

end semiring

section comm_semiring
variable [comm_semiring α]

@[simp] lemma derivative_mul_C {f : polynomial α} : derivative (f * C a) = derivative f * C a :=
have ∀i c, derivative (single i (a * c)) = derivative (single i c) * C a,
  by intros i c; cases i; simp [C, single_mul_single, mul_comm, mul_left_comm, mul_assoc],
calc derivative (f * C a) = derivative (f.sum (λi c, single i (a * c))) :
    by rw [mul_C_eq_sum]
  ... = f.sum (λi c, derivative (single i (a * c))) : derivative_sum
  ... = f.sum (λi c, derivative (single i c) * C a) : by simp [this]
  ... = f.sum (λi c, derivative (single i c)) * C a : finset.sum_mul.symm
  ... = derivative (f.sum single) * C a : by simp [finsupp.sum, derivative_sum]
  ... = _ : by rw [sum_single]

@[simp] lemma derivative_C_mul {f : polynomial α} : derivative (C a * f) = C a * (derivative f) :=
by rw [mul_comm, derivative_mul_C, mul_comm]

private lemma derivative_mul_X_aux {f : polynomial α} : sum (derivative f) (λ (i : ℕ) (c : α), single (i + 1) c) = sum f (λ (i : ℕ) (c : α), single i (c * ↑i)) :=
begin
simp [derivative, sum_sum_index],
{
  apply finsupp.sum_congr rfl,
  {
    intros n hnf,
    cases n,
    { simp, apply sum_zero_index },
    { simp [sum_single_index]}
  }
},
end

lemma derivative_mul_X {f : polynomial α} : derivative (f * X) = derivative f * X + f :=
calc derivative (f * X) = derivative (f.sum (λi c, single (i + 1) c)) :
    by rw [mul_X_eq_sum]
  ... = f.sum (λi c, derivative (single (i + 1) c)) :
    derivative_sum
  ... = f.sum (λi c, single i (c * (i + 1))) :
    by simp [derivative_single, (nat.succ_eq_add_one _).symm]
  ... = f.sum (λi c, single i (c * i) + single i c) : by simp [single_add, mul_add]
  ... = f.sum (λi c, single i (c * i)) + f: by simp [sum_add, sum_single]
  ... = derivative f * X + f : by rw [mul_X_eq_sum, derivative_mul_X_aux]

lemma derivative_mul {f : polynomial α} :
  ∀{g}, derivative (f * g) = derivative f * g + f * derivative g :=
begin
  apply f.induction_on_X,
  { simp [derivative_mul_C, mul_assoc, mul_comm, mul_left_comm] },
  { simp [add_mul, mul_add] {contextual := tt} },
  { intros p hp q,
    rw [mul_assoc, hp, hp, mul_comm X q, derivative_mul_X],
    simp [mul_add, add_mul, add_assoc, add_comm, add_left_comm, mul_assoc, mul_comm, mul_left_comm] }
end

open finset

lemma derivative_prod {β : Type w} {s : finset β} {f : β → polynomial α} :
  derivative (s.prod f) = s.sum (λb, derivative (f b) * (erase s b).prod f) :=
begin
  apply finset.induction_on s,
  { simp },
  {
    intros a s has ih,
    have : ∀b∈s, ((insert a s).erase b).prod f = f a * (s.erase b).prod f,
    {
      assume b hb,
      have : a ≠ b,
      {
        assume h, simp * at *
      },
      rw [erase_insert_eq_insert_erase, finset.prod_insert]; simp *
    },
    have : s.sum (λb, derivative (f b) * (erase (insert a s) b).prod f) =
      f a * s.sum (λb, derivative (f b) * (erase s b).prod f),
    {
      exact calc s.sum (λb, derivative (f b) * (erase (insert a s) b).prod f) =
        s.sum (λb, f a * (derivative (f b) * (s.erase b).prod f)) :
        sum_congr rfl $ by simp [this, mul_assoc, mul_comm, mul_left_comm] {contextual := tt}
        ... = f a * s.sum (λb, derivative (f b) * (erase s b).prod f) : by rw [mul_sum],
    },
    simp [ih, has, finset.prod_insert, derivative_mul, sum_insert, erase_insert, this]
  }
end

--Clean up done till here 9 april 2018

--For the lemmas below I did not try to refactor them yet.

lemma derivative_prod_multiset {s : multiset (polynomial α)} :
  derivative (s.prod) = (s.map (λb, derivative (b) * (s.erase b).prod)).sum :=
begin
  apply multiset.induction_on s,
  {
    simp * at *,
  },
  {
    intros a s has,
    simp * at *,
    rw derivative_mul,
    have h : multiset.sum (multiset.map (λ (b : polynomial α), derivative b * multiset.prod (multiset.erase (a :: s) b)) s) =
    a * multiset.sum (multiset.map (λ (b : polynomial α), derivative b * multiset.prod (multiset.erase s b)) s),
    {
      exact calc multiset.sum (multiset.map (λ (b : polynomial α), derivative b * multiset.prod (multiset.erase (a :: s) b)) s) =
      multiset.sum (multiset.map (λ (b : polynomial α), a * (derivative b * multiset.prod (multiset.erase (s) b))) s) :
      begin
        apply congr_arg,
        apply multiset.map_congr,
        intros x h,
        by_cases h2 : x = a,
        {
          subst h2,
          rw multiset.erase_cons_head,
          rcases multiset.exists_cons_of_mem h with ⟨t, h⟩,
          subst h,
          simp [mul_comm x (derivative x)],
          rw [←mul_assoc, ←mul_assoc, mul_comm x _],
        },
        {
          simp [multiset.erase_cons_tail s (ne.symm h2), mul_comm a _,mul_assoc],
        }
      end
      ... = _ : @multiset.sum_map_mul (polynomial α) _ _ a _ s,
    },
    rw [h, has],
  }
end

lemma derivative_pow {n : ℕ} {p : polynomial α}:
   derivative (p^n) = ite (n = 0) 0 (n*p^(n-1)*derivative p) :=
begin
  induction n with n h,
  { simp},
  {
    simp [if_neg, pow_succ', derivative_mul, nat.succ_ne_zero, *],
    cases n,
    {
      simp,
    },
    {
      simp [nat.succ_ne_zero, if_neg, pow_succ', *],
      exact calc p ^ n * p * derivative p + (1 + ↑n) * p ^ n * derivative p * p =
      1 * p ^ n * p * derivative p + (1 + ↑n) * p ^ n * derivative p * p : by simp
      ... = 1 * p ^ n * p * derivative p + (1 + ↑n) * p ^ n * (derivative p * p) : by simp [mul_assoc]
      ... = 1 * p ^ n * p * derivative p + (1 + ↑n) * p ^ n * (p * derivative p) : by simp [mul_comm]
      ... = 1 * p ^ n * p * derivative p + (1 + ↑n) * p ^ n * p * derivative p   : by simp [mul_assoc]
      ... = 1 * (p ^ n * p * derivative p) + (1 + ↑n) * (p ^ n * p * derivative p)   : by simp [mul_assoc]
      ... = (1 + (1 + ↑n)) * (p ^ n * p * derivative p): by rw [←( add_mul 1 (1 + ↑n) (p ^ n * p * derivative p))]
      ... = (1 + (1 + ↑n)) * (p ^ n * p) * derivative p : by simp [mul_assoc]
    }
  }
end

end comm_semiring

section integral_domain
variable [integral_domain α]

lemma derivative_apply {p : polynomial α} {n : ℕ} : derivative p n = (n + 1) * p (n + 1) :=
calc derivative p n = ({n + 1} : finset ℕ).sum (λm, (nat.cases_on m 0 (λn, single n (p m * (↑n + 1))) : polynomial α) n) :
  begin
    rw [derivative, sum_apply],
    apply finset.sum_bij_ne_zero (λx _ _, x),
    { intro m, cases m,
      { dsimp, simp },
      { by_cases m = n,
        { dsimp, simp [single_apply, h] },
        { dsimp, simp [single_apply, h] } } },
    { intros m hm, exact id },
    { intros a₁ a₂ _ _ _ _, exact id },
    { dsimp, simp,
      intro h,
      refine ⟨n + 1, _, _, _⟩,
      { change (single n (p (n + 1) * (n + 1)) n ≠ 0) at h,
        simp [mul_eq_zero, not_or_distrib] at h,
        exact h.left },
      { assumption },
      { refl } },
    { dsimp, simp }
  end
  ... = _ :
  begin
    simp,
    change single n (p (n + 1) * (n + 1)) n = (1 + n) * p (n + 1),
    simp [mul_comm]
  end

--Why placed here?
lemma degree_derivative_le {p : polynomial α} : degree (derivative p) ≤ degree p - 1 :=
degree_le $ assume m hm,
  have degree p < m + 1,
    from calc degree p ≤ (degree p - 1) + 1 : nat.le_sub_add (degree p) 1
      ... ≤ m : hm
      ... < m + 1 : nat.lt_succ_self _,
  have p (m + 1) = 0,
    from eq_zero_of_gt_degree this,
  by rw [derivative_apply, this, mul_zero]

--Problem with decidability propagated
lemma derivative_degree_sub_one_eq_degree_mul_leading_coeff {p : polynomial α} :
  derivative p (degree p - 1) = degree p * (leading_coeff p) :=
begin
  rw [leading_coeff],
  cases h : degree p,
  {
    have : is_constant p,
    { rwa [is_constant_iff_degree_eq_zero] },
    rcases this with ⟨a, ha⟩,
    rw [ha, derivative_C],
    simp
  },
  {  exact derivative_apply}
end

lemma derivative_eq_zero_iff_is_constant {p : polynomial α} (h : characteristic_zero α) :
  (derivative p = 0) ↔ (is_constant p) :=
begin
  constructor,
  {
    by_cases h1 : (p = 0),
    {
      intro h2,
      simp *,
    },
    {
      rw ←not_imp_not,
      intros h2,
      rw is_constant_iff_degree_eq_zero at h2,
      have h3 : degree p ∈ support p,
        from degree_mem_support_of_ne_zero h1,
      rw mem_support_iff at h3,
      have h4 : (derivative p) ((degree p)-1) = (degree p * (leading_coeff p)),
        from derivative_degree_sub_one_eq_degree_mul_leading_coeff,
      have h5 : (derivative p) (degree p - 1) ≠ 0,
      {
        rw h4,
        apply mul_ne_zero,
        apply h,
        exact h2,
        have h5 : leading_coeff p ≠ 0,
        {
          rw [←leading_coef_eq_zero_iff_eq_zero] at h1,
          exact h1,
        },
        exact h5,
      },
      by_contradiction h6,
      rw [h6, zero_apply] at h5,
      contradiction
    }
  },
  {
    exact derivative_eq_zero_of_is_constant
  }
end

end integral_domain

end polynomial


import tactic

import logic.function.basic
import init.data.setoid
import data.setoid.basic

import algebra.iterate_hom

universes u v

-- Things to mention in report:
-- - It's surprisingly easy to add unnecessary hypothesis to definitions for
-- example, but linting checks this and helps out.
-- (like requiring that f is injective in same_chain, when it is only required
-- for transitivity)
-- - Lean makes sense of things which "aren't well defined" by looking in
--   hypothesis and making sure they are reasonable
--   (when subtracting in the natural numbers, it will check the result
--   is non-negative)
-- - Lean keeps you honest when trying to use arguments like wlog?

def same_chain_rel {α : Type u} (f : α → α) : α → α → Prop :=
λ x y, (∃ n : ℕ, f^[n] x = y) ∨ (∃ n : ℕ, f^[n] y = x)

lemma same_chain_reflexive {α : Type u} (f : α → α) : reflexive (same_chain_rel f) :=
λ _, or.inl ⟨0, rfl⟩

lemma same_chain_symmetric {α : Type u} (f : α → α) : symmetric (same_chain_rel f) :=
λ x y, (or_comm (∃ n, f^[n] x = y) (∃ n, f^[n] y = x)).mp

lemma same_chain_transitive {α : Type u} {f : α → α} (hf : function.injective f)
  : transitive (same_chain_rel f) :=
begin
  intros x y z hxy hyz,
  rcases hxy with ⟨n, hn⟩ | ⟨n, hn⟩,
  { rcases hyz with ⟨m, hm⟩ | ⟨m, hm⟩,
    { left, use m + n,
      rw [←hm, ←hn, function.iterate_add] },
    { cases lt_or_le n m,
      { right, use m - n,
        apply function.injective.iterate hf n,
        rw [←function.iterate_add_apply, nat.add_sub_of_le (le_of_lt h), hn, hm] },
      { left, use n - m,
        apply function.injective.iterate hf m,
        rw [←function.iterate_add_apply, nat.add_sub_of_le h, hm, hn] }}},
  { rcases hyz with ⟨m, hm⟩ | ⟨m, hm⟩,
    { cases lt_or_le n m,
      { left, use m - n,
        rw [←hn, ←hm, ←function.iterate_add_apply, add_comm, nat.add_sub_of_le (le_of_lt h)] },
      { right, use n - m,
        rw [←hn, ←hm, ←function.iterate_add_apply, add_comm, nat.add_sub_of_le h] }},
    { right, use n + m,
      rw [←hn, ←hm,function.iterate_add] }},
end

lemma same_chain_equivalence {α : Type u} {f : α → α} (hf : function.injective f) : equivalence (same_chain_rel f) :=
⟨same_chain_reflexive f, same_chain_symmetric f, same_chain_transitive hf⟩

def same_chain_setoid {α : Type u} {f : α → α} (hf : function.injective f) : setoid α :=
{ r := same_chain_rel f, iseqv := same_chain_equivalence hf }

lemma iter_comp_assoc {α : Type u} {β : Type v} (f : α → β) (g : β → α) (n : ℕ)
  : ∀ a : α, f (g ∘ f^[n] a) = (f ∘ g^[n] (f a)) :=
begin
  induction n,
  { intro a,
    rw [function.iterate_zero_apply, function.iterate_zero_apply] },
  { intro a,
    rw [function.iterate_succ, function.iterate_succ, n_ih (g (f a))] }
end

def same_chain_quotient_map {α : Type u} {β : Type v} {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g)
  : quotient (same_chain_setoid (function.injective.comp hg hf))
    → quotient (same_chain_setoid (function.injective.comp hf hg)) :=
begin
  apply quotient.map' f,
  intros a b,
  rintros (⟨n, hn⟩ | ⟨n, hn⟩);
  rw [←hn, iter_comp_assoc f g n],
  { left, use n },
  { right, use n }
end

lemma same_chain_quotient_map_inverse {α : Type u} {β : Type v} {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g)
  : ∀ x, same_chain_quotient_map hg hf (same_chain_quotient_map hf hg x) = x :=
begin
  intro x,
  rw [←quotient.out_eq' x, same_chain_quotient_map, same_chain_quotient_map,
      quotient.map'_mk', quotient.map'_mk'],
  apply quotient.sound',
  right, use 1,
  refl,
end

def same_chain_quotient_equiv {α : Type u} {β : Type v} {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g)
  : quotient (same_chain_setoid (function.injective.comp hg hf))
    ≃ quotient (same_chain_setoid (function.injective.comp hf hg)) :=
{ to_fun    := same_chain_quotient_map hf hg,
  inv_fun   := same_chain_quotient_map hg hf,
  left_inv  := same_chain_quotient_map_inverse hf hg,
  right_inv := same_chain_quotient_map_inverse hg hf,
}

theorem schroder_bernstein {α : Type u} {β : Type v} {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g)
  : ∃ (h : α → β), function.bijective h :=
begin
  sorry,
end


/-
Copyright (c) 2020 Paul van Wamelen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul van Wamelen
-/
import number_theory.pythagorean_triples
import ring_theory.coprime.lemmas

/-!
# Fermat's Last Theorem for the case n = 4
There are no non-zero integers `a`, `b` and `c` such that `a ^ 4 + b ^ 4 = c ^ 4`.
-/

noncomputable theory
open_locale classical

/-- Shorthand for three non-zero integers `a`, `b`, and `c` satisfying `a ^ 4 + b ^ 4 = c ^ 2`.
We will show that no integers satisfy this equation. Clearly Fermat's Last theorem for n = 4
follows. -/
def fermat_42 (a b c : ℤ) : Prop := a ≠ 0 ∧ b ≠ 0 ∧ a ^ 4 + b ^ 4 = c ^ 2

namespace fermat_42

lemma comm {a b c : ℤ} :
 (fermat_42 a b c) ↔ (fermat_42 b a c) :=
 by { delta fermat_42, rw add_comm, tauto }

lemma mul {a b c k : ℤ} (hk0 : k ≠ 0) :
  fermat_42 a b c ↔ fermat_42 (k * a) (k * b) (k ^ 2 * c) :=
begin
  delta fermat_42,
  split,
  { intro f42,
    split, { exact mul_ne_zero hk0 f42.1 },
    split, { exact mul_ne_zero hk0 f42.2.1 },
    { calc (k * a) ^ 4 + (k * b) ^ 4
          = k ^ 4 * (a ^ 4 + b ^ 4) : by ring
      ... = k ^ 4 * c ^ 2 : by rw f42.2.2
      ... = (k ^ 2 * c) ^ 2 : by ring }},
  { intro f42,
    split, { exact right_ne_zero_of_mul f42.1 },
    split, { exact right_ne_zero_of_mul f42.2.1 },
    apply (mul_right_inj' (pow_ne_zero 4 hk0)).mp,
    { calc k ^ 4 * (a ^ 4 + b ^ 4)
          = (k * a) ^ 4 + (k * b) ^ 4 : by ring
      ... = (k ^ 2 * c) ^ 2 : by rw f42.2.2
      ... = k ^ 4 * c ^ 2 : by ring }}
end

lemma ne_zero {a b c : ℤ} (h : fermat_42 a b c) : c ≠ 0 :=
begin
  apply ne_zero_pow (dec_trivial : 2 ≠ 0), apply ne_of_gt,
  rw [← h.2.2, (by ring : a ^ 4 + b ^ 4 = (a ^ 2) ^ 2 + (b ^ 2) ^ 2)],
  exact add_pos (sq_pos_of_ne_zero _ (pow_ne_zero 2 h.1))
      (sq_pos_of_ne_zero _ (pow_ne_zero 2 h.2.1))
end

/-- We say a solution to `a ^ 4 + b ^ 4 = c ^ 2` is minimal if there is no other solution with
a smaller `c` (in absolute value). -/
def minimal (a b c : ℤ) : Prop :=
  (fermat_42 a b c) ∧ ∀ (a1 b1 c1 : ℤ), (fermat_42 a1 b1 c1) → int.nat_abs c ≤ int.nat_abs c1

/-- if we have a solution to `a ^ 4 + b ^ 4 = c ^ 2` then there must be a minimal one. -/
lemma exists_minimal {a b c : ℤ} (h : fermat_42 a b c) :
  ∃ (a0 b0 c0), (minimal a0 b0 c0) :=
begin
  let S : set ℕ := { n | ∃ (s : ℤ × ℤ × ℤ), fermat_42 s.1 s.2.1 s.2.2 ∧ n = int.nat_abs s.2.2},
  have S_nonempty : S.nonempty,
  { use int.nat_abs c,
    rw set.mem_set_of_eq,
    use ⟨a, ⟨b, c⟩⟩, tauto },
  let m : ℕ := nat.find S_nonempty,
  have m_mem : m ∈ S := nat.find_spec S_nonempty,
  rcases m_mem with ⟨s0, hs0, hs1⟩,
  use [s0.1, s0.2.1, s0.2.2, hs0],
  intros a1 b1 c1 h1,
  rw ← hs1,
  apply nat.find_min',
  use ⟨a1, ⟨b1, c1⟩⟩, tauto
end

/-- a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` must have `a` and `b` coprime. -/
lemma coprime_of_minimal {a b c : ℤ} (h : minimal a b c) : is_coprime a b :=
begin
  apply int.gcd_eq_one_iff_coprime.mp,
  by_contradiction hab,
  obtain ⟨p, hp, hpa, hpb⟩ := nat.prime.not_coprime_iff_dvd.mp hab,
  obtain ⟨a1, rfl⟩ := (int.coe_nat_dvd_left.mpr hpa),
  obtain ⟨b1, rfl⟩ := (int.coe_nat_dvd_left.mpr hpb),
  have hpc : (p : ℤ) ^ 2 ∣ c,
  { apply (int.pow_dvd_pow_iff (dec_trivial : 0 < 2)).mp,
    rw ← h.1.2.2,
    apply dvd.intro (a1 ^ 4 + b1 ^ 4), ring },
  obtain ⟨c1, rfl⟩ := hpc,
  have hf : fermat_42 a1 b1 c1,
    exact (fermat_42.mul (int.coe_nat_ne_zero.mpr (nat.prime.ne_zero hp))).mpr h.1,
  apply nat.le_lt_antisymm (h.2 _ _ _ hf),
  rw [int.nat_abs_mul, lt_mul_iff_one_lt_left, int.nat_abs_pow, int.nat_abs_of_nat],
  { exact nat.one_lt_pow _ _ (show 0 < 2, from dec_trivial) (nat.prime.one_lt hp) },
  { exact (nat.pos_of_ne_zero (int.nat_abs_ne_zero_of_ne_zero (ne_zero hf))) },
end

/-- We can swap `a` and `b` in a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2`. -/

/-- We can assume that a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` has positive `c`. -/
lemma neg_of_minimal {a b c : ℤ} :
 (minimal a b c) → (minimal a b (-c)) :=
begin
  rintros ⟨⟨ha, hb, heq⟩, h2⟩,
  split,
  { apply and.intro ha (and.intro hb _),
    rw heq, exact (neg_sq c).symm },
  rwa (int.nat_abs_neg c),
end

/-- We can assume that a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` has `a` odd. -/
lemma exists_odd_minimal {a b c : ℤ} (h : fermat_42 a b c) :
  ∃ (a0 b0 c0), (minimal a0 b0 c0) ∧ a0 % 2 = 1 :=
begin
  obtain ⟨a0, b0, c0, hf⟩ := exists_minimal h,
  cases int.mod_two_eq_zero_or_one a0 with hap hap,
  { cases int.mod_two_eq_zero_or_one b0 with hbp hbp,
    { exfalso,
      have h1 : 2 ∣ (int.gcd a0 b0 : ℤ),
      { exact int.dvd_gcd (int.dvd_of_mod_eq_zero hap) (int.dvd_of_mod_eq_zero hbp) },
        rw int.gcd_eq_one_iff_coprime.mpr (coprime_of_minimal hf) at h1, revert h1, norm_num },
    { exact ⟨b0, ⟨a0, ⟨c0, minimal_comm hf, hbp⟩⟩⟩ } },
  exact ⟨a0, ⟨b0, ⟨c0 , hf, hap⟩⟩⟩,
end

/-- We can assume that a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` has
`a` odd and `c` positive. -/
lemma exists_pos_odd_minimal {a b c : ℤ} (h : fermat_42 a b c) :
  ∃ (a0 b0 c0), (minimal a0 b0 c0) ∧ a0 % 2 = 1 ∧ 0 < c0  :=
begin
  obtain ⟨a0, b0, c0, hf, hc⟩ := exists_odd_minimal h,
  rcases lt_trichotomy 0 c0 with (h1 | rfl | h1),
  { use [a0, b0, c0], tauto },
  { exfalso, exact ne_zero hf.1 rfl},
  { use [a0, b0, -c0, neg_of_minimal hf, hc],
    exact neg_pos.mpr h1 },
end

end fermat_42

lemma int.coprime_of_sq_sum {r s : ℤ} (h2 : is_coprime s r) :
  is_coprime (r ^ 2 + s ^ 2) r :=
begin
  rw [sq, sq],
  exact (is_coprime.mul_left h2 h2).mul_add_left_left r
end

lemma int.coprime_of_sq_sum' {r s : ℤ} (h : is_coprime r s) :
  is_coprime (r ^ 2 + s ^ 2) (r * s) :=
begin
  apply is_coprime.mul_right (int.coprime_of_sq_sum (is_coprime_comm.mp h)),
  rw add_comm, apply int.coprime_of_sq_sum h
end

namespace fermat_42

-- If we have a solution to a ^ 4 + b ^ 4 = c ^ 2, we can construct a smaller one. This
-- implies there can't be a smallest solution.
lemma not_minimal {a b c : ℤ}
  (h : minimal a b c) (ha2 : a % 2 = 1) (hc : 0 < c) : false :=
begin
  -- Use the fact that a ^ 2, b ^ 2, c form a pythagorean triple to obtain m and n such that
  -- a ^ 2 = m ^ 2 - n ^ 2, b ^ 2 = 2 * m * n and c = m ^ 2 + n ^ 2
  -- first the formula:
  have ht : pythagorean_triple (a ^ 2) (b ^ 2) c,
  { calc ((a ^ 2) * (a ^ 2)) + ((b ^ 2) * (b ^ 2))
        = a ^ 4 + b ^ 4 : by ring
    ... = c ^ 2 : by rw h.1.2.2
    ... = c * c : by rw sq },
  -- coprime requirement:
  have h2 : int.gcd (a ^ 2) (b ^ 2) = 1 :=
    int.gcd_eq_one_iff_coprime.mpr (coprime_of_minimal h).pow,
  -- in order to reduce the possibilities we get from the classification of pythagorean triples
  -- it helps if we know the parity of a ^ 2 (and the sign of c):
  have ha22 : a ^ 2 % 2 = 1, { rw [sq, int.mul_mod, ha2], norm_num },
  obtain ⟨m, n, ht1, ht2, ht3, ht4, ht5, ht6⟩ :=
    pythagorean_triple.coprime_classification' ht h2 ha22 hc,
  -- Now a, n, m form a pythagorean triple and so we can obtain r and s such that
  -- a = r ^ 2 - s ^ 2, n = 2 * r * s and m = r ^ 2 + s ^ 2
  -- formula:
  have htt : pythagorean_triple a n m,
  { delta pythagorean_triple,
    rw [← sq, ← sq, ← sq], exact (add_eq_of_eq_sub ht1) },
  -- a and n are coprime, because a ^ 2 = m ^ 2 - n ^ 2 and m and n are coprime.
  have h3 : int.gcd a n = 1,
  { apply int.gcd_eq_one_iff_coprime.mpr,
    apply @is_coprime.of_mul_left_left _ _ _ a,
    rw [← sq, ht1, (by ring : m ^ 2 - n ^ 2 = m ^ 2 + (-n) * n)],
    exact (int.gcd_eq_one_iff_coprime.mp ht4).pow_left.add_mul_right_left (-n) },
  -- m is positive because b is non-zero and b ^ 2 = 2 * m * n and we already have 0 ≤ m.
  have hb20 : b ^ 2 ≠ 0 := mt pow_eq_zero h.1.2.1,
  have h4 : 0 < m,
  { apply lt_of_le_of_ne ht6,
    rintro rfl,
    revert hb20,
    rw ht2, simp },
  obtain ⟨r, s, htt1, htt2, htt3, htt4, htt5, htt6⟩ :=
    pythagorean_triple.coprime_classification' htt h3 ha2 h4,
  -- Now use the fact that (b / 2) ^ 2 = m * r * s, and m, r and s are pairwise coprime to obtain
  -- i, j and k such that m = i ^ 2, r = j ^ 2 and s = k ^ 2.
  -- m and r * s are coprime because m = r ^ 2 + s ^ 2 and r and s are coprime.
  have hcp : int.gcd m (r * s) = 1,
  { rw htt3,
    exact int.gcd_eq_one_iff_coprime.mpr (int.coprime_of_sq_sum'
      (int.gcd_eq_one_iff_coprime.mp htt4)) },
  -- b is even because b ^ 2 = 2 * m * n.
  have hb2 : 2 ∣ b,
  { apply @int.prime.dvd_pow' _ 2 _ (by norm_num : nat.prime 2),
    rw [ht2, mul_assoc], exact dvd_mul_right 2 (m * n) },
  cases hb2 with b' hb2',
  have hs : b' ^ 2 = m * (r * s),
  { apply (mul_right_inj' (by norm_num : (4 : ℤ) ≠ 0)).mp,
    calc 4 * b' ^ 2 = (2 * b') * (2 * b') : by ring
                    ... = 2 * m * (2 * r * s) : by rw [← hb2', ← sq, ht2, htt2]
                    ... = 4 * (m * (r * s)) : by ring },
  have hrsz : r * s ≠ 0, -- because b ^ 2 is not zero and (b / 2) ^ 2 = m * (r * s)
  { by_contradiction hrsz,
    revert hb20, rw [ht2, htt2, mul_assoc, @mul_assoc _ _ _ r s, hrsz],
    simp },
  have h2b0 : b' ≠ 0,
  { apply ne_zero_pow (dec_trivial : 2 ≠ 0),
    rw hs, apply mul_ne_zero, { exact ne_of_gt h4}, { exact hrsz } },
  obtain ⟨i, hi⟩ := int.sq_of_gcd_eq_one hcp hs.symm,
  -- use m is positive to exclude m = - i ^ 2
  have hi' : ¬ m = - i ^ 2,
  { by_contradiction h1,
    have hit : - i ^ 2 ≤ 0, apply neg_nonpos.mpr (sq_nonneg i),
    rw ← h1 at hit,
    apply absurd h4 (not_lt.mpr hit) },
  replace hi : m = i ^ 2, { apply or.resolve_right hi hi' },
  rw mul_comm at hs,
  rw [int.gcd_comm] at hcp,
  -- obtain d such that r * s = d ^ 2
  obtain ⟨d, hd⟩ := int.sq_of_gcd_eq_one hcp hs.symm,
  -- (b / 2) ^ 2 and m are positive so r * s is positive
  have hd' : ¬ r * s = - d ^ 2,
  { by_contradiction h1,
    rw h1 at hs,
    have h2 : b' ^ 2 ≤ 0,
    { rw [hs, (by ring : - d ^ 2 * m = - (d ^ 2 * m))],
      exact neg_nonpos.mpr ((zero_le_mul_right h4).mpr (sq_nonneg d)) },
    have h2' : 0 ≤ b' ^ 2, { apply sq_nonneg b' },
    exact absurd (lt_of_le_of_ne h2' (ne.symm (pow_ne_zero _ h2b0))) (not_lt.mpr h2) },
  replace hd : r * s = d ^ 2, { apply or.resolve_right hd hd' },
  -- r = +/- j ^ 2
  obtain ⟨j, hj⟩ := int.sq_of_gcd_eq_one htt4 hd,
  have hj0 : j ≠ 0,
  { intro h0, rw [h0, zero_pow (dec_trivial : 0 < 2), neg_zero, or_self] at hj,
    apply left_ne_zero_of_mul hrsz hj },
  rw mul_comm at hd,
  rw [int.gcd_comm] at htt4,
  -- s = +/- k ^ 2
  obtain ⟨k, hk⟩ := int.sq_of_gcd_eq_one htt4 hd,
  have hk0 : k ≠ 0,
  { intro h0, rw [h0, zero_pow (dec_trivial : 0 < 2), neg_zero, or_self] at hk,
    apply right_ne_zero_of_mul hrsz hk },
  have hj2 : r ^ 2 = j ^ 4, { cases hj with hjp hjp; { rw hjp, ring } },
  have hk2 : s ^ 2 = k ^ 4, { cases hk with hkp hkp; { rw hkp, ring } },
  -- from m = r ^ 2 + s ^ 2 we now get a new solution to a ^ 4 + b ^ 4 = c ^ 2:
  have hh : i ^ 2 = j ^ 4 + k ^ 4, { rw [← hi, htt3, hj2, hk2] },
  have hn : n ≠ 0, { rw ht2 at hb20, apply right_ne_zero_of_mul hb20 },
  -- and it has a smaller c: from c = m ^ 2 + n ^ 2 we see that m is smaller than c, and i ^ 2 = m.
  have hic : int.nat_abs i < int.nat_abs c,
  { apply int.coe_nat_lt.mp, rw ← (int.eq_nat_abs_of_zero_le (le_of_lt hc)),
    apply gt_of_gt_of_ge _ (int.abs_le_self_sq i),
    rw [← hi, ht3],
    apply gt_of_gt_of_ge _ (int.le_self_sq m),
    exact lt_add_of_pos_right (m ^ 2) (sq_pos_of_ne_zero n hn) },
  have hic' : int.nat_abs c ≤ int.nat_abs i,
  { apply (h.2 j k i),
    exact ⟨hj0, hk0, hh.symm⟩ },
  apply absurd (not_le_of_lt hic) (not_not.mpr hic')
end

end fermat_42

lemma not_fermat_42 {a b c : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) :
  a ^ 4 + b ^ 4 ≠ c ^ 2 :=
begin
  intro h,
  obtain ⟨a0, b0, c0, ⟨hf, h2, hp⟩⟩ :=
    fermat_42.exists_pos_odd_minimal (and.intro ha (and.intro hb h)),
  apply fermat_42.not_minimal hf h2 hp
end

theorem not_fermat_4 {a b c : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) :
  a ^ 4 + b ^ 4 ≠ c ^ 4 :=
begin
  intro heq,
  apply @not_fermat_42 _ _ (c ^ 2) ha hb,
  rw heq, ring
end


import .coeffs .int

def term : Type := int × coeffs

namespace term

def subscript_digit : char → char
| '0' := '₀'
| '1' := '₁'
| '2' := '₂'
| '3' := '₃'
| '4' := '₄'
| '5' := '₅'
| '6' := '₆'
| '7' := '₇'
| '8' := '₈'
| '9' := '₉'
| c := c
--
--def subscript_digits (ds : string) : string :=
--⟨ds.data.map subscript_digit⟩
--
--def to_string_monomial (m : nat) (i : int) : string :=
--i.repr ++ "x" ++ subscript_digits m.repr
--
--def to_string_aux : nat → list int → string
--| m []      := ""
--| m [i]     := to_string_monomial m i
--| m (i::is) := to_string_monomial m i ++ " + " ++ to_string_aux (m+1) is
--
--def repr (t : term) : string :=
--t.fst.repr ++ " + " ++ to_string_aux 0 t.snd
--
--instance has_repr : has_repr term := ⟨repr⟩
--
--meta instance has_to_format : has_to_format term := ⟨λ t, repr t⟩

@[omega] def val (v : nat → int) : term → int
| (b,as) := b + coeffs.val v as

@[omega] def neg : term → term
| (b,as) := (-b, as.neg)

@[omega] def add : term → term → term
| (c1,cfs1) (c2,cfs2) := (c1+c2, list.add cfs1 cfs2)

@[omega] def sub : term → term → term
| (c1,cfs1) (c2,cfs2) := (c1 - c2, list.sub cfs1 cfs2)

@[omega] def div (i : int) : term → term
| (b,as) := (b/i, as.map (λ x, x / i))

lemma val_neg {v} {t : term} :
(neg t).val v = -(t.val v) :=
begin cases t with b as, simp_omega [neg_add] end

@[omega] lemma val_sub {v} {t1 t2 : term} :
(sub t1 t2).val v = t1.val v - t2.val v :=
begin
  cases t1, cases t2,
  simp_omega, ring,
end

@[omega] lemma val_add {v} {t1 t2 : term} :
(add t1 t2).val v = t1.val v + t2.val v :=
begin
  cases t1, cases t2,
  simp_omega, ring,
end

def mul (i : int) : term → term
| (b,as) := (i * b, as.map ((*) i))

@[omega] lemma val_mul {v i t} :
val v (mul i t) = i * (val v t) :=
begin
  cases t,
  simp_omega [mul, mul_add, add_mul,
  coeffs.val, list.length_map],
end

lemma val_div {v i} {b as} :
i ∣ b → (∀ x ∈ as, i ∣ x) →
(div i (b,as)).val v = (val v (b,as)) / i :=
begin
  intros h1 h2, simp_omega,
  rw [int.add_div h1 (coeffs.dvd_val h2)],
  apply fun_mono_2 rfl,
  rw ← coeffs.val_map_div h2
end

def fresh_idx (t : term) : nat := t.snd.length

def terms.fresh_idx : list term → nat
| []      := 0
| (t::ts) := max t.fresh_idx (terms.fresh_idx ts)

#exit
lemma val_eq_of_eq_upto (v w) (t : term) :
eq_upto t.fresh_idx v w → t.val v = t.val w  :=
begin
  cases t with b as, simp only [val], intro h1,
  apply congr_arg, apply coeffs.val_eq_val_of_eq_upto,
  --rw [zero_add],
  apply h1
end

-- #exit
-- lemma val_div {v i} {t : term} :
--   i ∣ t.const → (∀ x ∈ t.snd, i ∣ x) →
--   val v (div i t) = (val v t) / i :=
-- begin
--   intros h1 h2, cases t with c cfs,
--   simp_omega [div],
-- end

lemma eq_const {v} {t : term} :
  (∀ (x : ℤ), x ∈ t.snd → x = 0) → t.val v = t.fst :=
begin
  intros h1, cases t with c cfs, simp_omega at *,
  have h3 : coeffs.val v cfs = 0 := coeffs.val_eq_zero h1,
  rw [h3, add_zero]
end

end term