/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Nicolò Cavalleri
-/
import topology.algebra.module.basic
import topology.continuous_function.ordered
import topology.algebra.uniform_group
import topology.uniform_space.compact_convergence
import topology.algebra.star
import algebra.algebra.subalgebra.basic
import tactic.field_simp

/-!
# Algebraic structures over continuous functions

In this file we define instances of algebraic structures over the type `continuous_map α β`
(denoted `C(α, β)`) of **bundled** continuous maps from `α` to `β`. For example, `C(α, β)`
is a group when `β` is a group, a ring when `β` is a ring, etc.

For each type of algebraic structure, we also define an appropriate subobject of `α → β`
with carrier `{ f : α → β | continuous f }`. For example, when `β` is a group, a subgroup
`continuous_subgroup α β` of `α → β` is constructed with carrier `{ f : α → β | continuous f }`.

Note that, rather than using the derived algebraic structures on these subobjects
(for example, when `β` is a group, the derived group structure on `continuous_subgroup α β`),
one should use `C(α, β)` with the appropriate instance of the structure.
-/

local attribute [elab_simple] continuous.comp

namespace continuous_functions

variables {α : Type*} {β : Type*} [topological_space α] [topological_space β]
variables {f g : {f : α → β | continuous f }}

instance : has_coe_to_fun {f : α → β | continuous f} (λ _, α → β) :=  ⟨subtype.val⟩

end continuous_functions

namespace continuous_map
variables {α : Type*} {β : Type*} {γ : Type*}
variables [topological_space α] [topological_space β] [topological_space γ]

@[to_additive]
instance has_mul [has_mul β] [has_continuous_mul β] : has_mul C(α, β) :=
⟨λ f g, ⟨f * g, continuous_mul.comp (f.continuous.prod_mk g.continuous : _)⟩⟩

@[simp, norm_cast, to_additive]
lemma coe_mul [has_mul β] [has_continuous_mul β] (f g : C(α, β)) : ⇑(f * g) = f * g := rfl

@[simp, to_additive] lemma mul_comp [has_mul γ] [has_continuous_mul γ]
  (f₁ f₂ : C(β, γ)) (g : C(α, β)) :
  (f₁ * f₂).comp g = f₁.comp g * f₂.comp g :=
rfl

@[to_additive]
instance [has_one β] : has_one C(α, β) := ⟨const α 1⟩

@[simp, norm_cast, to_additive]
lemma coe_one [has_one β]  : ⇑(1 : C(α, β)) = 1 := rfl

@[simp, to_additive] lemma one_comp [has_one γ] (g : C(α, β)) : (1 : C(β, γ)).comp g = 1 := rfl

instance [has_nat_cast β] : has_nat_cast C(α, β) :=
⟨λ n, continuous_map.const _ n⟩

@[simp, norm_cast]
lemma coe_nat_cast [has_nat_cast β] (n : ℕ) : ((n : C(α, β)) : α → β) = n := rfl

instance [has_int_cast β] : has_int_cast C(α, β) :=
⟨λ n, continuous_map.const _ n⟩

@[simp, norm_cast]
lemma coe_int_cast [has_int_cast β] (n : ℤ) : ((n : C(α, β)) : α → β) = n := rfl

instance has_nsmul [add_monoid β] [has_continuous_add β] : has_scalar ℕ C(α, β) :=
⟨λ n f, ⟨n • f, f.continuous.nsmul n⟩⟩

@[to_additive]
instance has_pow [monoid β] [has_continuous_mul β] : has_pow C(α, β) ℕ :=
⟨λ f n, ⟨f ^ n, f.continuous.pow n⟩⟩

@[norm_cast, to_additive]
lemma coe_pow [monoid β] [has_continuous_mul β] (f : C(α, β)) (n : ℕ) :
  ⇑(f ^ n) = f ^ n := rfl

-- don't make `coe_nsmul` simp as the linter complains it's redundant WRT `coe_smul`
attribute [simp] coe_pow

@[to_additive] lemma pow_comp [monoid γ] [has_continuous_mul γ]
  (f : C(β, γ)) (n : ℕ) (g : C(α, β)) :
  (f^n).comp g = (f.comp g)^n :=
rfl

-- don't make `nsmul_comp` simp as the linter complains it's redundant WRT `smul_comp`
attribute [simp] pow_comp

@[to_additive]
instance [group β] [topological_group β] : has_inv C(α, β) :=
{ inv := λ f, ⟨f⁻¹, f.continuous.inv⟩ }

@[simp, norm_cast, to_additive]
lemma coe_inv [group β] [topological_group β] (f : C(α, β)) :
  ⇑(f⁻¹) = f⁻¹ :=
rfl

@[simp, to_additive] lemma inv_comp [group γ] [topological_group γ] (f : C(β, γ)) (g : C(α, β)) :
  (f⁻¹).comp g = (f.comp g)⁻¹ :=
rfl

@[to_additive]
instance [has_div β] [has_continuous_div β] : has_div C(α, β) :=
{ div := λ f g, ⟨f / g, f.continuous.div' g.continuous⟩ }

@[simp, norm_cast, to_additive]
lemma coe_div [has_div β] [has_continuous_div β] (f g : C(α, β)) : ⇑(f / g) = f / g :=
rfl

@[simp, to_additive] lemma div_comp [has_div γ] [has_continuous_div γ]
  (f g : C(β, γ)) (h : C(α, β)) :
  (f / g).comp h = (f.comp h) / (g.comp h) :=
rfl

instance has_zsmul [add_group β] [topological_add_group β] : has_scalar ℤ C(α, β) :=
{ smul := λ z f, ⟨z • f, f.continuous.zsmul z⟩ }

@[to_additive]
instance has_zpow [group β] [topological_group β] :
  has_pow C(α, β) ℤ :=
{ pow := λ f z, ⟨f ^ z, f.continuous.zpow z⟩ }

@[norm_cast, to_additive]
lemma coe_zpow [group β] [topological_group β] (f : C(α, β)) (z : ℤ) :
  ⇑(f ^ z) = f ^ z :=
rfl

-- don't make `coe_zsmul` simp as the linter complains it's redundant WRT `coe_smul`
attribute [simp] coe_zpow

@[to_additive]
lemma zpow_comp [group γ] [topological_group γ] (f : C(β, γ)) (z : ℤ) (g : C(α, β)) :
  (f^z).comp g = (f.comp g)^z :=
rfl

-- don't make `zsmul_comp` simp as the linter complains it's redundant WRT `smul_comp`
attribute [simp] zpow_comp

end continuous_map

section group_structure

/-!
### Group stucture

In this section we show that continuous functions valued in a topological group inherit
the structure of a group.
-/

section subtype

/-- The `submonoid` of continuous maps `α → β`. -/
@[to_additive "The `add_submonoid` of continuous maps `α → β`. "]
def continuous_submonoid (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  [monoid β] [has_continuous_mul β] : submonoid (α → β) :=
{ carrier := { f : α → β | continuous f },
  one_mem' := @continuous_const _ _ _ _ 1,
  mul_mem' := λ f g fc gc, continuous.comp
    has_continuous_mul.continuous_mul (continuous.prod_mk fc gc : _) }

/-- The subgroup of continuous maps `α → β`. -/
@[to_additive "The `add_subgroup` of continuous maps `α → β`. "]
def continuous_subgroup (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  [group β] [topological_group β] : subgroup (α → β) :=
{ inv_mem' := λ f fc, continuous.inv fc,
  ..continuous_submonoid α β, }.

end subtype

namespace continuous_map

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [semigroup β] [has_continuous_mul β] : semigroup C(α, β) :=
coe_injective.semigroup _ coe_mul

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_semigroup β] [has_continuous_mul β] : comm_semigroup C(α, β) :=
coe_injective.comm_semigroup _ coe_mul

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [mul_one_class β] [has_continuous_mul β] : mul_one_class C(α, β) :=
coe_injective.mul_one_class _ coe_one coe_mul

instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [mul_zero_class β] [has_continuous_mul β] : mul_zero_class C(α, β) :=
coe_injective.mul_zero_class _ coe_zero coe_mul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [semigroup_with_zero β] [has_continuous_mul β] : semigroup_with_zero C(α, β) :=
coe_injective.semigroup_with_zero _ coe_zero coe_mul

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [monoid β] [has_continuous_mul β] : monoid C(α, β) :=
coe_injective.monoid _ coe_one coe_mul coe_pow

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [monoid_with_zero β] [has_continuous_mul β] : monoid_with_zero C(α, β) :=
coe_injective.monoid_with_zero _ coe_zero coe_one coe_mul coe_pow

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_monoid β] [has_continuous_mul β] : comm_monoid C(α, β) :=
coe_injective.comm_monoid _ coe_one coe_mul coe_pow

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [comm_monoid_with_zero β] [has_continuous_mul β] : comm_monoid_with_zero C(α, β) :=
coe_injective.comm_monoid_with_zero _ coe_zero coe_one coe_mul coe_pow

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α]
  [locally_compact_space α] [topological_space β]
  [has_mul β] [has_continuous_mul β] : has_continuous_mul C(α, β) :=
⟨begin
  refine continuous_of_continuous_uncurry _ _,
  have h1 : continuous (λ x : (C(α, β) × C(α, β)) × α, x.fst.fst x.snd) :=
    continuous_eval'.comp (continuous_fst.prod_map continuous_id),
  have h2 : continuous (λ x : (C(α, β) × C(α, β)) × α, x.fst.snd x.snd) :=
    continuous_eval'.comp (continuous_snd.prod_map continuous_id),
  exact h1.mul h2,
end⟩

/-- Coercion to a function as an `monoid_hom`. Similar to `monoid_hom.coe_fn`. -/
@[to_additive "Coercion to a function as an `add_monoid_hom`. Similar to `add_monoid_hom.coe_fn`.",
  simps]
def coe_fn_monoid_hom {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [monoid β] [has_continuous_mul β] : C(α, β) →* (α → β) :=
{ to_fun := coe_fn, map_one' := coe_one, map_mul' := coe_mul }

/-- Composition on the left by a (continuous) homomorphism of topological monoids, as a
`monoid_hom`. Similar to `monoid_hom.comp_left`. -/
@[to_additive "Composition on the left by a (continuous) homomorphism of topological `add_monoid`s,
as an `add_monoid_hom`. Similar to `add_monoid_hom.comp_left`.", simps]
protected def _root_.monoid_hom.comp_left_continuous (α : Type*) {β : Type*} {γ : Type*}
  [topological_space α] [topological_space β] [monoid β] [has_continuous_mul β]
  [topological_space γ] [monoid γ] [has_continuous_mul γ] (g : β →* γ) (hg : continuous g)  :
  C(α, β) →* C(α, γ) :=
{ to_fun := λ f, (⟨g, hg⟩ : C(β, γ)).comp f,
  map_one' := ext $ λ x, g.map_one,
  map_mul' := λ f₁ f₂, ext $ λ x, g.map_mul _ _ }

/-- Composition on the right as a `monoid_hom`. Similar to `monoid_hom.comp_hom'`. -/
@[to_additive "Composition on the right as an `add_monoid_hom`. Similar to
`add_monoid_hom.comp_hom'`.", simps]
def comp_monoid_hom' {α : Type*} {β : Type*} {γ : Type*}
  [topological_space α] [topological_space β] [topological_space γ]
  [mul_one_class γ] [has_continuous_mul γ] (g : C(α, β)) : C(β, γ) →* C(α, γ) :=
{ to_fun := λ f, f.comp g, map_one' := one_comp g, map_mul' := λ f₁ f₂, mul_comp f₁ f₂ g }

open_locale big_operators
@[simp, to_additive] lemma coe_prod {α : Type*} {β : Type*} [comm_monoid β]
  [topological_space α] [topological_space β] [has_continuous_mul β]
  {ι : Type*} (s : finset ι) (f : ι → C(α, β)) :
  ⇑(∏ i in s, f i) = (∏ i in s, (f i : α → β)) :=
(coe_fn_monoid_hom : C(α, β) →* _).map_prod f s

@[to_additive]
lemma prod_apply {α : Type*} {β : Type*} [comm_monoid β]
  [topological_space α] [topological_space β] [has_continuous_mul β]
  {ι : Type*} (s : finset ι) (f : ι → C(α, β)) (a : α) :
  (∏ i in s, f i) a = (∏ i in s, f i a) :=
by simp

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [group β] [topological_group β] : group C(α, β) :=
coe_injective.group _ coe_one coe_mul coe_inv coe_div coe_pow coe_zpow

@[to_additive]
instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_group β] [topological_group β] : comm_group C(α, β) :=
coe_injective.comm_group _ coe_one coe_mul coe_inv coe_div coe_pow coe_zpow

@[to_additive] instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_group β] [topological_group β] : topological_group C(α, β) :=
{ continuous_mul := by
  { letI : uniform_space β := topological_group.to_uniform_space β,
    have : uniform_group β := topological_group_is_uniform,
    rw continuous_iff_continuous_at,
    rintros ⟨f, g⟩,
    rw [continuous_at, tendsto_iff_forall_compact_tendsto_uniformly_on, nhds_prod_eq],
    exactI λ K hK, uniform_continuous_mul.comp_tendsto_uniformly_on
      ((tendsto_iff_forall_compact_tendsto_uniformly_on.mp filter.tendsto_id K hK).prod
      (tendsto_iff_forall_compact_tendsto_uniformly_on.mp filter.tendsto_id K hK)), },
  continuous_inv := by
  { letI : uniform_space β := topological_group.to_uniform_space β,
    have : uniform_group β := topological_group_is_uniform,
    rw continuous_iff_continuous_at,
    intro f,
    rw [continuous_at, tendsto_iff_forall_compact_tendsto_uniformly_on],
    exactI λ K hK, uniform_continuous_inv.comp_tendsto_uniformly_on
      (tendsto_iff_forall_compact_tendsto_uniformly_on.mp filter.tendsto_id K hK), } }

end continuous_map

end group_structure

section ring_structure

/-!
### Ring stucture

In this section we show that continuous functions valued in a topological semiring `R` inherit
the structure of a ring.
-/

section subtype

/-- The subsemiring of continuous maps `α → β`. -/
def continuous_subsemiring (α : Type*) (R : Type*) [topological_space α] [topological_space R]
  [semiring R] [topological_semiring R] : subsemiring (α → R) :=
{ ..continuous_add_submonoid α R,
  ..continuous_submonoid α R }

/-- The subring of continuous maps `α → β`. -/
def continuous_subring (α : Type*) (R : Type*) [topological_space α] [topological_space R]
  [ring R] [topological_ring R] : subring (α → R) :=
{ ..continuous_subsemiring α R,
  ..continuous_add_subgroup α R }

end subtype

namespace continuous_map

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_non_assoc_semiring β] [topological_semiring β] :
  non_unital_non_assoc_semiring C(α, β) :=
coe_injective.non_unital_non_assoc_semiring _ coe_zero coe_add coe_mul coe_nsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_semiring β] [topological_semiring β] :
  non_unital_semiring C(α, β) :=
coe_injective.non_unital_semiring _ coe_zero coe_add coe_mul coe_nsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [add_monoid_with_one β] [has_continuous_add β] :
  add_monoid_with_one C(α, β) :=
coe_injective.add_monoid_with_one _ coe_zero coe_one coe_add coe_nsmul coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_assoc_semiring β] [topological_semiring β] :
  non_assoc_semiring C(α, β) :=
coe_injective.non_assoc_semiring _ coe_zero coe_one coe_add coe_mul coe_nsmul coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [semiring β] [topological_semiring β] : semiring C(α, β) :=
coe_injective.semiring _ coe_zero coe_one coe_add coe_mul coe_nsmul coe_pow coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_non_assoc_ring β] [topological_ring β] : non_unital_non_assoc_ring C(α, β) :=
coe_injective.non_unital_non_assoc_ring _ coe_zero coe_add coe_mul coe_neg coe_sub
  coe_nsmul coe_zsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_ring β] [topological_ring β] : non_unital_ring C(α, β) :=
coe_injective.non_unital_ring _ coe_zero coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_assoc_ring β] [topological_ring β] : non_assoc_ring C(α, β) :=
coe_injective.non_assoc_ring _ coe_zero coe_one coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul
  coe_nat_cast coe_int_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [ring β] [topological_ring β] : ring C(α, β) :=
coe_injective.ring _ coe_zero coe_one coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul coe_pow
  coe_nat_cast coe_int_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_comm_semiring β] [topological_semiring β] : non_unital_comm_semiring C(α, β) :=
coe_injective.non_unital_comm_semiring _ coe_zero coe_add coe_mul coe_nsmul

instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_semiring β] [topological_semiring β] : comm_semiring C(α, β) :=
coe_injective.comm_semiring _ coe_zero coe_one coe_add coe_mul coe_nsmul coe_pow coe_nat_cast

instance {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [non_unital_comm_ring β] [topological_ring β] : non_unital_comm_ring C(α, β) :=
coe_injective.non_unital_comm_ring _ coe_zero coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul

instance {α : Type*} {β : Type*} [topological_space α]
  [topological_space β] [comm_ring β] [topological_ring β] : comm_ring C(α, β) :=
coe_injective.comm_ring _ coe_zero coe_one coe_add coe_mul coe_neg coe_sub coe_nsmul coe_zsmul
  coe_pow coe_nat_cast coe_int_cast

/-- Composition on the left by a (continuous) homomorphism of topological semirings, as a
`ring_hom`.  Similar to `ring_hom.comp_left`. -/
@[simps] protected def _root_.ring_hom.comp_left_continuous (α : Type*) {β : Type*} {γ : Type*}
  [topological_space α] [topological_space β] [semiring β] [topological_semiring β]
  [topological_space γ] [semiring γ] [topological_semiring γ] (g : β →+* γ) (hg : continuous g) :
  C(α, β) →+* C(α, γ) :=
{ .. g.to_monoid_hom.comp_left_continuous α hg,
  .. g.to_add_monoid_hom.comp_left_continuous α hg }

/-- Coercion to a function as a `ring_hom`. -/
@[simps]
def coe_fn_ring_hom {α : Type*} {β : Type*} [topological_space α] [topological_space β]
  [ring β] [topological_ring β] : C(α, β) →+* (α → β) :=
{ to_fun := coe_fn,
  ..(coe_fn_monoid_hom : C(α, β) →* _),
  ..(coe_fn_add_monoid_hom : C(α, β) →+ _) }

end continuous_map

end ring_structure

local attribute [ext] subtype.eq

section module_structure

/-!
### Semiodule stucture

In this section we show that continuous functions valued in a topological module `M` over a
topological semiring `R` inherit the structure of a module.
-/

section subtype

variables (α : Type*) [topological_space α]
variables (R : Type*) [semiring R]
variables (M : Type*) [topological_space M] [add_comm_group M]
variables [module R M] [has_continuous_const_smul R M] [topological_add_group M]

/-- The `R`-submodule of continuous maps `α → M`. -/
def continuous_submodule : submodule R (α → M) :=
{ carrier := { f : α → M | continuous f },
  smul_mem' := λ c f hf, hf.const_smul c,
  ..continuous_add_subgroup α M }

end subtype

namespace continuous_map
variables {α β : Type*} [topological_space α] [topological_space β]
  {R R₁ : Type*}
  {M : Type*} [topological_space M]
  {M₂ : Type*} [topological_space M₂]

@[to_additive continuous_map.has_vadd]
instance [has_scalar R M] [has_continuous_const_smul R M] : has_scalar R C(α, M) :=
⟨λ r f, ⟨r • f, f.continuous.const_smul r⟩⟩

@[to_additive]
instance [locally_compact_space α] [has_scalar R M] [has_continuous_const_smul R M] :
  has_continuous_const_smul R C(α, M) :=
⟨λ γ, continuous_of_continuous_uncurry _ (continuous_eval'.const_smul γ)⟩

@[to_additive]
instance [locally_compact_space α] [topological_space R] [has_scalar R M]
  [has_continuous_smul R M] : has_continuous_smul R C(α, M) :=
⟨begin
  refine continuous_of_continuous_uncurry _ _,
  have h : continuous (λ x : (R × C(α, M)) × α, x.fst.snd x.snd) :=
    continuous_eval'.comp (continuous_snd.prod_map continuous_id),
  exact (continuous_fst.comp continuous_fst).smul h,
end⟩

@[simp, to_additive, norm_cast]
lemma coe_smul [has_scalar R M] [has_continuous_const_smul R M]
  (c : R) (f : C(α, M)) : ⇑(c • f) = c • f := rfl

@[to_additive]
lemma smul_apply [has_scalar R M] [has_continuous_const_smul R M]
  (c : R) (f : C(α, M)) (a : α) : (c • f) a = c • (f a) :=
rfl

@[simp, to_additive] lemma smul_comp [has_scalar R M] [has_continuous_const_smul R M]
  (r : R) (f : C(β, M)) (g : C(α, β)) :
  (r • f).comp g = r • (f.comp g) :=
rfl

@[to_additive]
instance [has_scalar R M] [has_continuous_const_smul R M]
  [has_scalar R₁ M] [has_continuous_const_smul R₁ M]
  [smul_comm_class R R₁ M] : smul_comm_class R R₁ C(α, M) :=
{ smul_comm := λ _ _ _, ext $ λ _, smul_comm _ _ _ }

instance [has_scalar R M] [has_continuous_const_smul R M]
  [has_scalar R₁ M] [has_continuous_const_smul R₁ M]
  [has_scalar R R₁] [is_scalar_tower R R₁ M] : is_scalar_tower R R₁ C(α, M) :=
{ smul_assoc := λ _ _ _, ext $ λ _, smul_assoc _ _ _ }

instance [has_scalar R M] [has_scalar Rᵐᵒᵖ M] [has_continuous_const_smul R M]
  [is_central_scalar R M] : is_central_scalar R C(α, M) :=
{ op_smul_eq_smul := λ _ _, ext $ λ _, op_smul_eq_smul _ _ }

instance [monoid R] [mul_action R M] [has_continuous_const_smul R M] : mul_action R C(α, M) :=
function.injective.mul_action _ coe_injective coe_smul

instance [monoid R] [add_monoid M] [distrib_mul_action R M]
  [has_continuous_add M] [has_continuous_const_smul R M] :
  distrib_mul_action R C(α, M) :=
function.injective.distrib_mul_action coe_fn_add_monoid_hom coe_injective coe_smul

variables [semiring R] [add_comm_monoid M] [add_comm_monoid M₂]
variables [has_continuous_add M] [module R M] [has_continuous_const_smul R M]
variables [has_continuous_add M₂] [module R M₂] [has_continuous_const_smul R M₂]

instance module : module R C(α, M) :=
function.injective.module R coe_fn_add_monoid_hom coe_injective coe_smul

variables (R)

/-- Composition on the left by a continuous linear map, as a `linear_map`.
Similar to `linear_map.comp_left`. -/
@[simps] protected def _root_.continuous_linear_map.comp_left_continuous (α : Type*)
  [topological_space α] (g : M →L[R] M₂) :
  C(α, M) →ₗ[R] C(α, M₂) :=
{ map_smul' := λ c f, ext $ λ x, g.map_smul' c _,
  .. g.to_linear_map.to_add_monoid_hom.comp_left_continuous α g.continuous }

/-- Coercion to a function as a `linear_map`. -/
@[simps]
def coe_fn_linear_map : C(α, M) →ₗ[R] (α → M) :=
{ to_fun := coe_fn,
  map_smul' := coe_smul,
  ..(coe_fn_add_monoid_hom : C(α, M) →+ _) }

end continuous_map

end module_structure

section algebra_structure

/-!
### Algebra structure

In this section we show that continuous functions valued in a topological algebra `A` over a ring
`R` inherit the structure of an algebra. Note that the hypothesis that `A` is a topological algebra
is obtained by requiring that `A` be both a `has_continuous_smul` and a `topological_semiring`.-/

section subtype

variables {α : Type*} [topological_space α]
{R : Type*} [comm_semiring R]
{A : Type*} [topological_space A] [semiring A]
[algebra R A] [topological_semiring A]

/-- The `R`-subalgebra of continuous maps `α → A`. -/
def continuous_subalgebra : subalgebra R (α → A) :=
{ carrier := { f : α → A | continuous f },
  algebra_map_mem' := λ r, (continuous_const : continuous $ λ (x : α), algebra_map R A r),
  ..continuous_subsemiring α A }

end subtype

section continuous_map

variables {α : Type*} [topological_space α]
{R : Type*} [comm_semiring R]
{A : Type*} [topological_space A] [semiring A]
[algebra R A] [topological_semiring A]
{A₂ : Type*} [topological_space A₂] [semiring A₂]
[algebra R A₂] [topological_semiring A₂]

/-- Continuous constant functions as a `ring_hom`. -/
def continuous_map.C : R →+* C(α, A) :=
{ to_fun    := λ c : R, ⟨λ x: α, ((algebra_map R A) c), continuous_const⟩,
  map_one'  := by ext x; exact (algebra_map R A).map_one,
  map_mul'  := λ c₁ c₂, by ext x; exact (algebra_map R A).map_mul _ _,
  map_zero' := by ext x; exact (algebra_map R A).map_zero,
  map_add'  := λ c₁ c₂, by ext x; exact (algebra_map R A).map_add _ _ }

@[simp] lemma continuous_map.C_apply (r : R) (a : α) : continuous_map.C r a = algebra_map R A r :=
rfl

variables [has_continuous_const_smul R A] [has_continuous_const_smul R A₂]

instance continuous_map.algebra : algebra R C(α, A) :=
{ to_ring_hom := continuous_map.C,
  commutes' := λ c f, by ext x; exact algebra.commutes' _ _,
  smul_def' := λ c f, by ext x; exact algebra.smul_def' _ _, }

variables (R)

/-- Composition on the left by a (continuous) homomorphism of topological `R`-algebras, as an
`alg_hom`. Similar to `alg_hom.comp_left`. -/
@[simps] protected def alg_hom.comp_left_continuous {α : Type*} [topological_space α]
  (g : A →ₐ[R] A₂) (hg : continuous g) :
  C(α, A) →ₐ[R] C(α, A₂) :=
{ commutes' := λ c, continuous_map.ext $ λ _, g.commutes' _,
  .. g.to_ring_hom.comp_left_continuous α hg }

/-- Coercion to a function as an `alg_hom`. -/
@[simps]
def continuous_map.coe_fn_alg_hom : C(α, A) →ₐ[R] (α → A) :=
{ to_fun := coe_fn,
  commutes' := λ r, rfl,
  -- `..(continuous_map.coe_fn_ring_hom : C(α, A) →+* _)` times out for some reason
  map_zero' := continuous_map.coe_zero,
  map_one' := continuous_map.coe_one,
  map_add' := continuous_map.coe_add,
  map_mul' := continuous_map.coe_mul }

variables {R}

/--
A version of `separates_points` for subalgebras of the continuous functions,
used for stating the Stone-Weierstrass theorem.
-/
abbreviation subalgebra.separates_points (s : subalgebra R C(α, A)) : Prop :=
set.separates_points ((λ f : C(α, A), (f : α → A)) '' (s : set C(α, A)))

lemma subalgebra.separates_points_monotone :
  monotone (λ s : subalgebra R C(α, A), s.separates_points) :=
λ s s' r h x y n,
begin
  obtain ⟨f, m, w⟩ := h n,
  rcases m with ⟨f, ⟨m, rfl⟩⟩,
  exact ⟨_, ⟨f, ⟨r m, rfl⟩⟩, w⟩,
end

@[simp] lemma algebra_map_apply (k : R) (a : α) :
  algebra_map R C(α, A) k a = k • 1 :=
by { rw algebra.algebra_map_eq_smul_one, refl, }

variables {𝕜 : Type*} [topological_space 𝕜]

/--
A set of continuous maps "separates points strongly"
if for each pair of distinct points there is a function with specified values on them.

We give a slightly unusual formulation, where the specified values are given by some
function `v`, and we ask `f x = v x ∧ f y = v y`. This avoids needing a hypothesis `x ≠ y`.

In fact, this definition would work perfectly well for a set of non-continuous functions,
but as the only current use case is in the Stone-Weierstrass theorem,
writing it this way avoids having to deal with casts inside the set.
(This may need to change if we do Stone-Weierstrass on non-compact spaces,
where the functions would be continuous functions vanishing at infinity.)
-/
def set.separates_points_strongly (s : set C(α, 𝕜)) : Prop :=
∀ (v : α → 𝕜) (x y : α), ∃ f : s, (f x : 𝕜) = v x ∧ f y = v y

variables [field 𝕜] [topological_ring 𝕜]

/--
Working in continuous functions into a topological field,
a subalgebra of functions that separates points also separates points strongly.

By the hypothesis, we can find a function `f` so `f x ≠ f y`.
By an affine transformation in the field we can arrange so that `f x = a` and `f x = b`.
-/
lemma subalgebra.separates_points.strongly {s : subalgebra 𝕜 C(α, 𝕜)} (h : s.separates_points) :
  (s : set C(α, 𝕜)).separates_points_strongly :=
λ v x y,
begin
  by_cases n : x = y,
  { subst n,
    use ((v x) • 1 : C(α, 𝕜)),
    { apply s.smul_mem,
      apply s.one_mem, },
    { simp [coe_fn_coe_base'] }, },
  obtain ⟨f, ⟨f, ⟨m, rfl⟩⟩, w⟩ := h n,
  replace w : f x - f y ≠ 0 := sub_ne_zero_of_ne w,
  let a := v x,
  let b := v y,
  let f' := ((b - a) * (f x - f y)⁻¹) • (continuous_map.C (f x) - f) + continuous_map.C a,
  refine ⟨⟨f', _⟩, _, _⟩,
  { simp only [f', set_like.mem_coe, subalgebra.mem_to_submodule],
    -- TODO should there be a tactic for this?
    -- We could add an attribute `@[subobject_mem]`, and a tactic
    -- ``def subobject_mem := `[solve_by_elim with subobject_mem { max_depth := 10 }]``
    solve_by_elim
      [subalgebra.add_mem, subalgebra.smul_mem, subalgebra.sub_mem, subalgebra.algebra_map_mem]
      { max_depth := 6 }, },
  { simp [f', coe_fn_coe_base'], },
  { simp [f', coe_fn_coe_base', inv_mul_cancel_right₀ w], },
end

end continuous_map

-- TODO[gh-6025]: make this an instance once safe to do so
lemma continuous_map.subsingleton_subalgebra (α : Type*) [topological_space α]
  (R : Type*) [comm_semiring R] [topological_space R] [topological_semiring R]
  [subsingleton α] : subsingleton (subalgebra R C(α, R)) :=
begin
  fsplit,
  intros s₁ s₂,
  by_cases n : nonempty α,
  { obtain ⟨x⟩ := n,
    ext f,
    have h : f = algebra_map R C(α, R) (f x),
    { ext x', simp only [mul_one, algebra.id.smul_eq_mul, algebra_map_apply], congr, },
    rw h,
    simp only [subalgebra.algebra_map_mem], },
  { ext f,
    have h : f = 0,
    { ext x', exact false.elim (n ⟨x'⟩), },
    subst h,
    simp only [subalgebra.zero_mem], },
end

end algebra_structure

section module_over_continuous_functions

/-!
### Structure as module over scalar functions

If `M` is a module over `R`, then we show that the space of continuous functions from `α` to `M`
is naturally a module over the ring of continuous functions from `α` to `R`. -/

namespace continuous_map

instance has_scalar' {α : Type*} [topological_space α]
  {R : Type*} [semiring R] [topological_space R]
  {M : Type*} [topological_space M] [add_comm_monoid M]
  [module R M] [has_continuous_smul R M] :
  has_scalar C(α, R) C(α, M) :=
⟨λ f g, ⟨λ x, (f x) • (g x), (continuous.smul f.2 g.2)⟩⟩

instance module' {α : Type*} [topological_space α]
  (R : Type*) [ring R] [topological_space R] [topological_ring R]
  (M : Type*) [topological_space M] [add_comm_monoid M] [has_continuous_add M]
  [module R M] [has_continuous_smul R M] :
  module C(α, R) C(α, M) :=
{ smul     := (•),
  smul_add := λ c f g, by ext x; exact smul_add (c x) (f x) (g x),
  add_smul := λ c₁ c₂ f, by ext x; exact add_smul (c₁ x) (c₂ x) (f x),
  mul_smul := λ c₁ c₂ f, by ext x; exact mul_smul (c₁ x) (c₂ x) (f x),
  one_smul := λ f, by ext x; exact one_smul R (f x),
  zero_smul := λ f, by ext x; exact zero_smul _ _,
  smul_zero := λ r, by ext x; exact smul_zero _, }

end continuous_map

end module_over_continuous_functions

/-!
We now provide formulas for `f ⊓ g` and `f ⊔ g`, where `f g : C(α, β)`,
in terms of `continuous_map.abs`.
-/

section
variables {R : Type*} [linear_ordered_field R]

-- TODO:
-- This lemma (and the next) could go all the way back in `algebra.order.field`,
-- except that it is tedious to prove without tactics.
-- Rather than stranding it at some intermediate location,
-- it's here, immediately prior to the point of use.
lemma min_eq_half_add_sub_abs_sub {x y : R} : min x y = 2⁻¹ * (x + y - |x - y|) :=
by cases le_total x y with h h; field_simp [h, abs_of_nonneg, abs_of_nonpos, mul_two]; abel

lemma max_eq_half_add_add_abs_sub {x y : R} : max x y = 2⁻¹ * (x + y + |x - y|) :=
by cases le_total x y with h h; field_simp [h, abs_of_nonneg, abs_of_nonpos, mul_two]; abel

end

namespace continuous_map

section lattice
variables {α : Type*} [topological_space α]
variables {β : Type*} [linear_ordered_field β] [topological_space β]
  [order_topology β] [topological_ring β]

lemma inf_eq (f g : C(α, β)) : f ⊓ g = (2⁻¹ : β) • (f + g - |f - g|) :=
ext (λ x, by simpa using min_eq_half_add_sub_abs_sub)

-- Not sure why this is grosser than `inf_eq`:
lemma sup_eq (f g : C(α, β)) : f ⊔ g = (2⁻¹ : β) • (f + g + |f - g|) :=
ext (λ x, by simpa [mul_add] using @max_eq_half_add_add_abs_sub _ _ (f x) (g x))

end lattice

/-!
### Star structure

If `β` has a continuous star operation, we put a star structure on `C(α, β)` by using the
star operation pointwise.

If `β` is a ⋆-ring, then `C(α, β)` inherits a ⋆-ring structure.

If `β` is a ⋆-ring and a ⋆-module over `R`, then the space of continuous functions from `α` to `β`
is a ⋆-module over `R`.

-/

section star_structure
variables {R α β : Type*}
variables [topological_space α] [topological_space β]

section has_star
variables [has_star β] [has_continuous_star β]

instance : has_star C(α, β) :=
{ star := λ f, star_continuous_map.comp f }

@[simp] lemma coe_star (f : C(α, β)) : ⇑(star f) = star f := rfl

@[simp] lemma star_apply (f : C(α, β)) (x : α) : star f x = star (f x) := rfl

end has_star

instance [has_involutive_star β] [has_continuous_star β] : has_involutive_star C(α, β) :=
{ star_involutive := λ f, ext $ λ x, star_star _ }

instance [add_monoid β] [has_continuous_add β] [star_add_monoid β] [has_continuous_star β] :
  star_add_monoid C(α, β) :=
{ star_add := λ f g, ext $ λ x, star_add _ _ }

instance [semigroup β] [has_continuous_mul β] [star_semigroup β] [has_continuous_star β] :
  star_semigroup C(α, β) :=
{ star_mul := λ f g, ext $ λ x, star_mul _ _ }

instance [non_unital_semiring β] [topological_semiring β] [star_ring β] [has_continuous_star β] :
  star_ring C(α, β) :=
{ ..continuous_map.star_add_monoid }

instance [has_star R] [has_star β] [has_scalar R β] [star_module R β]
  [has_continuous_star β] [has_continuous_const_smul R β] :
  star_module R C(α, β) :=
{ star_smul := λ k f, ext $ λ x, star_smul _ _ }

end star_structure

end continuous_map


import ECTate.Algebra.Ring.Basic
import ECTate.Algebra.CharP.Basic
import ECTate.FieldTheory.PerfectClosure
import Mathlib.Tactic.SplitIfs
import Mathlib.Tactic.NormNum
import Mathlib.Tactic.Ring
import Mathlib.Tactic.PrintPrefix
import Mathlib.Tactic.LibrarySearch
import Mathlib.Util.WhatsNew
-- import Aesop

-- TODO cleanup variables, sections assumption strength

--#print AddCommGroup.toDivisionCommMonoid -- TODO a way to tell if this works

/-- A model of a (possibly singular) elliptic curve is given
by `a` invariants $$a₁, a₂, a₃, a₄, a₆$$ which represent the curve
$$
y^2 + a₁ xy + a₃ y = x^ 3 + a₂ x ^ 2 + a₄ x + a₆
$$
-/
structure Model (R : Type u) [CommRing R] where
  (a1 a2 a3 a4 a6 : R)
deriving Inhabited, DecidableEq

namespace Model
variable {R : Type u} [CommRing R]

instance [Repr R] : Repr (Model R) := ⟨λ (e : Model R) _ => repr (e.a1, e.a2, e.a3, e.a4, e.a6)⟩

def b2 (e : Model R) : R := e.a1 * e.a1 + 4 * e.a2

def b4 (e : Model R) : R := e.a1 * e.a3 + 2 * e.a4

def b6 (e : Model R) : R := e.a3 * e.a3 + 4 * e.a6

def b8 (e : Model R) : R :=
  e.a1*e.a1*e.a6 - e.a1*e.a3*e.a4 + 4*e.a2*e.a6 + e.a2*e.a3*e.a3 - e.a4*e.a4

/-- From Connell -/
def b5 (e : Model R) : R := e.a1 * e.a4 - 2 * e.a2 * e.a3

def b7 (e : Model R) : R := e.a1 * (e.a3 ^ 2 - 12 * e.a6) + 8 * e.a3 * e.a4

lemma b8_identity (e : Model R) : 4*e.b8 = e.b2*e.b6 - e.b4 ^ 2 :=
by
  simp only [b2, b4, b6, b8]
  ring

def c4 (e : Model R) : R := e.b2 ^ 2 - 24*e.b4

def c6 (e : Model R) : R := -e.b2 ^ 3 + 36*e.b2*e.b4 - 216*e.b6

def discr (e : Model R) : R :=
  -e.b2 * e.b2 * e.b8 - 8 * e.b4 ^ 3 - 27 * e.b6 * e.b6 + 9 * e.b2 * e.b4 * e.b6

lemma discr_identity (e : Model R) : 1728 * e.discr = e.c4 ^ 3 - e.c6 ^ 2 :=
by
  simp only [c4, c6, discr, mul_sub, mul_add]
  rw [(by ring : 1728 * (-e.b2 * e.b2 * e.b8) = -432 * e.b2 * e.b2 * (4 * e.b8))]
  rw [b8_identity]
  ring

def rst_iso (r s t : R) (e : Model R) : Model R :=
{ a1 := e.a1 + 2*s
  a2 := e.a2 - s*e.a1 + 3*r - s*s
  a3 := e.a3 + r*e.a1 + 2*t
  a4 := e.a4 - s*e.a3 + 2*r*e.a2 - (t+r*s)*e.a1 + 3*r*r - 2*s*t
  a6 := e.a6 + r*e.a4 + r*r*e.a2 + r*r*r - t*(e.a3 + t + r*e.a1) }

lemma rst_b2 (r s t : R) (e : Model R) : (rst_iso r s t e).b2 = e.b2 + 12*r := by
  simp [rst_iso, b2]
  ring

lemma rst_b4 (r s t : R) (e : Model R) :
  (rst_iso r s t e).b4 = e.b4 + r * (e.b2 + 6 * r) :=
by
  simp only [rst_iso, b2, b4]
  ring

lemma rst_b6 (r s t : R) (e : Model R) :
  (rst_iso r s t e).b6 = e.b6 + 2*r*e.b4 + r*r*e.b2 + 4*r*r*r :=
by
  simp only [rst_iso, b2, b4, b6]
  ring

lemma rst_b8 (r s t : R) (e : Model R) :
  (rst_iso r s t e).b8 = e.b8 + 3*r*e.b6 + 3*r*r*e.b4 + r*r*r*e.b2 + 3*r*r*r*r :=
by
  simp only [rst_iso, b2, b4, b6, b8]
  ring

@[simp]
lemma rst_c4 (r s t : R) (e : Model R) :
  (rst_iso r s t e).c4 = e.c4 :=
by
  simp only [rst_iso, b2, b4, b6, b8, c4]
  ring

@[simp]
lemma rst_c6 (r s t : R) (e : Model R) :
  (rst_iso r s t e).c6 = e.c6 :=
by
  simp only [rst_iso, b2, b4, b6, b8, c6]
  ring

lemma rst_discr (r s t : R) (e : Model R) : (rst_iso r s t e).discr = e.discr :=
by
  simp only [discr, rst_b2, rst_b4, rst_b6, rst_b8]
  simp only [mul_add]
  rw [(by ring : (-(b2 e + 12 * r) * b2 e + -(b2 e + 12 * r) * (12 * r)) * b8 e = -(b2 e ^ 2 * b8 e) + (- (3 * r) * b2 e + -(b2 e + 12 * r) * (3 * r)) * (4 * b8 e))]
  rw [b8_identity]
  ring

section Map

variable {R S : Type u} [CommRing R] [CommRing S] (f : R →+* S)

@[simps]
def map : Model R → Model S := fun e => ⟨f e.a1, f e.a2, f e.a3, f e.a4, f e.a6⟩

@[simp] lemma map_b2 : (map f e).b2 = f e.b2 := by simp [Model.b2, (by norm_num : (4 : R) = 1 + 1 + 1 + 1)]; norm_num
@[simp] lemma map_b4 : (map f e).b4 = f e.b4 := by simp [Model.b4, (by norm_num : (2 : R) = 1 + 1)]; norm_num
@[simp] lemma map_b5 : (map f e).b5 = f e.b5 := by simp [Model.b5, (by norm_num : (2 : R) = 1 + 1)]; norm_num
@[simp] lemma map_b6 : (map f e).b6 = f e.b6 := by simp [Model.b6, (by norm_num : (4 : R) = 1 + 1 + 1 + 1)]; norm_num
@[simp] lemma map_b7 : (map f e).b7 = f e.b7 := by simp [Model.b7, (by norm_num : (8 : R) = 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1), (by norm_num : (12 : R) = 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1)]; norm_num
@[simp] lemma map_b8 : (map f e).b8 = f e.b8 := by simp [Model.b8, (by norm_num : (4 : R) = 1 + 1 + 1 + 1)]; norm_num

@[simp] lemma map_c4 : (map f e).c4 = f e.c4 := by simp [Model.c4, (by norm_num : (36 : R) = (1 + 1) ^ 2 * (1 + 1 + 1)^2), (by norm_num : (24 : R) = (1 + 1) ^ 3 * (1 + 1 + 1))]; norm_num
@[simp] lemma map_c6 : (map f e).c6 = f e.c6 := by simp [Model.c6, (by norm_num : (36 : R) = (1 + 1) ^ 2 * (1 + 1 + 1)^2), (by norm_num : (216 : R) = (1 + 1) ^ 3 * (1 + 1 + 1)^3)]; norm_num

@[simp] lemma map_discr : (map f e).discr = f e.discr := by simp [Model.discr, (by norm_num : (8 : R) = (1 + 1) ^ 3), (by norm_num : (9 : R) = (1 + 1 + 1) ^ 2), (by norm_num : (27 : R) = (1 + 1 + 1) ^ 3)]; norm_num

end Map

def weierstrass (e : Model R) (P : R × R) : R :=
  P.2 ^ 2 + e.a1 * P.1 * P.2 + e.a3 * P.2 - (P.1 ^ 3 + e.a2 * P.1 ^ 2 + e.a4 * P.1 + e.a6)

--partial derivation library?

def dweierstrass_dx (e : Model R) (P : R × R) : R :=
  e.a1 * P.2 - (3 * P.1 ^ 2 + 2 * e.a2 * P.1 + e.a4)

def dweierstrass_dy (e : Model R) (P : R × R) : R :=
  2 * P.2 + e.a1 * P.1 + e.a3

section map
variable {R S : Type u} [CommRing R] [CommRing S] (f : R →+* S)
@[simp]
lemma weierstrass_map (e : Model R) (P : R × R) : weierstrass (e.map f) (P.map f f) =
  f (weierstrass e P) :=
by simp [weierstrass]

@[simp]
lemma dweierstrass_dx_map (e : Model R) (P : R × R) : dweierstrass_dx (e.map f) (P.map f f) =
  f (dweierstrass_dx e P) :=
by simp [dweierstrass_dx, (by norm_num : (3 : R) = 1 + 1 + 1), (by norm_num : (2 : R) = 1 + 1)]; norm_num

@[simp]
lemma dweierstrass_dy_map (e : Model R) (P : R × R) : dweierstrass_dy (e.map f) (P.map f f) =
  f (dweierstrass_dy e P) :=
by simp [dweierstrass_dy, (by norm_num : (2 : R) = 1 + 1)]; norm_num

end map

/--

We can compute the discriminant in terms of these using `Singular.jl`, part of `OSCAR`

```julia
julia> using Oscar

julia> R, ( x, y, a1, a2, a3, a4, a6 ) = PolynomialRing( ZZ, [ "x", "y", "a1", "a2", "a3", "a4", "a6" ] )
(Singular Polynomial Ring (ZZ),(x,y,a1,a2,a3,a4,a6),(dp(7),C), spoly{n_Z}[x, y, a1, a2, a3, a4, a6])

julia> I = Ideal( R, [2*y + a1*x + a3,y*a1 - (3*x^2 + 2*a2*x + a4), y ^2 + a1*x*y + a3*y - (x^3 + a2*x^2 + a4*x + a6)] )
Singular ideal over Singular Polynomial Ring (ZZ),(x,y,a1,a2,a3,a4,a6),(dp(7),C) with generators (x*a1 + 2*y + a3, -3*x^2 + y*a1 - 2*x*a2 - a4, -x^3 + x*y*a1 - x^2*a2 + y^2 + y*a3 - x*a4 - a6)

julia> IE = eliminate(eliminate(I, x), y)
Singular ideal over Singular Polynomial Ring (ZZ),(x,y,a1,a2,a3,a4,a6),(dp(7),C) with generators (a1^4*a2*a3^2 - a1^5*a3*a4 + a1^6*a6 + 8*a1^2*a2^2*a3^2 - a1^3*a3^3 - 8*a1^3*a2*a3*a4 - a1^4*a4^2 + 12*a1^4*a2*a6 + 16*a2^3*a3^2 - 36*a1*a2*a3^3 - 16*a1*a2^2*a3*a4 + 30*a1^2*a3^2*a4 - 8*a1^2*a2*a4^2 + 48*a1^2*a2^2*a6 - 36*a1^3*a3*a6 + 27*a3^4 - 72*a2*a3^2*a4 - 16*a2^2*a4^2 + 96*a1*a3*a4^2 + 64*a2^3*a6 - 144*a1*a2*a3*a6 - 72*a1^2*a4*a6 + 64*a4^3 + 216*a3^2*a6 - 288*a2*a4*a6 + 432*a6^2)

julia> lift(I, IE)[1][1]
-x^2*a1^5*gen(1)+y*a1^6*gen(1)-x*a1^5*a2*gen(1)-x*y*a1^4*gen(1)-y*a1^5*gen(2)-a1^6*gen(3)-9*x^2*a1^3*a2*gen(1)+x*a1^4*a2*gen(2)+11*y*a1^4*a2*gen(1)-10*x*a1^3*a2^2*gen(1)+x*a1^4*a3*gen(1)+a1^4*a2*a3*gen(1)-a1^5*a4*gen(1)-4*x*y*a1^3*gen(2)-6*y^2*a1^3*gen(1)-8*x*y*a1^2*a2*gen(1)-10*y*a1^3*a2*gen(2)-12*a1^4*a2*gen(3)-24*x^2*a1*a2^2*gen(1)+8*x*a1^2*a2^2*gen(2)+40*y*a1^2*a2^2*gen(1)-32*x*a1*a2^3*gen(1)+30*x^2*a1^2*a3*gen(1)-2*x*a1^3*a3*gen(2)-35*y*a1^3*a3*gen(1)+38*x*a1^2*a2*a3*gen(1)-a1^3*a2*a3*gen(2)+8*a1^2*a2^2*a3*gen(1)-a1^3*a3^2*gen(1)+3*x*a1^3*a4*gen(1)+a1^4*a4*gen(2)-9*a1^3*a2*a4*gen(1)+12*y*a1^3*gen(3)-32*x*y*a1*a2*gen(2)-48*y^2*a1*a2*gen(1)+32*x^2*a2^2*gen(2)+48*x*y*a2^2*gen(1)-32*y*a1*a2^2*gen(2)-48*a1^2*a2^2*gen(3)+32*x*a2^3*gen(2)+32*y*a2^3*gen(1)+24*x*y*a1*a3*gen(1)+28*y*a1^2*a3*gen(2)+36*a1^3*a3*gen(3)+30*x^2*a2*a3*gen(1)-46*x*a1*a2*a3*gen(2)-134*y*a1*a2*a3*gen(1)+76*x*a2^2*a3*gen(1)-8*a1*a2^2*a3*gen(2)+16*a2^3*a3*gen(1)-27*x*a1*a3^2*gen(1)+a1^2*a3^2*gen(2)-36*a1*a2*a3^2*gen(1)+60*x^2*a1*a4*gen(1)-58*y*a1^2*a4*gen(1)+84*x*a1*a2*a4*gen(1)+8*a1^2*a2*a4*gen(2)-24*a1*a2^2*a4*gen(1)+31*a1^2*a3*a4*gen(1)+96*y*a1*a2*gen(3)-96*x*a2^2*gen(3)-64*a2^3*gen(3)+96*x*y*a3*gen(2)+144*y^2*a3*gen(1)+52*y*a2*a3*gen(2)+168*a1*a2*a3*gen(3)+84*x*a3^2*gen(2)+198*y*a3^2*gen(1)+38*a2*a3^2*gen(2)+27*a3^3*gen(1)-96*x^2*a4*gen(2)-144*x*y*a4*gen(1)+56*y*a1*a4*gen(2)+60*a1^2*a4*gen(3)-112*x*a2*a4*gen(2)-120*y*a2*a4*gen(1)+16*a2^2*a4*gen(2)-168*x*a3*a4*gen(1)-36*a1*a3*a4*gen(2)-34*a2*a3*a4*gen(1)+60*a1*a4^2*gen(1)+36*x*a1*a6*gen(1)+12*a1^2*a6*gen(2)+24*a1*a2*a6*gen(1)-288*y*a3*gen(3)-252*a3^2*gen(3)+288*x*a4*gen(3)+240*a2*a4*gen(3)-64*a4^2*gen(2)+144*x*a6*gen(2)+216*y*a6*gen(1)+48*a2*a6*gen(2)-36*a3*a6*gen(1)-432*a6*gen(3)
```
-/
lemma discr_eq_neg_singular (e : Model R) : e.discr = -(
  e.a1^4*e.a2*e.a3^2 - e.a1^5*e.a3*e.a4 + e.a1^6*e.a6 + 8*e.a1^2*e.a2^2*e.a3^2 - e.a1^3*e.a3^3
    - 8*e.a1^3*e.a2*e.a3*e.a4 - e.a1^4*e.a4^2 + 12*e.a1^4*e.a2*e.a6 + 16*e.a2^3*e.a3^2
    - 36*e.a1*e.a2*e.a3^3 - 16*e.a1*e.a2^2*e.a3*e.a4 + 30*e.a1^2*e.a3^2*e.a4 - 8*e.a1^2*e.a2*e.a4^2
    + 48*e.a1^2*e.a2^2*e.a6 - 36*e.a1^3*e.a3*e.a6 + 27*e.a3^4 - 72*e.a2*e.a3^2*e.a4
    - 16*e.a2^2*e.a4^2 + 96*e.a1*e.a3*e.a4^2 + 64*e.a2^3*e.a6 - 144*e.a1*e.a2*e.a3*e.a6
    - 72*e.a1^2*e.a4*e.a6 + 64*e.a4^3 + 216*e.a3^2*e.a6 - 288*e.a2*e.a4*e.a6 + 432*e.a6^2) :=
by
  simp only [discr, weierstrass, dweierstrass_dx, dweierstrass_dy, b2, b4, b6, b8]
  ring

set_option maxHeartbeats 400000 in
lemma discr_in_jacobian_ideal (e : Model R) (P : R × R) : e.discr =
  -((48*P.1*P.2*e.a2^2 +24*e.a1*e.a2*e.a6 +216*P.2*e.a6 +P.2*e.a1^6 +11*P.2*e.a1^4*e.a2 +P.1*e.a1^4*e.a3 +38*P.1*e.a1^2*e.a2*e.a3 +8*e.a1^2*e.a2^2*e.a3
  +e.a1^4*e.a2*e.a3 +40*P.2*e.a1^2*e.a2^2 +32*P.2*e.a2^3 +24*P.1*P.2*e.a1*e.a3 +30*P.1^2*e.a2*e.a3 +3*P.1*e.a1^3*e.a4 +60*P.1^2*e.a1*e.a4 +30*P.1^2*e.a1^2*e.a3
  +31*e.a1^2*e.a3*e.a4 +144*P.2^2*e.a3 +198*P.2*e.a3^2 +27*e.a3^3 +60*e.a1*e.a4^2 +36*P.1*e.a1*e.a6 +76*P.1*e.a2^2*e.a3 +16*e.a2^3*e.a3 +84*P.1*e.a1*e.a2*e.a4
  -(36*e.a3*e.a6 +P.1^2*e.a1^5 +P.1*e.a1^5*e.a2 +P.1*P.2*e.a1^4 +9*P.1^2*e.a1^3*e.a2 +10*P.1*e.a1^3*e.a2^2 +e.a1^5*e.a4 +6*P.2^2*e.a1^3 +8*P.1*P.2*e.a1^2*e.a2
  +24*P.1^2*e.a1*e.a2^2 +32*P.1*e.a1*e.a2^3 +35*P.2*e.a1^3*e.a3 +e.a1^3*e.a3^2 +9*e.a1^3*e.a2*e.a4 +48*P.2^2*e.a1*e.a2 +134*P.2*e.a1*e.a2*e.a3 +27*P.1*e.a1*e.a3^2 +36*e.a1*e.a2*e.a3^2
  +58*P.2*e.a1^2*e.a4 +24*e.a1*e.a2^2*e.a4 +144*P.1*P.2*e.a4 +120*P.2*e.a2*e.a4 +168*P.1*e.a3*e.a4 +34*e.a2*e.a3*e.a4))*(dweierstrass_dy e P)

  +(e.a1^2*e.a3^2 +12*e.a1^2*e.a6 +16*e.a2^2*e.a4 +32*P.1*e.a2^3 +e.a1^4*e.a4 +144*P.1*e.a6 +48*e.a2*e.a6 +P.1*e.a1^4*e.a2 +84*P.1*e.a3^2 +56*P.2*e.a1*e.a4 +8*e.a1^2*e.a2*e.a4 +28*P.2*e.a1^2*e.a3 +52*P.2*e.a2*e.a3
  +96*P.1*P.2*e.a3 +8*P.1*e.a1^2*e.a2^2 +38*e.a2*e.a3^2 +32*P.1^2*e.a2^2
  -(2*P.1*e.a1^3*e.a3 +112*P.1*e.a2*e.a4 +e.a1^3*e.a2*e.a3 +36*e.a1*e.a3*e.a4 +96*P.1^2*e.a4 +32*P.1*P.2*e.a1*e.a2 +32*P.2*e.a1*e.a2^2 +64*e.a4^2
  +4*P.1*P.2*e.a1^3 +10*P.2*e.a1^3*e.a2 +P.2*e.a1^5 +8*e.a1*e.a2^2*e.a3 +46*P.1*e.a1*e.a2*e.a3))*(dweierstrass_dx e P)

  +(60*e.a1^2*e.a4 +288*P.1*e.a4 +240*e.a2*e.a4 +12*P.2*e.a1^3 +36*e.a1^3*e.a3 +96*P.2*e.a1*e.a2 +168*e.a1*e.a2*e.a3
  -(432*e.a6 +e.a1^6 +288*P.2*e.a3 +252*e.a3^2 +12*e.a1^4*e.a2 +48*e.a1^2*e.a2^2 +96*P.1*e.a2^2 +64*e.a2^3))*(weierstrass e P))
 :=
by
  rw [discr_eq_neg_singular]
  simp only [weierstrass, dweierstrass_dx, dweierstrass_dy]
  ring

def var_change (r s t : R) (P' : R × R) : R × R :=
  (P'.1 + r, P'.2 + s * P'.1 + t)

@[simp]
lemma var_change_comp (r s t : R) (r' s' t' : R) (P : R × R) :
  var_change r s t (var_change r' s' t' P) = var_change (r + r') (s + s') (t + t' + s * r') P :=
by
  simp only [var_change, Prod.mk.injEq]
  apply And.intro <;>
  ring

@[simp]
lemma var_change_zero (P : R × R) : var_change (0 : R) 0 0 P = P :=
by simp [var_change]

-- TODO probably these proofs should be more conceptual

theorem weierstrass_iso_eq_var_change (e : Model R) (P : R × R) :
  weierstrass (rst_iso r s t e) P = weierstrass e (var_change r s t P) :=
by
  simp only [weierstrass, rst_iso, var_change]
  ring

theorem dweierstrass_dx_iso_eq_var_change (e : Model R) (P : R × R) :
  dweierstrass_dx (rst_iso r s t e) P =
  dweierstrass_dx e (var_change r s t P) + s * dweierstrass_dy e (var_change r s t P) :=
by
  simp only [dweierstrass_dx, dweierstrass_dy, rst_iso, var_change]
  ring

theorem dweierstrass_dy_iso_eq_var_change (e : Model R) (P : R × R) :
  dweierstrass_dy (rst_iso r s t e) P = dweierstrass_dy e (var_change r s t P) :=
by
  simp only [dweierstrass_dy, rst_iso, var_change]
  ring

def rst_triple (e : Model R) (rst : R × R × R) : Model R :=
  rst_iso rst.fst rst.snd.fst rst.snd.snd e

lemma rst_iso_to_triple (e : Model R) (r s t : R) : rst_iso r s t e = rst_triple e (r, s, t) := rfl

end Model

structure ValidModel (R : Type u) [CommRing R] extends Model R where
  discr_not_zero : toModel.discr ≠ 0

namespace ValidModel
variable {R : Type u} [CommRing R]
instance [Repr R] : Repr (ValidModel R) := ⟨ λ (e : ValidModel R) _ => repr e.toModel⟩

@[simps]
def rst_iso (r s t : R) (e : ValidModel R) : ValidModel R := {
  toModel := Model.rst_iso r s t e.toModel,
  discr_not_zero := by
    rw [Model.rst_discr]
    exact e.discr_not_zero }

@[simp]
lemma rst_discr_valid (r s t : R) (e : ValidModel R) : (rst_iso r s t e).discr = e.discr :=
  Model.rst_discr r s t e.toModel

--more [simp] lemmas
@[simp]
lemma rt_of_a1 (e : ValidModel R) (r t : R) : (rst_iso r 0 t e).a1 = e.a1 :=
by simp only [rst_iso, Model.rst_iso, mul_zero, add_zero, one_mul]

lemma t_of_a2 (e : ValidModel R) (t : R) : (rst_iso 0 0 t e).a2 = e.a2 :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero, mul_zero, add_zero, one_mul]

lemma r_of_a2 (e : ValidModel R) (r : R) : (rst_iso r 0 0 e).a2 = e.a2 + 3 * r :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero, mul_zero, add_zero, one_mul]

lemma t_of_a3 (e : ValidModel R) (t : R) : (rst_iso 0 0 t e).a3 = e.a3 + 2 * t :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero, mul_zero, add_zero, one_mul]

lemma r_of_a3 (e : ValidModel R) (r : R) : (rst_iso r 0 0 e).a3 = e.a3 + r * e.a1 :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero, mul_zero, add_zero, one_mul]

lemma t_of_a4 (e : ValidModel R) (t : R) : (rst_iso 0 0 t e).a4 = e.a4 - t * e.a1 :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero, mul_zero, add_zero, one_mul]

lemma r_of_a4 (e : ValidModel R) (r : R) : (rst_iso r 0 0 e).a4 = e.a4 + 2 * r * e.a2 + 3 * r ^ 2 :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul,
  sub_zero, mul_zero, one_mul, add_zero, mul_assoc, ←pow_two r]

lemma t_of_a6 (e : ValidModel R) (t : R) : (rst_iso 0 0 t e).a6 = e.a6 - t * e.a3 - t ^ 2 :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero, mul_zero,
  one_mul, add_zero, mul_add, ←pow_two t, sub_eq_add_neg, neg_add, ←add_assoc]

lemma r_of_a6 (e : ValidModel R) (r : R) :
  (rst_iso r 0 0 e).a6 = e.a6 + r * e.a4 + r ^ 2 * e.a2 + r ^ 3 :=
by simp only [rst_iso, Model.rst_iso, one_pow, zero_mul, sub_zero,
  mul_zero, one_mul, add_zero, mul_assoc, pow_two r, pow_succ r, pow_zero, mul_one]

lemma st_of_a1 (e : ValidModel R) (s t : R) : (rst_iso 0 s t e).a1 = e.a1 + 2 * s :=
by simp only [rst_iso, Model.rst_iso, one_pow, mul_zero, one_mul]

lemma st_of_a2 (e : ValidModel R) (s t : R) : (rst_iso 0 s t e).a2 = e.a2 - s * e.a1 - s ^ 2 :=
by simp only [rst_iso, Model.rst_iso, one_pow, mul_zero, one_mul, add_zero, mul_assoc, ←pow_two s]

lemma st_of_a3 (e : ValidModel R) (s t : R) : (rst_iso 0 s t e).a3 = e.a3 + 2 * t :=
by simp only [rst_iso, Model.rst_iso, one_pow, mul_zero, one_mul, add_zero, mul_assoc, zero_mul]

lemma st_of_a4 (e : ValidModel R) (s t : R) :
  (rst_iso 0 s t e).a4 = e.a4 - s * e.a3 - t * e.a1 - 2 * s * t :=
by simp only [rst_iso, Model.rst_iso, one_pow, mul_zero, one_mul, add_zero, mul_assoc, zero_mul]

lemma st_of_a6 (e : ValidModel R) (s t : R) : (rst_iso 0 s t e).a6 = e.a6 - t * e.a3 - t ^ 2 :=
by simp only [rst_iso, Model.rst_iso, one_pow, mul_zero, one_mul,
  add_zero, mul_assoc, ←pow_two t, zero_mul, mul_add, sub_sub]

lemma st_of_b8 (e : ValidModel R) (s t : R) : (rst_iso 0 s t e).b8 = e.b8 := by
  rw [rst_iso, Model.rst_b8]
  simp only [mul_zero, add_zero, zero_mul]

def rst_triple (e : ValidModel R) (rst : R × R × R) : ValidModel R :=
  rst_iso rst.fst rst.snd.fst rst.snd.snd e

lemma rst_iso_to_triple (e : ValidModel R) (r s t : R) : rst_iso r s t e = rst_triple e (r, s, t) :=
rfl

end ValidModel

namespace Model

section
variable {K : Type u} [CommRing K]

def is_singular_point (e : Model K) (P : K × K) : Prop :=
weierstrass e P = 0 ∧ dweierstrass_dx e P = 0 ∧ dweierstrass_dy e P = 0

lemma discr_eq_zero_of_singular (e : Model K) {P} (h : is_singular_point e P) :
  e.discr = 0 :=
by
  rcases h with ⟨h₁, h₂, h₃⟩
  rw [discr_in_jacobian_ideal, h₁, h₂, h₃, mul_zero,
    mul_zero, mul_zero, add_zero, add_zero, neg_eq_zero]

end
section invariant_lemmas
variable {K : Type u} [CommRing K] [IsDomain K]

lemma c4_zero_iff_a1_zero_of_char_two (e : Model K) (h : ring_char K = 2) :
  e.c4 = 0 ↔ e.a1 = 0 :=
by
  have hchar' : (ring_char K : K) = 2 := by simp [h]
  have hchar'' : (2 : K) = 0 := by simp [← hchar', ring_char_eq_zero]
  rw [c4, b2, show (24 : K) = 2 * 12 by norm_num, show (4 : K) = 2 * 2 by norm_num, hchar'', ← pow_two] -- TODO this used to work without type ascription
  simp only [mul_zero, zero_mul, add_zero, ← pow_mul, sub_zero] -- TODO simp? doesn't do back arrows
  rw [pow_eq_zero_iff]
  norm_num

lemma c4_zero_iff_b2_zero_of_char_three (e : Model K) (h : ring_char K = 3) :
  e.c4 = 0 ↔ e.b2 = 0 :=
by
  have hchar' : (ring_char K : K) = 3 := by simp [h]
  have hchar'' : (3 : K) = 0 := by simp [← hchar', ring_char_eq_zero]
  rw [c4, show (24 : K) = 3 * 8 by norm_num, hchar'']
  simp only [mul_zero, zero_mul, add_zero, sub_zero] -- TODO simp? doesn't do back arrows
  rw [pow_eq_zero_iff]
  norm_num

-- TODO is this actually an iff
lemma a3_zero_of_a1_zero_of_disc_zero_of_char_two
  (e : Model K) (h : ring_char K = 2) (hdisc : e.discr = 0) (ha1 : e.a1 = 0) :
  e.a3 = 0 :=
by
  have hchar' : (ring_char K : K) = 2 := by simp [h]
  have hchar'' : (2 : K) = 0 := by simp [← hchar', ring_char_eq_zero]
  rw [discr, b2, b4, b6, b8, ha1,
    show (8 : K) = 2 * 4 by norm_num, show (4 : K) = 2 * 2 by norm_num, show (27 : K) = 2 * 13 + 1 by norm_num, hchar''] at hdisc
  -- TODO simp identifier "at" can't be on next line
  simp only [mul_zero, zero_mul, add_zero, neg_zero, sub_self, zero_add, one_mul, zero_sub, neg_eq_zero] at hdisc
  rw [← pow_two, ← pow_two, ← pow_mul] at hdisc
  rwa [pow_eq_zero_iff] at hdisc
  norm_num

-- TODO is this actually an iff discr
lemma b4_zero_of_b2_zero_of_disc_zero_of_char_three
  (e : Model K) (h : ring_char K = 3) (hdisc : e.discr = 0) (hb2 : e.b2 = 0) :
  e.b4 = 0 :=
by
  have hchar' : (ring_char K : K) = 3 := by simp [h]
  have hchar'' : (3 : K) = 0 := by simp [← hchar', ring_char_eq_zero]
  rw [discr, hb2,
    show (27 : K) = 3 * 9 by norm_num,
    show (8 : K) = 3 * 3 - 1 by norm_num,
    hchar''] at hdisc
  simpa using hdisc

end invariant_lemmas

namespace Field
variable {K : Type u} [Field K]

open Classical PerfectRing

/--
Proposition 1.5.4 of Elliptic Curve Handbook, Ian Connell February, 1999,
https://www.math.rug.nl/~top/ian.pdf
-/
noncomputable
def singular_point [PerfectRing K] (e : Model K) : K × K :=
  if e.c4 = 0 then
    match ring_char K with
    | 2 => (pth_root e.a4, pth_root (e.a2 * e.a4 + e.a6))
    | 3 => (pth_root (-(e.a3 ^ 2) - e.a6), e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a3)
    | _ => (-e.b2 / 12, -(-e.a1 * e.b2 / 12 + e.a3) / 2)
  else
    ((18 * e.b6 - e.b2 * e.b4) / e.c4, (e.b2 * e.b5 + 3 * e.b7) / e.c4)

-- TODO probably can be deleted
instance [h : IsAssociative R op] : Lean.IsAssociative op := {h with}
instance [h : IsCommutative R op] : Lean.IsCommutative op := by infer_instance
instance [h : IsIdempotent R op] : Lean.IsIdempotent op := {h with}
-- lemma test (e : Model K) :
--   c4 e ^ 3 * ((b2 e * b5 e + 3 * b7 e) ^ 2 * (c4 e)⁻¹ ^ 2) + 0 =
--             c4 e^ 3 * (c4 e)⁻¹ ^ 2 * ((b2 e * b5 e + 3 * b7 e) ^ 2) :=
-- by
--   rw [show c4 e ^ 3 * ((b2 e * b5 e+ 3 * b7 e) ^ 2 * (c4 e)⁻¹ ^ 2) =
--             c4 e^ 3 * (c4 e)⁻¹ ^ 2 * ((b2 e * b5 e + 3 * b7 e) ^ 2) by ac_rfl]
--   sorry
-- TODO a field should be a division comm monoid

-- TODO maybe rewrite to take an explicit point
set_option maxHeartbeats 600000 in
lemma is_singular_point_singular_point [PerfectRing K] (e : Model K) (h : e.discr = 0) :
  is_singular_point e (singular_point e) :=
by
  rw [singular_point]
  split_ifs with hc4 hc4
  . have hc6 : c6 e = 0 := by
      simpa [h, hc4, pow_succ, mul_eq_zero] using discr_identity e
    split
    -- case _ hchar => TODO get this working, but its subtly different
    . rw [is_singular_point]
      have hchar : ring_char K = 2 := by assumption
      have hchar' : (ring_char K : K) = 2 := by simp [hchar]
      have hchar'' : (2 : K) = 0 := by simp [← hchar', ring_char_eq_zero]
      have hcharne : ring_char K ≠ 0 := by simp [hchar]
      have ha1 : e.a1 = 0 := by simpa [c4_zero_iff_a1_zero_of_char_two e hchar] using hc4
      have ha3 : e.a3 = 0 := a3_zero_of_a1_zero_of_disc_zero_of_char_two e hchar h ha1
      refine ⟨?_, ?_, ?_⟩
      . rw [weierstrass]
        simp only [ha1, ha3, mul_zero, zero_add, zero_mul, add_zero]
        rw [show 3 = 2 + 1 by norm_num]
        rw [pow_succ _ 2]
        rw [← hchar, pth_root_pow_char hcharne]
        rw [pth_root_pow_char hcharne]
        simp only [add_sub_add_right_eq_sub, sub_eq_iff_eq_add, zero_add]
        rw [show pth_root e.a4 * e.a4 + e.a2 * e.a4 + e.a4 * pth_root e.a4 =
                2 * (pth_root e.a4 * e.a4) + e.a2 * e.a4 by ring]
        rw [hchar'', zero_mul, zero_add]
      . rw [dweierstrass_dx]
        simp only [ha1, zero_mul, hchar'', add_zero, zero_sub, neg_add_rev]
        rw [← hchar, pth_root_pow_char hcharne, ← sub_eq_add_neg]
        simp only [add_sub_add_right_eq_sub, sub_eq_iff_eq_add, zero_add]
        rw [show (3 : K) = 2 * 2 - 1 by norm_num]
        rw [hchar'']
        simp [← neg_mul_eq_neg_mul]
      . simp [dweierstrass_dy, ha1, ha3, hchar'']
    . rw [is_singular_point]
      have hchar : ring_char K = 3 := by assumption
      have hcharne : ring_char K ≠ 0 := by simp [hchar]
      have hchar' : (ring_char K : K) = 3 := by simp [hchar]
      have hchar'' : (3 : K) = 0 := by simp [← hchar', ring_char_eq_zero]
      have hb2 : e.b2 = 0 := by simpa [c4_zero_iff_b2_zero_of_char_three e hchar] using hc4
      have hb4 : e.b4 = 0 := b4_zero_of_b2_zero_of_disc_zero_of_char_three e hchar h hb2
      rw [b2] at hb2 -- TODO get versions that elim one b
      rw [b4] at hb4
      refine ⟨?_, ?_, ?_⟩
      . rw [weierstrass]
        rw [← hchar, pth_root_pow_char hcharne]
        simp only
        rw [show
          (e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a3) ^ 2 +
          e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) * (e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a3) +
          e.a3 * (e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a3) -
          (-(e.a3 ^ 2) - e.a6 + e.a2 * pth_root (-(e.a3 ^ 2) - e.a6) ^ 2 + e.a4 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a6) =
          (2 * e.a1 ^ 2 - e.a2) * pth_root (-(e.a3 ^ 2) - e.a6) ^ 2 +
          (4 * e.a1 * e.a3 - e.a4) * pth_root (-(e.a3 ^ 2) - e.a6) +
          3 * e.a3 ^ 2
          by ring]
        rw [show 2 * e.a1 ^ 2 - e.a2 = 0 from ?_]
        rw [show 4 * e.a1 * e.a3 - e.a4 = 0 from ?_]
        simp only [zero_mul, add_zero, hchar'']
        . rw [show (2 : K) = -1 by rw [← add_zero (-1), ← hchar'']; norm_num] at hb4
          rw [show (4 : K) = 1 by rw [← add_zero 1, ← hchar'']; norm_num]
          simp only [neg_mul, one_mul] at hb4
          simp [sub_eq_add_neg, hb4]
        . sorry
      . rw [dweierstrass_dx]
        rw [hchar'', zero_mul, zero_add]
        simp only
        rw [show e.a1 * (e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a3) - (2 * e.a2 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a4) =
                 (e.a1 * e.a1 - 2 * e.a2) * pth_root (-(e.a3 ^ 2) - e.a6) + (e.a1 * e.a3 - e.a4)
          by ring]
        rw [show (2 : K) = -1 by rw [← add_zero (-1), ← hchar'']; norm_num] at hb4
        rw [show (4 : K) = -2 by rw [← add_zero (-2), ← zero_mul (2 : K), ← hchar'']; norm_num] at hb2
        simp only [neg_mul, one_mul, ← sub_eq_add_neg] at hb4 hb2
        rw [hb4, hb2, zero_mul, zero_add]
      . rw [dweierstrass_dy]
        simp only
        rw [show 2 * (e.a1 * pth_root (-(e.a3 ^ 2) - e.a6) + e.a3)
            + e.a1 * pth_root (- (e.a3 ^ 2) - e.a6) + e.a3 = 3 * ((e.a1 * pth_root (-(e.a3 ^ 2) - e.a6)) + e.a3) by ring]
        rw [hchar'', zero_mul]
    . rw [is_singular_point]
      -- have hb4 : e.b2 ^ 2 = 24 * e.b4 := sorry
      have h2 : (2 : K) ≠ 0 := sorry
      have h3 : (3 : K) ≠ 0 := sorry
      have h12 : (12 : K) ≠ 0 := by
        rw [show (12 : K) = 2 * 2 * 3 by norm_num]
        repeat' apply mul_ne_zero
        all_goals assumption
      refine ⟨?_, ?_, ?_⟩
      . apply nzero_mul_left_cancel (12 ^ 3) _ _ (pow_ne_zero _ h12)
        simp only [weierstrass, div_eq_mul_inv, mul_zero]
        rw [show
          12 ^ 3 * ((-(-e.a1 * b2 e * 12⁻¹ + e.a3) * 2⁻¹) ^ 2 +
          e.a1 * (-b2 e * 12⁻¹) * (-(-e.a1 * b2 e * 12⁻¹ + e.a3) * 2⁻¹) +
          e.a3 * (-(-e.a1 * b2 e * 12⁻¹ + e.a3) * 2⁻¹) -
          ((-b2 e * 12⁻¹) ^ 3 + e.a2 * (-b2 e * 12⁻¹) ^ 2 + e.a4 * (-b2 e * 12⁻¹) + e.a6)) =
          3*(-(-e.a1 * b2 e * (12 * 12⁻¹) + 12 * e.a3) * (2 * 2⁻¹)) ^ 2 +
          e.a1 * (-b2 e * (12 * 12⁻¹)) * (-(-e.a1 * b2 e * (12 * 12⁻¹) + 12 * e.a3) * (6 * (2 * 2⁻¹))) +
          12 * e.a3 * (-(-e.a1 * b2 e * (12 * 12⁻¹) + 12 * e.a3) * (6 * (2 * 2⁻¹))) -
          ((-b2 e * (12 * 12⁻¹)) ^ 3 + 12 * e.a2 * (-b2 e * (12 * 12⁻¹)) ^ 2 + 12 ^ 2 * e.a4 * (-b2 e * (12 * 12⁻¹)) + 12 ^ 3 * e.a6) by ring]
        simp only [mul_inv_cancel h2, mul_inv_cancel h12, one_mul, mul_one]
        -- This is 2*c6
        rw [← mul_zero (2 : K), ← hc6]
        simp only [c6, b2, b4, b6]
        ring
      . apply nzero_mul_left_cancel (12 ^ 2) _ _ (pow_ne_zero _ h12)
        simp only [dweierstrass_dx, div_eq_mul_inv, mul_zero]
        rw [show
          12 ^ 2 * (e.a1 * (-(-e.a1 * b2 e * 12⁻¹ + e.a3) * 2⁻¹) - (3 * (-b2 e * 12⁻¹) ^ 2 + 2 * e.a2 * (-b2 e * 12⁻¹) + e.a4))
          =
          e.a1 * (-(-e.a1 * b2 e * (12 * 12⁻¹) + 12* e.a3) * 6 * (2 * 2⁻¹)) - (3 * (-b2 e * (12 * 12⁻¹)) ^ 2 + 24 * e.a2 * (-b2 e * (12 * 12⁻¹)) + 144 * e.a4)
          by ring]
        simp only [mul_inv_cancel h2, mul_inv_cancel h12, one_mul, mul_one]
        -- This is 2*c6
        rw [← mul_zero (3 : K), ← hc4]
        simp only [c4, c6, b2, b4, b6]
        ring
      . apply nzero_mul_left_cancel 12 _ _ h12
        simp only [dweierstrass_dy, div_eq_mul_inv, mul_zero]
        rw [show
          12 * (2 * (-(-e.a1 * b2 e * 12⁻¹ + e.a3) * 2⁻¹) + e.a1 * (-b2 e * 12⁻¹) + e.a3)
          =
          (-(-e.a1 * b2 e * (12 * 12⁻¹) + 12 * e.a3) * (2 * 2⁻¹)) + e.a1 * (-b2 e * (12 * 12⁻¹)) + 12 * e.a3
          by ring]
        simp only [mul_inv_cancel h2, mul_inv_cancel h12, one_mul, mul_one]
        -- This is 2*c6
        simp only [c6, b2, b4, b6]
        ring
  . rw [is_singular_point]
    refine ⟨?_, ?_, ?_⟩
    . rw [weierstrass]
      -- simp [b2, b5, b7]
      apply nzero_mul_left_cancel (e.c4 ^ 3) _ _ (pow_ne_zero _ hc4)
      rw [mul_zero]
      -- simp only [mul_add, mul_sub, div_eq_mul_inv, mul_pow]
      -- have : c4 e ^ 3 * ((b2 e * b5 e + 3 * b7 e) ^ 2 * (c4 e)⁻¹ ^ 2) =
      --     c4 e ^ 3 * (c4 e)⁻¹ ^ 2 * ((b2 e * b5 e + 3 * b7 e) ^ 2 ) :=
      --       by ac_rfl -- TODO ac_rfl bug or show bug?
      -- rw [this]
      simp only [div_eq_mul_inv]
      rw [show c4 e ^ 3 * (((b2 e * b5 e + 3 * b7 e) * (c4 e)⁻¹) ^ 2 +
            e.a1 * ((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) * ((b2 e * b5 e + 3 * b7 e) * (c4 e)⁻¹) +
          e.a3 * ((b2 e * b5 e + 3 * b7 e) * (c4 e)⁻¹) -
          (((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) ^ 3 + e.a2 * ((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) ^ 2 +
          e.a4 * ((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) + e.a6)) =
        (c4 e * (c4 e)⁻¹ * c4 e * (c4 e)⁻¹ * c4 e * ((b2 e * b5 e + 3 * b7 e)) ^ 2 +
          c4 e * (c4 e)⁻¹ * c4 e * (c4 e)⁻¹ * c4 e * e.a1 * ((18 * b6 e - b2 e * b4 e)) * ((b2 e * b5 e + 3 * b7 e)) +
        c4 e * (c4 e)⁻¹ * c4 e * c4 e * e.a3 * ((b2 e * b5 e + 3 * b7 e)) -
        (c4 e * (c4 e)⁻¹ * c4 e * (c4 e)⁻¹ * c4 e * (c4 e)⁻¹ * ((18 * b6 e - b2 e * b4 e)) ^ 3 +
        c4 e * (c4 e)⁻¹ * c4 e * (c4 e)⁻¹ * c4 e * e.a2 * ((18 * b6 e - b2 e * b4 e)) ^ 2 +
          c4 e * (c4 e)⁻¹ * c4 e * c4 e * e.a4 * ((18 * b6 e - b2 e * b4 e)) +
        c4 e * c4 e * c4 e * e.a6)) by ring]
      simp only [mul_inv_cancel hc4, one_mul]
      rw [b5, b7, c4, b2, b4, b6]
      -- what remains factors the discriminant (up to sign)
      rw [← mul_zero (e.a1^6 + 12*e.a1^4*e.a2 + 48*e.a1^2*e.a2^2 - 36*e.a1^3*e.a3 + 64*e.a2^3
        - 144*e.a1*e.a2*e.a3 - 72*e.a1^2*e.a4 + 216*e.a3^2 - 288*e.a2*e.a4 + 864*e.a6),
        ← h, discr_eq_neg_singular]
      ring
    . rw [dweierstrass_dx]
      apply nzero_mul_left_cancel (e.c4 ^ 2) _ _ (pow_ne_zero _ hc4)
      rw [mul_zero, pow_two]
      simp only [div_eq_mul_inv]
      rw [show c4 e * c4 e *
        (e.a1 * ((b2 e * b5 e + 3 * b7 e) * (c4 e)⁻¹) -
          (3 * ((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) ^ 2
          + 2 * e.a2 * ((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) + e.a4)) =
          c4 e * (c4 e)⁻¹ * c4 e * (e.a1 * (b2 e * b5 e + 3 * b7 e)
          - 2 * e.a2 * ((18 * b6 e - b2 e * b4 e)))
          - c4 e * (c4 e)⁻¹ * c4 e * (c4 e)⁻¹ *
          3 * (18 * b6 e - b2 e * b4 e) ^ 2 - e.a4 * c4 e * c4 e
        by ring]
      simp only [mul_inv_cancel hc4, one_mul]
      rw [b5, b7, c4, b2, b4, b6]
      -- what remains is just 36 times the discriminant (up to sign)
      rw [← mul_zero (36 : K), ← h, discr_eq_neg_singular]
      ring
    . rw [dweierstrass_dy]
      apply nzero_mul_left_cancel e.c4 _ _ hc4
      simp only [div_eq_mul_inv, mul_zero]
      rw [show c4 e * (2 * ((b2 e * b5 e + 3 * b7 e) * (c4 e)⁻¹)
          + e.a1 * ((18 * b6 e - b2 e * b4 e) * (c4 e)⁻¹) + e.a3) =
        c4 e * (c4 e)⁻¹ * (2 * (b2 e * b5 e + 3 * b7 e)
        + e.a1 * ((18 * b6 e - b2 e * b4 e))) + c4 e * e.a3 by ring]
      simp only [mul_inv_cancel hc4, one_mul]
      rw [b5, b7, c4, b2, b4, b6]
      ring

/--
Proposition 1.5.4 of Elliptic Curve Handbook, Ian Connell February, 1999,
https://www.math.rug.nl/~top/ian.pdf
-/
noncomputable
def move_singular_point_to_origin_triple [PerfectRing K] (e : Model K) : K × K × K :=
⟨(singular_point e).1, 0, (singular_point e).2⟩

noncomputable
def move_singular_point_to_origin_iso [PerfectRing K] (e : Model K) : Model K :=
rst_triple e (move_singular_point_to_origin_triple e)

lemma move_singular_point (e : Model K) (r t : K) {P : K × K} (h : is_singular_point e P) :
  is_singular_point (rst_iso r 0 t e) (var_change (-r) 0 (-t) P) :=
by
  rw [is_singular_point, weierstrass_iso_eq_var_change,
    dweierstrass_dx_iso_eq_var_change, zero_mul, add_zero,
    dweierstrass_dy_iso_eq_var_change, var_change_comp]
  simpa

lemma move_singular_point_to_origin [PerfectRing K] (e : Model K) (h : e.discr = 0) :
  is_singular_point (move_singular_point_to_origin_iso e) (0, 0) :=
by
  rw [move_singular_point_to_origin_iso, rst_triple, move_singular_point_to_origin_triple]
  convert move_singular_point e (singular_point e).fst (singular_point e).snd
    (is_singular_point_singular_point e h) using 2 <;> -- TODO convert does too much here
  simp [var_change]

lemma move_singular_point_to_origin' [PerfectRing K] (e : Model K) :
  (∃ P, is_singular_point e P) →
    is_singular_point (move_singular_point_to_origin_iso e) (0, 0) :=
by
  rintro ⟨P, hP⟩
  have hd := discr_eq_zero_of_singular e hP
  exact move_singular_point_to_origin e hd

end Field

end Model