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

Generalizes the Cauchy completion of (ℚ, abs) to the completion of a
commutative ring with absolute value.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.real.cau_seq
import Mathlib.PostPort

universes u_1 u_2 l

namespace Mathlib

namespace cau_seq.completion

def Cauchy {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] :=
  quotient cau_seq.equiv

def mk {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : cau_seq β abv → Cauchy :=
  quotient.mk

@[simp] theorem mk_eq_mk {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) : quotient.mk f = mk f :=
  rfl

theorem mk_eq {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] {f : cau_seq β abv} {g : cau_seq β abv} : mk f = mk g ↔ f ≈ g :=
  quotient.eq

def of_rat {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (x : β) : Cauchy :=
  mk (const abv x)

protected instance Cauchy.has_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : HasZero Cauchy :=
  { zero := of_rat 0 }

protected instance Cauchy.has_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : HasOne Cauchy :=
  { one := of_rat 1 }

protected instance Cauchy.inhabited {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : Inhabited Cauchy :=
  { default := 0 }

theorem of_rat_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : of_rat 0 = 0 :=
  rfl

theorem of_rat_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : of_rat 1 = 1 :=
  rfl

@[simp] theorem mk_eq_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] {f : cau_seq β abv} : mk f = 0 ↔ lim_zero f :=
  eq.mp (Eq._oldrec (Eq.refl (mk f = 0 ↔ lim_zero (f - 0))) (sub_zero f)) quotient.eq

protected instance Cauchy.has_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : Add Cauchy :=
  { add := fun (x y : Cauchy) => quotient.lift_on₂ x y (fun (f g : cau_seq β abv) => mk (f + g)) sorry }

@[simp] theorem mk_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) (g : cau_seq β abv) : mk f + mk g = mk (f + g) :=
  rfl

protected instance Cauchy.has_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : Neg Cauchy :=
  { neg := fun (x : Cauchy) => quotient.lift_on x (fun (f : cau_seq β abv) => mk (-f)) sorry }

@[simp] theorem mk_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) : -mk f = mk (-f) :=
  rfl

protected instance Cauchy.has_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : Mul Cauchy :=
  { mul := fun (x y : Cauchy) => quotient.lift_on₂ x y (fun (f g : cau_seq β abv) => mk (f * g)) sorry }

@[simp] theorem mk_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) (g : cau_seq β abv) : mk f * mk g = mk (f * g) :=
  rfl

protected instance Cauchy.has_sub {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : Sub Cauchy :=
  { sub := fun (x y : Cauchy) => quotient.lift_on₂ x y (fun (f g : cau_seq β abv) => mk (f - g)) sorry }

@[simp] theorem mk_sub {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (f : cau_seq β abv) (g : cau_seq β abv) : mk f - mk g = mk (f - g) :=
  rfl

theorem of_rat_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x + y) = of_rat x + of_rat y :=
  congr_arg mk (const_add x y)

theorem of_rat_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (x : β) : of_rat (-x) = -of_rat x :=
  congr_arg mk (const_neg x)

theorem of_rat_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x * y) = of_rat x * of_rat y :=
  congr_arg mk (const_mul x y)

protected instance Cauchy.comm_ring {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] : comm_ring Cauchy :=
  comm_ring.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub sorry sorry Mul.mul sorry 1 sorry sorry sorry sorry sorry

theorem of_rat_sub {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [comm_ring β] {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x - y) = of_rat x - of_rat y :=
  congr_arg mk (const_sub x y)

protected instance Cauchy.has_inv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] : has_inv Cauchy :=
  has_inv.mk
    fun (x : Cauchy) =>
      quotient.lift_on x
        (fun (f : cau_seq β abv) => mk (dite (lim_zero f) (fun (h : lim_zero f) => 0) fun (h : ¬lim_zero f) => inv f h))
        sorry

@[simp] theorem inv_zero {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] : 0⁻¹ = 0 := sorry

@[simp] theorem inv_mk {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] {f : cau_seq β abv} (hf : ¬lim_zero f) : mk f⁻¹ = mk (inv f hf) := sorry

theorem cau_seq_zero_ne_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] : ¬0 ≈ 1 := sorry

theorem zero_ne_one {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] : 0 ≠ 1 :=
  fun (h : 0 = 1) => cau_seq_zero_ne_one (iff.mp mk_eq h)

protected theorem inv_mul_cancel {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] {x : Cauchy} : x ≠ 0 → x⁻¹ * x = 1 := sorry

def field {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] : field Cauchy :=
  field.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub sorry sorry comm_ring.mul sorry
    comm_ring.one sorry sorry sorry sorry sorry has_inv.inv sorry sorry inv_zero

theorem of_rat_inv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] (x : β) : of_rat (x⁻¹) = (of_rat x⁻¹) := sorry

theorem of_rat_div {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] (x : β) (y : β) : of_rat (x / y) = of_rat x / of_rat y := sorry

end cau_seq.completion

namespace cau_seq

class is_complete {α : Type u_1} [linear_ordered_field α] (β : Type u_2) [ring β] (abv : β → α) [is_absolute_value abv]
where
  is_complete : ∀ (s : cau_seq β abv), ∃ (b : β), s ≈ const abv b

theorem complete {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (s : cau_seq β abv) : ∃ (b : β), s ≈ const abv b :=
  is_complete.is_complete

def lim {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (s : cau_seq β abv) : β :=
  classical.some (complete s)

theorem equiv_lim {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (s : cau_seq β abv) : s ≈ const abv (lim s) :=
  classical.some_spec (complete s)

theorem eq_lim_of_const_equiv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} {x : β} (h : const abv x ≈ f) : x = lim f :=
  iff.mp const_equiv (setoid.trans h (equiv_lim f))

theorem lim_eq_of_equiv_const {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} {x : β} (h : f ≈ const abv x) : lim f = x :=
  Eq.symm (eq_lim_of_const_equiv (setoid.symm h))

theorem lim_eq_lim_of_equiv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} {g : cau_seq β abv} (h : f ≈ g) : lim f = lim g :=
  lim_eq_of_equiv_const (setoid.trans h (equiv_lim g))

@[simp] theorem lim_const {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (x : β) : lim (const abv x) = x :=
  lim_eq_of_equiv_const (setoid.refl (const abv x))

theorem lim_add {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) (g : cau_seq β abv) : lim f + lim g = lim (f + g) := sorry

theorem lim_mul_lim {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) (g : cau_seq β abv) : lim f * lim g = lim (f * g) := sorry

theorem lim_mul {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) (x : β) : lim f * x = lim (f * const abv x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lim f * x = lim (f * const abv x))) (Eq.symm (lim_mul_lim f (const abv x)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (lim f * x = lim f * lim (const abv x))) (lim_const x))) (Eq.refl (lim f * x)))

theorem lim_neg {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) : lim (-f) = -lim f := sorry

theorem lim_eq_zero_iff {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [ring β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] (f : cau_seq β abv) : lim f = 0 ↔ lim_zero f := sorry

theorem lim_inv {α : Type u_1} [linear_ordered_field α] {β : Type u_2} [field β] {abv : β → α} [is_absolute_value abv] [is_complete β abv] {f : cau_seq β abv} (hf : ¬lim_zero f) : lim (inv f hf) = (lim f⁻¹) := sorry

theorem lim_le {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs} {x : α} (h : f ≤ const abs x) : lim f ≤ x :=
  iff.mp const_le (le_of_eq_of_le (setoid.symm (equiv_lim f)) h)

theorem le_lim {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs} {x : α} (h : const abs x ≤ f) : x ≤ lim f :=
  iff.mp const_le (le_of_le_of_eq h (equiv_lim f))

theorem lt_lim {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs} {x : α} (h : const abs x < f) : x < lim f :=
  iff.mp const_lt (lt_of_lt_of_eq h (equiv_lim f))

theorem lim_lt {α : Type u_1} [linear_ordered_field α] [is_complete α abs] {f : cau_seq α abs} {x : α} (h : f < const abs x) : lim f < x :=
  iff.mp const_lt (lt_of_eq_of_lt (setoid.symm (equiv_lim f)) h)


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import category_theory.idempotents.karoubi
import category_theory.additive.basic

/-!

# Biproducts in the idempotent completion of a preadditive category

In this file, we define an instance expressing that if `C` is an additive category,
then `karoubi C` is also an additive category.

We also obtain that for all `P : karoubi C` where `C` is a preadditive category `C`, there
is a canonical isomorphism `P ⊞ P.complement ≅ (to_karoubi C).obj P.X` in the category
`karoubi C` where `P.complement` is the formal direct factor of `P.X` corresponding to
the idempotent endomorphism `𝟙 P.X - P.p`.

-/

noncomputable theory

open category_theory.category
open category_theory.limits
open category_theory.preadditive

universes v

namespace category_theory

namespace idempotents

namespace karoubi

variables {C : Type*} [category.{v} C] [preadditive C]

namespace biproducts

/-- The `bicone` used in order to obtain the existence of
the biproduct of a functor `J ⥤ karoubi C` when the category `C` is additive. -/
@[simps]
def bicone [has_finite_biproducts C] {J : Type v} [decidable_eq J] [fintype J]
  (F : J → karoubi C) : bicone F :=
{ X :=
  { X := biproduct (λ j, (F j).X),
    p := biproduct.map (λ j, (F j).p),
    idem := begin
      ext j,
      simp only [biproduct.ι_map_assoc, biproduct.ι_map],
      slice_lhs 1 2 { rw (F j).idem, },
    end, },
  π := λ j,
    { f := biproduct.map (λ j, (F j).p) ≫ bicone.π _ j,
      comm := by simp only [assoc, biproduct.bicone_π, biproduct.map_π,
        biproduct.map_π_assoc, (F j).idem], },
  ι := λ j,
    { f := (by exact bicone.ι _ j) ≫ biproduct.map (λ j, (F j).p),
      comm := by rw [biproduct.ι_map, ← assoc, ← assoc, (F j).idem,
        assoc, biproduct.ι_map, ← assoc, (F j).idem], },
  ι_π := λ j j', begin
    split_ifs,
    { subst h,
      simp only [biproduct.bicone_ι, biproduct.ι_map, biproduct.bicone_π,
        biproduct.ι_π_self_assoc, comp, category.assoc, eq_to_hom_refl, id_eq,
        biproduct.map_π, (F j).idem], },
    { simpa only [hom_ext, biproduct.ι_π_ne_assoc _ h, assoc,
        biproduct.map_π, biproduct.map_π_assoc, zero_comp, comp], },
  end, }

end biproducts

lemma karoubi_has_finite_biproducts [has_finite_biproducts C] :
  has_finite_biproducts (karoubi C) :=
{ has_biproducts_of_shape := λ J hJ₁ hJ₂,
  { has_biproduct := λ F, begin
      letI := hJ₂,
      apply has_biproduct_of_total (biproducts.bicone F),
      ext1, ext1,
      simp only [id_eq, comp_id, biproducts.bicone_X_p, biproduct.ι_map],
      rw [sum_hom, comp_sum, finset.sum_eq_single j], rotate,
      { intros j' h1 h2,
        simp only [biproduct.ι_map, biproducts.bicone_ι_f, biproducts.bicone_π_f,
          assoc, comp, biproduct.map_π],
        slice_lhs 1 2 { rw biproduct.ι_π, },
        split_ifs,
        { exfalso, exact h2 h.symm, },
        { simp only [zero_comp], } },
      { intro h,
        exfalso,
        simpa only [finset.mem_univ, not_true] using h, },
      { simp only [biproducts.bicone_π_f, comp,
          biproduct.ι_map, assoc, biproducts.bicone_ι_f, biproduct.map_π],
        slice_lhs 1 2 { rw biproduct.ι_π, },
        split_ifs, swap, { exfalso, exact h rfl, },
        simp only [eq_to_hom_refl, id_comp, (F j).idem], },
    end, } }

instance {D : Type*} [category D] [additive_category D] : additive_category (karoubi D) :=
{ to_preadditive := infer_instance,
  to_has_finite_biproducts := karoubi_has_finite_biproducts }

/-- `P.complement` is the formal direct factor of `P.X` given by the idempotent
endomorphism `𝟙 P.X - P.p` -/
@[simps]
def complement (P : karoubi C) : karoubi C :=
{ X := P.X,
  p := 𝟙 _ - P.p,
  idem := idem_of_id_sub_idem P.p P.idem, }

instance (P : karoubi C) : has_binary_biproduct P P.complement :=
has_binary_biproduct_of_total
{ X := P.X,
  fst := P.decomp_id_p,
  snd := P.complement.decomp_id_p,
  inl := P.decomp_id_i,
  inr := P.complement.decomp_id_i,
  inl_fst' := P.decomp_id.symm,
  inl_snd' := begin
    simp only [decomp_id_i_f, decomp_id_p_f, complement_p, comp_sub, comp,
      hom_ext, quiver.hom.add_comm_group_zero_f, P.idem],
    erw [comp_id, sub_self],
  end,
  inr_fst' := begin
    simp only [decomp_id_i_f, complement_p, decomp_id_p_f, sub_comp, comp,
      hom_ext, quiver.hom.add_comm_group_zero_f, P.idem],
    erw [id_comp, sub_self],
  end,
  inr_snd' := P.complement.decomp_id.symm, }
(by simp only [hom_ext, ← decomp_p, quiver.hom.add_comm_group_add_f,
  to_karoubi_map_f, id_eq, coe_p, complement_p, add_sub_cancel'_right])

/-- A formal direct factor `P : karoubi C` of an object `P.X : C` in a
preadditive category is actually a direct factor of the image `(to_karoubi C).obj P.X`
of `P.X` in the category `karoubi C` -/
def decomposition (P : karoubi C) : P ⊞ P.complement ≅ (to_karoubi _).obj P.X :=
{ hom := biprod.desc P.decomp_id_i P.complement.decomp_id_i,
  inv := biprod.lift P.decomp_id_p P.complement.decomp_id_p,
  hom_inv_id' := begin
    ext1,
    { simp only [← assoc, biprod.inl_desc, comp_id, biprod.lift_eq, comp_add,
        ← decomp_id, id_comp, add_right_eq_self],
      convert zero_comp,
      ext,
      simp only [decomp_id_i_f, decomp_id_p_f, complement_p, comp_sub, comp,
        quiver.hom.add_comm_group_zero_f, P.idem],
      erw [comp_id, sub_self], },
    { simp only [← assoc, biprod.inr_desc, biprod.lift_eq, comp_add,
        ← decomp_id, comp_id, id_comp, add_left_eq_self],
      convert zero_comp,
      ext,
      simp only [decomp_id_i_f, decomp_id_p_f, complement_p, sub_comp, comp,
        quiver.hom.add_comm_group_zero_f, P.idem],
      erw [id_comp, sub_self], }
  end,
  inv_hom_id' := begin
    rw biprod.lift_desc,
    simp only [← decomp_p],
    ext,
    dsimp only [complement, to_karoubi],
    simp only [quiver.hom.add_comm_group_add_f, add_sub_cancel'_right, id_eq],
  end, }

end karoubi

end idempotents

end category_theory


variables (f : ℕ → ℕ) (a b : ℕ)

example (h₁ : a = b) (h₂ : f a = 0) : f b = 0 :=
begin
  rw [←h₁, h₂]
end


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

! This file was ported from Lean 3 source module algebra.star.pi
! leanprover-community/mathlib commit 9abfa6f0727d5adc99067e325e15d1a9de17fd8e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Star.Basic
import Mathbin.Algebra.Ring.Pi

/-!
# `star` on pi types

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

We put a `has_star` structure on pi types that operates elementwise, such that it describes the
complex conjugation of vectors.
-/

universe u v w

variable {I : Type u}

-- The indexing type
variable {f : I → Type v}

-- The family of types already equipped with instances
namespace Pi

instance [∀ i, Star (f i)] : Star (∀ i, f i) where unit x i := star (x i)

#print Pi.star_apply /-
@[simp]
theorem star_apply [∀ i, Star (f i)] (x : ∀ i, f i) (i : I) : star x i = star (x i) :=
  rfl
#align pi.star_apply Pi.star_apply
-/

#print Pi.star_def /-
theorem star_def [∀ i, Star (f i)] (x : ∀ i, f i) : star x = fun i => star (x i) :=
  rfl
#align pi.star_def Pi.star_def
-/

instance [∀ i, Star (f i)] [∀ i, TrivialStar (f i)] : TrivialStar (∀ i, f i)
    where star_trivial _ := funext fun _ => star_trivial _

instance [∀ i, InvolutiveStar (f i)] : InvolutiveStar (∀ i, f i)
    where star_involutive _ := funext fun _ => star_star _

instance [∀ i, Semigroup (f i)] [∀ i, StarSemigroup (f i)] : StarSemigroup (∀ i, f i)
    where star_mul _ _ := funext fun _ => star_mul _ _

instance [∀ i, AddMonoid (f i)] [∀ i, StarAddMonoid (f i)] : StarAddMonoid (∀ i, f i)
    where star_add _ _ := funext fun _ => star_add _ _

instance [∀ i, NonUnitalSemiring (f i)] [∀ i, StarRing (f i)] : StarRing (∀ i, f i) :=
  { Pi.starAddMonoid, (Pi.starSemigroup : StarSemigroup (∀ i, f i)) with }

instance {R : Type w} [∀ i, SMul R (f i)] [Star R] [∀ i, Star (f i)] [∀ i, StarModule R (f i)] :
    StarModule R (∀ i, f i) where star_smul r x := funext fun i => star_smul r (x i)

/- warning: pi.single_star -> Pi.single_star is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {f : I -> Type.{u2}} [_inst_1 : forall (i : I), AddMonoid.{u2} (f i)] [_inst_2 : forall (i : I), StarAddMonoid.{u2} (f i) (_inst_1 i)] [_inst_3 : DecidableEq.{succ u1} I] (i : I) (a : f i), Eq.{max (succ u1) (succ u2)} (forall (i : I), f i) (Pi.single.{u1, u2} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_3 a b) (fun (i : I) => AddZeroClass.toHasZero.{u2} (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_1 i))) i (Star.star.{u2} (f i) (InvolutiveStar.toHasStar.{u2} (f i) (StarAddMonoid.toHasInvolutiveStar.{u2} (f i) (_inst_1 i) (_inst_2 i))) a)) (Star.star.{max u1 u2} (forall (i : I), f i) (Pi.hasStar.{u1, u2} I (fun (i : I) => f i) (fun (i : I) => InvolutiveStar.toHasStar.{u2} (f i) (StarAddMonoid.toHasInvolutiveStar.{u2} (f i) (_inst_1 i) (_inst_2 i)))) (Pi.single.{u1, u2} I (fun (i : I) => f i) (fun (a : I) (b : I) => _inst_3 a b) (fun (i : I) => AddZeroClass.toHasZero.{u2} (f i) (AddMonoid.toAddZeroClass.{u2} (f i) (_inst_1 i))) i a))
but is expected to have type
  forall {I : Type.{u1}} {f : I -> Type.{u2}} [_inst_1 : forall (i : I), AddMonoid.{u2} (f i)] [_inst_2 : forall (i : I), StarAddMonoid.{u2} (f i) (_inst_1 i)] [_inst_3 : DecidableEq.{succ u1} I] (i : I) (a : f i), Eq.{max (succ u1) (succ u2)} (forall (i : I), f i) (Pi.single.{u1, u2} I f (fun (a : I) (b : I) => _inst_3 a b) (fun (i : I) => AddMonoid.toZero.{u2} (f i) (_inst_1 i)) i (Star.star.{u2} (f i) (InvolutiveStar.toStar.{u2} (f i) (StarAddMonoid.toInvolutiveStar.{u2} (f i) (_inst_1 i) (_inst_2 i))) a)) (Star.star.{max u2 u1} (forall (i : I), f i) (Pi.instStarForAll.{u1, u2} I (fun (i : I) => f i) (fun (i : I) => InvolutiveStar.toStar.{u2} (f i) (StarAddMonoid.toInvolutiveStar.{u2} (f i) (_inst_1 i) (_inst_2 i)))) (Pi.single.{u1, u2} I f (fun (a : I) (b : I) => _inst_3 a b) (fun (i : I) => AddMonoid.toZero.{u2} (f i) (_inst_1 i)) i a))
Case conversion may be inaccurate. Consider using '#align pi.single_star Pi.single_starₓ'. -/
theorem single_star [∀ i, AddMonoid (f i)] [∀ i, StarAddMonoid (f i)] [DecidableEq I] (i : I)
    (a : f i) : Pi.single i (star a) = star (Pi.single i a) :=
  single_op (fun i => @star (f i) _) (fun i => star_zero _) i a
#align pi.single_star Pi.single_star

end Pi

namespace Function

#print Function.update_star /-
theorem update_star [∀ i, Star (f i)] [DecidableEq I] (h : ∀ i : I, f i) (i : I) (a : f i) :
    Function.update (star h) i (star a) = star (Function.update h i a) :=
  funext fun j => (apply_update (fun i => star) h i a j).symm
#align function.update_star Function.update_star
-/

/- warning: function.star_sum_elim -> Function.star_sum_elim is a dubious translation:
lean 3 declaration is
  forall {I : Type.{u1}} {J : Type.{u2}} {α : Type.{u3}} (x : I -> α) (y : J -> α) [_inst_1 : Star.{u3} α], Eq.{succ (max (max u1 u2) u3)} ((Sum.{u1, u2} I J) -> α) (Star.star.{max (max u1 u2) u3} ((Sum.{u1, u2} I J) -> α) (Pi.hasStar.{max u1 u2, u3} (Sum.{u1, u2} I J) (fun (ᾰ : Sum.{u1, u2} I J) => α) (fun (i : Sum.{u1, u2} I J) => _inst_1)) (Sum.elim.{u1, u2, succ u3} I J α x y)) (Sum.elim.{u1, u2, succ u3} I J α (Star.star.{max u1 u3} (I -> α) (Pi.hasStar.{u1, u3} I (fun (ᾰ : I) => α) (fun (i : I) => _inst_1)) x) (Star.star.{max u2 u3} (J -> α) (Pi.hasStar.{u2, u3} J (fun (ᾰ : J) => α) (fun (i : J) => _inst_1)) y))
but is expected to have type
  forall {I : Type.{u3}} {J : Type.{u2}} {α : Type.{u1}} (x : I -> α) (y : J -> α) [_inst_1 : Star.{u1} α], Eq.{max (max (succ u3) (succ u2)) (succ u1)} ((Sum.{u3, u2} I J) -> α) (Star.star.{max (max u3 u2) u1} ((Sum.{u3, u2} I J) -> α) (Pi.instStarForAll.{max u3 u2, u1} (Sum.{u3, u2} I J) (fun (ᾰ : Sum.{u3, u2} I J) => α) (fun (i : Sum.{u3, u2} I J) => _inst_1)) (Sum.elim.{u3, u2, succ u1} I J α x y)) (Sum.elim.{u3, u2, succ u1} I J α (Star.star.{max u3 u1} (I -> α) (Pi.instStarForAll.{u3, u1} I (fun (ᾰ : I) => α) (fun (i : I) => _inst_1)) x) (Star.star.{max u1 u2} (J -> α) (Pi.instStarForAll.{u2, u1} J (fun (ᾰ : J) => α) (fun (i : J) => _inst_1)) y))
Case conversion may be inaccurate. Consider using '#align function.star_sum_elim Function.star_sum_elimₓ'. -/
theorem star_sum_elim {I J α : Type _} (x : I → α) (y : J → α) [Star α] :
    star (Sum.elim x y) = Sum.elim (star x) (star y) :=
  by
  ext x
  cases x <;> simp
#align function.star_sum_elim Function.star_sum_elim

end Function


/-
Copyright © 2022 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri, Sébastien Gouëzel, Heather Macbeth, Floris van Doorn
-/
import topology.fiber_bundle.constructions
import topology.vector_bundle.basic

/-!
# Standard constructions on vector bundles

This file contains several standard constructions on vector bundles:

* `bundle.trivial.vector_bundle 𝕜 B F`: the trivial vector bundle with scalar field `𝕜` and model
  fiber `F` over the base `B`

* `vector_bundle.prod`: for vector bundles `E₁` and `E₂` with scalar field `𝕜` over a common base,
  a vector bundle structure on their direct sum `E₁ ×ᵇ E₂` (the notation stands for
  `λ x, E₁ x × E₂ x`).

* `vector_bundle.pullback`: for a vector bundle `E` over `B`, a vector bundle structure on its
  pullback `f *ᵖ E` by a map `f : B' → B` (the notation is a type synonym for `E ∘ f`).

## Tags
Vector bundle, direct sum, pullback
-/

noncomputable theory

open bundle set fiber_bundle
open_locale classical bundle

/-! ### The trivial vector bundle -/

namespace bundle.trivial
variables (𝕜 : Type*) (B : Type*) (F : Type*)
  [nontrivially_normed_field 𝕜] [normed_add_comm_group F] [normed_space 𝕜 F] [topological_space B]

instance trivialization.is_linear : (trivialization B F).is_linear 𝕜 :=
{ linear := λ x hx, ⟨λ y z, rfl, λ c y, rfl⟩ }

variables {𝕜}

lemma trivialization.coord_changeL (b : B) :
  (trivialization B F).coord_changeL 𝕜 (trivialization B F) b = continuous_linear_equiv.refl 𝕜 F :=
begin
  ext v,
  rw [trivialization.coord_changeL_apply'],
  exacts [rfl, ⟨mem_univ _, mem_univ _⟩]
end

variables (𝕜)

instance vector_bundle : vector_bundle 𝕜 F (bundle.trivial B F) :=
{ trivialization_linear' := begin
    introsI e he,
    rw eq_trivialization B F e,
    apply_instance
  end,
  continuous_on_coord_change' := begin
    introsI e e' he he',
    unfreezingI { obtain rfl := eq_trivialization B F e },
    unfreezingI { obtain rfl := eq_trivialization B F e' },
    simp_rw trivialization.coord_changeL,
    exact continuous_const.continuous_on
  end }

end bundle.trivial

/-! ### Direct sum of two vector bundles -/

section
variables (𝕜 : Type*) {B : Type*} [nontrivially_normed_field 𝕜] [topological_space B]
  (F₁ : Type*) [normed_add_comm_group F₁] [normed_space 𝕜 F₁]
  (E₁ : B → Type*) [topological_space (total_space E₁)]
  (F₂ : Type*) [normed_add_comm_group F₂] [normed_space 𝕜 F₂]
  (E₂ : B → Type*) [topological_space (total_space E₂)]

namespace trivialization
variables {F₁ E₁ F₂ E₂}
  [Π x, add_comm_monoid (E₁ x)] [Π x, module 𝕜 (E₁ x)]
  [Π x, add_comm_monoid (E₂ x)] [Π x, module 𝕜 (E₂ x)]
  (e₁ e₁' : trivialization F₁ (π E₁)) (e₂ e₂' : trivialization F₂ (π E₂))

instance prod.is_linear [e₁.is_linear 𝕜] [e₂.is_linear 𝕜] : (e₁.prod e₂).is_linear 𝕜 :=
{ linear := λ x ⟨h₁, h₂⟩, (((e₁.linear 𝕜 h₁).mk' _).prod_map ((e₂.linear 𝕜 h₂).mk' _)).is_linear }

@[simp]
lemma coord_changeL_prod [e₁.is_linear 𝕜] [e₁'.is_linear 𝕜] [e₂.is_linear 𝕜] [e₂'.is_linear 𝕜] ⦃b⦄
  (hb : b ∈ ((e₁.prod e₂).base_set ∩ (e₁'.prod e₂').base_set)) :
  ((e₁.prod e₂).coord_changeL 𝕜 (e₁'.prod e₂') b : F₁ × F₂ →L[𝕜] F₁ × F₂) =
  (e₁.coord_changeL 𝕜 e₁' b : F₁ →L[𝕜] F₁).prod_map (e₂.coord_changeL 𝕜 e₂' b) :=
begin
  rw [continuous_linear_map.ext_iff, continuous_linear_map.coe_prod_map'],
  rintro ⟨v₁, v₂⟩,
  show (e₁.prod e₂).coord_changeL 𝕜 (e₁'.prod e₂') b (v₁, v₂) =
    (e₁.coord_changeL 𝕜 e₁' b v₁, e₂.coord_changeL 𝕜 e₂' b v₂),
  rw [e₁.coord_changeL_apply e₁', e₂.coord_changeL_apply e₂', (e₁.prod e₂).coord_changeL_apply'],
  exacts [rfl, hb, ⟨hb.1.2, hb.2.2⟩, ⟨hb.1.1, hb.2.1⟩]
end

variables {e₁ e₂} [Π x : B, topological_space (E₁ x)] [Π x : B, topological_space (E₂ x)]
  [fiber_bundle F₁ E₁] [fiber_bundle F₂ E₂]

lemma prod_apply [e₁.is_linear 𝕜] [e₂.is_linear 𝕜] {x : B} (hx₁ : x ∈ e₁.base_set)
  (hx₂ : x ∈ e₂.base_set) (v₁ : E₁ x) (v₂ : E₂ x) :
  prod e₁ e₂ ⟨x, (v₁, v₂)⟩
  = ⟨x, e₁.continuous_linear_equiv_at 𝕜 x hx₁ v₁, e₂.continuous_linear_equiv_at 𝕜 x hx₂ v₂⟩ :=
rfl

end trivialization

open trivialization

variables [Π x, add_comm_monoid (E₁ x)] [Π x, module 𝕜 (E₁ x)]
  [Π x, add_comm_monoid (E₂ x)] [Π x, module 𝕜 (E₂ x)]
  [Π x : B, topological_space (E₁ x)] [Π x : B, topological_space (E₂ x)]
  [fiber_bundle F₁ E₁] [fiber_bundle F₂ E₂]

/-- The product of two vector bundles is a vector bundle. -/
instance vector_bundle.prod  [vector_bundle 𝕜 F₁ E₁] [vector_bundle 𝕜 F₂ E₂] :
  vector_bundle 𝕜 (F₁ × F₂) (E₁ ×ᵇ E₂) :=
{ trivialization_linear' := begin
    rintros _ ⟨e₁, e₂, he₁, he₂, rfl⟩, resetI,
    apply_instance
  end,
  continuous_on_coord_change' := begin
    rintros _ _ ⟨e₁, e₂, he₁, he₂, rfl⟩ ⟨e₁', e₂', he₁', he₂', rfl⟩, resetI,
    refine (((continuous_on_coord_change 𝕜 e₁ e₁').mono _).prod_mapL 𝕜
      ((continuous_on_coord_change 𝕜 e₂ e₂').mono _)).congr _;
    dsimp only [base_set_prod] with mfld_simps,
    { mfld_set_tac },
    { mfld_set_tac },
    { rintro b hb,
      rw [continuous_linear_map.ext_iff],
      rintro ⟨v₁, v₂⟩,
      show (e₁.prod e₂).coord_changeL 𝕜 (e₁'.prod e₂') b (v₁, v₂) =
        (e₁.coord_changeL 𝕜 e₁' b v₁, e₂.coord_changeL 𝕜 e₂' b v₂),
      rw [e₁.coord_changeL_apply e₁', e₂.coord_changeL_apply e₂',
        (e₁.prod e₂).coord_changeL_apply'],
      exacts [rfl, hb, ⟨hb.1.2, hb.2.2⟩, ⟨hb.1.1, hb.2.1⟩] }
  end }

variables {𝕜 F₁ E₁ F₂ E₂}

@[simp] lemma trivialization.continuous_linear_equiv_at_prod {e₁ : trivialization F₁ (π E₁)}
  {e₂ : trivialization F₂ (π E₂)} [e₁.is_linear 𝕜] [e₂.is_linear 𝕜] {x : B} (hx₁ : x ∈ e₁.base_set)
  (hx₂ : x ∈ e₂.base_set) :
  (e₁.prod e₂).continuous_linear_equiv_at 𝕜 x ⟨hx₁, hx₂⟩
  = (e₁.continuous_linear_equiv_at 𝕜 x hx₁).prod (e₂.continuous_linear_equiv_at 𝕜 x hx₂) :=
begin
  ext1,
  funext v,
  obtain ⟨v₁, v₂⟩ := v,
  rw [(e₁.prod e₂).continuous_linear_equiv_at_apply 𝕜, trivialization.prod],
  exact (congr_arg prod.snd (prod_apply 𝕜 hx₁ hx₂ v₁ v₂) : _)
end

end

/-! ### Pullbacks of vector bundles -/

section
variables (R 𝕜 : Type*) {B : Type*} (F : Type*) (E : B → Type*) {B' : Type*} (f : B' → B)

instance [∀ (x : B), add_comm_monoid (E x)] : ∀ (x : B'), add_comm_monoid ((f *ᵖ E) x) :=
by delta_instance bundle.pullback
instance [semiring R] [∀ (x : B), add_comm_monoid (E x)] [∀ x, module R (E x)] :
  ∀ (x : B'), module R ((f *ᵖ E) x) :=
by delta_instance bundle.pullback

variables {E F} [topological_space B'] [topological_space (total_space E)]
  [nontrivially_normed_field 𝕜] [normed_add_comm_group F] [normed_space 𝕜 F] [topological_space B]
  [∀ x, add_comm_monoid (E x)] [∀ x, module 𝕜 (E x)]
  {K : Type*} [continuous_map_class K B' B]

instance trivialization.pullback_linear (e : trivialization F (π E)) [e.is_linear 𝕜] (f : K) :
  (@trivialization.pullback _ _ _ B' _ _ _ _ _ _ _ e f).is_linear 𝕜 :=
{ linear := λ x h, e.linear 𝕜 h }

instance vector_bundle.pullback [∀ x, topological_space (E x)]
  [fiber_bundle F E] [vector_bundle 𝕜 F E] (f : K) : vector_bundle 𝕜 F ((f : B' → B) *ᵖ E) :=
{ trivialization_linear' := begin
    rintro _ ⟨e, he, rfl⟩, resetI,
    apply_instance,
  end,
  continuous_on_coord_change' := begin
    rintro _ _ ⟨e, he, rfl⟩ ⟨e', he', rfl⟩, resetI,
    refine ((continuous_on_coord_change 𝕜 e e').comp (map_continuous f).continuous_on
      (λ b hb, hb)).congr _,
    rintro b (hb : f b ∈ e.base_set ∩ e'.base_set), ext v,
    show ((e.pullback f).coord_changeL 𝕜 (e'.pullback f) b) v = (e.coord_changeL 𝕜 e' (f b)) v,
    rw [e.coord_changeL_apply e' hb, (e.pullback f).coord_changeL_apply' _],
    exacts [rfl, hb]
  end }

end


/-
Copyright (c) 2022 Chris Birkbeck. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Birkbeck
-/
import analysis.complex.upper_half_plane.basic
import linear_algebra.matrix.general_linear_group
import linear_algebra.matrix.special_linear_group
/-!
# Slash actions

This file defines a class of slash actions, which are families of right actions of a given group
parametrized by some Type. This is modeled on the slash action of `GL_pos (fin 2) ℝ` on the space
of modular forms.
-/

open complex upper_half_plane

open_locale upper_half_plane

local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _

-- like `↑ₘ`, but allows the user to specify the ring `R`. Useful to help Lean elaborate.
local notation `↑ₘ[` R `]` := @coe _ (matrix (fin 2) (fin 2) R) _

local notation `GL(` n `, ` R `)`⁺ := matrix.GL_pos (fin n) R

local notation `SL(` n `, ` R `)` := matrix.special_linear_group (fin n) R

/--A general version of the slash action of the space of modular forms.-/
class slash_action (β G α γ : Type*) [group G] [has_zero α] [has_smul γ α] [has_add α] :=
(map : β → G → α → α)
(zero_slash : ∀ (k : β) (g : G), map k g 0 = 0)
(slash_one : ∀ (k : β) (a : α) , map k 1 a = a)
(right_action : ∀ (k : β) (g h : G) (a : α), map k h (map k g a) = map k (g * h) a )
(smul_action : ∀ (k : β) (g : G) (a : α) (z : γ), map k g (z • a) = z • (map k g a))
(add_action : ∀ (k : β) (g : G) (a b : α), map k g (a + b) = map k g a + map k g b)

/--Slash_action induced by a monoid homomorphism.-/
def monoid_hom_slash_action {β G H α γ : Type*} [group G] [has_zero α] [has_smul γ α] [has_add α]
  [group H] [slash_action β G α γ] (h : H →* G) : slash_action β H α γ :=
{ map := λ k g, slash_action.map γ k (h g),
  zero_slash := λ k g, slash_action.zero_slash k (h g),
  slash_one := λ k a, by simp only [map_one, slash_action.slash_one],
  right_action := λ k g gg a, by simp only [map_mul, slash_action.right_action],
  smul_action := λ _ _, slash_action.smul_action _ _,
  add_action := λ _ g _ _, slash_action.add_action _ (h g) _ _,}

namespace modular_form

noncomputable theory

/--The weight `k` action of `GL(2, ℝ)⁺` on functions `f : ℍ → ℂ`. -/
def slash (k : ℤ) (γ : GL(2, ℝ)⁺) (f : ℍ → ℂ) (x : ℍ) : ℂ :=
f (γ • x) * (((↑ₘ γ).det) : ℝ)^(k-1) * (upper_half_plane.denom γ x)^(-k)

variables {Γ : subgroup SL(2, ℤ)} {k: ℤ} (f : ℍ → ℂ)

localized "notation (name := modular_form.slash) f ` ∣[`:100 k `]`:0 γ :100 :=
  modular_form.slash k γ f" in modular_form

lemma slash_right_action (k : ℤ) (A B : GL(2, ℝ)⁺) (f : ℍ → ℂ) :
  (f ∣[k] A) ∣[k] B = f ∣[k] (A * B) :=
begin
  ext1,
  simp_rw [slash,(upper_half_plane.denom_cocycle A B x)],
  have e3 : (A * B) • x = A • B • x , by { convert (upper_half_plane.mul_smul' A B x), } ,
  rw e3,
  simp only [upper_half_plane.num, upper_half_plane.denom, of_real_mul, subgroup.coe_mul, coe_coe,
    upper_half_plane.coe_smul, units.coe_mul, matrix.mul_eq_mul, matrix.det_mul,
    upper_half_plane.smul_aux, upper_half_plane.smul_aux', subtype.coe_mk] at *,
  field_simp,
  have : (((↑(↑A : GL (fin 2) ℝ) : (matrix (fin 2) (fin 2) ℝ)).det : ℂ) *
    ((↑(↑B : GL (fin 2) ℝ) : (matrix (fin 2) (fin 2) ℝ)).det : ℂ))^(k-1) =
    ((↑(↑A : GL (fin 2) ℝ) : (matrix (fin 2) (fin 2) ℝ)).det : ℂ)^(k-1) *
    ((↑(↑B : GL (fin 2) ℝ) : (matrix (fin 2) (fin 2) ℝ)).det : ℂ)^(k-1) ,
    by {simp_rw [←mul_zpow]},
  simp_rw [this, ← mul_assoc, ←mul_zpow],
end

@[simp] lemma slash_add (k : ℤ) (A : GL(2, ℝ)⁺) (f g : ℍ → ℂ) :
  (f + g) ∣[k] A = (f ∣[k] A) + (g ∣[k] A) :=
begin
  ext1,
  simp only [slash, pi.add_apply, denom, coe_coe, zpow_neg],
  ring,
end

@[simp] lemma slash_one (k : ℤ) (f : ℍ → ℂ) : (f ∣[k] 1) = f :=
funext $ by simp [slash]

variables {α : Type*} [has_smul α ℂ] [is_scalar_tower α ℂ ℂ]

@[simp] lemma smul_slash (k : ℤ) (A : GL(2, ℝ)⁺) (f : ℍ → ℂ) (c : α) :
  (c • f) ∣[k] A = c • (f ∣[k] A) :=
begin
  simp_rw [←smul_one_smul ℂ c f, ←smul_one_smul ℂ c (f ∣[k] A)],
  ext1,
  simp_rw slash,
  simp only [slash, algebra.id.smul_eq_mul, matrix.general_linear_group.coe_det_apply,
    pi.smul_apply, subtype.val_eq_coe, coe_coe],
  ring,
end

@[simp] lemma neg_slash (k : ℤ) (A : GL(2, ℝ)⁺) (f : ℍ → ℂ) : (-f) ∣[k] A = - (f ∣[k] A) :=
funext $ by simp [slash]

@[simp] lemma zero_slash (k : ℤ) (A : GL(2, ℝ)⁺) : (0 : ℍ → ℂ) ∣[k] A = 0 :=
funext $ λ _, by simp only [slash, pi.zero_apply, zero_mul]

instance : slash_action ℤ GL(2, ℝ)⁺ (ℍ → ℂ) ℂ :=
{ map := slash,
  zero_slash := zero_slash,
  slash_one := slash_one,
  right_action := slash_right_action,
  smul_action := smul_slash,
  add_action := slash_add }

instance subgroup_action (Γ : subgroup SL(2, ℤ)) : slash_action ℤ Γ (ℍ → ℂ) ℂ :=
monoid_hom_slash_action (monoid_hom.comp (matrix.special_linear_group.to_GL_pos)
  (monoid_hom.comp (matrix.special_linear_group.map (int.cast_ring_hom ℝ)) (subgroup.subtype Γ)))

@[simp] lemma subgroup_slash (Γ : subgroup SL(2, ℤ)) (γ : Γ):
  (slash_action.map ℂ k γ f) = slash k (γ : GL(2,ℝ)⁺) f := rfl

instance SL_action : slash_action ℤ SL(2, ℤ) (ℍ → ℂ) ℂ :=
monoid_hom_slash_action (monoid_hom.comp (matrix.special_linear_group.to_GL_pos)
  (matrix.special_linear_group.map (int.cast_ring_hom ℝ)))

@[simp] lemma SL_slash (γ : SL(2, ℤ)):
  (slash_action.map ℂ k γ f) = slash k (γ : GL(2,ℝ)⁺) f := rfl

local notation f `∣[`:73 k:0, A `]` :72 := slash_action.map ℂ k A f

/-- The constant function 1 is invariant under any element of `SL(2, ℤ)`. -/
@[simp] lemma is_invariant_one (A : SL(2, ℤ)) : (1 : ℍ → ℂ) ∣[(0 : ℤ), A] = (1 : ℍ → ℂ) :=
begin
  have : (((↑ₘ(A : GL(2,ℝ)⁺)).det) : ℝ) = 1,
  { simp only [coe_coe,
      matrix.special_linear_group.coe_GL_pos_coe_GL_coe_matrix,
      matrix.special_linear_group.det_coe], },
  funext,
  rw [SL_slash, slash, zero_sub, this],
  simp,
end

/-- A function `f : ℍ → ℂ` is `slash_invariant`, of weight `k ∈ ℤ` and level `Γ`,
  if for every matrix `γ ∈ Γ` we have `f(γ • z)= (c*z+d)^k f(z)` where `γ= ![![a, b], ![c, d]]`,
  and it acts on `ℍ` via Möbius transformations. -/
lemma slash_action_eq'_iff (k : ℤ) (Γ : subgroup SL(2, ℤ)) (f : ℍ → ℂ) (γ : Γ)  (z : ℍ) :
  f ∣[k, γ] z = f z ↔ f (γ • z) = ((↑ₘ[ℤ]γ 1 0 : ℂ) * z + (↑ₘ[ℤ]γ 1 1 : ℂ))^k * f z :=
begin
  simp only [subgroup_slash, modular_form.slash],
  convert inv_mul_eq_iff_eq_mul₀ _ using 2,
  { rw mul_comm,
    simp only [denom, coe_coe, matrix.special_linear_group.coe_GL_pos_coe_GL_coe_matrix, zpow_neg,
      matrix.special_linear_group.det_coe, of_real_one, one_zpow, mul_one, subgroup_to_sl_moeb,
      sl_moeb],
    refl, },
  { convert zpow_ne_zero k (denom_ne_zero γ z) },
end

lemma mul_slash (k1 k2 : ℤ) (A : GL(2, ℝ)⁺) (f g : ℍ → ℂ) :
  (f * g) ∣[k1 + k2, A] = (((↑ₘ A).det) : ℝ) • (f ∣[k1, A]) * (g ∣[k2, A]) :=
begin
  ext1,
  simp only [slash_action.map, slash, matrix.general_linear_group.coe_det_apply, subtype.val_eq_coe,
    pi.mul_apply, pi.smul_apply, algebra.smul_mul_assoc, real_smul],
  set d : ℂ := ↑((↑ₘ A).det : ℝ),
  have h1 : d ^ (k1 + k2 - 1) = d * d ^ (k1 - 1) * d ^ (k2 - 1),
  { have : d ≠ 0,
    { dsimp [d],
      norm_cast,
      exact matrix.GL_pos.det_ne_zero A },
    rw [← zpow_one_add₀ this, ← zpow_add₀ this],
    ring_exp },
  have h22 : denom A x ^ (- (k1 + k2)) = denom A x ^ (- k1) * denom A x ^ (- k2),
  { rw [int.neg_add, zpow_add₀],
    exact upper_half_plane.denom_ne_zero A x, },
  rw [h1, h22],
  ring,
end

@[simp] lemma mul_slash_SL2 (k1 k2 : ℤ) (A : SL(2, ℤ)) (f g : ℍ → ℂ) :
  (f * g) ∣[k1 + k2, A] = (f ∣[k1, A]) * (g ∣[k2, A]) :=
calc (f * g) ∣[k1 + k2, (A : GL(2, ℝ)⁺)] = _ • (f ∣[k1, A]) * (g ∣[k2, A]) : mul_slash _ _ _ _ _
... = (1:ℝ) • (f ∣[k1, A]) * (g ∣[k2, A]) : by simp [-matrix.special_linear_group.coe_matrix_coe]
... = (f ∣[k1, A]) * (g ∣[k2, A]) : by simp

lemma mul_slash_subgroup (k1 k2 : ℤ) (Γ : subgroup SL(2, ℤ)) (A : Γ) (f g : ℍ → ℂ) :
  (f * g) ∣[k1 + k2, A] = (f ∣[k1, A]) * (g ∣[k2, A]) :=
mul_slash_SL2 k1 k2 A f g

end modular_form


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

! This file was ported from Lean 3 source module algebra.group_with_zero.defs
! leanprover-community/mathlib commit 2f3994e1b117b1e1da49bcfb67334f33460c3ce4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Group.Defs
import Mathlib.Logic.Nontrivial
import Mathlib.Algebra.NeZero

/-!
# Typeclasses for groups with an adjoined zero element

This file provides just the typeclass definitions, and the projection lemmas that expose their
members.

## Main definitions

* `GroupWithZero`
* `CommGroupWithZero`
-/

universe u

-- We have to fix the universe of `G₀` here, since the default argument to
-- `GroupWithZero.div'` cannot contain a universe metavariable.
variable {G₀ : Type u} {M₀ M₀' G₀' : Type _}

-- Porting note:
-- This theorem was introduced during ad-hoc porting
-- and hopefully can be removed again after `Mathlib.Algebra.Ring.Basic` is fully ported.
theorem eq_of_sub_eq_zero' [AddGroup R] {a b : R} (h : a - b = 0) : a = b :=
  add_right_cancel <| show a + (-b) = b + (-b) by rw [← sub_eq_add_neg, h, add_neg_self]

-- Porting note:
-- This theorem was introduced during ad-hoc porting
-- and hopefully can be removed again after `Mathlib.Algebra.Ring.Basic` is fully ported.
theorem pow_succ'' [Monoid M] : ∀ (n : ℕ) (a : M), a ^ n.succ = a * a ^ n :=
Monoid.npow_succ

/-- Typeclass for expressing that a type `M₀` with multiplication and a zero satisfies
`0 * a = 0` and `a * 0 = 0` for all `a : M₀`. -/
class MulZeroClass (M₀ : Type u) extends Mul M₀, Zero M₀ where
  /-- Zero is a left absorbing element for multiplication -/
  zero_mul : ∀ a : M₀, 0 * a = 0
  /-- Zero is a right absorbing element for multiplication -/
  mul_zero : ∀ a : M₀, a * 0 = 0
#align mul_zero_class MulZeroClass

/-- A mixin for left cancellative multiplication by nonzero elements. -/
class IsLeftCancelMulZero (M₀ : Type u) [Mul M₀] [Zero M₀] : Prop where
  /-- Multiplicatin by a nonzero element is left cancellative. -/
  protected mul_left_cancel_of_ne_zero : ∀ {a b c : M₀}, a ≠ 0 → a * b = a * c → b = c
#align is_left_cancel_mul_zero IsLeftCancelMulZero

section IsLeftCancelMulZero

variable [Mul M₀] [Zero M₀] [IsLeftCancelMulZero M₀] {a b c : M₀}

theorem mul_left_cancel₀ (ha : a ≠ 0) (h : a * b = a * c) : b = c :=
  IsLeftCancelMulZero.mul_left_cancel_of_ne_zero ha h
#align mul_left_cancel₀ mul_left_cancel₀

theorem mul_right_injective₀ (ha : a ≠ 0) : Function.Injective ((· * ·) a) :=
  fun _ _ => mul_left_cancel₀ ha
#align mul_right_injective₀ mul_right_injective₀

end IsLeftCancelMulZero

/-- A mixin for right cancellative multiplication by nonzero elements. -/
class IsRightCancelMulZero (M₀ : Type u) [Mul M₀] [Zero M₀] : Prop where
  /-- Multiplicatin by a nonzero element is right cancellative. -/
  protected mul_right_cancel_of_ne_zero : ∀ {a b c : M₀}, b ≠ 0 → a * b = c * b → a = c
#align is_right_cancel_mul_zero IsRightCancelMulZero

section IsRightCancelMulZero

variable [Mul M₀] [Zero M₀] [IsRightCancelMulZero M₀] {a b c : M₀}

theorem mul_right_cancel₀ (hb : b ≠ 0) (h : a * b = c * b) : a = c :=
  IsRightCancelMulZero.mul_right_cancel_of_ne_zero hb h
#align mul_right_cancel₀ mul_right_cancel₀

theorem mul_left_injective₀ (hb : b ≠ 0) : Function.Injective fun a => a * b :=
  fun _ _ => mul_right_cancel₀ hb
#align mul_left_injective₀ mul_left_injective₀

end IsRightCancelMulZero

/-- A mixin for cancellative multiplication by nonzero elements. -/
class IsCancelMulZero (M₀ : Type u) [Mul M₀] [Zero M₀]
  extends IsLeftCancelMulZero M₀, IsRightCancelMulZero M₀ : Prop
#align is_cancel_mul_zero IsCancelMulZero

export MulZeroClass (zero_mul mul_zero)
attribute [simp] zero_mul mul_zero
#align zero_mul MulZeroClass.zero_mul
#align mul_zero MulZeroClass.mul_zero

/-- Predicate typeclass for expressing that `a * b = 0` implies `a = 0` or `b = 0`
for all `a` and `b` of type `G₀`. -/
class NoZeroDivisors (M₀ : Type _) [Mul M₀] [Zero M₀] : Prop where
  /-- For all `a` and `b` of `G₀`, `a * b = 0` implies `a = 0` or `b = 0`. -/
  eq_zero_or_eq_zero_of_mul_eq_zero : ∀ {a b : M₀}, a * b = 0 → a = 0 ∨ b = 0
#align no_zero_divisors NoZeroDivisors

export NoZeroDivisors (eq_zero_or_eq_zero_of_mul_eq_zero)
/-- A type `S₀` is a "semigroup with zero” if it is a semigroup with zero element, and `0` is left
and right absorbing. -/
class SemigroupWithZero (S₀ : Type u) extends Semigroup S₀, MulZeroClass S₀
#align semigroup_with_zero SemigroupWithZero

/-- A typeclass for non-associative monoids with zero elements. -/
class MulZeroOneClass (M₀ : Type u) extends MulOneClass M₀, MulZeroClass M₀
#align mul_zero_one_class MulZeroOneClass

/-- A type `M₀` is a “monoid with zero” if it is a monoid with zero element, and `0` is left
and right absorbing. -/
class MonoidWithZero (M₀ : Type u) extends Monoid M₀, MulZeroOneClass M₀, SemigroupWithZero M₀
#align monoid_with_zero MonoidWithZero

/-- A type `M` is a `CancelMonoidWithZero` if it is a monoid with zero element, `0` is left
and right absorbing, and left/right multiplication by a non-zero element is injective. -/
class CancelMonoidWithZero (M₀ : Type _) extends MonoidWithZero M₀, IsCancelMulZero M₀
#align cancel_monoid_with_zero CancelMonoidWithZero

/-- A type `M` is a commutative “monoid with zero” if it is a commutative monoid with zero
element, and `0` is left and right absorbing. -/
class CommMonoidWithZero (M₀ : Type _) extends CommMonoid M₀, MonoidWithZero M₀
#align comm_monoid_with_zero CommMonoidWithZero

section CommSemigroup

variable [CommSemigroup M₀] [Zero M₀]

lemma IsLeftCancelMulZero.to_isRightCancelMulZero [IsLeftCancelMulZero M₀] :
    IsRightCancelMulZero M₀ :=
{ mul_right_cancel_of_ne_zero :=
    fun hb h => mul_left_cancel₀ hb <| (mul_comm _ _).trans (h.trans (mul_comm _ _)) }
#align is_left_cancel_mul_zero.to_is_right_cancel_mul_zero IsLeftCancelMulZero.to_isRightCancelMulZero

lemma IsRightCancelMulZero.to_isLeftCancelMulZero [IsRightCancelMulZero M₀] :
    IsLeftCancelMulZero M₀ :=
{ mul_left_cancel_of_ne_zero :=
    fun hb h => mul_right_cancel₀ hb <| (mul_comm _ _).trans (h.trans (mul_comm _ _)) }
#align is_right_cancel_mul_zero.to_is_left_cancel_mul_zero IsRightCancelMulZero.to_isLeftCancelMulZero

lemma IsLeftCancelMulZero.to_isCancelMulZero [IsLeftCancelMulZero M₀] :
    IsCancelMulZero M₀ :=
{ IsLeftCancelMulZero.to_isRightCancelMulZero with }
#align is_left_cancel_mul_zero.to_is_cancel_mul_zero IsLeftCancelMulZero.to_isCancelMulZero

lemma IsRightCancelMulZero.to_isCancelMulZero [IsRightCancelMulZero M₀] :
    IsCancelMulZero M₀ :=
{ IsRightCancelMulZero.to_isLeftCancelMulZero with }
#align is_right_cancel_mul_zero.to_is_cancel_mul_zero IsRightCancelMulZero.to_isCancelMulZero

end CommSemigroup

/-- A type `M` is a `CancelCommMonoidWithZero` if it is a commutative monoid with zero element,
 `0` is left and right absorbing,
  and left/right multiplication by a non-zero element is injective. -/
class CancelCommMonoidWithZero (M₀ : Type _) extends CommMonoidWithZero M₀, IsLeftCancelMulZero M₀
#align cancel_comm_monoid_with_zero CancelCommMonoidWithZero

instance (priority := 100) CancelCommMonoidWithZero.toCancelMonoidWithZero
    [CancelCommMonoidWithZero M₀] : CancelMonoidWithZero M₀ :=
{ IsLeftCancelMulZero.to_isCancelMulZero (M₀ := M₀) with }

/-- A type `G₀` is a “group with zero” if it is a monoid with zero element (distinct from `1`)
such that every nonzero element is invertible.
The type is required to come with an “inverse” function, and the inverse of `0` must be `0`.

Examples include division rings and the ordered monoids that are the
target of valuations in general valuation theory.-/
class GroupWithZero (G₀ : Type u) extends MonoidWithZero G₀, DivInvMonoid G₀, Nontrivial G₀ where
  /-- The inverse of `0` in a group with zero is `0`. -/
  inv_zero : (0 : G₀)⁻¹ = 0
  /-- Every nonzero element of a group with zero is invertible. -/
  mul_inv_cancel (a : G₀) : a ≠ 0 → a * a⁻¹ = 1
#align group_with_zero GroupWithZero

export GroupWithZero (inv_zero)
attribute [simp] inv_zero

@[simp] lemma mul_inv_cancel [GroupWithZero G₀] {a : G₀} (h : a ≠ 0) : a * a⁻¹ = 1 :=
GroupWithZero.mul_inv_cancel a h
#align mul_inv_cancel mul_inv_cancel

/-- A type `G₀` is a commutative “group with zero”
if it is a commutative monoid with zero element (distinct from `1`)
such that every nonzero element is invertible.
The type is required to come with an “inverse” function, and the inverse of `0` must be `0`. -/
class CommGroupWithZero (G₀ : Type _) extends CommMonoidWithZero G₀, GroupWithZero G₀
#align comm_group_with_zero CommGroupWithZero

section NeZero

attribute [field_simps] two_ne_zero three_ne_zero four_ne_zero

variable [MulZeroOneClass M₀] [Nontrivial M₀] {a b : M₀}

variable (M₀)

/-- In a nontrivial monoid with zero, zero and one are different. -/
instance NeZero.one : NeZero (1 : M₀) := ⟨by
  intro h
  rcases exists_pair_ne M₀ with ⟨x, y, hx⟩
  apply hx
  calc
    x = 1 * x := by rw [one_mul]
    _ = 0 := by rw [h, zero_mul]
    _ = 1 * y := by rw [h, zero_mul]
    _ = y := by rw [one_mul]⟩
#align ne_zero.one NeZero.one

variable {M₀}

/-- Pullback a `nontrivial` instance along a function sending `0` to `0` and `1` to `1`. -/
theorem pullback_nonzero [Zero M₀'] [One M₀'] (f : M₀' → M₀) (zero : f 0 = 0) (one : f 1 = 1) :
    Nontrivial M₀' :=
  ⟨⟨0, 1, mt (congr_arg f) <| by
    rw [zero, one]
    exact zero_ne_one⟩⟩
#align pullback_nonzero pullback_nonzero

end NeZero

section MulZeroClass

variable [MulZeroClass M₀]

theorem mul_eq_zero_of_left {a : M₀} (h : a = 0) (b : M₀) : a * b = 0 := h.symm ▸ zero_mul b
#align mul_eq_zero_of_left mul_eq_zero_of_left

theorem mul_eq_zero_of_right (a : M₀) {b : M₀} (h : b = 0) : a * b = 0 := h.symm ▸ mul_zero a
#align mul_eq_zero_of_right mul_eq_zero_of_right

variable [NoZeroDivisors M₀] {a b : M₀}

/-- If `α` has no zero divisors, then the product of two elements equals zero iff one of them
equals zero. -/
@[simp]
theorem mul_eq_zero : a * b = 0 ↔ a = 0 ∨ b = 0 :=
  ⟨eq_zero_or_eq_zero_of_mul_eq_zero,
    fun o => o.elim (fun h => mul_eq_zero_of_left h b) (mul_eq_zero_of_right a)⟩
#align mul_eq_zero mul_eq_zero

/-- If `α` has no zero divisors, then the product of two elements equals zero iff one of them
equals zero. -/
@[simp]
theorem zero_eq_mul : 0 = a * b ↔ a = 0 ∨ b = 0 := by rw [eq_comm, mul_eq_zero]
#align zero_eq_mul zero_eq_mul

/-- If `α` has no zero divisors, then the product of two elements is nonzero iff both of them
are nonzero. -/
theorem mul_ne_zero_iff : a * b ≠ 0 ↔ a ≠ 0 ∧ b ≠ 0 := mul_eq_zero.not.trans not_or
#align mul_ne_zero_iff mul_ne_zero_iff

/-- If `α` has no zero divisors, then for elements `a, b : α`, `a * b` equals zero iff so is
`b * a`. -/
theorem mul_eq_zero_comm : a * b = 0 ↔ b * a = 0 :=
  mul_eq_zero.trans <| or_comm.trans mul_eq_zero.symm
#align mul_eq_zero_comm mul_eq_zero_comm

/-- If `α` has no zero divisors, then for elements `a, b : α`, `a * b` is nonzero iff so is
`b * a`. -/
theorem mul_ne_zero_comm : a * b ≠ 0 ↔ b * a ≠ 0 := mul_eq_zero_comm.not
#align mul_ne_zero_comm mul_ne_zero_comm

theorem mul_self_eq_zero : a * a = 0 ↔ a = 0 := by simp
#align mul_self_eq_zero mul_self_eq_zero

theorem zero_eq_mul_self : 0 = a * a ↔ a = 0 := by simp
#align zero_eq_mul_self zero_eq_mul_self

theorem mul_self_ne_zero : a * a ≠ 0 ↔ a ≠ 0 := mul_self_eq_zero.not
#align mul_self_ne_zero mul_self_ne_zero

theorem zero_ne_mul_self : 0 ≠ a * a ↔ a ≠ 0 := zero_eq_mul_self.not
#align zero_ne_mul_self zero_ne_mul_self

end MulZeroClass


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

import algebra.cubic_discriminant
import ring_theory.norm
import tactic.linear_combination

/-!
# Weierstrass equations of elliptic curves

We give a working definition of an elliptic curve as a nonsingular Weierstrass curve given by a
Weierstrass equation, which is mathematically accurate in many cases but also good for computation.

## Mathematical background

Let `S` be a scheme. The actual category of elliptic curves over `S` is a large category, whose
objects are schemes `E` equipped with a map `E → S`, a section `S → E`, and some axioms (the map
is smooth and proper and the fibres are geometrically-connected one-dimensional group varieties). In
the special case where `S` is the spectrum of some commutative ring `R` whose Picard group is zero
(this includes all fields, all PIDs, and many other commutative rings) it can be shown (using a lot
of algebro-geometric machinery) that every elliptic curve `E` is a projective plane cubic isomorphic
to a Weierstrass curve given by the equation $Y^2 + a_1XY + a_3Y = X^3 + a_2X^2 + a_4X + a_6$ for
some $a_i$ in `R`, and such that a certain quantity called the discriminant of `E` is a unit in `R`.
If `R` is a field, this quantity divides the discriminant of a cubic polynomial whose roots over a
splitting field of `R` are precisely the $X$-coordinates of the non-zero 2-torsion points of `E`.

## Main definitions

 * `weierstrass_curve`: a Weierstrass curve over a commutative ring.
 * `weierstrass_curve.Δ`: the discriminant of a Weierstrass curve.
 * `weierstrass_curve.variable_change`: the Weierstrass curve induced by a change of variables.
 * `weierstrass_curve.base_change`: the Weierstrass curve base changed over an algebra.
 * `weierstrass_curve.two_torsion_polynomial`: the 2-torsion polynomial of a Weierstrass curve.
 * `weierstrass_curve.polynomial`: the polynomial associated to a Weierstrass curve.
 * `weierstrass_curve.equation`: the Weirstrass equation of a Weierstrass curve.
 * `weierstrass_curve.nonsingular`: the nonsingular condition at a point on a Weierstrass curve.
 * `weierstrass_curve.coordinate_ring`: the coordinate ring of a Weierstrass curve.
 * `weierstrass_curve.function_field`: the function field of a Weierstrass curve.
 * `weierstrass_curve.coordinate_ring.basis`: the power basis of the coordinate ring over `R[X]`.
 * `elliptic_curve`: an elliptic curve over a commutative ring.
 * `elliptic_curve.j`: the j-invariant of an elliptic curve.

## Main statements

 * `weierstrass_curve.two_torsion_polynomial_disc`: the discriminant of a Weierstrass curve is a
    constant factor of the cubic discriminant of its 2-torsion polynomial.
 * `weierstrass_curve.nonsingular_of_Δ_ne_zero`: a Weierstrass curve is nonsingular at every point
    if its discriminant is non-zero.
 * `weierstrass_curve.coordinate_ring.is_domain`: the coordinate ring of a Weierstrass curve is
    an integral domain.
 * `weierstrass_curve.coordinate_ring.degree_norm_smul_basis`: the degree of the norm of an element
    in the coordinate ring in terms of the power basis.
 * `elliptic_curve.nonsingular`: an elliptic curve is nonsingular at every point.
 * `elliptic_curve.variable_change_j`: the j-invariant of an elliptic curve is invariant under an
    admissible linear change of variables.

## Implementation notes

The definition of elliptic curves in this file makes sense for all commutative rings `R`, but it
only gives a type which can be beefed up to a category which is equivalent to the category of
elliptic curves over the spectrum $\mathrm{Spec}(R)$ of `R` in the case that `R` has trivial Picard
group $\mathrm{Pic}(R)$ or, slightly more generally, when its 12-torsion is trivial. The issue is
that for a general ring `R`, there might be elliptic curves over $\mathrm{Spec}(R)$ in the sense of
algebraic geometry which are not globally defined by a cubic equation valid over the entire base.

## References

 * [N Katz and B Mazur, *Arithmetic Moduli of Elliptic Curves*][katz_mazur]
 * [P Deligne, *Courbes Elliptiques: Formulaire (d'après J. Tate)*][deligne_formulaire]
 * [J Silverman, *The Arithmetic of Elliptic Curves*][silverman2009]

## Tags

elliptic curve, weierstrass equation, j invariant
-/

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

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

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

universes u v w

variable {R : Type u}

/-! ## Weierstrass curves -/

/-- A Weierstrass curve $Y^2 + a_1XY + a_3Y = X^3 + a_2X^2 + a_4X + a_6$ with parameters $a_i$. -/
@[ext] structure weierstrass_curve (R : Type u) := (a₁ a₂ a₃ a₄ a₆ : R)

instance [inhabited R] : inhabited $ weierstrass_curve R :=
⟨⟨default, default, default, default, default⟩⟩

namespace weierstrass_curve

variables [comm_ring R] (W : weierstrass_curve R)

section quantity

/-! ### Standard quantities -/

/-- The `b₂` coefficient of a Weierstrass curve. -/
@[simp] def b₂ : R := W.a₁ ^ 2 + 4 * W.a₂

/-- The `b₄` coefficient of a Weierstrass curve. -/
@[simp] def b₄ : R := 2 * W.a₄ + W.a₁ * W.a₃

/-- The `b₆` coefficient of a Weierstrass curve. -/
@[simp] def b₆ : R := W.a₃ ^ 2 + 4 * W.a₆

/-- The `b₈` coefficient of a Weierstrass curve. -/
@[simp] def b₈ : R :=
W.a₁ ^ 2 * W.a₆ + 4 * W.a₂ * W.a₆ - W.a₁ * W.a₃ * W.a₄ + W.a₂ * W.a₃ ^ 2 - W.a₄ ^ 2

lemma b_relation : 4 * W.b₈ = W.b₂ * W.b₆ - W.b₄ ^ 2 := by { simp only [b₂, b₄, b₆, b₈], ring1 }

/-- The `c₄` coefficient of a Weierstrass curve. -/
@[simp] def c₄ : R := W.b₂ ^ 2 - 24 * W.b₄

/-- The `c₆` coefficient of a Weierstrass curve. -/
@[simp] def c₆ : R := -W.b₂ ^ 3 + 36 * W.b₂ * W.b₄ - 216 * W.b₆

/-- The discriminant `Δ` of a Weierstrass curve. If `R` is a field, then this polynomial vanishes
if and only if the cubic curve cut out by this equation is singular. Sometimes only defined up to
sign in the literature; we choose the sign used by the LMFDB. For more discussion, see
[the LMFDB page on discriminants](https://www.lmfdb.org/knowledge/show/ec.discriminant). -/
@[simp] def Δ : R := -W.b₂ ^ 2 * W.b₈ - 8 * W.b₄ ^ 3 - 27 * W.b₆ ^ 2 + 9 * W.b₂ * W.b₄ * W.b₆

lemma c_relation : 1728 * W.Δ = W.c₄ ^ 3 - W.c₆ ^ 2 :=
by { simp only [b₂, b₄, b₆, b₈, c₄, c₆, Δ], ring1 }

end quantity

section variable_change

/-! ### Variable changes -/

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

/-- The Weierstrass curve over `R` induced by an admissible linear change of variables
$(X, Y) \mapsto (u^2X + r, u^3Y + u^2sX + t)$ for some $u \in R^\times$ and some $r, s, t \in R$. -/
@[simps] def variable_change : weierstrass_curve R :=
{ a₁ := ↑u⁻¹ * (W.a₁ + 2 * s),
  a₂ := ↑u⁻¹ ^ 2 * (W.a₂ - s * W.a₁ + 3 * r - s ^ 2),
  a₃ := ↑u⁻¹ ^ 3 * (W.a₃ + r * W.a₁ + 2 * t),
  a₄ := ↑u⁻¹ ^ 4 * (W.a₄ - s * W.a₃ + 2 * r * W.a₂ - (t + r * s) * W.a₁ + 3 * r ^ 2 - 2 * s * t),
  a₆ := ↑u⁻¹ ^ 6 * (W.a₆ + r * W.a₄ + r ^ 2 * W.a₂ + r ^ 3 - t * W.a₃ - t ^ 2 - r * t * W.a₁) }

@[simp] lemma variable_change_b₂ : (W.variable_change u r s t).b₂ = ↑u⁻¹ ^ 2 * (W.b₂ + 12 * r) :=
by { simp only [b₂, variable_change_a₁, variable_change_a₂], ring1 }

@[simp] lemma variable_change_b₄ :
  (W.variable_change u r s t).b₄ = ↑u⁻¹ ^ 4 * (W.b₄ + r * W.b₂ + 6 * r ^ 2) :=
by { simp only [b₂, b₄, variable_change_a₁, variable_change_a₃, variable_change_a₄], ring1 }

@[simp] lemma variable_change_b₆ :
  (W.variable_change u r s t).b₆ = ↑u⁻¹ ^ 6 * (W.b₆ + 2 * r * W.b₄ + r ^ 2 * W.b₂ + 4 * r ^ 3) :=
by { simp only [b₂, b₄, b₆, variable_change_a₃, variable_change_a₆], ring1 }

@[simp] lemma variable_change_b₈ :
  (W.variable_change u r s t).b₈
    = ↑u⁻¹ ^ 8 * (W.b₈ + 3 * r * W.b₆ + 3 * r ^ 2 * W.b₄ + r ^ 3 * W.b₂ + 3 * r ^ 4) :=
by { simp only [b₂, b₄, b₆, b₈, variable_change_a₁, variable_change_a₂, variable_change_a₃,
                variable_change_a₄, variable_change_a₆], ring1 }

@[simp] lemma variable_change_c₄ : (W.variable_change u r s t).c₄ = ↑u⁻¹ ^ 4 * W.c₄ :=
by { simp only [c₄, variable_change_b₂, variable_change_b₄], ring1 }

@[simp] lemma variable_change_c₆ : (W.variable_change u r s t).c₆ = ↑u⁻¹ ^ 6 * W.c₆ :=
by { simp only [c₆, variable_change_b₂, variable_change_b₄, variable_change_b₆], ring1 }

@[simp] lemma variable_change_Δ : (W.variable_change u r s t).Δ = ↑u⁻¹ ^ 12 * W.Δ :=
by { dsimp, ring1 }

end variable_change

variables (A : Type v) [comm_ring A] [algebra R A] (B : Type w) [comm_ring B] [algebra R B]
  [algebra A B] [is_scalar_tower R A B]

section base_change

/-! ### Base changes -/

/-- The Weierstrass curve over `R` base changed to `A`. -/
@[simps] def base_change : weierstrass_curve A :=
⟨algebra_map R A W.a₁, algebra_map R A W.a₂, algebra_map R A W.a₃, algebra_map R A W.a₄,
algebra_map R A W.a₆⟩

@[simp] lemma base_change_b₂ : (W.base_change A).b₂ = algebra_map R A W.b₂ :=
by { simp only [b₂, base_change_a₁, base_change_a₂], map_simp }

@[simp] lemma base_change_b₄ : (W.base_change A).b₄ = algebra_map R A W.b₄ :=
by { simp only [b₄, base_change_a₁, base_change_a₃, base_change_a₄], map_simp }

@[simp] lemma base_change_b₆ : (W.base_change A).b₆ = algebra_map R A W.b₆ :=
by { simp only [b₆, base_change_a₃, base_change_a₆], map_simp }

@[simp] lemma base_change_b₈ : (W.base_change A).b₈ = algebra_map R A W.b₈ :=
by { simp only [b₈, base_change_a₁, base_change_a₂, base_change_a₃, base_change_a₄, base_change_a₆],
     map_simp }

@[simp] lemma base_change_c₄ : (W.base_change A).c₄ = algebra_map R A W.c₄ :=
by { simp only [c₄, base_change_b₂, base_change_b₄], map_simp }

@[simp] lemma base_change_c₆ : (W.base_change A).c₆ = algebra_map R A W.c₆ :=
by { simp only [c₆, base_change_b₂, base_change_b₄, base_change_b₆], map_simp }

@[simp, nolint simp_nf] lemma base_change_Δ : (W.base_change A).Δ = algebra_map R A W.Δ :=
by { simp only [Δ, base_change_b₂, base_change_b₄, base_change_b₆, base_change_b₈], map_simp }

lemma base_change_self : W.base_change R = W := by ext; refl

lemma base_change_base_change : (W.base_change A).base_change B = W.base_change B :=
by ext; exact (is_scalar_tower.algebra_map_apply R A B _).symm

end base_change

section torsion_polynomial

/-! ### 2-torsion polynomials -/

/-- A cubic polynomial whose discriminant is a multiple of the Weierstrass curve discriminant. If
`W` is an elliptic curve over a field `R` of characteristic different from 2, then its roots over a
splitting field of `R` are precisely the $X$-coordinates of the non-zero 2-torsion points of `W`. -/
def two_torsion_polynomial : cubic R := ⟨4, W.b₂, 2 * W.b₄, W.b₆⟩

lemma two_torsion_polynomial_disc : W.two_torsion_polynomial.disc = 16 * W.Δ :=
by { dsimp [two_torsion_polynomial, cubic.disc], ring1 }

lemma two_torsion_polynomial_disc_is_unit [invertible (2 : R)] :
  is_unit W.two_torsion_polynomial.disc ↔ is_unit W.Δ :=
begin
  rw [two_torsion_polynomial_disc, is_unit.mul_iff, show (16 : R) = 2 ^ 4, by norm_num1],
  exact and_iff_right (is_unit_of_invertible $ 2 ^ 4)
end

end torsion_polynomial

localized "notation (name := outer_variable) `Y` := polynomial.X" in polynomial_polynomial

localized "notation (name := polynomial_polynomial) R`[X][Y]` := polynomial (polynomial R)"
  in polynomial_polynomial

section polynomial

/-! ### Weierstrass equations -/

open polynomial

open_locale polynomial

/-- The polynomial $W(X, Y) := Y^2 + a_1XY + a_3Y - (X^3 + a_2X^2 + a_4X + a_6)$ associated to a
Weierstrass curve `W` over `R`. For ease of polynomial manipulation, this is represented as a term
of type `R[X][X]`, where the inner variable represents $X$ and the outer variable represents $Y$.
For clarity, the alternative notations `Y` and `R[X][Y]` are provided in the `polynomial_polynomial`
locale to represent the outer variable and the bivariate polynomial ring `R[X][X]` respectively. -/
protected noncomputable def polynomial : R[X][Y] :=
Y ^ 2 + C (C W.a₁ * X + C W.a₃) * Y - C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)

lemma polynomial_eq : W.polynomial = cubic.to_poly
  ⟨0, 1, cubic.to_poly ⟨0, 0, W.a₁, W.a₃⟩, cubic.to_poly ⟨-1, -W.a₂, -W.a₄, -W.a₆⟩⟩ :=
by { simp only [weierstrass_curve.polynomial, cubic.to_poly], C_simp, ring1 }

lemma polynomial_ne_zero [nontrivial R] : W.polynomial ≠ 0 :=
by { rw [polynomial_eq], exact cubic.ne_zero_of_b_ne_zero one_ne_zero }

@[simp] lemma degree_polynomial [nontrivial R] : W.polynomial.degree = 2 :=
by { rw [polynomial_eq], exact cubic.degree_of_b_ne_zero' one_ne_zero }

@[simp] lemma nat_degree_polynomial [nontrivial R] : W.polynomial.nat_degree = 2 :=
by { rw [polynomial_eq], exact cubic.nat_degree_of_b_ne_zero' one_ne_zero }

lemma monic_polynomial : W.polynomial.monic :=
by { nontriviality R, simpa only [polynomial_eq] using cubic.monic_of_b_eq_one' }

lemma irreducible_polynomial [is_domain R] : irreducible W.polynomial :=
begin
  by_contra h,
  rcases (W.monic_polynomial.not_irreducible_iff_exists_add_mul_eq_coeff W.nat_degree_polynomial).mp
          h with ⟨f, g, h0, h1⟩,
  simp only [polynomial_eq, cubic.coeff_eq_c, cubic.coeff_eq_d] at h0 h1,
  apply_fun degree at h0 h1,
  rw [cubic.degree_of_a_ne_zero' $ neg_ne_zero.mpr $ one_ne_zero' R, degree_mul] at h0,
  apply (h1.symm.le.trans cubic.degree_of_b_eq_zero').not_lt,
  rcases nat.with_bot.add_eq_three_iff.mp h0.symm with h | h | h | h,
  any_goals { rw [degree_add_eq_left_of_degree_lt]; simp only [h]; dec_trivial },
  any_goals { rw [degree_add_eq_right_of_degree_lt]; simp only [h]; dec_trivial }
end

@[simp] lemma eval_polynomial (x y : R) :
  (W.polynomial.eval $ C y).eval x
    = y ^ 2 + W.a₁ * x * y + W.a₃ * y - (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆) :=
by { simp only [weierstrass_curve.polynomial], eval_simp, rw [add_mul, ← add_assoc] }

@[simp] lemma eval_polynomial_zero : (W.polynomial.eval 0).eval 0 = -W.a₆ :=
by simp only [← C_0, eval_polynomial, zero_add, zero_sub, mul_zero, zero_pow (nat.zero_lt_succ _)]

/-- The proposition that an affine point $(x, y)$ lies in `W`. In other words, $W(x, y) = 0$. -/
def equation (x y : R) : Prop := (W.polynomial.eval $ C y).eval x = 0

lemma equation_iff' (x y : R) :
  W.equation x y ↔ y ^ 2 + W.a₁ * x * y + W.a₃ * y - (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆) = 0 :=
by rw [equation, eval_polynomial]

@[simp] lemma equation_iff (x y : R) :
  W.equation x y ↔ y ^ 2 + W.a₁ * x * y + W.a₃ * y = x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆ :=
by rw [equation_iff', sub_eq_zero]

@[simp] lemma equation_zero : W.equation 0 0 ↔ W.a₆ = 0 :=
by rw [equation, C_0, eval_polynomial_zero, neg_eq_zero]

lemma equation_iff_variable_change (x y : R) :
  W.equation x y ↔ (W.variable_change 1 x 0 y).equation 0 0 :=
begin
  rw [equation_iff', ← neg_eq_zero, equation_zero, variable_change_a₆, inv_one, units.coe_one],
  congr' 2,
  ring1
end

lemma equation_iff_base_change [nontrivial A] [no_zero_smul_divisors R A] (x y : R) :
  W.equation x y ↔ (W.base_change A).equation (algebra_map R A x) (algebra_map R A y) :=
begin
  simp only [equation_iff],
  refine ⟨λ h, _, λ h, _⟩,
  { convert congr_arg (algebra_map R A) h; { map_simp, refl } },
  { apply no_zero_smul_divisors.algebra_map_injective R A, map_simp, exact h }
end

lemma equation_iff_base_change_of_base_change [nontrivial B] [no_zero_smul_divisors A B] (x y : A) :
  (W.base_change A).equation x y
    ↔ (W.base_change B).equation (algebra_map A B x) (algebra_map A B y) :=
by rw [equation_iff_base_change (W.base_change A) B, base_change_base_change]

/-! ### Nonsingularity of Weierstrass curves -/

/-- The partial derivative $W_X(X, Y)$ of $W(X, Y)$ with respect to $X$.

TODO: define this in terms of `polynomial.derivative`. -/
noncomputable def polynomial_X : R[X][Y] :=
C (C W.a₁) * Y - C (C 3 * X ^ 2 + C (2 * W.a₂) * X + C W.a₄)

@[simp] lemma eval_polynomial_X (x y : R) :
  (W.polynomial_X.eval $ C y).eval x = W.a₁ * y - (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄) :=
by { simp only [polynomial_X], eval_simp }

@[simp] lemma eval_polynomial_X_zero : (W.polynomial_X.eval 0).eval 0 = -W.a₄ :=
by simp only [← C_0, eval_polynomial_X, zero_add, zero_sub, mul_zero, zero_pow zero_lt_two]

/-- The partial derivative $W_Y(X, Y)$ of $W(X, Y)$ with respect to $Y$.

TODO: define this in terms of `polynomial.derivative`. -/
noncomputable def polynomial_Y : R[X][Y] := C (C 2) * Y + C (C W.a₁ * X + C W.a₃)

@[simp] lemma eval_polynomial_Y (x y : R) :
  (W.polynomial_Y.eval $ C y).eval x = 2 * y + W.a₁ * x + W.a₃ :=
by { simp only [polynomial_Y], eval_simp, rw [← add_assoc] }

@[simp] lemma eval_polynomial_Y_zero : (W.polynomial_Y.eval 0).eval 0 = W.a₃ :=
by simp only [← C_0, eval_polynomial_Y, zero_add, mul_zero]

/-- The proposition that an affine point $(x, y)$ on `W` is nonsingular.
In other words, either $W_X(x, y) \ne 0$ or $W_Y(x, y) \ne 0$. -/
def nonsingular (x y : R) : Prop :=
W.equation x y ∧ ((W.polynomial_X.eval $ C y).eval x ≠ 0 ∨ (W.polynomial_Y.eval $ C y).eval x ≠ 0)

lemma nonsingular_iff' (x y : R) :
  W.nonsingular x y
    ↔ W.equation x y
      ∧ (W.a₁ * y - (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄) ≠ 0 ∨ 2 * y + W.a₁ * x + W.a₃ ≠ 0) :=
by rw [nonsingular, equation_iff', eval_polynomial_X, eval_polynomial_Y]

@[simp] lemma nonsingular_iff (x y : R) :
  W.nonsingular x y
    ↔ W.equation x y ∧ (W.a₁ * y ≠ 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ ∨ y ≠ -y - W.a₁ * x - W.a₃) :=
by { rw [nonsingular_iff', sub_ne_zero, ← @sub_ne_zero _ _ y], congr' 4; ring1 }

@[simp] lemma nonsingular_zero : W.nonsingular 0 0 ↔ W.a₆ = 0 ∧ (W.a₃ ≠ 0 ∨ W.a₄ ≠ 0) :=
by rw [nonsingular, equation_zero, C_0, eval_polynomial_X_zero, neg_ne_zero, eval_polynomial_Y_zero,
       or_comm]

lemma nonsingular_iff_variable_change (x y : R) :
  W.nonsingular x y ↔ (W.variable_change 1 x 0 y).nonsingular 0 0 :=
begin
  rw [nonsingular_iff', equation_iff_variable_change, equation_zero, ← neg_ne_zero, or_comm,
      nonsingular_zero, variable_change_a₃, variable_change_a₄, inv_one, units.coe_one],
  congr' 4; ring1
end

lemma nonsingular_iff_base_change [nontrivial A] [no_zero_smul_divisors R A] (x y : R) :
  W.nonsingular x y ↔ (W.base_change A).nonsingular (algebra_map R A x) (algebra_map R A y) :=
begin
  rw [nonsingular_iff, nonsingular_iff, and_congr $ W.equation_iff_base_change A x y],
  refine ⟨or.imp (not_imp_not.mpr $ λ h, _) (not_imp_not.mpr $ λ h, _),
    or.imp (not_imp_not.mpr $ λ h, _) (not_imp_not.mpr $ λ h, _)⟩,
  any_goals { apply no_zero_smul_divisors.algebra_map_injective R A, map_simp, exact h },
  any_goals { convert congr_arg (algebra_map R A) h; { map_simp, refl } }
end

lemma nonsingular_iff_base_change_of_base_change [nontrivial B] [no_zero_smul_divisors A B]
  (x y : A) : (W.base_change A).nonsingular x y
    ↔ (W.base_change B).nonsingular (algebra_map A B x) (algebra_map A B y) :=
by rw [nonsingular_iff_base_change (W.base_change A) B, base_change_base_change]

lemma nonsingular_zero_of_Δ_ne_zero (h : W.equation 0 0) (hΔ : W.Δ ≠ 0) : W.nonsingular 0 0 :=
by { simp only [equation_zero, nonsingular_zero] at *, contrapose! hΔ, simp [h, hΔ] }

/-- A Weierstrass curve is nonsingular at every point if its discriminant is non-zero. -/
lemma nonsingular_of_Δ_ne_zero {x y : R} (h : W.equation x y) (hΔ : W.Δ ≠ 0) : W.nonsingular x y :=
(W.nonsingular_iff_variable_change x y).mpr $
  nonsingular_zero_of_Δ_ne_zero _ ((W.equation_iff_variable_change x y).mp h) $
by rwa [variable_change_Δ, inv_one, units.coe_one, one_pow, one_mul]

/-! ### Ideals in the coordinate ring -/

/-- The coordinate ring $R[W] := R[X, Y] / \langle W(X, Y) \rangle$ of `W`.

Note that `derive comm_ring` generates a reducible instance of `comm_ring` for `coordinate_ring`.
In certain circumstances this might be extremely slow, because all instances in its definition are
unified exponentially many times. In this case, one solution is to manually add the local attribute
`local attribute [irreducible] coordinate_ring.comm_ring` to block this type-level unification.

TODO Lean 4: verify if the new def-eq cache (lean4#1102) fixed this issue.

See Zulip thread:
https://leanprover.zulipchat.com/#narrow/stream/116395-maths/topic/.E2.9C.94.20class_group.2Emk -/
@[derive [inhabited, comm_ring]] def coordinate_ring : Type u := adjoin_root W.polynomial

/-- The function field $R(W) := \mathrm{Frac}(R[W])$ of `W`. -/
abbreviation function_field : Type u := fraction_ring W.coordinate_ring

namespace coordinate_ring

instance [is_domain R] [normalized_gcd_monoid R] : is_domain W.coordinate_ring :=
(ideal.quotient.is_domain_iff_prime _).mpr $
by simpa only [ideal.span_singleton_prime W.polynomial_ne_zero, ← gcd_monoid.irreducible_iff_prime]
   using W.irreducible_polynomial

instance is_domain_of_field {F : Type u} [field F] (W : weierstrass_curve F) :
  is_domain W.coordinate_ring :=
by { classical, apply_instance }

variables (x : R) (y : R[X])

/-- The class of the element $X - x$ in $R[W]$ for some $x \in R$. -/
@[simp] noncomputable def X_class : W.coordinate_ring := adjoin_root.mk W.polynomial $ C $ X - C x

lemma X_class_ne_zero [nontrivial R] : X_class W x ≠ 0 :=
adjoin_root.mk_ne_zero_of_nat_degree_lt W.monic_polynomial (C_ne_zero.mpr $ X_sub_C_ne_zero x) $
  by { rw [nat_degree_polynomial, nat_degree_C], norm_num1 }

/-- The class of the element $Y - y(X)$ in $R[W]$ for some $y(X) \in R[X]$. -/
@[simp] noncomputable def Y_class : W.coordinate_ring := adjoin_root.mk W.polynomial $ Y - C y

lemma Y_class_ne_zero [nontrivial R] : Y_class W y ≠ 0 :=
adjoin_root.mk_ne_zero_of_nat_degree_lt W.monic_polynomial (X_sub_C_ne_zero y) $
  by { rw [nat_degree_polynomial, nat_degree_X_sub_C], norm_num1 }

/-- The ideal $\langle X - x \rangle$ of $R[W]$ for some $x \in R$. -/
@[simp] noncomputable def X_ideal : ideal W.coordinate_ring := ideal.span {X_class W x}

/-- The ideal $\langle Y - y(X) \rangle$ of $R[W]$ for some $y(X) \in R[X]$. -/
@[simp] noncomputable def Y_ideal : ideal W.coordinate_ring := ideal.span {Y_class W y}

/-! ### The coordinate ring as an `R[X]`-algebra -/

noncomputable instance : algebra R[X] W.coordinate_ring := ideal.quotient.algebra R[X]

noncomputable instance algebra' : algebra R W.coordinate_ring := ideal.quotient.algebra R

instance : is_scalar_tower R R[X] W.coordinate_ring := ideal.quotient.is_scalar_tower R R[X] _

instance [subsingleton R] : subsingleton W.coordinate_ring := module.subsingleton R[X] _

/-- The basis $\{1, Y\}$ for the coordinate ring $R[W]$ over the polynomial ring $R[X]$.

Given a Weierstrass curve `W`, write `W^.coordinate_ring.basis` for this basis. -/
protected noncomputable def basis : basis (fin 2) R[X] W.coordinate_ring :=
(subsingleton_or_nontrivial R).by_cases (λ _, by exactI default) $ λ _, by exactI
  ((adjoin_root.power_basis' W.monic_polynomial).basis.reindex $
    fin_congr W.nat_degree_polynomial)

lemma basis_apply (n : fin 2) :
  W^.coordinate_ring.basis n = (adjoin_root.power_basis' W.monic_polynomial).gen ^ (n : ℕ) :=
begin
  classical,
  nontriviality R,
  simpa only [coordinate_ring.basis, or.by_cases, dif_neg (not_subsingleton R),
              basis.reindex_apply, power_basis.basis_eq_pow]
end

lemma basis_zero : W^.coordinate_ring.basis 0 = 1 := by simpa only [basis_apply] using pow_zero _

lemma basis_one : W^.coordinate_ring.basis 1 = adjoin_root.mk W.polynomial Y :=
by simpa only [basis_apply] using pow_one _

@[simp] lemma coe_basis :
  (W^.coordinate_ring.basis : fin 2 → W.coordinate_ring) = ![1, adjoin_root.mk W.polynomial Y] :=
by { ext n, fin_cases n, exacts [basis_zero W, basis_one W] }

variable {W}

lemma smul (x : R[X]) (y : W.coordinate_ring) : x • y = adjoin_root.mk W.polynomial (C x) * y :=
(algebra_map_smul W.coordinate_ring x y).symm

lemma smul_basis_eq_zero {p q : R[X]}
  (hpq : p • 1 + q • adjoin_root.mk W.polynomial Y = 0) : p = 0 ∧ q = 0 :=
begin
  have h := fintype.linear_independent_iff.mp (coordinate_ring.basis W).linear_independent ![p, q],
  erw [fin.sum_univ_succ, basis_zero, fin.sum_univ_one, basis_one] at h,
  exact ⟨h hpq 0, h hpq 1⟩
end

lemma exists_smul_basis_eq (x : W.coordinate_ring) :
  ∃ p q : R[X], p • 1 + q • adjoin_root.mk W.polynomial Y = x :=
begin
  have h := (coordinate_ring.basis W).sum_equiv_fun x,
  erw [fin.sum_univ_succ, fin.sum_univ_one, basis_zero, basis_one] at h,
  exact ⟨_, _, h⟩
end

variable (W)

lemma smul_basis_mul_C (p q : R[X]) :
  (p • 1 + q • adjoin_root.mk W.polynomial Y) * adjoin_root.mk W.polynomial (C y)
    = ((p * y) • 1 + (q * y) • adjoin_root.mk W.polynomial Y) :=
by { simp only [smul, map_mul], ring1 }

lemma smul_basis_mul_Y (p q : R[X]) :
  (p • 1 + q • adjoin_root.mk W.polynomial Y) * adjoin_root.mk W.polynomial Y
    = (q * (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)) • 1
      + (p - q * (C W.a₁ * X + C W.a₃)) • adjoin_root.mk W.polynomial Y :=
begin
  have Y_sq : adjoin_root.mk W.polynomial Y ^ 2 = adjoin_root.mk W.polynomial
    (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆) - C (C W.a₁ * X + C W.a₃) * Y) :=
  adjoin_root.mk_eq_mk.mpr ⟨1, by { simp only [weierstrass_curve.polynomial], ring1 }⟩,
  simp only [smul, add_mul, mul_assoc, ← sq, Y_sq, map_sub, map_mul],
  ring1
end

/-! ### Norms on the coordinate ring -/

lemma norm_smul_basis (p q : R[X]) :
  algebra.norm R[X] (p • 1 + q • adjoin_root.mk W.polynomial Y)
    = p ^ 2 - p * q * (C W.a₁ * X + C W.a₃)
      - q ^ 2 * (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆) :=
begin
  simp_rw [algebra.norm_eq_matrix_det W^.coordinate_ring.basis, matrix.det_fin_two,
           algebra.left_mul_matrix_eq_repr_mul, basis_zero, mul_one, basis_one, smul_basis_mul_Y,
           map_add, finsupp.add_apply, map_smul, finsupp.smul_apply, ← basis_zero, ← basis_one,
           basis.repr_self_apply, if_pos, if_neg one_ne_zero, if_neg zero_ne_one, smul_eq_mul],
  ring1
end

lemma coe_norm_smul_basis (p q : R[X]) :
  ↑(algebra.norm R[X] $ p • 1 + q • adjoin_root.mk W.polynomial Y)
    = adjoin_root.mk W.polynomial
      ((C p + C q * X) * (C p + C q * (-X - C (C W.a₁ * X + C W.a₃)))) :=
adjoin_root.mk_eq_mk.mpr
  ⟨C q ^ 2, by { rw [norm_smul_basis, weierstrass_curve.polynomial], C_simp, ring1 }⟩

lemma degree_norm_smul_basis [is_domain R] (p q : R[X]) :
  (algebra.norm R[X] $ p • 1 + q • adjoin_root.mk W.polynomial Y).degree
    = max (2 • p.degree) (2 • q.degree + 3) :=
begin
  have hdp : (p ^ 2).degree = 2 • p.degree := degree_pow p 2,
  have hdpq : (p * q * (C W.a₁ * X + C W.a₃)).degree ≤ p.degree + q.degree + 1,
  { simpa only [degree_mul] using add_le_add_left degree_linear_le (p.degree + q.degree) },
  have hdq : (q ^ 2 * (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)).degree = 2 • q.degree + 3,
  { rw [degree_mul, degree_pow, ← one_mul $ X ^ 3, ← C_1, degree_cubic $ one_ne_zero' R] },
  rw [norm_smul_basis],
  by_cases hp : p = 0, { simpa only [hp, hdq, neg_zero, zero_sub, zero_mul, zero_pow zero_lt_two,
                                     degree_neg] using (max_bot_left _).symm },
  by_cases hq : q = 0, { simpa only [hq, hdp, sub_zero, zero_mul, mul_zero, zero_pow zero_lt_two]
                           using (max_bot_right _).symm },
  rw [← not_iff_not_of_iff degree_eq_bot] at hp hq,
  cases p.degree with dp, { exact (hp rfl).elim },
  cases q.degree with dq, { exact (hq rfl).elim },
  cases le_or_lt dp (dq + 1) with hpq hpq,
  { convert (degree_sub_eq_right_of_degree_lt $ (degree_sub_le _ _).trans_lt $
      max_lt_iff.mpr ⟨hdp.trans_lt _, hdpq.trans_lt _⟩).trans (max_eq_right_of_lt _).symm; rw [hdq];
      exact with_bot.coe_lt_coe.mpr (by linarith only [hpq]) },
  { rw [sub_sub],
    convert (degree_sub_eq_left_of_degree_lt $ (degree_add_le _ _).trans_lt $
      max_lt_iff.mpr ⟨hdpq.trans_lt _, hdq.trans_lt _⟩).trans (max_eq_left_of_lt _).symm; rw [hdp];
      exact with_bot.coe_lt_coe.mpr (by linarith only [hpq]) }
end

variable {W}

lemma degree_norm_ne_one [is_domain R] (x : W.coordinate_ring) : (algebra.norm R[X] x).degree ≠ 1 :=
begin
  rcases exists_smul_basis_eq x with ⟨p, q, rfl⟩,
  rw [degree_norm_smul_basis],
  rcases p.degree with (_ | _ | _ | _); cases q.degree,
  any_goals { rintro (_ | _) },
  exact (lt_max_of_lt_right dec_trivial).ne'
end

lemma nat_degree_norm_ne_one [is_domain R] (x : W.coordinate_ring) :
  (algebra.norm R[X] x).nat_degree ≠ 1 :=
mt (degree_eq_iff_nat_degree_eq_of_pos zero_lt_one).mpr $ degree_norm_ne_one x

end coordinate_ring

end polynomial

end weierstrass_curve

/-! ## Elliptic curves -/

/-- An elliptic curve over a commutative ring. Note that this definition is only mathematically
accurate for certain rings whose Picard group has trivial 12-torsion, such as a field or a PID. -/
@[ext] structure elliptic_curve (R : Type u) [comm_ring R] extends weierstrass_curve R :=
(Δ' : Rˣ) (coe_Δ' : ↑Δ' = to_weierstrass_curve.Δ)

instance : inhabited $ elliptic_curve ℚ :=
⟨⟨⟨0, 0, 1, -1, 0⟩, ⟨37, 37⁻¹, by norm_num1, by norm_num1⟩, by { dsimp, ring1 }⟩⟩

namespace elliptic_curve

variables [comm_ring R] (E : elliptic_curve R)

/-- The j-invariant `j` of an elliptic curve, which is invariant under isomorphisms over `R`. -/
@[simp] def j : R := ↑E.Δ'⁻¹ * E.c₄ ^ 3

lemma two_torsion_polynomial_disc_ne_zero [nontrivial R] [invertible (2 : R)] :
  E.two_torsion_polynomial.disc ≠ 0 :=
E.two_torsion_polynomial_disc_ne_zero $ E.coe_Δ' ▸ E.Δ'.is_unit

lemma nonsingular [nontrivial R] {x y : R} (h : E.equation x y) : E.nonsingular x y :=
E.nonsingular_of_Δ_ne_zero h $ E.coe_Δ' ▸ E.Δ'.ne_zero

section variable_change

/-! ### Variable changes -/

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

/-- The elliptic curve over `R` induced by an admissible linear change of variables
$(X, Y) \mapsto (u^2X + r, u^3Y + u^2sX + t)$ for some $u \in R^\times$ and some $r, s, t \in R$.
When `R` is a field, any two Weierstrass equations isomorphic to `E` are related by this. -/
@[simps] def variable_change : elliptic_curve R :=
⟨E.variable_change u r s t, u⁻¹ ^ 12 * E.Δ',
by rw [units.coe_mul, units.coe_pow, coe_Δ', E.variable_change_Δ]⟩

lemma coe_variable_change_Δ' : (↑(E.variable_change u r s t).Δ' : R) = ↑u⁻¹ ^ 12 * E.Δ' :=
by rw [variable_change_Δ', units.coe_mul, units.coe_pow]

lemma coe_inv_variable_change_Δ' : (↑(E.variable_change u r s t).Δ'⁻¹ : R) = u ^ 12 * ↑E.Δ'⁻¹ :=
by rw [variable_change_Δ', mul_inv, inv_pow, inv_inv, units.coe_mul, units.coe_pow]

@[simp] lemma variable_change_j : (E.variable_change u r s t).j = E.j :=
begin
  rw [j, coe_inv_variable_change_Δ'],
  have hu : (u * ↑u⁻¹ : R) ^ 12 = 1 := by rw [u.mul_inv, one_pow],
  linear_combination E.j * hu with { normalization_tactic := `[dsimp, ring1] }
end

end variable_change

section base_change

/-! ### Base changes -/

variables (A : Type v) [comm_ring A] [algebra R A]

/-- The elliptic curve over `R` base changed to `A`. -/
@[simps] def base_change : elliptic_curve A :=
⟨E.base_change A, units.map ↑(algebra_map R A) E.Δ',
by rw [units.coe_map, ring_hom.coe_monoid_hom, coe_Δ', E.base_change_Δ]⟩

lemma coe_base_change_Δ' : ↑(E.base_change A).Δ' = algebra_map R A E.Δ' := rfl

lemma coe_inv_base_change_Δ' : ↑(E.base_change A).Δ'⁻¹ = algebra_map R A ↑E.Δ'⁻¹ := rfl

@[simp] lemma base_change_j : (E.base_change A).j = algebra_map R A E.j :=
by { simp only [j, coe_inv_base_change_Δ', base_change_to_weierstrass_curve, E.base_change_c₄],
     map_simp }

end base_change

end elliptic_curve


/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import data.rat
import data.fin

lemma eq_or_ne {α:Type*} [D:decidable_eq α] {x y:α}:(x=y)∨ (x≠ y) :=
begin
  have A1:decidable (x=y) := D x y,
  cases A1,
  {
    right,
    apply A1,
  },
  {
    left,
    apply A1,
  }
end

lemma lt_or_not_lt {α:Type*} [D:linear_order α] {x y:α}:(x<y)∨ ¬ (x< y) :=
begin
  have A1:decidable (x<y) := linear_order.decidable_lt x y,
  cases A1,
  {
    right,
    apply A1,
  },
  {
    left,
    apply A1,
  }
end

lemma le_or_not_le {α:Type*} [D:linear_order α] {x y:α}:(x≤y)∨ ¬(x≤y) :=
begin
  have A1:decidable (x≤y) := linear_order.decidable_le x y,
  cases A1,
  {
    right,
    apply A1,
  },
  {
    left,
    apply A1,
  }
end

lemma le_iff_not_gt {α:Type*} [linear_order α] {a b:α}:a ≤ b ↔ ¬ a > b :=
begin
  split,
  {
    intro A1,
    intro A2,
    apply not_le_of_gt A2,
    apply A1,
  },
  {
    apply le_of_not_gt,
  }
end

lemma has_le_fun_def {α β:Type*} [preorder β] {f g:α → β}: f ≤ g = (∀ a:α, f a ≤ g a) := rfl

lemma le_func_def2 {α β:Type*} [preorder β] {f g:α → β}:(f ≤ g) ↔ (∀ n:α, f n ≤ g n) :=
begin
  refl,
end

lemma function.le_trans {α β:Type*} [partial_order β] {f g h:α → β}:f ≤ g → g ≤ h → f ≤ h :=
begin
  intros A1 A2,
  intro x,
  apply le_trans,
  apply A1,
  apply A2,
end

lemma classical.some_func {α β:Type*} {P:α → β → Prop}:
    (∀ a:α, ∃ b:β,  P a b) → (∃ f:α → β, ∀ a:α, P a (f a)) :=
begin
  intros A1,
  let f:α → β := λ a:α, classical.some (A1 a),
  begin
    apply exists.intro f,
    intro a,
    have A2:P a (classical.some (A1 a)),
    {
      apply classical.some_spec,
    },
    have A3:f a = (classical.some (A1 a)),
    {
      simp,
    },
    rw ← A3 at A2,
    apply A2,
  end
end

lemma classical.forall_of_not_exists_not {α:Type*} {P:α → Prop}:(¬(∃ a:α, ¬ P a))→(∀ a:α, P a) :=
begin
  intro A1,
  rw ← @decidable.not_exists_not _ _ (λ x, @classical.prop_decidable _),
  apply A1,
end

lemma classical.exists_not_of_not_forall {α:Type*} {P:α → Prop}:(¬(∀ a:α, P a))→ (∃ a:α, ¬ P a) :=
begin
  intro A1,
  apply classical.by_contradiction,
  intro A2,
  apply A1,
  apply classical.forall_of_not_exists_not,
  apply A2,
end

lemma classical.not_forall_iff_exists_not {α:Type*} {P:α → Prop}:(¬(∀ a:α, P a)) ↔(∃ a:α, ¬ P a) :=
begin
  split,
  {
    apply classical.exists_not_of_not_forall,
    --apply A1,
  },
  {
    apply not_forall_of_exists_not,
    --apply A1,
  },
end

lemma not_exists_iff_forall_not {α:Sort*} {P:α → Prop}:
    (¬(∃ a:α, P a)) ↔(∀ a:α, ¬ P a) :=
begin
  split,
  {
    apply forall_not_of_not_exists,
  },
  {
    apply not_exists_of_forall_not,
    --apply A1,
  },
end

lemma classical.exists_of_not_forall_not {α:Sort*} {P:α → Prop}:
    (¬∀ a:α, ¬ P a)  → (∃ a:α, P a) :=
begin
  intro A1,
  cases (classical.em (∃ (a:α), P a)) with A2 A2,
  {
    apply A2,
  },
  {
    exfalso,
    rw not_exists_iff_forall_not at A2,
    apply A1,
    apply A2,
  },
end

lemma canonically_ordered_comm_semiring.add_le_add_right {α:Type*}
    [canonically_ordered_comm_semiring α] (a b:α):a≤ b → (∀ c, a + c ≤ b + c) :=
begin
  intros A1 c,
  rw add_comm a c,
  rw add_comm b c,
  apply canonically_ordered_comm_semiring.add_le_add_left,
  apply A1,
end

--This seems to be legitimately new.
lemma  lt_iff_le_not_eq {α:Type*} [linear_order α] {a b:α}:
    (a < b) ↔ ((a ≤ b) ∧  (a ≠ b)) :=
begin
  split;intros A1,
  {
    split,
    {
      apply le_of_lt A1,
    },
    {
      apply ne_of_lt A1,
    },
  },
  {
    rw lt_iff_le_not_le,
    split,
    {
      apply A1.left,
    },
    {
      intro A2,
      apply A1.right,
      apply  le_antisymm,
      apply A1.left,
      apply A2,
    },
  },
end

lemma le_add_of_nonneg {β:Type*} [ordered_add_comm_monoid β] (a b:β):
  0 ≤ b → a ≤ a + b :=
begin
  intros A1,
  have B1:a + 0 ≤ a + b,
  {
    apply @add_le_add,
    apply le_refl a,
    apply A1,
  },
  rw add_zero at B1,
  apply B1,
end

lemma le_add_nonnegative {β:Type*} [canonically_ordered_add_monoid β] (a b:β):
  a ≤ a + b :=
begin
  apply le_add_of_nonneg,
  apply zero_le,
end