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

! This file was ported from Lean 3 source module order.filter.ennreal
! leanprover-community/mathlib commit 57ac39bd365c2f80589a700f9fbb664d3a1a30c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Real.ENNReal
import Mathlib.Order.Filter.CountableInter
import Mathlib.Order.LiminfLimsup

/-!
# Order properties of extended non-negative reals

This file compiles filter-related results about `ℝ≥0∞` (see Data/Real/ENNReal.lean).
-/

open Filter ENNReal

namespace ENNReal

variable {α : Type _} {f : Filter α}

theorem eventually_le_limsup [CountableInterFilter f] (u : α → ℝ≥0∞) :
    ∀ᶠ y in f, u y ≤ f.limsup u := by
  by_cases hx_top : f.limsup u = ⊤
  · simp_rw [hx_top]
    exact eventually_of_forall fun a => le_top
  have h_forall_le : ∀ᶠ y in f, ∀ n : ℕ, u y < f.limsup u + (1 : ℝ≥0∞) / n
  · rw [eventually_countable_forall]
    refine' fun n => eventually_lt_of_limsup_lt _
    nth_rw 1 [← add_zero (f.limsup u)]
    exact (ENNReal.add_lt_add_iff_left hx_top).mpr (by simp)
  refine h_forall_le.mono fun y hy => le_of_forall_pos_le_add fun r hr_pos _ => ?_
  have hr_ne_zero : (r : ℝ≥0∞) ≠ 0
  · rw [Ne.def, coe_eq_zero]
    exact hr_pos.ne'
  cases' exists_inv_nat_lt hr_ne_zero with i hi
  rw [inv_eq_one_div] at hi
  exact (hy i).le.trans (add_le_add_left hi.le (f.limsup u))
#align ennreal.eventually_le_limsup ENNReal.eventually_le_limsup

theorem limsup_eq_zero_iff [CountableInterFilter f] {u : α → ℝ≥0∞} :
    f.limsup u = 0 ↔ u =ᶠ[f] 0 := by
  constructor <;> intro h
  · have hu_zero :=
      EventuallyLE.trans (eventually_le_limsup u) (eventually_of_forall fun _ => le_of_eq h)
    exact hu_zero.mono fun x hx => le_antisymm hx (zero_le _)
  · rw [limsup_congr h]
    simp_rw [Pi.zero_apply, ← ENNReal.bot_eq_zero, limsup_const_bot]
#align ennreal.limsup_eq_zero_iff ENNReal.limsup_eq_zero_iff

theorem limsup_const_mul_of_ne_top {u : α → ℝ≥0∞} {a : ℝ≥0∞} (ha_top : a ≠ ⊤) :
    (f.limsup fun x : α => a * u x) = a * f.limsup u := by
  by_cases ha_zero : a = 0
  · simp_rw [ha_zero, zero_mul, ← ENNReal.bot_eq_zero]
    exact limsup_const_bot
  let g := fun x : ℝ≥0∞ => a * x
  have hg_bij : Function.Bijective g :=
    Function.bijective_iff_has_inverse.mpr
      ⟨fun x => a⁻¹ * x,
        ⟨fun x => by simp [← mul_assoc, ENNReal.inv_mul_cancel ha_zero ha_top], fun x => by
          simp [← mul_assoc, ENNReal.mul_inv_cancel ha_zero ha_top]⟩⟩
  have hg_mono : StrictMono g :=
    Monotone.strictMono_of_injective (fun _ _ _ => by rwa [mul_le_mul_left ha_zero ha_top]) hg_bij.1
  let g_iso := StrictMono.orderIsoOfSurjective g hg_mono hg_bij.2
  refine' (OrderIso.limsup_apply g_iso _ _ _ _).symm
  all_goals isBoundedDefault
#align ennreal.limsup_const_mul_of_ne_top ENNReal.limsup_const_mul_of_ne_top

theorem limsup_const_mul [CountableInterFilter f] {u : α → ℝ≥0∞} {a : ℝ≥0∞} :
    f.limsup (a * u ·) = a * f.limsup u := by
  by_cases ha_top : a ≠ ⊤
  · exact limsup_const_mul_of_ne_top ha_top
  push_neg  at ha_top
  by_cases hu : u =ᶠ[f] 0
  · have hau : (a * u ·) =ᶠ[f] 0 := hu.mono fun x hx => by simp [hx]
    simp only [limsup_congr hu, limsup_congr hau, Pi.zero_apply, ← ENNReal.bot_eq_zero,
      limsup_const_bot]
    simp
  · have hu_mul : ∃ᶠ x : α in f, ⊤ ≤ ite (u x = 0) (0 : ℝ≥0∞) ⊤ := by
      rw [EventuallyEq, not_eventually] at hu
      refine' hu.mono fun x hx => _
      rw [Pi.zero_apply] at hx
      simp [hx]
    have h_top_le : (f.limsup fun x : α => ite (u x = 0) (0 : ℝ≥0∞) ⊤) = ⊤ :=
      eq_top_iff.mpr (le_limsup_of_frequently_le hu_mul)
    have hfu : f.limsup u ≠ 0 := mt limsup_eq_zero_iff.1 hu
    simp only [ha_top, top_mul', hfu, h_top_le]
#align ennreal.limsup_const_mul ENNReal.limsup_const_mul

theorem limsup_mul_le [CountableInterFilter f] (u v : α → ℝ≥0∞) :
    f.limsup (u * v) ≤ f.limsup u * f.limsup v :=
  calc
    f.limsup (u * v) ≤ f.limsup fun x => f.limsup u * v x := by
      refine limsup_le_limsup ?_
      filter_upwards [@eventually_le_limsup _ f _ u] with x hx using mul_le_mul' hx le_rfl
    _ = f.limsup u * f.limsup v := limsup_const_mul
#align ennreal.limsup_mul_le ENNReal.limsup_mul_le

theorem limsup_add_le [CountableInterFilter f] (u v : α → ℝ≥0∞) :
    f.limsup (u + v) ≤ f.limsup u + f.limsup v :=
  infₛ_le ((eventually_le_limsup u).mp
    ((eventually_le_limsup v).mono fun _ hxg hxf => add_le_add hxf hxg))
#align ennreal.limsup_add_le ENNReal.limsup_add_le

theorem limsup_liminf_le_liminf_limsup {β} [Countable β] {f : Filter α} [CountableInterFilter f]
    {g : Filter β} (u : α → β → ℝ≥0∞) :
    (f.limsup fun a : α => g.liminf fun b : β => u a b) ≤
      g.liminf fun b => f.limsup fun a => u a b :=
  have h1 : ∀ᶠ a in f, ∀ b, u a b ≤ f.limsup fun a' => u a' b := by
    rw [eventually_countable_forall]
    exact fun b => ENNReal.eventually_le_limsup fun a => u a b
  infₛ_le <| h1.mono fun x hx => Filter.liminf_le_liminf (Filter.eventually_of_forall hx)
#align ennreal.limsup_liminf_le_liminf_limsup ENNReal.limsup_liminf_le_liminf_limsup

end ENNReal


/-
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

! This file was ported from Lean 3 source module algebraic_geometry.elliptic_curve.point
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.EllipticCurve.Weierstrass
import Mathbin.FieldTheory.Galois
import Mathbin.RingTheory.ClassGroup

/-!
# 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
-/

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
-- temporary import to enable point notation
-- temporary import to enable point notation
private unsafe def map_simp : tactic Unit :=
  sorry
#align map_simp map_simp

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
private unsafe def eval_simp : tactic Unit :=
  sorry
#align eval_simp eval_simp

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
private unsafe def C_simp : tactic Unit :=
  sorry
#align C_simp C_simp

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
private unsafe def derivative_simp : tactic Unit :=
  sorry
#align derivative_simp derivative_simp

universe u v w

namespace WeierstrassCurve

open Polynomial

open Polynomial PolynomialPolynomial

section Basic

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

variable {R : Type u} [CommRing R] (W : WeierstrassCurve R) (A : Type v) [CommRing A] [Algebra R A]
  (B : Type w) [CommRing B] [Algebra R B] [Algebra A B] [IsScalarTower R A B] (x₁ x₂ y₁ y₂ L : R)

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

/-- 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 negY : R :=
  -y₁ - W.a₁ * x₁ - W.a₃
#align weierstrass_curve.neg_Y WeierstrassCurve.negY

theorem negY_negY : W.negY x₁ (W.negY x₁ y₁) = y₁ :=
  by
  simp only [neg_Y]
  ring1
#align weierstrass_curve.neg_Y_neg_Y WeierstrassCurve.negY_negY

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2137773769.map_simp -/
theorem baseChange_negY :
    (W.base_change A).negY (algebraMap R A x₁) (algebraMap R A y₁) =
      algebraMap R A (W.negY x₁ y₁) :=
  by
  simp only [neg_Y]
  run_tac
    map_simp
  rfl
#align weierstrass_curve.base_change_neg_Y WeierstrassCurve.baseChange_negY

theorem baseChange_negY_of_baseChange (x₁ y₁ : A) :
    (W.base_change B).negY (algebraMap A B x₁) (algebraMap A B y₁) =
      algebraMap A B ((W.base_change A).negY x₁ y₁) :=
  by rw [← base_change_neg_Y, base_change_base_change]
#align weierstrass_curve.base_change_neg_Y_of_base_change WeierstrassCurve.baseChange_negY_of_baseChange

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
@[simp]
theorem eval_negPolynomial : (W.negPolynomial.eval <| C y₁).eval x₁ = W.negY x₁ y₁ :=
  by
  rw [neg_Y, sub_sub, neg_polynomial]
  run_tac
    eval_simp
#align weierstrass_curve.eval_neg_polynomial WeierstrassCurve.eval_negPolynomial

/-- 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 linePolynomial : R[X] :=
  C L * (X - C x₁) + C y₁
#align weierstrass_curve.line_polynomial WeierstrassCurve.linePolynomial

/-- 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 addPolynomial : R[X] :=
  W.Polynomial.eval <| linePolynomial x₁ y₁ L
#align weierstrass_curve.add_polynomial WeierstrassCurve.addPolynomial

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.4157056569.C_simp -/
theorem addPolynomial_eq :
    W.addPolynomial x₁ y₁ L =
      -Cubic.toPoly
          ⟨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, WeierstrassCurve.polynomial, Cubic.toPoly]
  run_tac
    eval_simp
  run_tac
    C_simp
  ring1
#align weierstrass_curve.add_polynomial_eq WeierstrassCurve.addPolynomial_eq

/-- 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 addX : R :=
  L ^ 2 + W.a₁ * L - W.a₂ - x₁ - x₂
#align weierstrass_curve.add_X WeierstrassCurve.addX

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2137773769.map_simp -/
theorem baseChange_addX :
    (W.base_change A).addX (algebraMap R A x₁) (algebraMap R A x₂) (algebraMap R A L) =
      algebraMap R A (W.addX x₁ x₂ L) :=
  by
  simp only [add_X]
  run_tac
    map_simp
  rfl
#align weierstrass_curve.base_change_add_X WeierstrassCurve.baseChange_addX

theorem baseChange_addX_of_baseChange (x₁ x₂ L : A) :
    (W.base_change B).addX (algebraMap A B x₁) (algebraMap A B x₂) (algebraMap A B L) =
      algebraMap A B ((W.base_change A).addX x₁ x₂ L) :=
  by rw [← base_change_add_X, base_change_base_change]
#align weierstrass_curve.base_change_add_X_of_base_change WeierstrassCurve.baseChange_addX_of_baseChange

/-- 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 addY' : R :=
  L * (W.addX x₁ x₂ L - x₁) + y₁
#align weierstrass_curve.add_Y' WeierstrassCurve.addY'

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2137773769.map_simp -/
theorem baseChange_addY' :
    (W.base_change A).addY' (algebraMap R A x₁) (algebraMap R A x₂) (algebraMap R A y₁)
        (algebraMap R A L) =
      algebraMap R A (W.addY' x₁ x₂ y₁ L) :=
  by
  simp only [add_Y', base_change_add_X]
  run_tac
    map_simp
#align weierstrass_curve.base_change_add_Y' WeierstrassCurve.baseChange_addY'

theorem baseChange_addY'_of_baseChange (x₁ x₂ y₁ L : A) :
    (W.base_change B).addY' (algebraMap A B x₁) (algebraMap A B x₂) (algebraMap A B y₁)
        (algebraMap A B L) =
      algebraMap A B ((W.base_change A).addY' x₁ x₂ y₁ L) :=
  by rw [← base_change_add_Y', base_change_base_change]
#align weierstrass_curve.base_change_add_Y'_of_base_change WeierstrassCurve.baseChange_addY'_of_baseChange

/-- 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 addY : R :=
  W.negY (W.addX x₁ x₂ L) (W.addY' x₁ x₂ y₁ L)
#align weierstrass_curve.add_Y WeierstrassCurve.addY

theorem baseChange_addY :
    (W.base_change A).addY (algebraMap R A x₁) (algebraMap R A x₂) (algebraMap R A y₁)
        (algebraMap R A L) =
      algebraMap R A (W.addY x₁ x₂ y₁ L) :=
  by simp only [add_Y, base_change_add_Y', base_change_add_X, base_change_neg_Y]
#align weierstrass_curve.base_change_add_Y WeierstrassCurve.baseChange_addY

theorem baseChange_addY_of_baseChange (x₁ x₂ y₁ L : A) :
    (W.base_change B).addY (algebraMap A B x₁) (algebraMap A B x₂) (algebraMap A B y₁)
        (algebraMap A B L) =
      algebraMap A B ((W.base_change A).addY x₁ x₂ y₁ L) :=
  by rw [← base_change_add_Y, base_change_base_change]
#align weierstrass_curve.base_change_add_Y_of_base_change WeierstrassCurve.baseChange_addY_of_baseChange

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
theorem equation_add_iff :
    W.Equation (W.addX x₁ x₂ L) (W.addY' x₁ x₂ y₁ L) ↔
      (W.addPolynomial x₁ y₁ L).eval (W.addX x₁ x₂ L) = 0 :=
  by
  rw [equation, add_Y', add_polynomial, line_polynomial, WeierstrassCurve.polynomial]
  run_tac
    eval_simp
#align weierstrass_curve.equation_add_iff WeierstrassCurve.equation_add_iff

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.162409969.derivative_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
theorem nonsingular_add_of_eval_derivative_ne_zero
    (hx' : W.Equation (W.addX x₁ x₂ L) (W.addY' x₁ x₂ y₁ L))
    (hx : (derivative <| W.addPolynomial x₁ y₁ L).eval (W.addX x₁ x₂ L) ≠ 0) :
    W.Nonsingular (W.addX x₁ x₂ L) (W.addY' x₁ x₂ y₁ L) :=
  by
  rw [nonsingular, and_iff_right hx', add_Y', polynomial_X, polynomial_Y]
  run_tac
    eval_simp
  contrapose! hx
  rw [add_polynomial, line_polynomial, WeierstrassCurve.polynomial]
  run_tac
    eval_simp
  run_tac
    derivative_simp
  simp only [zero_add, add_zero, sub_zero, MulZeroClass.zero_mul, mul_one]
  run_tac
    eval_simp
  linear_combination (norm := (norm_num1; ring1)) hx.left + L * hx.right
#align weierstrass_curve.nonsingular_add_of_eval_derivative_ne_zero WeierstrassCurve.nonsingular_add_of_eval_derivative_ne_zero

/-! ### 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)
#align weierstrass_curve.point WeierstrassCurve.Point

-- mathport name: «expr ⟮ ⟯»
scoped notation W "⟮" S "⟯" => (W.base_change S).Point

namespace Point

instance : Inhabited W.Point :=
  ⟨zero⟩

instance : Zero W.Point :=
  ⟨zero⟩

@[simp]
theorem zero_def : (zero : W.Point) = 0 :=
  rfl
#align weierstrass_curve.point.zero_def WeierstrassCurve.Point.zero_def

end Point

variable {W x₁ y₁}

theorem equation_neg_iff : W.Equation x₁ (W.negY x₁ y₁) ↔ W.Equation x₁ y₁ :=
  by
  rw [equation_iff, equation_iff, neg_Y]
  congr 2
  ring1
#align weierstrass_curve.equation_neg_iff WeierstrassCurve.equation_neg_iff

theorem equation_neg_of (h : W.Equation x₁ <| W.negY x₁ y₁) : W.Equation x₁ y₁ :=
  equation_neg_iff.mp h
#align weierstrass_curve.equation_neg_of WeierstrassCurve.equation_neg_of

/-- The negation of an affine point in `W` lies in `W`. -/
theorem equation_neg (h : W.Equation x₁ y₁) : W.Equation x₁ <| W.negY x₁ y₁ :=
  equation_neg_iff.mpr h
#align weierstrass_curve.equation_neg WeierstrassCurve.equation_neg

theorem nonsingular_neg_iff : W.Nonsingular x₁ (W.negY x₁ y₁) ↔ W.Nonsingular x₁ y₁ :=
  by
  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_congr <| and_congr_left fun h => by rw [← h])
#align weierstrass_curve.nonsingular_neg_iff WeierstrassCurve.nonsingular_neg_iff

theorem nonsingular_neg_of (h : W.Nonsingular x₁ <| W.negY x₁ y₁) : W.Nonsingular x₁ y₁ :=
  nonsingular_neg_iff.mp h
#align weierstrass_curve.nonsingular_neg_of WeierstrassCurve.nonsingular_neg_of

/-- The negation of a nonsingular affine point in `W` is nonsingular. -/
theorem nonsingular_neg (h : W.Nonsingular x₁ y₁) : W.Nonsingular x₁ <| W.negY x₁ y₁ :=
  nonsingular_neg_iff.mpr h
#align weierstrass_curve.nonsingular_neg WeierstrassCurve.nonsingular_neg

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
#align weierstrass_curve.point.neg WeierstrassCurve.Point.neg

instance : Neg W.Point :=
  ⟨neg⟩

@[simp]
theorem neg_def (P : W.Point) : P.neg = -P :=
  rfl
#align weierstrass_curve.point.neg_def WeierstrassCurve.Point.neg_def

@[simp]
theorem neg_zero : (-0 : W.Point) = 0 :=
  rfl
#align weierstrass_curve.point.neg_zero WeierstrassCurve.Point.neg_zero

@[simp]
theorem neg_some (h : W.Nonsingular x₁ y₁) : -some h = some (nonsingular_neg h) :=
  rfl
#align weierstrass_curve.point.neg_some WeierstrassCurve.Point.neg_some

instance : InvolutiveNeg W.Point :=
  ⟨neg, by
    rintro (_ | _)
    · rfl
    · simp
      ring1⟩

end Point

end Basic

section Addition

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

open Classical

variable {F : Type u} [Field F] (W : WeierstrassCurve 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.negY x₂ y₂ then 0
    else (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁) / (y₁ - W.negY x₁ y₁)
  else (y₁ - y₂) / (x₁ - x₂)
#align weierstrass_curve.slope WeierstrassCurve.slope

variable {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]
theorem slope_of_Y_eq (hx : x₁ = x₂) (hy : y₁ = W.negY x₂ y₂) : W.slope x₁ x₂ y₁ y₂ = 0 := by
  rw [slope, dif_pos hx, dif_pos hy]
#align weierstrass_curve.slope_of_Y_eq WeierstrassCurve.slope_of_Y_eq

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

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

theorem slope_of_Y_ne_eq_eval (hx : x₁ = x₂) (hy : y₁ ≠ W.negY x₂ y₂) :
    W.slope x₁ x₂ y₁ y₂ =
      -(W.polynomialX.eval <| C y₁).eval x₁ / (W.polynomialY.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
#align weierstrass_curve.slope_of_Y_ne_eq_eval WeierstrassCurve.slope_of_Y_ne_eq_eval

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2137773769.map_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2137773769.map_simp -/
theorem baseChange_slope :
    (W.base_change K).slope (algebraMap F K x₁) (algebraMap F K x₂) (algebraMap F K y₁)
        (algebraMap F K y₂) =
      algebraMap F K (W.slope x₁ x₂ y₁ y₂) :=
  by
  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]
      · run_tac
          map_simp
        simpa only [base_change_neg_Y]
      · rw [base_change_neg_Y]
        contrapose! hy
        exact NoZeroSMulDivisors.algebraMap_injective F K hy
  · rw [slope_of_X_ne hx, slope_of_X_ne]
    ·
      run_tac
        map_simp
    · contrapose! hx
      exact NoZeroSMulDivisors.algebraMap_injective F K hx
#align weierstrass_curve.base_change_slope WeierstrassCurve.baseChange_slope

theorem baseChange_slope_of_baseChange {R : Type u} [CommRing R] (W : WeierstrassCurve R)
    (F : Type v) [Field F] [Algebra R F] (K : Type w) [Field K] [Algebra R K] [Algebra F K]
    [IsScalarTower R F K] (x₁ x₂ y₁ y₂ : F) :
    (W.base_change K).slope (algebraMap F K x₁) (algebraMap F K x₂) (algebraMap F K y₁)
        (algebraMap F K y₂) =
      algebraMap F K ((W.base_change F).slope x₁ x₂ y₁ y₂) :=
  by rw [← base_change_slope, base_change_base_change]
#align weierstrass_curve.base_change_slope_of_base_change WeierstrassCurve.baseChange_slope_of_baseChange

include h₁' h₂'

theorem Y_eq_of_X_eq (hx : x₁ = x₂) : y₁ = y₂ ∨ y₁ = W.negY x₂ y₂ :=
  by
  rw [equation_iff] at h₁' h₂'
  rw [← sub_eq_zero, ← @sub_eq_zero _ _ y₁, ← mul_eq_zero, neg_Y]
  linear_combination (norm := (rw [hx]; ring1)) h₁' - h₂'
#align weierstrass_curve.Y_eq_of_X_eq WeierstrassCurve.Y_eq_of_X_eq

theorem Y_eq_of_Y_ne (hx : x₁ = x₂) (hy : y₁ ≠ W.negY x₂ y₂) : y₁ = y₂ :=
  Or.resolve_right (Y_eq_of_X_eq h₁' h₂' hx) hy
#align weierstrass_curve.Y_eq_of_Y_ne WeierstrassCurve.Y_eq_of_Y_ne

theorem addPolynomial_slope (hxy : x₁ = x₂ → y₁ ≠ W.negY x₂ y₂) :
    W.addPolynomial x₁ y₁ (W.slope x₁ x₂ y₁ y₂) =
      -((X - C x₁) * (X - C x₂) * (X - C (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂))) :=
  by
  rw [add_polynomial_eq, neg_inj, Cubic.prod_X_sub_C_eq, Cubic.toPoly_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
    · rfl
    · simp only [add_X]
      ring1
    · field_simp [hxy rfl]
      ring1
    · linear_combination (norm := (field_simp [hxy rfl] ; ring1)) -h₁'
  · rw [equation_iff] at h₁' h₂'
    rw [slope_of_X_ne hx]
    rw [← sub_eq_zero] at hx
    ext
    · rfl
    · simp only [add_X]
      ring1
    · apply mul_right_injective₀ hx
      linear_combination (norm := (field_simp [hx] ; ring1)) h₂' - h₁'
    · apply mul_right_injective₀ hx
      linear_combination (norm := (field_simp [hx] ; ring1)) x₂ * h₁' - x₁ * h₂'
#align weierstrass_curve.add_polynomial_slope WeierstrassCurve.addPolynomial_slope

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.162409969.derivative_simp -/
theorem derivative_addPolynomial_slope (hxy : x₁ = x₂ → y₁ ≠ W.negY x₂ y₂) :
    derivative (W.addPolynomial x₁ y₁ <| W.slope x₁ x₂ y₁ y₂) =
      -((X - C x₁) * (X - C x₂) + (X - C x₁) * (X - C (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂)) +
          (X - C x₂) * (X - C (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂))) :=
  by
  rw [add_polynomial_slope h₁' h₂' hxy]
  run_tac
    derivative_simp
  ring1
#align weierstrass_curve.derivative_add_polynomial_slope WeierstrassCurve.derivative_addPolynomial_slope

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

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
/-- 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`. -/
theorem equation_add' (hxy : x₁ = x₂ → y₁ ≠ W.negY x₂ y₂) :
    W.Equation (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂) (W.addY' x₁ x₂ y₁ <| W.slope x₁ x₂ y₁ y₂) :=
  by
  rw [equation_add_iff, add_polynomial_slope h₁' h₂' hxy]
  run_tac
    eval_simp
  rw [neg_eq_zero, sub_self, MulZeroClass.mul_zero]
#align weierstrass_curve.equation_add' WeierstrassCurve.equation_add'

/-- The addition of two affine points in `W` on a sloped line lies in `W`. -/
theorem equation_add (hxy : x₁ = x₂ → y₁ ≠ W.negY x₂ y₂) :
    W.Equation (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂) (W.addY x₁ x₂ y₁ <| W.slope x₁ x₂ y₁ y₂) :=
  equation_neg <| equation_add' h₁' h₂' hxy
#align weierstrass_curve.equation_add WeierstrassCurve.equation_add

omit h₁' h₂'

include h₁ h₂

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3102772865.eval_simp -/
/-- 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. -/
theorem nonsingular_add' (hxy : x₁ = x₂ → y₁ ≠ W.negY x₂ y₂) :
    W.Nonsingular (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂) (W.addY' x₁ x₂ y₁ <| W.slope x₁ x₂ y₁ y₂) :=
  by
  by_cases hx₁ : W.add_X x₁ x₂ (W.slope x₁ x₂ y₁ y₂) = x₁
  · rwa [add_Y', hx₁, sub_self, MulZeroClass.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]
      run_tac
        eval_simp
      simpa only [neg_ne_zero, sub_self, MulZeroClass.mul_zero, add_zero] using
        mul_ne_zero (sub_ne_zero_of_ne hx₁) (sub_ne_zero_of_ne hx₂)
#align weierstrass_curve.nonsingular_add' WeierstrassCurve.nonsingular_add'

/-- The addition of two nonsingular affine points in `W` on a sloped line is nonsingular. -/
theorem nonsingular_add (hxy : x₁ = x₂ → y₁ ≠ W.negY x₂ y₂) :
    W.Nonsingular (W.addX x₁ x₂ <| W.slope x₁ x₂ y₁ y₂) (W.addY x₁ x₂ y₁ <| W.slope x₁ x₂ y₁ y₂) :=
  nonsingular_neg <| nonsingular_add' h₁ h₂ hxy
#align weierstrass_curve.nonsingular_add WeierstrassCurve.nonsingular_add

omit h₁ h₂

namespace Point

variable {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.negY x₂ y₂ then 0 else some <| nonsingular_add h₁ h₂ fun _ => hy
    else some <| nonsingular_add h₁ h₂ fun h => (hx h).elim
#align weierstrass_curve.point.add WeierstrassCurve.Point.add

noncomputable instance : Add W.Point :=
  ⟨add⟩

@[simp]
theorem add_def (P Q : W.Point) : P.add Q = P + Q :=
  rfl
#align weierstrass_curve.point.add_def WeierstrassCurve.Point.add_def

noncomputable instance : AddZeroClass W.Point :=
  ⟨0, (· + ·), by rintro (_ | _) <;> rfl, by rintro (_ | _) <;> rfl⟩

@[simp]
theorem some_add_some_of_Y_eq (hx : x₁ = x₂) (hy : y₁ = W.negY x₂ y₂) : some h₁ + some h₂ = 0 := by
  rw [← add_def, add, dif_pos hx, dif_pos hy]
#align weierstrass_curve.point.some_add_some_of_Y_eq WeierstrassCurve.Point.some_add_some_of_Y_eq

@[simp]
theorem some_add_self_of_Y_eq (hy : y₁ = W.negY x₁ y₁) : some h₁ + some h₁ = 0 :=
  some_add_some_of_Y_eq rfl hy
#align weierstrass_curve.point.some_add_self_of_Y_eq WeierstrassCurve.Point.some_add_self_of_Y_eq

@[simp]
theorem some_add_some_of_Y_ne (hx : x₁ = x₂) (hy : y₁ ≠ W.negY x₂ y₂) :
    some h₁ + some h₂ = some (nonsingular_add h₁ h₂ fun _ => hy) := by
  rw [← add_def, add, dif_pos hx, dif_neg hy]
#align weierstrass_curve.point.some_add_some_of_Y_ne WeierstrassCurve.Point.some_add_some_of_Y_ne

theorem some_add_some_of_Y_ne' (hx : x₁ = x₂) (hy : y₁ ≠ W.negY x₂ y₂) :
    some h₁ + some h₂ = -some (nonsingular_add' h₁ h₂ fun _ => hy) :=
  some_add_some_of_Y_ne hx hy
#align weierstrass_curve.point.some_add_some_of_Y_ne' WeierstrassCurve.Point.some_add_some_of_Y_ne'

@[simp]
theorem some_add_self_of_Y_ne (hy : y₁ ≠ W.negY x₁ y₁) :
    some h₁ + some h₁ = some (nonsingular_add h₁ h₁ fun _ => hy) :=
  some_add_some_of_Y_ne rfl hy
#align weierstrass_curve.point.some_add_self_of_Y_ne WeierstrassCurve.Point.some_add_self_of_Y_ne

theorem some_add_self_of_Y_ne' (hy : y₁ ≠ W.negY x₁ y₁) :
    some h₁ + some h₁ = -some (nonsingular_add' h₁ h₁ fun _ => hy) :=
  some_add_some_of_Y_ne rfl hy
#align weierstrass_curve.point.some_add_self_of_Y_ne' WeierstrassCurve.Point.some_add_self_of_Y_ne'

@[simp]
theorem some_add_some_of_X_ne (hx : x₁ ≠ x₂) :
    some h₁ + some h₂ = some (nonsingular_add h₁ h₂ fun h => (hx h).elim) := by
  rw [← add_def, add, dif_neg hx]
#align weierstrass_curve.point.some_add_some_of_X_ne WeierstrassCurve.Point.some_add_some_of_X_ne

theorem some_add_some_of_X_ne' (hx : x₁ ≠ x₂) :
    some h₁ + some h₂ = -some (nonsingular_add' h₁ h₂ fun h => (hx h).elim) :=
  some_add_some_of_X_ne hx
#align weierstrass_curve.point.some_add_some_of_X_ne' WeierstrassCurve.Point.some_add_some_of_X_ne'

end Point

end Addition

section Group

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

variable {F : Type u} [Field F] {W : WeierstrassCurve F}

namespace Point

@[simp]
theorem add_eq_zero (P Q : W.Point) : P + Q = 0 ↔ P = -Q :=
  by
  rcases P, Q with ⟨_ | @⟨x₁, y₁, _⟩, _ | @⟨x₂, y₂, _⟩⟩
  any_goals rfl
  · rw [zero_def, zero_add, ← neg_eq_iff_eq_neg, neg_zero, eq_comm]
  · simp only [neg_some]
    constructor
    · 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 fun ⟨hx, hy⟩ => some_add_some_of_Y_eq hx hy
#align weierstrass_curve.point.add_eq_zero WeierstrassCurve.Point.add_eq_zero

@[simp]
theorem add_left_neg (P : W.Point) : -P + P = 0 := by rw [add_eq_zero]
#align weierstrass_curve.point.add_left_neg WeierstrassCurve.Point.add_left_neg

@[simp]
theorem neg_add_eq_zero (P Q : W.Point) : -P + Q = 0 ↔ P = Q := by rw [add_eq_zero, neg_inj]
#align weierstrass_curve.point.neg_add_eq_zero WeierstrassCurve.Point.neg_add_eq_zero

end Point

end Group

section BaseChange

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

variable {R : Type u} [CommRing R] (W : WeierstrassCurve R) (F : Type v) [Field F] [Algebra R F]
  (K : Type w) [Field K] [Algebra R K] [Algebra F K] [IsScalarTower R F K]

namespace Point

open WeierstrassCurve

/- warning: weierstrass_curve.point.of_base_change_fun -> WeierstrassCurve.Point.ofBaseChangeFun is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : CommRing.{u1} R] (W : WeierstrassCurve.{u1} R) (F : Type.{u2}) [_inst_2 : Field.{u2} F] [_inst_3 : Algebra.{u1, u2} R F (CommRing.toCommSemiring.{u1} R _inst_1) (Ring.toSemiring.{u2} F (DivisionRing.toRing.{u2} F (Field.toDivisionRing.{u2} F _inst_2)))] (K : Type.{u3}) [_inst_4 : Field.{u3} K] [_inst_5 : Algebra.{u1, u3} R K (CommRing.toCommSemiring.{u1} R _inst_1) (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4)))] [_inst_6 : Algebra.{u2, u3} F K (Semifield.toCommSemiring.{u2} F (Field.toSemifield.{u2} F _inst_2)) (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4)))] [_inst_7 : IsScalarTower.{u1, u2, u3} R F K (SMulZeroClass.toHasSmul.{u1, u2} R F (AddZeroClass.toHasZero.{u2} F (AddMonoid.toAddZeroClass.{u2} F (AddCommMonoid.toAddMonoid.{u2} F (NonUnitalNonAssocSemiring.toAddCommMonoid.{u2} F (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} F (Semiring.toNonAssocSemiring.{u2} F (Ring.toSemiring.{u2} F (DivisionRing.toRing.{u2} F (Field.toDivisionRing.{u2} F _inst_2))))))))) (SMulWithZero.toSmulZeroClass.{u1, u2} R F (MulZeroClass.toHasZero.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (Semiring.toMonoidWithZero.{u1} R (CommSemiring.toSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)))))) (AddZeroClass.toHasZero.{u2} F (AddMonoid.toAddZeroClass.{u2} F (AddCommMonoid.toAddMonoid.{u2} F (NonUnitalNonAssocSemiring.toAddCommMonoid.{u2} F (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} F (Semiring.toNonAssocSemiring.{u2} F (Ring.toSemiring.{u2} F (DivisionRing.toRing.{u2} F (Field.toDivisionRing.{u2} F _inst_2))))))))) (MulActionWithZero.toSMulWithZero.{u1, u2} R F (Semiring.toMonoidWithZero.{u1} R (CommSemiring.toSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1))) (AddZeroClass.toHasZero.{u2} F (AddMonoid.toAddZeroClass.{u2} F (AddCommMonoid.toAddMonoid.{u2} F (NonUnitalNonAssocSemiring.toAddCommMonoid.{u2} F (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} F (Semiring.toNonAssocSemiring.{u2} F (Ring.toSemiring.{u2} F (DivisionRing.toRing.{u2} F (Field.toDivisionRing.{u2} F _inst_2))))))))) (Module.toMulActionWithZero.{u1, u2} R F (CommSemiring.toSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u2} F (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u2} F (Semiring.toNonAssocSemiring.{u2} F (Ring.toSemiring.{u2} F (DivisionRing.toRing.{u2} F (Field.toDivisionRing.{u2} F _inst_2)))))) (Algebra.toModule.{u1, u2} R F (CommRing.toCommSemiring.{u1} R _inst_1) (Ring.toSemiring.{u2} F (DivisionRing.toRing.{u2} F (Field.toDivisionRing.{u2} F _inst_2))) _inst_3))))) (SMulZeroClass.toHasSmul.{u2, u3} F K (AddZeroClass.toHasZero.{u3} K (AddMonoid.toAddZeroClass.{u3} K (AddCommMonoid.toAddMonoid.{u3} K (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))))))))) (SMulWithZero.toSmulZeroClass.{u2, u3} F K (MulZeroClass.toHasZero.{u2} F (MulZeroOneClass.toMulZeroClass.{u2} F (MonoidWithZero.toMulZeroOneClass.{u2} F (Semiring.toMonoidWithZero.{u2} F (CommSemiring.toSemiring.{u2} F (Semifield.toCommSemiring.{u2} F (Field.toSemifield.{u2} F _inst_2))))))) (AddZeroClass.toHasZero.{u3} K (AddMonoid.toAddZeroClass.{u3} K (AddCommMonoid.toAddMonoid.{u3} K (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))))))))) (MulActionWithZero.toSMulWithZero.{u2, u3} F K (Semiring.toMonoidWithZero.{u2} F (CommSemiring.toSemiring.{u2} F (Semifield.toCommSemiring.{u2} F (Field.toSemifield.{u2} F _inst_2)))) (AddZeroClass.toHasZero.{u3} K (AddMonoid.toAddZeroClass.{u3} K (AddCommMonoid.toAddMonoid.{u3} K (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))))))))) (Module.toMulActionWithZero.{u2, u3} F K (CommSemiring.toSemiring.{u2} F (Semifield.toCommSemiring.{u2} F (Field.toSemifield.{u2} F _inst_2))) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4)))))) (Algebra.toModule.{u2, u3} F K (Semifield.toCommSemiring.{u2} F (Field.toSemifield.{u2} F _inst_2)) (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))) _inst_6))))) (SMulZeroClass.toHasSmul.{u1, u3} R K (AddZeroClass.toHasZero.{u3} K (AddMonoid.toAddZeroClass.{u3} K (AddCommMonoid.toAddMonoid.{u3} K (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))))))))) (SMulWithZero.toSmulZeroClass.{u1, u3} R K (MulZeroClass.toHasZero.{u1} R (MulZeroOneClass.toMulZeroClass.{u1} R (MonoidWithZero.toMulZeroOneClass.{u1} R (Semiring.toMonoidWithZero.{u1} R (CommSemiring.toSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)))))) (AddZeroClass.toHasZero.{u3} K (AddMonoid.toAddZeroClass.{u3} K (AddCommMonoid.toAddMonoid.{u3} K (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))))))))) (MulActionWithZero.toSMulWithZero.{u1, u3} R K (Semiring.toMonoidWithZero.{u1} R (CommSemiring.toSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1))) (AddZeroClass.toHasZero.{u3} K (AddMonoid.toAddZeroClass.{u3} K (AddCommMonoid.toAddMonoid.{u3} K (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))))))))) (Module.toMulActionWithZero.{u1, u3} R K (CommSemiring.toSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u3} K (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u3} K (Semiring.toNonAssocSemiring.{u3} K (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4)))))) (Algebra.toModule.{u1, u3} R K (CommRing.toCommSemiring.{u1} R _inst_1) (Ring.toSemiring.{u3} K (DivisionRing.toRing.{u3} K (Field.toDivisionRing.{u3} K _inst_4))) _inst_5)))))], (WeierstrassCurve.Point.{u2} F (EuclideanDomain.toCommRing.{u2} F (Field.toEuclideanDomain.{u2} F _inst_2)) (WeierstrassCurve.baseChange.{u1, u2} R _inst_1 W F (EuclideanDomain.toCommRing.{u2} F (Field.toEuclideanDomain.{u2} F _inst_2)) _inst_3)) -> (WeierstrassCurve.Point.{u3} K (EuclideanDomain.toCommRing.{u3} K (Field.toEuclideanDomain.{u3} K _inst_4)) (WeierstrassCurve.baseChange.{u1, u3} R _inst_1 W K (EuclideanDomain.toCommRing.{u3} K (Field.toEuclideanDomain.{u3} K _inst_4)) _inst_5))
but is expected to have type
  PUnit.{max (max (succ (succ u1)) (succ (succ u2))) (succ (succ u3))}
Case conversion may be inaccurate. Consider using '#align weierstrass_curve.point.of_base_change_fun WeierstrassCurve.Point.ofBaseChangeFunₓ'. -/
/-- The function from `W⟮F⟯` to `W⟮K⟯` induced by a base change from `F` to `K`. -/
def ofBaseChangeFun : W⟮F⟯ → W⟮K⟯
  | 0 => 0
  | some h => some <| (nonsingular_iff_baseChange_of_baseChange W F K _ _).mp h
#align weierstrass_curve.point.of_base_change_fun WeierstrassCurve.Point.ofBaseChangeFun

/-- The group homomorphism from `W⟮F⟯` to `W⟮K⟯` induced by a base change from `F` to `K`. -/
@[simps]
def ofBaseChange : W⟮F⟯ →+ W⟮K⟯
    where
  toFun := ofBaseChangeFun W F K
  map_zero' := rfl
  map_add' := by
    rintro (_ | @⟨x₁, y₁, _⟩) (_ | @⟨x₂, y₂, _⟩)
    any_goals rfl
    by_cases hx : x₁ = x₂
    · by_cases hy : y₁ = (W.base_change F).negY 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 NoZeroSMulDivisors.algebraMap_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 NoZeroSMulDivisors.algebraMap_injective F K hx
#align weierstrass_curve.point.of_base_change WeierstrassCurve.Point.ofBaseChange

theorem ofBaseChange_injective : Function.Injective <| ofBaseChange W F K :=
  by
  rintro (_ | _) (_ | _) h
  · rfl
  any_goals contradiction
  simp only
  exact
    ⟨NoZeroSMulDivisors.algebraMap_injective F K (some.inj h).left,
      NoZeroSMulDivisors.algebraMap_injective F K (some.inj h).right⟩
#align weierstrass_curve.point.of_base_change_injective WeierstrassCurve.Point.ofBaseChange_injective

end Point

end BaseChange

end WeierstrassCurve

namespace EllipticCurve

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

namespace Point

variable {R : Type} [Nontrivial R] [CommRing R] (E : EllipticCurve R)

/-- An affine point on an elliptic curve `E` over `R`. -/
def mk {x y : R} (h : E.Equation x y) : E.Point :=
  WeierstrassCurve.Point.some <| E.Nonsingular h
#align elliptic_curve.point.mk EllipticCurve.Point.mk

end Point

end EllipticCurve


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import algebra.hom.equiv
import data.part
import tactic.norm_num

/-!
# Natural numbers with infinity

The natural numbers and an extra `top` element `⊤`.

## Main definitions

The following instances are defined:

* `ordered_add_comm_monoid enat`
* `canonically_ordered_add_monoid enat`

There is no additive analogue of `monoid_with_zero`; if there were then `enat` could
be an `add_monoid_with_top`.

* `to_with_top` : the map from `enat` to `with_top ℕ`, with theorems that it plays well
with `+` and `≤`.

* `with_top_add_equiv : enat ≃+ with_top ℕ`
* `with_top_order_iso : enat ≃o with_top ℕ`

## Implementation details

`enat` is defined to be `part ℕ`.

`+` and `≤` are defined on `enat`, but there is an issue with `*` because it's not
clear what `0 * ⊤` should be. `mul` is hence left undefined. Similarly `⊤ - ⊤` is ambiguous
so there is no `-` defined on `enat`.

Before the `open_locale classical` line, various proofs are made with decidability assumptions.
This can cause issues -- see for example the non-simp lemma `to_with_top_zero` proved by `rfl`,
followed by `@[simp] lemma to_with_top_zero'` whose proof uses `convert`.

## Tags

enat, with_top ℕ
-/
open part (hiding some)

/-- Type of natural numbers with infinity (`⊤`) -/
def enat : Type := part ℕ

namespace enat

/-- The computable embedding `ℕ → enat`.

This coincides with the coercion `coe : ℕ → enat`, see `enat.some_eq_coe`.
However, `coe` is noncomputable so `some` is preferable when computability is a concern. -/
def some : ℕ → enat := part.some

instance : has_zero enat := ⟨some 0⟩
instance : inhabited enat := ⟨0⟩
instance : has_one enat := ⟨some 1⟩
instance : has_add enat := ⟨λ x y, ⟨x.dom ∧ y.dom, λ h, get x h.1 + get y h.2⟩⟩

instance (n : ℕ) : decidable (some n).dom := is_true trivial

lemma some_eq_coe (n : ℕ) : some n = n :=
begin
  induction n with n ih, { refl },
  apply part.ext',
  { show true ↔ ((n : enat).dom ∧ true), rw [← ih, and_true], exact iff.rfl },
  { intros h H, show n.succ = (n : enat).get H.1 + 1,
    rw [nat.cast_succ] at H, revert H, simp only [← ih], intro, refl },
end

@[simp] lemma coe_inj {x y : ℕ} : (x : enat) = y ↔ x = y :=
by simpa only [← some_eq_coe] using part.some_inj

@[simp] lemma dom_some (x : ℕ) : (some x).dom := trivial

@[simp] lemma dom_coe (x : ℕ) : (x : enat).dom := by rw [← some_eq_coe]; trivial

instance : add_comm_monoid enat :=
{ add       := (+),
  zero      := (0),
  add_comm  := λ x y, part.ext' and.comm (λ _ _, add_comm _ _),
  zero_add  := λ x, part.ext' (true_and _) (λ _ _, zero_add _),
  add_zero  := λ x, part.ext' (and_true _) (λ _ _, add_zero _),
  add_assoc := λ x y z, part.ext' and.assoc (λ _ _, add_assoc _ _ _) }

instance : has_le enat := ⟨λ x y, ∃ h : y.dom → x.dom, ∀ hy : y.dom, x.get (h hy) ≤ y.get hy⟩
instance : has_top enat := ⟨none⟩
instance : has_bot enat := ⟨0⟩
instance : has_sup enat := ⟨λ x y, ⟨x.dom ∧ y.dom, λ h, x.get h.1 ⊔ y.get h.2⟩⟩

lemma le_def (x y : enat) : x ≤ y ↔ ∃ h : y.dom → x.dom, ∀ hy : y.dom, x.get (h hy) ≤ y.get hy :=
iff.rfl

@[elab_as_eliminator] protected lemma cases_on' {P : enat → Prop} :
  ∀ a : enat, P ⊤ → (∀ n : ℕ, P (some n)) → P a :=
part.induction_on

@[elab_as_eliminator] protected lemma cases_on {P : enat → Prop} :
  ∀ a : enat, P ⊤ → (∀ n : ℕ, P n) → P a :=
by { simp only [← some_eq_coe], exact enat.cases_on' }

@[simp] lemma top_add (x : enat) : ⊤ + x = ⊤ :=
part.ext' (false_and _) (λ h, h.left.elim)

@[simp] lemma add_top (x : enat) : x + ⊤ = ⊤ :=
by rw [add_comm, top_add]

@[simp] lemma coe_get {x : enat} (h : x.dom) : (x.get h : enat) = x :=
by { rw [← some_eq_coe], exact part.ext' (iff_of_true trivial h) (λ _ _, rfl) }

@[simp, norm_cast] lemma get_coe' (x : ℕ) (h : (x : enat).dom) : get (x : enat) h = x :=
by rw [← coe_inj, coe_get]

lemma get_coe {x : ℕ} : get (x : enat) (dom_coe x) = x := get_coe' _ _

lemma coe_add_get {x : ℕ} {y : enat} (h : ((x : enat) + y).dom) :
  get ((x : enat) + y) h = x + get y h.2 :=
by { simp only [← some_eq_coe] at h ⊢, refl }

@[simp] lemma get_add {x y : enat} (h : (x + y).dom) :
  get (x + y) h = x.get h.1 + y.get h.2 := rfl

@[simp] lemma get_zero (h : (0 : enat).dom) : (0 : enat).get h = 0 := rfl

@[simp] lemma get_one (h : (1 : enat).dom) : (1 : enat).get h = 1 := rfl

lemma get_eq_iff_eq_some {a : enat} {ha : a.dom} {b : ℕ} :
  a.get ha = b ↔ a = some b := get_eq_iff_eq_some

lemma get_eq_iff_eq_coe {a : enat} {ha : a.dom} {b : ℕ} :
  a.get ha = b ↔ a = b := by rw [get_eq_iff_eq_some, some_eq_coe]

lemma dom_of_le_of_dom {x y : enat} : x ≤ y → y.dom → x.dom := λ ⟨h, _⟩, h

lemma dom_of_le_some {x : enat} {y : ℕ} (h : x ≤ some y) : x.dom := dom_of_le_of_dom h trivial

lemma dom_of_le_coe {x : enat} {y : ℕ} (h : x ≤ y) : x.dom :=
by { rw [← some_eq_coe] at h, exact dom_of_le_some h }

instance decidable_le (x y : enat) [decidable x.dom] [decidable y.dom] : decidable (x ≤ y) :=
if hx : x.dom
then decidable_of_decidable_of_iff
  (show decidable (∀ (hy : (y : enat).dom), x.get hx ≤ (y : enat).get hy),
    from forall_prop_decidable _) $
  by { dsimp [(≤)], simp only [hx, exists_prop_of_true, forall_true_iff] }
else if hy : y.dom
then is_false $ λ h, hx $ dom_of_le_of_dom h hy
else is_true ⟨λ h, (hy h).elim, λ h, (hy h).elim⟩

/-- The coercion `ℕ → enat` preserves `0` and addition. -/
def coe_hom : ℕ →+ enat := ⟨coe, nat.cast_zero, nat.cast_add⟩

@[simp] lemma coe_coe_hom : ⇑coe_hom = coe := rfl

instance : partial_order enat :=
{ le          := (≤),
  le_refl     := λ x, ⟨id, λ _, le_rfl⟩,
  le_trans    := λ x y z ⟨hxy₁, hxy₂⟩ ⟨hyz₁, hyz₂⟩,
    ⟨hxy₁ ∘ hyz₁, λ _, le_trans (hxy₂ _) (hyz₂ _)⟩,
  le_antisymm := λ x y ⟨hxy₁, hxy₂⟩ ⟨hyx₁, hyx₂⟩, part.ext' ⟨hyx₁, hxy₁⟩
    (λ _ _, le_antisymm (hxy₂ _) (hyx₂ _)) }

lemma lt_def (x y : enat) : x < y ↔ ∃ (hx : x.dom), ∀ (hy : y.dom), x.get hx < y.get hy :=
begin
  rw [lt_iff_le_not_le, le_def, le_def, not_exists],
  split,
  { rintro ⟨⟨hyx, H⟩, h⟩,
    by_cases hx : x.dom,
    { use hx, intro hy,
      specialize H hy, specialize h (λ _, hy),
      rw not_forall at h, cases h with hx' h,
      rw not_le at h, exact h },
    { specialize h (λ hx', (hx hx').elim),
      rw not_forall at h, cases h with hx' h,
      exact (hx hx').elim } },
  { rintro ⟨hx, H⟩, exact ⟨⟨λ _, hx, λ hy, (H hy).le⟩, λ hxy h, not_lt_of_le (h _) (H _)⟩ }
end

@[simp, norm_cast] lemma coe_le_coe {x y : ℕ} : (x : enat) ≤ y ↔ x ≤ y :=
by { rw [← some_eq_coe, ← some_eq_coe], exact ⟨λ ⟨_, h⟩, h trivial, λ h, ⟨λ _, trivial, λ _, h⟩⟩ }

@[simp, norm_cast] lemma coe_lt_coe {x y : ℕ} : (x : enat) < y ↔ x < y :=
by rw [lt_iff_le_not_le, lt_iff_le_not_le, coe_le_coe, coe_le_coe]

@[simp] lemma get_le_get {x y : enat} {hx : x.dom} {hy : y.dom} :
  x.get hx ≤ y.get hy ↔ x ≤ y :=
by conv { to_lhs, rw [← coe_le_coe, coe_get, coe_get]}

lemma le_coe_iff (x : enat) (n : ℕ) : x ≤ n ↔ ∃ h : x.dom, x.get h ≤ n :=
begin
  rw [← some_eq_coe],
  show (∃ (h : true → x.dom), _) ↔ ∃ h : x.dom, x.get h ≤ n,
  simp only [forall_prop_of_true, some_eq_coe, dom_coe, get_coe']
end

lemma lt_coe_iff (x : enat) (n : ℕ) : x < n ↔ ∃ h : x.dom, x.get h < n :=
by simp only [lt_def, forall_prop_of_true, get_coe', dom_coe]

lemma coe_le_iff (n : ℕ) (x : enat) : (n : enat) ≤ x ↔ ∀ h : x.dom, n ≤ x.get h :=
begin
  rw [← some_eq_coe],
  simp only [le_def, exists_prop_of_true, dom_some, forall_true_iff],
  refl,
end

lemma coe_lt_iff (n : ℕ) (x : enat) : (n : enat) < x ↔ ∀ h : x.dom, n < x.get h :=
begin
  rw [← some_eq_coe],
  simp only [lt_def, exists_prop_of_true, dom_some, forall_true_iff],
  refl,
end

protected lemma zero_lt_one : (0 : enat) < 1 :=
by { norm_cast, norm_num }

instance semilattice_sup : semilattice_sup enat :=
{ sup := (⊔),
  le_sup_left := λ _ _, ⟨and.left, λ _, le_sup_left⟩,
  le_sup_right := λ _ _, ⟨and.right, λ _, le_sup_right⟩,
  sup_le := λ x y z ⟨hx₁, hx₂⟩ ⟨hy₁, hy₂⟩, ⟨λ hz, ⟨hx₁ hz, hy₁ hz⟩,
    λ _, sup_le (hx₂ _) (hy₂ _)⟩,
  ..enat.partial_order }

instance order_bot : order_bot enat :=
{ bot := (⊥),
  bot_le := λ _, ⟨λ _, trivial, λ _, nat.zero_le _⟩ }

instance order_top : order_top enat :=
{ top := (⊤),
  le_top := λ x, ⟨λ h, false.elim h, λ hy, false.elim hy⟩ }

lemma dom_of_lt {x y : enat} : x < y → x.dom :=
enat.cases_on x not_top_lt $ λ _ _, dom_coe _

lemma top_eq_none : (⊤ : enat) = none := rfl

@[simp] lemma coe_lt_top (x : ℕ) : (x : enat) < ⊤ :=
ne.lt_top (λ h, absurd (congr_arg dom h) $ by simpa only [dom_coe] using true_ne_false)

@[simp] lemma coe_ne_top (x : ℕ) : (x : enat) ≠ ⊤ := ne_of_lt (coe_lt_top x)

lemma ne_top_iff {x : enat} : x ≠ ⊤ ↔ ∃ (n : ℕ), x = n :=
by simpa only [← some_eq_coe] using part.ne_none_iff

lemma ne_top_iff_dom {x : enat} : x ≠ ⊤ ↔ x.dom :=
by classical; exact not_iff_comm.1 part.eq_none_iff'.symm

lemma ne_top_of_lt {x y : enat} (h : x < y) : x ≠ ⊤ :=
ne_of_lt $ lt_of_lt_of_le h le_top

lemma eq_top_iff_forall_lt (x : enat) : x = ⊤ ↔ ∀ n : ℕ, (n : enat) < x :=
begin
  split,
  { rintro rfl n, exact coe_lt_top _ },
  { contrapose!, rw ne_top_iff, rintro ⟨n, rfl⟩, exact ⟨n, irrefl _⟩ }
end

lemma eq_top_iff_forall_le (x : enat) : x = ⊤ ↔ ∀ n : ℕ, (n : enat) ≤ x :=
(eq_top_iff_forall_lt x).trans
⟨λ h n, (h n).le, λ h n, lt_of_lt_of_le (coe_lt_coe.mpr n.lt_succ_self) (h (n + 1))⟩

lemma pos_iff_one_le {x : enat} : 0 < x ↔ 1 ≤ x :=
enat.cases_on x (by simp only [iff_true, le_top, coe_lt_top, ← @nat.cast_zero enat]) $
  λ n, by { rw [← nat.cast_zero, ← nat.cast_one, enat.coe_lt_coe, enat.coe_le_coe], refl }

instance : is_total enat (≤) :=
{ total := λ x y, enat.cases_on x
    (or.inr le_top) (enat.cases_on y (λ _, or.inl le_top)
      (λ x y, (le_total x y).elim (or.inr ∘ coe_le_coe.2)
        (or.inl ∘ coe_le_coe.2))) }

noncomputable instance : linear_order enat :=
{ le_total := is_total.total,
  decidable_le := classical.dec_rel _,
  max := (⊔),
  max_def := @sup_eq_max_default _ _ (id _) _,
  ..enat.partial_order }

instance : bounded_order enat :=
{ ..enat.order_top,
  ..enat.order_bot }

noncomputable instance : lattice enat :=
{ inf := min,
  inf_le_left := min_le_left,
  inf_le_right := min_le_right,
  le_inf := λ _ _ _, le_min,
  ..enat.semilattice_sup }

instance : ordered_add_comm_monoid enat :=
{ add_le_add_left := λ a b ⟨h₁, h₂⟩ c,
    enat.cases_on c (by simp)
      (λ c, ⟨λ h, and.intro (dom_coe _) (h₁ h.2),
        λ h, by simpa only [coe_add_get] using add_le_add_left (h₂ _) c⟩),
  ..enat.linear_order,
  ..enat.add_comm_monoid }

instance : canonically_ordered_add_monoid enat :=
{ le_iff_exists_add := λ a b, enat.cases_on b
    (iff_of_true le_top ⟨⊤, (add_top _).symm⟩)
    (λ b, enat.cases_on a
      (iff_of_false (not_le_of_gt (coe_lt_top _))
        (not_exists.2 (λ x, ne_of_lt (by rw [top_add]; exact coe_lt_top _))))
      (λ a, ⟨λ h, ⟨(b - a : ℕ),
          by rw [← nat.cast_add, coe_inj, add_comm, tsub_add_cancel_of_le (coe_le_coe.1 h)]⟩,
        (λ ⟨c, hc⟩, enat.cases_on c
          (λ hc, hc.symm ▸ show (a : enat) ≤ a + ⊤, by rw [add_top]; exact le_top)
          (λ c (hc : (b : enat) = a + c),
            coe_le_coe.2 (by rw [← nat.cast_add, coe_inj] at hc;
              rw hc; exact nat.le_add_right _ _)) hc)⟩)),
  ..enat.semilattice_sup,
  ..enat.order_bot,
  ..enat.ordered_add_comm_monoid }

protected lemma add_lt_add_right {x y z : enat} (h : x < y) (hz : z ≠ ⊤) : x + z < y + z :=
begin
  rcases ne_top_iff.mp (ne_top_of_lt h) with ⟨m, rfl⟩,
  rcases ne_top_iff.mp hz with ⟨k, rfl⟩,
  induction y using enat.cases_on with n,
  { rw [top_add], apply_mod_cast coe_lt_top },
  norm_cast at h, apply_mod_cast add_lt_add_right h
end

protected lemma add_lt_add_iff_right {x y z : enat} (hz : z ≠ ⊤) : x + z < y + z ↔ x < y :=
⟨lt_of_add_lt_add_right, λ h, enat.add_lt_add_right h hz⟩

protected lemma add_lt_add_iff_left {x y z : enat} (hz : z ≠ ⊤) : z + x < z + y ↔ x < y :=
by rw [add_comm z, add_comm z, enat.add_lt_add_iff_right hz]

protected lemma lt_add_iff_pos_right {x y : enat} (hx : x ≠ ⊤) : x < x + y ↔ 0 < y :=
by { conv_rhs { rw [← enat.add_lt_add_iff_left hx] }, rw [add_zero] }

lemma lt_add_one {x : enat} (hx : x ≠ ⊤) : x < x + 1 :=
by { rw [enat.lt_add_iff_pos_right hx], norm_cast, norm_num }

lemma le_of_lt_add_one {x y : enat} (h : x < y + 1) : x ≤ y :=
begin
  induction y using enat.cases_on with n, apply le_top,
  rcases ne_top_iff.mp (ne_top_of_lt h) with ⟨m, rfl⟩,
  apply_mod_cast nat.le_of_lt_succ, apply_mod_cast h
end

lemma add_one_le_of_lt {x y : enat} (h : x < y) : x + 1 ≤ y :=
begin
  induction y using enat.cases_on with n, apply le_top,
  rcases ne_top_iff.mp (ne_top_of_lt h) with ⟨m, rfl⟩,
  apply_mod_cast nat.succ_le_of_lt, apply_mod_cast h
end

lemma add_one_le_iff_lt {x y : enat} (hx : x ≠ ⊤) : x + 1 ≤ y ↔ x < y :=
begin
  split, swap, exact add_one_le_of_lt,
  intro h, rcases ne_top_iff.mp hx with ⟨m, rfl⟩,
  induction y using enat.cases_on with n, apply coe_lt_top,
  apply_mod_cast nat.lt_of_succ_le, apply_mod_cast h
end

lemma lt_add_one_iff_lt {x y : enat} (hx : x ≠ ⊤) : x < y + 1 ↔ x ≤ y :=
begin
  split, exact le_of_lt_add_one,
  intro h, rcases ne_top_iff.mp hx with ⟨m, rfl⟩,
  induction y using enat.cases_on with n, { rw [top_add], apply coe_lt_top },
  apply_mod_cast nat.lt_succ_of_le, apply_mod_cast h
end

lemma add_eq_top_iff {a b : enat} : a + b = ⊤ ↔ a = ⊤ ∨ b = ⊤ :=
by apply enat.cases_on a; apply enat.cases_on b;
  simp; simp only [(nat.cast_add _ _).symm, enat.coe_ne_top]; simp

protected lemma add_right_cancel_iff {a b c : enat} (hc : c ≠ ⊤) : a + c = b + c ↔ a = b :=
begin
  rcases ne_top_iff.1 hc with ⟨c, rfl⟩,
  apply enat.cases_on a; apply enat.cases_on b;
  simp [add_eq_top_iff, coe_ne_top, @eq_comm _ (⊤ : enat)];
  simp only [(nat.cast_add _ _).symm, add_left_cancel_iff, enat.coe_inj, add_comm];
  tauto
end

protected lemma add_left_cancel_iff {a b c : enat} (ha : a ≠ ⊤) : a + b = a + c ↔ b = c :=
by rw [add_comm a, add_comm a, enat.add_right_cancel_iff ha]

section with_top

/-- Computably converts an `enat` to a `with_top ℕ`. -/
def to_with_top (x : enat) [decidable x.dom] : with_top ℕ := x.to_option

lemma to_with_top_top : to_with_top ⊤ = ⊤ := rfl

@[simp] lemma to_with_top_top' {h : decidable (⊤ : enat).dom} : to_with_top ⊤ = ⊤ :=
by convert to_with_top_top

lemma to_with_top_zero : to_with_top 0 = 0 := rfl

@[simp] lemma to_with_top_zero' {h : decidable (0 : enat).dom} : to_with_top 0 = 0 :=
by convert to_with_top_zero

lemma to_with_top_some (n : ℕ) : to_with_top (some n) = n := rfl

lemma to_with_top_coe (n : ℕ) {_ : decidable (n : enat).dom} : to_with_top n = n :=
by simp only [← some_eq_coe, ← to_with_top_some]

@[simp] lemma to_with_top_coe' (n : ℕ) {h : decidable (n : enat).dom} :
  to_with_top (n : enat) = n :=
by convert to_with_top_coe n

@[simp] lemma to_with_top_le {x y : enat} : Π [decidable x.dom]
  [decidable y.dom], by exactI to_with_top x ≤ to_with_top y ↔ x ≤ y :=
enat.cases_on y (by simp) (enat.cases_on x (by simp) (by intros; simp))

@[simp] lemma to_with_top_lt {x y : enat} [decidable x.dom] [decidable y.dom] :
  to_with_top x < to_with_top y ↔ x < y :=
lt_iff_lt_of_le_iff_le to_with_top_le

end with_top

section with_top_equiv

open_locale classical

@[simp] lemma to_with_top_add {x y : enat} : to_with_top (x + y) = to_with_top x + to_with_top y :=
by apply enat.cases_on y; apply enat.cases_on x; simp [← nat.cast_add, ← with_top.coe_add]

/-- `equiv` between `enat` and `with_top ℕ` (for the order isomorphism see `with_top_order_iso`). -/
noncomputable def with_top_equiv : enat ≃ with_top ℕ :=
{ to_fun := λ x, to_with_top x,
  inv_fun := λ x, match x with (option.some n) := coe n | none := ⊤ end,
  left_inv := λ x, by apply enat.cases_on x; intros; simp; refl,
  right_inv := λ x, by cases x; simp [with_top_equiv._match_1]; refl }

@[simp] lemma with_top_equiv_top : with_top_equiv ⊤ = ⊤ :=
to_with_top_top'

@[simp] lemma with_top_equiv_coe (n : nat) : with_top_equiv n = n :=
to_with_top_coe' _

@[simp] lemma with_top_equiv_zero : with_top_equiv 0 = 0 :=
by simpa only [nat.cast_zero] using with_top_equiv_coe 0

@[simp] lemma with_top_equiv_le {x y : enat} : with_top_equiv x ≤ with_top_equiv y ↔ x ≤ y :=
to_with_top_le

@[simp] lemma with_top_equiv_lt {x y : enat} : with_top_equiv x < with_top_equiv y ↔ x < y :=
to_with_top_lt

/-- `to_with_top` induces an order isomorphism between `enat` and `with_top ℕ`. -/
noncomputable def with_top_order_iso : enat ≃o with_top ℕ :=
{ map_rel_iff' := λ _ _, with_top_equiv_le,
  .. with_top_equiv}

@[simp] lemma with_top_equiv_symm_top : with_top_equiv.symm ⊤ = ⊤ :=
rfl

@[simp] lemma with_top_equiv_symm_coe (n : nat) : with_top_equiv.symm n = n :=
rfl

@[simp] lemma with_top_equiv_symm_zero : with_top_equiv.symm 0 = 0 :=
rfl

@[simp] lemma with_top_equiv_symm_le {x y : with_top ℕ} :
  with_top_equiv.symm x ≤ with_top_equiv.symm y ↔ x ≤ y :=
by rw ← with_top_equiv_le; simp

@[simp] lemma with_top_equiv_symm_lt {x y : with_top ℕ} :
  with_top_equiv.symm x < with_top_equiv.symm y ↔ x < y :=
by rw ← with_top_equiv_lt; simp

/-- `to_with_top` induces an additive monoid isomorphism between `enat` and `with_top ℕ`. -/
noncomputable def with_top_add_equiv : enat ≃+ with_top ℕ :=
{ map_add' := λ x y, by simp only [with_top_equiv]; convert to_with_top_add,
  ..with_top_equiv}

end with_top_equiv

lemma lt_wf : well_founded ((<) : enat → enat → Prop) :=
show well_founded (λ a b : enat, a < b),
by haveI := classical.dec; simp only [to_with_top_lt.symm] {eta := ff};
    exact inv_image.wf _ (with_top.well_founded_lt nat.lt_wf)

instance : has_well_founded enat := ⟨(<), lt_wf⟩

section find

variables (P : ℕ → Prop) [decidable_pred P]

/-- The smallest `enat` satisfying a (decidable) predicate `P : ℕ → Prop` -/
def find : enat := ⟨∃ n, P n, nat.find⟩

@[simp] lemma find_get (h : (find P).dom) : (find P).get h = nat.find h := rfl

lemma find_dom (h : ∃ n, P n) : (find P).dom := h

lemma lt_find (n : ℕ) (h : ∀ m ≤ n, ¬P m) : (n : enat) < find P :=
begin
  rw coe_lt_iff, intro h', rw find_get,
  have := @nat.find_spec P _ h',
  contrapose! this,
  exact h _ this
end

lemma lt_find_iff (n : ℕ) : (n : enat) < find P ↔ (∀ m ≤ n, ¬P m) :=
begin
  refine ⟨_, lt_find P n⟩,
  intros h m hm,
  by_cases H : (find P).dom,
  { apply nat.find_min H, rw coe_lt_iff at h, specialize h H, exact lt_of_le_of_lt hm h },
  { exact not_exists.mp H m }
end

lemma find_le (n : ℕ) (h : P n) : find P ≤ n :=
by { rw le_coe_iff, refine ⟨⟨_, h⟩, @nat.find_min' P _ _ _ h⟩ }

lemma find_eq_top_iff : find P = ⊤ ↔ ∀ n, ¬P n :=
(eq_top_iff_forall_lt _).trans
⟨λ h n, (lt_find_iff P n).mp (h n) _ le_rfl, λ h n, lt_find P n $ λ _ _, h _⟩

end find

noncomputable instance : linear_ordered_add_comm_monoid_with_top enat :=
{ top_add' := top_add,
  .. enat.linear_order,
  .. enat.ordered_add_comm_monoid,
  .. enat.order_top }

end enat


import tactic.tidy

import set_category.diagram_lemmas
import help_functions
import category_theory.category

namespace Coequalizer

open set
     diagram_lemmas
     classical
     function
     help_functions
     category_theory

universe u

local notation f ` ⊚ `:80 g:80 := category_struct.comp g f

def is_coequalizer {X : Type u} [category X]
    {A B C : X}
    (f g : A ⟶ B)
    (c : B ⟶ C) : Prop :=
    c ⊚ f = c ⊚ g ∧
    Π (Q : X) (q : B ⟶ Q),
    q ⊚ f = q ⊚ g →
    ∃! h : C ⟶ Q , h ⊚ c = q

variables {A B C : Type u}
variables (f g : A ⟶ B)

def R : B → B → Prop :=
    λ b₁ b₂ , ∃ a , f a = b₁ ∧ g a = b₂

def Θ : B → B → Prop := eqv_gen (R f g)

def Θ_setoid : setoid B := eqv_gen.setoid (R f g)

definition theta := quotient (Θ_setoid f g)

local notation `⟦`:max a `⟧`:0 := @quotient.mk B (Θ_setoid f g) a

definition coequalizer : B → theta f g := λ b, ⟦b⟧

open eqv_gen

lemma quot_is_surjective : surjective (coequalizer f g) :=
    by tidy

lemma coequalizer_kern :
    Π (Q : Type u) (q : B → Q),
    q ∘ f = q ∘ g → sub_kern (coequalizer f g) q :=
    begin
        intros Q q qfg,
        let co := (coequalizer f g),
        let ker := kern co,
        let ker_q := kern q,

        intros b₁ b₂ kb1b2,
        have quotb1b2 : ⟦b₁⟧ = ⟦b₂⟧  := kb1b2,
        let Θb1b2 : eqv_gen (R f g) b₁ b₂ :=
            @quotient.exact B (Θ_setoid f g)
            b₁ b₂
            quotb1b2,
        apply eqv_gen.rec_on Θb1b2,

        exact (λ b₁ b₂ (h: ∃ a : A , f a = b₁ ∧ g a = b₂),
            let a : A := some h in
            have fa_ga : f a = b₁ ∧ g a = b₂ := some_spec h,

            calc q b₁ = (q ∘ f) a       : by simp [some_spec h]
                  ... = (q ∘ g) a       : by simp [qfg]
                  ... = q b₂            : by simp [some_spec h]
            ),

        -- refl : ∀ (x : B), ker_q x x
        exact (λ x, rfl),

        -- symm : ∀ (x y : B), eqv_gen (R f g) x y → ker_q x y → ker_q y x
        exact (λ x y _ (h : q x = q y), eq.symm h),

        -- trans :∀ (x y z : B),
        --    eqv_gen (R f g) x y → eqv_gen (R f g) y z →
        --         ker_q x y → ker_q y z → ker_q x z

        exact (λ x y z _ _ (h₁ : q x = q y) (h₂ : q y = q z), eq.trans h₁ h₂),

    end

lemma quot_is_coequalizer
    : is_coequalizer f g (coequalizer f g) :=
    ⟨
        have element : ∀ a : A,
        ((coequalizer f g) ∘ f) a = ((coequalizer f g) ∘ g) a
        := assume a,
            have Rfg : R f g (f a) (g a) := exists.intro a ⟨rfl , rfl⟩,
            have Θfg : Θ f g (f a) (g a) := eqv_gen.rel (f a) (g a) Rfg,
            quot.sound Θfg,
        funext element
        ,
        begin
            intros Q q qfg,

            let co := (coequalizer f g),

            have sub_ker : sub_kern co q := coequalizer_kern f g Q q qfg,

            exact
                (diagram_surjective
                    co
                    q
                    (quot_is_surjective f g)).elim_right
                sub_ker
        end
    ⟩

end Coequalizer


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

Theorems about the natural numbers specific to HoTT
-/
import .order ..pointed .sub
universes u v w
hott_theory
namespace hott

open nat is_trunc hott.algebra hott.is_equiv hott.equiv

namespace nat
  @[hott, instance] def is_prop_le (n m : ℕ) : is_prop (n ≤ m) :=
  begin
    have lem : Π{n m : ℕ} (p : n ≤ m) (q : n = m), p = nat.le_of_eq q,
    begin
      intros, hinduction p with m p IH,
      { have H' : idp = q, by apply is_set.elim,
        hinduction H', reflexivity },
      { hinduction q using eq.rec_symm, apply empty.elim, apply not_succ_le_self p }
    end,
    have lem2 : Π{n m k : ℕ} (p : n ≤ m) (q : succ k = m) (r : n ≤ k),
      Σs : n ≤ k, p = transport (le n) q (le.step s),
    begin
      intros, hinduction p with m p IH,
      { hinduction q, apply empty.elim, exact not_succ_le_self r },
      { have : Σr, ap succ r = q, exact ⟨succ.inj q, is_set.elim _ _⟩,
        hinduction this with r s, hinduction s, hinduction r,
        exact ⟨p, idp⟩ }
    end,
    apply is_prop.mk, intros H1 H2, hinduction H2 with m H2 IH,
    { exact lem H1 idp },
    { hinduction lem2 H1 idp H2 with x H3 p, refine p ⬝ ap le.step _,
      apply IH },
  end

  @[hott, instance] def is_prop_lt (n m : ℕ) : is_prop (n < m) := is_prop_le _ _

  @[hott] def le_equiv_succ_le_succ (n m : ℕ) : (n ≤ m) ≃ (succ n ≤ succ m) :=
  equiv_of_is_prop succ_le_succ le_of_succ_le_succ
  @[hott] theorem le_succ_equiv_pred_le (n m : ℕ) : (n ≤ succ m) ≃ (pred n ≤ m) :=
  equiv_of_is_prop pred_le_pred le_succ_of_pred_le

  @[hott] theorem lt_by_cases_lt {a b : ℕ} {P : Type _} (H1 : a < b → P) (H2 : a = b → P)
    (H3 : a > b → P) (H : a < b) : lt.by_cases H1 H2 H3 = H1 H :=
  begin
     dsimp [lt.by_cases], hinduction (lt.trichotomy a b) with p H' H',
     { exact ap H1 (is_prop.elim _ _)},
     { apply empty.elim, cases H' with H' H', apply lt.irrefl b, exact H' ▸ H,
       exact lt.asymm H H'}
  end

  @[hott] theorem lt_by_cases_eq {a b : ℕ} {P : Type _} (H1 : a < b → P) (H2 : a = b → P)
    (H3 : a > b → P) (H : a = b) : lt.by_cases H1 H2 H3 = H2 H :=
  begin
    dsimp [lt.by_cases], induction (lt.trichotomy a b) with H' H',
    { apply empty.elim, apply lt.irrefl b, exact H ▸ H'},
    { cases H' with H' H', exact ap H2 (is_prop.elim _ _), apply empty.elim , apply lt.irrefl b,
      exact H ▸ H'}
  end

  @[hott] theorem lt_by_cases_ge {a b : ℕ} {P : Type _} (H1 : a < b → P) (H2 : a = b → P)
    (H3 : a > b → P) (H : a > b) : lt.by_cases H1 H2 H3 = H3 H :=
  begin
    dsimp [lt.by_cases], induction (lt.trichotomy a b) with H' H',
    { apply empty.elim, exact lt.asymm H H'},
    { cases H' with H' H', apply empty.elim, apply lt.irrefl b, exact H' ▸ H,
      exact ap H3 (is_prop.elim _ _)}
  end

  @[hott] theorem lt_ge_by_cases_lt {n m : ℕ} {P : Type _} (H1 : n < m → P) (H2 : n ≥ m → P)
    (H : n < m) : lt_ge_by_cases H1 H2 = H1 H :=
  by apply lt_by_cases_lt

  @[hott] theorem lt_ge_by_cases_ge {n m : ℕ} {P : Type _} (H1 : n < m → P) (H2 : n ≥ m → P)
    (H : n ≥ m) : lt_ge_by_cases H1 H2 = H2 H :=
  begin
    dsimp [lt_ge_by_cases,lt.by_cases], induction (lt.trichotomy n m) with H' H',
    { apply empty.elim, apply lt.irrefl m, exact lt_of_le_of_lt H H'},
    { cases H' with H' H'; apply ap H2 (is_prop.elim _ _)}
  end

  @[hott] theorem lt_ge_by_cases_le {n m : ℕ} {P : Type _} {H1 : n ≤ m → P} {H2 : n ≥ m → P}
    (H : n ≤ m) (Heq : Π(p : n = m), H1 (le_of_eq p) = H2 (le_of_eq p⁻¹))
    : lt_ge_by_cases (λH', H1 (le_of_lt H')) H2 = H1 H :=
  begin
    dsimp [lt_ge_by_cases,lt.by_cases], induction (lt.trichotomy n m) with H' H',
    { apply ap H1 (is_prop.elim _ _)},
    { cases H' with H' H',
      { induction H', symmetry,
        exact ap H1 (is_prop.elim _ _) ⬝ Heq idp ⬝ ap H2 (is_prop.elim _ _)},
      { apply empty.elim, apply lt.irrefl n, apply lt_of_le_of_lt H H'}}
  end

  @[hott] def nat_eq_equiv (n m : ℕ) : (n = m) ≃ nat.code n m :=
  equiv.MK nat.encode
           (nat.decode n m)
           begin
             revert m, induction n; intro m; induction m; intro c,
               induction c, reflexivity,
               exact empty.elim c,
               exact empty.elim c,
               dsimp [nat.decode, nat.encode], rwr [←tr_compose], apply n_ih
           end
           begin
             intro p, induction p, induction n,
               reflexivity,
               exact ap02 succ n_ih
           end

  @[hott, instance] def pointed_nat : pointed ℕ :=
  pointed.mk 0

  open sigma sum
  @[hott] def eq_even_or_eq_odd (n : ℕ) : (Σk, 2 * k = n) ⊎ (Σk, 2 * k + 1 = n) :=
  begin
    induction n with n IH,
    { exact inl ⟨0, idp⟩},
    { induction IH with H H; induction H with k p; induction p,
      { exact inr ⟨k, idp⟩},
      { refine inl ⟨k+1, idp⟩}}
  end

  @[hott] def rec_on_even_odd {P : ℕ → Type _} (n : ℕ) (H : Πk, P (2 * k)) (H2 : Πk, P (2 * k + 1))
    : P n :=
  begin
    cases eq_even_or_eq_odd n with v v; induction v with k p; induction p,
    { exact H k},
    { exact H2 k}
  end

  /- this inequality comes up a couple of times when using the freudenthal suspension @[hott] theorem -/
  @[hott] theorem add_mul_le_mul_add (n m k : ℕ) : n + (succ m) * k ≤ (succ m) * (n + k) :=
  calc
    n + (succ m) * k ≤ (m * n + n) + (succ m) * k : add_le_add_right (le_add_left _ _) _
      ... = (succ m) * n + (succ m) * k : by rwr ←succ_mul
      ... = (succ m) * (n + k) : by rwr ←hott.algebra.left_distrib

  /-
    Some operations work only for successors. For example fin (succ n) has a 0 and a 1, but fin 0
    doesn't. However, we want a bit more, because sometimes we want a zero of (fin a)
    where a is either
    - equal to a successor, but not definitionally a successor (e.g. (0 : fin (3 + n)))
    - definitionally equal to a successor, but not in a way that type class inference can infer.
      (e.g. (0 : fin 4). Note that 4 is bit0 (bit0 one), but (bit0 x) (defined as x + x),
        is not always a successor)
    To solve this we use an auxillary class `is_succ` which can solve whether a number is a
    successor.
  -/

  @[hott, class] inductive is_succ : ℕ → Type
  | mk : Π(n : ℕ), is_succ (succ n)

  attribute [instance] is_succ.mk

  @[hott, instance] def is_succ_1 : is_succ 1 := is_succ.mk 0

  @[hott, instance] def is_succ_add_right (n m : ℕ) [H : is_succ m] : is_succ (n+m) :=
  by unfreezeI; induction H with m; constructor

  @[hott, instance, priority 900] def is_succ_add_left (n m : ℕ) [H : is_succ n] :
    is_succ (n+m) :=
  by unfreezeI; induction H with n; cases m with m; constructor

  @[hott] def is_succ_bit0 (n : ℕ) [H : is_succ n] : is_succ (bit0 n) :=
  by dsimp [bit0]; apply_instance

  -- level 2 is useful for abelian homotopy groups, which only exist at level 2 and higher
  @[hott, class] inductive is_at_least_two : ℕ → Type
  | mk : Π(n : ℕ), is_at_least_two (succ (succ n))

  attribute [instance] is_at_least_two.mk

  @[hott, instance] def is_at_least_two_succ (n : ℕ) [H : is_succ n] :
    is_at_least_two (succ n) :=
  by unfreezeI; induction H with n; constructor

  @[hott, instance] def is_at_least_two_add_right (n m : ℕ) [H : is_at_least_two m] :
    is_at_least_two (n+m) :=
  by unfreezeI; induction H with m; constructor

  @[hott, instance] def is_at_least_two_add_left (n m : ℕ) [H : is_at_least_two n] :
    is_at_least_two (n+m) :=
  by unfreezeI; induction H with n; cases m with m; try { cases m with m }; constructor

  @[hott, instance, priority 900] def is_at_least_two_add_both (n m : ℕ)
    [H : is_succ n] [K : is_succ m] : is_at_least_two (n+m) :=
  by unfreezeI; induction H with n; induction K with m; cases m with m; constructor

  @[hott] def is_at_least_two_bit0 (n : ℕ) [H : is_succ n] : is_at_least_two (bit0 n) :=
  by dsimp [bit0]; apply_instance

  @[hott] def is_at_least_two_bit1 (n : ℕ) [H : is_succ n] : is_at_least_two (bit1 n) :=
  by dsimp [bit1, bit0]; apply_instance

  /- some facts about iterate -/

  @[hott] def iterate_succ {A : Type _} (f : A → A) (n : ℕ) (x : A) :
    f^[succ n] x = f^[n] (f x) :=
  begin induction n with n p, refl, exact ap f p end

  @[hott] lemma iterate_sub {A : Type _} (f : A ≃ A) {n m : ℕ} (h : n ≥ m) (a : A) :
    iterate f (n - m) a = iterate f n (iterate f⁻¹ᶠ m a) :=
  begin
    induction m with m p generalizing n h,
    { refl },
    { cases n with n, apply empty.elim, apply not_succ_le_zero _ h,
      rwr [succ_sub_succ], refine p (le_of_succ_le_succ h) ⬝ _,
      refine ap (f^[n]) _ ⬝ (iterate_succ _ _ _)⁻¹, exact (to_right_inv _ _)⁻¹ }
  end

  @[hott] def iterate_commute {A : Type _} {f g : A → A} (n : ℕ) (h : f ∘ g ~ g ∘ f) :
    iterate f n ∘ g ~ g ∘ iterate f n :=
  begin induction n with n IH, refl, exact λx, ap f (IH x) ⬝ h _ end

  @[hott] def iterate_equiv {A : Type _} (f : A ≃ A) (n : ℕ) : A ≃ A :=
  equiv.mk (iterate f n)
    begin induction n with n IH, apply is_equiv_id, exactI is_equiv_compose f (iterate f n) end

  @[hott] def iterate_inv {A : Type _} (f : A ≃ A) (n : ℕ) :
    (iterate_equiv f n)⁻¹ᶠ ~ iterate f⁻¹ᶠ n :=
  begin
    induction n with n p; intro a,
      refl,
      exact p (f⁻¹ᶠ a) ⬝ (iterate_succ _ _ _)⁻¹
  end

  @[hott] def iterate_left_inv {A : Type _} (f : A ≃ A) (n : ℕ) (a : A) : f⁻¹ᵉ^[n] (f^[n] a) = a :=
  (iterate_inv f n (f^[n] a))⁻¹ ⬝ to_left_inv (iterate_equiv f n) a

  @[hott] def iterate_right_inv {A : Type _} (f : A ≃ A) (n : ℕ) (a : A) : f^[n] (f⁻¹ᵉ^[n] a) = a :=
  ap (f^[n]) (iterate_inv f n a)⁻¹ ⬝ to_right_inv (iterate_equiv f n) a

end nat
end hott


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.measure.lebesgue
import number_theory.liouville.residual
import number_theory.liouville.liouville_with
import analysis.p_series

/-!
# Volume of the set of Liouville numbers

In this file we prove that the set of Liouville numbers with exponent (irrationality measure)
strictly greater than two is a set of Lebesuge measure zero, see
`volume_Union_set_of_liouville_with`.

Since this set is a residual set, we show that the filters `residual` and `volume.ae` are disjoint.
These filters correspond to two common notions of genericity on `ℝ`: residual sets and sets of full
measure. The fact that the filters are disjoint means that two mutually exclusive properties can be
“generic” at the same time (in the sense of different “genericity” filters).

## Tags

Liouville number, Lebesgue measure, residual, generic property
-/

open_locale filter big_operators ennreal topological_space nnreal
open filter set metric measure_theory real

lemma set_of_liouville_with_subset_aux :
  {x : ℝ | ∃ p > 2, liouville_with p x} ⊆
    ⋃ m : ℤ, (λ x : ℝ, x + m) ⁻¹' (⋃ n > (0 : ℕ),
      {x : ℝ | ∃ᶠ b : ℕ in at_top, ∃ a ∈ finset.Icc (0 : ℤ) b,
        |x - (a : ℤ) / b| < 1 / b ^ (2 + 1 / n : ℝ)}) :=
begin
  rintro x ⟨p, hp, hxp⟩,
  rcases exists_nat_one_div_lt (sub_pos.2 hp) with ⟨n, hn⟩,
  rw lt_sub_iff_add_lt' at hn,
  suffices : ∀ y : ℝ, liouville_with p y → y ∈ Ico (0 : ℝ) 1 →
    ∃ᶠ b : ℕ in at_top, ∃ a ∈ finset.Icc (0 : ℤ) b, |y - a / b| < 1 / b ^ (2 + 1 / (n + 1 : ℕ) : ℝ),
  { simp only [mem_Union, mem_preimage],
    have hx : x + ↑(-⌊x⌋) ∈ Ico (0 : ℝ) 1,
    { simp only [int.floor_le, int.lt_floor_add_one, add_neg_lt_iff_le_add', zero_add, and_self,
        mem_Ico, int.cast_neg, le_add_neg_iff_add_le] },
    refine ⟨-⌊x⌋, n + 1, n.succ_pos, this _ (hxp.add_int _) hx⟩ },
  clear hxp x, intros x hxp hx01,
  refine ((hxp.frequently_lt_rpow_neg hn).and_eventually (eventually_ge_at_top 1)).mono _,
  rintro b ⟨⟨a, hne, hlt⟩, hb⟩,
  rw [rpow_neg b.cast_nonneg, ← one_div, ← nat.cast_succ] at hlt,
  refine ⟨a, _, hlt⟩,
  replace hb : (1 : ℝ) ≤ b, from nat.one_le_cast.2 hb,
  have hb0 : (0 : ℝ) < b := zero_lt_one.trans_le hb,
  replace hlt : |x - a / b| < 1 / b,
  { refine hlt.trans_le (one_div_le_one_div_of_le hb0 _),
    calc (b : ℝ) = b ^ (1 : ℝ) : (rpow_one _).symm
    ... ≤ b ^ (2 + 1 / (n + 1 : ℕ) : ℝ) : rpow_le_rpow_of_exponent_le hb (one_le_two.trans _),
    simpa using n.cast_add_one_pos.le },
  rw [sub_div' _ _ _ hb0.ne', abs_div, abs_of_pos hb0, div_lt_div_right hb0,
    abs_sub_lt_iff, sub_lt_iff_lt_add, sub_lt_iff_lt_add, ← sub_lt_iff_lt_add'] at hlt,
  rw [finset.mem_Icc, ← int.lt_add_one_iff, ← int.lt_add_one_iff, ← neg_lt_iff_pos_add, add_comm,
    ← @int.cast_lt ℝ, ← @int.cast_lt ℝ], push_cast,
  refine ⟨lt_of_le_of_lt _ hlt.1, hlt.2.trans_le _⟩,
  { simp only [mul_nonneg hx01.left b.cast_nonneg, neg_le_sub_iff_le_add, le_add_iff_nonneg_left] },
  { rw [add_le_add_iff_left],
    calc x * b ≤ 1 * b : mul_le_mul_of_nonneg_right hx01.2.le hb0.le
    ... = b : one_mul b }
end

/-- The set of numbers satisfying the Liouville condition with some exponent `p > 2` has Lebesgue
measure zero. -/
@[simp] lemma volume_Union_set_of_liouville_with :
  volume (⋃ (p : ℝ) (hp : 2 < p), {x : ℝ | liouville_with p x}) = 0 :=
begin
  simp only [← set_of_exists],
  refine measure_mono_null set_of_liouville_with_subset_aux _,
  rw measure_Union_null_iff, intro m, rw measure_preimage_add_right, clear m,
  refine (measure_bUnion_null_iff $ countable_encodable _).2 (λ n (hn : 1 ≤ n), _),
  generalize hr : (2 + 1 / n : ℝ) = r,
  replace hr : 2 < r, by simp [← hr, zero_lt_one.trans_le hn], clear hn n,
  refine measure_set_of_frequently_eq_zero _,
  simp only [set_of_exists, ← real.dist_eq, ← mem_ball, set_of_mem_eq],
  set B : ℤ → ℕ → set ℝ := λ a b, ball (a / b) (1 / b ^ r),
  have hB : ∀ a b, volume (B a b) = ↑(2 / b ^ r : ℝ≥0),
  { intros a b, simp only [B, real.volume_ball],
    rw [ennreal.of_real, mul_one_div, to_nnreal_div zero_le_two, to_nnreal_bit0 zero_le_one,
      to_nnreal_one, to_nnreal_rpow_of_nonneg (nat.cast_nonneg _), nnreal.to_nnreal_coe_nat] },
  have : ∀ b : ℕ, volume (⋃ a ∈ finset.Icc (0 : ℤ) b, B a b) ≤ (2 * (b ^ (1 - r) + b ^ (-r)) : ℝ≥0),
  { intro b,
    calc volume (⋃ a ∈ finset.Icc (0 : ℤ) b, B a b)
        ≤ ∑ a in finset.Icc (0 : ℤ) b, volume (B a b) : measure_bUnion_finset_le _ _
    ... = ((b + 1) * (2 / b ^ r) : ℝ≥0) :
      by simp only [hB, int.card_Icc, finset.sum_const, nsmul_eq_mul, sub_zero,
        ← int.coe_nat_succ, int.to_nat_coe_nat, ← nat.cast_succ, ennreal.coe_mul, ennreal.coe_nat]
    ... = _ : _,
    have : 1 - r ≠ 0, by linarith,
    rw [ennreal.coe_eq_coe],
    simp [add_mul, div_eq_mul_inv, nnreal.rpow_neg, nnreal.rpow_sub' _ this, mul_add,
      mul_left_comm] },
  refine ne_top_of_le_ne_top (ennreal.tsum_coe_ne_top_iff_summable.2 _)
    (ennreal.tsum_le_tsum this),
  refine (summable.add _ _).mul_left _; simp only [nnreal.summable_rpow]; linarith
end

lemma ae_not_liouville_with : ∀ᵐ x, ∀ p > (2 : ℝ), ¬liouville_with p x :=
by simpa only [ae_iff, not_forall, not_not, set_of_exists]
  using volume_Union_set_of_liouville_with

lemma ae_not_liouville : ∀ᵐ x, ¬liouville x :=
ae_not_liouville_with.mono $ λ x h₁ h₂, h₁ 3 (by norm_num) (h₂.liouville_with 3)

/-- The set of Liouville numbers has Lebesgue measure zero. -/
@[simp] lemma volume_set_of_liouville : volume {x : ℝ | liouville x} = 0 :=
by simpa only [ae_iff, not_not] using ae_not_liouville

/-- The filters `residual ℝ` and `volume.ae` are disjoint. This means that there exists a residual
set of Lebesgue measure zero (e.g., the set of Liouville numbers). -/
lemma real.disjoint_residual_ae : disjoint (residual ℝ) volume.ae :=
disjoint_of_disjoint_of_mem disjoint_compl_right eventually_residual_liouville ae_not_liouville


import tactic

/-
# Level 1 : Using exact
-/

namespace math3345 -- hide

/-
P and Q are propositions.
-/

variable P : Prop
variable Q : Prop

/- Lemma : no-side-bar

`h` is evidence that `P` and `k` is evidence for `Q`.

Replace `sorry` with `exact h` or `exact k` to complete the proof of `P`.

-/
lemma use_exact (h : P) (k : Q) : P :=
begin

  sorry,

end

end math3345 -- hide


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import measure_theory.function.lp_space
import analysis.normed_space.lattice_ordered_group

/-!
# Order related properties of Lp spaces

### Results

- `Lp E p μ` is an `ordered_add_comm_group` when `E` is a `normed_lattice_add_comm_group`.

### TODO

- move definitions of `Lp.pos_part` and `Lp.neg_part` to this file, and define them as
  `has_pos_part.pos` and `has_pos_part.neg` given by the lattice structure.
- show that if `E` is a `normed_lattice_add_comm_group` then so is `Lp E p μ` for `1 ≤ p`. In
  particular, this shows `order_closed_topology` for `Lp`.

-/

open topological_space measure_theory lattice_ordered_comm_group
open_locale ennreal

variables {α E : Type*} {m : measurable_space α} {μ : measure α} {p : ℝ≥0∞}

namespace measure_theory
namespace Lp

section order
variables [normed_lattice_add_comm_group E]

lemma coe_fn_le (f g : Lp E p μ) : f ≤ᵐ[μ] g ↔ f ≤ g :=
by rw [← subtype.coe_le_coe, ← ae_eq_fun.coe_fn_le, ← coe_fn_coe_base, ← coe_fn_coe_base]

lemma coe_fn_nonneg (f : Lp E p μ) : 0 ≤ᵐ[μ] f ↔ 0 ≤ f :=
begin
  rw ← coe_fn_le,
  have h0 := Lp.coe_fn_zero E p μ,
  split; intro h; filter_upwards [h, h0] with _ _ h2,
  { rwa h2, },
  { rwa ← h2, },
end

instance : covariant_class (Lp E p μ) (Lp E p μ) (+) (≤) :=
begin
  refine ⟨λ f g₁ g₂ hg₁₂, _⟩,
  rw ← coe_fn_le at hg₁₂ ⊢,
  filter_upwards [coe_fn_add f g₁, coe_fn_add f g₂, hg₁₂] with _ h1 h2 h3,
  rw [h1, h2, pi.add_apply, pi.add_apply],
  exact add_le_add le_rfl h3,
end

instance : ordered_add_comm_group (Lp E p μ) :=
{ add_le_add_left := λ f g hfg f', add_le_add_left hfg f',
  ..subtype.partial_order _, ..add_subgroup.to_add_comm_group _}

lemma _root_.measure_theory.mem_ℒp.sup {f g : α → E} (hf : mem_ℒp f p μ) (hg : mem_ℒp g p μ) :
  mem_ℒp (f ⊔ g) p μ :=
mem_ℒp.mono' (hf.norm.add hg.norm) (hf.1.sup hg.1)
  (filter.eventually_of_forall (λ x, norm_sup_le_add (f x) (g x)))

lemma _root_.measure_theory.mem_ℒp.inf {f g : α → E} (hf : mem_ℒp f p μ) (hg : mem_ℒp g p μ) :
  mem_ℒp (f ⊓ g) p μ :=
mem_ℒp.mono' (hf.norm.add hg.norm) (hf.1.inf hg.1)
  (filter.eventually_of_forall (λ x, norm_inf_le_add (f x) (g x)))

lemma _root_.measure_theory.mem_ℒp.abs {f : α → E} (hf : mem_ℒp f p μ)  :
  mem_ℒp (|f|) p μ :=
hf.sup hf.neg

end order

end Lp
end measure_theory


theorem succ_succ_inj {a b : mynat} (h : succ(succ(a)) = succ(succ(b))) :  a = b :=
begin
cases h,
refl,
end

-- theorem succ_succ_inj {a b : mynat} (h : succ(succ(a)) = succ(succ(b))) :  a = b :=
-- begin
-- exact succ_inj(succ_inj(h)),
-- end

-- theorem succ_succ_inj {a b : mynat} (h : succ(succ(a)) = succ(succ(b))) :  a = b :=
-- begin
-- apply succ_inj,
-- exact succ_inj(h),
-- end

-- theorem succ_succ_inj {a b : mynat} (h : succ(succ(a)) = succ(succ(b))) :  a = b :=
-- begin
-- apply succ_inj,
-- apply succ_inj,
-- exact h,
-- end


import ..dual

open set

-- open_locale classical
noncomputable theory
namespace matroid

variables {E : Type*} [finite E] {s t : ℕ} {I : set E} {M : matroid E}

/-- Truncate a matroid to rank `t`. Every rank above `t` drops to `t`. -/
def tr (M : matroid E) (t : ℕ) :=
  matroid_of_r (λ X, min t (M.r X))
  (λ X, (min_le_right _ _).trans (M.r_le_card _))
  (λ X Y hXY, le_min (min_le_left _ _) ((min_le_right _ _).trans (M.r_mono hXY)))
  (λ X Y,
  (begin
    wlog hXY : M.r X ≤ M.r Y generalizing X Y,
    { obtain (h | h) := le_or_lt (M.r X) (M.r Y),
      { exact this _ _ h},
      rw [add_comm (min t (M.r X)), inter_comm, union_comm],
      exact this _ _ h.le},
    cases le_or_lt t (M.r Y) with ht ht,
    { rw [min_eq_left ht, min_eq_left (ht.trans (M.r_le_r_union_right _ _))],
      linarith [min_le_min (rfl.le : t ≤ t) (M.r_inter_left_le_r X Y)]},
    rw [min_eq_right_of_lt ht, min_eq_right (hXY.trans ht.le)],
    linarith [min_le_right t (M.r (X ∩ Y)), min_le_right t (M.r (X ∪ Y)), M.r_submod X Y],
  end))

@[simp] lemma tr_r (t : ℕ) (X : set E) :
  (M.tr t).r X = min t (M.r X) :=
by simp only [tr, matroid_of_r_apply]

@[simp] lemma tr_indep_iff :
  (M.tr t).indep I ↔ M.indep I ∧ I.ncard ≤ t :=
begin
  simp_rw [indep_iff_r_eq_card, tr_r],
  obtain (hle | hlt) := le_or_lt t (M.r I),
  { rw [min_eq_left hle],
    exact ⟨by {rintro rfl, exact ⟨hle.antisymm' (M.r_le_card _), rfl.le⟩},
      λ h, (hle.trans_eq h.1).antisymm h.2⟩},
  rw [min_eq_right hlt.le],
  simp only [iff_self_and],
  exact λ h, h.symm.trans_le hlt.le,
end

end matroid

/- An attempted definition of truncation (by one) that doesn't rely on rank. I don't know to what
  extent truncation is defined for infinite matroids. TODO -/
-- def tr' (M : matroid E) :
--   matroid E :=
-- matroid_of_flat (λ F, M.flat F ∧ ¬ M.hyperplane F)
--   ⟨M.univ_flat, M.univ_not_hyperplane⟩
-- (begin
--   refine λ F₁ F₂ hF₁ hF₂, ⟨hF₁.1.inter hF₂.1, λ h, _⟩,
--   obtain (rfl | h₁) := eq_or_ne F₁ univ,
--   { rw [univ_inter] at h, exact hF₂.2 h},
--   refine h₁ (h.ssupset_eq_univ_of_flat hF₁.1 (ssubset_of_ne_of_subset (λ h_eq, _)
--     (inter_subset_left _ _))),
--   rw [h_eq] at h,
--   exact hF₁.2 h,
-- end)
-- (begin
--   rintro F₀ e ⟨hF₀,hhF₀⟩ heF₀,
--   have hne : F₀ ≠ univ,
--   { rw [ne.def, eq_univ_iff_forall, not_forall], exact ⟨_,heF₀⟩, },
--   obtain ⟨F₁,⟨heF₁,hcov⟩,hunique⟩ := hF₀.exists_unique_flat_of_not_mem heF₀,
--   -- obtain ⟨heF₁,hF₀F₁⟩ := insert_subset.mp heF₀F₁,
--   by_cases hhF₁ : M.hyperplane F₁,
--   { refine ⟨univ, ⟨⟨M.univ_flat,M.univ_not_hyperplane⟩,(subset_univ _),λ F hF hF₀F hFss, _⟩,_⟩,
--     { obtain ⟨H,hH,hFH⟩ := hF.1.subset_hyperplane_of_ne_univ hFss.ne,
--       obtain (rfl | hne) := eq_or_ne H F₁,
--       { exact (hcov.eq_or_eq hF.1 hF₀F hFH).elim eq.symm (by {rintro rfl, exact (hF.2 hhF₁).elim})},
--       have hF₁ := hcov.flat_right,
--       obtain (hinter | h_eq) := hcov.eq_or_eq (hH.flat.inter hF₁)
--         (subset_inter (hF₀F.trans hFH) hcov.subset) (inter_subset_right _ _),
--       { subst hinter,
--         rw [←hH.inter_covby_comm hhF₁] at hcov,
--         rw hcov.eq_of_subset_of_ssubset hF.1 hF₀F (hFH.ssubset_of_ne _),
--         rintro rfl,
--         exact hF.2 hH},
--       rw inter_eq_right_iff_subset at h_eq,
--       have := hhF₁.eq_of_subset hH h_eq, subst this,
--       exact (hne rfl).elim},
--     rintro F₂ ⟨hF₂, hF₂h, hmax⟩,
--     by_contra' hF₂univ,
--     obtain ⟨H,hH,hFH⟩ := hF₂.1.subset_hyperplane_of_ne_univ hF₂univ,

--     sorry,
--   },

-- end)

/-def indep (M : indep_family E) (n : ℤ) : set E → Prop :=
  λ X, M.indep X ∧ size X ≤ max 0 n

lemma I1 (M : indep_family E) (n : ℤ) :
  satisfies_I1 (trunc.indep M n) :=
⟨M.I1, by {rw size_empty, apply le_max_left, }⟩

lemma I2 (M : indep_family E) (n : ℤ) :
  satisfies_I2 (trunc.indep M n) :=
λ I J hIJ hJ, ⟨M.I2 I J hIJ hJ.1, le_trans (size_monotone hIJ) hJ.2⟩

lemma I3 (M : indep_family E) (n : ℤ) :
  satisfies_I3 (trunc.indep M n) :=
begin
  intros I J hIJ hI hJ,
  cases (M.I3 _ _ hIJ hI.1 hJ.1) with e he,
  refine ⟨e, ⟨he.1, ⟨he.2,_ ⟩ ⟩⟩,
  by_contra h_con, push_neg at h_con,
  rw [(size_union_nonmem_singleton (mem_diff_iff.mp he.1).2)] at h_con,
  linarith [int.le_of_lt_add_one h_con, hIJ, hJ.2],
end-/

/-def tr (M : matroid E) (n : ℤ) : matroid E :=
  let M_ind := M.to_indep_family in
  matroid.of_indep_family ⟨indep M_ind n, I1 M_ind n, I2 M_ind n, I3 M_ind n⟩-/
/-def tr'' (M : matroid E) (n : ℕ) [decidable_eq E] (h : n ≤ M.rk) : matroid E :=
{ base := λ X, M.indep X ∧ nat.card X = n,
  exists_base' :=
    begin
      cases M.exists_base' with B h2,
      rw base_iff_indep_r at h2,
      cases h2 with h1 h2,
      rw indep_iff_r_eq_card at h1,
      rw h2 at h1,

      sorry,
    end,
  base_exchange' := _ }-/
-- do we need the assumption that n ≤ M.r? i think so

-- -- tried my hand at defining truncation w.r.t rank
-- def matroid.tr_r (M : matroid E) (n : ℕ) : set E → ℕ := λ X, min (M.r X) n

-- lemma tr_r_le_card (M : matroid E) (n : ℕ) : ∀ X, (M.tr_r n X) ≤ nat.card X := λ X,
-- begin
--   rw matroid.tr_r,
--   simp,
--   left,
--   apply M.r_le_card,
-- end

-- lemma tr_r_mono (M : matroid E) (n : ℕ) : ∀ X Y, X ⊆ Y → M.tr_r n X ≤ M.tr_r n Y :=
-- begin
--   intros X Y hXY,
--   rw matroid.tr_r,
--   simp,
--   by_cases hX : M.r X < n,
--   { by_cases hY : M.r Y < n,
--     { left,
--       refine ⟨M.r_mono hXY, le_of_lt hX⟩ },
--     { right,
--       push_neg at hY,
--       exact hY } },
--   { by_cases hY : M.r Y < n,
--     { by_contra,
--       apply hX (lt_of_le_of_lt (M.r_mono hXY) hY) },
--     { right,
--       push_neg at hY,
--       exact hY } },
-- end

-- theorem set.inter_subset_union (s t : set E) : s ∩ t ⊆ s ∪ t := λ x h, (mem_union_left t) (mem_of_mem_inter_left h)

-- lemma tr_r_submod (M : matroid E) (n : ℕ) :
--   ∀ X Y, M.tr_r n (X ∩ Y) + M.tr_r n (X ∪ Y) ≤ M.tr_r n X + M.tr_r n Y :=
-- begin
--   intros X Y,
--   rw matroid.tr_r,
--   simp,
--   simp_rw ← min_add_add_right,
--   simp,
--   simp_rw ← min_add_add_left,
--   simp,
--   by_cases hInter : (M.r (X ∩ Y) < n),
--   { left,
--     by_cases hUnion : (M.r (X ∪ Y) < n),
--     { by_cases hX : (M.r (X) < n),
--       { by_cases hY : (M.r (Y) < n),
--         { split,
--           { left,
--             refine ⟨M.r_inter_add_r_union_le_r_add_r X Y,
--             le_trans (M.r_inter_add_r_union_le_r_add_r X Y)
--             (le_of_lt ((add_lt_add_iff_left (M.r X)).2 hY))⟩ },
--           { left,
--             refine ⟨le_trans (M.r_inter_add_r_union_le_r_add_r X Y)
--             (le_of_lt ((add_lt_add_iff_right (M.r Y)).2 hX)), _⟩,
--             apply le_of_lt,
--             linarith } },
--         { by_contra,
--           apply hY (lt_of_le_of_lt (M.r_mono (subset_union_right X Y)) hUnion) } },
--       { by_contra,
--         apply hX (lt_of_le_of_lt (M.r_mono (subset_union_left X Y)) hUnion) } },
--     by_cases hX : (M.r (X) < n),
--     { push_neg at hUnion,
--       by_cases hY : (M.r (Y) < n),
--       { split,
--         { right,
--           refine ⟨le_trans (add_le_add le_rfl hUnion) (M.r_inter_add_r_union_le_r_add_r X Y), M.r_mono (inter_subset_left X Y)⟩ },
--         { right,
--           split,
--           rw add_comm,
--           apply add_le_add (le_refl n) (M.r_mono (inter_subset_right X Y)),
--           apply le_of_lt hInter } },
--       { push_neg at hY,
--         have h2 := add_le_add (M.r_mono (inter_subset_left X Y)) (le_refl n),
--         split,
--         { right,
--           split,
--           linarith,
--           apply M.r_mono (inter_subset_left X Y) },
--         { right,
--           split,
--           linarith,
--           linarith } } },
--     { push_neg at hUnion,
--       push_neg at hX,
--       have h2 := M.r_inter_add_r_union_le_r_add_r X Y,
--       split,
--       right,
--       split,
--       linarith,
--       linarith,
--       right,
--       split,
--       rw add_comm,
--       simp,
--       apply M.r_mono (inter_subset_right X Y),
--       linarith } },
--   { by_cases hUnion : (M.r (X ∪ Y) < n),
--     { by_contra,
--       apply hInter (lt_of_le_of_lt (M.r_mono (set.inter_subset_union X Y)) hUnion) },
--     { by_cases hX : (M.r (X) < n),
--       { by_contra,
--         apply hInter (lt_of_le_of_lt (M.r_mono (inter_subset_left X Y)) hX) },
--       { by_cases hY : (M.r (Y) < n),
--         { by_contra,
--           apply hInter (lt_of_le_of_lt (M.r_mono (inter_subset_right X Y)) hY) },
--        {  push_neg at hInter,
--           push_neg at hUnion,
--           push_neg at hX,
--           push_neg at hY,
--           right,
--           split,
--           right,
--           split,
--           linarith,
--           linarith,
--           right,
--           exact hY } } } },
-- end

-- def tr (M : matroid E) (n : ℕ) : matroid E :=
--   matroid_of_r (M.tr_r n) (tr_r_le_card M n) (tr_r_mono M n) (tr_r_submod M n)

/-lemma weak_image (M : matroid E){n : ℕ} (hn : 0 ≤ n) :
  (tr M n) ≤ M :=
λ X, by {rw r_eq, simp, tauto, tauto }-/

-- in retrospect it would probably have been easier to define truncation in terms of rank. This is at least possible though.
-- lemma r_eq (M : matroid E){n : ℕ} (hn : 0 ≤ n) (X : set E) :
--   (tr M n).r X = min n (M.r X) :=
-- begin
--   rw tr,
--   simp,
--   rw matroid.tr_r,
--   simp,
--   rw min_comm,
-- end