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

! This file was ported from Lean 3 source module analysis.ODE.gronwall
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecialFunctions.ExpDeriv

/-!
# Grönwall's inequality

The main technical result of this file is the Grönwall-like inequality
`norm_le_gronwall_bound_of_norm_deriv_right_le`. It states that if `f : ℝ → E` satisfies `‖f a‖ ≤ δ`
and `∀ x ∈ [a, b), ‖f' x‖ ≤ K * ‖f x‖ + ε`, then for all `x ∈ [a, b]` we have `‖f x‖ ≤ δ * exp (K *
x) + (ε / K) * (exp (K * x) - 1)`.

Then we use this inequality to prove some estimates on the possible rate of growth of the distance
between two approximate or exact solutions of an ordinary differential equation.

The proofs are based on [Hubbard and West, *Differential Equations: A Dynamical Systems Approach*,
Sec. 4.5][HubbardWest-ode], where `norm_le_gronwall_bound_of_norm_deriv_right_le` is called
“Fundamental Inequality”.

## TODO

- Once we have FTC, prove an inequality for a function satisfying `‖f' x‖ ≤ K x * ‖f x‖ + ε`,
  or more generally `liminf_{y→x+0} (f y - f x)/(y - x) ≤ K x * f x + ε` with any sign
  of `K x` and `f x`.
-/

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace ℝ E] {F : Type _} [NormedAddCommGroup F]
  [NormedSpace ℝ F]

open Metric Set Asymptotics Filter Real

open Classical Topology NNReal

/-! ### Technical lemmas about `gronwall_bound` -/

/-- Upper bound used in several Grönwall-like inequalities. -/
noncomputable def gronwallBound (δ K ε x : ℝ) : ℝ :=
  if K = 0 then δ + ε * x else δ * exp (K * x) + ε / K * (exp (K * x) - 1)
#align gronwall_bound gronwallBound

theorem gronwallBound_K0 (δ ε : ℝ) : gronwallBound δ 0 ε = fun x => δ + ε * x :=
  funext fun x => if_pos rfl
#align gronwall_bound_K0 gronwallBound_K0

theorem gronwallBound_of_K_ne_0 {δ K ε : ℝ} (hK : K ≠ 0) :
    gronwallBound δ K ε = fun x => δ * exp (K * x) + ε / K * (exp (K * x) - 1) :=
  funext fun x => if_neg hK
#align gronwall_bound_of_K_ne_0 gronwallBound_of_K_ne_0

theorem hasDerivAt_gronwallBound (δ K ε x : ℝ) :
    HasDerivAt (gronwallBound δ K ε) (K * gronwallBound δ K ε x + ε) x :=
  by
  by_cases hK : K = 0
  · subst K
    simp only [gronwallBound_K0, MulZeroClass.zero_mul, zero_add]
    convert((hasDerivAt_id x).const_mul ε).const_add δ
    rw [mul_one]
  · simp only [gronwallBound_of_K_ne_0 hK]
    convert(((hasDerivAt_id x).const_mul K).exp.const_mul δ).add
        ((((hasDerivAt_id x).const_mul K).exp.sub_const 1).const_mul (ε / K)) using
      1
    simp only [id, mul_add, (mul_assoc _ _ _).symm, mul_comm _ K, mul_div_cancel' _ hK]
    ring
#align has_deriv_at_gronwall_bound hasDerivAt_gronwallBound

theorem hasDerivAt_gronwallBound_shift (δ K ε x a : ℝ) :
    HasDerivAt (fun y => gronwallBound δ K ε (y - a)) (K * gronwallBound δ K ε (x - a) + ε) x :=
  by
  convert(hasDerivAt_gronwallBound δ K ε _).comp x ((hasDerivAt_id x).sub_const a)
  rw [id, mul_one]
#align has_deriv_at_gronwall_bound_shift hasDerivAt_gronwallBound_shift

theorem gronwallBound_x0 (δ K ε : ℝ) : gronwallBound δ K ε 0 = δ :=
  by
  by_cases hK : K = 0
  · simp only [gronwallBound, if_pos hK, MulZeroClass.mul_zero, add_zero]
  ·
    simp only [gronwallBound, if_neg hK, MulZeroClass.mul_zero, exp_zero, sub_self, mul_one,
      add_zero]
#align gronwall_bound_x0 gronwallBound_x0

theorem gronwallBound_ε0 (δ K x : ℝ) : gronwallBound δ K 0 x = δ * exp (K * x) :=
  by
  by_cases hK : K = 0
  · simp only [gronwallBound_K0, hK, MulZeroClass.zero_mul, exp_zero, add_zero, mul_one]
  · simp only [gronwallBound_of_K_ne_0 hK, zero_div, MulZeroClass.zero_mul, add_zero]
#align gronwall_bound_ε0 gronwallBound_ε0

theorem gronwallBound_ε0_δ0 (K x : ℝ) : gronwallBound 0 K 0 x = 0 := by
  simp only [gronwallBound_ε0, MulZeroClass.zero_mul]
#align gronwall_bound_ε0_δ0 gronwallBound_ε0_δ0

theorem gronwallBound_continuous_ε (δ K x : ℝ) : Continuous fun ε => gronwallBound δ K ε x :=
  by
  by_cases hK : K = 0
  · simp only [gronwallBound_K0, hK]
    exact continuous_const.add (continuous_id.mul continuous_const)
  · simp only [gronwallBound_of_K_ne_0 hK]
    exact continuous_const.add ((continuous_id.mul continuous_const).mul continuous_const)
#align gronwall_bound_continuous_ε gronwallBound_continuous_ε

/-! ### Inequality and corollaries -/

/-- A Grönwall-like inequality: if `f : ℝ → ℝ` is continuous on `[a, b]` and satisfies
the inequalities `f a ≤ δ` and
`∀ x ∈ [a, b), liminf_{z→x+0} (f z - f x)/(z - x) ≤ K * (f x) + ε`, then `f x`
is bounded by `gronwall_bound δ K ε (x - a)` on `[a, b]`.

See also `norm_le_gronwall_bound_of_norm_deriv_right_le` for a version bounding `‖f x‖`,
`f : ℝ → E`. -/
theorem le_gronwallBound_of_liminf_deriv_right_le {f f' : ℝ → ℝ} {δ K ε : ℝ} {a b : ℝ}
    (hf : ContinuousOn f (Icc a b))
    (hf' : ∀ x ∈ Ico a b, ∀ r, f' x < r → ∃ᶠ z in 𝓝[>] x, (z - x)⁻¹ * (f z - f x) < r)
    (ha : f a ≤ δ) (bound : ∀ x ∈ Ico a b, f' x ≤ K * f x + ε) :
    ∀ x ∈ Icc a b, f x ≤ gronwallBound δ K ε (x - a) :=
  by
  have H : ∀ x ∈ Icc a b, ∀ ε' ∈ Ioi ε, f x ≤ gronwallBound δ K ε' (x - a) :=
    by
    intro x hx ε' hε'
    apply image_le_of_liminf_slope_right_lt_deriv_boundary hf hf'
    · rwa [sub_self, gronwallBound_x0]
    · exact fun x => hasDerivAt_gronwallBound_shift δ K ε' x a
    · intro x hx hfB
      rw [← hfB]
      apply lt_of_le_of_lt (bound x hx)
      exact add_lt_add_left hε' _
    · exact hx
  intro x hx
  change f x ≤ (fun ε' => gronwallBound δ K ε' (x - a)) ε
  convert continuous_within_at_const.closure_le _ _ (H x hx)
  · simp only [closure_Ioi, left_mem_Ici]
  exact (gronwallBound_continuous_ε δ K (x - a)).ContinuousWithinAt
#align le_gronwall_bound_of_liminf_deriv_right_le le_gronwallBound_of_liminf_deriv_right_le

/-- A Grönwall-like inequality: if `f : ℝ → E` is continuous on `[a, b]`, has right derivative
`f' x` at every point `x ∈ [a, b)`, and satisfies the inequalities `‖f a‖ ≤ δ`,
`∀ x ∈ [a, b), ‖f' x‖ ≤ K * ‖f x‖ + ε`, then `‖f x‖` is bounded by `gronwall_bound δ K ε (x - a)`
on `[a, b]`. -/
theorem norm_le_gronwallBound_of_norm_deriv_right_le {f f' : ℝ → E} {δ K ε : ℝ} {a b : ℝ}
    (hf : ContinuousOn f (Icc a b)) (hf' : ∀ x ∈ Ico a b, HasDerivWithinAt f (f' x) (Ici x) x)
    (ha : ‖f a‖ ≤ δ) (bound : ∀ x ∈ Ico a b, ‖f' x‖ ≤ K * ‖f x‖ + ε) :
    ∀ x ∈ Icc a b, ‖f x‖ ≤ gronwallBound δ K ε (x - a) :=
  le_gronwallBound_of_liminf_deriv_right_le (continuous_norm.comp_continuousOn hf)
    (fun x hx r hr => (hf' x hx).liminf_right_slope_norm_le hr) ha bound
#align norm_le_gronwall_bound_of_norm_deriv_right_le norm_le_gronwallBound_of_norm_deriv_right_le

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x y «expr ∈ » s t) -/
/-- If `f` and `g` are two approximate solutions of the same ODE, then the distance between them
can't grow faster than exponentially. This is a simple corollary of Grönwall's inequality, and some
people call this Grönwall's inequality too.

This version assumes all inequalities to be true in some time-dependent set `s t`,
and assumes that the solutions never leave this set. -/
theorem dist_le_of_approx_trajectories_ODE_of_mem_set {v : ℝ → E → E} {s : ℝ → Set E} {K : ℝ}
    (hv : ∀ t, ∀ (x) (_ : x ∈ s t) (y) (_ : y ∈ s t), dist (v t x) (v t y) ≤ K * dist x y)
    {f g f' g' : ℝ → E} {a b : ℝ} {εf εg δ : ℝ} (hf : ContinuousOn f (Icc a b))
    (hf' : ∀ t ∈ Ico a b, HasDerivWithinAt f (f' t) (Ici t) t)
    (f_bound : ∀ t ∈ Ico a b, dist (f' t) (v t (f t)) ≤ εf) (hfs : ∀ t ∈ Ico a b, f t ∈ s t)
    (hg : ContinuousOn g (Icc a b)) (hg' : ∀ t ∈ Ico a b, HasDerivWithinAt g (g' t) (Ici t) t)
    (g_bound : ∀ t ∈ Ico a b, dist (g' t) (v t (g t)) ≤ εg) (hgs : ∀ t ∈ Ico a b, g t ∈ s t)
    (ha : dist (f a) (g a) ≤ δ) :
    ∀ t ∈ Icc a b, dist (f t) (g t) ≤ gronwallBound δ K (εf + εg) (t - a) :=
  by
  simp only [dist_eq_norm] at ha⊢
  have h_deriv : ∀ t ∈ Ico a b, HasDerivWithinAt (fun t => f t - g t) (f' t - g' t) (Ici t) t :=
    fun t ht => (hf' t ht).sub (hg' t ht)
  apply norm_le_gronwallBound_of_norm_deriv_right_le (hf.sub hg) h_deriv ha
  intro t ht
  have := dist_triangle4_right (f' t) (g' t) (v t (f t)) (v t (g t))
  rw [dist_eq_norm] at this
  refine'
    this.trans
      ((add_le_add (add_le_add (f_bound t ht) (g_bound t ht))
            (hv t (f t) (hfs t ht) (g t) (hgs t ht))).trans
        _)
  rw [dist_eq_norm, add_comm]
#align dist_le_of_approx_trajectories_ODE_of_mem_set dist_le_of_approx_trajectories_ODE_of_mem_set

/-- If `f` and `g` are two approximate solutions of the same ODE, then the distance between them
can't grow faster than exponentially. This is a simple corollary of Grönwall's inequality, and some
people call this Grönwall's inequality too.

This version assumes all inequalities to be true in the whole space. -/
theorem dist_le_of_approx_trajectories_ODE {v : ℝ → E → E} {K : ℝ≥0}
    (hv : ∀ t, LipschitzWith K (v t)) {f g f' g' : ℝ → E} {a b : ℝ} {εf εg δ : ℝ}
    (hf : ContinuousOn f (Icc a b)) (hf' : ∀ t ∈ Ico a b, HasDerivWithinAt f (f' t) (Ici t) t)
    (f_bound : ∀ t ∈ Ico a b, dist (f' t) (v t (f t)) ≤ εf) (hg : ContinuousOn g (Icc a b))
    (hg' : ∀ t ∈ Ico a b, HasDerivWithinAt g (g' t) (Ici t) t)
    (g_bound : ∀ t ∈ Ico a b, dist (g' t) (v t (g t)) ≤ εg) (ha : dist (f a) (g a) ≤ δ) :
    ∀ t ∈ Icc a b, dist (f t) (g t) ≤ gronwallBound δ K (εf + εg) (t - a) :=
  have hfs : ∀ t ∈ Ico a b, f t ∈ @univ E := fun t ht => trivial
  dist_le_of_approx_trajectories_ODE_of_mem_set (fun t x hx y hy => (hv t).dist_le_mul x y) hf hf'
    f_bound hfs hg hg' g_bound (fun t ht => trivial) ha
#align dist_le_of_approx_trajectories_ODE dist_le_of_approx_trajectories_ODE

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x y «expr ∈ » s t) -/
/-- If `f` and `g` are two exact solutions of the same ODE, then the distance between them
can't grow faster than exponentially. This is a simple corollary of Grönwall's inequality, and some
people call this Grönwall's inequality too.

This version assumes all inequalities to be true in some time-dependent set `s t`,
and assumes that the solutions never leave this set. -/
theorem dist_le_of_trajectories_ODE_of_mem_set {v : ℝ → E → E} {s : ℝ → Set E} {K : ℝ}
    (hv : ∀ t, ∀ (x) (_ : x ∈ s t) (y) (_ : y ∈ s t), dist (v t x) (v t y) ≤ K * dist x y)
    {f g : ℝ → E} {a b : ℝ} {δ : ℝ} (hf : ContinuousOn f (Icc a b))
    (hf' : ∀ t ∈ Ico a b, HasDerivWithinAt f (v t (f t)) (Ici t) t) (hfs : ∀ t ∈ Ico a b, f t ∈ s t)
    (hg : ContinuousOn g (Icc a b)) (hg' : ∀ t ∈ Ico a b, HasDerivWithinAt g (v t (g t)) (Ici t) t)
    (hgs : ∀ t ∈ Ico a b, g t ∈ s t) (ha : dist (f a) (g a) ≤ δ) :
    ∀ t ∈ Icc a b, dist (f t) (g t) ≤ δ * exp (K * (t - a)) :=
  by
  have f_bound : ∀ t ∈ Ico a b, dist (v t (f t)) (v t (f t)) ≤ 0 :=
    by
    intros
    rw [dist_self]
  have g_bound : ∀ t ∈ Ico a b, dist (v t (g t)) (v t (g t)) ≤ 0 :=
    by
    intros
    rw [dist_self]
  intro t ht
  have :=
    dist_le_of_approx_trajectories_ODE_of_mem_set hv hf hf' f_bound hfs hg hg' g_bound hgs ha t ht
  rwa [zero_add, gronwallBound_ε0] at this
#align dist_le_of_trajectories_ODE_of_mem_set dist_le_of_trajectories_ODE_of_mem_set

/-- If `f` and `g` are two exact solutions of the same ODE, then the distance between them
can't grow faster than exponentially. This is a simple corollary of Grönwall's inequality, and some
people call this Grönwall's inequality too.

This version assumes all inequalities to be true in the whole space. -/
theorem dist_le_of_trajectories_ODE {v : ℝ → E → E} {K : ℝ≥0} (hv : ∀ t, LipschitzWith K (v t))
    {f g : ℝ → E} {a b : ℝ} {δ : ℝ} (hf : ContinuousOn f (Icc a b))
    (hf' : ∀ t ∈ Ico a b, HasDerivWithinAt f (v t (f t)) (Ici t) t) (hg : ContinuousOn g (Icc a b))
    (hg' : ∀ t ∈ Ico a b, HasDerivWithinAt g (v t (g t)) (Ici t) t) (ha : dist (f a) (g a) ≤ δ) :
    ∀ t ∈ Icc a b, dist (f t) (g t) ≤ δ * exp (K * (t - a)) :=
  have hfs : ∀ t ∈ Ico a b, f t ∈ @univ E := fun t ht => trivial
  dist_le_of_trajectories_ODE_of_mem_set (fun t x hx y hy => (hv t).dist_le_mul x y) hf hf' hfs hg
    hg' (fun t ht => trivial) ha
#align dist_le_of_trajectories_ODE dist_le_of_trajectories_ODE

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (x y «expr ∈ » s t) -/
/-- There exists only one solution of an ODE \(\dot x=v(t, x)\) in a set `s ⊆ ℝ × E` with
a given initial value provided that RHS is Lipschitz continuous in `x` within `s`,
and we consider only solutions included in `s`. -/
theorem ODE_solution_unique_of_mem_set {v : ℝ → E → E} {s : ℝ → Set E} {K : ℝ}
    (hv : ∀ t, ∀ (x) (_ : x ∈ s t) (y) (_ : y ∈ s t), dist (v t x) (v t y) ≤ K * dist x y)
    {f g : ℝ → E} {a b : ℝ} (hf : ContinuousOn f (Icc a b))
    (hf' : ∀ t ∈ Ico a b, HasDerivWithinAt f (v t (f t)) (Ici t) t) (hfs : ∀ t ∈ Ico a b, f t ∈ s t)
    (hg : ContinuousOn g (Icc a b)) (hg' : ∀ t ∈ Ico a b, HasDerivWithinAt g (v t (g t)) (Ici t) t)
    (hgs : ∀ t ∈ Ico a b, g t ∈ s t) (ha : f a = g a) : ∀ t ∈ Icc a b, f t = g t :=
  by
  intro t ht
  have := dist_le_of_trajectories_ODE_of_mem_set hv hf hf' hfs hg hg' hgs (dist_le_zero.2 ha) t ht
  rwa [MulZeroClass.zero_mul, dist_le_zero] at this
#align ODE_solution_unique_of_mem_set ODE_solution_unique_of_mem_set

/-- There exists only one solution of an ODE \(\dot x=v(t, x)\) with
a given initial value provided that RHS is Lipschitz continuous in `x`. -/
theorem ODE_solution_unique {v : ℝ → E → E} {K : ℝ≥0} (hv : ∀ t, LipschitzWith K (v t))
    {f g : ℝ → E} {a b : ℝ} (hf : ContinuousOn f (Icc a b))
    (hf' : ∀ t ∈ Ico a b, HasDerivWithinAt f (v t (f t)) (Ici t) t) (hg : ContinuousOn g (Icc a b))
    (hg' : ∀ t ∈ Ico a b, HasDerivWithinAt g (v t (g t)) (Ici t) t) (ha : f a = g a) :
    ∀ t ∈ Icc a b, f t = g t :=
  have hfs : ∀ t ∈ Ico a b, f t ∈ @univ E := fun t ht => trivial
  ODE_solution_unique_of_mem_set (fun t x hx y hy => (hv t).dist_le_mul x y) hf hf' hfs hg hg'
    (fun t ht => trivial) ha
#align ODE_solution_unique ODE_solution_unique


/-
Copyright (c) 2022 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard
-/

import tactic -- imports all the Lean tactics

/-!

# Making ℤ from ℕ²

You can define `ℤ` as ℕ² / ≈, where (a,b) ≈ (c,d) ↔ a + d = b + c.
This sheet goes through this (definition, commutative ring structure) with very few hints.
All the techniques are things we've seen in the earlier sheets.

Hint: if the tactic state is

h : a + d = b + c
⊢ c + b = d + a

you can close the goal with `linarith`. If things get nonlinear (multiplication,
I'm looking at you), there's always `nlinarith`.

-/

/-

# Warm-up: how products work in Lean

-/

-- constructor for ℕ × ℕ

example : ℕ × ℕ := (3,4)

-- eliminators

def foo : ℕ × ℕ := (37, 53)

example : foo.1 = 37 :=
begin
  refl
end

example : foo.2 = 53 :=
begin
  refl
end

-- warning : constructor on eliminators isn't refl
example (a : ℕ × ℕ) : a = (a.1, a.2) :=
begin
  -- refl fails
  cases a with x y, -- a term of type ℕ × ℕ is a pair; `cases` takes it apart.
  -- now refl works
  refl,
end

def R (ab cd : ℕ × ℕ) : Prop :=
ab.1 + cd.2 = ab.2 + cd.1

lemma R_def (ab cd : ℕ × ℕ) :
R ab cd ↔ ab.1 + cd.2 = ab.2 + cd.1 :=
begin
  refl,
end

lemma R_def' (a b c d : ℕ) :
R (a, b) (c, d) ↔ a + d = b + c :=
begin
  refl,
end

lemma R_refl : reflexive R :=
begin
  rintro ⟨a, b⟩,
  exact add_comm a b,
end

lemma R_symm : symmetric R :=
begin
  rintro ⟨a, b⟩ ⟨c, d⟩ h,
  rw R_def' at *,
  linarith,
end

lemma R_trans : transitive R :=
begin
  rintro ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩ h1 h2,
  rw R_def' at *,
  linarith,
end

instance s : setoid (ℕ × ℕ) :=
{ r := R,
  iseqv := ⟨R_refl, R_symm, R_trans⟩ }

@[simp] lemma equiv_def (a b c d : ℕ) :
  (a, b) ≈ (c, d) ↔ a + d = b + c :=
begin
  refl,
end

notation `myint` := quotient s

-- Amusingly, we can't now make a myint namespace unless
-- we do some weird quote thing (Lean unfolds the notation otherwise)
namespace «myint»

instance : has_zero myint :=
{ zero := ⟦(0,0)⟧ }

@[simp] lemma zero_def : (0 : myint) = ⟦(0, 0)⟧ :=
begin
  refl,
end

-- remember (a,b) is supposed to represent the integer a - b
-- so b - a is represented by (b,a)
def neg : myint → myint :=
quotient.map (λ ab, (ab.2, ab.1)) begin
  rintro ⟨a, b⟩ ⟨c, d⟩ h,
  dsimp,
  rw equiv_def at *,
  linarith,
end

instance : has_neg myint :=
{ neg := neg }

@[simp] lemma neg_def (a b : ℕ) :
  -⟦(a, b)⟧ = ⟦(b, a)⟧ :=
begin
  refl,
end

def add : myint → myint → myint :=
quotient.map₂ (λ ab cd, (ab.1 + cd.1, ab.2 + cd.2)) begin
  rintro ⟨a, b⟩ ⟨c, d⟩ h1 ⟨e, f⟩ ⟨g, h⟩ h2,
  dsimp,
  rw equiv_def at *,
  linarith,
end

instance : has_add myint :=
{ add := add }

@[simp] lemma add_def (a b c d : ℕ) :
  ⟦(a, b)⟧ + ⟦(c, d)⟧ = ⟦(a + c, b + d)⟧ :=
begin
  refl,
end

instance add_comm_group : add_comm_group myint :=
{ add := (+),
  add_assoc := begin
    intros x y z,
    apply quotient.induction_on₃ x y z, clear x y z,
    rintro ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩,
    simp,
    ring,
  end,
  zero := 0,
  zero_add := begin
    intro x,
    apply quotient.induction_on x, clear x,
    rintro ⟨a, b⟩,
    simp [add_comm],
  end,
  add_zero := begin
    intro x,
    apply quotient.induction_on x, clear x,
    rintro ⟨a, b⟩,
    simp [add_comm],
  end,
  neg := has_neg.neg,
  add_left_neg := begin
    intro x,
    apply quotient.induction_on x, clear x,
    rintro ⟨a, b⟩,
    simp [add_comm],
  end,
  add_comm := begin
    intros x y,
    apply quotient.induction_on₂ x y, clear x y,
    rintro ⟨a, b⟩ ⟨c, d⟩,
    simp [add_comm],
  end }

-- our model is that the equivalence class ⟦(a, b)⟧
-- represents the integer a - b
instance : has_one myint :=
{ one := ⟦(1, 0)⟧}

@[simp] lemma one_def : (1 : myint) = ⟦(1, 0)⟧ :=
begin
  refl,
end

-- (a-b)*(c-d)=(ac+bd)-(ad+bc)
def mul : myint → myint → myint :=
quotient.map₂ (λ ab cd, (ab.1 * cd.1 + ab.2 * cd.2, ab.1 * cd.2 + ab.2 * cd.1)) begin
  rintro ⟨a, b⟩ ⟨c, d⟩ h1 ⟨e, f⟩ ⟨g, h⟩ h2,
  dsimp,
  rw equiv_def at *,
  nlinarith,
end

instance : has_mul myint :=
{ mul := mul }

@[simp] lemma mul_def (a b c d : ℕ) :
  ⟦(a, b)⟧ * ⟦(c, d)⟧ = ⟦(a * c + b * d, a * d + b * c)⟧ :=
begin
  refl,
end

instance : comm_ring myint :=
{ add := (+),
  zero := 0,
  mul := (*),
  mul_assoc := begin
    intros x y z,
    apply quotient.induction_on₃ x y z, clear x y z,
    rintro ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩,
    simp,
    ring,
  end,
  one := 1,
  one_mul := begin
    intro x,
    apply quotient.induction_on x, clear x,
    rintro ⟨a, b⟩,
    simp [add_comm],
  end,
  mul_one := begin
    intro x,
    apply quotient.induction_on x, clear x,
    rintro ⟨a, b⟩,
    simp [add_comm],
  end,
  left_distrib := begin
    intros x y z,
    apply quotient.induction_on₃ x y z, clear x y z,
    rintro ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩,
    simp,
    ring,
  end,
  right_distrib := begin
    intros x y z,
    apply quotient.induction_on₃ x y z, clear x y z,
    rintro ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩,
    simp,
    ring,
  end,
  mul_comm := begin
    intros x y,
    apply quotient.induction_on₂ x y, clear x y,
    rintro ⟨a, b⟩ ⟨c, d⟩,
    simp,
    ring,
  end,
  ..myint.add_comm_group }

def coe (a : ℕ) : myint := ⟦(a, 0)⟧

lemma coe_zero : coe 0 = 0 := rfl

lemma coe_add (a b : ℕ) : coe (a + b) = coe a + coe b :=
begin
  refl,
end

lemma coe_one : coe 1 = 1 := rfl

lemma coe_mul (a b : ℕ) : coe (a * b) = coe a * coe b :=
begin
  simp [coe],
end

end «myint»


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import order.lattice
import data.list.sort
import data.equiv.fin
import data.equiv.functor
/-!
# Jordan-Hölder Theorem

This file proves the Jordan Hölder theorem for a `jordan_holder_lattice`, a class also defined in
this file. Examples of `jordan_holder_lattice` include `subgroup G` if `G` is a group, and
`submodule R M` if `M` is an `R`-module. Using this approach the theorem need not be proved
seperately for both groups and modules, the proof in this file can be applied to both.

## Main definitions
The main definitions in this file are `jordan_holder_lattice` and `composition_series`,
and the relation `equivalent` on `composition_series`

A `jordan_holder_lattice` is the class for which the Jordan Hölder theorem is proved. A
Jordan Hölder lattice is a lattice equipped with a notion of maximality, `is_maximal`, and a notion
of isomorphism of pairs `iso`. In the example of subgroups of a group, `is_maximal H K` means that
`H` is a maximal normal subgroup of `K`, and `iso (H₁, K₁) (H₂, K₂)` means that the quotient
`H₁ / K₁` is isomorphic to the quotient `H₂ / K₂`. `iso` must be symmetric and transitive and must
satisfy the second isomorphism theorem `iso (H, H ⊔ K) (H ⊓ K, K)`.

A `composition_series X` is a finite nonempty series of elements of the lattice `X` such that
each element is maximal inside the next. The length of a `composition_series X` is
one less than the number of elements in the series. Note that there is no stipulation
that a series start from the bottom of the lattice and finish at the top.
For a composition series `s`, `s.top` is the largest element of the series,
and `s.bot` is the least element.

Two `composition_series X`, `s₁` and `s₂` are equivalent if there is a bijection
`e : fin s₁.length ≃ fin s₂.length` such that for any `i`,
`iso (s₁ i, s₁ i.succ) (s₂ (e i), s₂ (e i.succ))`

## Main theorems

The main theorem is `composition_series.jordan_holder`, which says that if two composition
series have the same least element and the same largest element,
then they are `equivalent`.

## TODO

Provide instances of `jordan_holder_lattice` for both submodules and subgroups, and potentially
for modular lattices.

It is not entirely clear how this should be done. Possibly there should be no global instances
of `jordan_holder_lattice`, and the instances should only be defined locally in order to prove
the Jordan-Hölder theorem for modules/groups and the API should be transferred because many of the
theorems in this file will have stronger versions for modules. There will also need to be an API for
mapping composition series across homomorphisms. It is also probably possible to
provide an instance of `jordan_holder_lattice` for any `modular_lattice`, and in this case the
Jordan-Hölder theorem will say that there is a well defined notion of length of a modular lattice.
However an instance of `jordan_holder_lattice` for a modular lattice will not be able to contain
the correct notion of isomorphism for modules, so a separate instance for modules will still be
required and this will clash with the instance for modular lattices, and so at least one of these
instances should not be a global instance.
-/

universe u

open set

/--
A `jordan_holder_lattice` is the class for which the Jordan Hölder theorem is proved. A
Jordan Hölder lattice is a lattice equipped with a notion of maximality, `is_maximal`, and a notion
of isomorphism of pairs `iso`. In the example of subgroups of a group, `is_maximal H K` means that
`H` is a maximal normal subgroup of `K`, and `iso (H₁, K₁) (H₂, K₂)` means that the quotient
`H₁ / K₁` is isomorphic to the quotient `H₂ / K₂`. `iso` must be symmetric and transitive and must
satisfy the second isomorphism theorem `iso (H, H ⊔ K) (H ⊓ K, K)`.
Examples include `subgroup G` if `G` is a group, and `submodule R M` if `M` is an `R`-module.
-/
class jordan_holder_lattice (X : Type u) [lattice X] :=
(is_maximal : X → X → Prop)
(lt_of_is_maximal : ∀ {x y}, is_maximal x y → x < y)
(sup_eq_of_is_maximal : ∀ {x y z}, is_maximal x z → is_maximal y z →
  x ≠ y → x ⊔ y = z)
(is_maximal_inf_left_of_is_maximal_sup : ∀ {x y}, is_maximal x (x ⊔ y) → is_maximal y (x ⊔ y) →
  is_maximal (x ⊓ y) x)
(iso : (X × X) → (X × X) → Prop)
(iso_symm : ∀ {x y}, iso x y → iso y x)
(iso_trans : ∀ {x y z}, iso x y → iso y z → iso x z)
(second_iso : ∀ {x y}, is_maximal x (x ⊔ y) → iso (x, x ⊔ y) (x ⊓ y, y))

namespace jordan_holder_lattice

variables {X : Type u} [lattice X] [jordan_holder_lattice X]

lemma is_maximal_inf_right_of_is_maximal_sup {x y : X}
  (hxz : is_maximal x (x ⊔ y)) (hyz : is_maximal y (x ⊔ y)) :
  is_maximal (x ⊓ y) y :=
begin
  rw [inf_comm],
  rw [sup_comm] at hxz hyz,
  exact is_maximal_inf_left_of_is_maximal_sup hyz hxz
end

lemma second_iso_of_eq {x y a b : X} (hm : is_maximal x a) (ha : x ⊔ y = a) (hb : x ⊓ y = b) :
  iso (x, a) (b, y) :=
by substs a b; exact second_iso hm

lemma is_maximal.iso_refl {x y : X} (h : is_maximal x y) : iso (x, y) (x, y) :=
second_iso_of_eq h
  (sup_eq_right.2 (le_of_lt (lt_of_is_maximal h)))
  (inf_eq_left.2 (le_of_lt (lt_of_is_maximal h)))

end jordan_holder_lattice

open jordan_holder_lattice

attribute [symm] iso_symm
attribute [trans] iso_trans

/--
A `composition_series X` is a finite nonempty series of elements of a
`jordan_holder_lattice` such that each element is maximal inside the next. The length of a
`composition_series X` is one less than the number of elements in the series.
Note that there is no stipulation that a series start from the bottom of the lattice and finish at
the top. For a composition series `s`, `s.top` is the largest element of the series,
and `s.bot` is the least element.
-/
structure composition_series (X : Type u) [lattice X] [jordan_holder_lattice X] : Type u :=
(length : ℕ)
(series : fin (length + 1) → X)
(step' : ∀ i : fin length, is_maximal (series i.cast_succ) (series i.succ))

namespace composition_series

variables {X : Type u} [lattice X] [jordan_holder_lattice X]

instance : has_coe_to_fun (composition_series X) (λ x, fin (x.length + 1) → X) :=
{ coe := composition_series.series }

instance [inhabited X] : inhabited (composition_series X) :=
⟨{ length := 0,
   series := λ _, default X,
   step' := λ x, x.elim0 }⟩

variables {X}

lemma step (s : composition_series X) : ∀ i : fin s.length,
  is_maximal (s i.cast_succ) (s i.succ) := s.step'

@[simp] lemma coe_fn_mk (length : ℕ) (series step) :
  (@composition_series.mk X _ _ length series step : fin length.succ → X) = series := rfl

theorem lt_succ (s : composition_series X) (i : fin s.length) :
  s i.cast_succ < s i.succ :=
lt_of_is_maximal (s.step _)

protected theorem strict_mono (s : composition_series X) : strict_mono s :=
fin.strict_mono_iff_lt_succ.2 (λ i h, s.lt_succ ⟨i, nat.lt_of_succ_lt_succ h⟩)

protected theorem injective (s : composition_series X) : function.injective s :=
s.strict_mono.injective

@[simp] protected theorem inj (s : composition_series X) {i j : fin s.length.succ} :
  s i = s j ↔ i = j :=
s.injective.eq_iff

instance : has_mem X (composition_series X) :=
⟨λ x s, x ∈ set.range s⟩

lemma mem_def {x : X} {s : composition_series X} : x ∈ s ↔ x ∈ set.range s := iff.rfl

lemma total {s : composition_series X} {x y : X} (hx : x ∈ s) (hy : y ∈ s) : x ≤ y ∨ y ≤ x :=
begin
  rcases set.mem_range.1 hx with ⟨i, rfl⟩,
  rcases set.mem_range.1 hy with ⟨j, rfl⟩,
  rw [s.strict_mono.le_iff_le, s.strict_mono.le_iff_le],
  exact le_total i j
end

/-- The ordered `list X` of elements of a `composition_series X`. -/
def to_list (s : composition_series X) : list X := list.of_fn s

/-- Two `composition_series` are equal if they are the same length and
have the same `i`th element for every `i` -/
lemma ext_fun {s₁ s₂ : composition_series X}
  (hl : s₁.length = s₂.length)
  (h : ∀ i, s₁ i = s₂ (fin.cast (congr_arg nat.succ hl) i)) :
  s₁ = s₂ :=
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst hl,
  simpa [function.funext_iff] using h
end

@[simp] lemma length_to_list (s : composition_series X) : s.to_list.length = s.length + 1 :=
by rw [to_list, list.length_of_fn]

lemma to_list_ne_nil (s : composition_series X) : s.to_list ≠ [] :=
by rw [← list.length_pos_iff_ne_nil, length_to_list]; exact nat.succ_pos _

lemma to_list_injective : function.injective (@composition_series.to_list X _ _) :=
λ s₁ s₂ (h : list.of_fn s₁ = list.of_fn s₂),
have h₁ : s₁.length = s₂.length,
  from nat.succ_injective
    ((list.length_of_fn s₁).symm.trans $
      (congr_arg list.length h).trans $
      list.length_of_fn s₂),
have h₂ : ∀ i : fin s₁.length.succ, (s₁ i) = s₂ (fin.cast (congr_arg nat.succ h₁) i),
  begin
    assume i,
    rw [← list.nth_le_of_fn s₁ i, ← list.nth_le_of_fn s₂],
    simp [h]
  end,
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst h₁,
  simp only [heq_iff_eq, eq_self_iff_true, true_and],
  simp only [fin.cast_refl] at h₂,
  exact funext h₂
end

lemma chain'_to_list (s : composition_series X) :
  list.chain' is_maximal s.to_list :=
list.chain'_iff_nth_le.2
  begin
    assume i hi,
    simp only [to_list, list.nth_le_of_fn'],
    rw [length_to_list] at hi,
    exact s.step ⟨i, hi⟩
  end

lemma to_list_sorted (s : composition_series X) : s.to_list.sorted (<) :=
list.pairwise_iff_nth_le.2 (λ i j hi hij,
  begin
    dsimp [to_list],
    rw [list.nth_le_of_fn', list.nth_le_of_fn'],
    exact s.strict_mono hij
  end)

lemma to_list_nodup (s : composition_series X) : s.to_list.nodup :=
list.nodup_iff_nth_le_inj.2
  (λ i j hi hj,
    begin
      delta to_list,
      rw [list.nth_le_of_fn', list.nth_le_of_fn', s.injective.eq_iff, fin.ext_iff,
        fin.coe_mk, fin.coe_mk],
      exact id
    end)

@[simp] lemma mem_to_list {s : composition_series X} {x : X} : x ∈ s.to_list ↔ x ∈ s :=
by rw [to_list, list.mem_of_fn, mem_def]

/-- Make a `composition_series X` from the ordered list of its elements. -/
def of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l) :
  composition_series X :=
{ length := l.length - 1,
  series := λ i, l.nth_le i begin
      conv_rhs { rw ← tsub_add_cancel_of_le (nat.succ_le_of_lt (list.length_pos_of_ne_nil hl)) },
      exact i.2
    end,
  step' := λ ⟨i, hi⟩, list.chain'_iff_nth_le.1 hc i hi }

lemma length_of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l) :
  (of_list l hl hc).length = l.length - 1 := rfl

lemma of_list_to_list (s : composition_series X) :
  of_list s.to_list s.to_list_ne_nil s.chain'_to_list = s :=
begin
  refine ext_fun _ _,
  { rw [length_of_list, length_to_list, nat.succ_sub_one] },
  { rintros ⟨i, hi⟩,
    dsimp [of_list, to_list],
    rw [list.nth_le_of_fn'] }
end

@[simp] lemma of_list_to_list' (s : composition_series X) :
  of_list s.to_list s.to_list_ne_nil s.chain'_to_list = s :=
of_list_to_list s

@[simp] lemma to_list_of_list (l : list X) (hl : l ≠ []) (hc : list.chain' is_maximal l)  :
  to_list (of_list l hl hc) = l :=
begin
  refine list.ext_le _ _,
  { rw [length_to_list, length_of_list,
      tsub_add_cancel_of_le (nat.succ_le_of_lt $ list.length_pos_of_ne_nil hl)] },
  { assume i hi hi',
    dsimp [of_list, to_list],
    rw [list.nth_le_of_fn'],
    refl }
end

/-- Two `composition_series` are equal if they have the same elements. See also `ext_fun`. -/
@[ext] lemma ext {s₁ s₂ : composition_series X} (h : ∀ x, x ∈ s₁ ↔ x ∈ s₂) : s₁ = s₂ :=
to_list_injective $ list.eq_of_perm_of_sorted
  (by classical; exact list.perm_of_nodup_nodup_to_finset_eq
    s₁.to_list_nodup
    s₂.to_list_nodup
    (finset.ext $ by simp *))
  s₁.to_list_sorted s₂.to_list_sorted

/-- The largest element of a `composition_series` -/
def top (s : composition_series X) : X := s (fin.last _)

lemma top_mem (s : composition_series X) : s.top ∈ s :=
mem_def.2 (set.mem_range.2 ⟨fin.last _, rfl⟩)

@[simp] lemma le_top {s : composition_series X} (i : fin (s.length + 1)) : s i ≤ s.top :=
s.strict_mono.monotone (fin.le_last _)

lemma le_top_of_mem {s : composition_series X} {x : X} (hx : x ∈ s) : x ≤ s.top :=
let ⟨i, hi⟩ := set.mem_range.2 hx in hi ▸ le_top _

/-- The smallest element of a `composition_series` -/
def bot (s : composition_series X) : X := s 0

lemma bot_mem (s : composition_series X) : s.bot ∈ s :=
mem_def.2 (set.mem_range.2 ⟨0, rfl⟩)

@[simp] lemma bot_le {s : composition_series X} (i : fin (s.length + 1)) : s.bot ≤ s i :=
s.strict_mono.monotone (fin.zero_le _)

lemma bot_le_of_mem {s : composition_series X} {x : X} (hx : x ∈ s) : s.bot ≤ x :=
let ⟨i, hi⟩ := set.mem_range.2 hx in hi ▸ bot_le _

lemma length_pos_of_mem_ne {s : composition_series X}
  {x y : X} (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y) :
  0 < s.length :=
let ⟨i, hi⟩ := hx, ⟨j, hj⟩ := hy in
have hij : i ≠ j, from mt s.inj.2 $ λ h, hxy (hi ▸ hj ▸ h),
hij.lt_or_lt.elim
  (λ hij, (lt_of_le_of_lt (zero_le i)
    (lt_of_lt_of_le hij (nat.le_of_lt_succ j.2))))
  (λ hji, (lt_of_le_of_lt (zero_le j)
    (lt_of_lt_of_le hji (nat.le_of_lt_succ i.2))))

lemma forall_mem_eq_of_length_eq_zero {s : composition_series X}
  (hs : s.length = 0) {x y} (hx : x ∈ s) (hy : y ∈ s) : x = y :=
by_contradiction (λ hxy, pos_iff_ne_zero.1 (length_pos_of_mem_ne hx hy hxy) hs)

/-- Remove the largest element from a `composition_series`. If the series `s`
has length zero, then `s.erase_top = s` -/
@[simps] def erase_top (s : composition_series X) : composition_series X :=
{ length := s.length - 1,
  series := λ i, s ⟨i, lt_of_lt_of_le i.2 (nat.succ_le_succ tsub_le_self)⟩,
  step' := λ i, begin
    have := s.step ⟨i, lt_of_lt_of_le i.2 tsub_le_self⟩,
    cases i,
    exact this
  end }

lemma top_erase_top (s : composition_series X) :
  s.erase_top.top = s ⟨s.length - 1, lt_of_le_of_lt tsub_le_self (nat.lt_succ_self _)⟩ :=
show s _ = s _, from congr_arg s
begin
  ext,
  simp only [erase_top_length, fin.coe_last, fin.coe_cast_succ, fin.coe_of_nat_eq_mod,
    fin.coe_mk, coe_coe]
end

lemma erase_top_top_le (s : composition_series X) : s.erase_top.top ≤ s.top :=
by simp [erase_top, top, s.strict_mono.le_iff_le, fin.le_iff_coe_le_coe, tsub_le_self]

@[simp] lemma bot_erase_top (s : composition_series X) : s.erase_top.bot = s.bot := rfl

lemma mem_erase_top_of_ne_of_mem {s : composition_series X} {x : X}
  (hx : x ≠ s.top) (hxs : x ∈ s) : x ∈ s.erase_top :=
begin
  { rcases hxs with ⟨i, rfl⟩,
    have hi : (i : ℕ) < (s.length - 1).succ,
    { conv_rhs { rw [← nat.succ_sub (length_pos_of_mem_ne ⟨i, rfl⟩ s.top_mem hx),
        nat.succ_sub_one] },
      exact lt_of_le_of_ne
        (nat.le_of_lt_succ i.2)
        (by simpa [top, s.inj, fin.ext_iff] using hx) },
    refine ⟨i.cast_succ, _⟩,
    simp [fin.ext_iff, nat.mod_eq_of_lt hi] }
end

lemma mem_erase_top {s : composition_series X} {x : X}
  (h : 0 < s.length) : x ∈ s.erase_top ↔ x ≠ s.top ∧ x ∈ s :=
begin
  simp only [mem_def],
  dsimp only [erase_top, coe_fn_mk],
  split,
  { rintros ⟨i, rfl⟩,
    have hi : (i : ℕ) < s.length,
    { conv_rhs { rw [← nat.succ_sub_one s.length, nat.succ_sub h] },
      exact i.2 },
    simp [top, fin.ext_iff, (ne_of_lt hi)] },
  { intro h,
    exact mem_erase_top_of_ne_of_mem h.1 h.2 }
end

lemma lt_top_of_mem_erase_top {s : composition_series X} {x : X} (h : 0 < s.length)
  (hx : x ∈ s.erase_top) : x < s.top :=
lt_of_le_of_ne
  (le_top_of_mem ((mem_erase_top h).1 hx).2)
  ((mem_erase_top h).1 hx).1

lemma is_maximal_erase_top_top {s : composition_series X} (h : 0 < s.length) :
  is_maximal s.erase_top.top s.top :=
have s.length - 1 + 1 = s.length,
  by conv_rhs { rw [← nat.succ_sub_one s.length] }; rw nat.succ_sub h,
begin
  rw [top_erase_top, top],
  convert s.step ⟨s.length - 1, nat.sub_lt h zero_lt_one⟩;
  ext; simp [this]
end

lemma append_cast_add_aux
  {s₁ s₂ : composition_series X}
  (i : fin s₁.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
by { cases i, simp [fin.append, *] }

lemma append_succ_cast_add_aux
  {s₁ s₂ : composition_series X}
  (i : fin s₁.length)
  (h : s₁ (fin.last _) = s₂ 0) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add s₂.length i).succ = s₁ i.succ :=
begin
  cases i with i hi,
  simp only [fin.append, hi, fin.succ_mk, function.comp_app, fin.cast_succ_mk,
    fin.coe_mk, fin.cast_add_mk],
  split_ifs,
  { refl },
  { have : i + 1 = s₁.length, from le_antisymm hi (le_of_not_gt h_1),
    calc s₂ ⟨i + 1 - s₁.length, by simp [this]⟩
        = s₂ 0 : congr_arg s₂ (by simp [fin.ext_iff, this])
    ... = s₁ (fin.last _) : h.symm
    ... = _ : congr_arg s₁ (by simp [fin.ext_iff, this]) }
end

lemma append_nat_add_aux
  {s₁ s₂ : composition_series X}
  (i : fin s₂.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.nat_add s₁.length i).cast_succ = s₂ i.cast_succ :=
begin
  cases i,
  simp only [fin.append, nat.not_lt_zero, fin.nat_add_mk, add_lt_iff_neg_left,
    add_tsub_cancel_left, dif_neg, fin.cast_succ_mk, not_false_iff, fin.coe_mk]
end

lemma append_succ_nat_add_aux
  {s₁ s₂ : composition_series X}
  (i : fin s₂.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.nat_add s₁.length i).succ = s₂ i.succ :=
begin
  cases i with i hi,
  simp only [fin.append, add_assoc, nat.not_lt_zero, fin.nat_add_mk, add_lt_iff_neg_left,
    add_tsub_cancel_left, fin.succ_mk, dif_neg, not_false_iff, fin.coe_mk]
end

/-- Append two composition series `s₁` and `s₂` such that
the least element of `s₁` is the maximum element of `s₂`. -/
@[simps length] def append (s₁ s₂ : composition_series X)
  (h : s₁.top = s₂.bot) : composition_series X :=
{ length := s₁.length + s₂.length,
  series := fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂,
  step' := λ i, begin
    refine fin.add_cases  _ _ i,
    { intro i,
      rw [append_succ_cast_add_aux _ h, append_cast_add_aux],
      exact s₁.step i },
    { intro i,
      rw [append_nat_add_aux, append_succ_nat_add_aux],
      exact s₂.step i }
  end }

@[simp] lemma append_cast_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₁.length) :
  append s₁ s₂ h (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
append_cast_add_aux i

@[simp] lemma append_succ_cast_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₁.length) :
  append s₁ s₂ h (fin.cast_add s₂.length i).succ = s₁ i.succ :=
append_succ_cast_add_aux i h

@[simp] lemma append_nat_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₂.length) :
  append s₁ s₂ h (fin.nat_add s₁.length i).cast_succ = s₂ i.cast_succ :=
append_nat_add_aux i

@[simp] lemma append_succ_nat_add {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) (i : fin s₂.length) :
  append s₁ s₂ h (fin.nat_add s₁.length i).succ = s₂ i.succ :=
append_succ_nat_add_aux i

/-- Add an element to the top of a `composition_series` -/
@[simps length] def snoc (s : composition_series X) (x : X)
  (hsat : is_maximal s.top x) : composition_series X :=
{ length := s.length + 1,
  series := fin.snoc s x,
  step' := λ i, begin
    refine fin.last_cases _ _ i,
    { rwa [fin.snoc_cast_succ, fin.succ_last, fin.snoc_last, ← top] },
    { intro i,
      rw [fin.snoc_cast_succ, ← fin.cast_succ_fin_succ, fin.snoc_cast_succ],
      exact s.step _ }
  end }

@[simp] lemma top_snoc (s : composition_series X) (x : X)
  (hsat : is_maximal s.top x) : (snoc s x hsat).top = x :=
fin.snoc_last _ _

@[simp] lemma snoc_last (s : composition_series X) (x : X) (hsat : is_maximal s.top x) :
  snoc s x hsat (fin.last (s.length + 1)) = x :=
fin.snoc_last _ _

@[simp] lemma snoc_cast_succ (s : composition_series X) (x : X) (hsat : is_maximal s.top x)
  (i : fin (s.length + 1)) : snoc s x hsat (i.cast_succ) = s i :=
fin.snoc_cast_succ _ _ _

@[simp] lemma bot_snoc (s : composition_series X) (x : X) (hsat : is_maximal s.top x) :
  (snoc s x hsat).bot = s.bot :=
by rw [bot, bot, ← fin.cast_succ_zero, snoc_cast_succ]

lemma mem_snoc {s : composition_series X} {x y: X}
  {hsat : is_maximal s.top x} : y ∈ snoc s x hsat ↔ y ∈ s ∨ y = x :=
begin
  simp only [snoc, mem_def],
  split,
  { rintros ⟨i, rfl⟩,
    refine fin.last_cases _ (λ i, _) i,
    { right, simp },
    { left, simp } },
  { intro h,
    rcases h with ⟨i, rfl⟩ | rfl,
    { use i.cast_succ, simp },
    { use (fin.last _), simp } }
end

lemma eq_snoc_erase_top {s : composition_series X} (h : 0 < s.length) :
  s = snoc (erase_top s) s.top (is_maximal_erase_top_top h) :=
begin
  ext x,
  simp [mem_snoc, mem_erase_top h],
  by_cases h : x = s.top; simp [*, s.top_mem]
end

@[simp] lemma snoc_erase_top_top {s : composition_series X}
  (h : is_maximal s.erase_top.top s.top) : s.erase_top.snoc s.top h = s :=
have h : 0 < s.length,
  from nat.pos_of_ne_zero begin
    assume hs,
    refine ne_of_gt (lt_of_is_maximal h) _,
    simp [top, fin.ext_iff, hs]
  end,
(eq_snoc_erase_top h).symm

/-- Two `composition_series X`, `s₁` and `s₂` are equivalent if there is a bijection
`e : fin s₁.length ≃ fin s₂.length` such that for any `i`,
`iso (s₁ i) (s₁ i.succ) (s₂ (e i), s₂ (e i.succ))` -/
def equivalent (s₁ s₂ : composition_series X) : Prop :=
∃ f : fin s₁.length ≃ fin s₂.length,
  ∀ i : fin s₁.length,
    iso (s₁ i.cast_succ, s₁ i.succ)
    (s₂ (f i).cast_succ, s₂ (f i).succ)

namespace equivalent

@[refl] lemma refl (s : composition_series X) : equivalent s s :=
⟨equiv.refl _, λ _, (s.step _).iso_refl⟩

@[symm] lemma symm {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) :
  equivalent s₂ s₁ :=
⟨h.some.symm, λ i, iso_symm (by simpa using h.some_spec (h.some.symm i))⟩

@[trans] lemma trans {s₁ s₂ s₃ : composition_series X}
  (h₁ : equivalent s₁ s₂)
  (h₂ : equivalent s₂ s₃) :
  equivalent s₁ s₃ :=
⟨h₁.some.trans h₂.some, λ i, iso_trans (h₁.some_spec i) (h₂.some_spec (h₁.some i))⟩

lemma append
  {s₁ s₂ t₁ t₂ : composition_series X}
  (hs : s₁.top = s₂.bot)
  (ht : t₁.top = t₂.bot)
  (h₁ : equivalent s₁ t₁)
  (h₂ : equivalent s₂ t₂) :
  equivalent (append s₁ s₂ hs) (append t₁ t₂ ht) :=
let e : fin (s₁.length + s₂.length) ≃ fin (t₁.length + t₂.length) :=
  calc fin (s₁.length + s₂.length) ≃ fin s₁.length ⊕ fin s₂.length : fin_sum_fin_equiv.symm
  ... ≃ fin t₁.length ⊕ fin t₂.length : equiv.sum_congr h₁.some h₂.some
  ... ≃ fin (t₁.length + t₂.length) : fin_sum_fin_equiv in
⟨e, begin
  assume i,
  refine fin.add_cases _ _ i,
  { assume i,
    simpa [top, bot] using h₁.some_spec i },
  { assume i,
    simpa [top, bot] using h₂.some_spec i }
end⟩

protected lemma snoc
  {s₁ s₂ : composition_series X}
  {x₁ x₂ : X}
  {hsat₁ : is_maximal s₁.top x₁}
  {hsat₂ : is_maximal s₂.top x₂}
  (hequiv : equivalent s₁ s₂)
  (htop : iso (s₁.top, x₁) (s₂.top, x₂)) :
  equivalent (s₁.snoc x₁ hsat₁) (s₂.snoc x₂ hsat₂) :=
let e : fin s₁.length.succ ≃ fin s₂.length.succ :=
  calc fin (s₁.length + 1) ≃ option (fin s₁.length) : fin_succ_equiv_last
  ... ≃ option (fin s₂.length) : functor.map_equiv option hequiv.some
  ... ≃ fin (s₂.length + 1) : fin_succ_equiv_last.symm in
⟨e,  λ i, begin
  refine fin.last_cases _ _ i,
  { simpa [top] using htop },
  { assume i,
    simpa [fin.succ_cast_succ] using hequiv.some_spec i }
end⟩

lemma length_eq {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) : s₁.length = s₂.length :=
by simpa using fintype.card_congr h.some

lemma snoc_snoc_swap
  {s : composition_series X}
  {x₁ x₂ y₁ y₂ : X}
  {hsat₁ : is_maximal s.top x₁}
  {hsat₂ : is_maximal s.top x₂}
  {hsaty₁ : is_maximal (snoc s x₁ hsat₁).top y₁}
  {hsaty₂ : is_maximal (snoc s x₂ hsat₂).top y₂}
  (hr₁ : iso (s.top, x₁) (x₂, y₂))
  (hr₂ : iso (x₁, y₁) (s.top, x₂)) :
  equivalent
    (snoc (snoc s x₁ hsat₁) y₁ hsaty₁)
    (snoc (snoc s x₂ hsat₂) y₂ hsaty₂) :=
let e : fin (s.length + 1 + 1) ≃ fin (s.length + 1 + 1) :=
equiv.swap (fin.last _) (fin.cast_succ (fin.last _)) in
have h1 : ∀ {i : fin s.length},
  i.cast_succ.cast_succ ≠ (fin.last _).cast_succ,
  from λ _, ne_of_lt (by simp [fin.cast_succ_lt_last]),
have h2 : ∀ {i : fin s.length},
  i.cast_succ.cast_succ ≠ (fin.last _),
  from λ _, ne_of_lt (by simp [fin.cast_succ_lt_last]),
⟨e, begin
  intro i,
  dsimp only [e],
  refine fin.last_cases _ (λ i, _) i,
  { erw [equiv.swap_apply_left, snoc_cast_succ, snoc_last, fin.succ_last, snoc_last,
      snoc_cast_succ, snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
      fin.succ_last, snoc_last],
    exact hr₂ },
  { refine fin.last_cases _ (λ i, _) i,
    { erw [equiv.swap_apply_right, snoc_cast_succ, snoc_cast_succ,
        snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
        fin.succ_last, snoc_last, snoc_last, fin.succ_last, snoc_last],
      exact hr₁ },
    { erw [equiv.swap_apply_of_ne_of_ne h2 h1, snoc_cast_succ, snoc_cast_succ,
        snoc_cast_succ, snoc_cast_succ, fin.succ_cast_succ, snoc_cast_succ,
        fin.succ_cast_succ, snoc_cast_succ, snoc_cast_succ, snoc_cast_succ],
      exact (s.step i).iso_refl } }
end⟩

end equivalent

lemma length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁ : s₁.length = 0) : s₂.length = 0 :=
begin
  have : s₁.bot = s₁.top,
    from congr_arg s₁ (fin.ext (by simp [hs₁])),
  have : (fin.last s₂.length) = (0 : fin s₂.length.succ),
    from s₂.injective (hb.symm.trans (this.trans ht)).symm,
  simpa [fin.ext_iff]
end

lemma length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  0 < s₁.length → 0 < s₂.length :=
not_imp_not.1 begin
  simp only [pos_iff_ne_zero, ne.def, not_iff_not, not_not],
  exact length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb.symm ht.symm
end

lemma eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁0 : s₁.length = 0) :
  s₁ = s₂ :=
have ∀ x, x ∈ s₁ ↔ x = s₁.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero hs₁0 hx s₁.top_mem, λ hx, hx.symm ▸ s₁.top_mem⟩,
have ∀ x, x ∈ s₂ ↔ x = s₂.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero
      (length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hs₁0)
    hx s₂.top_mem, λ hx, hx.symm ▸ s₂.top_mem⟩,
by { ext, simp * }

/-- Given a `composition_series`, `s`, and an element `x`
such that `x` is maximal inside `s.top` there is a series, `t`,
such that `t.top = x`, `t.bot = s.bot`
and `snoc t s.top _` is equivalent to `s`. -/
lemma exists_top_eq_snoc_equivalant (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : s.bot ≤ x) :
  ∃ t : composition_series X, t.bot = s.bot ∧ t.length + 1 = s.length ∧
    ∃ htx : t.top = x, equivalent s (snoc t s.top (htx.symm ▸ hm)) :=
begin
  induction hn : s.length with n ih generalizing s x,
  { exact (ne_of_gt (lt_of_le_of_lt hb (lt_of_is_maximal hm))
      (forall_mem_eq_of_length_eq_zero hn s.top_mem s.bot_mem)).elim },
  { have h0s : 0 < s.length, from hn.symm ▸ nat.succ_pos _,
    by_cases hetx : s.erase_top.top = x,
    { use s.erase_top,
      simp [← hetx, hn] },
    { have imxs : is_maximal (x ⊓ s.erase_top.top) s.erase_top.top,
        from is_maximal_of_eq_inf x s.top rfl (ne.symm hetx) hm
          (is_maximal_erase_top_top h0s),
      have := ih _ _ imxs (le_inf (by simpa) (le_top_of_mem s.erase_top.bot_mem)) (by simp [hn]),
      rcases this with ⟨t, htb, htl, htt, hteqv⟩,
      have hmtx : is_maximal t.top x,
        from is_maximal_of_eq_inf s.erase_top.top s.top
          (by rw [inf_comm, htt]) hetx
          (is_maximal_erase_top_top h0s) hm,
      use snoc t x hmtx,
      refine ⟨by simp [htb], by simp [htl], by simp, _⟩,
      have : s.equivalent ((snoc t s.erase_top.top (htt.symm ▸ imxs)).snoc s.top
        (by simpa using is_maximal_erase_top_top h0s)),
      { conv_lhs { rw eq_snoc_erase_top h0s },
        exact equivalent.snoc hteqv
          (by simpa using (is_maximal_erase_top_top h0s).iso_refl) },
      refine this.trans _,
      refine equivalent.snoc_snoc_swap _ _,
      { exact iso_symm (second_iso_of_eq hm
          (sup_eq_of_is_maximal hm
            (is_maximal_erase_top_top h0s)
            (ne.symm hetx))
          htt.symm) },
      { exact second_iso_of_eq (is_maximal_erase_top_top h0s)
          (sup_eq_of_is_maximal
            (is_maximal_erase_top_top h0s)
            hm hetx)
          (by rw [inf_comm, htt]) } } }
end

/-- The **Jordan-Hölder** theorem, stated for any `jordan_holder_lattice`.
If two composition series start and finish at the same place, they are equivalent. -/
theorem jordan_holder (s₁ s₂ : composition_series X)
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  equivalent s₁ s₂ :=
begin
  induction hle : s₁.length with n ih generalizing s₁ s₂,
  { rw [eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hle] },
  { have h0s₂ : 0 < s₂.length,
      from length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos hb ht (hle.symm ▸ nat.succ_pos _),
    rcases exists_top_eq_snoc_equivalant s₁ s₂.erase_top.top
      (ht.symm ▸ is_maximal_erase_top_top h0s₂)
      (hb.symm ▸ s₂.bot_erase_top ▸ bot_le_of_mem (top_mem _)) with ⟨t, htb, htl, htt, hteq⟩,
    have := ih t s₂.erase_top (by simp [htb, ← hb]) htt (nat.succ_inj'.1 (htl.trans hle)),
    refine hteq.trans _,
    conv_rhs { rw [eq_snoc_erase_top h0s₂] },
    simp only [ht],
    exact equivalent.snoc this
      (by simp [htt, (is_maximal_erase_top_top h0s₂).iso_refl]) }
end

end composition_series


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

import linear_algebra.bilinear_form
import linear_algebra.matrix.charpoly.coeff
import linear_algebra.determinant
import linear_algebra.vandermonde
import linear_algebra.trace
import field_theory.is_alg_closed.algebraic_closure
import field_theory.primitive_element
import ring_theory.power_basis

/-!
# Trace for (finite) ring extensions.

Suppose we have an `R`-algebra `S` with a finite basis. For each `s : S`,
the trace of the linear map given by multiplying by `s` gives information about
the roots of the minimal polynomial of `s` over `R`.

## Main definitions

 * `algebra.trace R S x`: the trace of an element `s` of an `R`-algebra `S`
 * `algebra.trace_form R S`: bilinear form sending `x`, `y` to the trace of `x * y`
 * `algebra.trace_matrix R b`: the matrix whose `(i j)`-th element is the trace of `b i * b j`.
 * `algebra.embeddings_matrix A C b : matrix κ (B →ₐ[A] C) C` is the matrix whose
   `(i, σ)` coefficient is `σ (b i)`.
 * `algebra.embeddings_matrix_reindex A C b e : matrix κ κ C` is the matrix whose `(i, j)`
   coefficient is `σⱼ (b i)`, where `σⱼ : B →ₐ[A] C` is the embedding corresponding to `j : κ`
   given by a bijection `e : κ ≃ (B →ₐ[A] C)`.

## Main results

 * `trace_algebra_map_of_basis`, `trace_algebra_map`: if `x : K`, then `Tr_{L/K} x = [L : K] x`
 * `trace_trace_of_basis`, `trace_trace`: `Tr_{L/K} (Tr_{F/L} x) = Tr_{F/K} x`
 * `trace_eq_sum_roots`: the trace of `x : K(x)` is the sum of all conjugate roots of `x`
 * `trace_eq_sum_embeddings`: the trace of `x : K(x)` is the sum of all embeddings of `x` into an
   algebraically closed field
 * `trace_form_nondegenerate`: the trace form over a separable extension is a nondegenerate
   bilinear form

## Implementation notes

Typically, the trace is defined specifically for finite field extensions.
The definition is as general as possible and the assumption that we have
fields or that the extension is finite is added to the lemmas as needed.

We only define the trace for left multiplication (`algebra.left_mul_matrix`,
i.e. `algebra.lmul_left`).
For now, the definitions assume `S` is commutative, so the choice doesn't matter anyway.

## References

 * https://en.wikipedia.org/wiki/Field_trace

-/

universes u v w z

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra R T]
variables {K L : Type*} [field K] [field L] [algebra K L]
variables {ι κ : Type w} [fintype ι]

open finite_dimensional
open linear_map
open matrix

open_locale big_operators
open_locale matrix

namespace algebra

variables (b : basis ι R S)

variables (R S)

/-- The trace of an element `s` of an `R`-algebra is the trace of `(*) s`,
as an `R`-linear map. -/
noncomputable def trace : S →ₗ[R] R :=
(linear_map.trace R S).comp (lmul R S).to_linear_map

variables {S}

-- Not a `simp` lemma since there are more interesting ways to rewrite `trace R S x`,
-- for example `trace_trace`
lemma trace_apply (x) : trace R S x = linear_map.trace R S (lmul R S x) := rfl

lemma trace_eq_zero_of_not_exists_basis
  (h : ¬ ∃ (s : finset S), nonempty (basis s R S)) : trace R S = 0 :=
by { ext s, simp [trace_apply, linear_map.trace, h] }

include b

variables {R}

-- Can't be a `simp` lemma because it depends on a choice of basis
lemma trace_eq_matrix_trace [decidable_eq ι] (b : basis ι R S) (s : S) :
  trace R S s = matrix.trace _ R _ (algebra.left_mul_matrix b s) :=
by rw [trace_apply, linear_map.trace_eq_matrix_trace _ b, to_matrix_lmul_eq]

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`. -/
lemma trace_algebra_map_of_basis (x : R) :
  trace R S (algebra_map R S x) = fintype.card ι • x :=
begin
  haveI := classical.dec_eq ι,
  rw [trace_apply, linear_map.trace_eq_matrix_trace R b, trace_diag],
  convert finset.sum_const _,
  ext i,
  simp,
end
omit b

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`.

(If `L` is not finite-dimensional over `K`, then `trace` and `finrank` return `0`.)
-/
@[simp]
lemma trace_algebra_map (x : K) : trace K L (algebra_map K L x) = finrank K L • x :=
begin
  by_cases H : ∃ (s : finset L), nonempty (basis s K L),
  { rw [trace_algebra_map_of_basis H.some_spec.some, finrank_eq_card_basis H.some_spec.some] },
  { simp [trace_eq_zero_of_not_exists_basis K H, finrank_eq_zero_of_not_exists_basis_finset H] }
end

lemma trace_trace_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ]
  (b : basis ι R S) (c : basis κ S T) (x : T) :
  trace R S (trace S T x) = trace R T x :=
begin
  haveI := classical.dec_eq ι,
  haveI := classical.dec_eq κ,
  rw [trace_eq_matrix_trace (b.smul c), trace_eq_matrix_trace b, trace_eq_matrix_trace c,
      matrix.trace_apply, matrix.trace_apply, matrix.trace_apply,
      ← finset.univ_product_univ, finset.sum_product],
  refine finset.sum_congr rfl (λ i _, _),
  simp only [alg_hom.map_sum, smul_left_mul_matrix, finset.sum_apply,
      -- The unifier is not smart enough to apply this one by itself:
      finset.sum_apply i _ (λ y, left_mul_matrix b (left_mul_matrix c x y y))]
end

lemma trace_comp_trace_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ]
  (b : basis ι R S) (c : basis κ S T) :
  (trace R S).comp ((trace S T).restrict_scalars R) = trace R T :=
by { ext, rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, trace_trace_of_basis b c] }

@[simp]
lemma trace_trace [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] (x : T) :
  trace K L (trace L T x) = trace K T x :=
trace_trace_of_basis (basis.of_vector_space K L) (basis.of_vector_space L T) x

@[simp]
lemma trace_comp_trace [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] :
  (trace K L).comp ((trace L T).restrict_scalars K) = trace K T :=
by { ext, rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, trace_trace] }

section trace_form

variables (R S)

/-- The `trace_form` maps `x y : S` to the trace of `x * y`.
It is a symmetric bilinear form and is nondegenerate if the extension is separable. -/
noncomputable def trace_form : bilin_form R S :=
(linear_map.compr₂ (lmul R S).to_linear_map (trace R S)).to_bilin

variables {S}

-- This is a nicer lemma than the one produced by `@[simps] def trace_form`.
@[simp] lemma trace_form_apply (x y : S) : trace_form R S x y = trace R S (x * y) := rfl

lemma trace_form_is_symm : (trace_form R S).is_symm :=
λ x y, congr_arg (trace R S) (mul_comm _ _)

lemma trace_form_to_matrix_power_basis (h : power_basis R S) :
  bilin_form.to_matrix h.basis (trace_form R S) = λ i j, (trace R S (h.gen ^ (i + j : ℕ))) :=
by { ext, rw [trace_form_to_matrix, pow_add, h.basis_eq_pow, h.basis_eq_pow] }

end trace_form

end algebra

section eq_sum_roots

open algebra polynomial

variables {F : Type*} [field F]
variables [algebra K S] [algebra K F]

/-- Given `pb : power_basis K S`, the trace of `pb.gen` is `-(minpoly K pb.gen).next_coeff`. -/
lemma power_basis.trace_gen_eq_next_coeff_minpoly [nontrivial S] (pb : power_basis K S) :
  algebra.trace K S pb.gen = -(minpoly K pb.gen).next_coeff :=
begin
  have d_pos : 0 < pb.dim := power_basis.dim_pos pb,
  have d_pos' : 0 < (minpoly K pb.gen).nat_degree, { simpa },
  haveI : nonempty (fin pb.dim) := ⟨⟨0, d_pos⟩⟩,
  rw [trace_eq_matrix_trace pb.basis, trace_eq_neg_charpoly_coeff, charpoly_left_mul_matrix,
      ← pb.nat_degree_minpoly, fintype.card_fin, ← next_coeff_of_pos_nat_degree _ d_pos']
end

/-- Given `pb : power_basis K S`, then the trace of `pb.gen` is
`((minpoly K pb.gen).map (algebra_map K F)).roots.sum`. -/
lemma power_basis.trace_gen_eq_sum_roots [nontrivial S] (pb : power_basis K S)
  (hf : (minpoly K pb.gen).splits (algebra_map K F)) :
  algebra_map K F (trace K S pb.gen) =
    ((minpoly K pb.gen).map (algebra_map K F)).roots.sum :=
begin
  rw [power_basis.trace_gen_eq_next_coeff_minpoly, ring_hom.map_neg, ← next_coeff_map
    (algebra_map K F).injective, sum_roots_eq_next_coeff_of_monic_of_split
      (monic_map _ (minpoly.monic (power_basis.is_integral_gen _)))
      ((splits_id_iff_splits _).2 hf), neg_neg]
end

namespace intermediate_field.adjoin_simple

open intermediate_field

lemma trace_gen_eq_zero {x : L} (hx : ¬ is_integral K x) :
  algebra.trace K K⟮x⟯ (adjoin_simple.gen K x) = 0 :=
begin
  rw [trace_eq_zero_of_not_exists_basis, linear_map.zero_apply],
  contrapose! hx,
  obtain ⟨s, ⟨b⟩⟩ := hx,
  refine is_integral_of_mem_of_fg (K⟮x⟯).to_subalgebra _ x _,
  { exact (submodule.fg_iff_finite_dimensional _).mpr (finite_dimensional.of_finset_basis b) },
  { exact subset_adjoin K _ (set.mem_singleton x) }
end

lemma trace_gen_eq_sum_roots (x : L)
  (hf : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (trace K K⟮x⟯ (adjoin_simple.gen K x)) =
    ((minpoly K x).map (algebra_map K F)).roots.sum :=
begin
  have injKKx : function.injective (algebra_map K K⟮x⟯) := ring_hom.injective _,
  have injKxL : function.injective (algebra_map K⟮x⟯ L) := ring_hom.injective _,
  by_cases hx : is_integral K x, swap,
  { simp [minpoly.eq_zero hx, trace_gen_eq_zero hx], },
  have hx' : is_integral K (adjoin_simple.gen K x),
  { rwa [← is_integral_algebra_map_iff injKxL, adjoin_simple.algebra_map_gen],
    apply_instance },
  rw [← adjoin.power_basis_gen hx, (adjoin.power_basis hx).trace_gen_eq_sum_roots];
    rw [adjoin.power_basis_gen hx, minpoly.eq_of_algebra_map_eq injKxL hx'];
    try { simp only [adjoin_simple.algebra_map_gen _ _] },
  exact hf
end

end intermediate_field.adjoin_simple

open intermediate_field

variables (K)

lemma trace_eq_trace_adjoin [finite_dimensional K L] (x : L) :
  algebra.trace K L x = finrank K⟮x⟯ L • trace K K⟮x⟯ (adjoin_simple.gen K x) :=
begin
  rw ← @trace_trace _ _ K K⟮x⟯ _ _ _ _ _ _ _ _ x,
  conv in x { rw ← intermediate_field.adjoin_simple.algebra_map_gen K x },
  rw [trace_algebra_map, linear_map.map_smul_of_tower],
end

variables {K}

lemma trace_eq_sum_roots [finite_dimensional K L]
  {x : L} (hF : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (algebra.trace K L x) =
    finrank K⟮x⟯ L • ((minpoly K x).map (algebra_map K _)).roots.sum :=
by rw [trace_eq_trace_adjoin K x, algebra.smul_def, ring_hom.map_mul, ← algebra.smul_def,
    intermediate_field.adjoin_simple.trace_gen_eq_sum_roots _ hF, is_scalar_tower.algebra_map_smul]

end eq_sum_roots

variables {F : Type*} [field F]
variables [algebra R L] [algebra L F] [algebra R F] [is_scalar_tower R L F]

open polynomial

lemma algebra.is_integral_trace [finite_dimensional L F] {x : F} (hx : _root_.is_integral R x) :
  _root_.is_integral R (algebra.trace L F x) :=
begin
  have hx' : _root_.is_integral L x := is_integral_of_is_scalar_tower _ hx,
  rw [← is_integral_algebra_map_iff (algebra_map L (algebraic_closure F)).injective,
      trace_eq_sum_roots],
  { refine (is_integral.multiset_sum _).nsmul _,
    intros y hy,
    rw mem_roots_map (minpoly.ne_zero hx') at hy,
    use [minpoly R x, minpoly.monic hx],
    rw ← aeval_def at ⊢ hy,
    exact minpoly.aeval_of_is_scalar_tower R x y hy },
  { apply is_alg_closed.splits_codomain },
  { apply_instance }
end

section eq_sum_embeddings

variables [algebra K F] [is_scalar_tower K L F]

open algebra intermediate_field

variables (F) (E : Type*) [field E] [algebra K E]

lemma trace_eq_sum_embeddings_gen
  (pb : power_basis K L)
  (hE : (minpoly K pb.gen).splits (algebra_map K E)) (hfx : (minpoly K pb.gen).separable) :
  algebra_map K E (algebra.trace K L pb.gen) =
    (@@finset.univ (power_basis.alg_hom.fintype pb)).sum (λ σ, σ pb.gen) :=
begin
  letI := classical.dec_eq E,
  rw [pb.trace_gen_eq_sum_roots hE, fintype.sum_equiv pb.lift_equiv', finset.sum_mem_multiset,
      finset.sum_eq_multiset_sum, multiset.to_finset_val,
      multiset.erase_dup_eq_self.mpr _, multiset.map_id],
  { exact nodup_roots ((separable_map _).mpr hfx) },
  { intro x, refl },
  { intro σ, rw [power_basis.lift_equiv'_apply_coe, id.def] }
end

variables [is_alg_closed E]

lemma sum_embeddings_eq_finrank_mul [finite_dimensional K F] [is_separable K F]
  (pb : power_basis K L) :
  ∑ σ : F →ₐ[K] E, σ (algebra_map L F pb.gen) =
    finrank L F • (@@finset.univ (power_basis.alg_hom.fintype pb)).sum
      (λ σ : L →ₐ[K] E, σ pb.gen) :=
begin
  haveI : finite_dimensional L F := finite_dimensional.right K L F,
  haveI : is_separable L F := is_separable_tower_top_of_is_separable K L F,
  letI : fintype (L →ₐ[K] E) := power_basis.alg_hom.fintype pb,
  letI : ∀ (f : L →ₐ[K] E), fintype (@@alg_hom L F E _ _ _ _ f.to_ring_hom.to_algebra) :=
    _, -- will be solved by unification
  rw [fintype.sum_equiv alg_hom_equiv_sigma (λ (σ : F →ₐ[K] E), _) (λ σ, σ.1 pb.gen),
      ← finset.univ_sigma_univ, finset.sum_sigma, ← finset.sum_nsmul],
  refine finset.sum_congr rfl (λ σ _, _),
  { letI : algebra L E := σ.to_ring_hom.to_algebra,
    simp only [finset.sum_const, finset.card_univ],
    rw alg_hom.card L F E },
  { intros σ,
    simp only [alg_hom_equiv_sigma, equiv.coe_fn_mk, alg_hom.restrict_domain, alg_hom.comp_apply,
         is_scalar_tower.coe_to_alg_hom'] }
end

lemma trace_eq_sum_embeddings [finite_dimensional K L] [is_separable K L]
  {x : L} : algebra_map K E (algebra.trace K L x) = ∑ σ : L →ₐ[K] E, σ x :=
begin
  have hx := is_separable.is_integral K x,
  rw [trace_eq_trace_adjoin K x, algebra.smul_def, ring_hom.map_mul, ← adjoin.power_basis_gen hx,
      trace_eq_sum_embeddings_gen E (adjoin.power_basis hx) (is_alg_closed.splits_codomain _),
      ← algebra.smul_def, algebra_map_smul],
  { exact (sum_embeddings_eq_finrank_mul L E (adjoin.power_basis hx)).symm },
  { haveI := is_separable_tower_bot_of_is_separable K K⟮x⟯ L,
    exact is_separable.separable K _ }
end

end eq_sum_embeddings

section det_ne_zero

namespace algebra

variables (A : Type u) {B : Type v} (C : Type z)
variables [comm_ring A] [comm_ring B] [algebra A B] [comm_ring C] [algebra A C]

open finset

/-- Given an `A`-algebra `B` and `b`, an `κ`-indexed family of elements of `B`, we define
`trace_matrix A b` as the matrix whose `(i j)`-th element is the trace of `b i * b j`. -/
@[simp] noncomputable
def trace_matrix (b : κ → B) : matrix κ κ A
| i j := trace_form A B (b i) (b j)

lemma trace_matrix_def (b : κ → B) : trace_matrix A b = λ i j, trace_form A B (b i) (b j) := rfl

variables {A}

lemma trace_matrix_of_matrix_vec_mul [fintype κ] (b : κ → B) (P : matrix κ κ A) :
  trace_matrix A ((P.map (algebra_map A B)).vec_mul b) = Pᵀ ⬝ (trace_matrix A b) ⬝ P :=
begin
  ext α β,
  rw [trace_matrix, vec_mul, dot_product, vec_mul, dot_product, matrix.mul_apply,
    bilin_form.sum_left, fintype.sum_congr _ _ (λ (i : κ), @bilin_form.sum_right _ _ _ _ _ _ _ _
    (b i * P.map (algebra_map A B) i α) (λ (y : κ), b y * P.map (algebra_map A B) y β)), sum_comm],
  congr, ext x,
  rw [matrix.mul_apply, sum_mul],
  congr, ext y,
  rw [map_apply, trace_form_apply, mul_comm (b y), ← smul_def],
  simp only [id.smul_eq_mul, ring_hom.id_apply, map_apply, transpose_apply, linear_map.map_smulₛₗ,
    trace_form_apply, algebra.smul_mul_assoc],
  rw [mul_comm (b x), ← smul_def],
  ring_nf,
  simp,
end

lemma trace_matrix_of_matrix_mul_vec [fintype κ] (b : κ → B) (P : matrix κ κ A) :
  trace_matrix A ((P.map (algebra_map A B)).mul_vec b) = P ⬝ (trace_matrix A b) ⬝ Pᵀ :=
begin
  refine add_equiv.injective transpose_add_equiv _,
  rw [transpose_add_equiv_apply, transpose_add_equiv_apply, ← vec_mul_transpose,
    ← transpose_map, trace_matrix_of_matrix_vec_mul, transpose_transpose, transpose_mul,
    transpose_transpose, transpose_mul]
end

lemma trace_matrix_of_basis [fintype κ] [decidable_eq κ] (b : basis κ A B) :
  trace_matrix A b = bilin_form.to_matrix b (trace_form A B) :=
begin
  ext i j,
  rw [trace_matrix, trace_form_apply, trace_form_to_matrix]
end

lemma trace_matrix_of_basis_mul_vec (b : basis ι A B) (z : B) :
  (trace_matrix A b).mul_vec (b.equiv_fun z) = (λ i, trace A B (z * (b i))) :=
begin
  ext i,
  rw [← col_apply ((trace_matrix A b).mul_vec (b.equiv_fun z)) i unit.star, col_mul_vec,
    matrix.mul_apply, trace_matrix_def],
  simp only [col_apply, trace_form_apply],
  conv_lhs
  { congr, skip, funext,
    rw [mul_comm _ (b.equiv_fun z _), ← smul_eq_mul, ← linear_map.map_smul] },
    rw [← linear_map.map_sum],
    congr,
    conv_lhs
    { congr, skip, funext,
      rw [← mul_smul_comm] },
    rw [← finset.mul_sum, mul_comm z],
    congr,
    rw [b.sum_equiv_fun ]
end

variable (A)
/-- `embeddings_matrix A C b : matrix κ (B →ₐ[A] C) C` is the matrix whose `(i, σ)` coefficient is
  `σ (b i)`. It is mostly useful for fields when `fintype.card κ = finrank A B` and `C` is
  algebraically closed. -/
@[simp] def embeddings_matrix (b : κ → B) : matrix κ (B →ₐ[A] C) C
| i σ := σ (b i)

/-- `embeddings_matrix_reindex A C b e : matrix κ κ C` is the matrix whose `(i, j)` coefficient
  is `σⱼ (b i)`, where `σⱼ : B →ₐ[A] C` is the embedding corresponding to `j : κ` given by a
  bijection `e : κ ≃ (B →ₐ[A] C)`. It is mostly useful for fields and `C` is algebraically closed.
  In this case, in presence of `h : fintype.card κ = finrank A B`, one can take
  `e := equiv_of_card_eq ((alg_hom.card A B C).trans h.symm)`. -/
def embeddings_matrix_reindex (b : κ → B) (e : κ ≃ (B →ₐ[A] C)) :=
reindex (equiv.refl κ) e.symm (embeddings_matrix A C b)

variable {A}

lemma embeddings_matrix_reindex_eq_vandermonde (pb : power_basis A B)
  (e : fin pb.dim ≃ (B →ₐ[A] C)) :
  embeddings_matrix_reindex A C pb.basis e = (vandermonde (λ i, e i pb.gen))ᵀ :=
by { ext i j, simp [embeddings_matrix_reindex, embeddings_matrix] }

section field

variables (K) {L} (E : Type z) [field E]
variables [algebra K E]
variables [module.finite K L] [is_separable K L] [is_alg_closed E]
variables (b : κ → L) (pb : power_basis K L)

lemma trace_matrix_eq_embeddings_matrix_mul_trans :
  (trace_matrix K b).map (algebra_map K E) =
  (embeddings_matrix K E b) ⬝ (embeddings_matrix K E b)ᵀ :=
by { ext i j, simp [trace_eq_sum_embeddings, embeddings_matrix, matrix.mul_apply] }

lemma trace_matrix_eq_embeddings_matrix_reindex_mul_trans [fintype κ]
  (e : κ ≃ (L →ₐ[K] E)) : (trace_matrix K b).map (algebra_map K E) =
  (embeddings_matrix_reindex K E b e) ⬝ (embeddings_matrix_reindex K E b e)ᵀ :=
by rw [trace_matrix_eq_embeddings_matrix_mul_trans, embeddings_matrix_reindex, reindex_apply,
  transpose_minor, ← minor_mul_transpose_minor, ← equiv.coe_refl, equiv.refl_symm]

end field

end algebra

open algebra

variables (pb : power_basis K L)

lemma det_trace_matrix_ne_zero' [is_separable K L] :
  det (trace_matrix K pb.basis) ≠ 0 :=
begin
  suffices : algebra_map K (algebraic_closure L) (det (trace_matrix K pb.basis)) ≠ 0,
  { refine mt (λ ht, _) this,
    rw [ht, ring_hom.map_zero] },
  haveI : finite_dimensional K L := pb.finite_dimensional,
  let e : fin pb.dim ≃ (L →ₐ[K] algebraic_closure L) := (fintype.equiv_fin_of_card_eq _).symm,
  rw [ring_hom.map_det, ring_hom.map_matrix_apply,
      trace_matrix_eq_embeddings_matrix_reindex_mul_trans K _ _ e,
      embeddings_matrix_reindex_eq_vandermonde, det_mul, det_transpose],
  refine mt mul_self_eq_zero.mp _,
  { simp only [det_vandermonde, finset.prod_eq_zero_iff, not_exists, sub_eq_zero],
    intros i _ j hij h,
    exact (finset.mem_filter.mp hij).2.ne' (e.injective $ pb.alg_hom_ext h) },
  { rw [alg_hom.card, pb.finrank] }
end

lemma det_trace_form_ne_zero [is_separable K L] [decidable_eq ι] (b : basis ι K L) :
  det (bilin_form.to_matrix b (trace_form K L)) ≠ 0 :=
begin
  haveI : finite_dimensional K L := finite_dimensional.of_fintype_basis b,
  let pb : power_basis K L := field.power_basis_of_finite_of_separable _ _,
  rw [← bilin_form.to_matrix_mul_basis_to_matrix pb.basis b,
      ← det_comm' (pb.basis.to_matrix_mul_to_matrix_flip b) _,
      ← matrix.mul_assoc, det_mul],
  swap, { apply basis.to_matrix_mul_to_matrix_flip },
  refine mul_ne_zero
    (is_unit_of_mul_eq_one _ ((b.to_matrix pb.basis)ᵀ ⬝ b.to_matrix pb.basis).det _).ne_zero
    _,
  { calc (pb.basis.to_matrix b ⬝ (pb.basis.to_matrix b)ᵀ).det *
        ((b.to_matrix pb.basis)ᵀ ⬝ b.to_matrix pb.basis).det
        = (pb.basis.to_matrix b ⬝ (b.to_matrix pb.basis ⬝ pb.basis.to_matrix b)ᵀ ⬝
          b.to_matrix pb.basis).det
        : by simp only [← det_mul, matrix.mul_assoc, matrix.transpose_mul]
    ... = 1 : by simp only [basis.to_matrix_mul_to_matrix_flip, matrix.transpose_one,
                            matrix.mul_one, matrix.det_one] },
  simpa only [trace_matrix_of_basis] using det_trace_matrix_ne_zero' pb
end

variables (K L)

theorem trace_form_nondegenerate [finite_dimensional K L] [is_separable K L] :
  (trace_form K L).nondegenerate :=
bilin_form.nondegenerate_of_det_ne_zero (trace_form K L) _
  (det_trace_form_ne_zero (finite_dimensional.fin_basis K L))

end det_ne_zero