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

import field_theory.galois

import algebraic_geometry.EllipticCurve

/-!
# Rational points on an elliptic curve over a field
-/

noncomputable theory
open_locale classical

universe u

variables {F : Type u} [field F]
variables {E : EllipticCurve F}
variables {K : Type u} [field K] [algebra F K]
variables {L : Type u} [field L] [algebra F L] [algebra K L] [is_scalar_tower F K L]

notation K↑L := algebra_map K L
notation K`⟶[`F]L := (algebra.of_id K L).restrict_scalars F

----------------------------------------------------------------------------------------------------

namespace EllipticCurve

/-- The group of `K`-rational points `E(K)` on an elliptic curve `E` over `F`, consisting of
    the point at infinity and the affine points satisfying a Weierstrass equation `w`. -/
inductive point (E : EllipticCurve F) (K : Type u) [field K] [algebra F K]
| zero : point
| some (x y : K) (w : y ^ 2 + (F↑K)E.a₁ * x * y + (F↑K)E.a₃ * y
                    = x ^ 3 + (F↑K)E.a₂ * x ^ 2 + (F↑K)E.a₄ * x + (F↑K)E.a₆) : point

notation E⟮K⟯ := point E K

open point

----------------------------------------------------------------------------------------------------
/-! ## Zero in `E(K)` -/

section zero

/-- `E(K)` has zero. -/
instance : has_zero E⟮K⟯ := ⟨zero⟩

@[simp] protected lemma zero_def : zero = (0 : E⟮K⟯) := rfl

/-- `E(K)` is inhabited. -/
instance : inhabited E⟮K⟯ := ⟨0⟩

end zero

----------------------------------------------------------------------------------------------------
/-! ## Negation in `E(K)` -/

section negation

variables {x y : K}
variables (w : y ^ 2 + (F↑K)E.a₁ * x * y + (F↑K)E.a₃ * y
             = x ^ 3 + (F↑K)E.a₂ * x ^ 2 + (F↑K)E.a₄ * x + (F↑K)E.a₆)

include w

private lemma neg_weierstrass :
  (-y - (F↑K)E.a₁ * x - (F↑K)E.a₃) ^ 2 + (F↑K)E.a₁ * x * (-y - (F↑K)E.a₁ * x - (F↑K)E.a₃)
    + (F↑K)E.a₃ * (-y - (F↑K)E.a₁ * x - (F↑K)E.a₃)
    = x ^ 3 + (F↑K)E.a₂ * x ^ 2 + (F↑K)E.a₄ * x + (F↑K)E.a₆ :=
by { rw [← w], ring1 }

omit w

/-- Negation in `E(K)`. -/
protected def neg : E⟮K⟯ → E⟮K⟯
| 0            := 0
| (some x y w) := some x (-y - (F↑K)E.a₁ * x - (F↑K)E.a₃) $ neg_weierstrass w

/-- `E(K)` has negation. -/
instance : has_neg E⟮K⟯ := ⟨EllipticCurve.neg⟩

@[simp] protected lemma neg_zero : -0 = (0 : E⟮K⟯) := rfl

@[simp] protected lemma neg_some :
  -some x y w = some x (-y - (F↑K)E.a₁ * x - (F↑K)E.a₃) (neg_weierstrass w) :=
rfl

end negation

----------------------------------------------------------------------------------------------------
/-! ## Doubling in `E(K)` -/

section doubling

variables {x y l x' y' : K}
variables (w : y ^ 2 + (F↑K)E.a₁ * x * y + (F↑K)E.a₃ * y
             = x ^ 3 + (F↑K)E.a₂ * x ^ 2 + (F↑K)E.a₄ * x + (F↑K)E.a₆)

include w

private lemma dbl_weierstrass
  (y_ne : 2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃ ≠ 0)
  (l_def : l  = (3 * x ^ 2 + 2 * (F↑K)E.a₂ * x + (F↑K)E.a₄ - (F↑K)E.a₁ * y)
                * (2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃)⁻¹)
  (x_def : x' = l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - 2 * x)
  (y_def : y' = -l * x' - (F↑K)E.a₁ * x' - y + l * x - (F↑K)E.a₃) :
  y' ^ 2 + (F↑K)E.a₁ * x' * y' + (F↑K)E.a₃ * y'
    = x' ^ 3 + (F↑K)E.a₂ * x' ^ 2 + (F↑K)E.a₄ * x' + (F↑K)E.a₆ :=
begin
  -- rewrite y
  have y_rw : ∀ a₁ a₃ x' l : K,
    (-l * x' - a₁ * x' - y + l * x - a₃) ^ 2
      + a₁ * x' * (-l * x' - a₁ * x' - y + l * x - a₃)
      + a₃ * (-l * x' - a₁ * x' - y + l * x - a₃)
      = x' ^ 2 * (l ^ 2 + a₁ * l)
      + x' * (-2 * x * l ^ 2 - a₁ * x * l + 2 * y * l + a₃ * l + a₁ * y)
      + (x ^ 2 * l ^ 2 - 2 * x * y * l - a₃ * x * l + y ^ 2 + a₃ * y) :=
  by { intros, ring1 },
  -- rewrite x
  have x_rw : ∀ a₁ a₂ a₃ a₄ a₆ l : K,
    (l ^ 2 + a₁ * l - a₂ - 2 * x) ^ 2 * (l ^ 2 + a₁ * l)
      + (l ^ 2 + a₁ * l - a₂ - 2 * x) * (-2 * x * l ^ 2 - a₁ * x * l + 2 * y * l + a₃ * l + a₁ * y)
      + (x ^ 2 * l ^ 2 - 2 * x * y * l - a₃ * x * l + y ^ 2 + a₃ * y)
      - ((l ^ 2 + a₁ * l - a₂ - 2 * x) ^ 3 + a₂ * (l ^ 2 + a₁ * l - a₂ - 2 * x) ^ 2
         + a₄ * (l ^ 2 + a₁ * l - a₂ - 2 * x) + a₆)
      = l * (l * (l * (2 * y + a₁ * x + a₃)
                  + (-3 * x ^ 2 + a₁ ^ 2 * x - 2 * a₂ * x + 3 * a₁ * y + a₁ * a₃ - a₄))
             + (-6 * a₁ * x ^ 2 - 6 * x * y - 3 * a₁ * a₂ * x - 3 * a₃ * x + a₁ ^ 2 * y - 2 * a₂ * y
                - a₁ * a₄ - a₂ * a₃))
        + (8 * x ^ 3 + 8 * a₂ * x ^ 2 - 2 * a₁ * x * y + y ^ 2 + 2 * a₂ ^ 2 * x + 2 * a₄ * x
           - a₁ * a₂ * y + a₃ * y + a₂ * a₄ - a₆) :=
  by { intros, ring1 },
  -- rewrite l step 1
  have l_rw_1 : ∀ {a₁ a₂ a₃ a₄ : K} (h_ne : 2 * y + a₁ * x + a₃ ≠ 0),
    (3 * x ^ 2 + 2 * a₂ * x + a₄ - a₁ * y) * (2 * y + a₁ * x + a₃)⁻¹ * (2 * y + a₁ * x + a₃)
      + (-3 * x ^ 2 + a₁ ^ 2 * x - 2 * a₂ * x + 3 * a₁ * y + a₁ * a₃ - a₄)
      = (2 * y + a₁ * x + a₃) * a₁ :=
  by { intros, rw [inv_mul_cancel_right₀ h_ne], ring1 },
  -- rewrite l step 2
  have l_rw_2 : ∀ {a₁ a₂ a₃ a₄ : K} (h_ne : 2 * y + a₁ * x + a₃ ≠ 0),
    (3 * x ^ 2 + 2 * a₂ * x + a₄ - a₁ * y) * (2 * y + a₁ * x + a₃)⁻¹ * ((2 * y + a₁ * x + a₃) * a₁)
      + (-6 * a₁ * x ^ 2 - 6 * x * y - 3 * a₁ * a₂ * x - 3 * a₃ * x + a₁ ^ 2 * y - 2 * a₂ * y
         - a₁ * a₄ - a₂ * a₃)
      = (2 * y + a₁ * x + a₃) * (-3 * x - a₂) :=
  by { intros, rw [← mul_assoc, inv_mul_cancel_right₀ h_ne], ring1 },
  -- rewrite l step 3
  have l_rw_3 : ∀ {a₁ a₂ a₃ a₄ a₆ : K} (h_ne : 2 * y + a₁ * x + a₃ ≠ 0)
    (h : y ^ 2 + a₁ * x * y + a₃ * y = x ^ 3 + a₂ * x ^ 2 + a₄ * x + a₆),
    (3 * x ^ 2 + 2 * a₂ * x + a₄ - a₁ * y) * (2 * y + a₁ * x + a₃)⁻¹
      * ((2 * y + a₁ * x + a₃) * (-3 * x - a₂))
      + (8 * x ^ 3 + 8 * a₂ * x ^ 2 - 2 * a₁ * x * y + y ^ 2 + 2 * a₂ ^ 2 * x + 2 * a₄ * x
         - a₁ * a₂ * y + a₃ * y + a₂ * a₄ - a₆)
      = 0 :=
  by { intros, rw [← mul_assoc, inv_mul_cancel_right₀ h_ne, ← sub_eq_zero.mpr h], ring1 },
  -- sequence steps
  rw [y_def, x_def, l_def, ← sub_eq_zero, y_rw, x_rw, l_rw_1, l_rw_2, l_rw_3],
  all_goals { assumption }
end

omit w

/-- Doubling in `E(K)`. -/
protected def dbl : E⟮K⟯ → E⟮K⟯
| 0            := 0
| (some x y w) :=
if y_ne : 2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃ ≠ 0 then
  let l  := (3 * x ^ 2 + 2 * (F↑K)E.a₂ * x + (F↑K)E.a₄ - (F↑K)E.a₁ * y)
            * (2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃)⁻¹,
      x' := l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - 2 * x,
      y' := -l * x' - (F↑K)E.a₁ * x' - y + l * x - (F↑K)E.a₃
  in  some x' y' $ dbl_weierstrass w y_ne rfl rfl rfl
else
  0

@[simp] protected lemma dbl_zero : EllipticCurve.dbl 0 = (0 : E⟮K⟯) := rfl

@[simp] protected lemma dbl_some_of_y_ne (y_ne : 2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃ ≠ 0) :
  EllipticCurve.dbl (some x y w)
    = let l  := (3 * x ^ 2 + 2 * (F↑K)E.a₂ * x + (F↑K)E.a₄ - (F↑K)E.a₁ * y)
                * (2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃)⁻¹,
          x' := l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - 2 * x,
          y' := -l * x' - (F↑K)E.a₁ * x' - y + l * x - (F↑K)E.a₃
      in  some x' y' $ dbl_weierstrass w y_ne rfl rfl rfl :=
by rw [EllipticCurve.dbl, dif_pos y_ne]

@[simp] protected lemma dbl_some_of_y_eq (y_eq : 2 * y + (F↑K)E.a₁ * x + (F↑K)E.a₃ = 0) :
  EllipticCurve.dbl (some x y w) = 0 :=
by rw [EllipticCurve.dbl, dif_neg $ not_not.mpr y_eq]

end doubling

----------------------------------------------------------------------------------------------------
/-! ## Addition in `E(K)` -/

section addition

variables {x₁ y₁ x₂ y₂ l x₃ y₃ : K}
variables (w₁ : y₁ ^ 2 + (F↑K)E.a₁ * x₁ * y₁ + (F↑K)E.a₃ * y₁
              = x₁ ^ 3 + (F↑K)E.a₂ * x₁ ^ 2 + (F↑K)E.a₄ * x₁ + (F↑K)E.a₆)
variables (w₂ : y₂ ^ 2 + (F↑K)E.a₁ * x₂ * y₂ + (F↑K)E.a₃ * y₂
              = x₂ ^ 3 + (F↑K)E.a₂ * x₂ ^ 2 + (F↑K)E.a₄ * x₂ + (F↑K)E.a₆)

include w₁ w₂

private lemma add_weierstrass
  (x_ne : x₁ ≠ x₂)
  (l_def : l  = (y₁ - y₂) * (x₁ - x₂)⁻¹)
  (x_def : x₃ = l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - x₁ - x₂)
  (y_def : y₃ = -l * x₃ - (F↑K)E.a₁ * x₃ - y₁ + l * x₁ - (F↑K)E.a₃) :
  y₃ ^ 2 + (F↑K)E.a₁ * x₃ * y₃ + (F↑K)E.a₃ * y₃
    = x₃ ^ 3 + (F↑K)E.a₂ * x₃ ^ 2 + (F↑K)E.a₄ * x₃ + (F↑K)E.a₆ :=
begin
  -- rewrite y
  have y_rw : ∀ a₁ a₃ x₃ l : K,
    (-l * x₃ - a₁ * x₃ - y₁ + l * x₁ - a₃) ^ 2
      + a₁ * x₃ * (-l * x₃ - a₁ * x₃ - y₁ + l * x₁ - a₃)
      + a₃ * (-l * x₃ - a₁ * x₃ - y₁ + l * x₁ - a₃)
      = x₃ ^ 2 * (l ^ 2 + a₁ * l)
      + x₃ * (-2 * x₁ * l ^ 2 - a₁ * x₁ * l + 2 * y₁ * l + a₃ * l + a₁ * y₁)
      + (x₁ ^ 2 * l ^ 2 - 2 * x₁ * y₁ * l - a₃ * x₁ * l + y₁ ^ 2 + a₃ * y₁) :=
  by { intros, ring1 },
  -- rewrite x
  have x_rw : ∀ a₁ a₂ a₃ a₄ a₆ l : K,
    (l ^ 2 + a₁ * l - a₂ - x₁ - x₂) ^ 2 * (l ^ 2 + a₁ * l)
      + (l ^ 2 + a₁ * l - a₂ - x₁ - x₂)
      * (-2 * x₁ * l ^ 2 - a₁ * x₁ * l + 2 * y₁ * l + a₃ * l + a₁ * y₁)
      + (x₁ ^ 2 * l ^ 2 - 2 * x₁ * y₁ * l - a₃ * x₁ * l + y₁ ^ 2 + a₃ * y₁)
      - ((l ^ 2 + a₁ * l - a₂ - x₁ - x₂) ^ 3 + a₂ * (l ^ 2 + a₁ * l - a₂ - x₁ - x₂) ^ 2
         + a₄ * (l ^ 2 + a₁ * l - a₂ - x₁ - x₂) + a₆)
      = l * (l * (l * (l * (x₁ - x₂) * -1
                       + (-a₁ * x₁ + 2 * a₁ * x₂ + 2 * y₁ + a₃))
                  + (x₁ ^ 2 - 2 * x₁ * x₂ - 2 * x₂ ^ 2 + a₁ ^ 2 * x₂ - 2 * a₂ * x₂ + 3 * a₁ * y₁
                     + a₁ * a₃ - a₄))
             + (-a₁ * x₁ ^ 2 - 3 * a₁ * x₁ * x₂ - 4 * x₁ * y₁ - 2 * a₁ * x₂ ^ 2 - 2 * x₂ * y₁
                - a₁ * a₂ * x₁ - 2 * a₃ * x₁ - 2 * a₁ * a₂ * x₂ - a₃ * x₂ + a₁ ^ 2 * y₁
                - 2 * a₂ * y₁ - a₁ * a₄ - a₂ * a₃))
        + (x₁ ^ 3 + 3 * x₁ ^ 2 * x₂ + 3 * x₁ * x₂ ^ 2 + x₂ ^ 3 + 2 * a₂ * x₁ ^ 2 + 4 * a₂ * x₁ * x₂
           - a₁ * x₁ * y₁ + 2 * a₂ * x₂ ^ 2 - a₁ * x₂ * y₁ + y₁ ^ 2 + a₂ ^ 2 * x₁ + a₄ * x₁
           + a₂ ^ 2 * x₂ + a₄ * x₂ - a₁ * a₂ * y₁ + a₃ * y₁ + a₂ * a₄ - a₆) :=
  by { intros, ring1 },
  -- rewrite l auxiliary tactic
  have l_rw : ∀ {a b c : K} (h : x₁ ≠ x₂),
    (y₁ - y₂) * (x₁ - x₂)⁻¹ * a + b = c ↔ (y₁ - y₂) * a + (x₁ - x₂) * b + 0 = (x₁ - x₂) * c + 0 :=
  by { intros, rw [← mul_right_inj' $ sub_ne_zero.mpr h, mul_add, ← mul_assoc, mul_comm (x₁ - x₂),
                   inv_mul_cancel_right₀ $ sub_ne_zero.mpr h, ← add_left_inj] },
  -- rewrite l step 1
  have l_rw_1 : ∀ {a₁ a₃ : K} (h : x₁ ≠ x₂),
    (y₁ - y₂) * (x₁ - x₂)⁻¹ * (x₁ - x₂) * -1 + (-a₁ * x₁ + 2 * a₁ * x₂ + 2 * y₁ + a₃)
      = -a₁ * x₁ + 2 * a₁ * x₂ + 2 * y₁ + a₃ - y₁ + y₂ :=
  by { intros, rw [inv_mul_cancel_right₀ $ sub_ne_zero.mpr h], ring1 },
  -- rewrite l step 2
  have l_rw_2 : ∀ {a₁ a₂ a₃ a₄ a₆ : K} (h_ne : x₁ ≠ x₂)
    (h₁ : y₁ ^ 2 + a₁ * x₁ * y₁ + a₃ * y₁ = x₁ ^ 3 + a₂ * x₁ ^ 2 + a₄ * x₁ + a₆)
    (h₂ : y₂ ^ 2 + a₁ * x₂ * y₂ + a₃ * y₂ = x₂ ^ 3 + a₂ * x₂ ^ 2 + a₄ * x₂ + a₆),
    (y₁ - y₂) * (x₁ - x₂)⁻¹ * (-a₁ * x₁ + 2 * a₁ * x₂ + 2 * y₁ + a₃ - y₁ + y₂)
      + (x₁ ^ 2 - 2 * x₁ * x₂ - 2 * x₂ ^ 2 + a₁ ^ 2 * x₂ - 2 * a₂ * x₂ + 3 * a₁ * y₁ + a₁ * a₃ - a₄)
      = 2 * x₁ ^ 2 - x₁ * x₂ - x₂ ^ 2 + a₂ * x₁ + a₁ ^ 2 * x₂ + a₂ * x₂ - 2 * a₂ * x₂ + a₁ * y₁
        + a₁ * y₂ + a₁ * a₃ :=
  by { intros, rw [l_rw h_ne], nth_rewrite_rhs 0 [← sub_eq_zero.mpr h₁],
       nth_rewrite_lhs 0 [← sub_eq_zero.mpr h₂], ring1 },
  -- rewrite l step 3
  have l_rw_3 : ∀ {a₁ a₂ a₃ a₄ a₆ : K} (h_ne : x₁ ≠ x₂)
    (h₁ : y₁ ^ 2 + a₁ * x₁ * y₁ + a₃ * y₁ = x₁ ^ 3 + a₂ * x₁ ^ 2 + a₄ * x₁ + a₆)
    (h₂ : y₂ ^ 2 + a₁ * x₂ * y₂ + a₃ * y₂ = x₂ ^ 3 + a₂ * x₂ ^ 2 + a₄ * x₂ + a₆),
    (y₁ - y₂) * (x₁ - x₂)⁻¹ * (2 * x₁ ^ 2 - x₁ * x₂ - x₂ ^ 2 + a₂ * x₁ + a₁ ^ 2 * x₂ + a₂ * x₂
                               - 2 * a₂ * x₂ + a₁ * y₁ + a₁ * y₂ + a₁ * a₃)
      + (-a₁ * x₁ ^ 2 - 3 * a₁ * x₁ * x₂ - 4 * x₁ * y₁ - 2 * a₁ * x₂ ^ 2 - 2 * x₂ * y₁
         - a₁ * a₂ * x₁ - 2 * a₃ * x₁ - 2 * a₁ * a₂ * x₂ - a₃ * x₂ + a₁ ^ 2 * y₁ - 2 * a₂ * y₁
         - a₁ * a₄ - a₂ * a₃)
      = -2 * a₁ * x₁ * x₂ - 2 * x₁ * y₁ - 2 * x₁ * y₂ - a₁ * x₂ ^ 2 - x₂ * y₁ - x₂ * y₂
        - 2 * a₃ * x₁ - a₁ * a₂ * x₂ - a₃ * x₂ - a₂ * y₁ - a₂ * y₂ - a₂ * a₃ :=
  by { intros, rw [l_rw h_ne], apply_fun ((*) a₁) at h₁ h₂,
       nth_rewrite_rhs 0 [← sub_eq_zero.mpr h₁], nth_rewrite_lhs 0 [← sub_eq_zero.mpr h₂], ring1 },
  -- rewrite l step 4
  have l_rw_4 : ∀ {a₁ a₂ a₃ a₄ a₆ : K} (h_ne : x₁ ≠ x₂)
    (h₁ : y₁ ^ 2 + a₁ * x₁ * y₁ + a₃ * y₁ = x₁ ^ 3 + a₂ * x₁ ^ 2 + a₄ * x₁ + a₆)
    (h₂ : y₂ ^ 2 + a₁ * x₂ * y₂ + a₃ * y₂ = x₂ ^ 3 + a₂ * x₂ ^ 2 + a₄ * x₂ + a₆),
    (y₁ - y₂) * (x₁ - x₂)⁻¹ * (-2 * a₁ * x₁ * x₂ - 2 * x₁ * y₁ - 2 * x₁ * y₂ - a₁ * x₂ ^ 2 - x₂ * y₁
                               - x₂ * y₂ - 2 * a₃ * x₁ - a₁ * a₂ * x₂ - a₃ * x₂ - a₂ * y₁ - a₂ * y₂
                               - a₂ * a₃)
      + (x₁ ^ 3 + 3 * x₁ ^ 2 * x₂ + 3 * x₁ * x₂ ^ 2 + x₂ ^ 3 + 2 * a₂ * x₁ ^ 2 + 4 * a₂ * x₁ * x₂
         - a₁ * x₁ * y₁ + 2 * a₂ * x₂ ^ 2 - a₁ * x₂ * y₁ + y₁ ^ 2 + a₂ ^ 2 * x₁ + a₄ * x₁
         + a₂ ^ 2 * x₂ + a₄ * x₂ - a₁ * a₂ * y₁ + a₃ * y₁ + a₂ * a₄ - a₆)
      = 0 :=
  by { intros, rw [l_rw h_ne], apply_fun ((*) (x₁ + 2 * x₂ + a₂)) at h₁,
       apply_fun ((*) (2 * x₁ + x₂ + a₂)) at h₂, nth_rewrite_lhs 0 [← sub_eq_zero.mpr h₁],
       nth_rewrite_rhs 1 [← sub_eq_zero.mpr h₂], ring1 },
  -- rewrite Weierstrass equation as w₃(x₃, y₃) = 0 and sequence steps
  rw [y_def, x_def, l_def, ← sub_eq_zero, y_rw, x_rw, l_rw_1, l_rw_2, l_rw_3, l_rw_4],
  all_goals { assumption }
end

private lemma y_ne_of_y_ne (x_eq : x₁ = x₂) (y_ne : y₁ + y₂ + (F↑K)E.a₁ * x₂ + (F↑K)E.a₃ ≠ 0) :
  2 * y₁ + (F↑K)E.a₁ * x₁ + (F↑K)E.a₃ ≠ 0 :=
begin
  have y_rw : ∀ a₁ a₃ : K,
    y₁ ^ 2 + a₁ * x₁ * y₁ + a₃ * y₁ - (y₂ ^ 2 + a₁ * x₁ * y₂ + a₃ * y₂)
      = (y₁ - y₂) * (y₁ + y₂ + a₁ * x₁ + a₃) :=
  by { intros, ring1 },
  subst x_eq,
  rw [← w₂, ← sub_eq_zero, y_rw, mul_eq_zero, sub_eq_zero] at w₁,
  cases w₁,
  { subst w₁,
    simpa only [two_mul] },
  { contradiction }
end

omit w₁ w₂

/-- Addition in `E(K)`. -/
protected def add : E⟮K⟯ → E⟮K⟯ → E⟮K⟯
| 0               P               := P
| P               0               := P
| (some x₁ y₁ w₁) (some x₂ y₂ w₂) :=
if x_ne : x₁ ≠ x₂ then
  let l  := (y₁ - y₂) * (x₁ - x₂)⁻¹,
      x₃ := l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - x₁ - x₂,
      y₃ := -l * x₃ - (F↑K)E.a₁ * x₃ - y₁ + l * x₁ - (F↑K)E.a₃
  in  some x₃ y₃ $ add_weierstrass w₁ w₂ x_ne rfl rfl rfl
else
  if y_ne : y₁ + y₂ + (F↑K)E.a₁ * x₂ + (F↑K)E.a₃ ≠ 0 then EllipticCurve.dbl $ some x₁ y₁ w₁ else 0

/-- `E(K)` has addition. -/
instance : has_add E⟮K⟯ := ⟨EllipticCurve.add⟩

@[simp] protected lemma zero_add (P : E⟮K⟯) : 0 + P = P := by cases P; refl

@[simp] protected lemma add_zero (P : E⟮K⟯) : P + 0 = P := by cases P; refl

@[simp] protected lemma some_add_some_of_x_ne (x_ne : x₁ ≠ x₂) :
  some x₁ y₁ w₁ + some x₂ y₂ w₂
    = let l  := (y₁ - y₂) * (x₁ - x₂)⁻¹,
          x₃ := l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - x₁ - x₂,
          y₃ := -l * x₃ - (F↑K)E.a₁ * x₃ - y₁ + l * x₁ - (F↑K)E.a₃
      in  some x₃ y₃ $ add_weierstrass w₁ w₂ x_ne rfl rfl rfl :=
by { unfold has_add.add, rw [EllipticCurve.add, dif_pos x_ne] }

@[simp] protected lemma some_add_some_of_y_ne (x_eq : x₁ = x₂)
  (y_ne : y₁ + y₂ + (F↑K)E.a₁ * x₂ + (F↑K)E.a₃ ≠ 0) :
  some x₁ y₁ w₁ + some x₂ y₂ w₂
    = let l  := (3 * x₁ ^ 2 + 2 * (F↑K)E.a₂ * x₁ + (F↑K)E.a₄ - (F↑K)E.a₁ * y₁)
                * (2 * y₁ + (F↑K)E.a₁ * x₁ + (F↑K)E.a₃)⁻¹,
          x' := l ^ 2 + (F↑K)E.a₁ * l - (F↑K)E.a₂ - 2 * x₁,
          y' := -l * x' - (F↑K)E.a₁ * x' - y₁ + l * x₁ - (F↑K)E.a₃
      in  some x' y' $ dbl_weierstrass w₁ (y_ne_of_y_ne w₁ w₂ x_eq y_ne) rfl rfl rfl :=
begin
  unfold has_add.add,
  rw [EllipticCurve.add, dif_neg $ not_not.mpr x_eq, if_pos y_ne, EllipticCurve.dbl,
      dif_pos $ y_ne_of_y_ne w₁ w₂ x_eq y_ne]
end

@[simp] protected lemma some_add_some_of_y_eq (x_eq : x₁ = x₂)
  (y_eq : y₁ + y₂ + (F↑K)E.a₁ * x₂ + (F↑K)E.a₃ = 0) : some x₁ y₁ w₁ + some x₂ y₂ w₂ = 0 :=
by { unfold has_add.add, rw [EllipticCurve.add, dif_neg $ not_not.mpr x_eq,
                             if_neg $ not_not.mpr y_eq] }

end addition

----------------------------------------------------------------------------------------------------
/-! ## Axioms in `E(K)` -/

section add_comm_group

@[simp] protected lemma add_left_neg (P : E⟮K⟯) : -P + P = 0 :=
begin
  cases P,
  { refl },
  { rw [EllipticCurve.neg_some, EllipticCurve.some_add_some_of_y_eq]; ring1 }
end

protected lemma add_comm (P Q : E⟮K⟯) : P + Q = Q + P :=
begin
  rcases ⟨P, Q⟩ with ⟨_ | _, _ | _⟩,
  any_goals { refl },

  by_cases P_x_ne_Q_x: P_x ≠ Q_x,

  have h0: (P_y - Q_y) * (P_x - Q_x)⁻¹ = (Q_y - P_y) * (Q_x - P_x)⁻¹,

  {calc (P_y - Q_y) * (P_x - Q_x)⁻¹ = -(-(P_y - Q_y)) * (-(-(P_x - Q_x)⁻¹)) : by {ring,}
    ...                             = -(-(P_y - Q_y)) * -(-(P_x - Q_x))⁻¹ : by {rw inv_neg,}
    ...                             = -(Q_y - P_y) * (-(Q_x - P_x)⁻¹) : by {rw [neg_sub, neg_sub P_x Q_x],}
    ...                             = (Q_y - P_y) * (Q_x - P_x)⁻¹: by {ring,}
  },

  have h1 : (2 * P_x + Q_x) * (Q_x - P_x)⁻¹ = (P_x + 2 * Q_x) * (Q_x - P_x)⁻¹ - 1,

  {calc   (2 * P_x + Q_x) * (Q_x - P_x)⁻¹ = (2 * P_x + Q_x) * (Q_x - P_x)⁻¹ + 1 - 1 : by {ring,}
          ...                             = (2 * P_x + Q_x) * (Q_x - P_x)⁻¹ + (Q_x - P_x)*(Q_x - P_x)⁻¹ - 1 : by {congr' 2, field_simp, rw div_self, intro h, rw sub_eq_zero at h,exact P_x_ne_Q_x h.symm,}
          ...                             = (P_x + 2 * Q_x) * (Q_x - P_x)⁻¹ - 1: by {field_simp,ring,}
  },

  have h2 : (-(2 * P_x) - Q_x) * (Q_x - P_x)⁻¹ - 1  = (-P_x - 2 * Q_x) * (Q_x - P_x)⁻¹,
  {calc   (-(2 * P_x) - Q_x) * (Q_x - P_x)⁻¹ - 1 = (-(2 * P_x) - Q_x) * (Q_x - P_x)⁻¹ - (Q_x - P_x)*(Q_x - P_x)⁻¹: by {field_simp, rw div_self,intro h, rw sub_eq_zero at h,exact P_x_ne_Q_x h.symm,}
    ...                                          = (-P_x - 2 * Q_x) * (Q_x - P_x)⁻¹ : by {field_simp,ring,}
  },

    { simp [P_x_ne_Q_x, P_x_ne_Q_x.symm],
      split,
      any_goals{rw h0, ring},
      congr' 4,
      any_goals{rw [right_distrib, right_distrib, h1], ring},
      any_goals{rw [right_distrib, right_distrib, <- add_assoc,<- add_sub, h2], ring},
    },
    { rw not_not at P_x_ne_Q_x,
     have y_eq_comm :  Q_y + P_y + (F↑K)E.a₁ * Q_x + (F↑K)E.a₃ = P_y + Q_y + (F↑K)E.a₁ * Q_x + (F↑K)E.a₃,
      {by ring},
      by_cases y_eq : P_y + Q_y + (F↑K)E.a₁ * Q_x + (F↑K)E.a₃ = 0,
      {
        have y_eq': Q_y + P_y + (F↑K)E.a₁ * Q_x + (F↑K)E.a₃ = 0, {begin rw y_eq_comm, exact y_eq end},
        simp [y_eq, P_x_ne_Q_x, y_eq'],
      },
      { have y_eq' : Q_y + P_y + (F↑K)E.a₁ * P_x + (F↑K)E.a₃ ≠ 0, {begin rw [P_x_ne_Q_x, y_eq_comm], exact y_eq end},
        unfold has_add.add,
        rw [EllipticCurve.add, dif_neg $ not_not.mpr P_x_ne_Q_x, if_pos y_eq], rw [EllipticCurve.add, dif_neg $ not_not.mpr P_x_ne_Q_x.symm, if_pos y_eq'],
        congr' 2,
        rw P_x_ne_Q_x at P_w,
        rw <- P_w at Q_w,
        have : (P_y - Q_y)*(P_y + Q_y + (F↑K) E.a₁ * Q_x + (F↑K) E.a₃)  = 0,
        { calc   (P_y - Q_y)*(P_y + Q_y + (F↑K) E.a₁ * Q_x + (F↑K) E.a₃) = (P_y ^ 2 + (F↑K) E.a₁ * Q_x * P_y + (F↑K) E.a₃ * P_y) - (Q_y ^ 2 + (F↑K) E.a₁ * Q_x * Q_y + (F↑K) E.a₃ * Q_y) : by {ring,}
          ...   = 0 : by {rw Q_w,ring}},
        cases mul_eq_zero.mp this,
        rw <- sub_eq_zero,
        exact h,
        exfalso,
        exact y_eq h,
      }
    },

end

protected lemma add_assoc (P Q R : E⟮K⟯) : (P + Q) + R = P + (Q + R) :=
begin
  rcases ⟨P, Q, R⟩ with ⟨_ | _, _ | _, _ | _⟩,
  any_goals { refl },
  { rw [EllipticCurve.zero_def, EllipticCurve.zero_add, EllipticCurve.zero_add] },
  { rw [EllipticCurve.zero_def, EllipticCurve.add_zero, EllipticCurve.add_zero] },
  sorry
end

/-- `E(K)` is an additive commutative group. -/
instance : add_comm_group E⟮K⟯ :=
{ zero         := 0,
  neg          := EllipticCurve.neg,
  add          := EllipticCurve.add,
  zero_add     := EllipticCurve.zero_add,
  add_zero     := EllipticCurve.add_zero,
  add_left_neg := EllipticCurve.add_left_neg,
  add_comm     := EllipticCurve.add_comm,
  add_assoc    := EllipticCurve.add_assoc }

end add_comm_group

----------------------------------------------------------------------------------------------------
/-! ## Functoriality of `K ↦ E(K)` -/

section functoriality

variables (φ : K →ₐ[F] L)

/-- Set function `E(K) → E(L)`. -/
def point_hom.to_fun : E⟮K⟯ → E⟮L⟯
| 0            := 0
| (some x y w) := some (φ x) (φ y) $
by { apply_fun φ at w, simp only [map_add, map_mul, map_pow, alg_hom.commutes] at w, exact w }

set_option trace.simplify.rewrite true

/-- Group homomorphism `E(K) → E(L)`. -/
def point_hom : E⟮K⟯ →+ E⟮L⟯ :=
{ to_fun    := point_hom.to_fun φ,
  map_zero' := rfl,
  map_add'  :=
  begin
    rintro (_ | _) (_ | _),
    any_goals { refl },
      by_cases h_x: x_x ≠ y_x,
      { change point_hom.to_fun φ (EllipticCurve.add (some x_x x_y x_w) (some y_x y_y y_w))
      = EllipticCurve.add (point_hom.to_fun φ (some x_x x_y x_w)) (point_hom.to_fun φ (some y_x y_y y_w)),
        have hφ_x: φ(x_x) ≠ φ(y_x),
        {begin intro h,
        exact h_x (φ.to_ring_hom.injective h), end},
        rw [EllipticCurve.add, dif_pos $ h_x],
        unfold point_hom.to_fun,
        rw [EllipticCurve.add , dif_pos $ hφ_x],
        simp only,
        split,
        simp,
        simp only [map_add,map_pow,map_mul,map_sub,alg_hom.map_inv,alg_hom.commutes, map_neg],
      },
      { have hφ_x: φ(x_x) = φ(y_x),
        {begin congr,
        exact not_not.mp h_x, end},
        have: φ(x_y) + φ(y_y) + (F↑L)E.a₁ * φ(y_x) + (F↑L)E.a₃  = φ(x_y + y_y + (F↑K)E.a₁ * y_x + (F↑K)E.a₃),
        {simp only [map_add, map_mul, alg_hom.commutes],},

        by_cases h_y: x_y + y_y + (F↑K)E.a₁ * y_x + (F↑K)E.a₃ = 0,
        { have  hφ_y: φ(x_y) + φ(y_y) + (F↑L)E.a₁ * φ(y_x) + (F↑L)E.a₃ = 0,
          {by rw [this,h_y,map_zero],},
          unfold point_hom.to_fun,
          simp [not_not.mp h_x, hφ_x, h_y,hφ_y],
          unfold point_hom.to_fun,
        },
        {
          have hφ_y: φ(x_y) + φ(y_y) + (F↑L)E.a₁ * φ(y_x) + (F↑L)E.a₃ ≠ 0,
          {begin rw [this],intro h, rw <- map_zero φ at h, exact h_y (φ.to_ring_hom.injective h), end},
          unfold point_hom.to_fun,
          change point_hom.to_fun φ (EllipticCurve.add (some x_x x_y x_w)(some y_x y_y y_w)) = EllipticCurve.add (some (φ x_x) (φ x_y) _) (some (φ y_x) (φ y_y) _),
          --unfold has_add.add,
          rw [EllipticCurve.add, dif_neg $ h_x, if_pos h_y,EllipticCurve.dbl],
          rw [EllipticCurve.add, dif_neg $ not_not.mpr hφ_x, if_pos hφ_y,EllipticCurve.dbl],
          have: φ (2 * x_y + (F↑K) E.a₁ * x_x + (F↑K) E.a₃) = 2 * φ x_y + (F↑L) E.a₁ * φ x_x + (F↑L) E.a₃,
          {by simp only [map_add, map_mul, map_bit0, map_one, alg_hom.commutes],},
          by_cases h_y : 2 * x_y + (F↑K) E.a₁ * x_x + (F↑K) E.a₃ ≠ 0,
          {
            have hφ_y: 2 * φ x_y + (F↑L) E.a₁ * φ x_x + (F↑L) E.a₃ ≠ 0,
            {begin rw <- this, intro h, rw <- map_zero φ at h, exact h_y (φ.to_ring_hom.injective h), end},
            rw [dif_pos $ h_y, dif_pos $ hφ_y],
            unfold point_hom.to_fun,
            simp only [map_add,map_pow,map_mul,map_sub,alg_hom.map_inv,alg_hom.commutes, map_neg, map_bit0,map_bit1, map_one],
            split,
            any_goals {refl},
          },
          {
            have hφ_y: 2 * φ x_y + (F↑L) E.a₁ * φ x_x + (F↑L) E.a₃ = 0,
            {by rw [<- this, not_not.mp h_y, map_zero φ],},
            rw [dif_neg $ h_y, dif_neg $ not_not.mpr hφ_y],
            unfold point_hom.to_fun,
          },
          --simp only [map_add,map_pow,map_mul,map_sub,alg_hom.map_inv,alg_hom.commutes, map_neg],
          --simp [not_not.mp h_x, h_y],
          --simp [eq.refl (φ y_x), hφ_y],

        },

      },

      --unfold point_hom.to_fun,
    --unfold EllipticCurve.add point_hom.to_fun,
    --by_cases x_x_ne_y_x: x_x ≠ y_x,
    --{
      --simp[x_x_ne_y_x,x_x_ne_y_x],
    --}

  end

}
@[simp] lemma point_hom.map_zero : point_hom φ 0 = (0 : E⟮L⟯) := (point_hom φ).map_zero'

@[simp] lemma point_hom.map_add (P Q : E⟮K⟯) :
  point_hom φ (P + Q) = point_hom φ P + point_hom φ Q :=
(point_hom φ).map_add P Q

@[simp] lemma point_hom.id (P : E⟮K⟯) : point_hom (K⟶[F]K) P = P := by cases P; refl

@[simp] lemma point_hom.comp {M : Type u} [field M] [algebra F M] [algebra K M] [algebra L M]
  [is_scalar_tower F L M] [is_scalar_tower F K M] (P : E⟮K⟯) :
  point_hom (L⟶[F]M) (point_hom (K⟶[F]L) P) = point_hom ((L⟶[F]M).comp (K⟶[F]L)) P :=
by cases P; refl

lemma point_hom.injective : function.injective $ @point_hom _ _ E _ _ _ _ _ _ _ _ φ :=
begin
  rintro (_ | _) (_ | _) hPQ,
  any_goals { contradiction },
  { refl },
  { injection hPQ with hx hy,
    simp only,
    exact ⟨φ.to_ring_hom.injective hx, φ.to_ring_hom.injective hy⟩ }
end

/-- Canonical inclusion map `E(K) ↪ E(L)`. -/
def ιₚ : E⟮K⟯ →+ E⟮L⟯ := point_hom $ K⟶[F]L

end functoriality

----------------------------------------------------------------------------------------------------
/-! ## Galois module structure of `E(L)` -/

section galois

/-- The Galois action `Gal(L/K) ↷ E(L)`. -/
def point_gal (σ : L ≃ₐ[K] L) : E⟮L⟯ → E⟮L⟯
| 0            := 0
| (some x y w) := some (σ • x) (σ • y)
begin
  apply_fun ((•) $ σ.restrict_scalars F) at w,
  simp only [smul_add, smul_mul', smul_pow'] at w,
  simp only [alg_equiv.smul_def, alg_equiv.commutes] at w,
  exact w
end

set_option trace.simplify.rewrite true
/-- `Gal(L/K) ↷ E(L)` is a distributive multiplicative action. -/
instance : distrib_mul_action (L ≃ₐ[K] L) E⟮L⟯ :=
{ smul      := point_gal,
  one_smul  :=
  by { rintro (_ | _), { refl }, { simp only [has_scalar.smul, point_gal], exact ⟨rfl, rfl⟩ } },
  mul_smul  := λ _ _,
  by { rintro (_ | _), { refl }, { simp only [has_scalar.smul, point_gal], exact ⟨rfl, rfl⟩ } },
  smul_add  := λ σ,
  begin
    rintro (_ | _) (_ | _),
    any_goals { refl },
    by_cases h_x: x_x ≠ y_x,
    {
      simp [h_x],
      unfold point_gal,
      have hσ_x: σ • x_x ≠ σ • y_x,
      {
        begin intro h, exact h_x (σ.injective h) end
      },
      rw [EllipticCurve.some_add_some_of_x_ne],
      simp [alg_equiv.commutes],
      split,
      refl,
    },
  end,
  smul_zero := λ _, rfl }

/-- The Galois invariant subgroup `E(L)ᴷ` of `E(L)` fixed by `Gal(L/K)`. -/
def point_gal.fixed : add_subgroup E⟮L⟯ :=
{ carrier   := mul_action.fixed_points (L ≃ₐ[K] L) E⟮L⟯,
  zero_mem' := λ _, rfl,
  add_mem'  := λ _ _ hP hQ _, by rw [smul_add, hP, hQ],
  neg_mem'  := λ _ hP σ, by simpa only [neg_inj, smul_neg] using hP σ }

notation E⟮L`⟯^`K := @point_gal.fixed _ _ E K _ _ L _ _ _ _

lemma point_gal.fixed.zero_mem : (0 : E⟮L⟯) ∈ E⟮L⟯^K := point_gal.fixed.zero_mem'

lemma point_gal.fixed.add_mem {P Q : E⟮L⟯} (hP : P ∈ E⟮L⟯^K) (hQ : Q ∈ E⟮L⟯^K) : P + Q ∈ E⟮L⟯^K :=
point_gal.fixed.add_mem' hP hQ

lemma point_gal.fixed.neg_mem {P : E⟮L⟯} (hP : P ∈ E⟮L⟯^K) : -P ∈ E⟮L⟯^K :=
point_gal.fixed.neg_mem' hP

variables [finite_dimensional K L] [is_galois K L]

lemma point_gal.fixed.eq : (E⟮L⟯^K) = (ιₚ : E⟮K⟯ →+ E⟮L⟯).range :=
begin
  ext P,
  split,
  { intro hP,
    cases P with x y w,
    { apply add_subgroup.zero_mem },
    { change ∀ σ : L ≃ₐ[K] L, σ • some x y w = some x y w at hP,
      simp only [has_scalar.smul, point_gal, forall_and_distrib] at hP,
      have hx : x ∈ intermediate_field.fixed_field (⊤ : subgroup (L ≃ₐ[K] L)) := λ σ, hP.left σ,
      have hy : y ∈ intermediate_field.fixed_field (⊤ : subgroup (L ≃ₐ[K] L)) := λ σ, hP.right σ,
      rw [((@is_galois.tfae K _ L _ _ _).out 0 1).mp _inst_9, intermediate_field.mem_bot] at hx hy,
      change ∃ x' : K, (K⟶[F]L)x' = x at hx,
      change ∃ y' : K, (K⟶[F]L)y' = y at hy,
      rw [add_monoid_hom.mem_range],
      existsi [some hx.some hy.some _],
      { change some ((K⟶[F]L)hx.some) ((K⟶[F]L)hy.some) _ = some x y w,
        simp only [hx.some_spec, hy.some_spec],
        exact ⟨rfl, rfl⟩ },
      { apply_fun (K⟶[F]L) using (K⟶[F]L : K →+* L).injective,
        simp only [map_add, map_mul, map_pow, alg_hom.commutes],
        rw [hx.some_spec, hy.some_spec, w] } } },
  { intros hP σ,
    cases P with x y w,
    { refl },
    { rcases hP with ⟨_ | ⟨x', y', w'⟩, hQ⟩,
      { contradiction },
      { change some ((K↑L)x') ((K↑L) y') _ = some x y w at hQ,
        simp only at hQ,
        have hx : x ∈ set.range (K↑L) := exists.intro x' hQ.left,
        have hy : y ∈ set.range (K↑L) := exists.intro y' hQ.right,
        rw [← intermediate_field.mem_bot,
            ← ((@is_galois.tfae K _ L _ _ _).out 0 1).mp _inst_9] at hx hy,
        simp only [has_scalar.smul, point_gal],
        exact ⟨hx ⟨σ, subgroup.mem_top σ⟩, hy ⟨σ, subgroup.mem_top σ⟩⟩ } } }
end

end galois

----------------------------------------------------------------------------------------------------
/-! ## Isomorphism on `E(K)` induced by a linear change of variables -/

section change_of_variables

variables (u : Fˣ) (r s t : F)

/-- The function on `E(K)` induced by a linear change of variables
  `(x, y) ↦ (u²x + r, u³y + u²sx + t)` for some `u ∈ Rˣ` and some `r, s, t ∈ R`. -/
def cov.to_fun : (E.cov u r s t)⟮K⟯ → E⟮K⟯
| 0            := 0
| (some x y w) :=
some ((F↑K)u.val ^ 2 * x + (F↑K)r) ((F↑K)u.val ^ 3 * y + (F↑K)u.val ^ 2 * (F↑K)s * x + (F↑K)t)
begin
  have w_rw : ∀ a₁ a₂ a₃ a₄ a₆ v i : K,
    v ^ 6 * (y ^ 2 + i * a₁ * x * y + i ^ 3 * a₃ * y)
    - v ^ 6 * (x ^ 3 + i ^ 2 * a₂ * x ^ 2 + i ^ 4 * a₄ * x + i ^ 6 * a₆)
    = v ^ 6 * y ^ 2 + v ^ 5 * (v * i) * a₁ * x * y + v ^ 3 * (v * i) ^ 3 * a₃ * y - v ^ 6 * x ^ 3
      - v ^ 4 * (v * i) ^ 2 * a₂ * x ^ 2 - v ^ 2 * (v * i) ^ 4 * a₄ * x - (v * i) ^ 6 * a₆ :=
  by { intros, ring1 },
  apply_fun ((*) ((F↑K)u.val ^ 6)) at w,
  simp only [cov, algebra.id.map_eq_self] at w,
  simp only [map_neg, map_add, map_sub, map_mul, map_pow] at w,
  rw [← sub_eq_zero, w_rw, ← map_mul, u.val_inv] at w,
  simp only [map_one, map_bit0, map_bit1] at w,
  rw [← sub_eq_zero, ← w],
  ring1
end

/-- The inverse function on `E(K)` induced by a linear change of variables
  `(x, y) ↦ ((u⁻¹)²(x - r), (u⁻¹)³(y - sx + rs - t))` for some `u ∈ Rˣ` and some `r, s, t ∈ R`. -/
def cov.inv_fun : E⟮K⟯ → (E.cov u r s t)⟮K⟯
| 0            := 0
| (some x y w) :=
some ((F↑K)u.inv ^ 2 * (x - (F↑K)r)) ((F↑K)u.inv ^ 3 * (y - (F↑K)s * x + (F↑K)r * (F↑K)s - (F↑K)t))
begin
  apply_fun ((*) ((F↑K)u.inv ^ 6)) at w,
  rw [← sub_eq_zero] at w,
  simp only [cov, algebra.id.map_eq_self],
  simp only [map_neg, map_add, map_sub, map_mul, map_pow],
  simp only [map_one, map_bit0, map_bit1],
  rw [← sub_eq_zero, ← w],
  ring1
end

/-- `(x, y) ↦ (u²x + r, u³y + u²sx + t)` is a group isomorphism on `E(K)`. -/
def cov.equiv_add : (E.cov u r s t)⟮K⟯ ≃+ E⟮K⟯ :=
{ to_fun    := cov.to_fun u r s t,
  inv_fun   := cov.inv_fun u r s t,
  left_inv  :=
  begin
    rintro (_ | ⟨x, y, _⟩),
    { refl },
    { have x_rw : ∀ r v i : K, i ^ 2 * (v ^ 2 * x + r - r) = (i * v) ^ 2 * x :=
      by { intros, ring1 },
      have y_rw : ∀ r s t v i : K,
        i ^ 3 * (v ^ 3 * y + v ^ 2 * s * x + t - s * (v ^ 2 * x + r) + r * s - t)
          = (i * v) ^ 3 * y :=
      by { intros, ring1 },
      simp only [cov.to_fun, cov.inv_fun],
      rw [x_rw, y_rw, ← map_mul, u.inv_val],
      simp only [one_mul, one_pow, map_one],
      exact ⟨rfl, rfl⟩ }
  end,
  right_inv :=
  begin
    rintro (_ | ⟨x, y, _⟩),
    { refl },
    { have x_rw : ∀ r v i : K, v ^ 2 * (i ^ 2 * (x - r)) + r = (v * i) ^ 2 * (x - r) + r :=
      by { intros, ring1 },
      have y_rw : ∀ r s t v i : K,
        v ^ 3 * (i ^ 3 * (y - s * x + r * s - t)) + v ^ 2 * s * (i ^ 2 * (x - r)) + t
        = (v * i) ^ 3 * y + ((v * i) ^ 2 - (v * i) ^ 3) * (s * x - r * s) + (1 - (v * i) ^ 3) * t :=
      by { intros, ring1 },
      simp only [cov.to_fun, cov.inv_fun],
      rw [x_rw, y_rw, ← map_mul, u.val_inv, map_one],
      simp only [sub_self, sub_add_cancel, add_zero, zero_mul, one_mul, one_pow],
      exact ⟨rfl, rfl⟩ }
  end,
  map_add'  :=
  begin
    rintro (_ | _) (_ | _),
    any_goals { refl },
    sorry
  end }

/-- Completing a square is a group isomorphism on `E(K)`. -/
def covₘ.equiv_add [invertible (2 : F)] : E.covₘ⟮K⟯ ≃+ E⟮K⟯ :=
cov.equiv_add 1 0 (-⅟2 * E.a₁) (-⅟2 * E.a₃)

end change_of_variables

----------------------------------------------------------------------------------------------------

end EllipticCurve


/-
Copyright (c) 2022 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Heather Macbeth
-/

import ring_theory.witt_vector.truncated
import data.mv_polynomial.supported

/-!
# Leading terms of Witt vector multiplication

The goal of this file is to study the leading terms of the formula for the `n+1`st coefficient
of a product of Witt vectors `x` and `y` over a ring of characteristic `p`.
We aim to isolate the `n+1`st coefficients of `x` and `y`, and express the rest of the product
in terms of a function of the lower coefficients.

For most of this file we work with terms of type `mv_polynomial (fin 2 × ℕ) ℤ`.
We will eventually evaluate them in `k`, but first we must take care of a calculation
that needs to happen in characteristic 0.

## Main declarations

* `witt_vector.nth_mul_coeff`: expresses the coefficient of a product of Witt vectors
  in terms of the previous coefficients of the multiplicands.

-/

noncomputable theory

namespace witt_vector

variables (p : ℕ) [hp : fact p.prime]
variables {k : Type*} [comm_ring k]
local notation `𝕎` := witt_vector p
open finset mv_polynomial
open_locale big_operators

/--
```
(∑ i in range n, (y.coeff i)^(p^(n-i)) * p^i.val) *
  (∑ i in range n, (y.coeff i)^(p^(n-i)) * p^i.val)
```
-/
def witt_poly_prod (n : ℕ) : mv_polynomial (fin 2 × ℕ) ℤ :=
rename (prod.mk (0 : fin 2)) (witt_polynomial p ℤ n) *
  rename (prod.mk (1 : fin 2)) (witt_polynomial p ℤ n)

include hp

lemma witt_poly_prod_vars (n : ℕ) : (witt_poly_prod p n).vars ⊆ univ ×ˢ range (n + 1) :=
begin
  rw [witt_poly_prod],
  apply subset.trans (vars_mul _ _),
  apply union_subset;
  { apply subset.trans (vars_rename _ _),
    simp [witt_polynomial_vars,image_subset_iff] }
end

/-- The "remainder term" of `witt_vector.witt_poly_prod`. See `mul_poly_of_interest_aux2`. -/
def witt_poly_prod_remainder (n : ℕ) : mv_polynomial (fin 2 × ℕ) ℤ :=
∑ i in range n, p^i * (witt_mul p i)^(p^(n-i))

lemma witt_poly_prod_remainder_vars (n : ℕ) :
  (witt_poly_prod_remainder p n).vars ⊆ univ ×ˢ range n :=
begin
  rw [witt_poly_prod_remainder],
  apply subset.trans (vars_sum_subset _ _),
  rw bUnion_subset,
  intros x hx,
  apply subset.trans (vars_mul _ _),
  apply union_subset,
  { apply subset.trans (vars_pow _ _),
    have : (p : mv_polynomial (fin 2 × ℕ) ℤ) = (C (p : ℤ)),
    { simp only [int.cast_coe_nat, eq_int_cast] },
    rw [this, vars_C],
    apply empty_subset },
  { apply subset.trans (vars_pow _ _),
    apply subset.trans (witt_mul_vars _ _),
    apply product_subset_product (subset.refl _),
    simp only [mem_range, range_subset] at hx ⊢,
    exact hx }
end

omit hp

/--
`remainder p n` represents the remainder term from `mul_poly_of_interest_aux3`.
`witt_poly_prod p (n+1)` will have variables up to `n+1`,
but `remainder` will only have variables up to `n`.
-/
def remainder (n : ℕ) : mv_polynomial (fin 2 × ℕ) ℤ :=
(∑ (x : ℕ) in
     range (n + 1),
     (rename (prod.mk 0)) ((monomial (finsupp.single x (p ^ (n + 1 - x)))) (↑p ^ x))) *
  ∑ (x : ℕ) in
    range (n + 1),
    (rename (prod.mk 1)) ((monomial (finsupp.single x (p ^ (n + 1 - x)))) (↑p ^ x))

include hp

lemma remainder_vars (n : ℕ) : (remainder p n).vars ⊆ univ ×ˢ range (n + 1) :=
begin
  rw [remainder],
  apply subset.trans (vars_mul _ _),
  apply union_subset;
  { apply subset.trans (vars_sum_subset _ _),
    rw bUnion_subset,
    intros x hx,
    rw [rename_monomial, vars_monomial, finsupp.map_domain_single],
    { apply subset.trans (finsupp.support_single_subset),
      simp [hx], },
    { apply pow_ne_zero,
      exact_mod_cast hp.out.ne_zero } }
end

/-- This is the polynomial whose degree we want to get a handle on. -/
def poly_of_interest (n : ℕ) : mv_polynomial (fin 2 × ℕ) ℤ :=
witt_mul p (n + 1) + p^(n+1) * X (0, n+1) * X (1, n+1) -
  (X (0, n+1)) * rename (prod.mk (1 : fin 2)) (witt_polynomial p ℤ (n + 1)) -
  (X (1, n+1)) * rename (prod.mk (0 : fin 2)) (witt_polynomial p ℤ (n + 1))

lemma mul_poly_of_interest_aux1 (n : ℕ) :
  (∑ i in range (n+1), p^i * (witt_mul p i)^(p^(n-i)) : mv_polynomial (fin 2 × ℕ) ℤ) =
    witt_poly_prod p n :=
begin
  simp only [witt_poly_prod],
  convert witt_structure_int_prop p (X (0 : fin 2) * X 1) n using 1,
  { simp only [witt_polynomial, witt_mul],
    rw alg_hom.map_sum,
    congr' 1 with i,
    congr' 1,
    have hsupp : (finsupp.single i (p ^ (n - i))).support = {i},
    { rw finsupp.support_eq_singleton,
      simp only [and_true, finsupp.single_eq_same, eq_self_iff_true, ne.def],
      exact pow_ne_zero _ hp.out.ne_zero, },
    simp only [bind₁_monomial, hsupp, int.cast_coe_nat, prod_singleton, eq_int_cast,
      finsupp.single_eq_same, C_pow, mul_eq_mul_left_iff, true_or, eq_self_iff_true], },
  { simp only [map_mul, bind₁_X_right] }
end

lemma mul_poly_of_interest_aux2 (n : ℕ) :
  (p ^ n * witt_mul p n : mv_polynomial (fin 2 × ℕ) ℤ) + witt_poly_prod_remainder p n =
    witt_poly_prod p n :=
begin
  convert mul_poly_of_interest_aux1 p n,
  rw [sum_range_succ, add_comm, nat.sub_self, pow_zero, pow_one],
  refl
end

omit hp

  -- unfold definitions and peel off the last entries of the sums.
  rw [witt_poly_prod, witt_polynomial, alg_hom.map_sum, alg_hom.map_sum,
      sum_range_succ],
  -- these are sums up to `n+2`, so be careful to only unfold to `n+1`.
  conv_lhs {congr, skip, rw [sum_range_succ] },
  simp only [add_mul, mul_add, tsub_self, pow_zero, alg_hom.map_sum],

  -- rearrange so that the first summand on rhs and lhs is `remainder`, and peel off
  conv_rhs { rw add_comm },
  simp only [add_assoc],
  apply congr_arg (has_add.add _),
  conv_rhs { rw sum_range_succ },

  -- the rest is equal with proper unfolding and `ring`
  simp only [rename_monomial, ← C_mul_X_pow_eq_monomial, map_mul, rename_C, pow_one, rename_X],
  simp only [mvpz, int.cast_coe_nat, map_pow, eq_int_cast, rename_X, pow_one, tsub_self, pow_zero],
  ring1
end
include hp

lemma mul_poly_of_interest_aux4 (n : ℕ) :
  (p ^ (n + 1) * witt_mul p (n + 1) : mv_polynomial (fin 2 × ℕ) ℤ) =
  - (p^(n+1) * X (0, n+1)) * (p^(n+1) * X (1, n+1)) +
  (p^(n+1) * X (0, n+1)) * rename (prod.mk (1 : fin 2)) (witt_polynomial p ℤ (n + 1)) +
  (p^(n+1) * X (1, n+1)) * rename (prod.mk (0 : fin 2)) (witt_polynomial p ℤ (n + 1)) +
  (remainder p n - witt_poly_prod_remainder p (n + 1)) :=
begin
  rw [← add_sub_assoc, eq_sub_iff_add_eq, mul_poly_of_interest_aux2],
  exact mul_poly_of_interest_aux3 _ _
end

lemma mul_poly_of_interest_aux5 (n : ℕ) :
  (p ^ (n + 1) : mv_polynomial (fin 2 × ℕ) ℤ) *
    poly_of_interest p n =
  (remainder p n - witt_poly_prod_remainder p (n + 1)) :=
begin
  simp only [poly_of_interest, mul_sub, mul_add, sub_eq_iff_eq_add'],
  rw mul_poly_of_interest_aux4 p n,
  ring,
end

lemma mul_poly_of_interest_vars (n : ℕ) :
  ((p ^ (n + 1) : mv_polynomial (fin 2 × ℕ) ℤ) * poly_of_interest p n).vars ⊆
  univ ×ˢ range (n + 1) :=
begin
  rw mul_poly_of_interest_aux5,
  apply subset.trans (vars_sub_subset _ _),
  apply union_subset,
  { apply remainder_vars },
  { apply witt_poly_prod_remainder_vars }
end

lemma poly_of_interest_vars_eq (n : ℕ) :
  (poly_of_interest p n).vars =
    ((p ^ (n + 1) : mv_polynomial (fin 2 × ℕ) ℤ) * (witt_mul p (n + 1) +
    p^(n+1) * X (0, n+1) * X (1, n+1) -
    (X (0, n+1)) * rename (prod.mk (1 : fin 2)) (witt_polynomial p ℤ (n + 1)) -
    (X (1, n+1)) * rename (prod.mk (0 : fin 2)) (witt_polynomial p ℤ (n + 1)))).vars :=
begin
  have : (p ^ (n + 1) : mv_polynomial (fin 2 × ℕ) ℤ) = C (p ^ (n + 1) : ℤ),
  { simp only [int.cast_coe_nat, eq_int_cast, C_pow, eq_self_iff_true] },
  rw [poly_of_interest, this, vars_C_mul],
  apply pow_ne_zero,
  exact_mod_cast hp.out.ne_zero
end

lemma poly_of_interest_vars (n : ℕ) : (poly_of_interest p n).vars ⊆ univ ×ˢ (range (n+1)) :=
by rw poly_of_interest_vars_eq; apply mul_poly_of_interest_vars

lemma peval_poly_of_interest (n : ℕ) (x y : 𝕎 k) :
  peval (poly_of_interest p n) ![λ i, x.coeff i, λ i, y.coeff i] =
  (x * y).coeff (n + 1) + p^(n+1) * x.coeff (n+1) * y.coeff (n+1)
    - y.coeff (n+1) * ∑ i in range (n+1+1), p^i * x.coeff i ^ (p^(n+1-i))
    - x.coeff (n+1) * ∑ i in range (n+1+1), p^i * y.coeff i ^ (p^(n+1-i)) :=
begin
  simp only [poly_of_interest, peval, map_nat_cast, matrix.head_cons, map_pow,
    function.uncurry_apply_pair, aeval_X,
  matrix.cons_val_one, map_mul, matrix.cons_val_zero, map_sub],
  rw [sub_sub, add_comm (_ * _), ← sub_sub],
  have mvpz : (p : mv_polynomial ℕ ℤ) = mv_polynomial.C ↑p,
  { rw [eq_int_cast, int.cast_coe_nat] },
  have : ∀ (f : ℤ →+* k) (g : ℕ → k), eval₂ f g p = f p,
  { intros, rw [mvpz, mv_polynomial.eval₂_C] },
  simp [witt_polynomial_eq_sum_C_mul_X_pow, aeval, eval₂_rename, this, mul_coeff, peval,
    map_nat_cast, map_add, map_pow, map_mul]
end

variable [char_p k p]

/-- The characteristic `p` version of `peval_poly_of_interest` -/
lemma peval_poly_of_interest' (n : ℕ) (x y : 𝕎 k) :
  peval (poly_of_interest p n) ![λ i, x.coeff i, λ i, y.coeff i] =
  (x * y).coeff (n + 1) - y.coeff (n+1) * x.coeff 0 ^ (p^(n+1))
    - x.coeff (n+1) * y.coeff 0 ^ (p^(n+1)) :=
begin
  rw peval_poly_of_interest,
  have : (p : k) = 0 := char_p.cast_eq_zero (k) p,
  simp only [this, add_zero, zero_mul, nat.succ_ne_zero, ne.def, not_false_iff, zero_pow'],
  have sum_zero_pow_mul_pow_p : ∀ y : 𝕎 k,
    ∑ (x : ℕ) in range (n + 1 + 1), 0 ^ x * y.coeff x ^ p ^ (n + 1 - x) = y.coeff 0 ^ p ^ (n + 1),
  { intro y,
    rw finset.sum_eq_single_of_mem 0,
    { simp },
    { simp },
    { intros j _ hj,
      simp [zero_pow (zero_lt_iff.mpr hj)] } },
  congr; apply sum_zero_pow_mul_pow_p,
end

variable (k)
lemma nth_mul_coeff' (n : ℕ) :
  ∃ f : truncated_witt_vector p (n+1) k → truncated_witt_vector p (n+1) k → k, ∀ (x y : 𝕎 k),
  f (truncate_fun (n+1) x) (truncate_fun (n+1) y)
  = (x * y).coeff (n+1) - y.coeff (n+1) * x.coeff 0 ^ (p^(n+1))
    - x.coeff (n+1) * y.coeff 0 ^ (p^(n+1)) :=
begin
  simp only [←peval_poly_of_interest'],
  obtain ⟨f₀, hf₀⟩ := exists_restrict_to_vars k (poly_of_interest_vars p n),
  let f : truncated_witt_vector p (n+1) k → truncated_witt_vector p (n+1) k → k,
  { intros x y,
    apply f₀,
    rintros ⟨a, ha⟩,
    apply function.uncurry (![x, y]),
    simp only [true_and, multiset.mem_cons, range_val, product_val, multiset.mem_range,
       multiset.mem_product, multiset.range_succ, mem_univ_val] at ha,
    refine ⟨a.fst, ⟨a.snd, _⟩⟩,
    cases ha with ha ha; linarith only [ha] },
  use f,
  intros x y,
  dsimp [peval],
  rw ← hf₀,
  simp only [f, function.uncurry_apply_pair],
  congr,
  ext a,
  cases a with a ha,
  cases a with i m,
  simp only [true_and, multiset.mem_cons, range_val, product_val, multiset.mem_range,
    multiset.mem_product, multiset.range_succ, mem_univ_val] at ha,
  have ha' : m < n + 1 := by cases ha with ha ha; linarith only [ha],
  fin_cases i;  -- surely this case split is not necessary
  { simpa only using x.coeff_truncate_fun ⟨m, ha'⟩ }
end

lemma nth_mul_coeff (n : ℕ) :
  ∃ f : truncated_witt_vector p (n+1) k → truncated_witt_vector p (n+1) k → k, ∀ (x y : 𝕎 k),
    (x * y).coeff (n+1) =
      x.coeff (n+1) * y.coeff 0 ^ (p^(n+1)) + y.coeff (n+1) * x.coeff 0 ^ (p^(n+1)) +
      f (truncate_fun (n+1) x) (truncate_fun (n+1) y) :=
begin
  obtain ⟨f, hf⟩ := nth_mul_coeff' p k n,
  use f,
  intros x y,
  rw hf x y,
  ring,
end

variable {k}

/--
Produces the "remainder function" of the `n+1`st coefficient, which does not depend on the `n+1`st
coefficients of the inputs. -/
def nth_remainder (n : ℕ) : (fin (n+1) → k) → (fin (n+1) → k) → k :=
classical.some (nth_mul_coeff p k n)

lemma nth_remainder_spec (n : ℕ) (x y : 𝕎 k) :
  (x * y).coeff (n+1) =
    x.coeff (n+1) * y.coeff 0 ^ (p^(n+1)) + y.coeff (n+1) * x.coeff 0 ^ (p^(n+1)) +
    nth_remainder p n (truncate_fun (n+1) x) (truncate_fun (n+1) y) :=
classical.some_spec (nth_mul_coeff p k n) _ _

end witt_vector


/-
Proof system for the locally-nameless representation of first-order logic
following the notes at /flypitch-notes

Thanks to Andrew who wrote the prototypical examples in language_term_n*
---Jesse 2018-10-16T00:00:50
-/

import .language_term_ln2

section
parameter L : Language

def arity (α β : Type) : nat → Type -- thanks Seul!!
| 0 := β
| (n+1) := α → arity n

-- inductive closed_preterm :Π n : ℕ,  preterm L n → Prop
-- | bvar : Π k : ℕ, closed_preterm 0 (preterm.bvar L k)
-- | func : Π n : ℕ, Π f : L.functions n, closed_preterm n (preterm.func f)
-- | apply : Π n : ℕ, Π t1 : (preterm L (n+1)), Π t2 : (preterm L 0), Π h1 : (closed_preterm (n+1) t1), Π h2 : (closed_preterm 0 t2), closed_preterm n (preterm.apply t1 t2)

-- inductive presentence : Π(n : ℕ), preformula L n → Prop
-- | true : presentence 0 (preformula.true L)
-- | false : presentence 0 (preformula.false L)
-- | equal : Π t1 t2 : term L, Π h1 : closed_preterm 0 t1, Π h2 : closed_preterm 0 t2, presentence 0 (preformula.equal t1 t2)
-- | rel : Π {n : ℕ}, Π R : L.relations n, presentence n (preformula.rel R)
-- | apprel : Π {n : ℕ}, Π ψ : preformula L (n+1), Π t : term L, Π h1 : presentence (n+1) ψ, Π h2 : closed_preterm 0 t, presentence n (preformula.apprel ψ t)
-- | imp : Π ϕ : preformula L 0, Π ψ : preformula L 0, Π h1 : presentence 0 ϕ, Π h2 : presentence 0 ψ, presentence 0 (preformula.imp ϕ ψ)
-- | all : Π ψ : preformula L 0, Π h : presentence 0 ψ, presentence 0 (preformula.all ψ) -- this is wrong
--
-- def sentence : formula L → Prop := presentence 0

/-- A sentence is a well-formed L-formula with no free variables --/
def is_sentence : formula L → Prop := λ ψ, (free_vars_formula L ψ = []) ∧ well_formed_formula L ψ
def sentences := {ψ : formula L // is_sentence ψ}

lemma true_is_sentence : is_sentence (preformula.true L) :=
begin
split,
{split,},
{trivial}
end

lemma false_is_sentence : is_sentence (preformula.false L) :=
begin
split,
{split},
{split}
end

lemma imp_is_sentence (ϕ : sentences) (ψ : sentences) : is_sentence (preformula.imp (ϕ.val) (ψ.val)) :=
begin
split,
  {cases ϕ,
  cases ψ,
  simp[free_vars_formula],
  cases ϕ_property,
  cases ψ_property,
  simp[free_vars_preformula],
  have h1 : free_vars_preformula L 0 ϕ_val = free_vars_formula L ϕ_val,
    {refl},
  have h2 :  free_vars_preformula L 0 ψ_val = free_vars_formula L ψ_val,
    {refl},
  simp [h1, h2],
  rw [ϕ_property_left, ψ_property_left],
  refl},
{split,
  {exact and.right (ϕ.property)},
  {exact and.right (ψ.property)}, }
end

#reduce true_is_sentence

-- For now, I am deciding against a proof system with nonempty contexts.

-- reflecting Prop-tautologies into sentences L

inductive propositional_combination : ((list (sentences)) → sentences) → Prop
| true : propositional_combination (λ xs, ⟨preformula.true L, true_is_sentence⟩)
| false : propositional_combination (λ xs, ⟨preformula.false L, false_is_sentence⟩)
| imp : Π f g : ((list (sentences)) → sentences), Π hf : propositional_combination f, Π hg : propositional_combination g, propositional_combination (λ xs, ⟨preformula.imp (f xs).val (g xs).val, imp_is_sentence⟩)

-- TODO: get all projections, get all propositional combinations thereof.

end


import morphism.Reynold_operator
import sub_module
import homothetic
import Projection.test_linear_algebra
open Reynold
universes  u v w w'
variables {G : Type u} [group G][fintype G] {R : Type v}[comm_ring R]
variables  {M : Type w}[add_comm_group M] [module R M]  ( ρ : group_representation G R M)
(W : submodule  R M)(hyp : stability.stable_submodule ρ  W)
lemma fact_minus_one (p : M→ₗ[R]M )(hyp : is_projector p)(x : M) : p (p x) = p x :=
begin
     change (has_mul.mul p  p) x = p x,
     unfold is_projector at hyp,
     rw hyp,
end
lemma fact0 (g : G) (x : M) : ρ g ((ρ g⁻¹) x) = x := begin
    change ((ρ g) * (ρ g⁻¹ )) x = x,
    erw ← ρ.map_mul,
    erw mul_inv_self,
    erw ρ.map_one, exact rfl,
end
lemma fact1 (p : M→ₗ[R]M )(hyp : is_projector p) (g : G) : is_projector (mixte_conj ρ ρ p g) :=
begin
    unfold is_projector,
    unfold mixte_conj, erw mul_assoc,
    erw ← mul_assoc ↑(ρ g), erw ← mul_assoc ↑(ρ g),
    ext,simp,
    erw fact0,
    erw fact_minus_one,
    assumption,
end
lemma range_mixte_conj (p : M→ₗ[R]M )(g : G) : linear_map.range (mixte_conj ρ ρ p g) =
submodule.map (ρ g⁻¹  : M →ₗ[R]M ) (linear_map.range p) := begin
    apply le_antisymm,
    unfold mixte_conj, rw submodule.le_def',
    intros x, intros hyp, rw submodule.mem_map,rw linear_map.mem_range at hyp,
    rcases hyp with ⟨y, hyp_y ⟩,
    use p (ρ g y),split,
    exact image_in_range p _,
    rw ← hyp_y,
    exact rfl,
    rw submodule.le_def' at  *, intros x, intros hyp_x, rw linear_map.mem_range,
    rcases hyp_x with ⟨z, hyp_z⟩  , rcases hyp_z,
    erw linear_map.mem_range at hyp_z_left,
    rcases hyp_z_left with ⟨y,hyp_u⟩ , use (ρ g⁻¹ ) y,
    dunfold mixte_conj,
    rw linear_map.comp_apply, erw fact0, rw ← hyp_z_right, rw ← hyp_u, exact rfl,
end
lemma range_grall(hyp : stability.stable_submodule ρ  W) ( g : G) : submodule.map (ρ g : M →ₗ[R] M) W = W  := begin
    apply le_antisymm,
        {rw submodule.le_def' ,intros x, intro hyp',  rcases hyp', rw ← hyp'_h.2,
            unfold stability.stable_submodule at hyp,
            exact ((hyp g) ⟨ hyp'_w,hyp'_h.1⟩ ),},
        {rw submodule.le_def',intros x,  intro certifa, rw submodule.mem_map,
        use (ρ g⁻¹ ) x, split,{exact (hyp g⁻¹ )⟨x,certifa⟩},{erw fact0},}

end
theorem pre_mask (hyp : stability.stable_submodule ρ  W) (Hyp : has_projector W) (a : R )  (inv : a * (fintype.card G) = 1 ) :
∃ F : ρ ⟶ ρ,is_projector F.ℓ ∧  linear_map.range (F.ℓ) = W   :=
begin
    rcases Hyp with ⟨p,hyp_p⟩,
    use a • (ℛ ρ ρ  p),
    rw homothetic.smul_ext, --- amélioration de la class homothetic
    erw reynold_ext,
    apply   @sum_proj R _  M _ _  G _ W a _,
    intros g,
    apply fact1, exact hyp_p.1,
    intros g,
    rw range_mixte_conj,rw hyp_p.2,rw range_grall, assumption,
    assumption,
end


import tactic --hide

/-Lemma
If $P, Q$ are logical statements then $P \implies \mathrm{false}$ implies $P \implies Q$.
-/
lemma P_to_false_to_P_to_Q (P Q : Prop) : (P → false) → P → Q :=
begin
  intros hpf hp,
  exfalso,
  apply hpf,
  exact hp,

end


import ring_theory

universe u

namespace field

open ideal

variable {α : Type u}
variable [field α]

lemma ne_bot_is_top : ∀ I : ideal α, I ≠ ⊥ → I = ⊤ :=
assume I : ideal α,
assume h : I ≠ ⊥,
have ∃ x ∈ I, (x : α) ≠ (0 : α), from mem_of_not_bot I h,
let ⟨x, hI, h0⟩ := this in
have is_unit x, from is_unit_of_mul_one x (x⁻¹) (field.mul_inv_cancel h0),
show I = ⊤, from eq_top_of_is_unit_mem I hI this

lemma bot_is_max : is_maximal (⊥ : ideal α) :=
have h : ∀ I : ideal α, ⊥ < I → I = ⊤, from
  assume I : ideal α,
  assume hI : ⊥ < I,
  have I ≠ ⊥, from lattice.bot_lt_iff_ne_bot.mp hI,
  show I = ⊤, from ne_bot_is_top I this,
show is_maximal (⊥ : ideal α), from ⟨bot_ne_top, h⟩

lemma bot_is_prime : is_prime (⊥ : ideal α) :=
is_maximal.is_prime bot_is_max

end field


import .size .induction_size

noncomputable theory
open_locale classical big_operators

variables {α : Type*}

def neg_one_pow (n : ℤ) : ℤ := (-1)^(n.nat_abs)

theorem ie (s : set (set α)) :
  size (⋃₀ s) = ∑ᶠ t in s.powerset \ {∅}, neg_one_pow (size t) * size (⋂₀ t) :=
begin
  revert s,
  refine induction_set_size_insert _ (by simp) _,
  intros s a ha IH,

end


/-
Copyright (c) 2022 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/

namespace Cpdt
namespace Chapter4

inductive IsZero : Nat → Prop where
  | zero : IsZero 0

theorem add_IsZero : IsZero m → n + m = n := by
  intro h
  cases h
  rfl

theorem IsZero_contra : IsZero 1 → False := by
  intro h
  cases h

end Chapter4
end Cpdt


open classical

variables p q : Prop

example (h : ¬(p ∧ q)) : ¬p ∨ ¬q :=
  or.elim (em p)
    (assume hp : p,
       or.inr
         (show ¬q, from
           assume hq : q,
           h ⟨hp, hq⟩))
    (assume hp : ¬p,
       or.inl hp)


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Chris Hughes
-/
import algebra.gcd_monoid.basic
import ring_theory.coprime.basic
import ring_theory.ideal.basic
import ring_theory.principal_ideal_domain

/-!
# Lemmas about Euclidean domains

Various about Euclidean domains are proved; all of them seem to be true
more generally for principal ideal domains, so these lemmas should
probably be reproved in more generality and this file perhaps removed?

## Tags

euclidean domain
-/

noncomputable theory
open_locale classical
open euclidean_domain set ideal

section gcd_monoid

variables {R : Type*} [euclidean_domain R] [gcd_monoid R]

lemma left_div_gcd_ne_zero {p q : R} (hp : p ≠ 0) :
  p / gcd_monoid.gcd p q ≠ 0 :=
begin
  obtain ⟨r, hr⟩ := gcd_monoid.gcd_dvd_left p q,
  obtain ⟨pq0, r0⟩ : gcd_monoid.gcd p q ≠ 0 ∧ r ≠ 0 := mul_ne_zero_iff.mp (hr ▸ hp),
  rw [hr, mul_comm, mul_div_cancel _ pq0] { occs := occurrences.pos [1] },
  exact r0,
end

lemma right_div_gcd_ne_zero {p q : R} (hq : q ≠ 0) :
  q / gcd_monoid.gcd p q ≠ 0 :=
begin
  obtain ⟨r, hr⟩ := gcd_monoid.gcd_dvd_right p q,
  obtain ⟨pq0, r0⟩ : gcd_monoid.gcd p q ≠ 0 ∧ r ≠ 0 := mul_ne_zero_iff.mp (hr ▸ hq),
  rw [hr, mul_comm, mul_div_cancel _ pq0] { occs := occurrences.pos [1] },
  exact r0,
end

end gcd_monoid

namespace euclidean_domain

/-- Create a `gcd_monoid` whose `gcd_monoid.gcd` matches `euclidean_domain.gcd`. -/
def gcd_monoid (R) [euclidean_domain R] : gcd_monoid R :=
{ gcd := gcd,
  lcm := lcm,
  gcd_dvd_left := gcd_dvd_left,
  gcd_dvd_right := gcd_dvd_right,
  dvd_gcd := λ a b c, dvd_gcd,
  gcd_mul_lcm := λ a b, by rw euclidean_domain.gcd_mul_lcm,
  lcm_zero_left := lcm_zero_left,
  lcm_zero_right := lcm_zero_right }

variables {α : Type*} [euclidean_domain α] [decidable_eq α]

theorem span_gcd {α} [euclidean_domain α] (x y : α) :
  span ({gcd x y} : set α) = span ({x, y} : set α) :=
begin
  letI := euclidean_domain.gcd_monoid α,
  exact span_gcd x y,
end

theorem gcd_is_unit_iff {α} [euclidean_domain α] {x y : α} :
  is_unit (gcd x y) ↔ is_coprime x y :=
begin
  letI := euclidean_domain.gcd_monoid α,
  exact gcd_is_unit_iff x y,
end

-- this should be proved for UFDs surely?
theorem is_coprime_of_dvd {α} [euclidean_domain α] {x y : α}
  (z : ¬ (x = 0 ∧ y = 0)) (H : ∀ z ∈ nonunits α, z ≠ 0 → z ∣ x → ¬ z ∣ y) :
  is_coprime x y :=
begin
  letI := euclidean_domain.gcd_monoid α,
  exact is_coprime_of_dvd x y z H,
end

-- this should be proved for UFDs surely?
theorem dvd_or_coprime {α} [euclidean_domain α] (x y : α)
  (h : irreducible x) : x ∣ y ∨ is_coprime x y :=
begin
  letI := euclidean_domain.gcd_monoid α,
  exact dvd_or_coprime x y h,
end

end euclidean_domain