/-
 These are my solutions to the katas in the Mathematical Analysis collection in Codewars (https://www.codewars.com/collections/mathematical-analysis).
-/

import data.real.basic data.set.intervals.basic algebra.geom_sum
open classical
attribute [instance] prop_decidable

/-
  Rigorous definition of a limit
  For a sequence x_n, we say that \lim_{n \to \infty} x_n = l if
    ∀ ε > 0, ∃ N, n ≥ N → |x_n - l| < ε
-/

def lim_to_inf (x : ℕ → ℝ) (l : ℝ) :=
  ∀ ε > 0, ∃ N, ∀ n ≥ N, abs (x n - l) < ε

/-
 Suppose `xₙ ≤ l ≤ yₙ` and the limit of `xₙ - yₙ` is `0` as `n → ∞`. Then we have the limit of `xₙ` is equal to the limit of `yₙ` which equals to `l` as `n → ∞`.
-/

--08 (6 kyu)
theorem exercise_1p2 (x y : ℕ → ℝ) (l : ℝ)
  (h₁ : ∀ n, x n ≤ l ∧ l ≤ y n)
  (h₂ : lim_to_inf (λ n, x n - y n) 0) :
  lim_to_inf x l ∧ lim_to_inf y l :=
begin
 split;
 try {
    intros ε h,
    rcases h₂ ε h with ⟨N,hN⟩,
    use N,
    intros n hn,
    specialize hN n hn,
    specialize h₁ n,
    have := sub_le_sub h₁.1 h₁.2,
    have H : x n - l ≤ y n - x n := by linarith,
    have H' : y n - l ≤ y n - x n := by linarith,
    have hH' : abs (y n - l) ≤ abs (x n - y n),
     simp [←abs_neg (x n - y n)],
     apply abs_le_abs H' _,
     linarith,
    have hH : abs (x n - l) ≤ abs (x n - y n),
     simp [←abs_neg (x n - y n)],
     apply abs_le_abs H _,
     linarith,
    simp at hN,
    linarith
  }
end

/-
 Suppose `|xₙ - l| ≤ yₙ` and `lim_{n → ∞} yₙ = 0`. Then we have `lim_{n → ∞} xₙ = l`.
-/

--09 (7 kyu)
theorem exercise_1p3 (x y : ℕ → ℝ) (l : ℝ)
  (h₁ : ∀ n, abs (x n - l) ≤ y n) (h₂ : lim_to_inf y 0) :
  lim_to_inf x l :=
begin
 intros ε h,
 rcases h₂ ε h with ⟨N,hN⟩,
 use N,
 intros n hn,
 specialize hN n hn,
 specialize h₁ n,
 simp at hN,
 calc abs (x n - l) ≤ y n       : by assumption
                ... ≤ abs (y n) : le_max_left (y n) (-y n)
                ... < ε         : by assumption
end

/-
 Suppose `lim_{n → ∞} xₙ = l`. Then we have `lim_{n → ∞} |xₙ| = |l|`.
-/

--10 (7 kyu)
theorem exercise_1p4 (x : ℕ → ℝ) (l : ℝ) (h₁ : lim_to_inf x l) :
  lim_to_inf (λ n, abs (x n)) (abs l) :=
begin
  intros ε h,
  rcases h₁ ε h with ⟨N,hN⟩,
  use N,
  intros n hn,
  specialize hN n hn,
  dsimp,
  linarith [abs_abs_sub_abs_le_abs_sub (x n) l],
end

/-
 Suppose `lim_{n → ∞} xₙ = l` and `lim_{n → ∞} yₙ = k`, then we have `lim_{n → ∞} max {xₙ, yₙ} = max {l, k}` and `lim_{n → ∞} min {xₙ, yₙ} = min {l, k}`.
-/

--11 (5 kyu)
theorem exercise_1p18 (x y : ℕ → ℝ) (l k : ℝ) (h₁ : lim_to_inf x l)
  (h₂ : lim_to_inf y k)  : lim_to_inf (λ n, max (x n) (y n)) (max l k) ∧
  lim_to_inf (λ n, min (x n) (y n)) (min l k) :=
begin
  split,
   { intros ε hε,
     cases h₁ ε hε with N hN,
     cases h₂ ε hε with N' hN',
     use max N N',
     intros n hn,
     dsimp,
    have HH := abs_max_sub_max_le_max (x n) (y n) l k,
    specialize hN n (by linarith [le_max_left N N']),
    specialize hN' n (by linarith [le_max_right N N']),
    cases max_cases (abs(x n - l)) (abs(y n - k)) with lH rH,
     { calc abs(max (x n) (y n) - max l k) ≤ max (abs(x n - l)) (abs(y n - k)) : HH
                                      ... = abs(x n - l) : lH.1
                                      ... < ε : hN },
     { calc abs(max (x n) (y n) - max l k) ≤ max (abs(x n - l)) (abs(y n - k)) : HH
                                       ... = abs(y n - k) : rH.1
                                       ... < ε : hN' } },
   { intros ε hε,
     cases h₁ ε hε with N hN,
     cases h₂ ε hε with N' hN',
     use max N N',
     intros n hn,
     dsimp,
     have HH := abs_min_sub_min_le_max (x n) (y n) l k,
     specialize hN n (by linarith [le_max_left N N']),
     specialize hN' n (by linarith [le_max_right N N']),
     cases max_cases (abs(x n - l)) (abs(y n - k)) with lH rH,
      { calc abs(min (x n) (y n) - min l k) ≤ max (abs(x n - l)) (abs(y n - k)) : HH
                                        ... = abs (x n - l) : lH.1
                                        ... < ε : hN, },
      { calc abs(min (x n) (y n) - min l k) ≤ max (abs(x n - l)) (abs(y n - k)) : HH
                                        ... = abs (y n - k) : rH.1
                                        ... < ε : hN' } }
end

open set

/-
  Continuous function
  A function f(x) is said to be continuous at x = a if, for any ε > 0,
  there is δ > 0 s.t. |f(x) - f(a)| < ε whenever |x - a| < δ
-/

def continuous_at (f : ℝ → ℝ) (a : ℝ) :=
  ∀ ε > 0, ∃ δ > 0, ∀ x, abs (x - a) < δ → abs (f x - f a) < ε

--13 (6 kyu)
theorem continuous_function_about_an_open_interval {f a}
  (hcont : continuous_at f a) (hgt : f a > 0) :
  ∃ b c : ℝ, a ∈ Ioo b c ∧ ∀ x ∈ Ioo b c, f x > 0 :=
begin
  rcases hcont ((f a)/2) (by linarith) with ⟨δ,hδ,h'⟩,
  use a - δ,
  use a + δ,
  split,
   { exact ⟨sub_lt_self a hδ,lt_add_of_pos_right a hδ⟩ },
   { intros x hx,
     simp [Ioo_def] at hx,
     cases hx,
     have hh : x - a > -δ := by linarith,
     have hh2 : x - a < δ := by linarith,
     have hh3 : abs (x - a) < δ,
      refine max_lt hh2 _,
      exact neg_lt.mp hh,
     specialize h' x (by linarith),
     rw abs_lt at h',
     cases h',
     linarith }
end

def uniform_continuous (f : ℝ → ℝ) :=
  ∀ ε > 0, ∃ δ > 0, ∀ x y, abs (x - y) < δ → abs (f x - f y) < ε

def lipschitz (f : ℝ → ℝ) :=
  ∃ L, ∀ x y, abs (f x - f y) ≤ L * abs (x - y)

-- 15
theorem uniform_continuous_of_lipschitz {f} (hf : lipschitz f) :
  uniform_continuous f :=
begin
  intros ε hε,
  rcases hf with ⟨L,hfl⟩,
  use ε/(L+1),
  have fs := abs_nonneg (f 1 - f 0),
  have nhfl := hfl 1 0,
  simp at nhfl,
  have hs : 0 ≤ L := by linarith,
  have hsl : 0 < L + 1 := by linarith,
  have sf := div_pos hε hsl,
  refine ⟨sf,_⟩,
   { intros x y hxy,
     specialize hfl x y,
     have sd := le_of_lt hxy,
     calc abs (f x - f y) ≤ L * abs (x - y) : hfl
                      ... ≤ L * (ε / (L + 1) ) : mul_le_mul (by refl) sd (abs_nonneg _) hs
                      ... < (L+1) * (ε / (L+1)) : by linarith
                      ... = ε * (L+1)/(L+1) : by ring_nf
                      ... = ε * ((L+1) * (L+1)⁻¹) : by ring_nf
                      ... = ε * 1 : by { refine congr rfl _, refine div_self _, linarith }
                      ... = ε : mul_one _,
      },
end

def bounded' (x : ℕ → ℝ) :=
  ∃ B, ∀ n, abs (x n) ≤ B

-- 16
theorem exercise_1p13 (x y : ℕ → ℝ) (h₁ : lim_to_inf x 0)
  (h₂ : bounded' y) : lim_to_inf (λ n, x n * y n) 0 :=
begin
  intros ε hε,
  cases h₂ with B hB,
  have nh2 := hB 0,
  have pre := abs_nonneg (y 0),
  have nhN : 0 ≤ B := by linarith,
  have prepre := le_of_lt hε,
  have nhN1 : 0 < B+1 := by linarith,
  have pren : ε / (B+1) > 0 := by linarith [div_pos hε nhN1],
  rcases h₁ (ε / (B + 1)) (by linarith) with ⟨N,hN⟩,
  use N,
  intros n hn,
  simp at *,
  specialize hN n hn,
  specialize hB n,
  have nb1 : abs (y n) < B + 1 := by linarith,
  have fs : B < B + 1 := by linarith,
  have nb2 := mul_lt_mul'' hN fs (abs_nonneg _) (by linarith),
  calc abs (x n * y n) = abs (x n) * abs (y n) : abs_mul _ _
                   ... ≤ abs (x n) * B : mul_le_mul (by refl) hB (abs_nonneg _) (abs_nonneg _)
                   ... < (ε / (B+1)) * (B+1) : nb2
                   ... = ε * (B+1)/(B+1) : by ring_nf
                   ... = ε * ((B+1)*(B+1)⁻¹) : by ring_nf
                   ... = ε *1 : by { refine congr rfl _, refine div_self _, linarith }
                   ... = ε : mul_one _,
end


import tactic.tidy tactic.library_search

inductive proposition
| false : proposition
| true : proposition
| atomic : ℕ → proposition
-- | and : proposition → proposition → proposition
| or : proposition → proposition → proposition
| not : proposition → proposition
-- | if_then : proposition → proposition → proposition

-- def proposition.if_then : proposition → proposition → proposition
-- | φ ψ := proposition.or (proposition.not φ) ψ

-- notation p `⇒` q := proposition.if_then p q

-- def proposition.not :  proposition → proposition := λ p, p ⇒ proposition.false

def proposition.and : proposition → proposition → proposition
| φ ψ := proposition.not $ proposition.or (proposition.not φ) (proposition.not ψ)

-- def proposition.iff : proposition → proposition → proposition
-- | φ ψ := proposition.and (φ ⇒ ψ) (ψ ⇒ φ)

def proposition.eval : proposition → (ℕ → bool) → bool
| proposition.false _ := ff
| proposition.true _ := tt
| (proposition.atomic n) f := if f n then tt else ff
-- | (proposition.and φ ψ) f := φ.eval f && ψ.eval f
| (proposition.or φ ψ) f := φ.eval f || ψ.eval f
| (proposition.not φ) f := not (φ.eval f)
-- | (proposition.if_then φ ψ) f := not (φ.eval f) || ψ.eval f

def proposition.appears : proposition → ℕ → bool
| proposition.false _ := ff
| proposition.true  _ := ff
| (proposition.atomic m) n := if n = m then tt else ff
-- | (proposition.and φ ψ) n := φ.appears n || ψ.appears n
| (proposition.or φ ψ) n := φ.appears n || ψ.appears n
| (proposition.not φ) f := φ.appears f
-- | (proposition.if_then φ ψ) n := φ.appears n || ψ.appears n

def theory.appears : list proposition → ℕ → bool
| [] _ :=  ff
| (x::xs) n := x.appears n || theory.appears xs n

lemma theory.exists : ∀ (Γ : list proposition) n,
                      theory.appears Γ n →
                      ∃ φ ∈ Γ, proposition.appears φ n
                      :=
begin
    intros Γ n h,
    induction Γ;
        simp [theory.appears] at h,
        contradiction,
    cases h,
        existsi Γ_hd,
        fsplit, simp,
        assumption,
    obtain ⟨φ, c₁, c₂⟩ := Γ_ih h,
    existsi φ,
    fsplit,
        simp [c₁],
    assumption,
end

def proposition.satisfiable (φ : proposition) :=
    ∃ I : ℕ → bool, φ.eval I

-- This code here actually implements the sat solver...
-- FROM A TACTIC PROOF!!!
instance sat_solver (φ : proposition) : decidable φ.satisfiable :=
let I₁ := λn : ℕ, tt in
begin
    induction φ,
    -- case false
        left,
        intro h,
        obtain ⟨I, c⟩ := h,
        simp [proposition.eval] at c,
        contradiction,
    -- case true
        right,
        existsi I₁,
        simp [proposition.eval],
    -- case atomic
        right,
        existsi I₁,
        simp [proposition.eval],
    -- case and
        -- This is actually hard.
        -- We only managed to prove that if
        -- either side of the conjunction is
        -- unsat, then the conjunction is unsat.
        -- maybe that is why most algorithms assume
        -- that the proposition is on
        -- a particular normal form.
        -- So when we got to this point,
        -- we changed the definition of proposition
        -- to use only ∨ and ¬, which is
        -- functionally complete.

        -- cases φ_ih_a,
        --     left,
        --     intro h,
        --     obtain ⟨I, c⟩ := h,
        --     simp [proposition.eval] at c,
        --     replace c : φ_a.satisfiable := ⟨I,c.1⟩,
        --     contradiction,
        -- cases φ_ih_a_1,
        --     left,
        --     intro h,
        --     obtain ⟨I, c⟩ := h,
        --     simp [proposition.eval] at c,
        --     replace c : φ_a_1.satisfiable := ⟨I,c.2⟩,
        --     contradiction,
    -- case or
        cases φ_ih_a,
            cases φ_ih_a_1,
                left,
                intro h,
                obtain ⟨I, c⟩ := h,
                simp [proposition.eval] at c,
                cases c,
                    replace c : φ_a.satisfiable := ⟨I,c⟩,
                    contradiction,
                replace c : φ_a_1.satisfiable := ⟨I,c⟩,
                contradiction,
            right,
            obtain ⟨I, c⟩ := φ_ih_a_1,
            existsi I,
            simp [proposition.eval],
            right,
            assumption,
        right,
        obtain ⟨I, c⟩ := φ_ih_a,
        existsi I,
        simp [proposition.eval],
        left,
        assumption,
    -- case not
        cases φ_ih,
            right,
            have c := not_exists.mp φ_ih I₁,
            existsi I₁,
            simp [proposition.eval],
            simp at c,
            rw c,
            simp,
        admit,
    -- case if_then
    -- cases φ_ih_a,
    --     right,
    --     existsi I₁,
    --     simp [proposition.eval],
    --     have c := not_exists.mp φ_ih_a I₁,
    --     simp at c,
    --     left,
    --     rw c,
    --     simp,
    -- cases φ_ih_a_1,
    --     left,
    --     intro h,
    --     obtain ⟨I, c⟩ := h,
    --     simp [proposition.eval] at c,
end

def proposition.sat : proposition → bool
| φ := if φ.satisfiable then tt else ff

#reduce proposition.false.sat
#reduce proposition.true.sat
#reduce λ n, (proposition.atomic n).sat
#reduce λ n, (proposition.or (proposition.atomic n) proposition.false).sat
#reduce λ n, (proposition.or (proposition.atomic n) (proposition.not $ proposition.atomic n)).sat
-- #reduce λ n, (proposition.and (proposition.atomic n) (proposition.not $ proposition.atomic n)).sat

def proposition.follows (Γ : list proposition) : proposition → Prop
| φ :=    ∀ (I : ℕ → bool),
          (∀ ψ ∈ Γ, proposition.eval ψ I == tt) →
          φ.eval I == tt

-- instance proposition_decidable (Γ : list proposition) (φ : proposition) :decidable (φ.follows Γ) :=
-- begin
--     induction φ,
--         admit,
--     right,
--     intros I h,
--     refl,
--     by_cases (theory.appears Γ φ) = tt,
--         have c : Prop,
--             obtain ⟨ψ, c₀, c₁⟩ := theory.exists Γ φ h,
--         replace h₂ := h₂ ψ c₀,
--         right,
--         intros I h₂,
--         dsimp [proposition.eval],
--         simp,
--         -- let ψ := proposition.atomic φ,

--         -- induction Γ;
--         --     simp [theory.appears] at h,
--         --     contradiction,

--         -- have c := h ψ h₂,

-- end

-- def proposition.decide : proposition → set proposition → bool
-- | φ Γ := if φ.follows Γ then tt else ff


import Mathlib.Algebra.Group.Basic

section FunctionOperations

  variable {α : Type u} {β : (a : α) → Type v} {γ : Type w}

  instance [∀ a, Add (β a)] : Add ((a : α) → β a) := ⟨λ f g => λ a => f a + g a⟩
  instance [∀ a, Sub (β a)] : Sub ((a : α) → β a) := ⟨λ f g => λ a => f a - g a⟩
  instance [∀ a, Mul (β a)] : Mul ((a : α) → β a) := ⟨λ f g => λ a => f a * g a⟩
  instance [∀ a, Div (β a)] : Div ((a : α) → β a) := ⟨λ f g => λ a => f a / g a⟩

  instance [∀ a, HMul γ (β a) (β a)] : HMul γ ((a : α) → β a) ((a : α) → β a) := ⟨λ c f => λ a => c * (f a)⟩

  instance [∀ a, Neg (β a)] : Neg ((a : α) → β a) := ⟨λ f => λ a => - f a⟩

  instance [∀ a, Zero (β a)] : Zero ((a : α) → β a) := ⟨λ _ => 0⟩
  instance [∀ a, One (β a)] : One ((a : α) → β a) := ⟨λ _ => 1⟩

  variable (f g : (a : α) → β a) (a : α)

  @[simp] theorem fun_zero_eval [∀ a, Zero (β a)] (x : α)
    : (0 : (a : α) → β a) x = (0 : β x) := by simp[OfNat.ofNat, Zero.zero]; done
  @[simp] theorem fun_one_eval [∀ a, One (β a)] (x : α)
    : (1 : (a : α) → β a) x = (1 : β x) := by simp[OfNat.ofNat, One.one]; done

  @[simp] theorem fun_neg_eval [∀ a, Neg (β a)]
    : (-f) a = -(f a) := by simp[Neg.neg]; done
  @[simp] theorem fun_add_eval [∀ a, Add (β a)]
    : (f + g) a = f a + g a := by simp[HAdd.hAdd,Add.add]; done
  @[simp] theorem fun_sub_eval [∀ a, Sub (β a)]
    : (f - g) a = f a - g a := by simp[HSub.hSub,Sub.sub]; done
  @[simp] theorem fun_mul_eval [∀ a, Mul (β a)]
    : (f * g) a = f a * g a := by simp[HMul.hMul,Mul.mul]; done
  @[simp] theorem fun_div_eval [∀ a, Div (β a)]
    : (f / g) a = f a / g a := by simp[HDiv.hDiv,Div.div]; done

  @[simp] theorem fun_hmul_eval [∀ a, HMul γ (β a) (β a)] (c : γ)
    : (c * f) a = c * (f a) := by simp[HMul.hMul]; done

end FunctionOperations


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Justus Springer
-/
import algebraic_geometry.locally_ringed_space
import algebraic_geometry.structure_sheaf
import data.equiv.transfer_instance
import topology.sheaves.sheaf_condition.sites
import topology.sheaves.functors

/-!
# $Spec$ as a functor to locally ringed spaces.

We define the functor $Spec$ from commutative rings to locally ringed spaces.

## Implementation notes

We define $Spec$ in three consecutive steps, each with more structure than the last:

1. `Spec.to_Top`, valued in the category of topological spaces,
2. `Spec.to_SheafedSpace`, valued in the category of sheafed spaces and
3. `Spec.to_LocallyRingedSpace`, valued in the category of locally ringed spaces.

Additionally, we provide `Spec.to_PresheafedSpace` as a composition of `Spec.to_SheafedSpace` with
a forgetful functor.

## Related results

The adjunction `Γ ⊣ Spec` is constructed in `algebraic_geometry/Gamma_Spec_adjunction.lean`.

-/

noncomputable theory
universes u v

namespace algebraic_geometry
open opposite
open category_theory
open structure_sheaf

/--
The spectrum of a commutative ring, as a topological space.
-/
def Spec.Top_obj (R : CommRing) : Top := Top.of (prime_spectrum R)

/--
The induced map of a ring homomorphism on the ring spectra, as a morphism of topological spaces.
-/
def Spec.Top_map {R S : CommRing} (f : R ⟶ S) :
  Spec.Top_obj S ⟶ Spec.Top_obj R :=
prime_spectrum.comap f

@[simp] lemma Spec.Top_map_id (R : CommRing) :
  Spec.Top_map (𝟙 R) = 𝟙 (Spec.Top_obj R) :=
prime_spectrum.comap_id

lemma Spec.Top_map_comp {R S T : CommRing} (f : R ⟶ S) (g : S ⟶ T) :
  Spec.Top_map (f ≫ g) = Spec.Top_map g ≫ Spec.Top_map f :=
prime_spectrum.comap_comp _ _

/--
The spectrum, as a contravariant functor from commutative rings to topological spaces.
-/
@[simps] def Spec.to_Top : CommRingᵒᵖ ⥤ Top :=
{ obj := λ R, Spec.Top_obj (unop R),
  map := λ R S f, Spec.Top_map f.unop,
  map_id' := λ R, by rw [unop_id, Spec.Top_map_id],
  map_comp' := λ R S T f g, by rw [unop_comp, Spec.Top_map_comp] }

/--
The spectrum of a commutative ring, as a `SheafedSpace`.
-/
@[simps] def Spec.SheafedSpace_obj (R : CommRing) : SheafedSpace CommRing :=
{ carrier := Spec.Top_obj R,
  presheaf := (structure_sheaf R).1,
  is_sheaf := (structure_sheaf R).2 }

/--
The induced map of a ring homomorphism on the ring spectra, as a morphism of sheafed spaces.
-/
@[simps] def Spec.SheafedSpace_map {R S : CommRing.{u}} (f : R ⟶ S) :
  Spec.SheafedSpace_obj S ⟶ Spec.SheafedSpace_obj R :=
{ base := Spec.Top_map f,
  c :=
  { app := λ U, comap f (unop U) ((topological_space.opens.map (Spec.Top_map f)).obj (unop U))
      (λ p, id),
    naturality' := λ U V i, ring_hom.ext $ λ s, subtype.eq $ funext $ λ p, rfl } }

@[simp] lemma Spec.SheafedSpace_map_id {R : CommRing} :
  Spec.SheafedSpace_map (𝟙 R) = 𝟙 (Spec.SheafedSpace_obj R) :=
PresheafedSpace.ext _ _ (Spec.Top_map_id R) $ nat_trans.ext _ _ $ funext $ λ U,
begin
  dsimp,
  erw [PresheafedSpace.id_c_app, comap_id], swap,
  { rw [Spec.Top_map_id, topological_space.opens.map_id_obj_unop] },
  simpa,
end

lemma Spec.SheafedSpace_map_comp {R S T : CommRing} (f : R ⟶ S) (g : S ⟶ T) :
  Spec.SheafedSpace_map (f ≫ g) = Spec.SheafedSpace_map g ≫ Spec.SheafedSpace_map f :=
PresheafedSpace.ext _ _ (Spec.Top_map_comp f g) $ nat_trans.ext _ _ $ funext $ λ U,
by { dsimp, rw category_theory.functor.map_id, rw category.comp_id, erw comap_comp f g, refl }

/--
Spec, as a contravariant functor from commutative rings to sheafed spaces.
-/
@[simps] def Spec.to_SheafedSpace : CommRingᵒᵖ ⥤ SheafedSpace CommRing :=
{ obj := λ R, Spec.SheafedSpace_obj (unop R),
  map := λ R S f, Spec.SheafedSpace_map f.unop,
  map_id' := λ R, by rw [unop_id, Spec.SheafedSpace_map_id],
  map_comp' := λ R S T f g, by rw [unop_comp, Spec.SheafedSpace_map_comp] }

/--
Spec, as a contravariant functor from commutative rings to presheafed spaces.
-/
def Spec.to_PresheafedSpace : CommRingᵒᵖ ⥤ PresheafedSpace CommRing :=
  Spec.to_SheafedSpace ⋙ SheafedSpace.forget_to_PresheafedSpace

@[simp] lemma Spec.to_PresheafedSpace_obj (R : CommRingᵒᵖ) :
  Spec.to_PresheafedSpace.obj R = (Spec.SheafedSpace_obj (unop R)).to_PresheafedSpace := rfl

lemma Spec.to_PresheafedSpace_obj_op (R : CommRing) :
  Spec.to_PresheafedSpace.obj (op R) = (Spec.SheafedSpace_obj R).to_PresheafedSpace := rfl

@[simp] lemma Spec.to_PresheafedSpace_map (R S : CommRingᵒᵖ) (f : R ⟶ S) :
  Spec.to_PresheafedSpace.map f = Spec.SheafedSpace_map f.unop := rfl

lemma Spec.to_PresheafedSpace_map_op (R S : CommRing) (f : R ⟶ S) :
  Spec.to_PresheafedSpace.map f.op = Spec.SheafedSpace_map f := rfl

lemma Spec.basic_open_hom_ext {X : RingedSpace} {R : CommRing} {α β : X ⟶ Spec.SheafedSpace_obj R}
  (w : α.base = β.base) (h : ∀ r : R, let U := prime_spectrum.basic_open r in
    (to_open R U ≫ α.c.app (op U)) ≫ X.presheaf.map (eq_to_hom (by rw w)) =
     to_open R U ≫ β.c.app (op U)) : α = β :=
begin
  ext1,
  { apply ((Top.sheaf.pushforward β.base).obj X.sheaf).hom_ext _
      prime_spectrum.is_basis_basic_opens,
    intro r,
    apply (structure_sheaf.to_basic_open_epi R r).1,
    simpa using h r },
  exact w,
end

/--
The spectrum of a commutative ring, as a `LocallyRingedSpace`.
-/
@[simps] def Spec.LocallyRingedSpace_obj (R : CommRing) : LocallyRingedSpace :=
{ local_ring := λ x, @@ring_equiv.local_ring _
    (show local_ring (localization.at_prime _), by apply_instance) _
    (iso.CommRing_iso_to_ring_equiv $ stalk_iso R x).symm,
  .. Spec.SheafedSpace_obj R }

@[elementwise]
lemma stalk_map_to_stalk {R S : CommRing} (f : R ⟶ S) (p : prime_spectrum S) :
  to_stalk R (prime_spectrum.comap f p) ≫
  PresheafedSpace.stalk_map (Spec.SheafedSpace_map f) p =
  f ≫ to_stalk S p :=
begin
  erw [← to_open_germ S ⊤ ⟨p, trivial⟩, ← to_open_germ R ⊤ ⟨prime_spectrum.comap f p, trivial⟩,
    category.assoc, PresheafedSpace.stalk_map_germ (Spec.SheafedSpace_map f) ⊤ ⟨p, trivial⟩,
    Spec.SheafedSpace_map_c_app, to_open_comp_comap_assoc],
  refl
end

/--
Under the isomorphisms `stalk_iso`, the map `stalk_map (Spec.SheafedSpace_map f) p` corresponds
to the induced local ring homomorphism `localization.local_ring_hom`.
-/
@[elementwise]
lemma local_ring_hom_comp_stalk_iso {R S : CommRing} (f : R ⟶ S) (p : prime_spectrum S) :
  (stalk_iso R (prime_spectrum.comap f p)).hom ≫
    @category_struct.comp _ _
      (CommRing.of (localization.at_prime (prime_spectrum.comap f p).as_ideal))
      (CommRing.of (localization.at_prime p.as_ideal)) _
      (localization.local_ring_hom (prime_spectrum.comap f p).as_ideal p.as_ideal f rfl)
      (stalk_iso S p).inv =
  PresheafedSpace.stalk_map (Spec.SheafedSpace_map f) p :=
(stalk_iso R (prime_spectrum.comap f p)).eq_inv_comp.mp $ (stalk_iso S p).comp_inv_eq.mpr $
localization.local_ring_hom_unique _ _ _ _ $ λ x, by
rw [stalk_iso_hom, stalk_iso_inv, comp_apply, comp_apply, localization_to_stalk_of,
  stalk_map_to_stalk_apply, stalk_to_fiber_ring_hom_to_stalk]

/--
The induced map of a ring homomorphism on the prime spectra, as a morphism of locally ringed spaces.
-/
@[simps] def Spec.LocallyRingedSpace_map {R S : CommRing} (f : R ⟶ S) :
  Spec.LocallyRingedSpace_obj S ⟶ Spec.LocallyRingedSpace_obj R :=
subtype.mk (Spec.SheafedSpace_map f) $ λ p, is_local_ring_hom.mk $ λ a ha,
begin
  -- Here, we are showing that the map on prime spectra induced by `f` is really a morphism of
  -- *locally* ringed spaces, i.e. that the induced map on the stalks is a local ring homomorphism.
  rw ← local_ring_hom_comp_stalk_iso_apply at ha,
  replace ha := (stalk_iso S p).hom.is_unit_map ha,
  rw coe_inv_hom_id at ha,
  replace ha := is_local_ring_hom.map_nonunit _ ha,
  convert ring_hom.is_unit_map (stalk_iso R (prime_spectrum.comap f p)).inv ha,
  rw coe_hom_inv_id,
end

@[simp] lemma Spec.LocallyRingedSpace_map_id (R : CommRing) :
  Spec.LocallyRingedSpace_map (𝟙 R) = 𝟙 (Spec.LocallyRingedSpace_obj R) :=
subtype.ext $ by { rw [Spec.LocallyRingedSpace_map_coe, Spec.SheafedSpace_map_id], refl }

lemma Spec.LocallyRingedSpace_map_comp {R S T : CommRing} (f : R ⟶ S) (g : S ⟶ T) :
  Spec.LocallyRingedSpace_map (f ≫ g) =
  Spec.LocallyRingedSpace_map g ≫ Spec.LocallyRingedSpace_map f :=
subtype.ext $ by { rw [Spec.LocallyRingedSpace_map_coe, Spec.SheafedSpace_map_comp], refl }

/--
Spec, as a contravariant functor from commutative rings to locally ringed spaces.
-/
@[simps] def Spec.to_LocallyRingedSpace : CommRingᵒᵖ ⥤ LocallyRingedSpace :=
{ obj := λ R, Spec.LocallyRingedSpace_obj (unop R),
  map := λ R S f, Spec.LocallyRingedSpace_map f.unop,
  map_id' := λ R, by rw [unop_id, Spec.LocallyRingedSpace_map_id],
  map_comp' := λ R S T f g, by rw [unop_comp, Spec.LocallyRingedSpace_map_comp] }

section Spec_Γ
open algebraic_geometry.LocallyRingedSpace

/-- The counit morphism `R ⟶ Γ(Spec R)` given by `algebraic_geometry.structure_sheaf.to_open`.  -/
@[simps] def to_Spec_Γ (R : CommRing) : R ⟶ Γ.obj (op (Spec.to_LocallyRingedSpace.obj (op R))) :=
structure_sheaf.to_open R ⊤

instance is_iso_to_Spec_Γ (R : CommRing) : is_iso (to_Spec_Γ R) :=
by { cases R, apply structure_sheaf.is_iso_to_global }

@[reassoc]
lemma Spec_Γ_naturality {R S : CommRing} (f : R ⟶ S) :
  f ≫ to_Spec_Γ S = to_Spec_Γ R ≫ Γ.map (Spec.to_LocallyRingedSpace.map f.op).op :=
by { ext, symmetry, apply localization.local_ring_hom_to_map }

/-- The counit (`Spec_Γ_identity.inv.op`) of the adjunction `Γ ⊣ Spec` is an isomorphism. -/
@[simps hom_app inv_app] def Spec_Γ_identity : Spec.to_LocallyRingedSpace.right_op ⋙ Γ ≅ 𝟭 _ :=
iso.symm $ nat_iso.of_components (λ R, as_iso (to_Spec_Γ R) : _) (λ _ _, Spec_Γ_naturality)

end Spec_Γ

/-- The stalk map of `Spec M⁻¹R ⟶ Spec R` is an iso for each `p : Spec M⁻¹R`. -/
lemma Spec_map_localization_is_iso (R : CommRing) (M : submonoid R)
  (x : prime_spectrum (localization M)) :
  is_iso (PresheafedSpace.stalk_map (Spec.to_PresheafedSpace.map
    (CommRing.of_hom (algebra_map R (localization M))).op) x) :=
begin
  erw ← local_ring_hom_comp_stalk_iso,
  apply_with is_iso.comp_is_iso { instances := ff },
  apply_instance,
  apply_with is_iso.comp_is_iso { instances := ff },
  /- I do not know why this is defeq to the goal, but I'm happy to accept that it is. -/
  exact (show is_iso (is_localization.localization_localization_at_prime_iso_localization
    M x.as_ideal).to_ring_equiv.to_CommRing_iso.hom, by apply_instance),
  apply_instance
end

end algebraic_geometry


/-
Copyright (c) 2022 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/

import analysis.specific_limits.basic
import analysis.special_functions.pow

/-!
# Results on discretized exponentials

We state several auxiliary results pertaining to sequences of the form `⌊c^n⌋₊`.

* `tendsto_div_of_monotone_of_tendsto_div_floor_pow`: If a monotone sequence `u` is such that
  `u ⌊c^n⌋₊ / ⌊c^n⌋₊` converges to a limit `l` for all `c > 1`, then `u n / n` tends to `l`.
* `sum_div_nat_floor_pow_sq_le_div_sq`: The sum of `1/⌊c^i⌋₊^2` above a threshold `j` is comparable
  to `1/j^2`, up to a multiplicative constant.
-/

open filter finset
open_locale topological_space big_operators

/-- If a monotone sequence `u` is such that `u n / n` tends to a limit `l` along subsequences with
exponential growth rate arbitrarily close to `1`, then `u n / n` tends to `l`. -/
lemma tendsto_div_of_monotone_of_exists_subseq_tendsto_div (u : ℕ → ℝ) (l : ℝ) (hmono : monotone u)
  (hlim : ∀ (a : ℝ), 1 < a → ∃ c : ℕ → ℕ, (∀ᶠ n in at_top, (c (n+1) : ℝ) ≤ a * c n) ∧
    tendsto c at_top at_top ∧ tendsto (λ n, u (c n) / (c n)) at_top (𝓝 l)) :
  tendsto (λ n, u n / n) at_top (𝓝 l) :=
begin
  /- To check the result up to some `ε > 0`, we use a sequence `c` for which the ratio
  `c (N+1) / c N` is bounded by `1 + ε`. Sandwiching a given `n` between two consecutive values of
  `c`, say `c N` and `c (N+1)`, one can then bound `u n / n` from above by `u (c N) / c (N - 1)`
  and from below by `u (c (N - 1)) / c N` (using that `u` is monotone), which are both comparable
  to the limit `l` up to `1 + ε`.
  We give a version of this proof by clearing out denominators first, to avoid discussing the sign
  of different quantities. -/
  have lnonneg : 0 ≤ l,
  { rcases hlim 2 one_lt_two with ⟨c, cgrowth, ctop, clim⟩,
    have : tendsto (λ n, u 0 / (c n)) at_top (𝓝 0) :=
      tendsto_const_nhds.div_at_top (tendsto_coe_nat_at_top_iff.2 ctop),
    apply le_of_tendsto_of_tendsto' this clim (λ n, _),
    simp_rw [div_eq_inv_mul],
    exact mul_le_mul_of_nonneg_left (hmono (zero_le _)) (inv_nonneg.2 (nat.cast_nonneg _)) },
  have A : ∀ (ε : ℝ), 0 < ε → ∀ᶠ n in at_top, u n - n * l ≤ (ε * (1 + ε + l)) * n,
  { assume ε εpos,
    rcases hlim (1 + ε) ((lt_add_iff_pos_right _).2 εpos) with ⟨c, cgrowth, ctop, clim⟩,
    have L : ∀ᶠ n in at_top, u (c n) - c n * l ≤ ε * c n,
    { rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ,
          asymptotics.is_o_iff] at clim,
      filter_upwards [clim εpos, ctop (Ioi_mem_at_top 0)] with n hn cnpos',
      have cnpos : 0 < c n := cnpos',
      calc u (c n) - c n * l
      = (u (c n) / c n - l) * c n:
        by simp only [cnpos.ne', ne.def, nat.cast_eq_zero, not_false_iff] with field_simps
      ... ≤ ε * c n :
        begin
          apply mul_le_mul_of_nonneg_right _ (nat.cast_nonneg _),
          simp only [mul_one, real.norm_eq_abs, abs_one] at hn,
          exact le_trans (le_abs_self _) hn,
        end },
    obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), a ≤ b → (c (b + 1) : ℝ) ≤ (1 + ε) * c b
        ∧ u (c b) - c b * l ≤ ε * c b := eventually_at_top.1 (cgrowth.and L),
    let M := ((finset.range (a+1)).image (λ i, c i)).max' (by simp),
    filter_upwards [Ici_mem_at_top M] with n hn,
    have exN : ∃ N, n < c N,
    { rcases (tendsto_at_top.1 ctop (n+1)).exists with ⟨N, hN⟩,
      exact ⟨N, by linarith only [hN]⟩ },
    let N := nat.find exN,
    have ncN : n < c N := nat.find_spec exN,
    have aN : a + 1 ≤ N,
    { by_contra' h,
      have cNM : c N ≤ M,
      { apply le_max',
        apply mem_image_of_mem,
        exact mem_range.2 h },
      exact lt_irrefl _ ((cNM.trans hn).trans_lt ncN) },
    have Npos : 0 < N := lt_of_lt_of_le (nat.succ_pos') aN,
    have cNn : c (N - 1) ≤ n,
    { have : N - 1 < N := nat.pred_lt Npos.ne',
      simpa only [not_lt] using nat.find_min exN this },
    have IcN : (c N : ℝ) ≤ (1 + ε) * (c (N - 1)),
    { have A : a ≤ N - 1, by linarith only [aN, Npos],
      have B : N - 1 + 1 = N := nat.succ_pred_eq_of_pos Npos,
      have := (ha _ A).1,
      rwa B at this },
    calc u n - n * l ≤ u (c N) - c (N - 1) * l :
      begin
        apply sub_le_sub (hmono ncN.le),
        apply mul_le_mul_of_nonneg_right (nat.cast_le.2 cNn) lnonneg,
      end
    ... = (u (c N) - c N * l) + (c N - c (N - 1)) * l : by ring
    ... ≤ ε * c N + (ε * c (N - 1)) * l :
      begin
        apply add_le_add,
        { apply (ha _ _).2,
          exact le_trans (by simp only [le_add_iff_nonneg_right, zero_le']) aN },
        { apply mul_le_mul_of_nonneg_right _ lnonneg,
          linarith only [IcN] },
      end
    ... ≤ ε * ((1 + ε) * c (N-1)) + (ε * c (N - 1)) * l :
      add_le_add (mul_le_mul_of_nonneg_left IcN εpos.le) le_rfl
    ... = (ε * (1 + ε + l)) * c (N - 1) : by ring
    ... ≤ (ε * (1 + ε + l)) * n :
      begin
        refine mul_le_mul_of_nonneg_left (nat.cast_le.2 cNn) _,
        apply mul_nonneg εpos.le,
        linarith only [εpos, lnonneg]
      end },
  have B : ∀ (ε : ℝ), 0 < ε → ∀ᶠ (n : ℕ) in at_top, (n : ℝ) * l - u n ≤ (ε * (1 + l)) * n,
  { assume ε εpos,
    rcases hlim (1 + ε) ((lt_add_iff_pos_right _).2 εpos) with ⟨c, cgrowth, ctop, clim⟩,
    have L : ∀ᶠ (n : ℕ) in at_top, (c n : ℝ) * l - u (c n) ≤ ε * c n,
    { rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ,
          asymptotics.is_o_iff] at clim,
      filter_upwards [clim εpos, ctop (Ioi_mem_at_top 0)] with n hn cnpos',
      have cnpos : 0 < c n := cnpos',
      calc (c n : ℝ) * l - u (c n)
      = -(u (c n) / c n - l) * c n:
        by simp only [cnpos.ne', ne.def, nat.cast_eq_zero, not_false_iff, neg_sub] with field_simps
      ... ≤ ε * c n :
        begin
          apply mul_le_mul_of_nonneg_right _ (nat.cast_nonneg _),
          simp only [mul_one, real.norm_eq_abs, abs_one] at hn,
          exact le_trans (neg_le_abs_self _) hn,
        end },
    obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), a ≤ b → (c (b + 1) : ℝ) ≤ (1 + ε) * c b
        ∧ (c b : ℝ) * l - u (c b) ≤ ε * c b := eventually_at_top.1 (cgrowth.and L),
    let M := ((finset.range (a+1)).image (λ i, c i)).max' (by simp),
    filter_upwards [Ici_mem_at_top M] with n hn,
    have exN : ∃ N, n < c N,
    { rcases (tendsto_at_top.1 ctop (n+1)).exists with ⟨N, hN⟩,
      exact ⟨N, by linarith only [hN]⟩ },
    let N := nat.find exN,
    have ncN : n < c N := nat.find_spec exN,
    have aN : a + 1 ≤ N,
    { by_contra' h,
      have cNM : c N ≤ M,
      { apply le_max',
        apply mem_image_of_mem,
        exact mem_range.2 h },
      exact lt_irrefl _ ((cNM.trans hn).trans_lt ncN) },
    have Npos : 0 < N := lt_of_lt_of_le (nat.succ_pos') aN,
    have aN' : a ≤ N - 1 := by linarith only [aN, Npos],
    have cNn : c (N - 1) ≤ n,
    { have : N - 1 < N := nat.pred_lt Npos.ne',
      simpa only [not_lt] using nat.find_min exN this },
    calc (n : ℝ) * l - u n ≤ c N * l - u (c (N - 1)) :
      begin
        refine add_le_add (mul_le_mul_of_nonneg_right (nat.cast_le.2 ncN.le) lnonneg) _,
        exact neg_le_neg (hmono cNn),
      end
    ... ≤ ((1 + ε) * c (N - 1)) * l - u (c (N - 1)) :
      begin
        refine add_le_add (mul_le_mul_of_nonneg_right _ lnonneg) le_rfl,
        have B : N - 1 + 1 = N := nat.succ_pred_eq_of_pos Npos,
        have := (ha _ aN').1,
        rwa B at this,
      end
    ... = (c (N - 1) * l - u (c (N - 1))) + ε * c (N - 1) * l : by ring
    ... ≤ ε * c (N - 1) + ε * c (N - 1) * l :
      add_le_add (ha _ aN').2 le_rfl
    ... = (ε * (1 + l)) * c (N - 1) : by ring
    ... ≤ (ε * (1 + l)) * n :
      begin
        refine mul_le_mul_of_nonneg_left (nat.cast_le.2 cNn) _,
        exact mul_nonneg (εpos.le) (add_nonneg zero_le_one lnonneg),
      end },
  refine tendsto_order.2 ⟨λ d hd, _, λ d hd, _⟩,
  { obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ), d + ε * (1 + l) < l ∧ 0 < ε,
    { have L : tendsto (λ ε, d + (ε * (1 + l))) (𝓝[>] 0) (𝓝 (d + 0 * (1 + l))),
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        exact tendsto_const_nhds.add (tendsto_id.mul tendsto_const_nhds) },
      simp only [zero_mul, add_zero] at L,
      exact (((tendsto_order.1 L).2 l hd).and (self_mem_nhds_within)).exists },
    filter_upwards [B ε εpos, Ioi_mem_at_top 0] with n hn npos,
    simp_rw [div_eq_inv_mul],
    calc d < (n⁻¹ * n) * (l - ε * (1 + l)) :
      begin
        rw [inv_mul_cancel, one_mul],
        { linarith only [hε] },
        { exact nat.cast_ne_zero.2 (ne_of_gt npos) }
      end
    ... = n⁻¹ * (n * l - ε * (1 + l) * n) : by ring
    ... ≤ n⁻¹ * u n :
      begin
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (nat.cast_nonneg _)),
        linarith only [hn],
      end },
  { obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ), l + ε * (1 + ε + l) < d ∧ 0 < ε,
    { have L : tendsto (λ ε, l + (ε * (1 + ε + l))) (𝓝[>] 0) (𝓝 (l + 0 * (1 + 0 + l))),
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        exact tendsto_const_nhds.add
          (tendsto_id.mul ((tendsto_const_nhds.add tendsto_id).add tendsto_const_nhds)) },
      simp only [zero_mul, add_zero] at L,
      exact (((tendsto_order.1 L).2 d hd).and (self_mem_nhds_within)).exists },
    filter_upwards [A ε εpos, Ioi_mem_at_top 0] with n hn npos,
    simp_rw [div_eq_inv_mul],
    calc (n : ℝ)⁻¹ * u n ≤ (n : ℝ)⁻¹ * (n * l + ε * (1 + ε + l) * n) :
      begin
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (nat.cast_nonneg _)),
        linarith only [hn],
      end
    ... = ((n : ℝ) ⁻¹ * n) * (l + ε * (1 + ε + l)) : by ring
    ... < d :
      begin
        rwa [inv_mul_cancel, one_mul],
        exact nat.cast_ne_zero.2 (ne_of_gt npos),
      end }
end

/-- If a monotone sequence `u` is such that `u ⌊c^n⌋₊ / ⌊c^n⌋₊` converges to a limit `l` for all
`c > 1`, then `u n / n` tends to `l`. It is even enough to have the assumption for a sequence of
`c`s converging to `1`. -/
lemma tendsto_div_of_monotone_of_tendsto_div_floor_pow
  (u : ℕ → ℝ) (l : ℝ) (hmono : monotone u)
  (c : ℕ → ℝ) (cone : ∀ k, 1 < c k) (clim : tendsto c at_top (𝓝 1))
  (hc : ∀ k, tendsto (λ (n : ℕ), u (⌊(c k) ^ n⌋₊) / ⌊(c k)^n⌋₊) at_top (𝓝 l)) :
  tendsto (λ n, u n / n) at_top (𝓝 l) :=
begin
  apply tendsto_div_of_monotone_of_exists_subseq_tendsto_div u l hmono,
  assume a ha,
  obtain ⟨k, hk⟩ : ∃ k, c k < a := ((tendsto_order.1 clim).2 a ha).exists,
  refine ⟨λ n, ⌊(c k)^n⌋₊, _,
    tendsto_nat_floor_at_top.comp (tendsto_pow_at_top_at_top_of_one_lt (cone k)), hc k⟩,
  have H : ∀ (n : ℕ), (0 : ℝ) < ⌊c k ^ n⌋₊,
  { assume n,
    refine zero_lt_one.trans_le _,
    simp only [nat.one_le_cast, nat.one_le_floor_iff, one_le_pow_of_one_le (cone k).le n] },
  have A : tendsto (λ (n : ℕ), ((⌊c k ^ (n+1)⌋₊ : ℝ) / c k ^ (n+1)) * c k /
    (⌊c k ^ n⌋₊ / c k ^ n)) at_top (𝓝 (1 * c k / 1)),
  { refine tendsto.div (tendsto.mul _ tendsto_const_nhds) _ one_ne_zero,
    { refine tendsto_nat_floor_div_at_top.comp _,
      exact (tendsto_pow_at_top_at_top_of_one_lt (cone k)).comp (tendsto_add_at_top_nat 1) },
    { refine tendsto_nat_floor_div_at_top.comp _,
      exact tendsto_pow_at_top_at_top_of_one_lt (cone k) } },
  have B : tendsto (λ (n : ℕ), (⌊c k ^ (n+1)⌋₊ : ℝ) / ⌊c k ^ n⌋₊) at_top (𝓝 (c k)),
  { simp only [one_mul, div_one] at A,
    convert A,
    ext1 n,
    simp only [(zero_lt_one.trans (cone k)).ne', ne.def, not_false_iff, (H n).ne']
      with field_simps {discharger := tactic.field_simp.ne_zero},
    ring_exp },
  filter_upwards [(tendsto_order.1 B).2 a hk] with n hn,
  exact (div_le_iff (H n)).1 hn.le
end

/-- The sum of `1/(c^i)^2` above a threshold `j` is comparable to `1/j^2`, up to a multiplicative
constant. -/
lemma sum_div_pow_sq_le_div_sq (N : ℕ) {j : ℝ} (hj : 0 < j) {c : ℝ} (hc : 1 < c) :
  ∑ i in (range N).filter (λ i, j < c ^ i), 1 / (c ^ i) ^ 2 ≤ (c^3 * (c - 1) ⁻¹) / j ^ 2 :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  have A : 0 < (c⁻¹) ^ 2 := sq_pos_of_pos (inv_pos.2 cpos),
  have B : c^2 * (1 - c⁻¹ ^ 2) ⁻¹ ≤ c^3 * (c - 1) ⁻¹,
  { rw [← div_eq_mul_inv, ← div_eq_mul_inv, div_le_div_iff _ (sub_pos.2 hc)], swap,
    { exact sub_pos.2 (pow_lt_one (inv_nonneg.2 cpos.le) (inv_lt_one hc) two_ne_zero) },
    have : c ^ 3 = c^2 * c, by ring_exp,
    simp only [mul_sub, this, mul_one, inv_pow, sub_le_sub_iff_left],
    rw [mul_assoc, mul_comm c, ← mul_assoc, mul_inv_cancel (sq_pos_of_pos cpos).ne', one_mul],
    simpa using pow_le_pow hc.le one_le_two },
  calc
  ∑ i in (range N).filter (λ i, j < c ^ i), 1/ (c ^ i) ^ 2
    ≤ ∑ i in Ico (⌊real.log j / real.log c⌋₊) N, 1 / (c ^ i) ^ 2 :
  begin
    refine sum_le_sum_of_subset_of_nonneg _ (λ i hi hident, div_nonneg zero_le_one (sq_nonneg _)),
    assume i hi,
    simp only [mem_filter, mem_range] at hi,
    simp only [hi.1, mem_Ico, and_true],
    apply nat.floor_le_of_le,
    apply le_of_lt,
    rw [div_lt_iff (real.log_pos hc), ← real.log_pow],
    exact real.log_lt_log hj hi.2
  end
  ... = ∑ i in Ico (⌊real.log j / real.log c⌋₊) N, ((c⁻¹) ^ 2) ^ i :
  begin
    congr' 1 with i,
    simp [← pow_mul, mul_comm],
  end
  ... ≤ ((c⁻¹) ^ 2) ^ (⌊real.log j / real.log c⌋₊) / (1 - (c⁻¹) ^ 2) :
  begin
    apply geom_sum_Ico_le_of_lt_one (sq_nonneg _),
    rw sq_lt_one_iff (inv_nonneg.2 (zero_le_one.trans hc.le)),
    exact inv_lt_one hc
  end
  ... ≤ ((c⁻¹) ^ 2) ^ (real.log j / real.log c - 1) / (1 - (c⁻¹) ^ 2) :
  begin
    apply div_le_div _ _ _ le_rfl,
    { apply real.rpow_nonneg_of_nonneg (sq_nonneg _) },
    { rw ← real.rpow_nat_cast,
      apply real.rpow_le_rpow_of_exponent_ge A,
      { exact pow_le_one _ (inv_nonneg.2 (zero_le_one.trans hc.le)) (inv_le_one hc.le) },
      { exact (nat.sub_one_lt_floor _).le } },
    { simpa only [inv_pow, sub_pos] using inv_lt_one (one_lt_pow hc two_ne_zero) }
  end
  ... = (c^2 * (1 - c⁻¹ ^ 2) ⁻¹) / j ^ 2 :
  begin
    have I : (c ⁻¹ ^ 2) ^ (real.log j / real.log c) = 1 / j ^ 2,
    { apply real.log_inj_on_pos (real.rpow_pos_of_pos A _),
      { rw [one_div], exact inv_pos.2 (sq_pos_of_pos hj) },
      rw real.log_rpow A,
      simp only [one_div, real.log_inv, real.log_pow, nat.cast_bit0, nat.cast_one, mul_neg,
        neg_inj],
      field_simp [(real.log_pos hc).ne'],
      ring },
    rw [real.rpow_sub A, I],
    have : c^2 - 1 ≠ 0 := (sub_pos.2 (one_lt_pow hc two_ne_zero)).ne',
    field_simp [hj.ne', (zero_lt_one.trans hc).ne'],
    ring,
  end
  ... ≤ (c^3 * (c - 1) ⁻¹) / j ^ 2 :
  begin
    apply div_le_div _ B (sq_pos_of_pos hj) le_rfl,
    exact mul_nonneg (pow_nonneg cpos.le _) (inv_nonneg.2 (sub_pos.2 hc).le),
  end
end

lemma mul_pow_le_nat_floor_pow {c : ℝ} (hc : 1 < c) (i : ℕ) :
  (1 - c⁻¹) * c ^ i ≤ ⌊c ^ i⌋₊ :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  rcases nat.eq_zero_or_pos i with rfl|hi,
  { simp only [pow_zero, nat.floor_one, nat.cast_one, mul_one, sub_le_self_iff, inv_nonneg,
      cpos.le] },
  have hident : 1 ≤ i := hi,
  calc (1 - c⁻¹) * c ^ i
      = c ^ i - c ^ i * c ⁻¹ : by ring
  ... ≤ c ^ i - 1 :
    by simpa only [←div_eq_mul_inv, sub_le_sub_iff_left, one_le_div cpos, pow_one]
      using pow_le_pow hc.le hident
  ... ≤ ⌊c ^ i⌋₊ : (nat.sub_one_lt_floor _).le
end

/-- The sum of `1/⌊c^i⌋₊^2` above a threshold `j` is comparable to `1/j^2`, up to a multiplicative
constant. -/
lemma sum_div_nat_floor_pow_sq_le_div_sq (N : ℕ) {j : ℝ} (hj : 0 < j) {c : ℝ} (hc : 1 < c) :
  ∑ i in (range N).filter (λ i, j < ⌊c ^ i⌋₊), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2
    ≤ (c ^ 5 * (c - 1) ⁻¹ ^ 3) / j ^ 2 :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  have A : 0 < 1 - c⁻¹ := sub_pos.2 (inv_lt_one hc),
  calc
  ∑ i in (range N).filter (λ i, j < ⌊c ^ i⌋₊), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2
      ≤ ∑ i in (range N).filter (λ i, j < c ^ i), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2 :
  begin
    apply sum_le_sum_of_subset_of_nonneg,
    { assume i hi,
      simp only [mem_filter, mem_range] at hi,
      simpa only [hi.1, mem_filter, mem_range, true_and]
        using hi.2.trans_le (nat.floor_le (pow_nonneg cpos.le _)) },
    { assume i hi hident,
      exact div_nonneg zero_le_one (sq_nonneg _), }
  end
  ... ≤ ∑ i in (range N).filter (λ i, j < c ^ i), ((1 - c⁻¹) ⁻¹) ^ 2 * (1 / (c ^ i) ^ 2) :
  begin
    apply sum_le_sum (λ i hi, _),
    rw [mul_div_assoc', mul_one, div_le_div_iff], rotate,
    { apply sq_pos_of_pos,
      refine zero_lt_one.trans_le _,
      simp only [nat.le_floor, one_le_pow_of_one_le, hc.le, nat.one_le_cast, nat.cast_one] },
    { exact sq_pos_of_pos (pow_pos cpos _) },
    rw [one_mul, ← mul_pow],
    apply pow_le_pow_of_le_left (pow_nonneg cpos.le _),
    rw [← div_eq_inv_mul, le_div_iff A, mul_comm],
    exact mul_pow_le_nat_floor_pow hc i,
  end
  ... ≤ ((1 - c⁻¹) ⁻¹) ^ 2 * (c^3 * (c - 1) ⁻¹) / j ^ 2 :
  begin
    rw [← mul_sum, ← mul_div_assoc'],
    refine mul_le_mul_of_nonneg_left _ (sq_nonneg _),
    exact sum_div_pow_sq_le_div_sq N hj hc,
  end
  ... = (c ^ 5 * (c - 1) ⁻¹ ^ 3) / j ^ 2 :
  begin
    congr' 1,
    field_simp [cpos.ne', (sub_pos.2 hc).ne'],
    ring,
  end
end


/-
Copyright (c) 2022 David Kurniadi Angdinata. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Kurniadi Angdinata
-/

import algebraic_geometry.elliptic_curve.weierstrass
import field_theory.galois -- temporary import to enable point notation
import ring_theory.class_group

/-!
# The group of nonsingular rational points on a Weierstrass curve over a field

This file defines the type of nonsingular rational points on a Weierstrass curve over a field and
(TODO) proves that it forms an abelian group under a geometric secant-and-tangent process.

## Mathematical background

Let `W` be a Weierstrass curve over a field `F`. A rational point on `W` is simply a point
$[A:B:C]$ defined over `F` in the projective plane satisfying the homogeneous cubic equation
$B^2C + a_1ABC + a_3BC^2 = A^3 + a_2A^2C + a_4AC^2 + a_6C^3$. Any such point either lies in the
affine chart $C \ne 0$ and satisfies the Weierstrass equation obtained by setting $X := A/C$ and
$Y := B/C$, or is the unique point at infinity $0 := [0:1:0]$ when $C = 0$. With this new
description, a nonsingular rational point on `W` is either $0$ or an affine point $(x, y)$ where
the partial derivatives $W_X(X, Y)$ and $W_Y(X, Y)$ do not vanish simultaneously. For a field
extension `K` of `F`, a `K`-rational point is simply a rational point on `W` base changed to `K`.

The set of nonsingular rational points forms an abelian group under a secant-and-tangent process.
 * The identity rational point is `0`.
 * Given a nonsingular rational point `P`, its negation `-P` is defined to be the unique third
    point of intersection between `W` and the line through `0` and `P`.
    Explicitly, if `P` is $(x, y)$, then `-P` is $(x, -y - a_1x - a_3)$.
 * Given two points `P` and `Q`, their addition `P + Q` is defined to be the negation of the unique
    third point of intersection between `W` and the line `L` through `P` and `Q`.
    Explicitly, let `P` be $(x_1, y_1)$ and let `Q` be $(x_2, y_2)$.
      * If $x_1 = x_2$ and $y_1 = -y_2 - a_1x_2 - a_3$, then `L` is vertical and `P + Q` is `0`.
      * If $x_1 = x_2$ and $y_1 \ne -y_2 - a_1x_2 - a_3$, then `L` is the tangent of `W` at `P = Q`,
        and has slope $\ell := (3x_1^2 + 2a_2x_1 + a_4 - a_1y_1) / (2y_1 + a_1x_1 + a_3)$.
      * Otherwise $x_1 \ne x_2$, then `L` is the secant of `W` through `P` and `Q`, and has slope
        $\ell := (y_1 - y_2) / (x_1 - x_2)$.
    In the latter two cases, the $X$-coordinate of `P + Q` is then the unique third solution of the
    equation obtained by substituting the line $Y = \ell(X - x_1) + y_1$ into the Weierstrass
    equation, and can be written down explicitly as $x := \ell^2 + a_1\ell - a_2 - x_1 - x_2$ by
    inspecting the $X^2$ terms. The $Y$-coordinate of `P + Q`, after applying the final negation
    that maps $Y$ to $-Y - a_1X - a_3$, is precisely $y := -(\ell(x - x_1) + y_1) - a_1x - a_3$.
The group law on this set is then uniquely determined by these constructions.

## Main definitions

 * `weierstrass_curve.point`: the type of nonsingular rational points on a Weierstrass curve `W`.
 * `weierstrass_curve.point.add`: the addition of two nonsingular rational points on `W`.

## Main statements

 * TODO: the addition of two nonsingular rational points on `W` forms a group.

## Notations

 * `W⟮K⟯`: the group of nonsingular rational points on a Weierstrass curve `W` base changed to `K`.

## References

[J Silverman, *The Arithmetic of Elliptic Curves*][silverman2009]

## Tags

elliptic curve, rational point, group law
-/

private meta def map_simp : tactic unit :=
`[simp only [map_one, map_bit0, map_bit1, map_neg, map_add, map_sub, map_mul, map_pow, map_div₀]]

private meta def eval_simp : tactic unit :=
`[simp only [eval_C, eval_X, eval_neg, eval_add, eval_sub, eval_mul, eval_pow]]

private meta def C_simp : tactic unit :=
`[simp only [C_1, C_bit0, C_bit1, C_neg, C_add, C_sub, C_mul, C_pow]]

private meta def derivative_simp : tactic unit :=
`[simp only [derivative_C, derivative_X, derivative_X_pow, derivative_neg, derivative_add,
             derivative_sub, derivative_mul, derivative_sq]]

universes u v w

namespace weierstrass_curve

open polynomial

open_locale polynomial polynomial_polynomial

section basic

/-! ### Polynomials associated to nonsingular rational points on a Weierstrass curve -/

variables {R : Type u} [comm_ring R] (W : weierstrass_curve R) (A : Type v) [comm_ring A]
  [algebra R A] (B : Type w) [comm_ring B] [algebra R B] [algebra A B] [is_scalar_tower R A B]
  (x₁ x₂ y₁ y₂ L : R)

/-- The polynomial $-Y - a_1X - a_3$ associated to negation. -/
noncomputable def neg_polynomial : R[X][Y] := -Y - C (C W.a₁ * X + C W.a₃)

/-- The $Y$-coordinate of the negation of an affine point in `W`.

This depends on `W`, and has argument order: $x_1$, $y_1$. -/
@[simp] def neg_Y : R := -y₁ - W.a₁ * x₁ - W.a₃

lemma neg_Y_neg_Y : W.neg_Y x₁ (W.neg_Y x₁ y₁) = y₁ := by { simp only [neg_Y], ring1 }

lemma base_change_neg_Y :
  (W.base_change A).neg_Y (algebra_map R A x₁) (algebra_map R A y₁)
    = algebra_map R A (W.neg_Y x₁ y₁) :=
by { simp only [neg_Y], map_simp, refl }

lemma base_change_neg_Y_of_base_change (x₁ y₁ : A) :
  (W.base_change B).neg_Y (algebra_map A B x₁) (algebra_map A B y₁)
    = algebra_map A B ((W.base_change A).neg_Y x₁ y₁) :=
by rw [← base_change_neg_Y, base_change_base_change]

@[simp] lemma eval_neg_polynomial : (W.neg_polynomial.eval $ C y₁).eval x₁ = W.neg_Y x₁ y₁ :=
by { rw [neg_Y, sub_sub, neg_polynomial], eval_simp }

/-- The polynomial $L(X - x_1) + y_1$ associated to the line $Y = L(X - x_1) + y_1$,
with a slope of $L$ that passes through an affine point $(x_1, y_1)$.

This does not depend on `W`, and has argument order: $x_1$, $y_1$, $L$. -/
noncomputable def line_polynomial : R[X] := C L * (X - C x₁) + C y₁

/-- The polynomial obtained by substituting the line $Y = L(X - x_1) + y_1$, with a slope of $L$
that passes through an affine point $(x_1, y_1)$, into the polynomial $W(X, Y)$ associated to `W`.
If such a line intersects `W` at another point $(x_2, y_2)$, then the roots of this polynomial are
precisely $x_1$, $x_2$, and the $X$-coordinate of the addition of $(x_1, y_1)$ and $(x_2, y_2)$.

This depends on `W`, and has argument order: $x_1$, $y_1$, $L$. -/
noncomputable def add_polynomial : R[X] := W.polynomial.eval $ line_polynomial x₁ y₁ L

lemma add_polynomial_eq : W.add_polynomial x₁ y₁ L = -cubic.to_poly
  ⟨1, -L ^ 2 - W.a₁ * L + W.a₂,
    2 * x₁ * L ^ 2 + (W.a₁ * x₁ - 2 * y₁ - W.a₃) * L + (-W.a₁ * y₁ + W.a₄),
    -x₁ ^ 2 * L ^ 2 + (2 * x₁ * y₁ + W.a₃ * x₁) * L - (y₁ ^ 2 + W.a₃ * y₁ - W.a₆)⟩ :=
by { rw [add_polynomial, line_polynomial, weierstrass_curve.polynomial, cubic.to_poly], eval_simp,
     C_simp, ring1 }

/-- The $X$-coordinate of the addition of two affine points $(x_1, y_1)$ and $(x_2, y_2)$ in `W`,
where the line through them is not vertical and has a slope of $L$.

This depends on `W`, and has argument order: $x_1$, $x_2$, $L$. -/
@[simp] def add_X : R := L ^ 2 + W.a₁ * L - W.a₂ - x₁ - x₂

lemma base_change_add_X :
  (W.base_change A).add_X (algebra_map R A x₁) (algebra_map R A x₂) (algebra_map R A L)
    = algebra_map R A (W.add_X x₁ x₂ L) :=
by { simp only [add_X], map_simp, refl }

lemma base_change_add_X_of_base_change (x₁ x₂ L : A) :
  (W.base_change B).add_X (algebra_map A B x₁) (algebra_map A B x₂) (algebra_map A B L)
    = algebra_map A B ((W.base_change A).add_X x₁ x₂ L) :=
by rw [← base_change_add_X, base_change_base_change]

/-- The $Y$-coordinate, before applying the final negation, of the addition of two affine points
$(x_1, y_1)$ and $(x_2, y_2)$, where the line through them is not vertical and has a slope of $L$.

This depends on `W`, and has argument order: $x_1$, $x_2$, $y_1$, $L$. -/
@[simp] def add_Y' : R := L * (W.add_X x₁ x₂ L - x₁) + y₁

lemma base_change_add_Y' :
  (W.base_change A).add_Y' (algebra_map R A x₁) (algebra_map R A x₂) (algebra_map R A y₁)
    (algebra_map R A L) = algebra_map R A (W.add_Y' x₁ x₂ y₁ L) :=
by { simp only [add_Y', base_change_add_X], map_simp }

lemma base_change_add_Y'_of_base_change (x₁ x₂ y₁ L : A) :
  (W.base_change B).add_Y' (algebra_map A B x₁) (algebra_map A B x₂) (algebra_map A B y₁)
    (algebra_map A B L) = algebra_map A B ((W.base_change A).add_Y' x₁ x₂ y₁ L) :=
by rw [← base_change_add_Y', base_change_base_change]

/-- The $Y$-coordinate of the addition of two affine points $(x_1, y_1)$ and $(x_2, y_2)$ in `W`,
where the line through them is not vertical and has a slope of $L$.

This depends on `W`, and has argument order: $x_1$, $x_2$, $y_1$, $L$. -/
@[simp] def add_Y : R := W.neg_Y (W.add_X x₁ x₂ L) (W.add_Y' x₁ x₂ y₁ L)

lemma base_change_add_Y :
  (W.base_change A).add_Y (algebra_map R A x₁) (algebra_map R A x₂) (algebra_map R A y₁)
    (algebra_map R A L) = algebra_map R A (W.add_Y x₁ x₂ y₁ L) :=
by simp only [add_Y, base_change_add_Y', base_change_add_X, base_change_neg_Y]

lemma base_change_add_Y_of_base_change (x₁ x₂ y₁ L : A) :
  (W.base_change B).add_Y (algebra_map A B x₁) (algebra_map A B x₂) (algebra_map A B y₁)
    (algebra_map A B L) = algebra_map A B ((W.base_change A).add_Y x₁ x₂ y₁ L) :=
by rw [← base_change_add_Y, base_change_base_change]

lemma equation_add_iff :
  W.equation (W.add_X x₁ x₂ L) (W.add_Y' x₁ x₂ y₁ L)
    ↔ (W.add_polynomial x₁ y₁ L).eval (W.add_X x₁ x₂ L) = 0 :=
by { rw [equation, add_Y', add_polynomial, line_polynomial, weierstrass_curve.polynomial],
     eval_simp }

lemma nonsingular_add_of_eval_derivative_ne_zero
  (hx' : W.equation (W.add_X x₁ x₂ L) (W.add_Y' x₁ x₂ y₁ L))
  (hx : (derivative $ W.add_polynomial x₁ y₁ L).eval (W.add_X x₁ x₂ L) ≠ 0) :
  W.nonsingular (W.add_X x₁ x₂ L) (W.add_Y' x₁ x₂ y₁ L) :=
begin
  rw [nonsingular, and_iff_right hx', add_Y', polynomial_X, polynomial_Y],
  eval_simp,
  contrapose! hx,
  rw [add_polynomial, line_polynomial, weierstrass_curve.polynomial],
  eval_simp,
  derivative_simp,
  simp only [zero_add, add_zero, sub_zero, zero_mul, mul_one],
  eval_simp,
  linear_combination hx.left + L * hx.right with { normalization_tactic := `[norm_num1, ring1] }
end

/-! ### The type of nonsingular rational points on a Weierstrass curve -/

/-- A nonsingular rational point on a Weierstrass curve `W` over `R`. This is either the point at
infinity `weierstrass_curve.point.zero` or an affine point `weierstrass_curve.point.some` $(x, y)$
satisfying the equation $y^2 + a_1xy + a_3y = x^3 + a_2x^2 + a_4x + a_6$ of `W`. For an algebraic
extension `S` of `R`, the type of nonsingular `S`-rational points on `W` is denoted `W⟮S⟯`. -/
inductive point
| zero
| some {x y : R} (h : W.nonsingular x y)

localized "notation W⟮S⟯ := (W.base_change S).point" in weierstrass_curve

namespace point

instance : inhabited W.point := ⟨zero⟩

instance : has_zero W.point := ⟨zero⟩

@[simp] lemma zero_def : (zero : W.point) = 0 := rfl

end point

variables {W x₁ y₁}

lemma equation_neg_iff : W.equation x₁ (W.neg_Y x₁ y₁) ↔ W.equation x₁ y₁ :=
by { rw [equation_iff, equation_iff, neg_Y], congr' 2, ring1 }

lemma equation_neg_of (h : W.equation x₁ $ W.neg_Y x₁ y₁) : W.equation x₁ y₁ :=
equation_neg_iff.mp h

/-- The negation of an affine point in `W` lies in `W`. -/
lemma equation_neg (h : W.equation x₁ y₁) : W.equation x₁ $ W.neg_Y x₁ y₁ := equation_neg_iff.mpr h

lemma nonsingular_neg_iff : W.nonsingular x₁ (W.neg_Y x₁ y₁) ↔ W.nonsingular x₁ y₁ :=
begin
  rw [nonsingular_iff, equation_neg_iff, ← neg_Y, neg_Y_neg_Y, ← @ne_comm _ y₁, nonsingular_iff],
  exact and_congr_right' ((iff_congr not_and_distrib.symm not_and_distrib.symm).mpr $
                            not_iff_not_of_iff $ and_congr_left $ λ h, by rw [← h])
end

lemma nonsingular_neg_of (h : W.nonsingular x₁ $ W.neg_Y x₁ y₁) : W.nonsingular x₁ y₁ :=
nonsingular_neg_iff.mp h

/-- The negation of a nonsingular affine point in `W` is nonsingular. -/
lemma nonsingular_neg (h : W.nonsingular x₁ y₁) : W.nonsingular x₁ $ W.neg_Y x₁ y₁ :=
nonsingular_neg_iff.mpr h

namespace point

/-- The negation of a nonsingular rational point.

Given a nonsingular rational point `P`, use `-P` instead of `neg P`. -/
def neg : W.point → W.point
| 0        := 0
| (some h) := some $ nonsingular_neg h

instance : has_neg W.point := ⟨neg⟩

@[simp] lemma neg_def (P : W.point) : P.neg = -P := rfl

@[simp] lemma neg_zero : (-0 : W.point) = 0 := rfl

@[simp] lemma neg_some (h : W.nonsingular x₁ y₁) : -some h = some (nonsingular_neg h) := rfl

instance : has_involutive_neg W.point := ⟨neg, by { rintro (_ | _), { refl }, { simp, ring1 } }⟩

end point

end basic

section addition

/-! ### Slopes of lines through nonsingular rational points on a Weierstrass curve -/

open_locale classical

variables {F : Type u} [field F] (W : weierstrass_curve F) (K : Type v) [field K] [algebra F K]
  (x₁ x₂ y₁ y₂ : F)

/-- The slope of the line through two affine points $(x_1, y_1)$ and $(x_2, y_2)$ in `W`.
If $x_1 \ne x_2$, then this line is the secant of `W` through $(x_1, y_1)$ and $(x_2, y_2)$,
and has slope $(y_1 - y_2) / (x_1 - x_2)$. Otherwise, if $y_1 \ne -y_1 - a_1x_1 - a_3$,
then this line is the tangent of `W` at $(x_1, y_1) = (x_2, y_2)$, and has slope
$(3x_1^2 + 2a_2x_1 + a_4 - a_1y_1) / (2y_1 + a_1x_1 + a_3)$. Otherwise, this line is vertical,
and has undefined slope, in which case this function returns the value 0.

This depends on `W`, and has argument order: $x_1$, $x_2$, $y_1$, $y_2$. -/
noncomputable def slope : F :=
if hx : x₁ = x₂ then if hy : y₁ = W.neg_Y x₂ y₂ then 0
else (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁) / (y₁ - W.neg_Y x₁ y₁)
else (y₁ - y₂) / (x₁ - x₂)

variables {W x₁ x₂ y₁ y₂} (h₁ : W.nonsingular x₁ y₁) (h₂ : W.nonsingular x₂ y₂)
  (h₁' : W.equation x₁ y₁) (h₂' : W.equation x₂ y₂)

@[simp] lemma slope_of_Y_eq (hx : x₁ = x₂) (hy : y₁ = W.neg_Y x₂ y₂) :
  W.slope x₁ x₂ y₁ y₂ = 0 :=
by rw [slope, dif_pos hx, dif_pos hy]

@[simp] lemma slope_of_Y_ne (hx : x₁ = x₂) (hy : y₁ ≠ W.neg_Y x₂ y₂) :
  W.slope x₁ x₂ y₁ y₂ = (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁) / (y₁ - W.neg_Y x₁ y₁) :=
by rw [slope, dif_pos hx, dif_neg hy]

@[simp] lemma slope_of_X_ne (hx : x₁ ≠ x₂) : W.slope x₁ x₂ y₁ y₂ = (y₁ - y₂) / (x₁ - x₂) :=
by rw [slope, dif_neg hx]

lemma slope_of_Y_ne_eq_eval (hx : x₁ = x₂) (hy : y₁ ≠ W.neg_Y x₂ y₂) :
  W.slope x₁ x₂ y₁ y₂
    = -(W.polynomial_X.eval $ C y₁).eval x₁ / (W.polynomial_Y.eval $ C y₁).eval x₁ :=
by { rw [slope_of_Y_ne hx hy, eval_polynomial_X, neg_sub], congr' 1, rw [neg_Y, eval_polynomial_Y],
     ring1 }

lemma base_change_slope :
  (W.base_change K).slope (algebra_map F K x₁) (algebra_map F K x₂) (algebra_map F K y₁)
    (algebra_map F K y₂) = algebra_map F K (W.slope x₁ x₂ y₁ y₂) :=
begin
  by_cases hx : x₁ = x₂,
  { by_cases hy : y₁ = W.neg_Y x₂ y₂,
    { rw [slope_of_Y_eq hx hy, slope_of_Y_eq $ congr_arg _ hx, map_zero],
      { rw [hy, base_change_neg_Y] } },
    { rw [slope_of_Y_ne hx hy, slope_of_Y_ne $ congr_arg _ hx],
      { map_simp,
        simpa only [base_change_neg_Y] },
      { rw [base_change_neg_Y],
        contrapose! hy,
        exact no_zero_smul_divisors.algebra_map_injective F K hy } } },
  { rw [slope_of_X_ne hx, slope_of_X_ne],
    { map_simp },
    { contrapose! hx,
      exact no_zero_smul_divisors.algebra_map_injective F K hx } }
end

lemma base_change_slope_of_base_change {R : Type u} [comm_ring R] (W : weierstrass_curve R)
  (F : Type v) [field F] [algebra R F] (K : Type w) [field K] [algebra R K] [algebra F K]
  [is_scalar_tower R F K] (x₁ x₂ y₁ y₂ : F) :
  (W.base_change K).slope (algebra_map F K x₁) (algebra_map F K x₂) (algebra_map F K y₁)
    (algebra_map F K y₂) = algebra_map F K ((W.base_change F).slope x₁ x₂ y₁ y₂) :=
by rw [← base_change_slope, base_change_base_change]

include h₁' h₂'

lemma Y_eq_of_X_eq (hx : x₁ = x₂) : y₁ = y₂ ∨ y₁ = W.neg_Y x₂ y₂ :=
begin
  rw [equation_iff] at h₁' h₂',
  rw [← sub_eq_zero, ← @sub_eq_zero _ _ y₁, ← mul_eq_zero, neg_Y],
  linear_combination h₁' - h₂' with { normalization_tactic := `[rw [hx], ring1] }
end

lemma Y_eq_of_Y_ne (hx : x₁ = x₂) (hy : y₁ ≠ W.neg_Y x₂ y₂) : y₁ = y₂ :=
or.resolve_right (Y_eq_of_X_eq h₁' h₂' hx) hy

lemma add_polynomial_slope (hxy : x₁ = x₂ → y₁ ≠ W.neg_Y x₂ y₂) :
  W.add_polynomial x₁ y₁ (W.slope x₁ x₂ y₁ y₂)
    = -((X - C x₁) * (X - C x₂) * (X - C (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂))) :=
begin
  rw [add_polynomial_eq, neg_inj, cubic.prod_X_sub_C_eq, cubic.to_poly_injective],
  by_cases hx : x₁ = x₂,
  { rcases ⟨hx, Y_eq_of_Y_ne h₁' h₂' hx (hxy hx)⟩ with ⟨rfl, rfl⟩,
    rw [equation_iff] at h₁' h₂',
    rw [slope_of_Y_ne rfl $ hxy rfl],
    rw [neg_Y, ← sub_ne_zero] at hxy,
    ext,
    { refl },
    { simp only [add_X],
      ring1 },
    { field_simp [hxy rfl],
      ring1 },
    { linear_combination -h₁' with { normalization_tactic := `[field_simp [hxy rfl], ring1] } } },
  { rw [equation_iff] at h₁' h₂',
    rw [slope_of_X_ne hx],
    rw [← sub_eq_zero] at hx,
    ext,
    { refl },
    { simp only [add_X],
      ring1 },
    { apply mul_right_injective₀ hx,
      linear_combination h₂' - h₁' with { normalization_tactic := `[field_simp [hx], ring1] } },
    { apply mul_right_injective₀ hx,
      linear_combination x₂ * h₁' - x₁ * h₂'
        with { normalization_tactic := `[field_simp [hx], ring1] } } }
end

lemma derivative_add_polynomial_slope (hxy : x₁ = x₂ → y₁ ≠ W.neg_Y x₂ y₂) :
  derivative (W.add_polynomial x₁ y₁ $ W.slope x₁ x₂ y₁ y₂)
    = -((X - C x₁) * (X - C x₂) + (X - C x₁) * (X - C (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂))
        + (X - C x₂) * (X - C (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂))) :=
by { rw [add_polynomial_slope h₁' h₂' hxy], derivative_simp, ring1 }

/-! ### The addition law on nonsingular rational points on a Weierstrass curve -/

/-- The addition of two affine points in `W` on a sloped line,
before applying the final negation that maps $Y$ to $-Y - a_1X - a_3$, lies in `W`. -/
lemma equation_add' (hxy : x₁ = x₂ → y₁ ≠ W.neg_Y x₂ y₂) :
  W.equation (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂) (W.add_Y' x₁ x₂ y₁ $ W.slope x₁ x₂ y₁ y₂) :=
by { rw [equation_add_iff, add_polynomial_slope h₁' h₂' hxy], eval_simp,
     rw [neg_eq_zero, sub_self, mul_zero] }

/-- The addition of two affine points in `W` on a sloped line lies in `W`. -/
lemma equation_add (hxy : x₁ = x₂ → y₁ ≠ W.neg_Y x₂ y₂) :
  W.equation (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂) (W.add_Y x₁ x₂ y₁ $ W.slope x₁ x₂ y₁ y₂) :=
equation_neg $ equation_add' h₁' h₂' hxy

omit h₁' h₂'

include h₁ h₂

/-- The addition of two nonsingular affine points in `W` on a sloped line,
before applying the final negation that maps $Y$ to $-Y - a_1X - a_3$, is nonsingular. -/
lemma nonsingular_add' (hxy : x₁ = x₂ → y₁ ≠ W.neg_Y x₂ y₂) :
  W.nonsingular (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂) (W.add_Y' x₁ x₂ y₁ $ W.slope x₁ x₂ y₁ y₂) :=
begin
  by_cases hx₁ : W.add_X x₁ x₂ (W.slope x₁ x₂ y₁ y₂) = x₁,
  { rwa [add_Y', hx₁, sub_self, mul_zero, zero_add] },
  { by_cases hx₂ : W.add_X x₁ x₂ (W.slope x₁ x₂ y₁ y₂) = x₂,
    { by_cases hx : x₁ = x₂,
      { subst hx,
        contradiction },
      { rwa [add_Y', ← neg_sub, mul_neg, hx₂, slope_of_X_ne hx,
             div_mul_cancel _ $ sub_ne_zero_of_ne hx, neg_sub, sub_add_cancel] } },
    { apply W.nonsingular_add_of_eval_derivative_ne_zero _ _ _ _ (equation_add' h₁.1 h₂.1 hxy),
      rw [derivative_add_polynomial_slope h₁.left h₂.left hxy],
      eval_simp,
      simpa only [neg_ne_zero, sub_self, mul_zero, add_zero]
        using mul_ne_zero (sub_ne_zero_of_ne hx₁) (sub_ne_zero_of_ne hx₂) } }
end

/-- The addition of two nonsingular affine points in `W` on a sloped line is nonsingular. -/
lemma nonsingular_add (hxy : x₁ = x₂ → y₁ ≠ W.neg_Y x₂ y₂) :
  W.nonsingular (W.add_X x₁ x₂ $ W.slope x₁ x₂ y₁ y₂) (W.add_Y x₁ x₂ y₁ $ W.slope x₁ x₂ y₁ y₂) :=
nonsingular_neg $ nonsingular_add' h₁ h₂ hxy

omit h₁ h₂

namespace point

variables {h₁ h₂}

/-- The addition of two nonsingular rational points.

Given two nonsingular rational points `P` and `Q`, use `P + Q` instead of `add P Q`. -/
noncomputable def add : W.point → W.point → W.point
| 0                      P                      := P
| P                      0                      := P
| (@some _ _ _ x₁ y₁ h₁) (@some _ _ _ x₂ y₂ h₂) :=
if hx : x₁ = x₂ then if hy : y₁ = W.neg_Y x₂ y₂ then 0
else some $ nonsingular_add h₁ h₂ $ λ _, hy
else some $ nonsingular_add h₁ h₂ $ λ h, (hx h).elim

noncomputable instance : has_add W.point := ⟨add⟩

@[simp] lemma add_def (P Q : W.point) : P.add Q = P + Q := rfl

noncomputable instance : add_zero_class W.point :=
⟨0, (+), by rintro (_ | _); refl, by rintro (_ | _); refl⟩

@[simp] lemma some_add_some_of_Y_eq (hx : x₁ = x₂) (hy : y₁ = W.neg_Y x₂ y₂) :
  some h₁ + some h₂ = 0 :=
by rw [← add_def, add, dif_pos hx, dif_pos hy]

@[simp]

@[simp] lemma some_add_some_of_Y_ne (hx : x₁ = x₂) (hy : y₁ ≠ W.neg_Y x₂ y₂) :
  some h₁ + some h₂ = some (nonsingular_add h₁ h₂ $ λ _, hy) :=
by rw [← add_def, add, dif_pos hx, dif_neg hy]

lemma some_add_some_of_Y_ne' (hx : x₁ = x₂) (hy : y₁ ≠ W.neg_Y x₂ y₂) :
  some h₁ + some h₂ = -some (nonsingular_add' h₁ h₂ $ λ _, hy) :=
some_add_some_of_Y_ne hx hy

@[simp] lemma some_add_self_of_Y_ne (hy : y₁ ≠ W.neg_Y x₁ y₁) :
  some h₁ + some h₁ = some (nonsingular_add h₁ h₁ $ λ _, hy) :=
some_add_some_of_Y_ne rfl hy

lemma some_add_self_of_Y_ne' (hy : y₁ ≠ W.neg_Y x₁ y₁) :
  some h₁ + some h₁ = -some (nonsingular_add' h₁ h₁ $ λ _, hy) :=
some_add_some_of_Y_ne rfl hy

@[simp] lemma some_add_some_of_X_ne (hx : x₁ ≠ x₂) :
  some h₁ + some h₂ = some (nonsingular_add h₁ h₂ $ λ h, (hx h).elim) :=
by rw [← add_def, add, dif_neg hx]

lemma some_add_some_of_X_ne' (hx : x₁ ≠ x₂) :
  some h₁ + some h₂ = -some (nonsingular_add' h₁ h₂ $ λ h, (hx h).elim) :=
some_add_some_of_X_ne hx

end point

end addition

section group

/-! ### The axioms for nonsingular rational points on a Weierstrass curve -/

variables {F : Type u} [field F] {W : weierstrass_curve F}

namespace point

@[simp] lemma add_eq_zero (P Q : W.point) : P + Q = 0 ↔ P = -Q :=
begin
  rcases ⟨P, Q⟩ with ⟨_ | @⟨x₁, y₁, _⟩, _ | @⟨x₂, y₂, _⟩⟩,
  any_goals { refl },
  { rw [zero_def, zero_add, ← neg_eq_iff_eq_neg, neg_zero, eq_comm], },
  { simp only [neg_some],
    split,
    { intro h,
      by_cases hx : x₁ = x₂,
      { by_cases hy : y₁ = W.neg_Y x₂ y₂,
        { exact ⟨hx, hy⟩ },
        { rw [some_add_some_of_Y_ne hx hy] at h,
          contradiction } },
      { rw [some_add_some_of_X_ne hx] at h,
        contradiction } },
    { exact λ ⟨hx, hy⟩, some_add_some_of_Y_eq hx hy } }
end

@[simp] lemma add_left_neg (P : W.point) : -P + P = 0 := by rw [add_eq_zero]

@[simp] lemma neg_add_eq_zero (P Q : W.point) : -P + Q = 0 ↔ P = Q := by rw [add_eq_zero, neg_inj]

end point

end group

section base_change

/-! ### Nonsingular rational points on a base changed Weierstrass curve -/

variables {R : Type u} [comm_ring R] (W : weierstrass_curve R) (F : Type v) [field F] [algebra R F]
  (K : Type w) [field K] [algebra R K] [algebra F K] [is_scalar_tower R F K]

namespace point

open_locale weierstrass_curve

/-- The function from `W⟮F⟯` to `W⟮K⟯` induced by a base change from `F` to `K`. -/
def of_base_change_fun : W⟮F⟯ → W⟮K⟯
| 0        := 0
| (some h) := some $ (nonsingular_iff_base_change_of_base_change W F K _ _).mp h

/-- The group homomorphism from `W⟮F⟯` to `W⟮K⟯` induced by a base change from `F` to `K`. -/
@[simps] def of_base_change : W⟮F⟯ →+ W⟮K⟯ :=
{ to_fun    := of_base_change_fun W F K,
  map_zero' := rfl,
  map_add'  :=
  begin
    rintro (_ | @⟨x₁, y₁, _⟩) (_ | @⟨x₂, y₂, _⟩),
    any_goals { refl },
    by_cases hx : x₁ = x₂,
    { by_cases hy : y₁ = (W.base_change F).neg_Y x₂ y₂,
      { simp only [some_add_some_of_Y_eq hx hy, of_base_change_fun],
        rw [some_add_some_of_Y_eq $ congr_arg _ hx],
        { rw [hy, base_change_neg_Y_of_base_change] } },
      { simp only [some_add_some_of_Y_ne hx hy, of_base_change_fun],
        rw [some_add_some_of_Y_ne $ congr_arg _ hx],
        { simp only [base_change_add_X_of_base_change, base_change_add_Y_of_base_change,
                     base_change_slope_of_base_change],
          exact ⟨rfl, rfl⟩ },
        { rw [base_change_neg_Y_of_base_change],
          contrapose! hy,
          exact no_zero_smul_divisors.algebra_map_injective F K hy } } },
    { simp only [some_add_some_of_X_ne hx, of_base_change_fun],
      rw [some_add_some_of_X_ne],
      { simp only [base_change_add_X_of_base_change, base_change_add_Y_of_base_change,
                   base_change_slope_of_base_change],
        exact ⟨rfl, rfl⟩ },
      { contrapose! hx,
        exact no_zero_smul_divisors.algebra_map_injective F K hx } }
  end }

lemma of_base_change_injective : function.injective $ of_base_change W F K :=
begin
  rintro (_ | _) (_ | _) h,
  { refl },
  any_goals { contradiction },
  simp only,
  exact ⟨no_zero_smul_divisors.algebra_map_injective F K (some.inj h).left,
    no_zero_smul_divisors.algebra_map_injective F K (some.inj h).right⟩
end

end point

end base_change

end weierstrass_curve

namespace elliptic_curve

/-! ### Rational points on an elliptic curve -/

namespace point

variables {R : Type} [nontrivial R] [comm_ring R] (E : elliptic_curve R)

/-- An affine point on an elliptic curve `E` over `R`. -/
def mk {x y : R} (h : E.equation x y) : E.point := weierstrass_curve.point.some $ E.nonsingular h

end point

end elliptic_curve


import Lean4Axiomatic.Rational.Core
import Lean4Axiomatic.Rational.Impl.Fraction.Naive

namespace Lean4Axiomatic.Rational.Impl

open Logic (AP)
open Relation.Equivalence (EqvOp)
open Signed (Negative Positive Positivity)

/-!
## (True) Fractions

With the knowledge gained from the attempt at naive fractions, we can now make
formal fractions that have the right constraints to be useful as rational
numbers.
-/

/--
A formal fraction of signed values, where the denominator must be positive.

As explored in `Fraction.Naive`, we must at least constrain the denominator to
be nonzero if we want to have a useful definition of fractions. We go a bit
further than that here, and require a positive denominator, because it
simplifies the definition of positive and negative for fractions: only the sign
of the numerator matters.

The `denominator_positive` field is defined with square brackets so that it
becomes an instance parameter in `Fraction`'s constructor, allowing Lean to
automatically fill it in. Otherwise it would frequently require tedious
bookkeeping to manage.

One way to think about values of this type is that they represent a "frozen" or
"unevaluated" division operation between two numbers. If we represent a value
of this type as the expression `n//d`, where `n` is the numerator and `d` is
the denominator, then informally the division concept says `(n//d) * d ≃ n`.

Another viewpoint, also described in the section on naive fractions, is that a
fraction is a numeric value (the numerator) which is at a certain "size" or
"scale" given by the denominator. Using the simple case of integer fractions, a
scale of `1` corresponds with ordinary integers; a scale of `2` means that a
numerator of `2` is the same size as the ordinary integer `1`; and in general
we have `n//n ≃ 1`. Integers at the same scale can be added directly
(`a//n + b//n ≃ (a + b)//n`), and this is what motivates the definition of
addition for fractions.
-/
structure Fraction
    (α : Type) [EqvOp α] [OfNat α 0] [Positivity.Ops α]
    : Type :=
  numerator : α
  denominator : α
  [denominator_positive : AP (Positive denominator)]

infix:90 "//" => Fraction.mk

namespace Fraction

/--
The naive representation of this fraction.

This simply drops the positive requirement for the denominator. Mainly good for
reusing naive fraction definitions that still work for true fractions.
-/
def naive
    {α : Type} [EqvOp α] [OfNat α 0] [Positivity.Ops α]
    : Fraction α → Naive.Fraction α
| a//b => Naive.Fraction.mk a b

/--
Lift a naive fraction to a true fraction, if its denominator is positive.
-/
def from_naive
    {α : Type} [EqvOp α] [OfNat α 0] [Positivity.Ops α] (p : Naive.Fraction α)
    : Positive p.denominator → Fraction α
    := by
  revert p; intro (Naive.Fraction.mk pn pd) (_ : Positive pd)
  have : AP (Positive pd) := AP.mk ‹Positive pd›
  exact pn//pd

variable {ℕ : Type} [Natural ℕ]
variable {ℤ : Type} [Integer (ℕ := ℕ) ℤ]

/--
Equivalence relation on formal fractions of integers.

See `Naive.eqv` for more explanation.
-/
def eqv (p q : Fraction ℤ) : Prop := Naive.eqv p.naive q.naive

instance equivalence_ops : Equivalence.Ops (Fraction ℤ) := {
  eqv := eqv
}

/-- Fraction equivalence is reflexive. -/
theorem eqv_refl {p : Fraction ℤ} : p ≃ p := Naive.eqv_refl (p := p.naive)

/-- Fraction equivalence is symmetric. -/
theorem eqv_symm {p q : Fraction ℤ} : p ≃ q → q ≃ p :=
  Naive.eqv_symm (p := p.naive) (q := q.naive)

/-- Fraction equivalence is transitive. -/
theorem eqv_trans {p q r : Fraction ℤ} : p ≃ q → q ≃ r → p ≃ r :=
  let qd := q.denominator
  have : Positive qd := q.denominator_positive.ev
  have : Positive qd ∨ Negative qd := Or.inl this
  have : Integer.Nonzero qd := Integer.nonzero_iff_pos_or_neg.mpr this
  have : qd ≄ 0 := Integer.nonzero_iff_neqv_zero.mp this
  Naive.eqv_trans_nonzero_denom
    (p := p.naive) (q := q.naive) (r := r.naive) ‹qd ≄ 0›

instance equivalence_props : Equivalence.Props (Fraction ℤ) := {
  eqv_refl := eqv_refl
  eqv_symm := eqv_symm
  eqv_trans := eqv_trans
}

instance equivalence : Equivalence (Fraction ℤ) := {}

/--
Replacing the numerator of a fraction with an equivalent value gives an
equivalent result.

**Property intuition**: This must be true for fractions to be a useful data
structure.

**Proof intuition**: Expand the definition of equivalence; use substitution of
integer multiplication.
-/
theorem substN {a₁ a₂ b : ℤ} [AP (Positive b)] : a₁ ≃ a₂ → a₁//b ≃ a₂//b := by
  intro (_ : a₁ ≃ a₂)
  show a₁//b ≃ a₂//b
  show a₁ * b ≃ a₂ * b
  exact AA.substL ‹a₁ ≃ a₂›

/--
Replacing the denominator of a fraction with an equivalent value gives an
equivalent result.

**Property intuition**: This must be true for fractions to be a useful data
structure.

**Proof intuition**: Expand the definition of equivalence; use substitution of
integer multiplication.
-/
theorem substD
    {a b₁ b₂ : ℤ} [pb₁ : AP (Positive b₁)] [pb₂ : AP (Positive b₂)]
    : b₁ ≃ b₂ → a//b₁ ≃ a//b₂
    := by
  intro (_ : b₁ ≃ b₂)
  show a//b₁ ≃ a//b₂
  show a * b₂ ≃ a * b₁
  exact AA.substR (Rel.symm ‹b₁ ≃ b₂›)

/--
Every integer can be represented as a fraction.

**Intuition**: Dividing by `1` leaves the input unchanged. Or, a denominator of
`1` means that every unit of the numerator is the same "size" as the integer
`1`.
-/
def from_integer : ℤ → Fraction ℤ := (·//1)

instance conversion_ops : Conversion.Ops (ℤ := ℤ) (Fraction ℤ) := {
  from_integer := from_integer
}

/--
Equivalent integers are converted to equivalent integer fractions.

**Property intuition**: This must be true if we want integer fractions to be a
superset of the integers.

**Proof intuition**: The denominators are identical, so the result follows from
the equivalence of the numerators.
-/
theorem from_integer_subst
    {a₁ a₂ : ℤ} : a₁ ≃ a₂ → from_integer a₁ ≃ from_integer a₂
    := by
  intro (_ : a₁ ≃ a₂)
  show from_integer a₁ ≃ from_integer a₂
  show a₁//1 ≃ a₂//1
  exact substN ‹a₁ ≃ a₂›

/--
Equivalent converted fractions came from the same integer.

**Property intuition**: Every integer must have a unique representation as an
integer fraction.

**Proof intuition**: Expand the hypothesis into an equivalence on integers.
Cancel the common factor to obtain the result.
-/
theorem from_integer_inject
    {a₁ a₂ : ℤ} : from_integer a₁ ≃ from_integer a₂ → a₁ ≃ a₂
    := by
  intro (_ : from_integer a₁ ≃ from_integer a₂)
  show a₁ ≃ a₂
  have : a₁//1 ≃ a₂//1 := ‹from_integer a₁ ≃ from_integer a₂›
  have : a₁ * 1 ≃ a₂ * 1 := this
  have : a₁ ≃ a₂ := AA.cancelRC (C := (· ≄ 0)) Integer.one_neqv_zero this
  exact this

instance conversion_props : Conversion.Props (Fraction ℤ) := {
  from_integer_subst := from_integer_subst
  from_integer_inject := from_integer_inject
}

instance conversion : Conversion (ℤ := ℤ) (Fraction ℤ) := {
  toOps := conversion_ops
  toProps := conversion_props
}

instance core : Core (ℤ := ℤ) (Fraction ℤ) := {
  toEquivalence := equivalence
  toConversion := conversion
}

/--
Fractions are equivalent to zero exactly when their numerators are.

**Property intuition**: The numerator of a fraction is the integer value that
is "scaled down" by the denominator. So the fraction should represent zero only
when its numerator is zero, and vice versa.

**Proof intuition**: In both directions, expand equivalence between fractions
into equivalence between integers. The goals follow easily from integer facts.
-/
theorem eqv_zero_iff_numerator_eqv_zero
    {p : Fraction ℤ} : p ≃ 0 ↔ p.numerator ≃ 0
    := by
  revert p; intro (pn//pd)
  apply Iff.intro
  case mp =>
    intro (_ : pn//pd ≃ 0)
    show pn ≃ 0
    have : pn//pd ≃ 0//1 := ‹pn//pd ≃ 0›
    have : pn * 1 ≃ 0 * pd := ‹pn//pd ≃ 0//1›
    calc
      pn     ≃ _ := Rel.symm AA.identR
      pn * 1 ≃ _ := ‹pn * 1 ≃ 0 * pd›
      0 * pd ≃ _ := AA.absorbL
      0      ≃ _ := Rel.refl
  case mpr =>
    intro (_ : pn ≃ 0)
    show pn//pd ≃ 0
    show pn//pd ≃ 0//1
    show pn * 1 ≃ 0 * pd
    calc
      pn * 1 ≃ _ := AA.identR
      pn     ≃ _ := ‹pn ≃ 0›
      0      ≃ _ := Rel.symm AA.absorbL
      0 * pd ≃ _ := Rel.refl

/--
An integer fraction that's not equivalent to zero has a nonzero numerator.

This lemma is helpful for saving a few steps in proofs.

**Property and proof intuition**: Follows directly from integer fractions being
zero iff their numerators are.
-/
theorem nonzero_numerator
    (p : Fraction ℤ) [AP (p ≄ 0)] : Integer.Nonzero p.numerator
    := by
  revert p; intro (a//b) (_ : AP (a//b ≄ 0))
  have : a ≃ 0 → a//b ≃ 0 := (eqv_zero_iff_numerator_eqv_zero (p := a//b)).mpr
  have : a ≄ 0 := mt this ‹AP (a//b ≄ 0)›.ev
  have : Integer.Nonzero a := Integer.nonzero_iff_neqv_zero.mpr this
  exact this

/--
Fractions are equivalent to one exactly when their numerators and denominators
are equivalent.

**Property intuition**: The denominator of a fraction denotes what the quantity
of the numerator must be for the fraction to be equivalent to one, and that's
exactly what this property expresses.

**Proof intuition**: In both directions, expand equivalence between fractions
into equivalence between integers. The goals follow easily from integer facts.
-/
theorem eqv_one_iff_numer_eqv_denom
    {p : Fraction ℤ} : p ≃ 1 ↔ p.numerator ≃ p.denominator
    := by
  revert p; intro (pn//pd)
  apply Iff.intro
  case mp =>
    intro (_ : pn//pd ≃ 1)
    show pn ≃ pd
    have : pn//pd ≃ 1//1 := ‹pn//pd ≃ 1//1›
    have : pn * 1 ≃ 1 * pd := ‹pn//pd ≃ 1//1›
    calc
      pn     ≃ _ := Rel.symm AA.identR
      pn * 1 ≃ _ := ‹pn * 1 ≃ 1 * pd›
      1 * pd ≃ _ := AA.identL
      pd     ≃ _ := Rel.refl
  case mpr =>
    intro (_ : pn ≃ pd)
    show pn//pd ≃ 1
    show pn//pd ≃ 1//1
    show pn * 1 ≃ 1 * pd
    calc
      pn * 1 ≃ _ := AA.substL ‹pn ≃ pd›
      pd * 1 ≃ _ := AA.comm
      1 * pd ≃ _ := Rel.refl

end Lean4Axiomatic.Rational.Impl.Fraction