/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

! This file was ported from Lean 3 source module init.data.list.basic
! leanprover-community/mathlib commit 7cb84a2a93c1e2d37b3ad5017fc5372973dbb9fb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Logic
import Leanbin.Init.Data.Nat.Basic
import Leanbin.Init.Data.Bool.Basic
import Leanbin.Init.Propext

open Decidable List

universe u v w

instance (α : Type u) : Inhabited (List α) :=
  ⟨List.nil⟩

variable {α : Type u} {β : Type v} {γ : Type w}

namespace List

#print List.hasDecEq /-
protected def hasDecEq [s : DecidableEq α] : DecidableEq (List α)
  | [], [] => isTrue rfl
  | a :: as, [] => isFalse fun h => List.noConfusion h
  | [], b :: bs => isFalse fun h => List.noConfusion h
  | a :: as, b :: bs =>
    match s a b with
    | is_true hab =>
      match has_dec_eq as bs with
      | is_true habs => isTrue (Eq.subst hab (Eq.subst habs rfl))
      | is_false nabs => isFalse fun h => List.noConfusion h fun _ habs => absurd habs nabs
    | is_false nab => isFalse fun h => List.noConfusion h fun hab _ => absurd hab nab
#align list.has_dec_eq List.hasDecEq
-/

instance [DecidableEq α] : DecidableEq (List α) :=
  List.hasDecEq

#print List.append /-
@[simp]
protected def append : List α → List α → List α
  | [], l => l
  | h :: s, t => h :: append s t
#align list.append List.append
-/

instance : Append (List α) :=
  ⟨List.append⟩

#print List.Mem /-
protected def Mem : α → List α → Prop
  | a, [] => False
  | a, b :: l => a = b ∨ mem a l
#align list.mem List.Mem
-/

instance : Membership α (List α) :=
  ⟨List.Mem⟩

instance decidableMem [DecidableEq α] (a : α) : ∀ l : List α, Decidable (a ∈ l)
  | [] => isFalse not_false
  | b :: l =>
    if h₁ : a = b then isTrue (Or.inl h₁)
    else
      match decidable_mem l with
      | is_true h₂ => isTrue (Or.inr h₂)
      | is_false h₂ => isFalse (not_or_of_not h₁ h₂)
#align list.decidable_mem List.decidableMem

instance : EmptyCollection (List α) :=
  ⟨List.nil⟩

protected def erase {α} [DecidableEq α] : List α → α → List α
  | [], b => []
  | a :: l, b => if a = b then l else a :: erase l b
#align list.erase List.eraseₓ

protected def bagInter {α} [DecidableEq α] : List α → List α → List α
  | [], _ => []
  | _, [] => []
  | a :: l₁, l₂ => if a ∈ l₂ then a :: bag_inter l₁ (l₂.eraseₓ a) else bag_inter l₁ l₂
#align list.bag_inter List.bagInterₓ

protected def diff {α} [DecidableEq α] : List α → List α → List α
  | l, [] => l
  | l₁, a :: l₂ => if a ∈ l₁ then diff (l₁.eraseₓ a) l₂ else diff l₁ l₂
#align list.diff List.diffₓ

#print List.length /-
@[simp]
def length : List α → Nat
  | [] => 0
  | a :: l => length l + 1
#align list.length List.length
-/

#print List.isEmpty /-
def isEmpty : List α → Bool
  | [] => true
  | _ :: _ => false
#align list.empty List.isEmpty
-/

open Option Nat

#print List.get? /-
@[simp]
def get? : List α → Nat → Option α
  | [], n => none
  | a :: l, 0 => some a
  | a :: l, n + 1 => nth l n
#align list.nth List.get?
-/

#print List.nthLe /-
@[simp]
def nthLe : ∀ (l : List α) (n), n < l.length → α
  | [], n, h => absurd h n.not_lt_zero
  | a :: l, 0, h => a
  | a :: l, n + 1, h => nth_le l n (le_of_succ_le_succ h)
#align list.nth_le List.nthLe
-/

#print List.headI /-
@[simp]
def headI [Inhabited α] : List α → α
  | [] => default
  | a :: l => a
#align list.head List.headI
-/

#print List.tail /-
@[simp]
def tail : List α → List α
  | [] => []
  | a :: l => l
#align list.tail List.tail
-/

#print List.reverseAux /-
def reverseAux : List α → List α → List α
  | [], r => r
  | a :: l, r => reverse_core l (a :: r)
#align list.reverse_core List.reverseAux
-/

#print List.reverse /-
def reverse : List α → List α := fun l => reverseAux l []
#align list.reverse List.reverse
-/

#print List.map /-
@[simp]
def map (f : α → β) : List α → List β
  | [] => []
  | a :: l => f a :: map l
#align list.map List.map
-/

#print List.zipWith /-
@[simp]
def zipWith (f : α → β → γ) : List α → List β → List γ
  | [], _ => []
  | _, [] => []
  | x :: xs, y :: ys => f x y :: map₂ xs ys
#align list.map₂ List.zipWith
-/

/- warning: list.map_with_index_core clashes with [anonymous] -> [anonymous]
Case conversion may be inaccurate. Consider using '#align list.map_with_index_core [anonymous]ₓ'. -/
#print [anonymous] /-
def [anonymous] (f : ℕ → α → β) : ℕ → List α → List β
  | k, [] => []
  | k, a :: as => f k a :: map_with_index_core (k + 1) as
#align list.map_with_index_core [anonymous]
-/

#print List.mapIdx /-
/-- Given a function `f : ℕ → α → β` and `as : list α`, `as = [a₀, a₁, ...]`, returns the list
`[f 0 a₀, f 1 a₁, ...]`. -/
def mapIdx (f : ℕ → α → β) (as : List α) : List β :=
  [anonymous] f 0 as
#align list.map_with_index List.mapIdx
-/

#print List.join /-
def join : List (List α) → List α
  | [] => []
  | l :: ls => l ++ join ls
#align list.join List.join
-/

#print List.filterMap /-
def filterMap (f : α → Option β) : List α → List β
  | [] => []
  | a :: l =>
    match f a with
    | none => filter_map l
    | some b => b :: filter_map l
#align list.filter_map List.filterMap
-/

def filter (p : α → Prop) [DecidablePred p] : List α → List α
  | [] => []
  | a :: l => if p a then a :: Filter l else Filter l
#align list.filter List.filterₓ

def partition (p : α → Prop) [DecidablePred p] : List α → List α × List α
  | [] => ([], [])
  | a :: l =>
    let (l₁, l₂) := partition l
    if p a then (a :: l₁, l₂) else (l₁, a :: l₂)
#align list.partition List.partitionₓ

def dropWhile (p : α → Prop) [DecidablePred p] : List α → List α
  | [] => []
  | a :: l => if p a then drop_while l else a :: l
#align list.drop_while List.dropWhileₓ

/-- `after p xs` is the suffix of `xs` after the first element that satisfies
  `p`, not including that element.

  ```lean
  after      (eq 1)       [0, 1, 2, 3] = [2, 3]
  drop_while (not ∘ eq 1) [0, 1, 2, 3] = [1, 2, 3]
  ```
-/
def after (p : α → Prop) [DecidablePred p] : List α → List α
  | [] => []
  | x :: xs => if p x then xs else after xs
#align list.after List.afterₓ

def span (p : α → Prop) [DecidablePred p] : List α → List α × List α
  | [] => ([], [])
  | a :: xs =>
    if p a then
      let (l, r) := span xs
      (a :: l, r)
    else ([], a :: xs)
#align list.span List.spanₓ

#print List.findIndex /-
def findIndex (p : α → Prop) [DecidablePred p] : List α → Nat
  | [] => 0
  | a :: l => if p a then 0 else succ (find_index l)
#align list.find_index List.findIndex
-/

def indexOf [DecidableEq α] (a : α) : List α → Nat :=
  findIndex (Eq a)
#align list.index_of List.indexOfₓ

def removeAll [DecidableEq α] (xs ys : List α) : List α :=
  filter (· ∉ ys) xs
#align list.remove_all List.removeAllₓ

#print List.set /-
def set : List α → ℕ → α → List α
  | x :: xs, 0, a => a :: xs
  | x :: xs, i + 1, a => x :: update_nth xs i a
  | [], _, _ => []
#align list.update_nth List.set
-/

#print List.removeNth /-
def removeNth : List α → ℕ → List α
  | [], _ => []
  | x :: xs, 0 => xs
  | x :: xs, i + 1 => x :: remove_nth xs i
#align list.remove_nth List.removeNth
-/

#print List.drop /-
@[simp]
def drop : ℕ → List α → List α
  | 0, a => a
  | succ n, [] => []
  | succ n, x :: r => drop n r
#align list.drop List.drop
-/

#print List.take /-
@[simp]
def take : ℕ → List α → List α
  | 0, a => []
  | succ n, [] => []
  | succ n, x :: r => x :: take n r
#align list.take List.take
-/

#print List.foldl /-
@[simp]
def foldl (f : α → β → α) : α → List β → α
  | a, [] => a
  | a, b :: l => foldl (f a b) l
#align list.foldl List.foldl
-/

#print List.foldr /-
@[simp]
def foldr (f : α → β → β) (b : β) : List α → β
  | [] => b
  | a :: l => f a (foldr l)
#align list.foldr List.foldr
-/

#print List.any /-
def any (l : List α) (p : α → Bool) : Bool :=
  foldr (fun a r => p a || r) false l
#align list.any List.any
-/

#print List.all /-
def all (l : List α) (p : α → Bool) : Bool :=
  foldr (fun a r => p a && r) true l
#align list.all List.all
-/

#print List.or /-
def or (l : List Bool) : Bool :=
  any l id
#align list.bor List.or
-/

#print List.and /-
def and (l : List Bool) : Bool :=
  all l id
#align list.band List.and
-/

/- warning: list.zip_with clashes with list.map₂ -> List.zipWith
Case conversion may be inaccurate. Consider using '#align list.zip_with List.zipWithₓ'. -/
#print List.zipWith /-
def zipWith (f : α → β → γ) : List α → List β → List γ
  | x :: xs, y :: ys => f x y :: zip_with xs ys
  | _, _ => []
#align list.zip_with List.zipWith
-/

#print List.zip /-
def zip : List α → List β → List (Prod α β) :=
  zipWith Prod.mk
#align list.zip List.zip
-/

#print List.unzip /-
def unzip : List (α × β) → List α × List β
  | [] => ([], [])
  | (a, b) :: t =>
    match unzip t with
    | (al, bl) => (a :: al, b :: bl)
#align list.unzip List.unzip
-/

#print List.insert /-
protected def insert [DecidableEq α] (a : α) (l : List α) : List α :=
  if a ∈ l then l else a :: l
#align list.insert List.insert
-/

instance [DecidableEq α] : Insert α (List α) :=
  ⟨List.insert⟩

instance : Singleton α (List α) :=
  ⟨fun x => [x]⟩

instance [DecidableEq α] : IsLawfulSingleton α (List α) :=
  ⟨fun x => show (if x ∈ ([] : List α) then [] else [x]) = [x] from if_neg not_false⟩

#print List.union /-
protected def union [DecidableEq α] (l₁ l₂ : List α) : List α :=
  foldr insert l₂ l₁
#align list.union List.union
-/

instance [DecidableEq α] : Union (List α) :=
  ⟨List.union⟩

#print List.inter /-
protected def inter [DecidableEq α] (l₁ l₂ : List α) : List α :=
  filter (· ∈ l₂) l₁
#align list.inter List.inter
-/

instance [DecidableEq α] : Inter (List α) :=
  ⟨List.inter⟩

@[simp]
def repeat (a : α) : ℕ → List α
  | 0 => []
  | succ n => a :: repeat n
#align list.repeat List.repeat

#print List.range.loop /-
def List.range.loop : ℕ → List ℕ → List ℕ
  | 0, l => l
  | succ n, l => range_core n (n :: l)
#align list.range_core List.range.loop
-/

#print List.range /-
def range (n : ℕ) : List ℕ :=
  List.range.loop n []
#align list.range List.range
-/

#print List.iota /-
def iota : ℕ → List ℕ
  | 0 => []
  | succ n => succ n :: iota n
#align list.iota List.iota
-/

#print List.enumFrom /-
def enumFrom : ℕ → List α → List (ℕ × α)
  | n, [] => nil
  | n, x :: xs => (n, x) :: enum_from (n + 1) xs
#align list.enum_from List.enumFrom
-/

#print List.enum /-
def enum : List α → List (ℕ × α) :=
  enumFrom 0
#align list.enum List.enum
-/

#print List.getLast /-
@[simp]
def getLast : ∀ l : List α, l ≠ [] → α
  | [], h => absurd rfl h
  | [a], h => a
  | a :: b :: l, h => last (b :: l) fun h => List.noConfusion h
#align list.last List.getLast
-/

#print List.getLastI /-
def getLastI [Inhabited α] : List α → α
  | [] => Inhabited.default α
  | [a] => a
  | [a, b] => b
  | a :: b :: l => ilast l
#align list.ilast List.getLastI
-/

#print List.dropLast /-
def dropLast : List α → List α
  | [] => []
  | [a] => []
  | a :: l => a :: init l
#align list.init List.dropLast
-/

#print List.intersperse /-
def intersperse (sep : α) : List α → List α
  | [] => []
  | [x] => [x]
  | x :: xs => x :: sep :: intersperse xs
#align list.intersperse List.intersperse
-/

#print List.intercalate /-
def intercalate (sep : List α) (xs : List (List α)) : List α :=
  join (intersperse sep xs)
#align list.intercalate List.intercalate
-/

#print List.bind /-
@[inline]
protected def bind {α : Type u} {β : Type v} (a : List α) (b : α → List β) : List β :=
  join (map b a)
#align list.bind List.bind
-/

#print List.ret /-
@[inline]
protected def ret {α : Type u} (a : α) : List α :=
  [a]
#align list.ret List.ret
-/

#print List.lt /-
protected def lt [LT α] : List α → List α → Prop
  | [], [] => False
  | [], b :: bs => True
  | a :: as, [] => False
  | a :: as, b :: bs => a < b ∨ ¬b < a ∧ lt as bs
#align list.lt List.lt
-/

instance [LT α] : LT (List α) :=
  ⟨List.lt⟩

#print List.hasDecidableLt /-
instance hasDecidableLt [LT α] [h : DecidableRel ((· < ·) : α → α → Prop)] :
    ∀ l₁ l₂ : List α, Decidable (l₁ < l₂)
  | [], [] => isFalse not_false
  | [], b :: bs => isTrue trivial
  | a :: as, [] => isFalse not_false
  | a :: as, b :: bs =>
    match h a b with
    | is_true h₁ => isTrue (Or.inl h₁)
    | is_false h₁ =>
      match h b a with
      | is_true h₂ => isFalse fun h => Or.elim h (fun h => absurd h h₁) fun ⟨h, _⟩ => absurd h₂ h
      | is_false h₂ =>
        match has_decidable_lt as bs with
        | is_true h₃ => isTrue (Or.inr ⟨h₂, h₃⟩)
        | is_false h₃ => isFalse fun h => Or.elim h (fun h => absurd h h₁) fun ⟨_, h⟩ => absurd h h₃
#align list.has_decidable_lt List.hasDecidableLt
-/

@[reducible]
protected def Le [LT α] (a b : List α) : Prop :=
  ¬b < a
#align list.le List.Le

instance [LT α] : LE (List α) :=
  ⟨List.Le⟩

instance hasDecidableLe [LT α] [h : DecidableRel ((· < ·) : α → α → Prop)] :
    ∀ l₁ l₂ : List α, Decidable (l₁ ≤ l₂) := fun a b => Not.decidable
#align list.has_decidable_le List.hasDecidableLe

#print List.le_eq_not_gt /-
theorem le_eq_not_gt [LT α] : ∀ l₁ l₂ : List α, (l₁ ≤ l₂) = ¬l₂ < l₁ := fun l₁ l₂ => rfl
#align list.le_eq_not_gt List.le_eq_not_gt
-/

theorem lt_eq_not_ge [LT α] [DecidableRel ((· < ·) : α → α → Prop)] :
    ∀ l₁ l₂ : List α, (l₁ < l₂) = ¬l₂ ≤ l₁ := fun l₁ l₂ =>
  show (l₁ < l₂) = ¬¬l₁ < l₂ from Eq.subst (propext (not_not_iff (l₁ < l₂))).symm rfl
#align list.lt_eq_not_ge List.lt_eq_not_ge

/-- `is_prefix_of l₁ l₂` returns `tt` iff `l₁` is a prefix of `l₂`. -/
def isPrefixOf [DecidableEq α] : List α → List α → Bool
  | [], _ => true
  | _, [] => false
  | a :: as, b :: bs => decide (a = b) && is_prefix_of as bs
#align list.is_prefix_of List.isPrefixOfₓ

/-- `is_suffix_of l₁ l₂` returns `tt` iff `l₁` is a suffix of `l₂`. -/
def isSuffixOf [DecidableEq α] (l₁ l₂ : List α) : Bool :=
  isPrefixOf l₁.reverse l₂.reverse
#align list.is_suffix_of List.isSuffixOfₓ

end List

namespace BinTree

private def to_list_aux : BinTree α → List α → List α
  | Empty, as => as
  | leaf a, as => a :: as
  | node l r, as => to_list_aux l (to_list_aux r as)
#align bin_tree.to_list_aux bin_tree.to_list_aux

def toList (t : BinTree α) : List α :=
  toListAux t []
#align bin_tree.to_list BinTree.toList

end BinTree


@[eliminator] protected def Nat.recDiag {motive : Nat → Nat → Sort u}
    (zero_zero : motive 0 0)
    (succ_zero : (x : Nat) → motive x 0 → motive (x + 1) 0)
    (zero_succ : (y : Nat) → motive 0 y → motive 0 (y + 1))
    (succ_succ : (x y : Nat) → motive x y → motive (x + 1) (y + 1))
    (x y : Nat) :  motive x y :=
  let rec go : (x y : Nat) → motive x y
    | 0,     0 => zero_zero
    | x+1, 0   => succ_zero x (go x 0)
    | 0,   y+1 => zero_succ y (go 0 y)
    | x+1, y+1 => succ_succ x y (go x y)
  go x y
termination_by go x y => (x, y)

def f (x y : Nat) :=
  match x, y with
  | 0,   0   => 1
  | x+1, 0   => f x 0
  | 0,   y+1 => f 0 y
  | x+1, y+1 => f x y
termination_by f x y => (x, y)

example (x y : Nat) : f x y > 0 := by
  induction x, y with
  | zero_zero => decide
  | succ_zero x ih => simp [f, ih]
  | zero_succ y ih => simp [f, ih]
  | succ_succ x y ih => simp [f, ih]

example (x y : Nat) : f x y > 0 := by
  induction x, y <;> simp [f, *]


/-
Copyright (c) 2015 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro

! This file was ported from Lean 3 source module data.list.prod_sigma
! leanprover-community/mathlib commit be24ec5de6701447e5df5ca75400ffee19d65659
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.List.BigOperators.Basic

/-!
# Lists in product and sigma types

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

This file proves basic properties of `list.product` and `list.sigma`, which are list constructions
living in `prod` and `sigma` types respectively. Their definitions can be found in
[`data.list.defs`](./defs). Beware, this is not about `list.prod`, the multiplicative product.
-/

variable {α β : Type _}

namespace List

/-! ### product -/

#print List.nil_product /-
@[simp]
theorem nil_product (l : List β) : product (@nil α) l = [] :=
  rfl
#align list.nil_product List.nil_product
-/

/- warning: list.product_cons -> List.product_cons is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (a : α) (l₁ : List.{u1} α) (l₂ : List.{u2} β), Eq.{succ (max u1 u2)} (List.{max u1 u2} (Prod.{u1, u2} α β)) (List.product.{u1, u2} α β (List.cons.{u1} α a l₁) l₂) (Append.append.{max u1 u2} (List.{max u1 u2} (Prod.{u1, u2} α β)) (List.hasAppend.{max u1 u2} (Prod.{u1, u2} α β)) (List.map.{u2, max u1 u2} β (Prod.{u1, u2} α β) (fun (b : β) => Prod.mk.{u1, u2} α β a b) l₂) (List.product.{u1, u2} α β l₁ l₂))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (a : α) (l₁ : List.{u2} α) (l₂ : List.{u1} β), Eq.{max (succ u2) (succ u1)} (List.{max u1 u2} (Prod.{u2, u1} α β)) (List.product.{u2, u1} α β (List.cons.{u2} α a l₁) l₂) (HAppend.hAppend.{max u2 u1, max u2 u1, max u2 u1} (List.{max u1 u2} (Prod.{u2, u1} α β)) (List.{max u1 u2} (Prod.{u2, u1} α β)) (List.{max u1 u2} (Prod.{u2, u1} α β)) (instHAppend.{max u2 u1} (List.{max u1 u2} (Prod.{u2, u1} α β)) (List.instAppendList.{max u2 u1} (Prod.{u2, u1} α β))) (List.map.{u1, max u1 u2} β (Prod.{u2, u1} α β) (fun (b : β) => Prod.mk.{u2, u1} α β a b) l₂) (List.product.{u2, u1} α β l₁ l₂))
Case conversion may be inaccurate. Consider using '#align list.product_cons List.product_consₓ'. -/
@[simp]
theorem product_cons (a : α) (l₁ : List α) (l₂ : List β) :
    product (a :: l₁) l₂ = map (fun b => (a, b)) l₂ ++ product l₁ l₂ :=
  rfl
#align list.product_cons List.product_cons

/- warning: list.product_nil -> List.product_nil is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (l : List.{u1} α), Eq.{succ (max u1 u2)} (List.{max u1 u2} (Prod.{u1, u2} α β)) (List.product.{u1, u2} α β l (List.nil.{u2} β)) (List.nil.{max u1 u2} (Prod.{u1, u2} α β))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (l : List.{u2} α), Eq.{max (succ u2) (succ u1)} (List.{max u1 u2} (Prod.{u2, u1} α β)) (List.product.{u2, u1} α β l (List.nil.{u1} β)) (List.nil.{max u2 u1} (Prod.{u2, u1} α β))
Case conversion may be inaccurate. Consider using '#align list.product_nil List.product_nilₓ'. -/
@[simp]
theorem product_nil : ∀ l : List α, product l (@nil β) = []
  | [] => rfl
  | a :: l => by rw [product_cons, product_nil] <;> rfl
#align list.product_nil List.product_nil

/- warning: list.mem_product -> List.mem_product is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {l₁ : List.{u1} α} {l₂ : List.{u2} β} {a : α} {b : β}, Iff (Membership.Mem.{max u1 u2, max u1 u2} (Prod.{u1, u2} α β) (List.{max u1 u2} (Prod.{u1, u2} α β)) (List.hasMem.{max u1 u2} (Prod.{u1, u2} α β)) (Prod.mk.{u1, u2} α β a b) (List.product.{u1, u2} α β l₁ l₂)) (And (Membership.Mem.{u1, u1} α (List.{u1} α) (List.hasMem.{u1} α) a l₁) (Membership.Mem.{u2, u2} β (List.{u2} β) (List.hasMem.{u2} β) b l₂))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {l₁ : List.{u2} α} {l₂ : List.{u1} β} {a : α} {b : β}, Iff (Membership.mem.{max u1 u2, max u1 u2} (Prod.{u2, u1} α β) (List.{max u1 u2} (Prod.{u2, u1} α β)) (List.instMembershipList.{max u2 u1} (Prod.{u2, u1} α β)) (Prod.mk.{u2, u1} α β a b) (List.product.{u2, u1} α β l₁ l₂)) (And (Membership.mem.{u2, u2} α (List.{u2} α) (List.instMembershipList.{u2} α) a l₁) (Membership.mem.{u1, u1} β (List.{u1} β) (List.instMembershipList.{u1} β) b l₂))
Case conversion may be inaccurate. Consider using '#align list.mem_product List.mem_productₓ'. -/
@[simp]
theorem mem_product {l₁ : List α} {l₂ : List β} {a : α} {b : β} :
    (a, b) ∈ product l₁ l₂ ↔ a ∈ l₁ ∧ b ∈ l₂ := by
  simp only [product, mem_bind, mem_map, Prod.ext_iff, exists_prop, and_left_comm, exists_and_left,
    exists_eq_left, exists_eq_right]
#align list.mem_product List.mem_product

/- warning: list.length_product -> List.length_product is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (l₁ : List.{u1} α) (l₂ : List.{u2} β), Eq.{1} Nat (List.length.{max u1 u2} (Prod.{u1, u2} α β) (List.product.{u1, u2} α β l₁ l₂)) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (List.length.{u1} α l₁) (List.length.{u2} β l₂))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (l₁ : List.{u2} α) (l₂ : List.{u1} β), Eq.{1} Nat (List.length.{max u1 u2} (Prod.{u2, u1} α β) (List.product.{u2, u1} α β l₁ l₂)) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (List.length.{u2} α l₁) (List.length.{u1} β l₂))
Case conversion may be inaccurate. Consider using '#align list.length_product List.length_productₓ'. -/
theorem length_product (l₁ : List α) (l₂ : List β) :
    length (product l₁ l₂) = length l₁ * length l₂ := by
  induction' l₁ with x l₁ IH <;> [exact (MulZeroClass.zero_mul _).symm,
    simp only [length, product_cons, length_append, IH, right_distrib, one_mul, length_map,
      add_comm]]
#align list.length_product List.length_product

/-! ### sigma -/

variable {σ : α → Type _}

#print List.nil_sigma /-
@[simp]
theorem nil_sigma (l : ∀ a, List (σ a)) : (@nil α).Sigma l = [] :=
  rfl
#align list.nil_sigma List.nil_sigma
-/

/- warning: list.sigma_cons -> List.sigma_cons is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : α -> Type.{u2}} (a : α) (l₁ : List.{u1} α) (l₂ : forall (a : α), List.{u2} (σ a)), Eq.{succ (max u1 u2)} (List.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a))) (List.sigma.{u1, u2} α (fun (a : α) => σ a) (List.cons.{u1} α a l₁) l₂) (Append.append.{max u1 u2} (List.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a))) (List.hasAppend.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a))) (List.map.{u2, max u1 u2} (σ a) (Sigma.{u1, u2} α (fun (a : α) => σ a)) (Sigma.mk.{u1, u2} α (fun (a : α) => σ a) a) (l₂ a)) (List.sigma.{u1, u2} α (fun (a : α) => σ a) l₁ l₂))
but is expected to have type
  forall {α : Type.{u2}} {σ : α -> Type.{u1}} (a : α) (l₁ : List.{u2} α) (l₂ : forall (a : α), List.{u1} (σ a)), Eq.{max (succ u2) (succ u1)} (List.{max u1 u2} (Sigma.{u2, u1} α (fun (a : α) => σ a))) (List.sigma.{u2, u1} α (fun (a : α) => σ a) (List.cons.{u2} α a l₁) l₂) (HAppend.hAppend.{max u2 u1, max u2 u1, max u2 u1} (List.{max u2 u1} (Sigma.{u2, u1} α σ)) (List.{max u1 u2} (Sigma.{u2, u1} α (fun (a : α) => σ a))) (List.{max u2 u1} (Sigma.{u2, u1} α σ)) (instHAppend.{max u2 u1} (List.{max u2 u1} (Sigma.{u2, u1} α σ)) (List.instAppendList.{max u2 u1} (Sigma.{u2, u1} α σ))) (List.map.{u1, max u2 u1} (σ a) (Sigma.{u2, u1} α σ) (Sigma.mk.{u2, u1} α σ a) (l₂ a)) (List.sigma.{u2, u1} α (fun (a : α) => σ a) l₁ l₂))
Case conversion may be inaccurate. Consider using '#align list.sigma_cons List.sigma_consₓ'. -/
@[simp]
theorem sigma_cons (a : α) (l₁ : List α) (l₂ : ∀ a, List (σ a)) :
    (a :: l₁).Sigma l₂ = map (Sigma.mk a) (l₂ a) ++ l₁.Sigma l₂ :=
  rfl
#align list.sigma_cons List.sigma_cons

/- warning: list.sigma_nil -> List.sigma_nil is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : α -> Type.{u2}} (l : List.{u1} α), Eq.{succ (max u1 u2)} (List.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a))) (List.sigma.{u1, u2} α (fun (a : α) => σ a) l (fun (a : α) => List.nil.{u2} (σ a))) (List.nil.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a)))
but is expected to have type
  forall {α : Type.{u2}} {σ : α -> Type.{u1}} (l : List.{u2} α), Eq.{max (succ u2) (succ u1)} (List.{max u1 u2} (Sigma.{u2, u1} α (fun (a : α) => σ a))) (List.sigma.{u2, u1} α (fun (a : α) => σ a) l (fun (a : α) => List.nil.{u1} (σ a))) (List.nil.{max u2 u1} (Sigma.{u2, u1} α (fun (a : α) => σ a)))
Case conversion may be inaccurate. Consider using '#align list.sigma_nil List.sigma_nilₓ'. -/
@[simp]
theorem sigma_nil : ∀ l : List α, (l.Sigma fun a => @nil (σ a)) = []
  | [] => rfl
  | a :: l => by rw [sigma_cons, sigma_nil] <;> rfl
#align list.sigma_nil List.sigma_nil

/- warning: list.mem_sigma -> List.mem_sigma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : α -> Type.{u2}} {l₁ : List.{u1} α} {l₂ : forall (a : α), List.{u2} (σ a)} {a : α} {b : σ a}, Iff (Membership.Mem.{max u1 u2, max u1 u2} (Sigma.{u1, u2} α (fun {a : α} => σ a)) (List.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a))) (List.hasMem.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a))) (Sigma.mk.{u1, u2} α (fun {a : α} => σ a) a b) (List.sigma.{u1, u2} α (fun (a : α) => σ a) l₁ l₂)) (And (Membership.Mem.{u1, u1} α (List.{u1} α) (List.hasMem.{u1} α) a l₁) (Membership.Mem.{u2, u2} (σ a) (List.{u2} (σ a)) (List.hasMem.{u2} (σ a)) b (l₂ a)))
but is expected to have type
  forall {α : Type.{u2}} {σ : α -> Type.{u1}} {l₁ : List.{u2} α} {l₂ : forall (a : α), List.{u1} (σ a)} {a : α} {b : σ a}, Iff (Membership.mem.{max u1 u2, max u2 u1} (Sigma.{u2, u1} α σ) (List.{max u1 u2} (Sigma.{u2, u1} α (fun (a : α) => σ a))) (List.instMembershipList.{max u2 u1} (Sigma.{u2, u1} α (fun (a : α) => σ a))) (Sigma.mk.{u2, u1} α σ a b) (List.sigma.{u2, u1} α (fun (a : α) => σ a) l₁ l₂)) (And (Membership.mem.{u2, u2} α (List.{u2} α) (List.instMembershipList.{u2} α) a l₁) (Membership.mem.{u1, u1} (σ a) (List.{u1} (σ a)) (List.instMembershipList.{u1} (σ a)) b (l₂ a)))
Case conversion may be inaccurate. Consider using '#align list.mem_sigma List.mem_sigmaₓ'. -/
@[simp]
theorem mem_sigma {l₁ : List α} {l₂ : ∀ a, List (σ a)} {a : α} {b : σ a} :
    Sigma.mk a b ∈ l₁.Sigma l₂ ↔ a ∈ l₁ ∧ b ∈ l₂ a := by
  simp only [List.sigma, mem_bind, mem_map, exists_prop, exists_and_left, and_left_comm,
    exists_eq_left, heq_iff_eq, exists_eq_right]
#align list.mem_sigma List.mem_sigma

/- warning: list.length_sigma -> List.length_sigma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : α -> Type.{u2}} (l₁ : List.{u1} α) (l₂ : forall (a : α), List.{u2} (σ a)), Eq.{1} Nat (List.length.{max u1 u2} (Sigma.{u1, u2} α (fun (a : α) => σ a)) (List.sigma.{u1, u2} α (fun (a : α) => σ a) l₁ l₂)) (List.sum.{0} Nat Nat.hasAdd Nat.hasZero (List.map.{u1, 0} α Nat (fun (a : α) => List.length.{u2} (σ a) (l₂ a)) l₁))
but is expected to have type
  forall {α : Type.{u2}} {σ : α -> Type.{u1}} (l₁ : List.{u2} α) (l₂ : forall (a : α), List.{u1} (σ a)), Eq.{1} Nat (List.length.{max u2 u1} (Sigma.{u2, u1} α (fun (a : α) => σ a)) (List.sigma.{u2, u1} α (fun (a : α) => σ a) l₁ l₂)) (List.sum.{0} Nat instAddNat (LinearOrderedCommMonoidWithZero.toZero.{0} Nat Nat.linearOrderedCommMonoidWithZero) (List.map.{u2, 0} α Nat (fun (a : α) => List.length.{u1} (σ a) (l₂ a)) l₁))
Case conversion may be inaccurate. Consider using '#align list.length_sigma List.length_sigmaₓ'. -/
theorem length_sigma (l₁ : List α) (l₂ : ∀ a, List (σ a)) :
    length (l₁.Sigma l₂) = (l₁.map fun a => length (l₂ a)).Sum := by
  induction' l₁ with x l₁ IH <;> [rfl,
    simp only [map, sigma_cons, length_append, length_map, IH, sum_cons]]
#align list.length_sigma List.length_sigma

end List


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/
import geometry.manifold.algebra.lie_group

/-!
# Smooth structures

In this file we define smooth structures that build on Lie groups. We prefer using the term smooth
instead of Lie mainly because Lie ring has currently another use in mathematics.
-/

open_locale manifold

section smooth_ring
variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{H : Type*} [topological_space H]
{E : Type*} [normed_group E] [normed_space 𝕜 E]

set_option old_structure_cmd true
set_option default_priority 100 -- see Note [default priority]

/-- A smooth semiring is a semiring where addition and multiplication are smooth. -/
-- See note [Design choices about smooth algebraic structures]
class smooth_semiring (I : model_with_corners 𝕜 E H)
  (R : Type*) [semiring R] [topological_space R] [charted_space H R]
  extends has_smooth_add I R, has_smooth_mul I R : Prop

/-- A smooth ring is a ring where the ring operations are smooth. -/
-- See note [Design choices about smooth algebraic structures]
class smooth_ring (I : model_with_corners 𝕜 E H)
  (R : Type*) [ring R] [topological_space R] [charted_space H R]
  extends lie_add_group I R, has_smooth_mul I R : Prop

instance smooth_ring.to_smooth_semiring {I : model_with_corners 𝕜 E H}
  {R : Type*} [ring R] [topological_space R]
  [charted_space H R] [t : smooth_ring I R] :
  smooth_semiring I R := { ..t }

end smooth_ring

instance field_smooth_ring {𝕜 : Type*} [nondiscrete_normed_field 𝕜] :
  smooth_ring 𝓘(𝕜) 𝕜 :=
{ smooth_mul :=
  begin
    rw smooth_iff,
    refine ⟨continuous_mul, λ x y, _⟩,
    simp only [prod.mk.eta] with mfld_simps,
    rw times_cont_diff_on_univ,
    exact times_cont_diff_mul,
  end,
  ..normed_space_lie_add_group }

variables {𝕜 R E H : Type*} [topological_space R] [topological_space H]
  [nondiscrete_normed_field 𝕜] [normed_group E] [normed_space 𝕜 E]
  [charted_space H R] (I : model_with_corners 𝕜 E H)

/-- A smooth semiring is a topological semiring. This is not an instance for technical reasons,
see note [Design choices about smooth algebraic structures]. -/
lemma topological_semiring_of_smooth [semiring R] [smooth_semiring I R] :
  topological_semiring R :=
{ .. has_continuous_mul_of_smooth I, .. has_continuous_add_of_smooth I }

/-- A smooth ring is a topological ring. This is not an instance for technical reasons,
see note [Design choices about smooth algebraic structures]. -/
lemma topological_ring_of_smooth [ring R] [smooth_ring I R] :
  topological_ring R :=
{ .. has_continuous_mul_of_smooth I, .. topological_add_group_of_lie_add_group I }


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Amelia Livingston

! This file was ported from Lean 3 source module category_theory.abelian.homology
! leanprover-community/mathlib commit 956af7c76589f444f2e1313911bad16366ea476d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Homology.Additive
import Mathbin.CategoryTheory.Abelian.Pseudoelements
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Kernels
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Images

/-!

The object `homology f g w`, where `w : f ≫ g = 0`, can be identified with either a
cokernel or a kernel. The isomorphism with a cokernel is `homology_iso_cokernel_lift`, which
was obtained elsewhere. In the case of an abelian category, this file shows the isomorphism
with a kernel as well.

We use these isomorphisms to obtain the analogous api for `homology`:
- `homology.ι` is the map from `homology f g w` into the cokernel of `f`.
- `homology.π'` is the map from `kernel g` to `homology f g w`.
- `homology.desc'` constructs a morphism from `homology f g w`, when it is viewed as a cokernel.
- `homology.lift` constructs a morphism to `homology f g w`, when it is viewed as a kernel.
- Various small lemmas are proved as well, mimicking the API for (co)kernels.
With these definitions and lemmas, the isomorphisms between homology and a (co)kernel need not
be used directly.
-/

open CategoryTheory.Limits

open CategoryTheory

noncomputable section

universe v u

variable {A : Type u} [Category.{v} A] [Abelian A]

variable {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0)

namespace CategoryTheory.Abelian

/-- The cokernel of `kernel.lift g f w`. This is isomorphic to `homology f g w`.
  See `homology_iso_cokernel_lift`. -/
abbrev homologyC : A :=
  cokernel (kernel.lift g f w)
#align category_theory.abelian.homology_c CategoryTheory.Abelian.homologyC

/-- The kernel of `cokernel.desc f g w`. This is isomorphic to `homology f g w`.
  See `homology_iso_kernel_desc`. -/
abbrev homologyK : A :=
  kernel (cokernel.desc f g w)
#align category_theory.abelian.homology_k CategoryTheory.Abelian.homologyK

/-- The canonical map from `homology_c` to `homology_k`.
  This is an isomorphism, and it is used in obtaining the API for `homology f g w`
  in the bottom of this file. -/
abbrev homologyCToK : homologyC f g w ⟶ homologyK f g w :=
  cokernel.desc _ (kernel.lift _ (kernel.ι _ ≫ cokernel.π _) (by simp))
    (by
      apply limits.equalizer.hom_ext
      simp)
#align category_theory.abelian.homology_c_to_k CategoryTheory.Abelian.homologyCToK

attribute [local instance] pseudoelement.hom_to_fun pseudoelement.has_zero

instance : Mono (homologyCToK f g w) :=
  by
  apply pseudoelement.mono_of_zero_of_map_zero
  intro a ha
  obtain ⟨a, rfl⟩ := pseudoelement.pseudo_surjective_of_epi (cokernel.π (kernel.lift g f w)) a
  apply_fun kernel.ι (cokernel.desc f g w)  at ha
  simp only [← pseudoelement.comp_apply, cokernel.π_desc, kernel.lift_ι,
    pseudoelement.apply_zero] at ha
  simp only [pseudoelement.comp_apply] at ha
  obtain ⟨b, hb⟩ : ∃ b, f b = _ := (pseudoelement.pseudo_exact_of_exact (exact_cokernel f)).2 _ ha
  rsuffices ⟨c, rfl⟩ : ∃ c, kernel.lift g f w c = a
  · simp [← pseudoelement.comp_apply]
  use b
  apply_fun kernel.ι g
  swap; · apply pseudoelement.pseudo_injective_of_mono
  simpa [← pseudoelement.comp_apply]

instance : Epi (homologyCToK f g w) :=
  by
  apply pseudoelement.epi_of_pseudo_surjective
  intro a
  let b := kernel.ι (cokernel.desc f g w) a
  obtain ⟨c, hc⟩ : ∃ c, cokernel.π f c = b
  apply pseudoelement.pseudo_surjective_of_epi (cokernel.π f)
  have : g c = 0 := by
    dsimp [b] at hc
    rw [show g = cokernel.π f ≫ cokernel.desc f g w by simp, pseudoelement.comp_apply, hc]
    simp [← pseudoelement.comp_apply]
  obtain ⟨d, hd⟩ : ∃ d, kernel.ι g d = c := by
    apply (pseudoelement.pseudo_exact_of_exact exact_kernel_ι).2 _ this
  use cokernel.π (kernel.lift g f w) d
  apply_fun kernel.ι (cokernel.desc f g w)
  swap
  · apply pseudoelement.pseudo_injective_of_mono
  simp only [← pseudoelement.comp_apply, cokernel.π_desc, kernel.lift_ι]
  simp only [pseudoelement.comp_apply, hd, hc]

instance (w : f ≫ g = 0) : IsIso (homologyCToK f g w) :=
  isIso_of_mono_of_epi _

end CategoryTheory.Abelian

/-- The homology associated to `f` and `g` is isomorphic to a kernel. -/
def homologyIsoKernelDesc : homology f g w ≅ kernel (cokernel.desc f g w) :=
  homologyIsoCokernelLift _ _ _ ≪≫ asIso (CategoryTheory.Abelian.homologyCToK _ _ _)
#align homology_iso_kernel_desc homologyIsoKernelDesc

namespace homology

-- `homology.π` is taken
/-- The canonical map from the kernel of `g` to the homology of `f` and `g`. -/
def π' : kernel g ⟶ homology f g w :=
  cokernel.π _ ≫ (homologyIsoCokernelLift _ _ _).inv
#align homology.π' homology.π'

/-- The canonical map from the homology of `f` and `g` to the cokernel of `f`. -/
def ι : homology f g w ⟶ cokernel f :=
  (homologyIsoKernelDesc _ _ _).Hom ≫ kernel.ι _
#align homology.ι homology.ι

/-- Obtain a morphism from the homology, given a morphism from the kernel. -/
def desc' {W : A} (e : kernel g ⟶ W) (he : kernel.lift g f w ≫ e = 0) : homology f g w ⟶ W :=
  (homologyIsoCokernelLift _ _ _).Hom ≫ cokernel.desc _ e he
#align homology.desc' homology.desc'

/-- Obtain a moprhism to the homology, given a morphism to the kernel. -/
def lift {W : A} (e : W ⟶ cokernel f) (he : e ≫ cokernel.desc f g w = 0) : W ⟶ homology f g w :=
  kernel.lift _ e he ≫ (homologyIsoKernelDesc _ _ _).inv
#align homology.lift homology.lift

@[simp, reassoc.1]
theorem π'_desc' {W : A} (e : kernel g ⟶ W) (he : kernel.lift g f w ≫ e = 0) :
    π' f g w ≫ desc' f g w e he = e := by
  dsimp [π', desc']
  simp
#align homology.π'_desc' homology.π'_desc'

@[simp, reassoc.1]
theorem lift_ι {W : A} (e : W ⟶ cokernel f) (he : e ≫ cokernel.desc f g w = 0) :
    lift f g w e he ≫ ι _ _ _ = e := by
  dsimp [ι, lift]
  simp
#align homology.lift_ι homology.lift_ι

@[simp, reassoc.1]
theorem condition_π' : kernel.lift g f w ≫ π' f g w = 0 :=
  by
  dsimp [π']
  simp
#align homology.condition_π' homology.condition_π'

@[simp, reassoc.1]
theorem condition_ι : ι f g w ≫ cokernel.desc f g w = 0 :=
  by
  dsimp [ι]
  simp
#align homology.condition_ι homology.condition_ι

@[ext]
theorem hom_from_ext {W : A} (a b : homology f g w ⟶ W) (h : π' f g w ≫ a = π' f g w ≫ b) : a = b :=
  by
  dsimp [π'] at h
  apply_fun fun e => (homologyIsoCokernelLift f g w).inv ≫ e
  swap
  · intro i j hh
    apply_fun fun e => (homologyIsoCokernelLift f g w).Hom ≫ e  at hh
    simpa using hh
  simp only [category.assoc] at h
  exact coequalizer.hom_ext h
#align homology.hom_from_ext homology.hom_from_ext

@[ext]
theorem hom_to_ext {W : A} (a b : W ⟶ homology f g w) (h : a ≫ ι f g w = b ≫ ι f g w) : a = b :=
  by
  dsimp [ι] at h
  apply_fun fun e => e ≫ (homologyIsoKernelDesc f g w).Hom
  swap
  · intro i j hh
    apply_fun fun e => e ≫ (homologyIsoKernelDesc f g w).inv  at hh
    simpa using hh
  simp only [← category.assoc] at h
  exact equalizer.hom_ext h
#align homology.hom_to_ext homology.hom_to_ext

@[simp, reassoc.1]
theorem π'_ι : π' f g w ≫ ι f g w = kernel.ι _ ≫ cokernel.π _ :=
  by
  dsimp [π', ι, homologyIsoKernelDesc]
  simp
#align homology.π'_ι homology.π'_ι

@[simp, reassoc.1]
theorem π'_eq_π : (kernelSubobjectIso _).Hom ≫ π' f g w = π _ _ _ :=
  by
  dsimp [π', homologyIsoCokernelLift]
  simp only [← category.assoc]
  rw [iso.comp_inv_eq]
  dsimp [π, homologyIsoCokernelImageToKernel']
  simp
#align homology.π'_eq_π homology.π'_eq_π

section

variable {X' Y' Z' : A} (f' : X' ⟶ Y') (g' : Y' ⟶ Z') (w' : f' ≫ g' = 0)

@[simp, reassoc.1]
theorem π'_map (α β h) :
    π' _ _ _ ≫ map w w' α β h = kernel.map _ _ α.right β.right (by simp [h, β.w.symm]) ≫ π' _ _ _ :=
  by
  apply_fun fun e => (kernel_subobject_iso _).Hom ≫ e
  swap
  · intro i j hh
    apply_fun fun e => (kernel_subobject_iso _).inv ≫ e  at hh
    simpa using hh
  dsimp [map]
  simp only [π'_eq_π_assoc]
  dsimp [π]
  simp only [cokernel.π_desc]
  rw [← iso.inv_comp_eq, ← category.assoc]
  have :
    (limits.kernel_subobject_iso g).inv ≫ limits.kernel_subobject_map β =
      kernel.map _ _ β.left β.right β.w.symm ≫ (kernel_subobject_iso _).inv :=
    by
    rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv]
    ext
    dsimp
    simp
  rw [this]
  simp only [category.assoc]
  dsimp [π', homologyIsoCokernelLift]
  simp only [cokernel_iso_of_eq_inv_comp_desc, cokernel.π_desc_assoc]
  congr 1
  · congr
    exact h.symm
  · rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv]
    dsimp [homologyIsoCokernelImageToKernel']
    simp
#align homology.π'_map homology.π'_map

theorem map_eq_desc'_lift_left (α β h) :
    map w w' α β h =
      homology.desc' _ _ _ (homology.lift _ _ _ (kernel.ι _ ≫ β.left ≫ cokernel.π _) (by simp))
        (by
          ext
          simp only [← h, category.assoc, zero_comp, lift_ι, kernel.lift_ι_assoc]
          erw [← reassoc_of α.w]
          simp) :=
  by
  apply homology.hom_from_ext
  simp only [π'_map, π'_desc']
  dsimp [π', lift]
  rw [iso.eq_comp_inv]
  dsimp [homologyIsoKernelDesc]
  ext
  simp [h]
#align homology.map_eq_desc'_lift_left homology.map_eq_desc'_lift_left

theorem map_eq_lift_desc'_left (α β h) :
    map w w' α β h =
      homology.lift _ _ _
        (homology.desc' _ _ _ (kernel.ι _ ≫ β.left ≫ cokernel.π _)
          (by
            simp only [kernel.lift_ι_assoc, ← h]
            erw [← reassoc_of α.w]
            simp))
        (by
          ext
          simp) :=
  by
  rw [map_eq_desc'_lift_left]
  ext
  simp
#align homology.map_eq_lift_desc'_left homology.map_eq_lift_desc'_left

theorem map_eq_desc'_lift_right (α β h) :
    map w w' α β h =
      homology.desc' _ _ _ (homology.lift _ _ _ (kernel.ι _ ≫ α.right ≫ cokernel.π _) (by simp [h]))
        (by
          ext
          simp only [category.assoc, zero_comp, lift_ι, kernel.lift_ι_assoc]
          erw [← reassoc_of α.w]
          simp) :=
  by
  rw [map_eq_desc'_lift_left]
  ext
  simp [h]
#align homology.map_eq_desc'_lift_right homology.map_eq_desc'_lift_right

theorem map_eq_lift_desc'_right (α β h) :
    map w w' α β h =
      homology.lift _ _ _
        (homology.desc' _ _ _ (kernel.ι _ ≫ α.right ≫ cokernel.π _)
          (by
            simp only [kernel.lift_ι_assoc]
            erw [← reassoc_of α.w]
            simp))
        (by
          ext
          simp [h]) :=
  by
  rw [map_eq_desc'_lift_right]
  ext
  simp
#align homology.map_eq_lift_desc'_right homology.map_eq_lift_desc'_right

@[simp, reassoc.1]
theorem map_ι (α β h) :
    map w w' α β h ≫ ι f' g' w' =
      ι f g w ≫ cokernel.map f f' α.left β.left (by simp [h, β.w.symm]) :=
  by
  rw [map_eq_lift_desc'_left, lift_ι]
  ext
  simp only [← category.assoc]
  rw [π'_ι, π'_desc', category.assoc, category.assoc, cokernel.π_desc]
#align homology.map_ι homology.map_ι

end

end homology

namespace CategoryTheory.Functor

variable {ι : Type _} {c : ComplexShape ι} {B : Type _} [Category B] [Abelian B] (F : A ⥤ B)
  [Functor.Additive F] [PreservesFiniteLimits F] [PreservesFiniteColimits F]

/-- When `F` is an exact additive functor, `F(Hᵢ(X)) ≅ Hᵢ(F(X))` for `X` a complex. -/
noncomputable def homologyIso (C : HomologicalComplex A c) (j : ι) :
    F.obj (C.homology j) ≅ ((F.mapHomologicalComplex _).obj C).homology j :=
  (PreservesCokernel.iso _ _).trans
    (cokernel.mapIso _ _
      ((F.mapIso (imageSubobjectIso _)).trans
        ((PreservesImage.iso _ _).symm.trans (imageSubobjectIso _).symm))
      ((F.mapIso (kernelSubobjectIso _)).trans
        ((PreservesKernel.iso _ _).trans (kernelSubobjectIso _).symm))
      (by
        dsimp
        ext
        simp only [category.assoc, imageToKernel_arrow]
        erw [kernel_subobject_arrow', kernel_comparison_comp_ι, image_subobject_arrow']
        simp [← F.map_comp]))
#align category_theory.functor.homology_iso CategoryTheory.Functor.homologyIso

/-- If `F` is an exact additive functor, then `F` commutes with `Hᵢ` (up to natural isomorphism). -/
noncomputable def homologyFunctorIso (i : ι) :
    homologyFunctor A c i ⋙ F ≅ F.mapHomologicalComplex c ⋙ homologyFunctor B c i :=
  NatIso.ofComponents (fun X => homologyIso F X i)
    (by
      intro X Y f
      dsimp
      rw [← iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv]
      refine' coequalizer.hom_ext _
      dsimp [homology_iso]
      simp only [homology.map, ← category.assoc, cokernel.π_desc]
      simp only [category.assoc, cokernel_comparison_map_desc, cokernel.π_desc,
        π_comp_cokernel_comparison, ← F.map_comp]
      erw [← kernel_subobject_iso_comp_kernel_map_assoc]
      simp only [HomologicalComplex.Hom.sqFrom_right, HomologicalComplex.Hom.sqFrom_left,
        F.map_homological_complex_map_f, F.map_comp]
      dsimp only [HomologicalComplex.dFrom, HomologicalComplex.Hom.next]
      dsimp
      rw [kernel_map_comp_preserves_kernel_iso_inv_assoc, ← F.map_comp_assoc, ←
        kernel_map_comp_kernel_subobject_iso_inv]
      any_goals simp)
#align category_theory.functor.homology_functor_iso CategoryTheory.Functor.homologyFunctorIso

end CategoryTheory.Functor


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

! This file was ported from Lean 3 source module topology.sheaves.local_predicate
! leanprover-community/mathlib commit b8fb47c4f31648a8273c864e75f06c7b759e468c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.SheafOfFunctions
import Mathbin.Topology.Sheaves.Stalks
import Mathbin.Topology.LocalHomeomorph
import Mathbin.Topology.Sheaves.SheafCondition.UniqueGluing

/-!
# Functions satisfying a local predicate form a sheaf.

At this stage, in `topology/sheaves/sheaf_of_functions.lean`
we've proved that not-necessarily-continuous functions from a topological space
into some type (or type family) form a sheaf.

Why do the continuous functions form a sheaf?
The point is just that continuity is a local condition,
so one can use the lifting condition for functions to provide a candidate lift,
then verify that the lift is actually continuous by using the factorisation condition for the lift
(which guarantees that on each open set it agrees with the functions being lifted,
which were assumed to be continuous).

This file abstracts this argument to work for
any collection of dependent functions on a topological space
satisfying a "local predicate".

As an application, we check that continuity is a local predicate in this sense, and provide
* `Top.sheaf_to_Top`: continuous functions into a topological space form a sheaf

A sheaf constructed in this way has a natural map `stalk_to_fiber` from the stalks
to the types in the ambient type family.

We give conditions sufficient to show that this map is injective and/or surjective.
-/

universe v

noncomputable section

variable {X : TopCat.{v}}

variable (T : X → Type v)

open TopologicalSpace

open Opposite

open CategoryTheory

open CategoryTheory.Limits

open CategoryTheory.Limits.Types

namespace TopCat

/-- Given a topological space `X : Top` and a type family `T : X → Type`,
a `P : prelocal_predicate T` consists of:
* a family of predicates `P.pred`, one for each `U : opens X`, of the form `(Π x : U, T x) → Prop`
* a proof that if `f : Π x : V, T x` satisfies the predicate on `V : opens X`, then
  the restriction of `f` to any open subset `U` also satisfies the predicate.
-/
structure PrelocalPredicate where
  pred : ∀ {U : Opens X}, (∀ x : U, T x) → Prop
  res : ∀ {U V : Opens X} (i : U ⟶ V) (f : ∀ x : V, T x) (h : pred f), pred fun x : U => f (i x)
#align Top.prelocal_predicate TopCat.PrelocalPredicate

variable (X)

/-- Continuity is a "prelocal" predicate on functions to a fixed topological space `T`.
-/
@[simps]
def continuousPrelocal (T : TopCat.{v}) : PrelocalPredicate fun x : X => T
    where
  pred U f := Continuous f
  res U V i f h := Continuous.comp h (Opens.openEmbedding_of_le i.le).Continuous
#align Top.continuous_prelocal TopCat.continuousPrelocal

/-- Satisfying the inhabited linter. -/
instance inhabitedPrelocalPredicate (T : TopCat.{v}) :
    Inhabited (PrelocalPredicate fun x : X => T) :=
  ⟨continuousPrelocal X T⟩
#align Top.inhabited_prelocal_predicate TopCat.inhabitedPrelocalPredicate

variable {X}

/-- Given a topological space `X : Top` and a type family `T : X → Type`,
a `P : local_predicate T` consists of:
* a family of predicates `P.pred`, one for each `U : opens X`, of the form `(Π x : U, T x) → Prop`
* a proof that if `f : Π x : V, T x` satisfies the predicate on `V : opens X`, then
  the restriction of `f` to any open subset `U` also satisfies the predicate, and
* a proof that given some `f : Π x : U, T x`,
  if for every `x : U` we can find an open set `x ∈ V ≤ U`
  so that the restriction of `f` to `V` satisfies the predicate,
  then `f` itself satisfies the predicate.
-/
structure LocalPredicate extends PrelocalPredicate T where
  locality :
    ∀ {U : Opens X} (f : ∀ x : U, T x)
      (w : ∀ x : U, ∃ (V : Opens X)(m : x.1 ∈ V)(i : V ⟶ U), pred fun x : V => f (i x : U)), pred f
#align Top.local_predicate TopCat.LocalPredicate

variable (X)

/-- Continuity is a "local" predicate on functions to a fixed topological space `T`.
-/
def continuousLocal (T : TopCat.{v}) : LocalPredicate fun x : X => T :=
  { continuousPrelocal X T with
    locality := fun U f w => by
      apply continuous_iff_continuousAt.2
      intro x
      specialize w x
      rcases w with ⟨V, m, i, w⟩
      dsimp at w
      rw [continuous_iff_continuousAt] at w
      specialize w ⟨x, m⟩
      simpa using (opens.open_embedding_of_le i.le).continuousAt_iff.1 w }
#align Top.continuous_local TopCat.continuousLocal

/-- Satisfying the inhabited linter. -/
instance inhabitedLocalPredicate (T : TopCat.{v}) : Inhabited (LocalPredicate _) :=
  ⟨continuousLocal X T⟩
#align Top.inhabited_local_predicate TopCat.inhabitedLocalPredicate

variable {X T}

/-- Given a `P : prelocal_predicate`, we can always construct a `local_predicate`
by asking that the condition from `P` holds locally near every point.
-/
def PrelocalPredicate.sheafify {T : X → Type v} (P : PrelocalPredicate T) : LocalPredicate T
    where
  pred U f := ∀ x : U, ∃ (V : Opens X)(m : x.1 ∈ V)(i : V ⟶ U), P.pred fun x : V => f (i x : U)
  res V U i f w x := by
    specialize w (i x)
    rcases w with ⟨V', m', i', p⟩
    refine' ⟨V ⊓ V', ⟨x.2, m'⟩, opens.inf_le_left _ _, _⟩
    convert P.res (opens.inf_le_right V V') _ p
  locality U f w x := by
    specialize w x
    rcases w with ⟨V, m, i, p⟩
    specialize p ⟨x.1, m⟩
    rcases p with ⟨V', m', i', p'⟩
    exact ⟨V', m', i' ≫ i, p'⟩
#align Top.prelocal_predicate.sheafify TopCat.PrelocalPredicate.sheafify

theorem PrelocalPredicate.sheafify_of {T : X → Type v} {P : PrelocalPredicate T} {U : Opens X}
    {f : ∀ x : U, T x} (h : P.pred f) : P.sheafify.pred f := fun x =>
  ⟨U, x.2, 𝟙 _, by
    convert h
    ext ⟨y, w⟩
    rfl⟩
#align Top.prelocal_predicate.sheafify_of TopCat.PrelocalPredicate.sheafify_of

/-- The subpresheaf of dependent functions on `X` satisfying the "pre-local" predicate `P`.
-/
@[simps]
def subpresheafToTypes (P : PrelocalPredicate T) : Presheaf (Type v) X
    where
  obj U := { f : ∀ x : unop U, T x // P.pred f }
  map U V i f := ⟨fun x => f.1 (i.unop x), P.res i.unop f.1 f.2⟩
#align Top.subpresheaf_to_Types TopCat.subpresheafToTypes

namespace SubpresheafToTypes

variable (P : PrelocalPredicate T)

/-- The natural transformation including the subpresheaf of functions satisfying a local predicate
into the presheaf of all functions.
-/
def subtype : subpresheafToTypes P ⟶ presheafToTypes X T where app U f := f.1
#align Top.subpresheaf_to_Types.subtype TopCat.subpresheafToTypes.subtype

open TopCat.Presheaf

/-- The functions satisfying a local predicate satisfy the sheaf condition.
-/
theorem isSheaf (P : LocalPredicate T) : (subpresheafToTypes P.toPrelocalPredicate).IsSheaf :=
  Presheaf.isSheaf_of_isSheafUniqueGluing_types _ fun ι U sf sf_comp =>
    by
    -- We show the sheaf condition in terms of unique gluing.
    -- First we obtain a family of sections for the underlying sheaf of functions,
    -- by forgetting that the prediacte holds
    let sf' : ∀ i : ι, (presheaf_to_Types X T).obj (op (U i)) := fun i => (sf i).val
    -- Since our original family is compatible, this one is as well
    have sf'_comp : (presheaf_to_Types X T).IsCompatible U sf' := fun i j =>
      congr_arg Subtype.val (sf_comp i j)
    -- So, we can obtain a unique gluing
    obtain ⟨gl, gl_spec, gl_uniq⟩ := (sheaf_to_Types X T).existsUnique_gluing U sf' sf'_comp
    refine' ⟨⟨gl, _⟩, _, _⟩
    · -- Our first goal is to show that this chosen gluing satisfies the
      -- predicate. Of course, we use locality of the predicate.
      apply P.locality
      rintro ⟨x, mem⟩
      -- Once we're at a particular point `x`, we can select some open set `x ∈ U i`.
      choose i hi using opens.mem_supr.mp mem
      -- We claim that the predicate holds in `U i`
      use U i, hi, opens.le_supr U i
      -- This follows, since our original family `sf` satisfies the predicate
      convert(sf i).property
      exact gl_spec i
    -- It remains to show that the chosen lift is really a gluing for the subsheaf and
    -- that it is unique. Both of which follow immediately from the corresponding facts
    -- in the sheaf of functions without the local predicate.
    · intro i
      ext1
      exact gl_spec i
    · intro gl' hgl'
      ext1
      exact gl_uniq gl'.1 fun i => congr_arg Subtype.val (hgl' i)
#align Top.subpresheaf_to_Types.is_sheaf TopCat.subpresheafToTypes.isSheaf

end SubpresheafToTypes

/-- The subsheaf of the sheaf of all dependently typed functions satisfying the local predicate `P`.
-/
@[simps]
def subsheafToTypes (P : LocalPredicate T) : Sheaf (Type v) X :=
  ⟨subpresheafToTypes P.toPrelocalPredicate, subpresheafToTypes.isSheaf P⟩
#align Top.subsheaf_to_Types TopCat.subsheafToTypes

/-- There is a canonical map from the stalk to the original fiber, given by evaluating sections.
-/
def stalkToFiber (P : LocalPredicate T) (x : X) : (subsheafToTypes P).Presheaf.stalk x ⟶ T x :=
  by
  refine'
    colimit.desc _
      { pt := T x
        ι :=
          { app := fun U f => _
            naturality' := _ } }
  · exact f.1 ⟨x, (unop U).2⟩
  · tidy
#align Top.stalk_to_fiber TopCat.stalkToFiber

@[simp]
theorem stalkToFiber_germ (P : LocalPredicate T) (U : Opens X) (x : U) (f) :
    stalkToFiber P x ((subsheafToTypes P).Presheaf.germ x f) = f.1 x :=
  by
  dsimp [presheaf.germ, stalk_to_fiber]
  cases x
  simp
  rfl
#align Top.stalk_to_fiber_germ TopCat.stalkToFiber_germ

/-- The `stalk_to_fiber` map is surjective at `x` if
every point in the fiber `T x` has an allowed section passing through it.
-/
theorem stalkToFiber_surjective (P : LocalPredicate T) (x : X)
    (w : ∀ t : T x, ∃ (U : OpenNhds x)(f : ∀ y : U.1, T y)(h : P.pred f), f ⟨x, U.2⟩ = t) :
    Function.Surjective (stalkToFiber P x) := fun t =>
  by
  rcases w t with ⟨U, f, h, rfl⟩
  fconstructor
  · exact (subsheaf_to_Types P).Presheaf.germ ⟨x, U.2⟩ ⟨f, h⟩
  · exact stalk_to_fiber_germ _ U.1 ⟨x, U.2⟩ ⟨f, h⟩
#align Top.stalk_to_fiber_surjective TopCat.stalkToFiber_surjective

/-- The `stalk_to_fiber` map is injective at `x` if any two allowed sections which agree at `x`
agree on some neighborhood of `x`.
-/
theorem stalkToFiber_injective (P : LocalPredicate T) (x : X)
    (w :
      ∀ (U V : OpenNhds x) (fU : ∀ y : U.1, T y) (hU : P.pred fU) (fV : ∀ y : V.1, T y)
        (hV : P.pred fV) (e : fU ⟨x, U.2⟩ = fV ⟨x, V.2⟩),
        ∃ (W : OpenNhds x)(iU : W ⟶ U)(iV : W ⟶ V), ∀ w : W.1, fU (iU w : U.1) = fV (iV w : V.1)) :
    Function.Injective (stalkToFiber P x) := fun tU tV h =>
  by
  -- We promise to provide all the ingredients of the proof later:
  let Q :
    ∃ (W : (open_nhds x)ᵒᵖ)(s : ∀ w : (unop W).1, T w)(hW : P.pred s),
      tU = (subsheaf_to_Types P).Presheaf.germ ⟨x, (unop W).2⟩ ⟨s, hW⟩ ∧
        tV = (subsheaf_to_Types P).Presheaf.germ ⟨x, (unop W).2⟩ ⟨s, hW⟩ :=
    _
  · choose W s hW e using Q
    exact e.1.trans e.2.symm
  -- Then use induction to pick particular representatives of `tU tV : stalk x`
  obtain ⟨U, ⟨fU, hU⟩, rfl⟩ := jointly_surjective'.{v, v} tU
  obtain ⟨V, ⟨fV, hV⟩, rfl⟩ := jointly_surjective'.{v, v} tV
  · -- Decompose everything into its constituent parts:
    dsimp
    simp only [stalk_to_fiber, types.colimit.ι_desc_apply'] at h
    specialize w (unop U) (unop V) fU hU fV hV h
    rcases w with ⟨W, iU, iV, w⟩
    -- and put it back together again in the correct order.
    refine' ⟨op W, fun w => fU (iU w : (unop U).1), P.res _ _ hU, _⟩
    rcases W with ⟨W, m⟩
    exact ⟨colimit_sound iU.op (Subtype.eq rfl), colimit_sound iV.op (Subtype.eq (funext w).symm)⟩
#align Top.stalk_to_fiber_injective TopCat.stalkToFiber_injective

/-- Some repackaging:
the presheaf of functions satisfying `continuous_prelocal` is just the same thing as
the presheaf of continuous functions.
-/
def subpresheafContinuousPrelocalIsoPresheafToTop (T : TopCat.{v}) :
    subpresheafToTypes (continuousPrelocal X T) ≅ presheafToTop X T :=
  NatIso.ofComponents
    (fun X =>
      { Hom := by
          rintro ⟨f, c⟩
          exact ⟨f, c⟩
        inv := by
          rintro ⟨f, c⟩
          exact ⟨f, c⟩
        hom_inv_id' := by
          ext (⟨f, p⟩x)
          rfl
        inv_hom_id' := by
          ext (⟨f, p⟩x)
          rfl })
    (by tidy)
#align Top.subpresheaf_continuous_prelocal_iso_presheaf_to_Top TopCat.subpresheafContinuousPrelocalIsoPresheafToTop

/-- The sheaf of continuous functions on `X` with values in a space `T`.
-/
def sheafToTop (T : TopCat.{v}) : Sheaf (Type v) X :=
  ⟨presheafToTop X T,
    Presheaf.isSheaf_of_iso (subpresheafContinuousPrelocalIsoPresheafToTop T)
      (subpresheafToTypes.isSheaf (continuousLocal X T))⟩
#align Top.sheaf_to_Top TopCat.sheafToTop

end TopCat


import data.polynomial.basic
import data.polynomial.eval
import data.polynomial.identities
import data.polynomial.splits

import data.polynomial.nat_degree_quartic
import algebra.quartic_discriminant.card_eq_four

noncomputable theory

@[ext] structure quartic (R : Type*) := (a b c d e : R)

namespace quartic

open quartic polynomial

open_locale polynomial

variables {R S F K : Type*}

instance [inhabited R] : inhabited (quartic R) := ⟨⟨default, default, default, default, default⟩⟩

instance [has_zero R] : has_zero (quartic R) := ⟨⟨0, 0, 0, 0, 0⟩⟩

section basic

variables {P Q : quartic R} {a b c d e a' b' c' d' e' : R} [semiring R]

/-- Convert a quartic polynomial to a polynomial. -/
def to_poly (P : quartic R) : R[X] := C P.a * X ^ 4 + C P.b * X ^ 3 + C P.c * X ^ 2 + C P.d * X + C P.e

theorem C_mul_prod_X_sub_C_eq [comm_ring S] {v w x y z : S} :
  C v * (X - C w) * (X - C x) * (X - C y) * (X - C z)
    = to_poly ⟨v, v * -(w + x + y + z), v * (w * x + w * y + w * z + x * y + x * z + y * z), v * -(w * x * y + w * x * z + w * y * z + x * y * z), v * (w * x * y * z)⟩ :=
by { simp only [to_poly, C_neg, C_add, C_mul], ring1 }

theorem prod_X_sub_C_eq [comm_ring S] {w x y z : S} :
  (X - C w) * (X - C x) * (X - C y) * (X - C z)
    = to_poly ⟨1, -(w + x + y + z), (w * x + w * y + w * z + x * y + x * z + y * z), -(w * x * y + w * x * z + w * y * z + x * y * z), (w * x * y * z)⟩ :=
by rw [← one_mul $ X - C w, ← C_1, C_mul_prod_X_sub_C_eq, one_mul, one_mul, one_mul, one_mul ]

/-! ### Coefficients -/

section coeff

private lemma coeffs :
  (∀ n > 4, P.to_poly.coeff n = 0) ∧ P.to_poly.coeff 4 = P.a ∧ P.to_poly.coeff 3 = P.b
    ∧ P.to_poly.coeff 2 = P.c ∧ P.to_poly.coeff 1 = P.d ∧ P.to_poly.coeff 0 = P.e :=
begin
  simp only [to_poly, coeff_add, coeff_C, coeff_C_mul_X, coeff_C_mul_X_pow],
  norm_num,
  intros n hn,
  repeat { rw [if_neg] },
  any_goals { linarith only [hn] },
  repeat { rw [zero_add] }
end

@[simp] lemma coeff_eq_zero {n : ℕ} (hn : 4 < n) : P.to_poly.coeff n = 0 := coeffs.1 n hn

@[simp] lemma coeff_eq_a : P.to_poly.coeff 4 = P.a := coeffs.2.1

@[simp] lemma coeff_eq_b : P.to_poly.coeff 3 = P.b := coeffs.2.2.1

@[simp] lemma coeff_eq_c : P.to_poly.coeff 2 = P.c := coeffs.2.2.2.1

@[simp] lemma coeff_eq_d : P.to_poly.coeff 1 = P.d := coeffs.2.2.2.2.1

@[simp] lemma coeff_eq_e : P.to_poly.coeff 0 = P.e := coeffs.2.2.2.2.2

lemma a_of_eq (h : P.to_poly = Q.to_poly) : P.a = Q.a := by rw [← coeff_eq_a, h, coeff_eq_a]

lemma b_of_eq (h : P.to_poly = Q.to_poly) : P.b = Q.b := by rw [← coeff_eq_b, h, coeff_eq_b]

lemma c_of_eq (h : P.to_poly = Q.to_poly) : P.c = Q.c := by rw [← coeff_eq_c, h, coeff_eq_c]

lemma d_of_eq (h : P.to_poly = Q.to_poly) : P.d = Q.d := by rw [← coeff_eq_d, h, coeff_eq_d]

lemma e_of_eq (h : P.to_poly = Q.to_poly) : P.e = Q.e := by rw [← coeff_eq_e, h, coeff_eq_e]

lemma to_poly_injective (P Q : quartic R) : P.to_poly = Q.to_poly ↔ P = Q :=
⟨λ h, ext P Q (a_of_eq h) (b_of_eq h) (c_of_eq h) (d_of_eq h) (e_of_eq h), congr_arg to_poly⟩

lemma of_a_eq_zero (ha : P.a = 0) : P.to_poly = C P.b * X ^ 3 + C P.c * X ^ 2 + C P.d * X + C P.e :=
by rw [to_poly, ha, C_0, zero_mul, zero_add]

lemma of_a_eq_zero' : to_poly ⟨0, b, c, d, e⟩ = C b * X ^ 3 + C c * X ^ 2 + C d * X + C e := of_a_eq_zero rfl

lemma of_b_eq_zero (ha : P.a = 0) (hb : P.b = 0) : P.to_poly = C P.c * X ^ 2 + C P.d * X + C P.e :=
by rw [of_a_eq_zero ha, hb, C_0, zero_mul, zero_add]

lemma of_b_eq_zero' : to_poly ⟨0, 0, c, d, e⟩ = C c * X ^ 2 + C d * X + C e := of_b_eq_zero rfl rfl

lemma of_c_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) : P.to_poly = C P.d * X + C P.e :=
by rw [of_b_eq_zero ha hb, hc, C_0, zero_mul, zero_add]

lemma of_c_eq_zero' : to_poly ⟨0, 0, 0, d, e⟩ = C d * X + C e := of_c_eq_zero rfl rfl rfl

lemma of_d_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) :
  P.to_poly = C P.e :=
by rw [of_c_eq_zero ha hb hc, hd, C_0, zero_mul, zero_add]

lemma of_d_eq_zero' : to_poly ⟨0, 0, 0, 0, e⟩ = C e := of_d_eq_zero rfl rfl rfl rfl

lemma of_e_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) (he : P.e = 0) :
  P.to_poly = 0 :=
by rw [of_d_eq_zero ha hb hc hd, he, C_0]

lemma of_e_eq_zero' : (⟨0, 0, 0, 0, 0⟩ : quartic R).to_poly = 0 := of_e_eq_zero rfl rfl rfl rfl rfl

lemma zero : (0 : quartic R).to_poly = 0 := of_e_eq_zero'

lemma to_poly_eq_zero_iff (P : quartic R) : P.to_poly = 0 ↔ P = 0 :=
by rw [← zero, to_poly_injective]

private lemma ne_zero (h0 : P.a ≠ 0 ∨ P.b ≠ 0 ∨ P.c ≠ 0 ∨ P.d ≠ 0 ∨ P.e ≠ 0) : P.to_poly ≠ 0 :=
by { contrapose! h0, rw [(to_poly_eq_zero_iff P).mp h0], exact ⟨rfl, rfl, rfl, rfl, rfl⟩ }

lemma ne_zero_of_a_ne_zero (ha : P.a ≠ 0) : P.to_poly ≠ 0 := (or_imp_distrib.mp ne_zero).1 ha

lemma ne_zero_of_b_ne_zero (hb : P.b ≠ 0) : P.to_poly ≠ 0 :=
(or_imp_distrib.mp (or_imp_distrib.mp ne_zero).2).1 hb

lemma ne_zero_of_c_ne_zero (hc : P.c ≠ 0) : P.to_poly ≠ 0 :=
(or_imp_distrib.mp (or_imp_distrib.mp (or_imp_distrib.mp ne_zero).2).2).1 hc

lemma ne_zero_of_d_ne_zero (hd : P.d ≠ 0) : P.to_poly ≠ 0 :=
(or_imp_distrib.mp (or_imp_distrib.mp (or_imp_distrib.mp (or_imp_distrib.mp ne_zero).2).2).2).1 hd

lemma ne_zero_of_e_ne_zero (he : P.e ≠ 0) : P.to_poly ≠ 0 :=
(or_imp_distrib.mp (or_imp_distrib.mp (or_imp_distrib.mp (or_imp_distrib.mp ne_zero).2).2).2).2 he

@[simp] lemma leading_coeff_of_a_ne_zero (ha : P.a ≠ 0) : P.to_poly.leading_coeff = P.a :=
leading_coeff_quartic ha

@[simp] lemma leading_coeff_of_a_ne_zero' (ha : a ≠ 0) : (to_poly ⟨a, b, c, d, e⟩).leading_coeff = a :=
leading_coeff_of_a_ne_zero ha

@[simp] lemma leading_coeff_of_b_ne_zero (ha : P.a = 0) (hb : P.b ≠ 0) :
  P.to_poly.leading_coeff = P.b :=
by rw [of_a_eq_zero ha, leading_coeff_cubic hb]

@[simp] lemma leading_coeff_of_b_ne_zero' (hb : b ≠ 0) : (to_poly ⟨0, b, c, d, e⟩).leading_coeff = b :=
leading_coeff_of_b_ne_zero rfl hb

@[simp] lemma leading_coeff_of_c_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c ≠ 0) :
  P.to_poly.leading_coeff = P.c :=
by rw [of_b_eq_zero ha hb, leading_coeff_quadratic hc]

@[simp] lemma leading_coeff_of_c_ne_zero' (hc : c ≠ 0) : (to_poly ⟨0, 0, c, d, e⟩).leading_coeff = c :=
leading_coeff_of_c_ne_zero rfl rfl hc

@[simp] lemma leading_coeff_of_d_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d ≠ 0) :
  P.to_poly.leading_coeff = P.d :=
by rw [of_c_eq_zero ha hb hc, leading_coeff_linear hd]

@[simp] lemma leading_coeff_of_d_ne_zero' (hd : d ≠ 0) : (to_poly ⟨0, 0, 0, d, e⟩).leading_coeff = d :=
leading_coeff_of_d_ne_zero rfl rfl rfl hd

@[simp] lemma leading_coeff_of_d_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) :
  P.to_poly.leading_coeff = P.e :=
by rw [of_d_eq_zero ha hb hc hd, leading_coeff_C]

@[simp] lemma leading_coeff_of_d_eq_zero' : (to_poly ⟨0, 0, 0, 0, e⟩).leading_coeff = e :=
leading_coeff_of_d_eq_zero rfl rfl rfl rfl

lemma monic_of_a_eq_one (ha : P.a = 1) : P.to_poly.monic :=
begin
  nontriviality,
  rw [monic, leading_coeff_of_a_ne_zero $ by { rw [ha], exact one_ne_zero }, ha]
end

lemma monic_of_a_eq_one' : (to_poly ⟨1, b, c, d, e⟩).monic := monic_of_a_eq_one rfl

lemma monic_of_b_eq_one (ha : P.a = 0) (hb : P.b = 1) : P.to_poly.monic :=
begin
  nontriviality,
  rw [monic, leading_coeff_of_b_ne_zero ha $ by { rw [hb], exact one_ne_zero }, hb]
end

lemma monic_of_b_eq_one' : (to_poly ⟨0, 1, c, d, e⟩).monic := monic_of_b_eq_one rfl rfl

lemma monic_of_c_eq_one (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 1) : P.to_poly.monic :=
begin
  nontriviality,
  rw [monic, leading_coeff_of_c_ne_zero ha hb $ by { rw [hc], exact one_ne_zero }, hc]
end

lemma monic_of_c_eq_one' : (to_poly ⟨0, 0, 1, d, e⟩).monic := monic_of_c_eq_one rfl rfl rfl

lemma monic_of_d_eq_one (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 1) :
  P.to_poly.monic :=
begin
  nontriviality,
  rw [monic, leading_coeff_of_d_ne_zero ha hb hc $ by { rw [hd], exact one_ne_zero }, hd]
end

lemma monic_of_d_eq_one' : (to_poly ⟨0, 0, 0, 1, e⟩).monic := monic_of_d_eq_one rfl rfl rfl rfl

lemma monic_of_e_eq_one (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) (he : P.e = 1) :
  P.to_poly.monic :=
by rw [monic, leading_coeff_of_d_eq_zero ha hb hc hd, he]

lemma monic_of_e_eq_one' : (to_poly ⟨0, 0, 0, 0, 1⟩).monic := monic_of_e_eq_one rfl rfl rfl rfl rfl

end coeff

/-! ### Degrees -/

section degree

/-- The equivalence between quartic polynomials and polynomials of degree at most four. -/
@[simps] def equiv : quartic R ≃ {p : R[X] // p.degree ≤ 4} :=
{ to_fun    := λ P, ⟨P.to_poly, degree_quartic_le⟩,
  inv_fun   := λ f, ⟨coeff f 4, coeff f 3, coeff f 2, coeff f 1, coeff f 0⟩,
  left_inv  := λ P, by ext; simp only [subtype.coe_mk, coeffs],
  right_inv := λ f,
  begin
    ext (_ | _ | _ | _ | _ | n); simp only [subtype.coe_mk, coeffs],
    have h4 : 4 < n + 5 := by linarith only,
    rw [coeff_eq_zero h4,
        (degree_le_iff_coeff_zero (f : R[X]) 4).mp f.2 _ $ with_bot.coe_lt_coe.mpr h4]
  end }

@[simp] lemma degree_of_a_ne_zero (ha : P.a ≠ 0) : P.to_poly.degree = 4 := degree_quartic ha

@[simp] lemma degree_of_a_ne_zero' (ha : a ≠ 0) : (to_poly ⟨a, b, c, d, e⟩).degree = 4 :=
degree_of_a_ne_zero ha

lemma degree_of_a_eq_zero (ha : P.a = 0) : P.to_poly.degree ≤ 3 :=
by simpa only [of_a_eq_zero ha] using degree_cubic_le

lemma degree_of_a_eq_zero' : (to_poly ⟨0, b, c, d, e⟩).degree ≤ 3 := degree_of_a_eq_zero rfl

@[simp] lemma degree_of_b_ne_zero (ha : P.a = 0) (hb : P.b ≠ 0) : P.to_poly.degree = 3 :=
by rw [of_a_eq_zero ha, degree_cubic hb]

@[simp] lemma degree_of_b_ne_zero' (hb : b ≠ 0) : (to_poly ⟨0, b, c, d, e⟩).degree = 3 :=
degree_of_b_ne_zero rfl hb

lemma degree_of_b_eq_zero (ha : P.a = 0) (hb : P.b = 0) : P.to_poly.degree ≤ 2 :=
by simpa only [of_b_eq_zero ha hb] using degree_quadratic_le

lemma degree_of_b_eq_zero' : (to_poly ⟨0, 0, c, d, e⟩).degree ≤ 2 := degree_of_b_eq_zero rfl rfl

@[simp] lemma degree_of_c_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c ≠ 0) :
  P.to_poly.degree = 2 :=
by rw [of_b_eq_zero ha hb, degree_quadratic hc]

@[simp] lemma degree_of_c_ne_zero' (hc : c ≠ 0) : (to_poly ⟨0, 0, c, d, e⟩).degree = 2 :=
degree_of_c_ne_zero rfl rfl hc

lemma degree_of_c_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) : P.to_poly.degree ≤ 1 :=
by simpa only [of_c_eq_zero ha hb hc] using degree_linear_le

lemma degree_of_c_eq_zero' : (to_poly ⟨0, 0, 0, d, e⟩).degree ≤ 1 := degree_of_c_eq_zero rfl rfl rfl

@[simp] lemma degree_of_d_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d ≠ 0) :
  P.to_poly.degree = 1 :=
by rw [of_c_eq_zero ha hb hc, degree_linear hd]

@[simp] lemma degree_of_d_ne_zero' (hd : d ≠ 0) : (to_poly ⟨0, 0, 0, d, e⟩).degree = 1 :=
degree_of_d_ne_zero rfl rfl rfl hd

lemma degree_of_d_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) : P.to_poly.degree ≤ 0 :=
by simpa only [of_d_eq_zero ha hb hc hd] using degree_C_le

lemma degree_of_d_eq_zero' : (to_poly ⟨0, 0, 0, 0, e⟩).degree ≤ 0 := degree_of_d_eq_zero rfl rfl rfl rfl

@[simp] lemma degree_of_e_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) (he : P.e ≠ 0) :
  P.to_poly.degree = 0 :=
by rw [of_d_eq_zero ha hb hc hd, degree_C he]

@[simp] lemma degree_of_e_ne_zero' (he : e ≠ 0) : (to_poly ⟨0, 0, 0, 0, e⟩).degree = 0 :=
degree_of_e_ne_zero rfl rfl rfl rfl he

@[simp] lemma degree_of_e_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) (he : P.e = 0) :
  P.to_poly.degree = ⊥ :=
by rw [of_e_eq_zero ha hb hc hd he, degree_zero]

@[simp] lemma degree_of_e_eq_zero' : (⟨0, 0, 0, 0, 0⟩ : quartic R).to_poly.degree = ⊥ :=
degree_of_e_eq_zero rfl rfl rfl rfl rfl

@[simp] lemma degree_of_zero : (0 : quartic R).to_poly.degree = ⊥ := degree_of_e_eq_zero'

@[simp] lemma nat_degree_of_a_ne_zero (ha : P.a ≠ 0) : P.to_poly.nat_degree = 4 :=
nat_degree_quartic ha

@[simp] lemma nat_degree_of_a_ne_zero' (ha : a ≠ 0) : (to_poly ⟨a, b, c, d, e⟩).nat_degree = 4 :=
nat_degree_of_a_ne_zero ha

lemma nat_degree_of_a_eq_zero (ha : P.a = 0) : P.to_poly.nat_degree ≤ 3 :=
by simpa only [of_a_eq_zero ha] using nat_degree_cubic_le

lemma nat_degree_of_a_eq_zero' : (to_poly ⟨0, b, c, d, e⟩).nat_degree ≤ 3 :=
nat_degree_of_a_eq_zero rfl

@[simp] lemma nat_degree_of_b_ne_zero (ha : P.a = 0) (hb : P.b ≠ 0) : P.to_poly.nat_degree = 3 :=
by rw [of_a_eq_zero ha, nat_degree_cubic hb]

@[simp] lemma nat_degree_of_b_ne_zero' (hb : b ≠ 0) : (to_poly ⟨0, b, c, d, e⟩).nat_degree = 3 :=
nat_degree_of_b_ne_zero rfl hb

lemma nat_degree_of_b_eq_zero (ha : P.a = 0) (hb : P.b = 0) : P.to_poly.nat_degree ≤ 2 :=
by simpa only [of_b_eq_zero ha hb] using nat_degree_quadratic_le

lemma nat_degree_of_b_eq_zero' : (to_poly ⟨0, 0, c, d, e⟩).nat_degree ≤ 2 :=
nat_degree_of_b_eq_zero rfl rfl

@[simp] lemma nat_degree_of_c_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c ≠ 0) :
  P.to_poly.nat_degree = 2 :=
by rw [of_b_eq_zero ha hb, nat_degree_quadratic hc]

@[simp] lemma nat_degree_of_c_ne_zero' (hc : c ≠ 0) : (to_poly ⟨0, 0, c, d, e⟩).nat_degree = 2 :=
nat_degree_of_c_ne_zero rfl rfl hc

lemma nat_degree_of_c_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d ≠ 0) :
  P.to_poly.nat_degree ≤ 1 :=
by rw [of_c_eq_zero ha hb hc, nat_degree_linear hd]

lemma nat_degree_of_c_eq_zero' (hd : d ≠ 0) : (to_poly ⟨0, 0, 0, d, e⟩).nat_degree ≤ 1 :=
nat_degree_of_c_eq_zero rfl rfl rfl hd

@[simp] lemma nat_degree_of_d_ne_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d ≠ 0) :
  P.to_poly.nat_degree = 1 :=
by rw [of_c_eq_zero ha hb hc, nat_degree_linear hd]

@[simp] lemma nat_degree_of_d_ne_zero' (hd : d ≠ 0) : (to_poly ⟨0, 0, 0, d, e⟩).nat_degree = 1 :=
nat_degree_of_d_ne_zero rfl rfl rfl hd

@[simp] lemma nat_degree_of_d_eq_zero (ha : P.a = 0) (hb : P.b = 0) (hc : P.c = 0) (hd : P.d = 0) :
  P.to_poly.nat_degree = 0 :=
by rw [of_d_eq_zero ha hb hc hd, nat_degree_C]

@[simp] lemma nat_degree_of_d_eq_zero' : (to_poly ⟨0, 0, 0, 0, e⟩).nat_degree = 0 :=
nat_degree_of_d_eq_zero rfl rfl rfl rfl

@[simp] lemma nat_degree_of_zero : (0 : quartic R).to_poly.nat_degree = 0 := nat_degree_of_d_eq_zero'

end degree

section map

variables [semiring S] {φ : R →+* S}

/-- Map a quartic polynomial across a semiring homomorphism. -/
def map (φ : R →+* S) (P : quartic R) : quartic S := ⟨φ P.a, φ P.b, φ P.c, φ P.d, φ P.e⟩

lemma map_to_poly : (map φ P).to_poly = polynomial.map φ P.to_poly :=
by simp only [map, to_poly, map_C, map_X, polynomial.map_add, polynomial.map_mul,
              polynomial.map_pow]

end map

end basic

section roots

open multiset

/-! ### Roots over an extension -/

section extension

variables {P : quartic R} [comm_ring R] [comm_ring S] {φ : R →+* S}

/-- The roots of a cubic polynomial. -/
def roots [is_domain R] (P : quartic R) : multiset R := P.to_poly.roots

lemma map_roots [is_domain S] : (map φ P).roots = (polynomial.map φ P.to_poly).roots :=
by rw [roots, map_to_poly]

theorem mem_roots_iff [is_domain R] (h0 : P.to_poly ≠ 0) (x : R) :
  x ∈ P.roots ↔ P.a * x ^ 4 + P.b * x ^ 3 + P.c * x ^ 2 + P.d * x + P.e = 0 :=
begin
  rw [roots, mem_roots h0, is_root, to_poly],
  simp only [eval_C, eval_X, eval_add, eval_mul, eval_pow]
end

theorem card_roots_le [is_domain R] [decidable_eq R] : P.roots.to_finset.card ≤ 4 :=
begin
  apply (to_finset_card_le P.to_poly.roots).trans,
  by_cases hP : P.to_poly = 0,
  { exact (card_roots' P.to_poly).trans (by { rw [hP, nat_degree_zero], exact zero_le 4 }) },
  { exact with_bot.coe_le_coe.1 ((card_roots hP).trans degree_quartic_le) }
end

end extension

variables {P : quartic F} [field F] [field K] {φ : F →+* K} {w x y z : K}

/-! ### Roots over a splitting field -/

section split

theorem splits_iff_card_roots (ha : P.a ≠ 0) : splits φ P.to_poly ↔ (map φ P).roots.card = 4 :=
begin
  replace ha : (map φ P).a ≠ 0 := (_root_.map_ne_zero φ).mpr ha,
  nth_rewrite_lhs 0 [← ring_hom.id_comp φ],
  rw [roots, ← splits_map_iff, ← map_to_poly, splits_iff_card_roots,
      ← ((degree_eq_iff_nat_degree_eq $ ne_zero_of_a_ne_zero ha).mp $
          degree_of_a_ne_zero ha : _ = 4)]
end

theorem splits_iff_roots_eq_four (ha : P.a ≠ 0) :
  splits φ P.to_poly ↔ ∃ w x y z : K, (map φ P).roots = {w, x, y, z} :=
by rw [splits_iff_card_roots ha, multiset.card_eq_four]

theorem eq_prod_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  (map φ P).to_poly = C (φ P.a) * (X - C w) * (X - C x) * (X - C y) * (X - C z) :=
begin
  rw [map_to_poly, eq_prod_roots_of_splits $ (splits_iff_roots_eq_four ha).mpr $ exists.intro w $
        exists.intro x $ exists.intro y $ exists.intro z h4, leading_coeff_of_a_ne_zero ha, ← map_roots, h4],
  change C (φ P.a) * ((X - C w) ::ₘ (X - C x) ::ₘ (X - C y) ::ₘ {X - C z}).prod = _,
  rw [prod_cons, prod_cons, prod_cons, prod_singleton, mul_assoc, mul_assoc, mul_assoc]
end

theorem eq_sum_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  map φ P = ⟨φ P.a, φ P.a * -(w + x + y + z), φ P.a * (w * x + w * y + w * z + x * y + x * z + y * z), φ P.a * -(w * x * y + w * x * z + w * y * z + x * y * z), φ P.a * (w * x * y * z)⟩ :=
begin
  apply_fun to_poly,
  any_goals { exact λ P Q, (to_poly_injective P Q).mp },
  rw [eq_prod_four_roots ha h4, C_mul_prod_X_sub_C_eq]
end

theorem b_eq_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  φ P.b = φ P.a * -(w + x + y + z) :=
by injection eq_sum_four_roots ha h4

theorem c_eq_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  φ P.c = φ P.a * (w * x + w * y + w * z + x * y + x * z + y * z) :=
by injection eq_sum_four_roots ha h4

theorem d_eq_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  φ P.d = φ P.a * -(w * x * y + w * x * z + w * y * z + x * y * z) :=
by injection eq_sum_four_roots ha h4

theorem e_eq_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  φ P.e = φ P.a * (w * x * y * z) :=
by injection eq_sum_four_roots ha h4

end split

/-! ### Discriminant over a splitting field -/

section discriminant

def discP {R : Type*} [ring R] (P : quartic R) : R := 8 * P.a * P.c - 3 * P.b ^ 2
def discR {R : Type*} [ring R] (P : quartic R) : R := P.b ^ 3 + 8 * P.d * P.a ^ 2 - 4 * P.a * P.b * P.c
def discΔ_0 {R : Type*} [ring R] (P : quartic R) : R := P.c ^ 2 - 3 * P.b * P.d + 12 * P.a * P.e
def discD {R : Type*} [ring R] (P : quartic R) : R := 64 * P.a ^ 3 * P.e - 16 * P.a ^ 2 * P.c ^ 2 + 16 * P.a * P.b ^ 2 * P.c - 16 * P.a ^ 2 * P.b * P.d - 3 * P.b ^ 4

/-- The discriminant of a quartic polynomial. -/
def disc {R : Type*} [ring R] (P : quartic R) : R :=
256 * P.a^3 * P.e^3-192 * P.a^2 * P.b * P.d * P.e^2-128 * P.a^2 * P.c^2 * P.e^2+144 * P.a^2 * P.c * P.d^2 * P.e-27 * P.a^2 * P.d^4+144 * P.a * P.b^2 * P.c * P.e^2-6 * P.a * P.b^2 * P.d^2 * P.e-80 * P.a * P.b * P.c^2 * P.d * P.e+18 * P.a * P.b * P.c * P.d^3+16 * P.a * P.c^4 * P.e-4 * P.a * P.c^3 * P.d^2-27 * P.b^4 * P.e^2+18 * P.b^3 * P.c * P.d * P.e-4 * P.b^3 * P.d^3-4 * P.b^2 * P.c^3 * P.e+  P.b^2 * P.c^2 * P.d^2

theorem disc_eq_prod_four_roots (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  φ P.disc = (φ P.a * φ P.a * φ P.a * (w - x) * (w - y) * (w - z) * (x - y) * (x - z) * (y - z)) ^ 2 :=
begin
  simp only [disc, ring_hom.map_add, ring_hom.map_sub, ring_hom.map_mul, map_pow],
  simp only [ring_hom.map_one, map_bit0, map_bit1],
  rw [b_eq_four_roots ha h4, c_eq_four_roots ha h4, d_eq_four_roots ha h4, e_eq_four_roots ha h4],
  ring1
end

theorem disc_ne_zero_iff_roots_ne (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  P.disc ≠ 0 ↔ w ≠ x ∧ w ≠ y ∧ w ≠ z ∧ x ≠ y ∧ x ≠ z ∧ y ≠ z :=
begin
  rw [←_root_.map_ne_zero φ, disc_eq_prod_four_roots ha h4, pow_two],
  simp_rw [mul_ne_zero_iff, sub_ne_zero, _root_.map_ne_zero, and_self, and_iff_right ha, and_assoc],
end

theorem disc_ne_zero_iff_roots_nodup (ha : P.a ≠ 0) (h4 : (map φ P).roots = {w, x, y, z}) :
  P.disc ≠ 0 ↔ (map φ P).roots.nodup :=
begin
  rw [disc_ne_zero_iff_roots_ne ha h4, h4],
  change _ ↔ (w ::ₘ x ::ₘ y ::ₘ {z}).nodup,
  rw [nodup_cons, nodup_cons, nodup_cons, mem_cons, mem_cons, mem_cons, mem_singleton, mem_singleton, mem_singleton],
  simp only [nodup_singleton],
  tautology
end

theorem card_roots_of_disc_ne_zero [decidable_eq K] (ha : P.a ≠ 0)
  (h3 : (map φ P).roots = {w, x, y, z}) (hd : P.disc ≠ 0) : (map φ P).roots.to_finset.card = 4 :=
begin
  rw [to_finset_card_of_nodup $ (disc_ne_zero_iff_roots_nodup ha h3).mp hd,
      ← splits_iff_card_roots ha, splits_iff_roots_eq_four ha],
  exact ⟨w, ⟨x, ⟨y, ⟨z, h3⟩⟩⟩⟩
end

end discriminant

end roots

end quartic


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

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
For example, if `x` is algebraic over a ring/field, adjoining `x`
gives a `power_basis` structure generated by `x`.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `finrank (hf : f ≠ 0) : finite_dimensional.finrank K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, ... are `comm_ring`s, `A`, `B`, ... are
`comm_ring` with `is_domain`s and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

open polynomial
open_locale polynomial

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra S T] [algebra R T] [is_scalar_tower R S T]
variables {A B : Type*} [comm_ring A]
  [comm_ring B] [is_domain B] [algebra A B]
variables {K L : Type*} [field K] [field L] [algebra K L]

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
@[nolint has_inhabited_instance]
structure power_basis (R S : Type*) [comm_ring R] [ring S] [algebra R S] :=
(gen : S)
(dim : ℕ)
(basis : basis (fin dim) R S)
(basis_eq_pow : ∀ i, basis i = gen ^ (i : ℕ))

-- this is usually not needed because of `basis_eq_pow` but can be needed in some cases;
-- in such circumstances, add it manually using `@[simps dim gen basis]`.
initialize_simps_projections power_basis (-basis)

namespace power_basis

@[simp] lemma coe_basis (pb : power_basis R S) :
  ⇑pb.basis = λ (i : fin pb.dim), pb.gen ^ (i : ℕ) :=
funext pb.basis_eq_pow

/-- Cannot be an instance because `power_basis` cannot be a class. -/
lemma finite_dimensional [algebra K S] (pb : power_basis K S) : finite_dimensional K S :=
finite_dimensional.of_fintype_basis pb.basis

lemma finrank [algebra K S] (pb : power_basis K S) : finite_dimensional.finrank K S = pb.dim :=
by rw [finite_dimensional.finrank_eq_card_basis pb.basis, fintype.card_fin]

lemma mem_span_pow' {x y : S} {d : ℕ} :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : R[X], f.degree < d ∧ y = aeval x f :=
begin
  have : set.range (λ (i : fin d), x ^ (i : ℕ)) = (λ (i : ℕ), x ^ i) '' ↑(finset.range d),
  { ext n,
    simp_rw [set.mem_range, set.mem_image, finset.mem_coe, finset.mem_range],
    exact ⟨λ ⟨⟨i, hi⟩, hy⟩, ⟨i, hi, hy⟩, λ ⟨i, hi, hy⟩, ⟨⟨i, hi⟩, hy⟩⟩ },
  simp only [this, finsupp.mem_span_image_iff_total, degree_lt_iff_coeff_zero,
    exists_iff_exists_finsupp, coeff, aeval, eval₂_ring_hom', eval₂_eq_sum, polynomial.sum, support,
    finsupp.mem_supported', finsupp.total, finsupp.sum, algebra.smul_def, eval₂_zero, exists_prop,
    linear_map.id_coe, eval₂_one, id.def, not_lt, finsupp.coe_lsum, linear_map.coe_smul_right,
    finset.mem_range, alg_hom.coe_mk, finset.mem_coe],
  simp_rw [@eq_comm _ y],
  exact iff.rfl
end

lemma mem_span_pow {x y : S} {d : ℕ} (hd : d ≠ 0) :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : R[X], f.nat_degree < d ∧ y = aeval x f :=
begin
  rw mem_span_pow',
  split;
  { rintros ⟨f, h, hy⟩,
    refine ⟨f, _, hy⟩,
    by_cases hf : f = 0,
    { simp only [hf, nat_degree_zero, degree_zero] at h ⊢,
      exact lt_of_le_of_ne (nat.zero_le d) hd.symm <|> exact with_bot.bot_lt_coe d },
    simpa only [degree_eq_nat_degree hf, with_bot.coe_lt_coe] using h },
end

lemma dim_ne_zero [h : nontrivial S] (pb : power_basis R S) : pb.dim ≠ 0 :=
λ h, not_nonempty_iff.mpr (h.symm ▸ fin.is_empty : is_empty (fin pb.dim)) pb.basis.index_nonempty

lemma dim_pos [nontrivial S] (pb : power_basis R S) : 0 < pb.dim :=
nat.pos_of_ne_zero pb.dim_ne_zero

lemma exists_eq_aeval [nontrivial S] (pb : power_basis R S) (y : S) :
  ∃ f : R[X], f.nat_degree < pb.dim ∧ y = aeval pb.gen f :=
(mem_span_pow pb.dim_ne_zero).mp (by simpa using pb.basis.mem_span y)

lemma exists_eq_aeval' (pb : power_basis R S) (y : S) :
  ∃ f : R[X], y = aeval pb.gen f :=
begin
  nontriviality S,
  obtain ⟨f, _, hf⟩ := exists_eq_aeval pb y,
  exact ⟨f, hf⟩
end

lemma alg_hom_ext {S' : Type*} [semiring S'] [algebra R S']
  (pb : power_basis R S) ⦃f g : S →ₐ[R] S'⦄ (h : f pb.gen = g pb.gen) :
  f = g :=
begin
  ext x,
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x,
  rw [← polynomial.aeval_alg_hom_apply, ← polynomial.aeval_alg_hom_apply, h]
end

section minpoly

open_locale big_operators

variable [algebra A S]

/-- `pb.minpoly_gen` is a minimal polynomial for `pb.gen`.

If `A` is not a field, it might not necessarily be *the* minimal polynomial,
however `nat_degree_minpoly` shows its degree is indeed minimal.
-/
noncomputable def minpoly_gen (pb : power_basis A S) : A[X] :=
X ^ pb.dim -
  ∑ (i : fin pb.dim), C (pb.basis.repr (pb.gen ^ pb.dim) i) * X ^ (i : ℕ)

@[simp]
lemma aeval_minpoly_gen (pb : power_basis A S) : aeval pb.gen (minpoly_gen pb) = 0 :=
begin
  simp_rw [minpoly_gen, alg_hom.map_sub, alg_hom.map_sum, alg_hom.map_mul, alg_hom.map_pow,
           aeval_C, ← algebra.smul_def, aeval_X],
  refine sub_eq_zero.mpr ((pb.basis.total_repr (pb.gen ^ pb.dim)).symm.trans _),
  rw [finsupp.total_apply, finsupp.sum_fintype];
    simp only [pb.coe_basis, zero_smul, eq_self_iff_true, implies_true_iff]
end

lemma dim_le_nat_degree_of_root (h : power_basis A S) {p : A[X]}
  (ne_zero : p ≠ 0) (root : aeval h.gen p = 0) :
  h.dim ≤ p.nat_degree :=
begin
  refine le_of_not_lt (λ hlt, ne_zero _),
  let p_coeff : fin (h.dim) → A := λ i, p.coeff i,
  suffices : ∀ i, p_coeff i = 0,
  { ext i,
    by_cases hi : i < h.dim,
    { exact this ⟨i, hi⟩ },
    exact coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)) },
  intro i,
  refine linear_independent_iff'.mp h.basis.linear_independent _ _ _ i (finset.mem_univ _),
  rw aeval_eq_sum_range' hlt at root,
  rw finset.sum_fin_eq_sum_range,
  convert root,
  ext i,
  split_ifs with hi,
  { simp_rw [coe_basis, p_coeff, fin.coe_mk] },
  { rw [coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)),
        zero_smul] }
end

lemma dim_le_degree_of_root (h : power_basis A S) {p : A[X]}
  (ne_zero : p ≠ 0) (root : aeval h.gen p = 0) :
  ↑h.dim ≤ p.degree :=
by { rw [degree_eq_nat_degree ne_zero, with_bot.coe_le_coe],
     exact h.dim_le_nat_degree_of_root ne_zero root }

variables [is_domain A]

@[simp]
lemma degree_minpoly_gen (pb : power_basis A S) :
  degree (minpoly_gen pb) = pb.dim :=
begin
  unfold minpoly_gen,
  rw degree_sub_eq_left_of_degree_lt; rw degree_X_pow,
  apply degree_sum_fin_lt
end

@[simp]
lemma nat_degree_minpoly_gen (pb : power_basis A S) :
  nat_degree (minpoly_gen pb) = pb.dim :=
nat_degree_eq_of_degree_eq_some pb.degree_minpoly_gen

lemma minpoly_gen_monic (pb : power_basis A S) : monic (minpoly_gen pb) :=
begin
  apply (monic_X_pow _).sub_of_left _,
  rw degree_X_pow,
  exact degree_sum_fin_lt _
end

lemma is_integral_gen (pb : power_basis A S) : is_integral A pb.gen :=
⟨minpoly_gen pb, minpoly_gen_monic pb, aeval_minpoly_gen pb⟩

@[simp]
lemma nat_degree_minpoly (pb : power_basis A S) :
  (minpoly A pb.gen).nat_degree = pb.dim :=
begin
  refine le_antisymm _
    (dim_le_nat_degree_of_root pb (minpoly.ne_zero pb.is_integral_gen) (minpoly.aeval _ _)),
  rw ← nat_degree_minpoly_gen,
  apply nat_degree_le_of_degree_le,
  rw ← degree_eq_nat_degree (minpoly_gen_monic pb).ne_zero,
  exact minpoly.min _ _ (minpoly_gen_monic pb) (aeval_minpoly_gen pb)
end

@[simp]
lemma minpoly_gen_eq [algebra K S] (pb : power_basis K S) :
  pb.minpoly_gen = minpoly K pb.gen :=
minpoly.unique K pb.gen pb.minpoly_gen_monic pb.aeval_minpoly_gen (λ p p_monic p_root,
  pb.degree_minpoly_gen.symm ▸ pb.dim_le_degree_of_root p_monic.ne_zero p_root)

end minpoly

section equiv

variables [algebra A S] {S' : Type*} [comm_ring S'] [algebra A S']

lemma nat_degree_lt_nat_degree {p q : R[X]} (hp : p ≠ 0) (hpq : p.degree < q.degree) :
  p.nat_degree < q.nat_degree :=
begin
  by_cases hq : q = 0, { rw [hq, degree_zero] at hpq, have := not_lt_bot hpq, contradiction },
  rwa [degree_eq_nat_degree hp, degree_eq_nat_degree hq, with_bot.coe_lt_coe] at hpq
end

variables [is_domain A]

lemma constr_pow_aeval (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (f : A[X]) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) (aeval pb.gen f) = aeval y f :=
begin
  rw [← aeval_mod_by_monic_eq_self_of_root (minpoly.monic pb.is_integral_gen) (minpoly.aeval _ _),
      ← @aeval_mod_by_monic_eq_self_of_root _ _ _ _ _ f _ (minpoly.monic pb.is_integral_gen) y hy],
  by_cases hf : f %ₘ minpoly A pb.gen = 0,
  { simp only [hf, alg_hom.map_zero, linear_map.map_zero] },
  have : (f %ₘ minpoly A pb.gen).nat_degree < pb.dim,
  { rw ← pb.nat_degree_minpoly,
    apply nat_degree_lt_nat_degree hf,
    exact degree_mod_by_monic_lt _ (minpoly.monic pb.is_integral_gen) },
  rw [aeval_eq_sum_range' this, aeval_eq_sum_range' this, linear_map.map_sum],
  refine finset.sum_congr rfl (λ i (hi : i ∈ finset.range pb.dim), _),
  rw finset.mem_range at hi,
  rw linear_map.map_smul,
  congr,
  rw [← fin.coe_mk hi, ← pb.basis_eq_pow ⟨i, hi⟩, basis.constr_basis]
end

lemma constr_pow_gen (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) pb.gen = y :=
by { convert pb.constr_pow_aeval hy X; rw aeval_X }

lemma constr_pow_algebra_map (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (x : A) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) (algebra_map A S x) = algebra_map A S' x :=
by { convert pb.constr_pow_aeval hy (C x); rw aeval_C }

lemma constr_pow_mul (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (x x' : S) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) (x * x') =
    pb.basis.constr A (λ i, y ^ (i : ℕ)) x * pb.basis.constr A (λ i, y ^ (i : ℕ)) x' :=
begin
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x,
  obtain ⟨g, rfl⟩ := pb.exists_eq_aeval' x',
  simp only [← aeval_mul, pb.constr_pow_aeval hy]
end

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`.

See `power_basis.lift_equiv` for a bundled equiv sending `⟨y, hy⟩` to the algebra map.
-/
noncomputable def lift (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) :
  S →ₐ[A] S' :=
{ map_one' := by { convert pb.constr_pow_algebra_map hy 1 using 2; rw ring_hom.map_one },
  map_zero' := by { convert pb.constr_pow_algebra_map hy 0 using 2; rw ring_hom.map_zero },
  map_mul' := pb.constr_pow_mul hy,
  commutes' := pb.constr_pow_algebra_map hy,
  .. pb.basis.constr A (λ i, y ^ (i : ℕ)) }

@[simp] lemma lift_gen (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) :
  pb.lift y hy pb.gen = y :=
pb.constr_pow_gen hy

@[simp] lemma lift_aeval (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) (f : A[X]) :
  pb.lift y hy (aeval pb.gen f) = aeval y f :=
pb.constr_pow_aeval hy f

/-- `pb.lift_equiv` states that roots of the minimal polynomial of `pb.gen` correspond to
maps sending `pb.gen` to that root.

This is the bundled equiv version of `power_basis.lift`.
If the codomain of the `alg_hom`s is an integral domain, then the roots form a multiset,
see `lift_equiv'` for the corresponding statement.
-/
@[simps]
noncomputable def lift_equiv (pb : power_basis A S) :
  (S →ₐ[A] S') ≃ {y : S' // aeval y (minpoly A pb.gen) = 0} :=
{ to_fun := λ f, ⟨f pb.gen, by rw [aeval_alg_hom_apply, minpoly.aeval, f.map_zero]⟩,
  inv_fun := λ y, pb.lift y y.2,
  left_inv := λ f, pb.alg_hom_ext $ lift_gen _ _ _,
  right_inv := λ y, subtype.ext $ lift_gen _ _ y.prop }

/-- `pb.lift_equiv'` states that elements of the root set of the minimal
polynomial of `pb.gen` correspond to maps sending `pb.gen` to that root. -/
@[simps {fully_applied := ff}]
noncomputable def lift_equiv' (pb : power_basis A S) :
  (S →ₐ[A] B) ≃ {y : B // y ∈ ((minpoly A pb.gen).map (algebra_map A B)).roots} :=
pb.lift_equiv.trans ((equiv.refl _).subtype_equiv (λ x,
  begin
    rw [mem_roots, is_root.def, equiv.refl_apply, ← eval₂_eq_eval_map, ← aeval_def],
    exact map_monic_ne_zero (minpoly.monic pb.is_integral_gen)
  end))

/-- There are finitely many algebra homomorphisms `S →ₐ[A] B` if `S` is of the form `A[x]`
and `B` is an integral domain. -/
noncomputable def alg_hom.fintype (pb : power_basis A S) :
  fintype (S →ₐ[A] B) :=
by letI := classical.dec_eq B; exact
fintype.of_equiv _ pb.lift_equiv'.symm

local attribute [irreducible] power_basis.lift

/-- `pb.equiv_of_root pb' h₁ h₂` is an equivalence of algebras with the same power basis,
where "the same" means that `pb` is a root of `pb'`s minimal polynomial and vice versa.

See also `power_basis.equiv_of_minpoly` which takes the hypothesis that the
minimal polynomials are identical.
-/
@[simps apply {attrs := []}]
noncomputable def equiv_of_root
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
  S ≃ₐ[A] S' :=
alg_equiv.of_alg_hom
  (pb.lift pb'.gen h₂)
  (pb'.lift pb.gen h₁)
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb'.exists_eq_aeval' x, simp })
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval' x, simp })

@[simp]
lemma equiv_of_root_aeval
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0)
  (f : A[X]) :
  pb.equiv_of_root pb' h₁ h₂ (aeval pb.gen f) = aeval pb'.gen f :=
pb.lift_aeval _ h₂ _

@[simp]
lemma equiv_of_root_gen
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
  pb.equiv_of_root pb' h₁ h₂ pb.gen = pb'.gen :=
pb.lift_gen _ h₂

@[simp]
lemma equiv_of_root_symm
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
  (pb.equiv_of_root pb' h₁ h₂).symm = pb'.equiv_of_root pb h₂ h₁ :=
rfl

/-- `pb.equiv_of_minpoly pb' h` is an equivalence of algebras with the same power basis,
where "the same" means that they have identical minimal polynomials.

See also `power_basis.equiv_of_root` which takes the hypothesis that each generator is a root of the
other basis' minimal polynomial; `power_basis.equiv_root` is more general if `A` is not a field.
-/
@[simps apply {attrs := []}]
noncomputable def equiv_of_minpoly
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  S ≃ₐ[A] S' :=
pb.equiv_of_root pb' (h ▸ minpoly.aeval _ _) (h.symm ▸ minpoly.aeval _ _)

@[simp]
lemma equiv_of_minpoly_aeval
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen)
  (f : A[X]) :
  pb.equiv_of_minpoly pb' h (aeval pb.gen f) = aeval pb'.gen f :=
pb.equiv_of_root_aeval pb' _ _ _

@[simp]
lemma equiv_of_minpoly_gen
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  pb.equiv_of_minpoly pb' h pb.gen = pb'.gen :=
pb.equiv_of_root_gen pb' _ _

@[simp]
lemma equiv_of_minpoly_symm
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  (pb.equiv_of_minpoly pb' h).symm = pb'.equiv_of_minpoly pb h.symm :=
rfl

end equiv

end power_basis

open power_basis

/-- Useful lemma to show `x` generates a power basis:
the powers of `x` less than the degree of `x`'s minimal polynomial are linearly independent. -/
lemma is_integral.linear_independent_pow [algebra K S] {x : S} (hx : is_integral K x) :
  linear_independent K (λ (i : fin (minpoly K x).nat_degree), x ^ (i : ℕ)) :=
begin
  rw linear_independent_iff,
  intros p hp,
  set f : K[X] := p.sum (λ i, monomial i) with hf0,
  have f_def : ∀ (i : fin _), f.coeff i = p i,
  { intro i,
    simp only [f, finsupp.sum, coeff_monomial, finset_sum_coeff],
    rw [finset.sum_eq_single, if_pos rfl],
    { intros b _ hb,
      rw if_neg (mt (λ h, _) hb),
      exact fin.coe_injective h },
    { intro hi,
      rw if_pos rfl,
      exact finsupp.not_mem_support_iff.mp hi } },
  have f_def' : ∀ i, f.coeff i = if hi : i < _ then p ⟨i, hi⟩ else 0,
  { intro i,
    split_ifs with hi,
    { exact f_def ⟨i, hi⟩ },
    simp only [f, finsupp.sum, coeff_monomial, finset_sum_coeff],
    apply finset.sum_eq_zero,
    rintro ⟨j, hj⟩ -,
    apply if_neg (mt _ hi),
    rintro rfl,
    exact hj },
  suffices : f = 0,
  { ext i, rw [← f_def, this, coeff_zero, finsupp.zero_apply] },
  contrapose hp with hf,
  intro h,
  have : (minpoly K x).degree ≤ f.degree,
  { apply minpoly.degree_le_of_ne_zero K x hf,
    convert h,
    simp_rw [finsupp.total_apply, aeval_def, hf0, finsupp.sum, eval₂_finset_sum],
    apply finset.sum_congr rfl,
    rintro i -,
    simp only [algebra.smul_def, eval₂_monomial] },
  have : ¬ (minpoly K x).degree ≤ f.degree,
  { apply not_le_of_lt,
    rw [degree_eq_nat_degree (minpoly.ne_zero hx), degree_lt_iff_coeff_zero],
    intros i hi,
    rw [f_def' i, dif_neg],
    exact hi.not_lt },
  contradiction
end

lemma is_integral.mem_span_pow [nontrivial R] {x y : S} (hx : is_integral R x)
  (hy : ∃ f : R[X], y = aeval x f) :
  y ∈ submodule.span R (set.range (λ (i : fin (minpoly R x).nat_degree),
    x ^ (i : ℕ))) :=
begin
  obtain ⟨f, rfl⟩ := hy,
  apply mem_span_pow'.mpr _,
  have := minpoly.monic hx,
  refine ⟨f.mod_by_monic (minpoly R x),
      lt_of_lt_of_le (degree_mod_by_monic_lt _ this) degree_le_nat_degree,
      _⟩,
  conv_lhs { rw ← mod_by_monic_add_div f this },
  simp only [add_zero, zero_mul, minpoly.aeval, aeval_add, alg_hom.map_mul]
end

namespace power_basis

section map

variables {S' : Type*} [comm_ring S'] [algebra R S']

/-- `power_basis.map pb (e : S ≃ₐ[R] S')` is the power basis for `S'` generated by `e pb.gen`. -/
@[simps dim gen basis]
noncomputable def map (pb : power_basis R S) (e : S ≃ₐ[R] S') : power_basis R S' :=
{ dim := pb.dim,
  basis := pb.basis.map e.to_linear_equiv,
  gen := e pb.gen,
  basis_eq_pow :=
    λ i, by rw [basis.map_apply, pb.basis_eq_pow, e.to_linear_equiv_apply, e.map_pow] }

variables [algebra A S] [algebra A S']

@[simp]
lemma minpoly_gen_map (pb : power_basis A S) (e : S ≃ₐ[A] S') :
  (pb.map e).minpoly_gen = pb.minpoly_gen :=
by { dsimp only [minpoly_gen, map_dim], -- Turn `fin (pb.map e).dim` into `fin pb.dim`
     simp only [linear_equiv.trans_apply, map_basis, basis.map_repr,
        map_gen, alg_equiv.to_linear_equiv_apply, e.to_linear_equiv_symm, alg_equiv.map_pow,
        alg_equiv.symm_apply_apply, sub_right_inj] }

variables [is_domain A]

@[simp]
lemma equiv_of_root_map (pb : power_basis A S) (e : S ≃ₐ[A] S')
  (h₁ h₂) :
  pb.equiv_of_root (pb.map e) h₁ h₂ = e :=
by { ext x, obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x, simp [aeval_alg_equiv] }

@[simp]
lemma equiv_of_minpoly_map (pb : power_basis A S) (e : S ≃ₐ[A] S')
  (h : minpoly A pb.gen = minpoly A (pb.map e).gen) :
  pb.equiv_of_minpoly (pb.map e) h = e :=
pb.equiv_of_root_map _ _ _

end map

section adjoin

open algebra

lemma adjoin_gen_eq_top (B : power_basis R S) : adjoin R ({B.gen} : set S) = ⊤ :=
begin
  rw [← to_submodule_eq_top, _root_.eq_top_iff, ← B.basis.span_eq, submodule.span_le],
  rintros x ⟨i, rfl⟩,
  rw [B.basis_eq_pow i],
  exact subalgebra.pow_mem _ (subset_adjoin (set.mem_singleton _)) _,
end

lemma adjoin_eq_top_of_gen_mem_adjoin {B : power_basis R S} {x : S}
  (hx : B.gen ∈ adjoin R ({x} : set S)) : adjoin R ({x} : set S) = ⊤ :=
begin
  rw [_root_.eq_top_iff, ← B.adjoin_gen_eq_top],
  refine adjoin_le _,
  simp [hx],
end

end adjoin

end power_basis