/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import algebra.order.module
import linear_algebra.affine_space.midpoint
import tactic.field_simp

/-!
# Ordered modules as affine spaces

In this file we define the slope of a function `f : k → PE` taking values in an affine space over
`k` and prove some theorems about `slope` and `line_map` in the case when `PE` is an ordered
module over `k`. The `slope` function naturally appears in the Mean Value Theorem, and in the
proof of the fact that a function with nonnegative second derivative on an interval is convex on
this interval. In the third part of this file we prove inequalities that will be used in
`analysis.convex.function` to link convexity of a function on an interval to monotonicity of the
slope, see section docstring below for details.

## Implementation notes

We do not introduce the notion of ordered affine spaces (yet?). Instead, we prove various theorems
for an ordered module interpreted as an affine space.

## Tags

affine space, ordered module, slope
-/

open affine_map

variables {k E PE : Type*}

/-!
### Definition of `slope` and basic properties

In this section we define `slope f a b` and prove some properties that do not require order on the
codomain.  -/

section no_order

variables [field k] [add_comm_group E] [module k E] [add_torsor E PE]

include E

/-- `slope f a b = (b - a)⁻¹ • (f b -ᵥ f a)` is the slope of a function `f` on the interval
`[a, b]`. Note that `slope f a a = 0`, not the derivative of `f` at `a`. -/
def slope (f : k → PE) (a b : k) : E := (b - a)⁻¹ • (f b -ᵥ f a)

omit E

lemma slope_def_field (f : k → k) (a b : k) : slope f a b = (f b - f a) / (b - a) :=
div_eq_inv_mul.symm

@[simp] lemma slope_same (f : k → PE) (a : k) : (slope f a a : E) = 0 :=
by rw [slope, sub_self, inv_zero, zero_smul]

include E

lemma eq_of_slope_eq_zero {f : k → PE} {a b : k} (h : slope f a b = (0:E)) : f a = f b :=
begin
  rw [slope, smul_eq_zero, inv_eq_zero, sub_eq_zero, vsub_eq_zero_iff_eq] at h,
  exact h.elim (λ h, h ▸ rfl) eq.symm
end

lemma slope_comm (f : k → PE) (a b : k) : slope f a b = slope f b a :=
by rw [slope, slope, ← neg_vsub_eq_vsub_rev, smul_neg, ← neg_smul, neg_inv, neg_sub]

/-- `slope f a c` is a linear combination of `slope f a b` and `slope f b c`. This version
explicitly provides coefficients. If `a ≠ c`, then the sum of the coefficients is `1`, so it is
actually an affine combination, see `line_map_slope_slope_sub_div_sub`. -/
lemma sub_div_sub_smul_slope_add_sub_div_sub_smul_slope (f : k → PE) (a b c : k) :
  ((b - a) / (c - a)) • slope f a b + ((c - b) / (c - a)) • slope f b c = slope f a c :=
begin
  by_cases hab : a = b,
  { subst hab,
    rw [sub_self, zero_div, zero_smul, zero_add],
    by_cases hac : a = c,
    { simp [hac] },
    { rw [div_self (sub_ne_zero.2 $ ne.symm hac), one_smul] } },
  by_cases hbc : b = c, { subst hbc, simp [sub_ne_zero.2 (ne.symm hab)] },
  rw [add_comm],
  simp_rw [slope, div_eq_inv_mul, mul_smul, ← smul_add,
    smul_inv_smul₀ (sub_ne_zero.2 $ ne.symm hab), smul_inv_smul₀ (sub_ne_zero.2 $ ne.symm hbc),
    vsub_add_vsub_cancel],
end

/-- `slope f a c` is an affine combination of `slope f a b` and `slope f b c`. This version uses
`line_map` to express this property. -/
lemma line_map_slope_slope_sub_div_sub (f : k → PE) (a b c : k) (h : a ≠ c) :
  line_map (slope f a b) (slope f b c) ((c - b) / (c - a)) = slope f a c :=
by  field_simp [sub_ne_zero.2 h.symm, ← sub_div_sub_smul_slope_add_sub_div_sub_smul_slope f a b c,
  line_map_apply_module]

/-- `slope f a b` is an affine combination of `slope f a (line_map a b r)` and
`slope f (line_map a b r) b`. We use `line_map` to express this property. -/
lemma line_map_slope_line_map_slope_line_map (f : k → PE) (a b r : k) :
  line_map (slope f (line_map a b r) b) (slope f a (line_map a b r)) r = slope f a b :=
begin
  obtain (rfl|hab) : a = b ∨ a ≠ b := classical.em _, { simp },
  rw [slope_comm _ a, slope_comm _ a, slope_comm _ _ b],
  convert line_map_slope_slope_sub_div_sub f b (line_map a b r) a hab.symm using 2,
  rw [line_map_apply_ring, eq_div_iff (sub_ne_zero.2 hab), sub_mul, one_mul, mul_sub, ← sub_sub,
    sub_sub_cancel]
end

end no_order

/-!
### Monotonicity of `line_map`

In this section we prove that `line_map a b r` is monotone (strictly or not) in its arguments if
other arguments belong to specific domains.
-/

section ordered_ring

variables [ordered_ring k] [ordered_add_comm_group E] [module k E] [ordered_smul k E]

variables {a a' b b' : E} {r r' : k}

lemma line_map_mono_left (ha : a ≤ a') (hr : r ≤ 1) :
  line_map a b r ≤ line_map a' b r :=
begin
  simp only [line_map_apply_module],
  exact add_le_add_right (smul_le_smul_of_nonneg ha (sub_nonneg.2 hr)) _
end

lemma line_map_strict_mono_left (ha : a < a') (hr : r < 1) :
  line_map a b r < line_map a' b r :=
begin
  simp only [line_map_apply_module],
  exact add_lt_add_right (smul_lt_smul_of_pos ha (sub_pos.2 hr)) _
end

lemma line_map_mono_right (hb : b ≤ b') (hr : 0 ≤ r) :
  line_map a b r ≤ line_map a b' r :=
begin
  simp only [line_map_apply_module],
  exact add_le_add_left (smul_le_smul_of_nonneg hb hr) _
end

lemma line_map_strict_mono_right (hb : b < b') (hr : 0 < r) :
  line_map a b r < line_map a b' r :=
begin
  simp only [line_map_apply_module],
  exact add_lt_add_left (smul_lt_smul_of_pos hb hr) _
end

lemma line_map_mono_endpoints (ha : a ≤ a') (hb : b ≤ b') (h₀ : 0 ≤ r) (h₁ : r ≤ 1) :
  line_map a b r ≤ line_map a' b' r :=
(line_map_mono_left ha h₁).trans (line_map_mono_right hb h₀)

lemma line_map_strict_mono_endpoints (ha : a < a') (hb : b < b') (h₀ : 0 ≤ r) (h₁ : r ≤ 1) :
  line_map a b r < line_map a' b' r :=
begin
  rcases h₀.eq_or_lt with (rfl|h₀), { simpa },
  exact (line_map_mono_left ha.le h₁).trans_lt (line_map_strict_mono_right hb h₀)
end

lemma line_map_lt_line_map_iff_of_lt (h : r < r') :
  line_map a b r < line_map a b r' ↔ a < b :=
begin
  simp only [line_map_apply_module],
  rw [← lt_sub_iff_add_lt, add_sub_assoc, ← sub_lt_iff_lt_add', ← sub_smul, ← sub_smul,
    sub_sub_sub_cancel_left, smul_lt_smul_iff_of_pos (sub_pos.2 h)],
  apply_instance,
end

lemma left_lt_line_map_iff_lt (h : 0 < r) : a < line_map a b r ↔ a < b :=
iff.trans (by rw line_map_apply_zero) (line_map_lt_line_map_iff_of_lt h)

lemma line_map_lt_left_iff_lt (h : 0 < r) : line_map a b r < a ↔ b < a :=
@left_lt_line_map_iff_lt k (order_dual E) _ _ _ _ _ _ _ h

lemma line_map_lt_right_iff_lt (h : r < 1) : line_map a b r < b ↔ a < b :=
iff.trans (by rw line_map_apply_one) (line_map_lt_line_map_iff_of_lt h)

lemma right_lt_line_map_iff_lt (h : r < 1) : b < line_map a b r ↔ b < a :=
@line_map_lt_right_iff_lt k (order_dual E) _ _ _ _ _ _ _ h

end ordered_ring

section linear_ordered_ring

variables [linear_ordered_ring k] [ordered_add_comm_group E] [module k E]
  [ordered_smul k E] [invertible (2:k)] {a a' b b' : E} {r r' : k}

lemma midpoint_le_midpoint (ha : a ≤ a') (hb : b ≤ b') :
  midpoint k a b ≤ midpoint k a' b' :=
line_map_mono_endpoints ha hb (inv_of_nonneg.2 zero_le_two) $
  inv_of_le_one one_le_two

end linear_ordered_ring

section linear_ordered_field

variables [linear_ordered_field k] [ordered_add_comm_group E]
variables [module k E] [ordered_smul k E]

section

variables {a b : E} {r r' : k}

lemma line_map_le_line_map_iff_of_lt (h : r < r') :
  line_map a b r ≤ line_map a b r' ↔ a ≤ b :=
begin
  simp only [line_map_apply_module],
  rw [← le_sub_iff_add_le, add_sub_assoc, ← sub_le_iff_le_add', ← sub_smul, ← sub_smul,
    sub_sub_sub_cancel_left, smul_le_smul_iff_of_pos (sub_pos.2 h)],
  apply_instance,
end

lemma left_le_line_map_iff_le (h : 0 < r) : a ≤ line_map a b r ↔ a ≤ b :=
iff.trans (by rw line_map_apply_zero) (line_map_le_line_map_iff_of_lt h)

@[simp] lemma left_le_midpoint : a ≤ midpoint k a b ↔ a ≤ b :=
left_le_line_map_iff_le $ inv_pos.2 zero_lt_two

lemma line_map_le_left_iff_le (h : 0 < r) : line_map a b r ≤ a ↔ b ≤ a :=
@left_le_line_map_iff_le k (order_dual E) _ _ _ _ _ _ _ h

@[simp] lemma midpoint_le_left : midpoint k a b ≤ a ↔ b ≤ a :=
line_map_le_left_iff_le $ inv_pos.2 zero_lt_two

lemma line_map_le_right_iff_le (h : r < 1) : line_map a b r ≤ b ↔ a ≤ b :=
iff.trans (by rw line_map_apply_one) (line_map_le_line_map_iff_of_lt h)

@[simp] lemma midpoint_le_right : midpoint k a b ≤ b ↔ a ≤ b :=
line_map_le_right_iff_le $ inv_lt_one one_lt_two

lemma right_le_line_map_iff_le (h : r < 1) : b ≤ line_map a b r ↔ b ≤ a :=
@line_map_le_right_iff_le k (order_dual E) _ _ _ _ _ _ _ h

@[simp] lemma right_le_midpoint : b ≤ midpoint k a b ↔ b ≤ a :=
right_le_line_map_iff_le $ inv_lt_one one_lt_two

end

/-!
### Convexity and slope

Given an interval `[a, b]` and a point `c ∈ (a, b)`, `c = line_map a b r`, there are a few ways to
say that the point `(c, f c)` is above/below the segment `[(a, f a), (b, f b)]`:

* compare `f c` to `line_map (f a) (f b) r`;
* compare `slope f a c` to `slope `f a b`;
* compare `slope f c b` to `slope f a b`;
* compare `slope f a c` to `slope f c b`.

In this section we prove equivalence of these four approaches. In order to make the statements more
readable, we introduce local notation `c = line_map a b r`. Then we prove lemmas like

```
lemma map_le_line_map_iff_slope_le_slope_left (h : 0 < r * (b - a)) :
  f c ≤ line_map (f a) (f b) r ↔ slope f a c ≤ slope f a b :=
```

For each inequality between `f c` and `line_map (f a) (f b) r` we provide 3 lemmas:

* `*_left` relates it to an inequality on `slope f a c` and `slope f a b`;
* `*_right` relates it to an inequality on `slope f a b` and `slope f c b`;
* no-suffix version relates it to an inequality on `slope f a c` and `slope f c b`.

Later these inequalities will be used in to restate `convex_on` in terms of monotonicity of the
slope.
-/

variables {f : k → E} {a b r : k}

local notation `c` := line_map a b r

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is non-strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c ≤ slope f a b`. -/
lemma map_le_line_map_iff_slope_le_slope_left (h : 0 < r * (b - a)) :
  f c ≤ line_map (f a) (f b) r ↔ slope f a c ≤ slope f a b :=
begin
  rw [line_map_apply, line_map_apply, slope, slope,
  vsub_eq_sub, vsub_eq_sub, vsub_eq_sub, vadd_eq_add, vadd_eq_add,
  smul_eq_mul, add_sub_cancel, smul_sub, smul_sub, smul_sub,
  sub_le_iff_le_add, mul_inv_rev₀, mul_smul, mul_smul, ←smul_sub, ←smul_sub, ←smul_add, smul_smul,
  ← mul_inv_rev₀, smul_le_iff_of_pos (inv_pos.2 h), inv_inv₀, smul_smul,
  mul_inv_cancel_right₀ (right_ne_zero_of_mul h.ne'), smul_add,
  smul_inv_smul₀ (left_ne_zero_of_mul h.ne')],
  apply_instance
end

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is non-strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b ≤ slope f a c`. -/
lemma line_map_le_map_iff_slope_le_slope_left (h : 0 < r * (b - a)) :
  line_map (f a) (f b) r ≤ f c ↔ slope f a b ≤ slope f a c :=
@map_le_line_map_iff_slope_le_slope_left k (order_dual E) _ _ _ _ f a b r h

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c < slope f a b`. -/
lemma map_lt_line_map_iff_slope_lt_slope_left (h : 0 < r * (b - a)) :
  f c < line_map (f a) (f b) r ↔ slope f a c < slope f a b :=
lt_iff_lt_of_le_iff_le' (line_map_le_map_iff_slope_le_slope_left h)
  (map_le_line_map_iff_slope_le_slope_left h)

/-- Given `c = line_map a b r`, `a < c`, the point `(c, f c)` is strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b < slope f a c`. -/
lemma line_map_lt_map_iff_slope_lt_slope_left (h : 0 < r * (b - a)) :
  line_map (f a) (f b) r < f c ↔ slope f a b < slope f a c :=
@map_lt_line_map_iff_slope_lt_slope_left k (order_dual E) _ _ _ _ f a b r h

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is non-strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b ≤ slope f c b`. -/
lemma map_le_line_map_iff_slope_le_slope_right (h : 0 < (1 - r) * (b - a)) :
  f c ≤ line_map (f a) (f b) r ↔ slope f a b ≤ slope f c b :=
begin
  rw [← line_map_apply_one_sub, ← line_map_apply_one_sub _ _ r],
  revert h, generalize : 1 - r = r', clear r, intro h,
  simp_rw [line_map_apply, slope, vsub_eq_sub, vadd_eq_add, smul_eq_mul],
  rw [sub_add_eq_sub_sub_swap, sub_self, zero_sub, le_smul_iff_of_pos, inv_inv₀, smul_smul,
    neg_mul_eq_mul_neg, neg_sub, mul_inv_cancel_right₀, le_sub, ← neg_sub (f b), smul_neg,
    neg_add_eq_sub],
  { exact right_ne_zero_of_mul h.ne' },
  { simpa [mul_sub] using h }
end

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is non-strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b ≤ slope f a b`. -/
lemma line_map_le_map_iff_slope_le_slope_right (h : 0 < (1 - r) * (b - a)) :
  line_map (f a) (f b) r ≤ f c ↔ slope f c b ≤ slope f a b :=
@map_le_line_map_iff_slope_le_slope_right k (order_dual E) _ _ _ _ f a b r h

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a b < slope f c b`. -/
lemma map_lt_line_map_iff_slope_lt_slope_right (h : 0 < (1 - r) * (b - a)) :
  f c < line_map (f a) (f b) r ↔ slope f a b < slope f c b :=
lt_iff_lt_of_le_iff_le' (line_map_le_map_iff_slope_le_slope_right h)
  (map_le_line_map_iff_slope_le_slope_right h)

/-- Given `c = line_map a b r`, `c < b`, the point `(c, f c)` is strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b < slope f a b`. -/
lemma line_map_lt_map_iff_slope_lt_slope_right (h : 0 < (1 - r) * (b - a)) :
  line_map (f a) (f b) r < f c ↔ slope f c b < slope f a b :=
@map_lt_line_map_iff_slope_lt_slope_right k (order_dual E) _ _ _ _ f a b r h

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is non-strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c ≤ slope f c b`. -/
lemma map_le_line_map_iff_slope_le_slope (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
  f c ≤ line_map (f a) (f b) r ↔ slope f a c ≤ slope f c b :=
begin
  rw [map_le_line_map_iff_slope_le_slope_left (mul_pos h₀ (sub_pos.2 hab)),
    ← line_map_slope_line_map_slope_line_map f a b r, right_le_line_map_iff_le h₁],
  apply_instance,
  apply_instance,
end

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is non-strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b ≤ slope f a c`. -/
lemma line_map_le_map_iff_slope_le_slope (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
  line_map (f a) (f b) r ≤ f c ↔ slope f c b ≤ slope f a c :=
@map_le_line_map_iff_slope_le_slope k (order_dual E) _ _ _ _ _ _ _ _ hab h₀ h₁

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is strictly below the
segment `[(a, f a), (b, f b)]` if and only if `slope f a c < slope f c b`. -/
lemma map_lt_line_map_iff_slope_lt_slope (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
  f c < line_map (f a) (f b) r ↔ slope f a c < slope f c b :=
lt_iff_lt_of_le_iff_le' (line_map_le_map_iff_slope_le_slope hab h₀ h₁)
  (map_le_line_map_iff_slope_le_slope hab h₀ h₁)

/-- Given `c = line_map a b r`, `a < c < b`, the point `(c, f c)` is strictly above the
segment `[(a, f a), (b, f b)]` if and only if `slope f c b < slope f a c`. -/
lemma line_map_lt_map_iff_slope_lt_slope (hab : a < b) (h₀ : 0 < r) (h₁ : r < 1) :
  line_map (f a) (f b) r < f c ↔ slope f c b < slope f a c :=
@map_lt_line_map_iff_slope_lt_slope k (order_dual E) _ _ _ _ _ _ _ _ hab h₀ h₁

end linear_ordered_field


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.term
import Mathlib.PostPort

universes l

namespace Mathlib

/-
Linear natural number arithmetic terms in pre-normalized form.
-/

namespace omega

namespace nat

/-- The shadow syntax for arithmetic terms. All constants are reified to `cst`
(e.g., `5` is reified to `cst 5`) and all other atomic terms are reified to
`exp` (e.g., `5 * (list.length l)` is reified to `exp 5 \`(list.length l)`).
`exp` accepts a coefficient of type `nat` as its first argument because
multiplication by constant is allowed by the omega test. -/
/-- Similar to `exprterm`, except that all exprs are now replaced with
de Brujin indices of type `nat`. This is akin to generalizing over
the terms represented by the said exprs. -/
inductive preterm where
| cst : ℕ → preterm
| var : ℕ → ℕ → preterm
| add : preterm → preterm → preterm
| sub : preterm → preterm → preterm

namespace preterm

/-- Helper tactic for proof by induction over preterms -/
/-- Preterm evaluation -/
def val (v : ℕ → ℕ) : preterm → ℕ := sorry

@[simp] theorem val_const {v : ℕ → ℕ} {m : ℕ} : val v (cst m) = m := rfl

@[simp] theorem val_var {v : ℕ → ℕ} {m : ℕ} {n : ℕ} : val v (var m n) = m * v n := sorry

@[simp] theorem val_add {v : ℕ → ℕ} {t : preterm} {s : preterm} :
    val v (add t s) = val v t + val v s :=
  rfl

@[simp] theorem val_sub {v : ℕ → ℕ} {t : preterm} {s : preterm} :
    val v (sub t s) = val v t - val v s :=
  rfl

/-- Fresh de Brujin index not used by any variable in argument -/
def fresh_index : preterm → ℕ := sorry

/-- If variable assignments `v` and `w` agree on all variables that occur
in term `t`, the value of `t` under `v` and `w` are identical. -/
theorem val_constant (v : ℕ → ℕ) (w : ℕ → ℕ) (t : preterm) :
    (∀ (x : ℕ), x < fresh_index t → v x = w x) → val v t = val w t :=
  sorry

def repr : preterm → string := sorry

@[simp] def add_one (t : preterm) : preterm := add t (cst 1)

/-- Preterm is free of subtractions -/
def sub_free : preterm → Prop := sorry

end preterm

/-- Return a term (which is in canonical form by definition)
    that is equivalent to the input preterm -/
@[simp] def canonize : preterm → term := sorry

@[simp] theorem val_canonize {v : ℕ → ℕ} {t : preterm} :
    preterm.sub_free t → term.val (fun (x : ℕ) => ↑(v x)) (canonize t) = ↑(preterm.val v t) :=
  sorry

end Mathlib


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

! This file was ported from Lean 3 source module algebra.lie.skew_adjoint
! leanprover-community/mathlib commit 075b3f7d19b9da85a0b54b3e33055a74fc388dec
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Lie.Matrix
import Mathbin.LinearAlgebra.Matrix.BilinearForm

/-!
# Lie algebras of skew-adjoint endomorphisms of a bilinear form

When a module carries a bilinear form, the Lie algebra of endomorphisms of the module contains a
distinguished Lie subalgebra: the skew-adjoint endomorphisms. Such subalgebras are important
because they provide a simple, explicit construction of the so-called classical Lie algebras.

This file defines the Lie subalgebra of skew-adjoint endomorphims cut out by a bilinear form on
a module and proves some basic related results. It also provides the corresponding definitions and
results for the Lie algebra of square matrices.

## Main definitions

  * `skew_adjoint_lie_subalgebra`
  * `skew_adjoint_lie_subalgebra_equiv`
  * `skew_adjoint_matrices_lie_subalgebra`
  * `skew_adjoint_matrices_lie_subalgebra_equiv`

## Tags

lie algebra, skew-adjoint, bilinear form
-/

universe u v w w₁

section SkewAdjointEndomorphisms

open BilinForm

variable {R : Type u} {M : Type v} [CommRing R] [AddCommGroup M] [Module R M]

variable (B : BilinForm R M)

theorem BilinForm.is_skew_adjoint_bracket (f g : Module.End R M) (hf : f ∈ B.skewAdjointSubmodule)
    (hg : g ∈ B.skewAdjointSubmodule) : ⁅f, g⁆ ∈ B.skewAdjointSubmodule :=
  by
  rw [mem_skew_adjoint_submodule] at *
  have hfg : is_adjoint_pair B B (f * g) (g * f) :=
    by
    rw [← neg_mul_neg g f]
    exact hf.mul hg
  have hgf : is_adjoint_pair B B (g * f) (f * g) :=
    by
    rw [← neg_mul_neg f g]
    exact hg.mul hf
  change BilinForm.IsAdjointPair B B (f * g - g * f) (-(f * g - g * f))
  rw [neg_sub]
  exact hfg.sub hgf
#align bilin_form.is_skew_adjoint_bracket BilinForm.is_skew_adjoint_bracket

/-- Given an `R`-module `M`, equipped with a bilinear form, the skew-adjoint endomorphisms form a
Lie subalgebra of the Lie algebra of endomorphisms. -/
def skewAdjointLieSubalgebra : LieSubalgebra R (Module.End R M) :=
  { B.skewAdjointSubmodule with lie_mem' := B.is_skew_adjoint_bracket }
#align skew_adjoint_lie_subalgebra skewAdjointLieSubalgebra

variable {N : Type w} [AddCommGroup N] [Module R N] (e : N ≃ₗ[R] M)

/-- An equivalence of modules with bilinear forms gives equivalence of Lie algebras of skew-adjoint
endomorphisms. -/
def skewAdjointLieSubalgebraEquiv :
    skewAdjointLieSubalgebra (B.comp (↑e : N →ₗ[R] M) ↑e) ≃ₗ⁅R⁆ skewAdjointLieSubalgebra B :=
  by
  apply LieEquiv.ofSubalgebras _ _ e.lie_conj
  ext f
  simp only [LieSubalgebra.mem_coe, Submodule.mem_map_equiv, LieSubalgebra.mem_map_submodule,
    coe_coe]
  exact (BilinForm.isPairSelfAdjoint_equiv (-B) B e f).symm
#align skew_adjoint_lie_subalgebra_equiv skewAdjointLieSubalgebraEquiv

@[simp]
theorem skewAdjointLieSubalgebraEquiv_apply (f : skewAdjointLieSubalgebra (B.comp ↑e ↑e)) :
    ↑(skewAdjointLieSubalgebraEquiv B e f) = e.lieConj f := by simp [skewAdjointLieSubalgebraEquiv]
#align skew_adjoint_lie_subalgebra_equiv_apply skewAdjointLieSubalgebraEquiv_apply

@[simp]
theorem skewAdjointLieSubalgebraEquiv_symm_apply (f : skewAdjointLieSubalgebra B) :
    ↑((skewAdjointLieSubalgebraEquiv B e).symm f) = e.symm.lieConj f := by
  simp [skewAdjointLieSubalgebraEquiv]
#align skew_adjoint_lie_subalgebra_equiv_symm_apply skewAdjointLieSubalgebraEquiv_symm_apply

end SkewAdjointEndomorphisms

section SkewAdjointMatrices

open Matrix

variable {R : Type u} {n : Type w} [CommRing R] [DecidableEq n] [Fintype n]

variable (J : Matrix n n R)

theorem Matrix.lie_transpose (A B : Matrix n n R) : ⁅A, B⁆ᵀ = ⁅Bᵀ, Aᵀ⁆ :=
  show (A * B - B * A)ᵀ = Bᵀ * Aᵀ - Aᵀ * Bᵀ by simp
#align matrix.lie_transpose Matrix.lie_transpose

theorem Matrix.is_skew_adjoint_bracket (A B : Matrix n n R)
    (hA : A ∈ skewAdjointMatricesSubmodule J) (hB : B ∈ skewAdjointMatricesSubmodule J) :
    ⁅A, B⁆ ∈ skewAdjointMatricesSubmodule J :=
  by
  simp only [mem_skewAdjointMatricesSubmodule] at *
  change ⁅A, B⁆ᵀ ⬝ J = J ⬝ (-⁅A, B⁆); change Aᵀ ⬝ J = J ⬝ (-A) at hA; change Bᵀ ⬝ J = J ⬝ (-B) at hB
  simp only [← Matrix.mul_eq_mul] at *
  rw [Matrix.lie_transpose, LieRing.of_associative_ring_bracket,
    LieRing.of_associative_ring_bracket, sub_mul, mul_assoc, mul_assoc, hA, hB, ← mul_assoc, ←
    mul_assoc, hA, hB]
  noncomm_ring
#align matrix.is_skew_adjoint_bracket Matrix.is_skew_adjoint_bracket

/-- The Lie subalgebra of skew-adjoint square matrices corresponding to a square matrix `J`. -/
def skewAdjointMatricesLieSubalgebra : LieSubalgebra R (Matrix n n R) :=
  { skewAdjointMatricesSubmodule J with lie_mem' := J.is_skew_adjoint_bracket }
#align skew_adjoint_matrices_lie_subalgebra skewAdjointMatricesLieSubalgebra

@[simp]
theorem mem_skewAdjointMatricesLieSubalgebra (A : Matrix n n R) :
    A ∈ skewAdjointMatricesLieSubalgebra J ↔ A ∈ skewAdjointMatricesSubmodule J :=
  Iff.rfl
#align mem_skew_adjoint_matrices_lie_subalgebra mem_skewAdjointMatricesLieSubalgebra

/-- An invertible matrix `P` gives a Lie algebra equivalence between those endomorphisms that are
skew-adjoint with respect to a square matrix `J` and those with respect to `PᵀJP`. -/
def skewAdjointMatricesLieSubalgebraEquiv (P : Matrix n n R) (h : Invertible P) :
    skewAdjointMatricesLieSubalgebra J ≃ₗ⁅R⁆ skewAdjointMatricesLieSubalgebra (Pᵀ ⬝ J ⬝ P) :=
  LieEquiv.ofSubalgebras _ _ (P.lieConj h).symm
    (by
      ext A
      suffices
        P.lie_conj h A ∈ skewAdjointMatricesSubmodule J ↔
          A ∈ skewAdjointMatricesSubmodule (Pᵀ ⬝ J ⬝ P)
        by
        simp only [LieSubalgebra.mem_coe, Submodule.mem_map_equiv, LieSubalgebra.mem_map_submodule,
          coe_coe]
        exact this
      simp [Matrix.IsSkewAdjoint, J.is_adjoint_pair_equiv' _ _ P (isUnit_of_invertible P)])
#align skew_adjoint_matrices_lie_subalgebra_equiv skewAdjointMatricesLieSubalgebraEquiv

theorem skewAdjointMatricesLieSubalgebraEquiv_apply (P : Matrix n n R) (h : Invertible P)
    (A : skewAdjointMatricesLieSubalgebra J) :
    ↑(skewAdjointMatricesLieSubalgebraEquiv J P h A) = P⁻¹ ⬝ ↑A ⬝ P := by
  simp [skewAdjointMatricesLieSubalgebraEquiv]
#align skew_adjoint_matrices_lie_subalgebra_equiv_apply skewAdjointMatricesLieSubalgebraEquiv_apply

/-- An equivalence of matrix algebras commuting with the transpose endomorphisms restricts to an
equivalence of Lie algebras of skew-adjoint matrices. -/
def skewAdjointMatricesLieSubalgebraEquivTranspose {m : Type w} [DecidableEq m] [Fintype m]
    (e : Matrix n n R ≃ₐ[R] Matrix m m R) (h : ∀ A, (e A)ᵀ = e Aᵀ) :
    skewAdjointMatricesLieSubalgebra J ≃ₗ⁅R⁆ skewAdjointMatricesLieSubalgebra (e J) :=
  LieEquiv.ofSubalgebras _ _ e.toLieEquiv
    (by
      ext A
      suffices J.is_skew_adjoint (e.symm A) ↔ (e J).IsSkewAdjoint A by simpa [this]
      simp [Matrix.IsSkewAdjoint, Matrix.IsAdjointPair, ← Matrix.mul_eq_mul, ← h, ←
        Function.Injective.eq_iff e.injective])
#align skew_adjoint_matrices_lie_subalgebra_equiv_transpose skewAdjointMatricesLieSubalgebraEquivTranspose

@[simp]
theorem skewAdjointMatricesLieSubalgebraEquivTranspose_apply {m : Type w} [DecidableEq m]
    [Fintype m] (e : Matrix n n R ≃ₐ[R] Matrix m m R) (h : ∀ A, (e A)ᵀ = e Aᵀ)
    (A : skewAdjointMatricesLieSubalgebra J) :
    (skewAdjointMatricesLieSubalgebraEquivTranspose J e h A : Matrix m m R) = e A :=
  rfl
#align skew_adjoint_matrices_lie_subalgebra_equiv_transpose_apply skewAdjointMatricesLieSubalgebraEquivTranspose_apply

theorem mem_skewAdjointMatricesLieSubalgebra_unit_smul (u : Rˣ) (J A : Matrix n n R) :
    A ∈ skewAdjointMatricesLieSubalgebra (u • J) ↔ A ∈ skewAdjointMatricesLieSubalgebra J :=
  by
  change A ∈ skewAdjointMatricesSubmodule (u • J) ↔ A ∈ skewAdjointMatricesSubmodule J
  simp only [mem_skewAdjointMatricesSubmodule, Matrix.IsSkewAdjoint, Matrix.IsAdjointPair]
  constructor <;> intro h
  · simpa using congr_arg (fun B => u⁻¹ • B) h
  · simp [h]
#align mem_skew_adjoint_matrices_lie_subalgebra_unit_smul mem_skewAdjointMatricesLieSubalgebra_unit_smul

end SkewAdjointMatrices


import tactic
import group_theory.quotient_group

namespace chapter2.section3

variables {G : Type*} [group G]

-- 定义 3-1 & 命题 3-1 对于正规子群 H 的任意元素 a，其左旁集等于右旁集
lemma definition_3_1 {H : subgroup G} :
  H.normal ↔ ∀ a : G, right_coset ↑H a = left_coset a H :=
⟨
  begin
    intros nH a,
    replace nH := nH.conj_mem,
    ext x,
    unfold right_coset left_coset set.image, simp,
    split; rintro ⟨b,hb, rfl⟩,
    {
      specialize nH _ hb a⁻¹,
      use a⁻¹ * b * a,
      simpa [mul_assoc] using nH,
    },
    {
      specialize nH _ hb a,
      use a * b * a⁻¹,
      simpa [mul_assoc] using nH,
    }
  end,
  λ nH, {
    conj_mem := begin
      dunfold right_coset left_coset set.image at nH,
      intros g hg n,
      specialize nH n,
      rw set.ext_iff at nH,
      simp at nH,
      obtain ⟨g', hg', hh⟩ := (nH (n * g)).mpr ⟨g, hg, rfl⟩,
      convert hg',
      exact mul_inv_eq_of_eq_mul (eq.symm hh),
    end
  }
⟩

-- #check subgroup.centralizer
def my_subgroup_centralizer (H : subgroup G) : subgroup G :=
{
  carrier := H.carrier.centralizer,
  one_mem' := by simp,
  inv_mem' := begin
    simp [set.centralizer],
    intros g h a ha,
    specialize h a ha,
    replace h := eq_mul_inv_of_mul_eq h,
    rw mul_assoc at h,
    replace h := inv_mul_eq_of_eq_mul h,
    exact h.symm,
  end,
  mul_mem' := begin
    simp [set.centralizer],
    intros a b ha hb g hg,
    specialize ha g hg,
    specialize hb g hg,
    clear hg,
    rw ←mul_assoc,
    rw ha,
    rw [mul_assoc, mul_assoc],
    rw ←hb,
  end
}

-- #check subgroup.normalizer
def my_subgroup_normalizer (H : subgroup G) : subgroup G :=
{ carrier := {g : G | ∀ n, n ∈ H ↔ g * n * g⁻¹ ∈ H},
  one_mem' := by simp,
  mul_mem' := begin
    simp,
    intros a b ha hb n,
    convert_to n ∈ H ↔ a * (b * n * b⁻¹) * a⁻¹ ∈ H, { simp [mul_assoc] },
    specialize hb n,
    specialize ha (b * n * b⁻¹),
    rw [hb, ha],
  end,
  inv_mem' := begin
    simp,
    intros a ha n,
    specialize ha (a⁻¹ * n * a⁻¹⁻¹),
    simp [mul_assoc] at *,
    exact ha.symm,
  end
}

def my_subgroup_normalizer2 (H : subgroup G) : subgroup G :=
begin
  have K := my_subgroup_normalizer H,
  refine K.copy {g : G | right_coset ↑H g = left_coset g H} _,
  rw set.ext_iff,
  intro g,
  unfold right_coset left_coset set.image,
  simp,
  rw set.ext_iff,
  simp,
  sorry,
end

-- #check quotient_group.mk

end chapter2.section3


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

Adjoining roots of polynomials
-/
import data.polynomial.field_division
import linear_algebra.finite_dimensional
import ring_theory.adjoin.basic
import ring_theory.power_basis
import ring_theory.principal_ideal_domain

/-!
# Adjoining roots of polynomials

This file defines the commutative ring `adjoin_root f`, the ring R[X]/(f) obtained from a
commutative ring `R` and a polynomial `f : R[X]`. If furthermore `R` is a field and `f` is
irreducible, the field structure on `adjoin_root f` is constructed.

## Main definitions and results

The main definitions are in the `adjoin_root` namespace.

*  `mk f : polynomial R →+* adjoin_root f`, the natural ring homomorphism.

*  `of f : R →+* adjoin_root f`, the natural ring homomorphism.

* `root f : adjoin_root f`, the image of X in R[X]/(f).

* `lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : (adjoin_root f) →+* S`, the ring
  homomorphism from R[X]/(f) to S extending `i : R →+* S` and sending `X` to `x`.

* `lift_hom (x : S) (hfx : aeval x f = 0) : adjoin_root f →ₐ[R] S`, the algebra
  homomorphism from R[X]/(f) to S extending `algebra_map R S` and sending `X` to `x`

* `equiv : (adjoin_root f →ₐ[F] E) ≃ {x // x ∈ (f.map (algebra_map F E)).roots}` a
  bijection between algebra homomorphisms from `adjoin_root` and roots of `f` in `S`

-/
noncomputable theory
open_locale classical
open_locale big_operators

universes u v w

variables {R : Type u} {S : Type v} {K : Type w}

open polynomial ideal

/-- Adjoin a root of a polynomial `f` to a commutative ring `R`. We define the new ring
as the quotient of `R` by the principal ideal of `f`. -/
def adjoin_root [comm_ring R] (f : polynomial R) : Type u :=
ideal.quotient (span {f} : ideal (polynomial R))

namespace adjoin_root

section comm_ring
variables [comm_ring R] (f : polynomial R)

instance : comm_ring (adjoin_root f) := ideal.quotient.comm_ring _

instance : inhabited (adjoin_root f) := ⟨0⟩

instance : decidable_eq (adjoin_root f) := classical.dec_eq _

/-- Ring homomorphism from `R[x]` to `adjoin_root f` sending `X` to the `root`. -/
def mk : polynomial R →+* adjoin_root f := ideal.quotient.mk _

@[elab_as_eliminator]
theorem induction_on {C : adjoin_root f → Prop} (x : adjoin_root f)
  (ih : ∀ p : polynomial R, C (mk f p)) : C x :=
quotient.induction_on' x ih

/-- Embedding of the original ring `R` into `adjoin_root f`. -/
def of : R →+* adjoin_root f := (mk f).comp (ring_hom.of C)

instance : algebra R (adjoin_root f) := (of f).to_algebra

@[simp]

/-- The adjoined root. -/
def root : adjoin_root f := mk f X

variables {f}

instance adjoin_root.has_coe_t : has_coe_t R (adjoin_root f) := ⟨of f⟩

@[simp] lemma mk_self : mk f f = 0 :=
quotient.sound' (mem_span_singleton.2 $ by simp)

@[simp] lemma mk_C (x : R) : mk f (C x) = x := rfl

@[simp] lemma mk_X : mk f X = root f := rfl

@[simp] lemma aeval_eq (p : polynomial R) : aeval (root f) p = mk f p :=
polynomial.induction_on p (λ x, by { rw aeval_C, refl })
  (λ p q ihp ihq, by rw [alg_hom.map_add, ring_hom.map_add, ihp, ihq])
  (λ n x ih, by { rw [alg_hom.map_mul, aeval_C, alg_hom.map_pow, aeval_X,
    ring_hom.map_mul, mk_C, ring_hom.map_pow, mk_X], refl })

theorem adjoin_root_eq_top : algebra.adjoin R ({root f} : set (adjoin_root f)) = ⊤ :=
algebra.eq_top_iff.2 $ λ x, induction_on f x $ λ p,
(algebra.adjoin_singleton_eq_range R (root f)).symm ▸ ⟨p, aeval_eq p⟩

@[simp] lemma eval₂_root (f : polynomial R) : f.eval₂ (of f) (root f) = 0 :=
by rw [← algebra_map_eq, ← aeval_def, aeval_eq, mk_self]

lemma is_root_root (f : polynomial R) : is_root (f.map (of f)) (root f) :=
by rw [is_root, eval_map, eval₂_root]

variables [comm_ring S]

/-- Lift a ring homomorphism `i : R →+* S` to `adjoin_root f →+* S`. -/
def lift (i : R →+* S) (x : S) (h : f.eval₂ i x = 0) : (adjoin_root f) →+* S :=
begin
  apply ideal.quotient.lift _ (eval₂_ring_hom i x),
  intros g H,
  rcases mem_span_singleton.1 H with ⟨y, hy⟩,
  rw [hy, ring_hom.map_mul, coe_eval₂_ring_hom, h, zero_mul]
end

variables {i : R →+* S} {a : S} {h : f.eval₂ i a = 0}

@[simp] lemma lift_mk {g : polynomial R} : lift i a h (mk f g) = g.eval₂ i a :=
ideal.quotient.lift_mk _ _ _

@[simp] lemma lift_root : lift i a h (root f) = a := by rw [root, lift_mk, eval₂_X]

@[simp] lemma lift_of {x : R} : lift i a h x = i x :=
by rw [← mk_C x, lift_mk, eval₂_C]

@[simp] lemma lift_comp_of : (lift i a h).comp (of f) = i :=
ring_hom.ext $ λ _, @lift_of _ _ _ _ _ _ _ h _

variables (f) [algebra R S]

/-- Produce an algebra homomorphism `adjoin_root f →ₐ[R] S` sending `root f` to
a root of `f` in `S`. -/
def lift_hom (x : S) (hfx : aeval x f = 0) : adjoin_root f →ₐ[R] S :=
{ commutes' := λ r, show lift _ _ hfx r = _, from lift_of, .. lift (algebra_map R S) x hfx }

@[simp] lemma coe_lift_hom (x : S) (hfx : aeval x f = 0) :
  (lift_hom f x hfx : adjoin_root f →+* S) = lift (algebra_map R S) x hfx := rfl

@[simp] lemma aeval_alg_hom_eq_zero (ϕ : adjoin_root f →ₐ[R] S) : aeval (ϕ (root f)) f = 0 :=
begin
  have h : ϕ.to_ring_hom.comp (of f) = algebra_map R S := ring_hom.ext_iff.mpr (ϕ.commutes),
  rw [aeval_def, ←h, ←ring_hom.map_zero ϕ.to_ring_hom, ←eval₂_root f, hom_eval₂],
  refl,
end

@[simp] lemma lift_hom_eq_alg_hom (f : polynomial R) (ϕ : adjoin_root f →ₐ[R] S) :
  lift_hom f (ϕ (root f)) (aeval_alg_hom_eq_zero f ϕ) = ϕ :=
begin
  suffices : ϕ.equalizer (lift_hom f (ϕ (root f)) (aeval_alg_hom_eq_zero f ϕ)) = ⊤,
  { exact (alg_hom.ext (λ x, (set_like.ext_iff.mp (this) x).mpr algebra.mem_top)).symm },
  rw [eq_top_iff, ←adjoin_root_eq_top, algebra.adjoin_le_iff, set.singleton_subset_iff],
  exact (@lift_root _ _ _ _ _ _ _ (aeval_alg_hom_eq_zero f ϕ)).symm,
end

/-- If `E` is a field extension of `F` and `f` is a polynomial over `F` then the set
of maps from `F[x]/(f)` into `E` is in bijection with the set of roots of `f` in `E`. -/
def equiv (F E : Type*) [field F] [field E] [algebra F E] (f : polynomial F) (hf : f ≠ 0) :
  (adjoin_root f →ₐ[F] E) ≃ {x // x ∈ (f.map (algebra_map F E)).roots} :=
{ to_fun := λ ϕ, ⟨ϕ (root f), begin
    rw [mem_roots (map_ne_zero hf), is_root.def, ←eval₂_eq_eval_map],
    exact aeval_alg_hom_eq_zero f ϕ,
    exact field.to_nontrivial E, end⟩,
  inv_fun := λ x, lift_hom f ↑x (begin
    rw [aeval_def, eval₂_eq_eval_map, ←is_root.def, ←mem_roots (map_ne_zero hf)],
    exact subtype.mem x,
    exact field.to_nontrivial E end),
  left_inv := λ ϕ, lift_hom_eq_alg_hom f ϕ,
  right_inv := λ x, begin
    ext,
    refine @lift_root F E _ f _ _ ↑x _,
    rw [eval₂_eq_eval_map, ←is_root.def, ←mem_roots (map_ne_zero hf), ←multiset.mem_to_finset],
    exact multiset.mem_to_finset.mpr (subtype.mem x),
    exact field.to_nontrivial E end }

end comm_ring

section irreducible

variables [field K] {f : polynomial K} [irreducible f]

instance is_maximal_span : is_maximal (span {f} : ideal (polynomial K)) :=
principal_ideal_ring.is_maximal_of_irreducible ‹irreducible f›

noncomputable instance field : field (adjoin_root f) :=
{ ..adjoin_root.comm_ring f,
  ..ideal.quotient.field (span {f} : ideal (polynomial K)) }

lemma coe_injective : function.injective (coe : K → adjoin_root f) :=
(of f).injective

variable (f)

lemma mul_div_root_cancel :
  ((X - C (root f)) * (f.map (of f) / (X - C (root f))) : polynomial (adjoin_root f)) =
    f.map (of f) :=
mul_div_eq_iff_is_root.2 $ is_root_root _

end irreducible

section power_basis

variables [field K] {f : polynomial K}

lemma power_basis_is_basis (hf : f ≠ 0) : is_basis K (λ (i : fin f.nat_degree), (root f ^ i.val)) :=
begin
  set f' := f * C (f.leading_coeff⁻¹) with f'_def,
  have deg_f' : f'.nat_degree = f.nat_degree,
  { rw [nat_degree_mul hf, nat_degree_C, add_zero],
    { rwa [ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero] } },
  have f'_monic : monic f' := monic_mul_leading_coeff_inv hf,
  have aeval_f' : aeval (root f) f' = 0,
  { rw [f'_def, alg_hom.map_mul, aeval_eq, mk_self, zero_mul] },
  have hx : is_integral K (root f) := ⟨f', f'_monic, aeval_f'⟩,
  have minpoly_eq : f' = minpoly K (root f),
  { apply minpoly.unique K _ f'_monic aeval_f',
    intros q q_monic q_aeval,
    have commutes : (lift (algebra_map K (adjoin_root f)) (root f) q_aeval).comp (mk q) = mk f,
    { ext,
      { simp only [ring_hom.comp_apply, mk_C, lift_of], refl },
      { simp only [ring_hom.comp_apply, mk_X, lift_root] } },
    rw [degree_eq_nat_degree f'_monic.ne_zero, degree_eq_nat_degree q_monic.ne_zero,
        with_bot.coe_le_coe, deg_f'],
    apply nat_degree_le_of_dvd,
    { rw [←ideal.mem_span_singleton, ←ideal.quotient.eq_zero_iff_mem],
      change mk f q = 0,
      rw [←commutes, ring_hom.comp_apply, mk_self, ring_hom.map_zero] },
    { exact q_monic.ne_zero } },
  refine ⟨_, eq_top_iff.mpr _⟩,
  { rw [←deg_f', minpoly_eq],
    exact hx.linear_independent_pow },
  { rintros y -,
    rw [←deg_f', minpoly_eq],
    apply hx.mem_span_pow,
    obtain ⟨g⟩ := y,
    use g,
    rw aeval_eq,
    refl }
end

/-- The power basis `1, root f, ..., root f ^ (d - 1)` for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
noncomputable def power_basis (hf : f ≠ 0) :
  power_basis K (adjoin_root f) :=
{ gen := root f,
  dim := f.nat_degree,
  is_basis := power_basis_is_basis hf }

end power_basis

end adjoin_root


/-
Copyright (c) 2020 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Riccardo Brasca
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.polynomial.cyclotomic
import Mathlib.topology.algebra.polynomial
import Mathlib.field_theory.finite.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Primes congruent to one

We prove that, for any positive `k : ℕ`, there are infinitely many primes `p` such that
`p ≡ 1 [MOD k]`.
-/

namespace nat

/-- For any positive `k : ℕ` there are infinitely many primes `p` such that `p ≡ 1 [MOD k]`. -/
theorem exists_prime_ge_modeq_one (k : ℕ) (n : ℕ) (hpos : 0 < k) :
    ∃ (p : ℕ), prime p ∧ n ≤ p ∧ modeq k p 1 :=
  sorry

theorem frequently_at_top_modeq_one (k : ℕ) (hpos : 0 < k) :
    filter.frequently (fun (p : ℕ) => prime p ∧ modeq k p 1) filter.at_top :=
  sorry

theorem infinite_set_of_prime_modeq_one (k : ℕ) (hpos : 0 < k) :
    set.infinite (set_of fun (p : ℕ) => prime p ∧ modeq k p 1) :=
  iff.mp frequently_at_top_iff_infinite (frequently_at_top_modeq_one k hpos)

end Mathlib


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Gluing metric spaces
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.metric_space.isometry
import Mathlib.topology.metric_space.premetric_space
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Metric space gluing

Gluing two metric spaces along a common subset. Formally, we are given

```
     Φ
  γ ---> α
  |
  |Ψ
  v
  β
```
where `hΦ : isometry Φ` and `hΨ : isometry Ψ`.
We want to complete the square by a space `glue_space hΦ hΨ` and two isometries
`to_glue_l hΦ hΨ` and `to_glue_r hΦ hΨ` that make the square commute.
We start by defining a predistance on the disjoint union `α ⊕ β`, for which
points `Φ p` and `Ψ p` are at distance 0. The (quotient) metric space associated
to this predistance is the desired space.

This is an instance of a more general construction, where `Φ` and `Ψ` do not have to be isometries,
but the distances in the image almost coincide, up to `2ε` say. Then one can almost glue the two
spaces so that the images of a point under `Φ` and `Ψ` are ε-close. If `ε > 0`, this yields a metric
space structure on `α ⊕ β`, without the need to take a quotient. In particular, when `α` and `β` are
inhabited, this gives a natural metric space structure on `α ⊕ β`, where the basepoints are at
distance 1, say, and the distances between other points are obtained by going through the two
basepoints.

We also define the inductive limit of metric spaces. Given
```
     f 0        f 1        f 2        f 3
X 0 -----> X 1 -----> X 2 -----> X 3 -----> ...
```
where the `X n` are metric spaces and `f n` isometric embeddings, we define the inductive
limit of the `X n`, also known as the increasing union of the `X n` in this context, if we
identify `X n` and `X (n+1)` through `f n`. This is a metric space in which all `X n` embed
isometrically and in a way compatible with `f n`.

-/

namespace metric

/-- Define a predistance on α ⊕ β, for which Φ p and Ψ p are at distance ε -/
def glue_dist {α : Type u} {β : Type v} {γ : Type w} [metric_space α] [metric_space β] (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) : α ⊕ β → α ⊕ β → ℝ :=
  sorry

theorem glue_dist_glued_points {α : Type u} {β : Type v} {γ : Type w} [metric_space α] [metric_space β] [Nonempty γ] (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) (p : γ) : glue_dist Φ Ψ ε (sum.inl (Φ p)) (sum.inr (Ψ p)) = ε := sorry

/-- Given two maps Φ and Ψ intro metric spaces α and β such that the distances between Φ p and Φ q,
and between Ψ p and Ψ q, coincide up to 2 ε where ε > 0, one can almost glue the two spaces α
and β along the images of Φ and Ψ, so that Φ p and Ψ p are at distance ε. -/
def glue_metric_approx {α : Type u} {β : Type v} {γ : Type w} [metric_space α] [metric_space β] [Nonempty γ] (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) (ε0 : 0 < ε) (H : ∀ (p q : γ), abs (dist (Φ p) (Φ q) - dist (Ψ p) (Ψ q)) ≤ bit0 1 * ε) : metric_space (α ⊕ β) :=
  metric_space.mk (glue_dist_self Φ Ψ ε) (glue_eq_of_dist_eq_zero Φ Ψ ε ε0) (glue_dist_comm Φ Ψ ε)
    (glue_dist_triangle Φ Ψ ε H) (fun (x y : α ⊕ β) => ennreal.of_real (glue_dist Φ Ψ ε x y))
    (uniform_space_of_dist (glue_dist Φ Ψ ε) (glue_dist_self Φ Ψ ε) (glue_dist_comm Φ Ψ ε) (glue_dist_triangle Φ Ψ ε H))

/- A particular case of the previous construction is when one uses basepoints in α and β and one
glues only along the basepoints, putting them at distance 1. We give a direct definition of
the distance, without infi, as it is easier to use in applications, and show that it is equal to
the gluing distance defined above to take advantage of the lemmas we have already proved. -/

/- Distance on a disjoint union. There are many (noncanonical) ways to put a distance compatible
with each factor.
If the two spaces are bounded, one can say for instance that each point in the first is at distance
`diam α + diam β + 1` of each point in the second.
Instead, we choose a construction that works for unbounded spaces, but requires basepoints.
We embed isometrically each factor, set the basepoints at distance 1,
arbitrarily, and say that the distance from `a` to `b` is the sum of the distances of `a` and `b` to
their respective basepoints, plus the distance 1 between the basepoints.
Since there is an arbitrary choice in this construction, it is not an instance by default. -/

def sum.dist {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] : α ⊕ β → α ⊕ β → ℝ :=
  sorry

theorem sum.dist_eq_glue_dist {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] {p : α ⊕ β} {q : α ⊕ β} : sum.dist p q = glue_dist (fun (_x : Unit) => Inhabited.default) (fun (_x : Unit) => Inhabited.default) 1 p q := sorry

theorem sum.one_dist_le {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] {x : α} {y : β} : 1 ≤ sum.dist (sum.inl x) (sum.inr y) :=
  le_trans (le_add_of_nonneg_right dist_nonneg)
    (add_le_add_right (le_add_of_nonneg_left dist_nonneg) (dist Inhabited.default y))

theorem sum.one_dist_le' {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] {x : α} {y : β} : 1 ≤ sum.dist (sum.inr y) (sum.inl x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 ≤ sum.dist (sum.inr y) (sum.inl x))) (sum.dist_comm (sum.inr y) (sum.inl x))))
    sum.one_dist_le

/-- The distance on the disjoint union indeed defines a metric space. All the distance properties
follow from our choice of the distance. The harder work is to show that the uniform structure
defined by the distance coincides with the disjoint union uniform structure. -/
def metric_space_sum {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] : metric_space (α ⊕ β) :=
  metric_space.mk sorry sorry sum.dist_comm sorry (fun (x y : α ⊕ β) => ennreal.of_real (sum.dist x y)) sum.uniform_space

theorem sum.dist_eq {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] {x : α ⊕ β} {y : α ⊕ β} : dist x y = sum.dist x y :=
  rfl

/-- The left injection of a space in a disjoint union in an isometry -/
theorem isometry_on_inl {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] : isometry sum.inl :=
  iff.mpr isometry_emetric_iff_metric fun (x y : α) => rfl

/-- The right injection of a space in a disjoint union in an isometry -/
theorem isometry_on_inr {α : Type u} {β : Type v} [metric_space α] [metric_space β] [Inhabited α] [Inhabited β] : isometry sum.inr :=
  iff.mpr isometry_emetric_iff_metric fun (x y : β) => rfl

/- Exact gluing of two metric spaces along isometric subsets. -/

def glue_premetric {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) : premetric_space (α ⊕ β) :=
  premetric_space.mk sorry sorry sorry

def glue_space {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) :=
  premetric.metric_quot (α ⊕ β)

protected instance metric_space_glue_space {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) : metric_space (glue_space hΦ hΨ) :=
  premetric.metric_space_quot

def to_glue_l {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) (x : α) : glue_space hΦ hΨ :=
  quotient.mk (sum.inl x)

def to_glue_r {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) (y : β) : glue_space hΦ hΨ :=
  quotient.mk (sum.inr y)

protected instance inhabited_left {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) [Inhabited α] : Inhabited (glue_space hΦ hΨ) :=
  { default := to_glue_l hΦ hΨ Inhabited.default }

protected instance inhabited_right {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) [Inhabited β] : Inhabited (glue_space hΦ hΨ) :=
  { default := to_glue_r hΦ hΨ Inhabited.default }

theorem to_glue_commute {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) : to_glue_l hΦ hΨ ∘ Φ = to_glue_r hΦ hΨ ∘ Ψ := sorry

theorem to_glue_l_isometry {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) : isometry (to_glue_l hΦ hΨ) :=
  iff.mpr isometry_emetric_iff_metric fun (_x _x_1 : α) => rfl

theorem to_glue_r_isometry {α : Type u} {β : Type v} {γ : Type w} [Nonempty γ] [metric_space γ] [metric_space α] [metric_space β] {Φ : γ → α} {Ψ : γ → β} (hΦ : isometry Φ) (hΨ : isometry Ψ) : isometry (to_glue_r hΦ hΨ) :=
  iff.mpr isometry_emetric_iff_metric fun (_x _x_1 : β) => rfl

/- In this section, we define the inductive limit of
     f 0        f 1        f 2        f 3
X 0 -----> X 1 -----> X 2 -----> X 3 -----> ...
where the X n are metric spaces and f n isometric embeddings. We do it by defining a premetric
space structure on Σn, X n, where the predistance dist x y is obtained by pushing x and y in a
common X k using composition by the f n, and taking the distance there. This does not depend on
the choice of k as the f n are isometries. The metric space associated to this premetric space
is the desired inductive limit.-/

/-- Predistance on the disjoint union Σn, X n. -/
def inductive_limit_dist {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] (f : (n : ℕ) → X n → X (n + 1)) (x : sigma fun (n : ℕ) => X n) (y : sigma fun (n : ℕ) => X n) : ℝ :=
  dist (nat.le_rec_on sorry f (sigma.snd x)) (nat.le_rec_on sorry f (sigma.snd y))

/-- The predistance on the disjoint union Σn, X n can be computed in any X k for large enough k.-/
theorem inductive_limit_dist_eq_dist {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) (x : sigma fun (n : ℕ) => X n) (y : sigma fun (n : ℕ) => X n) (m : ℕ) (hx : sigma.fst x ≤ m) (hy : sigma.fst y ≤ m) : inductive_limit_dist f x y = dist (nat.le_rec_on hx f (sigma.snd x)) (nat.le_rec_on hy f (sigma.snd y)) := sorry

/-- Premetric space structure on Σn, X n.-/
def inductive_premetric {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) : premetric_space (sigma fun (n : ℕ) => X n) :=
  premetric_space.mk sorry sorry sorry

/-- The type giving the inductive limit in a metric space context. -/
def inductive_limit {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) :=
  premetric.metric_quot (sigma fun (n : ℕ) => X n)

/-- Metric space structure on the inductive limit. -/
protected instance metric_space_inductive_limit {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) : metric_space (inductive_limit I) :=
  premetric.metric_space_quot

/-- Mapping each `X n` to the inductive limit. -/
def to_inductive_limit {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) (n : ℕ) (x : X n) : inductive_limit I :=
  quotient.mk (sigma.mk n x)

protected instance inductive_limit.inhabited {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) [Inhabited (X 0)] : Inhabited (inductive_limit I) :=
  { default := to_inductive_limit I 0 Inhabited.default }

/-- The map `to_inductive_limit n` mapping `X n` to the inductive limit is an isometry. -/
theorem to_inductive_limit_isometry {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) (n : ℕ) : isometry (to_inductive_limit I n) := sorry

/-- The maps `to_inductive_limit n` are compatible with the maps `f n`. -/
theorem to_inductive_limit_commute {X : ℕ → Type u} [(n : ℕ) → metric_space (X n)] {f : (n : ℕ) → X n → X (n + 1)} (I : ∀ (n : ℕ), isometry (f n)) (n : ℕ) : to_inductive_limit I (Nat.succ n) ∘ f n = to_inductive_limit I n := sorry


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

! This file was ported from Lean 3 source module algebraic_geometry.elliptic_curve.weierstrass
! leanprover-community/mathlib commit 03994e05d8bfc59a41d2ec99523d6553d21848ac
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.CubicDiscriminant
import Mathbin.RingTheory.Norm
import Mathbin.Tactic.LinearCombination

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

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

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

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

universe 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 WeierstrassCurve (R : Type u) where
  (a₁ a₂ a₃ a₄ a₆ : R)
#align weierstrass_curve WeierstrassCurve

instance [Inhabited R] : Inhabited <| WeierstrassCurve R :=
  ⟨⟨default, default, default, default, default⟩⟩

namespace WeierstrassCurve

variable [CommRing R] (W : WeierstrassCurve R)

section Quantity

/-! ### Standard quantities -/

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

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

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

/-- 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
#align weierstrass_curve.b₈ WeierstrassCurve.b₈

theorem b_relation : 4 * W.b₈ = W.b₂ * W.b₆ - W.b₄ ^ 2 :=
  by
  simp only [b₂, b₄, b₆, b₈]
  ring1
#align weierstrass_curve.b_relation WeierstrassCurve.b_relation

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

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

/-- 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₆
#align weierstrass_curve.Δ WeierstrassCurve.Δ

theorem c_relation : 1728 * W.Δ = W.c₄ ^ 3 - W.c₆ ^ 2 :=
  by
  simp only [b₂, b₄, b₆, b₈, c₄, c₆, Δ]
  ring1
#align weierstrass_curve.c_relation WeierstrassCurve.c_relation

end Quantity

section VariableChange

/-! ### Variable changes -/

variable (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 variableChange : WeierstrassCurve R
    where
  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₁)
#align weierstrass_curve.variable_change WeierstrassCurve.variableChange

@[simp]
theorem variableChange_b₂ : (W.variableChange u r s t).b₂ = ↑u⁻¹ ^ 2 * (W.b₂ + 12 * r) :=
  by
  simp only [b₂, variable_change_a₁, variable_change_a₂]
  ring1
#align weierstrass_curve.variable_change_b₂ WeierstrassCurve.variableChange_b₂

@[simp]
theorem variableChange_b₄ :
    (W.variableChange 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
#align weierstrass_curve.variable_change_b₄ WeierstrassCurve.variableChange_b₄

@[simp]
theorem variableChange_b₆ :
    (W.variableChange 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
#align weierstrass_curve.variable_change_b₆ WeierstrassCurve.variableChange_b₆

@[simp]
theorem variableChange_b₈ :
    (W.variableChange 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
#align weierstrass_curve.variable_change_b₈ WeierstrassCurve.variableChange_b₈

@[simp]
theorem variableChange_c₄ : (W.variableChange u r s t).c₄ = ↑u⁻¹ ^ 4 * W.c₄ :=
  by
  simp only [c₄, variable_change_b₂, variable_change_b₄]
  ring1
#align weierstrass_curve.variable_change_c₄ WeierstrassCurve.variableChange_c₄

@[simp]
theorem variableChange_c₆ : (W.variableChange u r s t).c₆ = ↑u⁻¹ ^ 6 * W.c₆ :=
  by
  simp only [c₆, variable_change_b₂, variable_change_b₄, variable_change_b₆]
  ring1
#align weierstrass_curve.variable_change_c₆ WeierstrassCurve.variableChange_c₆

@[simp]
theorem variableChange_Δ : (W.variableChange u r s t).Δ = ↑u⁻¹ ^ 12 * W.Δ :=
  by
  dsimp
  ring1
#align weierstrass_curve.variable_change_Δ WeierstrassCurve.variableChange_Δ

end VariableChange

variable (A : Type v) [CommRing A] [Algebra R A] (B : Type w) [CommRing B] [Algebra R B]
  [Algebra A B] [IsScalarTower R A B]

section BaseChange

/-! ### Base changes -/

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

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_b₂ : (W.base_change A).b₂ = algebraMap R A W.b₂ :=
  by
  simp only [b₂, base_change_a₁, base_change_a₂]
  run_tac
    map_simp
#align weierstrass_curve.base_change_b₂ WeierstrassCurve.baseChange_b₂

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_b₄ : (W.base_change A).b₄ = algebraMap R A W.b₄ :=
  by
  simp only [b₄, base_change_a₁, base_change_a₃, base_change_a₄]
  run_tac
    map_simp
#align weierstrass_curve.base_change_b₄ WeierstrassCurve.baseChange_b₄

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_b₆ : (W.base_change A).b₆ = algebraMap R A W.b₆ :=
  by
  simp only [b₆, base_change_a₃, base_change_a₆]
  run_tac
    map_simp
#align weierstrass_curve.base_change_b₆ WeierstrassCurve.baseChange_b₆

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_b₈ : (W.base_change A).b₈ = algebraMap R A W.b₈ :=
  by
  simp only [b₈, base_change_a₁, base_change_a₂, base_change_a₃, base_change_a₄, base_change_a₆]
  run_tac
    map_simp
#align weierstrass_curve.base_change_b₈ WeierstrassCurve.baseChange_b₈

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_c₄ : (W.base_change A).c₄ = algebraMap R A W.c₄ :=
  by
  simp only [c₄, base_change_b₂, base_change_b₄]
  run_tac
    map_simp
#align weierstrass_curve.base_change_c₄ WeierstrassCurve.baseChange_c₄

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_c₆ : (W.base_change A).c₆ = algebraMap R A W.c₆ :=
  by
  simp only [c₆, base_change_b₂, base_change_b₄, base_change_b₆]
  run_tac
    map_simp
#align weierstrass_curve.base_change_c₆ WeierstrassCurve.baseChange_c₆

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp, nolint simp_nf]
theorem baseChange_Δ : (W.base_change A).Δ = algebraMap R A W.Δ :=
  by
  simp only [Δ, base_change_b₂, base_change_b₄, base_change_b₆, base_change_b₈]
  run_tac
    map_simp
#align weierstrass_curve.base_change_Δ WeierstrassCurve.baseChange_Δ

theorem baseChange_self : W.base_change R = W := by ext <;> rfl
#align weierstrass_curve.base_change_self WeierstrassCurve.baseChange_self

theorem baseChange_baseChange : (W.base_change A).base_change B = W.base_change B := by
  ext <;> exact (IsScalarTower.algebraMap_apply R A B _).symm
#align weierstrass_curve.base_change_base_change WeierstrassCurve.baseChange_baseChange

end BaseChange

section TorsionPolynomial

/-! ### 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 twoTorsionPolynomial : Cubic R :=
  ⟨4, W.b₂, 2 * W.b₄, W.b₆⟩
#align weierstrass_curve.two_torsion_polynomial WeierstrassCurve.twoTorsionPolynomial

theorem twoTorsionPolynomial_disc : W.twoTorsionPolynomial.disc = 16 * W.Δ :=
  by
  dsimp [two_torsion_polynomial, Cubic.disc]
  ring1
#align weierstrass_curve.two_torsion_polynomial_disc WeierstrassCurve.twoTorsionPolynomial_disc

theorem twoTorsionPolynomial_disc_isUnit [Invertible (2 : R)] :
    IsUnit W.twoTorsionPolynomial.disc ↔ IsUnit W.Δ :=
  by
  rw [two_torsion_polynomial_disc, IsUnit.mul_iff, show (16 : R) = 2 ^ 4 by norm_num1]
  exact and_iff_right (isUnit_of_invertible <| 2 ^ 4)
#align weierstrass_curve.two_torsion_polynomial_disc_is_unit WeierstrassCurve.twoTorsionPolynomial_disc_isUnit

theorem twoTorsionPolynomial_disc_ne_zero [Nontrivial R] [Invertible (2 : R)] (hΔ : IsUnit W.Δ) :
    W.twoTorsionPolynomial.disc ≠ 0 :=
  (W.twoTorsionPolynomial_disc_isUnit.mpr hΔ).NeZero
#align weierstrass_curve.two_torsion_polynomial_disc_ne_zero WeierstrassCurve.twoTorsionPolynomial_disc_ne_zero

end TorsionPolynomial

-- mathport name: outer_variable
scoped[PolynomialPolynomial] notation "Y" => Polynomial.X

-- mathport name: polynomial_polynomial
scoped[PolynomialPolynomial] notation R "[X][Y]" => Polynomial (Polynomial R)

section Polynomial

/-! ### Weierstrass equations -/

open Polynomial

open 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₆)
#align weierstrass_curve.polynomial WeierstrassCurve.polynomial

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2327590855.C_simp -/
theorem polynomial_eq :
    W.Polynomial =
      Cubic.toPoly
        ⟨0, 1, Cubic.toPoly ⟨0, 0, W.a₁, W.a₃⟩, Cubic.toPoly ⟨-1, -W.a₂, -W.a₄, -W.a₆⟩⟩ :=
  by
  simp only [WeierstrassCurve.polynomial, Cubic.toPoly]
  run_tac
    C_simp
  ring1
#align weierstrass_curve.polynomial_eq WeierstrassCurve.polynomial_eq

theorem polynomial_ne_zero [Nontrivial R] : W.Polynomial ≠ 0 :=
  by
  rw [polynomial_eq]
  exact Cubic.ne_zero_of_b_ne_zero one_ne_zero
#align weierstrass_curve.polynomial_ne_zero WeierstrassCurve.polynomial_ne_zero

@[simp]
theorem degree_polynomial [Nontrivial R] : W.Polynomial.degree = 2 :=
  by
  rw [polynomial_eq]
  exact Cubic.degree_of_b_ne_zero' one_ne_zero
#align weierstrass_curve.degree_polynomial WeierstrassCurve.degree_polynomial

@[simp]
theorem natDegree_polynomial [Nontrivial R] : W.Polynomial.natDegree = 2 :=
  by
  rw [polynomial_eq]
  exact Cubic.natDegree_of_b_ne_zero' one_ne_zero
#align weierstrass_curve.nat_degree_polynomial WeierstrassCurve.natDegree_polynomial

theorem monic_polynomial : W.Polynomial.Monic :=
  by
  nontriviality R
  simpa only [polynomial_eq] using Cubic.monic_of_b_eq_one'
#align weierstrass_curve.monic_polynomial WeierstrassCurve.monic_polynomial

theorem irreducible_polynomial [IsDomain R] : Irreducible W.Polynomial :=
  by
  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] <;> decide
  any_goals rw [degree_add_eq_right_of_degree_lt] <;> simp only [h] <;> decide
#align weierstrass_curve.irreducible_polynomial WeierstrassCurve.irreducible_polynomial

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3687834639.eval_simp -/
@[simp]
theorem 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 [WeierstrassCurve.polynomial]
  run_tac
    eval_simp
  rw [add_mul, ← add_assoc]
#align weierstrass_curve.eval_polynomial WeierstrassCurve.eval_polynomial

@[simp]
theorem eval_polynomial_zero : (W.Polynomial.eval 0).eval 0 = -W.a₆ := by
  simp only [← C_0, eval_polynomial, zero_add, zero_sub, MulZeroClass.mul_zero,
    zero_pow (Nat.zero_lt_succ _)]
#align weierstrass_curve.eval_polynomial_zero WeierstrassCurve.eval_polynomial_zero

/-- 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
#align weierstrass_curve.equation WeierstrassCurve.Equation

theorem 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]
#align weierstrass_curve.equation_iff' WeierstrassCurve.equation_iff'

@[simp]
theorem 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]
#align weierstrass_curve.equation_iff WeierstrassCurve.equation_iff

@[simp]
theorem equation_zero : W.Equation 0 0 ↔ W.a₆ = 0 := by
  rw [equation, C_0, eval_polynomial_zero, neg_eq_zero]
#align weierstrass_curve.equation_zero WeierstrassCurve.equation_zero

theorem equation_iff_variableChange (x y : R) :
    W.Equation x y ↔ (W.variableChange 1 x 0 y).Equation 0 0 :=
  by
  rw [equation_iff', ← neg_eq_zero, equation_zero, variable_change_a₆, inv_one, Units.val_one]
  congr 2
  ring1
#align weierstrass_curve.equation_iff_variable_change WeierstrassCurve.equation_iff_variableChange

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
theorem equation_iff_baseChange [Nontrivial A] [NoZeroSMulDivisors R A] (x y : R) :
    W.Equation x y ↔ (W.base_change A).Equation (algebraMap R A x) (algebraMap R A y) :=
  by
  simp only [equation_iff]
  refine' ⟨fun h => _, fun h => _⟩
  ·
    convert congr_arg (algebraMap R A) h <;>
      · run_tac
          map_simp
        rfl
  · apply NoZeroSMulDivisors.algebraMap_injective R A
    run_tac
      map_simp
    exact h
#align weierstrass_curve.equation_iff_base_change WeierstrassCurve.equation_iff_baseChange

theorem equation_iff_baseChange_of_baseChange [Nontrivial B] [NoZeroSMulDivisors A B] (x y : A) :
    (W.base_change A).Equation x y ↔
      (W.base_change B).Equation (algebraMap A B x) (algebraMap A B y) :=
  by rw [equation_iff_base_change (W.base_change A) B, base_change_base_change]
#align weierstrass_curve.equation_iff_base_change_of_base_change WeierstrassCurve.equation_iff_baseChange_of_baseChange

/-! ### 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 polynomialX : R[X][Y] :=
  C (C W.a₁) * Y - C (C 3 * X ^ 2 + C (2 * W.a₂) * X + C W.a₄)
#align weierstrass_curve.polynomial_X WeierstrassCurve.polynomialX

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3687834639.eval_simp -/
@[simp]
theorem eval_polynomialX (x y : R) :
    (W.polynomialX.eval <| C y).eval x = W.a₁ * y - (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄) :=
  by
  simp only [polynomial_X]
  run_tac
    eval_simp
#align weierstrass_curve.eval_polynomial_X WeierstrassCurve.eval_polynomialX

@[simp]
theorem eval_polynomialX_zero : (W.polynomialX.eval 0).eval 0 = -W.a₄ := by
  simp only [← C_0, eval_polynomial_X, zero_add, zero_sub, MulZeroClass.mul_zero,
    zero_pow zero_lt_two]
#align weierstrass_curve.eval_polynomial_X_zero WeierstrassCurve.eval_polynomialX_zero

/-- 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 polynomialY : R[X][Y] :=
  C (C 2) * Y + C (C W.a₁ * X + C W.a₃)
#align weierstrass_curve.polynomial_Y WeierstrassCurve.polynomialY

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.3687834639.eval_simp -/
@[simp]
theorem eval_polynomialY (x y : R) : (W.polynomialY.eval <| C y).eval x = 2 * y + W.a₁ * x + W.a₃ :=
  by
  simp only [polynomial_Y]
  run_tac
    eval_simp
  rw [← add_assoc]
#align weierstrass_curve.eval_polynomial_Y WeierstrassCurve.eval_polynomialY

@[simp]
theorem eval_polynomialY_zero : (W.polynomialY.eval 0).eval 0 = W.a₃ := by
  simp only [← C_0, eval_polynomial_Y, zero_add, MulZeroClass.mul_zero]
#align weierstrass_curve.eval_polynomial_Y_zero WeierstrassCurve.eval_polynomialY_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.polynomialX.eval <| C y).eval x ≠ 0 ∨ (W.polynomialY.eval <| C y).eval x ≠ 0)
#align weierstrass_curve.nonsingular WeierstrassCurve.Nonsingular

theorem 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]
#align weierstrass_curve.nonsingular_iff' WeierstrassCurve.nonsingular_iff'

@[simp]
theorem 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
#align weierstrass_curve.nonsingular_iff WeierstrassCurve.nonsingular_iff

@[simp]
theorem 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']
#align weierstrass_curve.nonsingular_zero WeierstrassCurve.nonsingular_zero

theorem nonsingular_iff_variableChange (x y : R) :
    W.Nonsingular x y ↔ (W.variableChange 1 x 0 y).Nonsingular 0 0 :=
  by
  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.val_one]
  congr 4 <;> ring1
#align weierstrass_curve.nonsingular_iff_variable_change WeierstrassCurve.nonsingular_iff_variableChange

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
theorem nonsingular_iff_baseChange [Nontrivial A] [NoZeroSMulDivisors R A] (x y : R) :
    W.Nonsingular x y ↔ (W.base_change A).Nonsingular (algebraMap R A x) (algebraMap R A y) :=
  by
  rw [nonsingular_iff, nonsingular_iff, and_congr <| W.equation_iff_base_change A x y]
  refine'
    ⟨Or.imp (not_imp_not.mpr fun h => _) (not_imp_not.mpr fun h => _),
      Or.imp (not_imp_not.mpr fun h => _) (not_imp_not.mpr fun h => _)⟩
  any_goals apply NoZeroSMulDivisors.algebraMap_injective R A;
    run_tac
      map_simp;
    exact h
  any_goals
    convert congr_arg (algebraMap R A) h <;>
      · run_tac
          map_simp
        rfl
#align weierstrass_curve.nonsingular_iff_base_change WeierstrassCurve.nonsingular_iff_baseChange

theorem nonsingular_iff_baseChange_of_baseChange [Nontrivial B] [NoZeroSMulDivisors A B] (x y : A) :
    (W.base_change A).Nonsingular x y ↔
      (W.base_change B).Nonsingular (algebraMap A B x) (algebraMap A B y) :=
  by rw [nonsingular_iff_base_change (W.base_change A) B, base_change_base_change]
#align weierstrass_curve.nonsingular_iff_base_change_of_base_change WeierstrassCurve.nonsingular_iff_baseChange_of_baseChange

theorem 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Δ]
#align weierstrass_curve.nonsingular_zero_of_Δ_ne_zero WeierstrassCurve.nonsingular_zero_of_Δ_ne_zero

/-- A Weierstrass curve is nonsingular at every point if its discriminant is non-zero. -/
theorem nonsingular_of_Δ_ne_zero {x y : R} (h : W.Equation x y) (hΔ : W.Δ ≠ 0) :
    W.Nonsingular x y :=
  (W.nonsingular_iff_variableChange x y).mpr <|
    nonsingular_zero_of_Δ_ne_zero _ ((W.equation_iff_variableChange x y).mp h) <| by
      rwa [variable_change_Δ, inv_one, Units.val_one, one_pow, one_mul]
#align weierstrass_curve.nonsingular_of_Δ_ne_zero WeierstrassCurve.nonsingular_of_Δ_ne_zero

/-! ### 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 -/
def CoordinateRing : Type u :=
  AdjoinRoot W.Polynomial deriving Inhabited, CommRing
#align weierstrass_curve.coordinate_ring WeierstrassCurve.CoordinateRing

/-- The function field $R(W) := \mathrm{Frac}(R[W])$ of `W`. -/
abbrev FunctionField : Type u :=
  FractionRing W.CoordinateRing
#align weierstrass_curve.function_field WeierstrassCurve.FunctionField

namespace CoordinateRing

instance [IsDomain R] [NormalizedGCDMonoid R] : IsDomain W.CoordinateRing :=
  (Ideal.Quotient.isDomain_iff_prime _).mpr <| by
    simpa only [Ideal.span_singleton_prime W.polynomial_ne_zero, ←
      GCDMonoid.irreducible_iff_prime] using W.irreducible_polynomial

instance isDomain_of_field {F : Type u} [Field F] (W : WeierstrassCurve F) :
    IsDomain W.CoordinateRing := by classical infer_instance
#align weierstrass_curve.coordinate_ring.is_domain_of_field WeierstrassCurve.CoordinateRing.isDomain_of_field

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

/-- The class of the element $X - x$ in $R[W]$ for some $x \in R$. -/
@[simp]
noncomputable def xClass : W.CoordinateRing :=
  AdjoinRoot.mk W.Polynomial <| C <| X - C x
#align weierstrass_curve.coordinate_ring.X_class WeierstrassCurve.CoordinateRing.xClass

theorem xClass_ne_zero [Nontrivial R] : xClass W x ≠ 0 :=
  AdjoinRoot.mk_ne_zero_of_natDegree_lt W.monic_polynomial (C_ne_zero.mpr <| X_sub_C_ne_zero x) <|
    by
    rw [nat_degree_polynomial, nat_degree_C]
    norm_num1
#align weierstrass_curve.coordinate_ring.X_class_ne_zero WeierstrassCurve.CoordinateRing.xClass_ne_zero

/-- The class of the element $Y - y(X)$ in $R[W]$ for some $y(X) \in R[X]$. -/
@[simp]
noncomputable def yClass : W.CoordinateRing :=
  AdjoinRoot.mk W.Polynomial <| Y - C y
#align weierstrass_curve.coordinate_ring.Y_class WeierstrassCurve.CoordinateRing.yClass

theorem yClass_ne_zero [Nontrivial R] : yClass W y ≠ 0 :=
  AdjoinRoot.mk_ne_zero_of_natDegree_lt W.monic_polynomial (X_sub_C_ne_zero y) <|
    by
    rw [nat_degree_polynomial, nat_degree_X_sub_C]
    norm_num1
#align weierstrass_curve.coordinate_ring.Y_class_ne_zero WeierstrassCurve.CoordinateRing.yClass_ne_zero

/-- The ideal $\langle X - x \rangle$ of $R[W]$ for some $x \in R$. -/
@[simp]
noncomputable def xIdeal : Ideal W.CoordinateRing :=
  Ideal.span {xClass W x}
#align weierstrass_curve.coordinate_ring.X_ideal WeierstrassCurve.CoordinateRing.xIdeal

/-- The ideal $\langle Y - y(X) \rangle$ of $R[W]$ for some $y(X) \in R[X]$. -/
@[simp]
noncomputable def yIdeal : Ideal W.CoordinateRing :=
  Ideal.span {yClass W y}
#align weierstrass_curve.coordinate_ring.Y_ideal WeierstrassCurve.CoordinateRing.yIdeal

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

noncomputable instance : Algebra R[X] W.CoordinateRing :=
  Ideal.Quotient.algebra R[X]

noncomputable instance algebra' : Algebra R W.CoordinateRing :=
  Ideal.Quotient.algebra R
#align weierstrass_curve.coordinate_ring.algebra' WeierstrassCurve.CoordinateRing.algebra'

instance : IsScalarTower R R[X] W.CoordinateRing :=
  Ideal.Quotient.isScalarTower R R[X] _

instance [Subsingleton R] : Subsingleton W.CoordinateRing :=
  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.CoordinateRing :=
  (subsingleton_or_nontrivial R).byCases (fun _ => default) fun _ =>
    (AdjoinRoot.powerBasis' W.monic_polynomial).Basis.reindex <| finCongr W.nat_degree_polynomial
#align weierstrass_curve.coordinate_ring.basis WeierstrassCurve.CoordinateRing.basis

theorem basis_apply (n : Fin 2) :
    W.CoordinateRing.Basis n = (AdjoinRoot.powerBasis' W.monic_polynomial).gen ^ (n : ℕ) := by
  classical
    nontriviality R
    simpa only [coordinate_ring.basis, Or.by_cases, dif_neg (not_subsingleton R),
      Basis.reindex_apply, PowerBasis.basis_eq_pow]
#align weierstrass_curve.coordinate_ring.basis_apply WeierstrassCurve.CoordinateRing.basis_apply

theorem basis_zero : W.CoordinateRing.Basis 0 = 1 := by simpa only [basis_apply] using pow_zero _
#align weierstrass_curve.coordinate_ring.basis_zero WeierstrassCurve.CoordinateRing.basis_zero

theorem basis_one : W.CoordinateRing.Basis 1 = AdjoinRoot.mk W.Polynomial Y := by
  simpa only [basis_apply] using pow_one _
#align weierstrass_curve.coordinate_ring.basis_one WeierstrassCurve.CoordinateRing.basis_one

@[simp]
theorem coe_basis :
    (W.CoordinateRing.Basis : Fin 2 → W.CoordinateRing) = ![1, AdjoinRoot.mk W.Polynomial Y] :=
  by
  ext n
  fin_cases n
  exacts[basis_zero W, basis_one W]
#align weierstrass_curve.coordinate_ring.coe_basis WeierstrassCurve.CoordinateRing.coe_basis

variable {W}

theorem smul (x : R[X]) (y : W.CoordinateRing) : x • y = AdjoinRoot.mk W.Polynomial (C x) * y :=
  (algebraMap_smul W.CoordinateRing x y).symm
#align weierstrass_curve.coordinate_ring.smul WeierstrassCurve.CoordinateRing.smul

theorem smul_basis_eq_zero {p q : R[X]} (hpq : p • 1 + q • AdjoinRoot.mk W.Polynomial Y = 0) :
    p = 0 ∧ q = 0 :=
  by
  have h := fintype.linear_independent_iff.mp (coordinate_ring.basis W).LinearIndependent ![p, q]
  erw [Fin.sum_univ_succ, basis_zero, Fin.sum_univ_one, basis_one] at h
  exact ⟨h hpq 0, h hpq 1⟩
#align weierstrass_curve.coordinate_ring.smul_basis_eq_zero WeierstrassCurve.CoordinateRing.smul_basis_eq_zero

theorem exists_smul_basis_eq (x : W.CoordinateRing) :
    ∃ p q : R[X], p • 1 + q • AdjoinRoot.mk W.Polynomial Y = x :=
  by
  have h := (coordinate_ring.basis W).sum_equivFun x
  erw [Fin.sum_univ_succ, Fin.sum_univ_one, basis_zero, basis_one] at h
  exact ⟨_, _, h⟩
#align weierstrass_curve.coordinate_ring.exists_smul_basis_eq WeierstrassCurve.CoordinateRing.exists_smul_basis_eq

variable (W)

theorem smul_basis_mul_c (p q : R[X]) :
    (p • 1 + q • AdjoinRoot.mk W.Polynomial Y) * AdjoinRoot.mk W.Polynomial (C y) =
      (p * y) • 1 + (q * y) • AdjoinRoot.mk W.Polynomial Y :=
  by
  simp only [smul, map_mul]
  ring1
#align weierstrass_curve.coordinate_ring.smul_basis_mul_C WeierstrassCurve.CoordinateRing.smul_basis_mul_c

theorem smul_basis_mul_Y (p q : R[X]) :
    (p • 1 + q • AdjoinRoot.mk W.Polynomial Y) * AdjoinRoot.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₃)) • AdjoinRoot.mk W.Polynomial Y :=
  by
  have Y_sq :
    AdjoinRoot.mk W.polynomial Y ^ 2 =
      AdjoinRoot.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 [WeierstrassCurve.polynomial]
        ring1⟩
  simp only [smul, add_mul, mul_assoc, ← sq, Y_sq, map_sub, map_mul]
  ring1
#align weierstrass_curve.coordinate_ring.smul_basis_mul_Y WeierstrassCurve.CoordinateRing.smul_basis_mul_Y

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

theorem norm_smul_basis (p q : R[X]) :
    Algebra.norm R[X] (p • 1 + q • AdjoinRoot.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₆) :=
  by
  simp_rw [Algebra.norm_eq_matrix_det W.CoordinateRing.Basis, Matrix.det_fin_two,
    Algebra.leftMulMatrix_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
#align weierstrass_curve.coordinate_ring.norm_smul_basis WeierstrassCurve.CoordinateRing.norm_smul_basis

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.2327590855.C_simp -/
theorem coe_norm_smul_basis (p q : R[X]) :
    ↑(Algebra.norm R[X] <| p • 1 + q • AdjoinRoot.mk W.Polynomial Y) =
      AdjoinRoot.mk W.Polynomial ((C p + C q * X) * (C p + C q * (-X - C (C W.a₁ * X + C W.a₃)))) :=
  AdjoinRoot.mk_eq_mk.mpr
    ⟨C q ^ 2, by
      rw [norm_smul_basis, WeierstrassCurve.polynomial]
      run_tac
        C_simp
      ring1⟩
#align weierstrass_curve.coordinate_ring.coe_norm_smul_basis WeierstrassCurve.CoordinateRing.coe_norm_smul_basis

theorem degree_norm_smul_basis [IsDomain R] (p q : R[X]) :
    (Algebra.norm R[X] <| p • 1 + q • AdjoinRoot.mk W.Polynomial Y).degree =
      max (2 • p.degree) (2 • q.degree + 3) :=
  by
  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 := by
    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 :=
    by 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, MulZeroClass.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, MulZeroClass.zero_mul, MulZeroClass.mul_zero,
      zero_pow zero_lt_two] using (max_bot_right _).symm
  rw [← not_congr 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])
#align weierstrass_curve.coordinate_ring.degree_norm_smul_basis WeierstrassCurve.CoordinateRing.degree_norm_smul_basis

variable {W}

theorem degree_norm_ne_one [IsDomain R] (x : W.CoordinateRing) : (Algebra.norm R[X] x).degree ≠ 1 :=
  by
  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 (by decide)).ne'
#align weierstrass_curve.coordinate_ring.degree_norm_ne_one WeierstrassCurve.CoordinateRing.degree_norm_ne_one

theorem natDegree_norm_ne_one [IsDomain R] (x : W.CoordinateRing) :
    (Algebra.norm R[X] x).natDegree ≠ 1 :=
  mt (degree_eq_iff_natDegree_eq_of_pos zero_lt_one).mpr <| degree_norm_ne_one x
#align weierstrass_curve.coordinate_ring.nat_degree_norm_ne_one WeierstrassCurve.CoordinateRing.natDegree_norm_ne_one

end CoordinateRing

end Polynomial

end WeierstrassCurve

/-! ## 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 EllipticCurve (R : Type u) [CommRing R] extends WeierstrassCurve R where
  Δ' : Rˣ
  coe_Δ' : ↑Δ' = to_weierstrass_curve.Δ
#align elliptic_curve EllipticCurve

instance : Inhabited <| EllipticCurve ℚ :=
  ⟨⟨⟨0, 0, 1, -1, 0⟩, ⟨37, 37⁻¹, by norm_num1, by norm_num1⟩,
      by
      dsimp
      ring1⟩⟩

namespace EllipticCurve

variable [CommRing R] (E : EllipticCurve R)

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

theorem twoTorsionPolynomial_disc_ne_zero [Nontrivial R] [Invertible (2 : R)] :
    E.twoTorsionPolynomial.disc ≠ 0 :=
  E.twoTorsionPolynomial_disc_ne_zero <| E.coe_Δ' ▸ E.Δ'.IsUnit
#align elliptic_curve.two_torsion_polynomial_disc_ne_zero EllipticCurve.twoTorsionPolynomial_disc_ne_zero

theorem nonsingular [Nontrivial R] {x y : R} (h : E.Equation x y) : E.Nonsingular x y :=
  E.nonsingular_of_Δ_ne_zero h <| E.coe_Δ' ▸ E.Δ'.NeZero
#align elliptic_curve.nonsingular EllipticCurve.nonsingular

section VariableChange

/-! ### Variable changes -/

variable (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 variableChange : EllipticCurve R :=
  ⟨E.variableChange u r s t, u⁻¹ ^ 12 * E.Δ', by
    rw [Units.val_mul, Units.val_pow_eq_pow_val, coe_Δ', E.variable_change_Δ]⟩
#align elliptic_curve.variable_change EllipticCurve.variableChange

theorem coe_variableChange_Δ' : (↑(E.variableChange u r s t).Δ' : R) = ↑u⁻¹ ^ 12 * E.Δ' := by
  rw [variable_change_Δ', Units.val_mul, Units.val_pow_eq_pow_val]
#align elliptic_curve.coe_variable_change_Δ' EllipticCurve.coe_variableChange_Δ'

theorem coe_inv_variableChange_Δ' : (↑(E.variableChange u r s t).Δ'⁻¹ : R) = u ^ 12 * ↑E.Δ'⁻¹ := by
  rw [variable_change_Δ', mul_inv, inv_pow, inv_inv, Units.val_mul, Units.val_pow_eq_pow_val]
#align elliptic_curve.coe_inv_variable_change_Δ' EllipticCurve.coe_inv_variableChange_Δ'

@[simp]
theorem variableChange_j : (E.variableChange u r s t).j = E.j :=
  by
  rw [j, coe_inv_variable_change_Δ']
  have hu : (u * ↑u⁻¹ : R) ^ 12 = 1 := by rw [u.mul_inv, one_pow]
  linear_combination (norm := (dsimp; ring1)) E.j * hu
#align elliptic_curve.variable_change_j EllipticCurve.variableChange_j

end VariableChange

section BaseChange

/-! ### Base changes -/

variable (A : Type v) [CommRing A] [Algebra R A]

/-- The elliptic curve over `R` base changed to `A`. -/
@[simps]
def baseChange : EllipticCurve A :=
  ⟨E.base_change A, Units.map (↑(algebraMap R A)) E.Δ', by
    rw [Units.coe_map, [anonymous], coe_Δ', E.base_change_Δ]⟩
#align elliptic_curve.base_change EllipticCurve.baseChange

theorem coeBase_change_Δ' : ↑(E.base_change A).Δ' = algebraMap R A E.Δ' :=
  rfl
#align elliptic_curve.coe_base_change_Δ' EllipticCurve.coeBase_change_Δ'

theorem coe_inv_baseChange_Δ' : ↑(E.base_change A).Δ'⁻¹ = algebraMap R A ↑E.Δ'⁻¹ :=
  rfl
#align elliptic_curve.coe_inv_base_change_Δ' EllipticCurve.coe_inv_baseChange_Δ'

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.367748183.map_simp -/
@[simp]
theorem baseChange_j : (E.base_change A).j = algebraMap R A E.j :=
  by
  simp only [j, coe_inv_base_change_Δ', base_change_to_weierstrass_curve, E.base_change_c₄]
  run_tac
    map_simp
#align elliptic_curve.base_change_j EllipticCurve.baseChange_j

end BaseChange

end EllipticCurve


meta def triv_tac : tactic unit := tactic.interactive.exact ``(dec_trivial)

-- m and n (the two numbers on the board) are constant.

-- The possible worlds are pairs (a,b) of nats with a+b=m or a+b=n

structure possible_worlds (m n : ℕ) :=
(a : ℕ) (b : ℕ) (H : a+b=m ∨ a+b=n)

open nat

-- the predicate "beliefs m n t" represents the beliefs (i.e. opinions of the
-- possible worlds) of, if t is even, player A, and if t is odd, player B.
def beliefs (m n : ℕ) : ℕ → possible_worlds m n → Prop
|  0 := λ w, let ⟨a,b,H⟩ := w in (a+b=m ∨ a+b=n)
| (succ 0) := λ w, let ⟨a,b,H⟩ := w in (a+b=m ∨ a+b=n) ∧ ∃ bb : ℕ, ¬ (b = bb) ∧ (a+bb=m ∨ a+bb=n)
/- player B wants to say
 "I know that player A couldn't work it out immediately"
so
"there's another value bb which I could have which is distinct to b and logically consistent"
-/
| (succ (succ t)) := λ w, let ⟨a,b,_⟩ := w in beliefs t w ∧ ite (2 ∣ t)
  (∃ aa : ℕ, ¬ (a = aa) ∧ ∃ H : (aa+b=m ∨ aa+b=n), beliefs (succ t) ⟨aa,b,H⟩)
  (∃ bb : ℕ, ¬ (b = bb) ∧ ∃ H : (a+bb=m ∨ a+bb=n), beliefs (succ t) ⟨a,bb,H⟩)
/- this guy wants to say
"I now know that there's a possible value for my secret other than the correct one,
 and for which the other guys beliefs are currently OK"
-/

theorem T0 : (beliefs 2 3 0 ⟨1,2,dec_trivial⟩) :=
begin
unfold beliefs,
exact dec_trivial,
end

theorem T1 : (beliefs 2 3 1 ⟨1,2,dec_trivial⟩) :=
begin
unfold beliefs,
split,exact dec_trivial,
existsi 1,
exact dec_trivial,
end

theorem T2 : (beliefs 2 3 2 ⟨1,2,dec_trivial⟩) :=
begin
unfold beliefs,
split,exact dec_trivial,
existsi 0,
split,
exact dec_trivial,
simp,
existsi _,
{ existsi 3,simp,exact dec_trivial
},
{left,trivial

}

end

theorem T3 : (beliefs 2 3 3 ⟨1,2,dec_trivial⟩) :=
begin
unfold beliefs,
split,
split,
exact dec_trivial,
existsi 1,-- bb not 2 but 1+1=2
split;exact dec_trivial,
simp [show ¬ (2 ∣ 1), by exact dec_trivial],
existsi 1,--bb not 2 but 1+1=2
split,exact dec_trivial,
existsi _,
split,
left,exact dec_trivial,
tactic.swap,exact dec_trivial,
existsi 2,-- aa not 1 but 2+1=3
split,exact dec_trivial,
existsi _,
split,
right,refl,
existsi 0,-- bb not 1 but 2+0=2
split;simp,right,simp,
end

theorem T4 : (beliefs 2 3 4 ⟨1,2,dec_trivial⟩) :=
begin
unfold beliefs,
simp,
split,
existsi 0,-- aa not 1 but 0+2=2
split,exact dec_trivial,
existsi _,
split,left,refl,
existsi 3,--bb not 2 but 0+3=3
split,exact dec_trivial,
right,refl,left,refl,
existsi 0,--aa not 1 but 0+2=2
split,
simp,
existsi _,
split,
split,left,refl,
existsi 3,--bb not 2 but 0+3=3
split,exact dec_trivial,right,refl,
simp [show ¬(2 ∣ 1), from dec_trivial],
existsi 3,--bb not 2 and 0+3=3
split,exact dec_trivial,
existsi _,
split,right,refl,

repeat {admit},
end

lemma technical_lemma1 (m n a b : ℕ) (H : a + b = m ∨ a + b = n)
(H2 : a + b + b ≤ m + n) : let aa : ℕ := m + n - (a + b + b) in
aa + b = m ∨ aa + b = n:=
begin
let aa : ℕ := m + n - (a + b + b),
have H4 : aa + (a + b + b) = m+n,
      show (m + n - (a + b + b))+ (a + b + b) = m+n,
      apply nat.sub_add_cancel H2,
      cases H with H H,
      { rw H at H4,
      right,
      suffices : m + (aa + b) = m + n,
      exact nat.add_left_cancel this,
      rw ← H4,
      simp,
      },
      { rw H at H4,
        left,
        show aa + b = m,
        suffices : (aa+b)+n=m+n,
        exact nat.add_right_cancel this,
        rw ← H4,
        simp,
      }
end

lemma technical_lemma2 (m n a b : ℕ) (H : a + b = m ∨ a + b = n)
(H2 : b + a + a ≤ m + n) : let bb : ℕ := m + n - (b + a + a) in
a + bb = m ∨ a + bb = n:=
begin
let bb : ℕ := m + n - (b + a + a),
have H4 : bb + (b + a + a) = m+n,
      show (m + n - (b + a + a))+ (b + a + a) = m+n,
      apply nat.sub_add_cancel H2,
      cases H with H H,
      { have H1 : b + a = m := by rw ←H;simp,
        rw H1 at H4,
      right,
      suffices : m + (a + bb) = m + n,
      exact nat.add_left_cancel this,
      rw ← H4,
      simp,
      },
      { have H1 : b + a = n := by rw ←H;simp,
        rw H1 at H4,
        left,
        show a + bb = m,
        suffices : (a+bb)+n=m+n,
        exact nat.add_right_cancel this,
        rw ← H4,
        simp,
      }
end

def beliefs2 (m n : ℕ) : ℕ → possible_worlds m n → Prop
|  0 := λ w, let ⟨a,b,H⟩ := w in (a+b=m ∨ a+b=n)
| (succ 0) := λ w, let ⟨a,b,H⟩ := w in (a+b=m ∨ a+b=n) ∧ ∃ bb : ℕ, ¬ (b = bb) ∧ (a+bb=m ∨ a+bb=n)
/- player B wants to say
 "I know that player A couldn't work it out immediately"
so
"there's another value bb which I could have which is distinct to b and logically consistent"
-/
| (succ (succ t)) := λ w, let ⟨a,b,H⟩ := w in beliefs2 t w ∧ ite (2 ∣ t)
  --(∃ aa : ℕ, ¬ (a = aa) ∧ ∃ H : (aa+b=m ∨ aa+b=n), beliefs2 (succ t) ⟨aa,b,H⟩)
  (let aa := m + n - (a + b + b) in a + b + b ≤ m + n ∧ (a + b + b ≤ m + n → beliefs2 (succ t) ⟨aa,b,
    technical_lemma1 m n a b (by assumption) (by assumption)⟩))
  -- aa +b + a + b must be m + n
  (let bb := m + n - (b + a + a) in b + a + a ≤ m + n ∧ (b + a + a ≤ m + n → beliefs2 (succ t) ⟨a,bb,
    technical_lemma2 m n a b (by assumption) (by assumption)⟩))
/- this guy wants to say
"I now know that there's more than one b for which the other guys beliefs are OK"
-/