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

! This file was ported from Lean 3 source module linear_algebra.annihilating_polynomial
! leanprover-community/mathlib commit d3e8e0a0237c10c2627bf52c246b15ff8e7df4c0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.FieldTheory.Minpoly.Field
import Mathbin.RingTheory.PrincipalIdealDomain

/-!
# Annihilating Ideal

Given a commutative ring `R` and an `R`-algebra `A`
Every element `a : A` defines
an ideal `polynomial.ann_ideal a ⊆ R[X]`.
Simply put, this is the set of polynomials `p` where
the polynomial evaluation `p(a)` is 0.

## Special case where the ground ring is a field

In the special case that `R` is a field, we use the notation `R = 𝕜`.
Here `𝕜[X]` is a PID, so there is a polynomial `g ∈ polynomial.ann_ideal a`
which generates the ideal. We show that if this generator is
chosen to be monic, then it is the minimal polynomial of `a`,
as defined in `field_theory.minpoly`.

## Special case: endomorphism algebra

Given an `R`-module `M` (`[add_comm_group M] [module R M]`)
there are some common specializations which may be more familiar.
* Example 1: `A = M →ₗ[R] M`, the endomorphism algebra of an `R`-module M.
* Example 2: `A = n × n` matrices with entries in `R`.
-/

open Polynomial

namespace Polynomial

section Semiring

variable {R A : Type _} [CommSemiring R] [Semiring A] [Algebra R A]

variable (R)

/-- `ann_ideal R a` is the *annihilating ideal* of all `p : R[X]` such that `p(a) = 0`.

The informal notation `p(a)` stand for `polynomial.aeval a p`.
Again informally, the annihilating ideal of `a` is
`{ p ∈ R[X] | p(a) = 0 }`. This is an ideal in `R[X]`.
The formal definition uses the kernel of the aeval map. -/
noncomputable def annIdeal (a : A) : Ideal R[X] :=
  ((aeval a).toRingHom : R[X] →+* A).ker
#align polynomial.ann_ideal Polynomial.annIdeal

variable {R}

/-- It is useful to refer to ideal membership sometimes
 and the annihilation condition other times. -/
theorem mem_annIdeal_iff_aeval_eq_zero {a : A} {p : R[X]} : p ∈ annIdeal R a ↔ aeval a p = 0 :=
  Iff.rfl
#align polynomial.mem_ann_ideal_iff_aeval_eq_zero Polynomial.mem_annIdeal_iff_aeval_eq_zero

end Semiring

section Field

variable {𝕜 A : Type _} [Field 𝕜] [Ring A] [Algebra 𝕜 A]

variable (𝕜)

open Submodule

/-- `ann_ideal_generator 𝕜 a` is the monic generator of `ann_ideal 𝕜 a`
if one exists, otherwise `0`.

Since `𝕜[X]` is a principal ideal domain there is a polynomial `g` such that
 `span 𝕜 {g} = ann_ideal a`. This picks some generator.
 We prefer the monic generator of the ideal. -/
noncomputable def annIdealGenerator (a : A) : 𝕜[X] :=
  let g := IsPrincipal.generator <| annIdeal 𝕜 a
  g * C g.leadingCoeff⁻¹
#align polynomial.ann_ideal_generator Polynomial.annIdealGenerator

section

variable {𝕜}

@[simp]
theorem annIdealGenerator_eq_zero_iff {a : A} : annIdealGenerator 𝕜 a = 0 ↔ annIdeal 𝕜 a = ⊥ := by
  simp only [ann_ideal_generator, mul_eq_zero, is_principal.eq_bot_iff_generator_eq_zero,
    Polynomial.C_eq_zero, inv_eq_zero, Polynomial.leadingCoeff_eq_zero, or_self_iff]
#align polynomial.ann_ideal_generator_eq_zero_iff Polynomial.annIdealGenerator_eq_zero_iff

end

/-- `ann_ideal_generator 𝕜 a` is indeed a generator. -/
@[simp]
theorem span_singleton_annIdealGenerator (a : A) :
    Ideal.span {annIdealGenerator 𝕜 a} = annIdeal 𝕜 a :=
  by
  by_cases h : ann_ideal_generator 𝕜 a = 0
  · rw [h, ann_ideal_generator_eq_zero_iff.mp h, Set.singleton_zero, Ideal.span_zero]
  · rw [ann_ideal_generator, Ideal.span_singleton_mul_right_unit, Ideal.span_singleton_generator]
    apply polynomial.is_unit_C.mpr
    apply IsUnit.mk0
    apply inv_eq_zero.not.mpr
    apply polynomial.leading_coeff_eq_zero.not.mpr
    apply (mul_ne_zero_iff.mp h).1
#align polynomial.span_singleton_ann_ideal_generator Polynomial.span_singleton_annIdealGenerator

/-- The annihilating ideal generator is a member of the annihilating ideal. -/
theorem annIdealGenerator_mem (a : A) : annIdealGenerator 𝕜 a ∈ annIdeal 𝕜 a :=
  Ideal.mul_mem_right _ _ (Submodule.IsPrincipal.generator_mem _)
#align polynomial.ann_ideal_generator_mem Polynomial.annIdealGenerator_mem

theorem mem_iff_eq_smul_annIdealGenerator {p : 𝕜[X]} (a : A) :
    p ∈ annIdeal 𝕜 a ↔ ∃ s : 𝕜[X], p = s • annIdealGenerator 𝕜 a := by
  simp_rw [@eq_comm _ p, ← mem_span_singleton, ← span_singleton_ann_ideal_generator 𝕜 a, Ideal.span]
#align polynomial.mem_iff_eq_smul_ann_ideal_generator Polynomial.mem_iff_eq_smul_annIdealGenerator

/-- The generator we chose for the annihilating ideal is monic when the ideal is non-zero. -/
theorem monic_annIdealGenerator (a : A) (hg : annIdealGenerator 𝕜 a ≠ 0) :
    Monic (annIdealGenerator 𝕜 a) :=
  monic_mul_leadingCoeff_inv (mul_ne_zero_iff.mp hg).1
#align polynomial.monic_ann_ideal_generator Polynomial.monic_annIdealGenerator

/-! We are working toward showing the generator of the annihilating ideal
in the field case is the minimal polynomial. We are going to use a uniqueness
theorem of the minimal polynomial.

This is the first condition: it must annihilate the original element `a : A`. -/

theorem annIdealGenerator_aeval_eq_zero (a : A) : aeval a (annIdealGenerator 𝕜 a) = 0 :=
  mem_annIdeal_iff_aeval_eq_zero.mp (annIdealGenerator_mem 𝕜 a)
#align polynomial.ann_ideal_generator_aeval_eq_zero Polynomial.annIdealGenerator_aeval_eq_zero

variable {𝕜}

theorem mem_iff_annIdealGenerator_dvd {p : 𝕜[X]} {a : A} :
    p ∈ annIdeal 𝕜 a ↔ annIdealGenerator 𝕜 a ∣ p := by
  rw [← Ideal.mem_span_singleton, span_singleton_ann_ideal_generator]
#align polynomial.mem_iff_ann_ideal_generator_dvd Polynomial.mem_iff_annIdealGenerator_dvd

/-- The generator of the annihilating ideal has minimal degree among
 the non-zero members of the annihilating ideal -/
theorem degree_annIdealGenerator_le_of_mem (a : A) (p : 𝕜[X]) (hp : p ∈ annIdeal 𝕜 a)
    (hpn0 : p ≠ 0) : degree (annIdealGenerator 𝕜 a) ≤ degree p :=
  degree_le_of_dvd (mem_iff_annIdealGenerator_dvd.1 hp) hpn0
#align polynomial.degree_ann_ideal_generator_le_of_mem Polynomial.degree_annIdealGenerator_le_of_mem

variable (𝕜)

/-- The generator of the annihilating ideal is the minimal polynomial. -/
theorem annIdealGenerator_eq_minpoly (a : A) : annIdealGenerator 𝕜 a = minpoly 𝕜 a :=
  by
  by_cases h : ann_ideal_generator 𝕜 a = 0
  · rw [h, minpoly.eq_zero]
    rintro ⟨p, p_monic, hp : aeval a p = 0⟩
    refine' p_monic.ne_zero (ideal.mem_bot.mp _)
    simpa only [ann_ideal_generator_eq_zero_iff.mp h] using mem_ann_ideal_iff_aeval_eq_zero.mpr hp
  ·
    exact
      minpoly.unique _ _ (monic_ann_ideal_generator _ _ h) (ann_ideal_generator_aeval_eq_zero _ _)
        fun q q_monic hq =>
        degree_ann_ideal_generator_le_of_mem a q (mem_ann_ideal_iff_aeval_eq_zero.mpr hq)
          q_monic.NeZero
#align polynomial.ann_ideal_generator_eq_minpoly Polynomial.annIdealGenerator_eq_minpoly

/-- If a monic generates the annihilating ideal, it must match our choice
 of the annihilating ideal generator. -/
theorem monic_generator_eq_minpoly (a : A) (p : 𝕜[X]) (p_monic : p.Monic)
    (p_gen : Ideal.span {p} = annIdeal 𝕜 a) : annIdealGenerator 𝕜 a = p :=
  by
  by_cases h : p = 0
  · rwa [h, ann_ideal_generator_eq_zero_iff, ← p_gen, ideal.span_singleton_eq_bot.mpr]
  · rw [← span_singleton_ann_ideal_generator, Ideal.span_singleton_eq_span_singleton] at p_gen
    rw [eq_comm]
    apply eq_of_monic_of_associated p_monic _ p_gen
    · apply monic_ann_ideal_generator _ _ ((Associated.ne_zero_iff p_gen).mp h)
#align polynomial.monic_generator_eq_minpoly Polynomial.monic_generator_eq_minpoly

end Field

end Polynomial


-- Chapter 4

-- 1.
variables (α : Type) (p q : α → Prop)

-- naming:  eq = equivalence.
theorem eq1 : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=
iff.intro
  (assume h : (∀ x, p x ∧ q x),
    and.intro
      (assume z : α, (h z).left)
      (assume z : α, (h z).right))
  (assume h : (∀ x, p x) ∧ (∀ x, q x),
    show (∀ x, p x ∧ q x), from
      assume z : α, and.intro (h.left z) (h.right z))

theorem eq2 : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) :=
assume h₁ : (∀ x, p x → q x),
assume h₂ : (∀ x, p x),
  assume z : α, (h₁ z) (h₂ z)

theorem eq3 : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x :=
assume h₁ : (∀ x, p x) ∨ (∀ x, q x),
assume z : α,
  or.elim h₁
    (assume hpx : (∀ x, p x), or.inl (hpx z))
    (assume hqx : (∀ x, q x), or.inr (hqx z))

-- 2.
-- variables (α : Type) (p q : α → Prop)
variable r : Prop
open classical

--naming: two{1,2,3}

theorem two1 : α → ((∀ x : α, r) ↔ r) :=
(assume z : α,
  iff.intro
    (assume h₁ : (∀ x : α, r), h₁ z)
    (assume hr : r, assume z : α, hr))

theorem two2 : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
iff.intro
  (assume h₁ : (∀ x, p x ∨ r),
    or.elim (em r)
      (assume hr : r,
        or.inr hr)
      (assume hnr : ¬r,
      -- this next bit took an hour. my god.
      or.inl (assume z : α,
        (h₁ z).elim
          (assume hpz : p z, hpz)
          (assume hr : r, absurd hr hnr))))
  (assume h₂ : (∀ x, p x) ∨ r,
    h₂.elim
      (assume hpx : ∀ x, p x,
        assume z : α, or.inl (hpx z))
      (assume hr : r,
        assume z : α, or.inr hr))

theorem two3 : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
iff.intro
  (assume h₁ : (∀ x, r → p x),
    show (r → ∀ x, p x), from
      assume hr : r,
      assume z : α,
      have hpz : p z, from (h₁ z) hr,
    hpz)
  (assume h₂ : (r → ∀ x, p x),
    show (∀ x, r → p x), from
      assume z : α,
      assume hr : r,
      have hpz : p z, from (h₂ hr) z,
      hpz)

-- 3. Barber Paradox
variables (men : Type) (barber : men)
variable  (shaves : men → men → Prop)

-- theorem barber1 (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : false :=

-- -- 4 / 5.
-- namespace hidden

-- def divides (m n : ℕ) : Prop := ∃ k, m * k = n

-- instance : has_dvd nat := ⟨divides⟩

-- def even (n : ℕ) : Prop := 2 ∣ n -- You can enter the '∣' character by typing \mid

-- section
--   variables m n : ℕ

--   #check m ∣ n
--   #check m^n
--   #check even (m^n +3)
-- end

-- end hidden

-- def prime (n : ℕ) : Prop := sorry

-- def infinitely_many_primes : Prop := sorry

-- def Fermat_prime (n : ℕ) : Prop := sorry

-- def infinitely_many_Fermat_primes : Prop := sorry

-- def goldbach_conjecture : Prop := sorry

-- def Goldbach's_weak_conjecture : Prop := sorry

-- def Fermat's_last_theorem : Prop := sorry

-- -- 6.
-- variables (real : Type) [ordered_ring real]
-- variables (log exp : real → real)
-- variable  log_exp_eq : ∀ x, log (exp x) = x
-- variable  exp_log_eq : ∀ {x}, x > 0 → exp (log x) = x
-- variable  exp_pos    : ∀ x, exp x > 0
-- variable  exp_add    : ∀ x y, exp (x + y) = exp x * exp y

-- -- this ensures the assumptions are available in tactic proofs
-- include log_exp_eq exp_log_eq exp_pos exp_add

-- example (x y z : real) :
--   exp (x + y + z) = exp x * exp y * exp z :=
-- by rw [exp_add, exp_add]

-- example (y : real) (h : y > 0)  : exp (log y) = y :=
-- exp_log_eq h

-- theorem log_mul {x y : real} (hx : x > 0) (hy : y > 0) :
--   log (x * y) = log x + log y :=
-- sorry

-- -- 7.
-- #check sub_self

-- example (x : ℤ) : x * 0 = 0 :=
-- sorry


-- Considerarei um grafo de 4 vértices A, B, C, D, com arestas AB, BC, AD e BD
-- Veja que um caminho Hamiltoniano possível é D -> A -> B -> C
-- Farei A = 1, B = 2, C = 3, D = 4
-- Logo G = ((1,2),(2,3),(1,4),(2,4))

-- Lembrando que xij é: a i-ésima posição no caminho é ocupada pelo j-ésimo nó.

variables {x11 x12 x13 x14 x21 x22 x23 x24 x31 x32 x33 x34 x41 x42 x43 x44: Prop}

-- Quero provar que esse caminho é Hamiltoniano, logo essa sequência de "And's" é satisfeita.
variable path:  x14 ∧ x21 ∧ x32 ∧ x43

-- Também queremos que:
variable not_path: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                   ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44

-- Vou demostrar que esse caminho satisfaz todas as condições
-- Cada nó ocupa uma posição.
lemma condition1 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                 ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(x11 ∨ x21 ∨ x31 ∨ x41) ∧ (x12 ∨ x22 ∨ x32 ∨ x42) ∧ (x13 ∨ x23 ∨ x33 ∨ x43) ∧ (x14 ∨ x24 ∨ x34 ∨ x44) :=
have h1: (x11 ∨ x21 ∨ x31 ∨ x41), from or.inr (or.inl p.right.left),
have h2: (x12 ∨ x22 ∨ x32 ∨ x42), from or.inr (or.inr (or.inl (p.right.right.left))),
have h3: (x13 ∨ x23 ∨ x33 ∨ x43), from or.inr (or.inr (or.inr (p.right.right.right))),
have h4: (x14 ∨ x24 ∨ x34 ∨ x44), from or.inl p.left,
show (x11 ∨ x21 ∨ x31 ∨ x41) ∧ (x12 ∨ x22 ∨ x32 ∨ x42) ∧
     (x13 ∨ x23 ∨ x33 ∨ x43) ∧ (x14 ∨ x24 ∨ x34 ∨ x44),
     from  and.intro h1 (and.intro h2 (and.intro h3 h4))

-- o nó não pode ocupar duas posições.
lemma condition2_node1 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x12 ∨ ¬ x22) ∧ (¬ x12 ∨ ¬ x32) ∧ (¬ x12 ∨ ¬ x42) ∧ (¬ x22 ∨ ¬ x32) ∧ (¬ x22 ∨ ¬ x42) ∧ (¬ x32 ∨ ¬ x42) :=
have h1: ¬ x12, from np.right.left,
have h2: ¬ x22, from np.right.right.right.left,
have h3: ¬ x42, from np.right.right.right.right.right.right.right.right.right.right.left,
show  (¬ x12 ∨ ¬ x22) ∧ (¬ x12 ∨ ¬ x32) ∧ (¬ x12 ∨ ¬ x42) ∧
      (¬ x22 ∨ ¬ x32) ∧ (¬ x22 ∨ ¬ x42) ∧ (¬ x32 ∨ ¬ x42),
      from and.intro (or.inl h1) (and.intro (or.inl h1) (and.intro (or.inl h1)
           (and.intro (or.inl h2) (and.intro (or.inr h3) (or.inr h3)))))

lemma condition2_node2 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x11 ∨ ¬ x21) ∧ (¬ x11 ∨ ¬ x31) ∧ (¬ x11 ∨ ¬ x41) ∧ (¬ x21 ∨ ¬ x31) ∧ (¬ x21 ∨ ¬ x41) ∧ (¬ x31 ∨ ¬ x41) :=
have h1: ¬ x11, from np.left,
have h2: ¬ x31, from np.right.right.right.right.right.right.left,
have h3: ¬ x41, from np.right.right.right.right.right.right.right.right.right.left,
show  (¬ x11 ∨ ¬ x21) ∧ (¬ x11 ∨ ¬ x31) ∧ (¬ x11 ∨ ¬ x41) ∧
      (¬ x21 ∨ ¬ x31) ∧ (¬ x21 ∨ ¬ x41) ∧ (¬ x31 ∨ ¬ x41),
      from and.intro (or.inl h1) (and.intro (or.inl h1) (and.intro (or.inl h1)
           (and.intro (or.inr h2) (and.intro (or.inr h3) (or.inl h2)))))

lemma condition2_node3 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x13 ∨ ¬ x23) ∧ (¬ x13 ∨ ¬ x33) ∧ (¬ x13 ∨ ¬ x43) ∧ (¬ x23 ∨ ¬ x33) ∧ (¬ x23 ∨ ¬ x43) ∧ (¬ x33 ∨ ¬ x43) :=
have h1: ¬ x13, from np.right.right.left,
have h2: ¬ x23, from np.right.right.right.right.left,
have h3: ¬ x33, from np.right.right.right.right.right.right.right.left,
show  (¬ x13 ∨ ¬ x23) ∧ (¬ x13 ∨ ¬ x33) ∧ (¬ x13 ∨ ¬ x43) ∧
      (¬ x23 ∨ ¬ x33) ∧ (¬ x23 ∨ ¬ x43) ∧ (¬ x33 ∨ ¬ x43),
      from and.intro (or.inl h1) (and.intro (or.inl h1) (and.intro (or.inl h1)
           (and.intro (or.inl h2) (and.intro (or.inl h2) (or.inl h3)))))

lemma condition2_node4 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x14 ∨ ¬ x24) ∧ (¬ x14 ∨ ¬ x34) ∧ (¬ x14 ∨ ¬ x44) ∧ (¬ x24 ∨ ¬ x34) ∧ (¬ x24 ∨ ¬ x44) ∧ (¬ x34 ∨ ¬ x44) :=
have h1: ¬ x24, from np.right.right.right.right.right.left,
have h2: ¬ x34, from np.right.right.right.right.right.right.right.right.left,
have h3: ¬ x44, from np.right.right.right.right.right.right.right.right.right.right.right,
show  (¬ x14 ∨ ¬ x24) ∧ (¬ x14 ∨ ¬ x34) ∧ (¬ x14 ∨ ¬ x44) ∧
      (¬ x24 ∨ ¬ x34) ∧ (¬ x24 ∨ ¬ x44) ∧ (¬ x34 ∨ ¬ x44),
      from and.intro (or.inr h1) (and.intro (or.inr h2) (and.intro (or.inr h3)
           (and.intro (or.inl h1) (and.intro (or.inr h3) (or.inl h2)))))

-- Cada posição deve ser ocupada por um nó
lemma condition3 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                 ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(x11 ∨ x12 ∨ x13 ∨ x14) ∧ (x21 ∨ x22 ∨ x23 ∨ x24) ∧ (x31 ∨ x32 ∨ x33 ∨ x34) ∧ (x41 ∨ x42 ∨ x43 ∨ x44) :=
show (x11 ∨ x12 ∨ x13 ∨ x14) ∧ (x21 ∨ x22 ∨ x23 ∨ x24) ∧
     (x31 ∨ x32 ∨ x33 ∨ x34) ∧ (x41 ∨ x42 ∨ x43 ∨ x44),
     from and.intro (or.inr(or.inr(or.inr(p.left))))
                    (and.intro (or.inl(p.right.left))
                               (and.intro (or.inr(or.inl(p.right.right.left)))
                                          (or.inr(or.inr(or.inl(p.right.right.right))))))

-- Cada posição pode ser ocupada po apenas um nó.
lemma condition4_position1 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x11 ∨ ¬ x12) ∧ (¬ x11 ∨ ¬ x13) ∧ (¬ x11 ∨ ¬ x14) ∧ (¬ x12 ∨ ¬ x13) ∧ (¬ x12 ∨ ¬ x14) ∧ (¬ x13 ∨ ¬ x14) :=
have h1: ¬ x11, from np.left,
have h2: ¬ x12, from np.right.left,
have h3: ¬ x13, from np.right.right.left,
show  (¬ x11 ∨ ¬ x12) ∧ (¬ x11 ∨ ¬ x13) ∧ (¬ x11 ∨ ¬ x14) ∧
      (¬ x12 ∨ ¬ x13) ∧ (¬ x12 ∨ ¬ x14) ∧ (¬ x13 ∨ ¬ x14),
      from and.intro (or.inl h1) (and.intro (or.inl h1) (and.intro (or.inl h1)
           (and.intro (or.inl h2) (and.intro (or.inl h2) (or.inl h3)))))

lemma condition4_position2 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x21 ∨ ¬ x22) ∧ (¬ x21 ∨ ¬ x23) ∧ (¬ x21 ∨ ¬ x24) ∧ (¬ x22 ∨ ¬ x23) ∧ (¬ x22 ∨ ¬ x24) ∧ (¬ x23 ∨ ¬ x24) :=
have h1: ¬ x22, from np.right.right.right.left,
have h2: ¬ x23, from np.right.right.right.right.left,
have h3: ¬ x24, from np.right.right.right.right.right.left,
show  (¬ x21 ∨ ¬ x22) ∧ (¬ x21 ∨ ¬ x23) ∧ (¬ x21 ∨ ¬ x24) ∧
      (¬ x22 ∨ ¬ x23) ∧ (¬ x22 ∨ ¬ x24) ∧ (¬ x23 ∨ ¬ x24),
      from and.intro (or.inr h1) (and.intro (or.inr h2) (and.intro (or.inr h3)
           (and.intro (or.inl h1) (and.intro (or.inl h1) (or.inl h2)))))

lemma condition4_position3 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x31 ∨ ¬ x32) ∧ (¬ x31 ∨ ¬ x33) ∧ (¬ x31 ∨ ¬ x34) ∧ (¬ x32 ∨ ¬ x33) ∧ (¬ x32 ∨ ¬ x34) ∧ (¬ x33 ∨ ¬ x34) :=
have h1: ¬ x31, from np.right.right.right.right.right.right.left,
have h2: ¬ x33, from np.right.right.right.right.right.right.right.left,
have h3: ¬ x34, from np.right.right.right.right.right.right.right.right.left,
show  (¬ x31 ∨ ¬ x32) ∧ (¬ x31 ∨ ¬ x33) ∧ (¬ x31 ∨ ¬ x34) ∧
      (¬ x32 ∨ ¬ x33) ∧ (¬ x32 ∨ ¬ x34) ∧ (¬ x33 ∨ ¬ x34),
      from and.intro (or.inl h1) (and.intro (or.inl h1) (and.intro (or.inl h1)
           (and.intro (or.inr h2) (and.intro (or.inr h3) (or.inr h3)))))

lemma condition4_position4 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x41 ∨ ¬ x42) ∧ (¬ x41 ∨ ¬ x43) ∧ (¬ x41 ∨ ¬ x44) ∧ (¬ x42 ∨ ¬ x43) ∧ (¬ x42 ∨ ¬ x44) ∧ (¬ x43 ∨ ¬ x44) :=
have h1: ¬ x41, from np.right.right.right.right.right.right.right.right.right.left,
have h2: ¬ x42, from np.right.right.right.right.right.right.right.right.right.right.left,
have h3: ¬ x44, from np.right.right.right.right.right.right.right.right.right.right.right,
show  (¬ x41 ∨ ¬ x42) ∧ (¬ x41 ∨ ¬ x43) ∧ (¬ x41 ∨ ¬ x44) ∧
      (¬ x42 ∨ ¬ x43) ∧ (¬ x42 ∨ ¬ x44) ∧ (¬ x43 ∨ ¬ x44),
      from and.intro (or.inl h1) (and.intro (or.inl h1) (and.intro (or.inl h1)
           (and.intro (or.inl h2) (and.intro (or.inl h2) (or.inr h3)))))

-- (1,3) e (3,4) não pertencem ao grafo, portanto não podem ser subsequentes.
-- Nós não adjacentes não podem fazer parte do caminho de forma adjacente.
lemma condition5_13 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x11 ∨ ¬ x23) ∧ (¬ x21 ∨ ¬ x33) ∧ (¬ x31 ∨ ¬ x43) ∧  (¬ x13 ∨ ¬ x21) ∧ (¬ x23 ∨ ¬ x31) ∧ (¬ x33 ∨ ¬ x41) :=
have h1: ¬ x11, from np.left,
have h2: ¬ x13, from np.right.right.left,
have h3: ¬ x31, from np.right.right.right.right.right.right.left,
have h4: ¬ x33, from np.right.right.right.right.right.right.right.left,
show (¬ x11 ∨ ¬ x23) ∧ (¬ x21 ∨ ¬ x33) ∧ (¬ x31 ∨ ¬ x43) ∧
     (¬ x13 ∨ ¬ x21) ∧ (¬ x23 ∨ ¬ x31) ∧ (¬ x33 ∨ ¬ x41),
     from and.intro (or.inl h1) (and.intro (or.inr h4) (and.intro (or.inl h3)
             (and.intro (or.inl h2) (and.intro (or.inr h3) (or.inl h4)))))

lemma condition5_34 (p: x14 ∧ x21 ∧ x32 ∧ x43) (np: ¬ x11 ∧ ¬ x12 ∧ ¬ x13 ∧ ¬ x22 ∧ ¬ x23 ∧ ¬ x24 ∧
                                                       ¬ x31 ∧ ¬ x33 ∧ ¬ x34 ∧ ¬ x41 ∧ ¬ x42 ∧ ¬ x44) :
(¬ x13 ∨ ¬ x24) ∧ (¬ x23 ∨ ¬ x34) ∧ (¬ x33 ∨ ¬ x44) ∧  (¬ x14 ∨ ¬ x23) ∧ (¬ x24 ∨ ¬ x33) ∧ (¬ x34 ∨ ¬ x43) :=
have h1: ¬ x13, from np.right.right.left,
have h2: ¬ x23, from np.right.right.right.right.left,
have h3: ¬ x33, from np.right.right.right.right.right.right.right.left,
have h4: ¬ x34, from np.right.right.right.right.right.right.right.right.left,
show (¬ x13 ∨ ¬ x24) ∧ (¬ x23 ∨ ¬ x34) ∧ (¬ x33 ∨ ¬ x44) ∧
     (¬ x14 ∨ ¬ x23) ∧ (¬ x24 ∨ ¬ x33) ∧ (¬ x34 ∨ ¬ x43),
     from and.intro (or.inl h1) (and.intro (or.inl h2) (and.intro (or.inl h3)
             (and.intro (or.inr h2) (and.intro (or.inr h3) (or.inl h4)))))


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

! This file was ported from Lean 3 source module data.set.intervals.ord_connected
! leanprover-community/mathlib commit 76de8ae01554c3b37d66544866659ff174e66e1f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Intervals.UnorderedInterval
import Mathlib.Data.Set.Lattice
import Mathlib.Order.Antichain

/-!
# Order-connected sets

We say that a set `s : Set α` is `OrdConnected` if for all `x y ∈ s` it includes the
interval `[[x, y]]`. If `α` is a `DenselyOrdered` `ConditionallyCompleteLinearOrder` with
the `OrderTopology`, then this condition is equivalent to `IsPreconnected s`. If `α` is a
`LinearOrderedField`, then this condition is also equivalent to `Convex α s`.

In this file we prove that intersection of a family of `OrdConnected` sets is `OrdConnected` and
that all standard intervals are `OrdConnected`.
-/

open Interval

open OrderDual (toDual ofDual)

namespace Set

section Preorder

variable {α β : Type _} [Preorder α] [Preorder β] {s t : Set α}

/-- We say that a set `s : Set α` is `OrdConnected` if for all `x y ∈ s` it includes the
interval `[[x, y]]`. If `α` is a `DenselyOrdered` `ConditionallyCompleteLinearOrder` with
the `OrderTopology`, then this condition is equivalent to `IsPreconnected s`. If `α` is a
`LinearOrderedField`, then this condition is also equivalent to `Convex α s`. -/
class OrdConnected (s : Set α) : Prop where
  /-- `s : Set α` is `OrdConnected` if for all `x y ∈ s` it includes the interval `[[x, y]]`. -/
  out' ⦃x⦄ (hx : x ∈ s) ⦃y⦄ (hy : y ∈ s) : Icc x y ⊆ s
#align set.ord_connected Set.OrdConnected

theorem OrdConnected.out (h : OrdConnected s) : ∀ ⦃x⦄ (_ : x ∈ s) ⦃y⦄ (_ : y ∈ s), Icc x y ⊆ s :=
  h.1
#align set.ord_connected.out Set.OrdConnected.out

theorem ordConnected_def : OrdConnected s ↔ ∀ ⦃x⦄ (_ : x ∈ s) ⦃y⦄ (_ : y ∈ s), Icc x y ⊆ s :=
  ⟨fun h => h.1, fun h => ⟨h⟩⟩
#align set.ord_connected_def Set.ordConnected_def

/-- It suffices to prove `[[x, y]] ⊆ s` for `x y ∈ s`, `x ≤ y`. -/
theorem ordConnected_iff : OrdConnected s ↔ ∀ x ∈ s, ∀ y ∈ s, x ≤ y → Icc x y ⊆ s :=
  ordConnected_def.trans
    ⟨fun hs _ hx _ hy _ => hs hx hy, fun H x hx y hy _ hz => H x hx y hy (le_trans hz.1 hz.2) hz⟩
#align set.ord_connected_iff Set.ordConnected_iff

theorem ordConnected_of_Ioo {α : Type _} [PartialOrder α] {s : Set α}
    (hs : ∀ x ∈ s, ∀ y ∈ s, x < y → Ioo x y ⊆ s) : OrdConnected s := by
  rw [ordConnected_iff]
  intro x hx y hy hxy
  rcases eq_or_lt_of_le hxy with (rfl | hxy'); · simpa
  rw [← Ioc_insert_left hxy, ← Ioo_insert_right hxy']
  exact insert_subset.2 ⟨hx, insert_subset.2 ⟨hy, hs x hx y hy hxy'⟩⟩
#align set.ord_connected_of_Ioo Set.ordConnected_of_Ioo

theorem OrdConnected.preimage_mono {f : β → α} (hs : OrdConnected s) (hf : Monotone f) :
    OrdConnected (f ⁻¹' s) :=
  ⟨fun _ hx _ hy _ hz => hs.out hx hy ⟨hf hz.1, hf hz.2⟩⟩
#align set.ord_connected.preimage_mono Set.OrdConnected.preimage_mono

theorem OrdConnected.preimage_anti {f : β → α} (hs : OrdConnected s) (hf : Antitone f) :
    OrdConnected (f ⁻¹' s) :=
  ⟨fun _ hx _ hy _ hz => hs.out hy hx ⟨hf hz.2, hf hz.1⟩⟩
#align set.ord_connected.preimage_anti Set.OrdConnected.preimage_anti

protected theorem Icc_subset (s : Set α) [hs : OrdConnected s] {x y} (hx : x ∈ s) (hy : y ∈ s) :
    Icc x y ⊆ s :=
  hs.out hx hy
#align set.Icc_subset Set.Icc_subset

theorem OrdConnected.inter {s t : Set α} (hs : OrdConnected s) (ht : OrdConnected t) :
    OrdConnected (s ∩ t) :=
  ⟨fun _ hx _ hy => subset_inter (hs.out hx.1 hy.1) (ht.out hx.2 hy.2)⟩
#align set.ord_connected.inter Set.OrdConnected.inter

instance OrdConnected.inter' {s t : Set α} [OrdConnected s] [OrdConnected t] :
    OrdConnected (s ∩ t) :=
  OrdConnected.inter ‹_› ‹_›
#align set.ord_connected.inter' Set.OrdConnected.inter'

theorem OrdConnected.dual {s : Set α} (hs : OrdConnected s) :
    OrdConnected (OrderDual.ofDual ⁻¹' s) :=
  ⟨fun _ hx _ hy _ hz => hs.out hy hx ⟨hz.2, hz.1⟩⟩
#align set.ord_connected.dual Set.OrdConnected.dual

theorem ordConnected_dual {s : Set α} : OrdConnected (OrderDual.ofDual ⁻¹' s) ↔ OrdConnected s :=
  ⟨fun h => by simpa only [ordConnected_def] using h.dual, fun h => h.dual⟩
#align set.ord_connected_dual Set.ordConnected_dual

theorem ordConnected_interₛ {S : Set (Set α)} (hS : ∀ s ∈ S, OrdConnected s) :
    OrdConnected (⋂₀ S) :=
  ⟨fun _ hx _ hy => subset_interₛ fun s hs => (hS s hs).out (hx s hs) (hy s hs)⟩
#align set.ord_connected_sInter Set.ordConnected_interₛ

theorem ordConnected_interᵢ {ι : Sort _} {s : ι → Set α} (hs : ∀ i, OrdConnected (s i)) :
    OrdConnected (⋂ i, s i) :=
  ordConnected_interₛ <| forall_range_iff.2 hs
#align set.ord_connected_Inter Set.ordConnected_interᵢ

instance ordConnected_interᵢ' {ι : Sort _} {s : ι → Set α} [∀ i, OrdConnected (s i)] :
    OrdConnected (⋂ i, s i) :=
  ordConnected_interᵢ ‹_›
#align set.ord_connected_Inter' Set.ordConnected_interᵢ'

/- ./././Mathport/Syntax/Translate/Expr.lean:107:6: warning: expanding binder group (i hi) -/
theorem ordConnected_binterᵢ  {ι : Sort _} {p : ι → Prop} {s : ∀ (i : ι) (_ : p i), Set α}
    (hs : ∀ i hi, OrdConnected (s i hi)) : OrdConnected (⋂ (i) (hi), s i hi) :=
  ordConnected_interᵢ fun i => ordConnected_interᵢ <| hs i
#align set.ord_connected_bInter Set.ordConnected_binterᵢ

theorem ordConnected_pi {ι : Type _} {α : ι → Type _} [∀ i, Preorder (α i)] {s : Set ι}
    {t : ∀ i, Set (α i)} (h : ∀ i ∈ s, OrdConnected (t i)) : OrdConnected (s.pi t) :=
  ⟨fun _ hx _ hy _ hz i hi => (h i hi).out (hx i hi) (hy i hi) ⟨hz.1 i, hz.2 i⟩⟩
#align set.ord_connected_pi Set.ordConnected_pi

instance ordConnected_pi' {ι : Type _} {α : ι → Type _} [∀ i, Preorder (α i)] {s : Set ι}
    {t : ∀ i, Set (α i)} [h : ∀ i, OrdConnected (t i)] : OrdConnected (s.pi t) :=
  ordConnected_pi fun i _ => h i
#align set.ord_connected_pi' Set.ordConnected_pi'

@[instance]
theorem ordConnected_Ici {a : α} : OrdConnected (Ici a) :=
  ⟨fun _ hx _ _ _ hz => le_trans hx hz.1⟩
#align set.ord_connected_Ici Set.ordConnected_Ici

@[instance]
theorem ordConnected_Iic {a : α} : OrdConnected (Iic a) :=
  ⟨fun _ _ _ hy _ hz => le_trans hz.2 hy⟩
#align set.ord_connected_Iic Set.ordConnected_Iic

@[instance]
theorem ordConnected_Ioi {a : α} : OrdConnected (Ioi a) :=
  ⟨fun _ hx _ _ _ hz => lt_of_lt_of_le hx hz.1⟩
#align set.ord_connected_Ioi Set.ordConnected_Ioi

@[instance]
theorem ordConnected_Iio {a : α} : OrdConnected (Iio a) :=
  ⟨fun _ _ _ hy _ hz => lt_of_le_of_lt hz.2 hy⟩
#align set.ord_connected_Iio Set.ordConnected_Iio

@[instance]
theorem ordConnected_Icc {a b : α} : OrdConnected (Icc a b) :=
  ordConnected_Ici.inter ordConnected_Iic
#align set.ord_connected_Icc Set.ordConnected_Icc

@[instance]
theorem ordConnected_Ico {a b : α} : OrdConnected (Ico a b) :=
  ordConnected_Ici.inter ordConnected_Iio
#align set.ord_connected_Ico Set.ordConnected_Ico

@[instance]
theorem ordConnected_Ioc {a b : α} : OrdConnected (Ioc a b) :=
  ordConnected_Ioi.inter ordConnected_Iic
#align set.ord_connected_Ioc Set.ordConnected_Ioc

@[instance]
theorem ordConnected_Ioo {a b : α} : OrdConnected (Ioo a b) :=
  ordConnected_Ioi.inter ordConnected_Iio
#align set.ord_connected_Ioo Set.ordConnected_Ioo

@[instance]
theorem ordConnected_singleton {α : Type _} [PartialOrder α] {a : α} :
    OrdConnected ({a} : Set α) := by
  rw [← Icc_self]
  exact ordConnected_Icc
#align set.ord_connected_singleton Set.ordConnected_singleton

@[instance]
theorem ordConnected_empty : OrdConnected (∅ : Set α) :=
  ⟨fun _ => False.elim⟩
#align set.ord_connected_empty Set.ordConnected_empty

@[instance]
theorem ordConnected_univ : OrdConnected (univ : Set α) :=
  ⟨fun _ _ _ _ => subset_univ _⟩
#align set.ord_connected_univ Set.ordConnected_univ

/-- In a dense order `α`, the subtype from an `OrdConnected` set is also densely ordered. -/
instance [DenselyOrdered α] {s : Set α} [hs : OrdConnected s] : DenselyOrdered s :=
  ⟨fun a b (h : (a : α) < b) =>
    let ⟨x, H⟩ := exists_between h
    ⟨⟨x, (hs.out a.2 b.2) (Ioo_subset_Icc_self H)⟩, H⟩⟩

@[instance]
theorem ordConnected_preimage {F : Type _} [OrderHomClass F α β] (f : F) {s : Set β}
    [hs : OrdConnected s] : OrdConnected (f ⁻¹' s) :=
  ⟨fun _ hx _ hy _ hz => hs.out hx hy ⟨OrderHomClass.mono _ hz.1, OrderHomClass.mono _ hz.2⟩⟩
#align set.ord_connected_preimage Set.ordConnected_preimage

@[instance]
theorem ordConnected_image {E : Type _} [OrderIsoClass E α β] (e : E) {s : Set α}
    [hs : OrdConnected s] : OrdConnected (e '' s) := by
  erw [(e : α ≃o β).image_eq_preimage]
  apply ordConnected_preimage (e : α ≃o β).symm
#align set.ord_connected_image Set.ordConnected_image

-- porting note: split up `simp_rw [← image_univ, OrdConnected_image e]`, would not work otherwise
@[instance]
theorem ordConnected_range {E : Type _} [OrderIsoClass E α β] (e : E) : OrdConnected (range e) := by
  simp_rw [← image_univ]
  exact ordConnected_image (e : α ≃o β)
#align set.ord_connected_range Set.ordConnected_range

@[simp]
theorem dual_ordConnected_iff {s : Set α} : OrdConnected (ofDual ⁻¹' s) ↔ OrdConnected s := by
  simp_rw [ordConnected_def, toDual.surjective.forall, dual_Icc, Subtype.forall']
  exact forall_swap
#align set.dual_ord_connected_iff Set.dual_ordConnected_iff

@[instance]
theorem dual_ordConnected {s : Set α} [OrdConnected s] : OrdConnected (ofDual ⁻¹' s) :=
  dual_ordConnected_iff.2 ‹_›
#align set.dual_ord_connected Set.dual_ordConnected

end Preorder

section PartialOrder

variable {α : Type _} [PartialOrder α] {s : Set α}

protected theorem _root_.IsAntichain.ordConnected (hs : IsAntichain (· ≤ ·) s) : s.OrdConnected :=
  ⟨fun x hx y hy z hz => by
    obtain rfl := hs.eq hx hy (hz.1.trans hz.2)
    rw [Icc_self, mem_singleton_iff] at hz
    rwa [hz]⟩
#align is_antichain.ord_connected IsAntichain.ordConnected

end PartialOrder

section LinearOrder

variable {α : Type _} [LinearOrder α] {s : Set α} {x : α}

@[instance]
theorem ordConnected_uIcc {a b : α} : OrdConnected [[a, b]] :=
  ordConnected_Icc
#align set.ord_connected_uIcc Set.ordConnected_uIcc

@[instance]
theorem ordConnected_uIoc {a b : α} : OrdConnected (Ι a b) :=
  ordConnected_Ioc
#align set.ord_connected_uIoc Set.ordConnected_uIoc

theorem OrdConnected.uIcc_subset (hs : OrdConnected s) ⦃x⦄ (hx : x ∈ s) ⦃y⦄ (hy : y ∈ s) :
    [[x, y]] ⊆ s :=
  hs.out (min_rec' (· ∈ s) hx hy) (max_rec' (· ∈ s) hx hy)
#align set.ord_connected.uIcc_subset Set.OrdConnected.uIcc_subset

theorem OrdConnected.uIoc_subset (hs : OrdConnected s) ⦃x⦄ (hx : x ∈ s) ⦃y⦄ (hy : y ∈ s) :
    Ι x y ⊆ s :=
  Ioc_subset_Icc_self.trans <| hs.uIcc_subset hx hy
#align set.ord_connected.uIoc_subset Set.OrdConnected.uIoc_subset

theorem ordConnected_iff_uIcc_subset :
    OrdConnected s ↔ ∀ ⦃x⦄ (_ : x ∈ s) ⦃y⦄ (_ : y ∈ s), [[x, y]] ⊆ s :=
  ⟨fun h => h.uIcc_subset, fun H => ⟨fun _ hx _ hy => Icc_subset_uIcc.trans <| H hx hy⟩⟩
#align set.ord_connected_iff_uIcc_subset Set.ordConnected_iff_uIcc_subset

theorem ordConnected_of_uIcc_subset_left (h : ∀ y ∈ s, [[x, y]] ⊆ s) : OrdConnected s :=
  ordConnected_iff_uIcc_subset.2 fun y hy z hz =>
    calc
      [[y, z]] ⊆ [[y, x]] ∪ [[x, z]] := uIcc_subset_uIcc_union_uIcc
      _ = [[x, y]] ∪ [[x, z]] := by rw [uIcc_comm]
      _ ⊆ s := union_subset (h y hy) (h z hz)
#align set.ord_connected_of_uIcc_subset_left Set.ordConnected_of_uIcc_subset_left

theorem ordConnected_iff_uIcc_subset_left (hx : x ∈ s) :
    OrdConnected s ↔ ∀ ⦃y⦄, y ∈ s → [[x, y]] ⊆ s :=
  ⟨fun hs => hs.uIcc_subset hx, ordConnected_of_uIcc_subset_left⟩
#align set.ord_connected_iff_uIcc_subset_left Set.ordConnected_iff_uIcc_subset_left

theorem ordConnected_iff_uIcc_subset_right (hx : x ∈ s) :
    OrdConnected s ↔ ∀ ⦃y⦄, y ∈ s → [[y, x]] ⊆ s := by
  simp_rw [ordConnected_iff_uIcc_subset_left hx, uIcc_comm]
#align set.ord_connected_iff_uIcc_subset_right Set.ordConnected_iff_uIcc_subset_right


import tactic
import data.real.basic
import algebra.quaternion
import data.matrix.notation
import linear_algebra.matrix.determinant
import linear_algebra.matrix.nonsingular_inverse

localized "notation `ℍ[` R `]` := quaternion R" in quaternion

localized "postfix `ᵀ`:1500 := matrix.transpose" in matrix

variables {R : Type*} [comm_ring R] (a b : ℍ[R])

def spin_group_3D (R : Type*) [comm_ring R] :=
{a : ℍ[R] // a.re^2 + a.im_i^2 + a.im_j^2 + a.im_k^2 = 1}

instance has_coe_to_H : has_coe (spin_group_3D R) (ℍ[R]) := ⟨λ A, A.val⟩

namespace spin_group_3D

variables (z m : spin_group_3D R) (n : Type*) [decidable_eq n] [fintype n] (k : Type*) [decidable_eq k] [fintype k]

def mul (a b : spin_group_3D R) : spin_group_3D R := ⟨a.1*b.1, begin
have h₁ := a.property,
have h₂ := b.property,
have h₃ : (a.val.re ^ 2 + a.val.im_i ^ 2 + a.val.im_j ^ 2 + a.val.im_k ^ 2)
  * (b.val.re ^ 2 + b.val.im_i ^ 2 + b.val.im_j ^ 2 + b.val.im_k ^ 2) = 1,
{rw h₁, rw h₂, norm_num,},
convert h₃,
field_simp,
ring,
end⟩

def one : spin_group_3D R := ⟨(1 : ℍ[R]), by simp⟩

def inv (a : spin_group_3D R) : spin_group_3D R := ⟨a.1.conj, by simpa using a.2⟩

def neg (a : spin_group_3D R) : spin_group_3D R := ⟨-a.1, by simpa using a.2⟩

instance : has_mul (spin_group_3D R) := ⟨mul⟩
instance : has_one (spin_group_3D R) := ⟨one⟩
instance : has_inv (spin_group_3D R) := ⟨inv⟩
instance : has_neg (spin_group_3D R) := ⟨neg⟩

lemma inv_def (a : spin_group_3D R) : a⁻¹.1 = a.1.conj := rfl

lemma mul_def (a b : spin_group_3D R) : (a * b).1 = a.1 * b.1 := rfl

instance : group (spin_group_3D R) :=
{ mul := (*),
  mul_assoc := begin
    intros a b c,
    ext1,
    apply mul_assoc, end,
  one := 1,
  one_mul := begin
    intro a,
    ext1,
    apply one_mul, end,
  mul_one := begin
    intro a, ext1, apply mul_one, end,
  inv := has_inv.inv,
  mul_left_inv :=
  begin
    intro a,
    ext1,
    unfold_coes,
    simp only [has_inv.inv, inv, mul_def],
    rw quaternion.conj_mul_self a.val,
    rw quaternion.norm_sq_def',
    simp at *,
    have h := a.2, simp at h,
    norm_cast,
    rw h, refl,
  end }

def my_special_orthogonal_group :=
  {A : matrix n n R // A.det = 1 ∧ A * Aᵀ= 1}

namespace my_special_orthogonal_group

instance has_coe_to_matrix : has_coe (@my_special_orthogonal_group R _ n _ _) (matrix n n R) :=
⟨λ A, A.val⟩

def mul' (a b : @my_special_orthogonal_group R _ n _ _)
: @my_special_orthogonal_group R _ n _ _ := ⟨a.1*b.1,
begin
  have h1 := a.2,
  have h2 := b.2,
  cases h1, cases h2, simp at *,
  split,
  { rw h1_left, rw h2_left,
    norm_num,
  },
  { repeat {rw ← matrix.mul_eq_mul},
    have h := calc
    (a:matrix n n R) * ↑b * ((↑b)ᵀ * (↑a)ᵀ) = ↑a * (↑b * (↑b)ᵀ) * ((a : matrix n n R))ᵀ : by simp [matrix.mul_assoc]
    ...                                     = ↑a * (↑a)ᵀ : by simp [h2_right],
    rw h,
    simp [h1_right],
  },
end⟩

def one' : @my_special_orthogonal_group R _ n _ _ := ⟨(1 : matrix n n R),
begin
  split,
  {simp},
  {simp}
end⟩

def inv' (a : @my_special_orthogonal_group R _ n _ _)
  : @my_special_orthogonal_group R _ n _ _ := ⟨(a.1)ᵀ,
begin
  split,
  { simp [matrix.det_transpose],
    have h := a.2, simp at h, cases h, assumption, },
  { simp,
    have h := a.2, simp at h, cases h,
    simp [matrix.mul_eq_one_comm, h_right], }
end⟩

instance : has_mul (@my_special_orthogonal_group R _ n _ _) := ⟨@mul' R _ n _ _⟩
instance : has_one (@my_special_orthogonal_group R _ n _ _) := ⟨@one' R _ n _ _⟩
instance : has_inv (@my_special_orthogonal_group R _ n _ _) := ⟨@inv' R _ n _ _⟩

lemma inv_trick (A : @my_special_orthogonal_group R _ n _ _) : A⁻¹.1 = Aᵀ := rfl

lemma mul_trick (a b : @my_special_orthogonal_group R _ n _ _) : (a * b).1 = a.1 * b.1 := rfl

instance : group (@my_special_orthogonal_group R _ n _ _) :=
{ mul := (*),
  mul_assoc :=
  begin
    intros a b c,
    ext1,
    apply matrix.mul_assoc,
  end,
  one := 1,
  one_mul :=
  begin
    intro a,
    ext1,
    apply matrix.one_mul,
  end,
  mul_one :=
  begin
    intro a,
    ext1,
    apply matrix.mul_one,
  end,
  inv := has_inv.inv,
  mul_left_inv :=
  begin
    intro a,
    ext1,
    unfold_coes,
    simp [has_inv.inv, inv', mul_trick],
    have h := a.2, simp at h, cases h,
    rw [matrix.mul_eq_one_comm] at h_right,
    convert h_right,
  end }

lemma two_to_one (q : spin_group_3D ℝ) (h : ∀ r : ℍ[ℝ], r.re = 0 → r * q = q * r):
  (q : ℍ[ℝ]) = 1 ∨ (q : ℍ[ℝ]) = -1 :=
begin
  have h1 := h,
  specialize h ⟨0, 1, 0, 0⟩,
  simp [quaternion.ext_iff] at h,
  cases h with h2 h3,
  rw [neg_eq_self_iff] at h2,
  have h4 : (q : ℍ[ℝ]).im_j = 0 := neg_eq_self_iff.mp (eq.symm h3), clear h3,
  specialize h1 ⟨0, 0, 1, 0⟩,
  simp [quaternion.ext_iff] at h1,
  cases h1 with h5 h6, clear h5,
  rw [neg_eq_self_iff] at h6,
  have h7 := q.2, simp [h2, h4, h6] at h7,
  cases h7 with h8 h9,
  { left,
    simp [quaternion.ext_iff, h2, h4, h6, h8], },
  { right,
    simp [quaternion.ext_iff, h2, h4, h6, h9], },
end

end my_special_orthogonal_group

end spin_group_3D


import mathlib.logic
import phase1.code
import phase1.f_map

/-!
# Alternative extensions

The alternative extension map, aka A-map, from `γ` to `β` sends a code of extension `γ` to its
lternative extension `β`. This will used to identify codes and construct the TTT objects.

An important property for intuition is that A-maps have disjoint ranges (except on empty codes) and
are each injective, so if we connect each code to its images under A-maps, we get a tree (except for
empty codes that form a complete graph).

## Main declarations

* `con_nf.A_map`: Alternative extension map as a map from sets of `γ`-tangles to of `β`-tangles.
  Note that `γ` can be any type index while `β` has to be a proper type index.
* `con_nf.A_map_code`: Alternative extension map as a map from codes to codes of extension `β`.
* `con_nf.A_map_rel`: The relation on codes generated by `A_map_code`. It relates `c` to `d` iff `d`
  is the image of `c` under some A-map. This relation is well-founded on **nonempty** codes. See
  `con_nf.A_map_rel'_well_founded`.

## Notation

* `c ↝ d`: `d` is the image of `c` under some A-map.
-/

noncomputable theory

open function set with_bot
open_locale cardinal

universe u

namespace con_nf
variables [params.{u}] [position_data.{}]

open code

section A_map
variables {α : Λ} {γ : Iio_index α} [core_tangle_data γ] [positioned_tangle_data γ]
  {β : Iio α} [core_tangle_data (Iio_coe β)]
  [positioned_tangle_data (Iio_coe β)] [almost_tangle_data β] (hγβ : γ ≠ β)

lemma coe_ne : γ ≠ β → (γ : type_index) ≠ (β : Λ) := subtype.coe_injective.ne

/-- The *alternative extension* map. For a set of tangles `G`, consider the code
`(α, γ, G)`. We then construct the non-empty set `D` such that `(α, β, D)` is an alternative
extension of the same object in TTT. -/
def A_map (s : set (tangle γ)) : set (tangle $ Iio_coe β) :=
typed_near_litter '' ⋃ t ∈ s, local_cardinal (f_map (coe_ne hγβ) t)

variables {β} {hγβ}

@[simp] lemma mem_A_map {t : tangle $ Iio_coe β}
  {s : set (tangle γ)} : t ∈ A_map hγβ s ↔
    ∃ (t' ∈ s) N (hN : is_near_litter (f_map (coe_ne hγβ) t') N),
      typed_near_litter ⟨_, N, hN⟩ = t :=
begin
  simp only [A_map, and_comm, mem_image, mem_Union, exists_prop],
  split,
  { rintro ⟨⟨i, N, hN⟩, rfl, t, ht₁, ⟨rfl, ht₂⟩⟩,
    exact ⟨t, ht₁, N, _, rfl⟩ },
  { rintro ⟨t, ht, N, hN, rfl⟩, cases hN,
    exact ⟨⟨f_map (coe_ne hγβ) t, N, _⟩, rfl, t, ht, rfl⟩ }
end

@[simp] lemma A_map_empty : A_map hγβ (∅ : set (tangle γ)) = ∅ :=
by simp only [A_map, Union_false, Union_empty, image_empty]

@[simp] lemma A_map_singleton (t) :
  A_map hγβ ({t} : set (tangle γ)) = typed_near_litter '' local_cardinal (f_map (coe_ne hγβ) t) :=
by simp only [A_map, mem_singleton_iff, Union_Union_eq_left]

variables {s : set (tangle γ)} {t : tangle γ}

lemma _root_.set.nonempty.A_map (h : s.nonempty) : (A_map hγβ s).nonempty :=
begin
  refine (nonempty_bUnion.2 _).image _,
  exact h.imp (λ t ht, ⟨ht, ⟨f_map (coe_ne hγβ) _, litter_set _, is_near_litter_litter_set _⟩, rfl⟩),
end

@[simp] lemma A_map_eq_empty (hγβ : γ ≠ β) : A_map hγβ s = ∅ ↔ s = ∅ :=
begin
  refine ⟨λ h, not_nonempty_iff_eq_empty.1 $ λ hs, hs.A_map.ne_empty h, _⟩,
  rintro rfl,
  exact A_map_empty,
end

@[simp] lemma A_map_nonempty (hγβ : γ ≠ β) : (A_map hγβ s).nonempty ↔ s.nonempty :=
by simp_rw [nonempty_iff_ne_empty, ne.def, A_map_eq_empty]

lemma subset_A_map (ht : t ∈ s) : typed_near_litter '' local_cardinal (f_map (coe_ne hγβ) t) ⊆ A_map hγβ s :=
image_subset _ $ subset_Union₂ t ht

lemma μ_le_mk_A_map : s.nonempty → #μ ≤ #(A_map hγβ s) :=
begin
  rintro ⟨t, ht⟩,
  refine (cardinal.mk_le_mk_of_subset $ subset_A_map ht).trans_eq' _,
  rw [cardinal.mk_image_eq, mk_local_cardinal],
  exact typed_near_litter.inj',
end

lemma A_map_injective : injective (A_map hγβ) :=
typed_near_litter.injective.image_injective.comp $ pairwise.bUnion_injective
  (λ x y h, local_cardinal_disjoint $ (f_map_injective _).ne h) $ λ _, local_cardinal_nonempty _

variables {δ : Iio_index α} [core_tangle_data δ] [positioned_tangle_data δ]
  {hδβ : (δ : type_index) ≠ (β : Λ)}

lemma A_map_disjoint_range {hδβ} (c : set (tangle γ)) (d : set (tangle δ)) (hc : c.nonempty)
  (h : A_map hγβ c = A_map hδβ d) : γ = δ :=
begin
  obtain ⟨b, hb⟩ := hc,
  have := (subset_Union₂ b hb).trans (typed_near_litter.injective.image_injective h).subset,
  obtain ⟨i, -, hi⟩ := mem_Union₂.1 (this (f_map _ b).to_near_litter_mem_local_cardinal),
  refine subtype.coe_injective _,
  exact (f_map_β (coe_ne hγβ) b).trans ((congr_arg litter.β hi).trans (f_map_β (coe_ne hδβ) i)),
end

/-!
We don't need to prove that the ranges of the `A_δ` are disjoint for different `β`, since this holds
at the type level.

We now show that there are only finitely many iterated images under any inverse A-map, in the case
of nonempty sets.
-/

variable {γ}

lemma well_founded_position : well_founded (λ a b : tangle γ, position a < position b) :=
inv_image.wf _ is_well_founded.wf

/-- The minimum tangle of a nonempty set of tangles. -/
noncomputable def min_tangle (c : set (tangle γ)) (hc : c.nonempty) : tangle γ :=
well_founded_position.min c hc

lemma min_tangle_mem (c : set (tangle γ)) (hc : c.nonempty) : min_tangle c hc ∈ c :=
well_founded.min_mem _ c hc

lemma min_tangle_le (c : set (tangle γ)) (hc : c.nonempty) {x} (hx : x ∈ c) :
  position (min_tangle c hc) ≤ position x :=
not_lt.1 $ well_founded_position.not_lt_min c hc hx

lemma A_map_order (c : set (tangle γ)) (hc : c.nonempty) :
  position (min_tangle c hc) < position (min_tangle (A_map hγβ c) hc.A_map) :=
begin
  obtain ⟨t, ht, s, hs, h⟩ := mem_A_map.1 (min_tangle_mem (A_map hγβ c) hc.A_map),
  rw ←h,
  refine (min_tangle_le c hc ht).trans_lt (f_map_position (coe_ne hγβ) t _ hs),
end

end A_map

section A_map_code
variables {α : Λ} [core_tangle_cumul α] [positioned_tangle_cumul α]

/-- Tool that lets us use well-founded recursion on codes via `μ`. -/
noncomputable def code_min_map (c : nonempty_code α) : μ := position $ min_tangle _ c.prop

/-- The pullback `<` relation on codes is well-founded. -/
lemma code_wf : well_founded (inv_image μr (code_min_map : nonempty_code α → μ)) :=
inv_image.wf (code_min_map) μwf.wf

section extension

variables [almost_tangle_cumul α] {β : Iio_index α}

/-- The A-map, phrased as a function on sets of `γ`-tangles, but if `γ = β`, this is the
identity function. This is the true alternative extension map. -/
def extension (s : set (tangle β)) (γ : Iio α) : set (tangle γ) :=
if hβγ : β = γ then cast (by rw hβγ; refl) s else A_map hβγ s

@[simp] lemma extension_self {γ : Iio α} (s : set (tangle (Iio_coe γ))) : extension s γ = s :=
dif_pos rfl

variables (s : set (tangle β)) (γ : Iio α)

@[simp] lemma extension_eq (hβγ : β = γ) : extension s γ = cast (by rw hβγ; refl) s := dif_pos hβγ
@[simp] lemma extension_ne (hβγ : β ≠ γ) : extension s γ = A_map hβγ s := dif_neg hβγ

end extension

variables [almost_tangle_cumul α] (γ : Iio_index α) (β : Iio α) (c d : code α)

/-- The A-map, phrased as a function on `α`-codes, but if the code's level matches `β`, this is the
identity function. This is written in a weird way in order to make `(A_map_code β c).1` defeq
to `β`. -/
def A_map_code (c : code α) : code α := mk β (extension c.2 β)

lemma A_map_code_eq (hcβ : c.1 = β) : A_map_code β c = c :=
begin
  rw [A_map_code, extension_eq _ _ hcβ],
  ext : 1,
  { exact hcβ.symm },
  { simp only [snd_mk, cast_heq] },
end

lemma A_map_code_ne (hcβ : c.1 ≠ β) : A_map_code β c = mk β (A_map hcβ c.2) :=
by rw [A_map_code, extension_ne _ _ hcβ]

@[simp] lemma fst_A_map_code : (A_map_code β c).1 = β := rfl

@[simp] lemma snd_A_map_code (hcβ : c.1 ≠ β) : (A_map_code β c).2 = A_map hcβ c.2 :=
begin
  have := A_map_code_ne β c hcβ,
  rw sigma.ext_iff at this,
  exact this.2.eq,
end

@[simp] lemma A_map_code_mk_eq (s) :
  A_map_code β (mk β s) = mk β s :=
by { rw A_map_code_eq, refl }

@[simp] lemma A_map_code_mk_ne (hγβ : γ ≠ β) (s) :
  A_map_code β (mk γ s) = mk β (A_map hγβ s) :=
by { rw A_map_code_ne β (mk γ s) hγβ, refl }

variables {β c d}

@[simp] lemma A_map_code_is_empty : (A_map_code β c).is_empty ↔ c.is_empty :=
begin
  obtain ⟨γ, s⟩ := c,
  by_cases γ = β,
  { rw A_map_code_eq,
    exact h },
  { rw A_map_code_ne,
    exact A_map_eq_empty h }
end

@[simp] lemma A_map_code_nonempty : (A_map_code β c).2.nonempty ↔ c.2.nonempty :=
by { simp_rw nonempty_iff_ne_empty, exact A_map_code_is_empty.not }

alias A_map_code_is_empty ↔ _ code.is_empty.A_map_code

attribute [protected] code.is_empty.A_map_code

lemma A_map_code_inj_on : {c : code α | c.1 ≠ β ∧ c.2.nonempty}.inj_on (A_map_code β) :=
begin
  rintro ⟨⟨γ, hγ⟩, s⟩ ⟨hγβ, hs⟩ ⟨⟨δ, hδ⟩, t⟩ ⟨hδβ, ht⟩ h,
  rw [A_map_code_ne _ _ hγβ, A_map_code_ne _ _ hδβ] at h,
  have := (congr_arg_heq sigma.snd h).eq,
  dsimp only at this,
  obtain rfl : γ = δ := congr_arg subtype.val (A_map_disjoint_range _ _ hs this),
  rw A_map_injective this,
end

lemma μ_le_mk_A_map_code (c : code α) (hcβ : c.1 ≠ β) : c.2.nonempty → #μ ≤ #(A_map_code β c).2 :=
by { rw A_map_code_ne β c hcβ, exact μ_le_mk_A_map }

variables (β)

lemma A_map_code_order (c : nonempty_code α) (hcβ : c.1.1 ≠ β) :
  code_min_map c < code_min_map ⟨A_map_code β c, A_map_code_nonempty.mpr c.2⟩ :=
begin
  unfold code_min_map,
  have := A_map_code_ne β c hcβ,
  convert A_map_order c.1.2 c.2 using 1,
  congr,
  exact snd_A_map_code β c hcβ,
end

/-- This relation on `α`-codes allows us to state that there are only finitely many iterated images
under the inverse A-map. Note that we require the A-map to actually change the data, by requiring
that `c.1 ≠ β`. -/
@[mk_iff] inductive A_map_rel (c : code α) : code α → Prop
| intro (β : Iio α) : c.1 ≠ β → A_map_rel (A_map_code β c)

infix ` ↝ `:62 := A_map_rel

lemma A_map_rel_subsingleton (hc : c.2.nonempty) : {d : code α | d ↝ c}.subsingleton :=
begin
  intros d hd e he,
  simp only [A_map_rel_iff] at hd he,
  obtain ⟨⟨β, hβ⟩, hdβ, rfl⟩ := hd,
  obtain ⟨⟨γ, hγ⟩, heγ, h⟩ := he,
  have := congr_arg subtype.val (sigma.ext_iff.1 h).1,
  dsimp only [fst_A_map_code, Iio.coe_mk] at this,
  rw coe_eq_coe at this,
  subst this,
  refine A_map_code_inj_on ⟨hdβ, A_map_code_nonempty.1 hc⟩ _ h,
  rw h at hc,
  exact ⟨heγ, A_map_code_nonempty.1 hc⟩,
end

lemma A_map_rel_A_map_code (hd : d.2.nonempty) (hdβ : d.1 ≠ β) :
  c ↝ A_map_code β d ↔ c = d :=
begin
  refine ⟨λ h, A_map_rel_subsingleton (by rwa A_map_code_nonempty) h $ A_map_rel.intro _ hdβ, _⟩,
  rintro rfl,
  exact ⟨_, hdβ⟩,
end

lemma A_map_rel.nonempty_iff : c ↝ d → (c.2.nonempty ↔ d.2.nonempty) :=
by { rintro ⟨β, hcβ⟩, exact A_map_code_nonempty.symm }

lemma A_map_rel_empty_empty (hγβ : γ ≠ β) : mk γ ∅ ↝ mk β ∅ :=
(A_map_rel_iff _ _).2 ⟨β, hγβ, begin
  ext : 1,
  { refl },
  { refine heq_of_eq _,
    simp only [snd_mk, snd_A_map_code _ (mk γ ∅) hγβ, A_map_empty] }
end⟩

lemma eq_of_A_map_code {β γ : Iio α} (hc : c.2.nonempty) (hcβ : c.1 ≠ β)
  (hdγ : d.1 ≠ γ) (h : A_map_code β c = A_map_code γ d) : c = d :=
begin
  refine A_map_rel_subsingleton (by rwa A_map_code_nonempty) (A_map_rel.intro _ hcβ) _,
  simp_rw h,
  exact A_map_rel.intro _ hdγ,
end

/-- This relation on `α`-codes allows us to state that there are only finitely many iterated images
under the inverse A-map. -/
@[mk_iff] inductive A_map_rel' (c : nonempty_code α) : nonempty_code α → Prop
| intro (β : Iio α) : (c : code α).1 ≠ β →
  A_map_rel' ⟨A_map_code β c, A_map_code_nonempty.mpr c.2⟩

@[simp] lemma A_map_rel_coe_coe {c d : nonempty_code α} : (c : code α) ↝ d ↔ A_map_rel' c d :=
begin
  rw [A_map_rel_iff, A_map_rel'_iff, iff.comm],
  exact exists_congr (λ β, and_congr_right' subtype.ext_iff),
end

lemma A_map_subrelation : subrelation A_map_rel' (inv_image μr (code_min_map : nonempty_code α → μ))
| c _ (A_map_rel'.intro β hc) := A_map_code_order β c hc

/-- There are only finitely many iterated images under any inverse A-map. -/
lemma A_map_rel'_well_founded : well_founded (A_map_rel' : _ → nonempty_code α → Prop) :=
A_map_subrelation.wf code_wf

instance : has_well_founded (nonempty_code α) := ⟨_, A_map_rel'_well_founded⟩

/-- There is at most one inverse under an A-map. This corresponds to the fact that there is only one
code which is related (on the left) to any given code under the A-map relation. -/
lemma A_map_rel'_subsingleton (c : nonempty_code α) :
  {d : nonempty_code α | A_map_rel' d c}.subsingleton :=
begin
  intros d hd e he,
  simp only [subtype.val_eq_coe, ne.def, A_map_rel'_iff, mem_set_of_eq] at hd he,
  obtain ⟨⟨β, hβ⟩, hdβ, rfl⟩ := hd,
  obtain ⟨⟨γ, hγ⟩, heγ, h⟩ := he,
  rw subtype.ext_iff at h,
  have := congr_arg subtype.val (sigma.ext_iff.1 h).1,
  simp only [subtype.coe_mk, fst_A_map_code, Iio.coe_mk, coe_eq_coe] at this,
  subst this,
  exact subtype.coe_injective (A_map_code_inj_on ⟨hdβ, d.2⟩ ⟨heγ, e.2⟩ h),
end

end A_map_code
end con_nf


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import field_theory.minpoly
import ring_theory.adjoin_root
import linear_algebra.finite_dimensional
import algebra.polynomial.big_operators
import ring_theory.algebraic
import ring_theory.algebra_tower
import tactic.field_simp

/-!
# Splitting fields

This file introduces the notion of a splitting field of a polynomial and provides an embedding from
a splitting field to any field that splits the polynomial. A polynomial `f : polynomial K` splits
over a field extension `L` of `K` if it is zero or all of its irreducible factors over `L` have
degree `1`. A field extension of `K` of a polynomial `f : polynomial K` is called a splitting field
if it is the smallest field extension of `K` such that `f` splits.

## Main definitions

* `polynomial.splits i f`: A predicate on a field homomorphism `i : K → L` and a polynomial `f`
  saying that `f` is zero or all of its irreducible factors over `L` have degree `1`.
* `polynomial.splitting_field f`: A fixed splitting field of the polynomial `f`.
* `polynomial.is_splitting_field`: A predicate on a field to be a splitting field of a polynomial
  `f`.

## Main statements

* `polynomial.C_leading_coeff_mul_prod_multiset_X_sub_C`: If a polynomial has as many roots as its
  degree, it can be written as the product of its leading coefficient with `∏ (X - a)` where `a`
  ranges through its roots.
* `lift_of_splits`: If `K` and `L` are field extensions of a field `F` and for some finite subset
  `S` of `K`, the minimal polynomial of every `x ∈ K` splits as a polynomial with coefficients in
  `L`, then `algebra.adjoin F S` embeds into `L`.
* `polynomial.is_splitting_field.lift`: An embedding of a splitting field of the polynomial `f` into
  another field such that `f` splits.
* `polynomial.is_splitting_field.alg_equiv`: Every splitting field of a polynomial `f` is isomorphic
  to `splitting_field f` and thus, being a splitting field is unique up to isomorphism.

-/

noncomputable theory
open_locale classical big_operators

universes u v w

variables {F : Type u} {K : Type v} {L : Type w}

namespace polynomial

variables [field K] [field L] [field F]
open polynomial

section splits

variables (i : K →+* L)

/-- A polynomial `splits` iff it is zero or all of its irreducible factors have `degree` 1. -/
def splits (f : polynomial K) : Prop :=
f = 0 ∨ ∀ {g : polynomial L}, irreducible g → g ∣ f.map i → degree g = 1

@[simp] lemma splits_zero : splits i (0 : polynomial K) := or.inl rfl

@[simp] lemma splits_C (a : K) : splits i (C a) :=
if ha : a = 0 then ha.symm ▸ (@C_0 K _).symm ▸ splits_zero i
else
have hia : i a ≠ 0, from mt ((i.injective_iff).1
  i.injective _) ha,
or.inr $ λ g hg ⟨p, hp⟩, absurd hg.1 (not_not.2 (is_unit_iff_degree_eq_zero.2 $
  by have := congr_arg degree hp;
    simp [degree_C hia, @eq_comm (with_bot ℕ) 0,
      nat.with_bot.add_eq_zero_iff] at this; clear _fun_match; tauto))

lemma splits_of_degree_eq_one {f : polynomial K} (hf : degree f = 1) : splits i f :=
or.inr $ λ g hg ⟨p, hp⟩,
  by have := congr_arg degree hp;
  simp [nat.with_bot.add_eq_one_iff, hf, @eq_comm (with_bot ℕ) 1,
    mt is_unit_iff_degree_eq_zero.2 hg.1] at this;
  clear _fun_match; tauto

lemma splits_of_degree_le_one {f : polynomial K} (hf : degree f ≤ 1) : splits i f :=
begin
  cases h : degree f with n,
  { rw [degree_eq_bot.1 h]; exact splits_zero i },
  { cases n with n,
    { rw [eq_C_of_degree_le_zero (trans_rel_right (≤) h le_rfl)];
      exact splits_C _ _ },
    { have hn : n = 0,
      { rw h at hf,
        cases n, { refl }, { exact absurd hf dec_trivial } },
      exact splits_of_degree_eq_one _ (by rw [h, hn]; refl) } }
end

lemma splits_of_nat_degree_le_one {f : polynomial K} (hf : nat_degree f ≤ 1) : splits i f :=
splits_of_degree_le_one i (degree_le_of_nat_degree_le hf)

lemma splits_of_nat_degree_eq_one {f : polynomial K} (hf : nat_degree f = 1) : splits i f :=
splits_of_nat_degree_le_one i (le_of_eq hf)

lemma splits_mul {f g : polynomial K} (hf : splits i f) (hg : splits i g) : splits i (f * g) :=
if h : f * g = 0 then by simp [h]
else or.inr $ λ p hp hpf, ((principal_ideal_ring.irreducible_iff_prime.1 hp).2.2 _ _
    (show p ∣ map i f * map i g, by convert hpf; rw polynomial.map_mul)).elim
  (hf.resolve_left (λ hf, by simpa [hf] using h) hp)
  (hg.resolve_left (λ hg, by simpa [hg] using h) hp)

lemma splits_of_splits_mul {f g : polynomial K} (hfg : f * g ≠ 0) (h : splits i (f * g)) :
  splits i f ∧ splits i g :=
⟨or.inr $ λ g hgi hg, or.resolve_left h hfg hgi
   (by rw map_mul; exact hg.trans (dvd_mul_right _ _)),
 or.inr $ λ g hgi hg, or.resolve_left h hfg hgi
   (by rw map_mul; exact hg.trans (dvd_mul_left _ _))⟩

lemma splits_of_splits_of_dvd {f g : polynomial K} (hf0 : f ≠ 0) (hf : splits i f) (hgf : g ∣ f) :
  splits i g :=
by { obtain ⟨f, rfl⟩ := hgf, exact (splits_of_splits_mul i hf0 hf).1 }

lemma splits_of_splits_gcd_left {f g : polynomial K} (hf0 : f ≠ 0) (hf : splits i f) :
  splits i (euclidean_domain.gcd f g) :=
polynomial.splits_of_splits_of_dvd i hf0 hf (euclidean_domain.gcd_dvd_left f g)

lemma splits_of_splits_gcd_right {f g : polynomial K} (hg0 : g ≠ 0) (hg : splits i g) :
  splits i (euclidean_domain.gcd f g) :=
polynomial.splits_of_splits_of_dvd i hg0 hg (euclidean_domain.gcd_dvd_right f g)

lemma splits_map_iff (j : L →+* F) {f : polynomial K} :
  splits j (f.map i) ↔ splits (j.comp i) f :=
by simp [splits, polynomial.map_map]

theorem splits_one : splits i 1 :=
splits_C i 1

theorem splits_of_is_unit {u : polynomial K} (hu : is_unit u) : u.splits i :=
splits_of_splits_of_dvd i one_ne_zero (splits_one _) $ is_unit_iff_dvd_one.1 hu

theorem splits_X_sub_C {x : K} : (X - C x).splits i :=
splits_of_degree_eq_one _ $ degree_X_sub_C x

theorem splits_X : X.splits i :=
splits_of_degree_eq_one _ $ degree_X

theorem splits_id_iff_splits {f : polynomial K} :
  (f.map i).splits (ring_hom.id L) ↔ f.splits i :=
by rw [splits_map_iff, ring_hom.id_comp]

theorem splits_mul_iff {f g : polynomial K} (hf : f ≠ 0) (hg : g ≠ 0) :
  (f * g).splits i ↔ f.splits i ∧ g.splits i :=
⟨splits_of_splits_mul i (mul_ne_zero hf hg), λ ⟨hfs, hgs⟩, splits_mul i hfs hgs⟩

theorem splits_prod {ι : Type u} {s : ι → polynomial K} {t : finset ι} :
  (∀ j ∈ t, (s j).splits i) → (∏ x in t, s x).splits i :=
begin
  refine finset.induction_on t (λ _, splits_one i) (λ a t hat ih ht, _),
  rw finset.forall_mem_insert at ht, rw finset.prod_insert hat,
  exact splits_mul i ht.1 (ih ht.2)
end

lemma splits_pow {f : polynomial K} (hf : f.splits i) (n : ℕ) : (f ^ n).splits i :=
begin
  rw [←finset.card_range n, ←finset.prod_const],
  exact splits_prod i (λ j hj, hf),
end

lemma splits_X_pow (n : ℕ) : (X ^ n).splits i := splits_pow i (splits_X i) n

theorem splits_prod_iff {ι : Type u} {s : ι → polynomial K} {t : finset ι} :
  (∀ j ∈ t, s j ≠ 0) → ((∏ x in t, s x).splits i ↔ ∀ j ∈ t, (s j).splits i) :=
begin
  refine finset.induction_on t (λ _, ⟨λ _ _ h, h.elim, λ _, splits_one i⟩) (λ a t hat ih ht, _),
  rw finset.forall_mem_insert at ht ⊢,
  rw [finset.prod_insert hat, splits_mul_iff i ht.1 (finset.prod_ne_zero_iff.2 ht.2), ih ht.2]
end

lemma degree_eq_one_of_irreducible_of_splits {p : polynomial L}
  (hp : irreducible p) (hp_splits : splits (ring_hom.id L) p) :
  p.degree = 1 :=
begin
  by_cases h_nz : p = 0,
  { exfalso, simp [*] at *, },
  rcases hp_splits,
  { contradiction },
  { apply hp_splits hp, simp }
end

lemma exists_root_of_splits {f : polynomial K} (hs : splits i f) (hf0 : degree f ≠ 0) :
  ∃ x, eval₂ i x f = 0 :=
if hf0 : f = 0 then ⟨37, by simp [hf0]⟩
else
  let ⟨g, hg⟩ := wf_dvd_monoid.exists_irreducible_factor
    (show ¬ is_unit (f.map i), from mt is_unit_iff_degree_eq_zero.1 (by rwa degree_map))
    (map_ne_zero hf0) in
  let ⟨x, hx⟩ := exists_root_of_degree_eq_one (hs.resolve_left hf0 hg.1 hg.2) in
  let ⟨i, hi⟩ := hg.2 in
  ⟨x, by rw [← eval_map, hi, eval_mul, show _ = _, from hx, zero_mul]⟩

lemma exists_multiset_of_splits {f : polynomial K} : splits i f →
  ∃ (s : multiset L), f.map i = C (i f.leading_coeff) *
  (s.map (λ a : L, (X : polynomial L) - C a)).prod :=
suffices splits (ring_hom.id _) (f.map i) → ∃ s : multiset L, f.map i =
  (C (f.map i).leading_coeff) * (s.map (λ a : L, (X : polynomial L) - C a)).prod,
by rwa [splits_map_iff, leading_coeff_map i] at this,
wf_dvd_monoid.induction_on_irreducible (f.map i)
  (λ _, ⟨{37}, by simp [i.map_zero]⟩)
  (λ u hu _, ⟨0,
    by conv_lhs { rw eq_C_of_degree_eq_zero (is_unit_iff_degree_eq_zero.1 hu) };
      simp [leading_coeff, nat_degree_eq_of_degree_eq_some (is_unit_iff_degree_eq_zero.1 hu)]⟩)
  (λ f p hf0 hp ih hfs,
    have hpf0 : p * f ≠ 0, from mul_ne_zero hp.ne_zero hf0,
    let ⟨s, hs⟩ := ih (splits_of_splits_mul _ hpf0 hfs).2 in
    ⟨-(p * norm_unit p).coeff 0 ::ₘ s,
      have hp1 : degree p = 1, from hfs.resolve_left hpf0 hp (by simp),
      begin
        rw [multiset.map_cons, multiset.prod_cons, leading_coeff_mul, C_mul, mul_assoc,
          mul_left_comm (C f.leading_coeff), ← hs, ← mul_assoc, mul_left_inj' hf0],
        conv_lhs {rw eq_X_add_C_of_degree_eq_one hp1},
        simp only [mul_add, coe_norm_unit_of_ne_zero hp.ne_zero, mul_comm p, coeff_neg,
          C_neg, sub_eq_add_neg, neg_neg, coeff_C_mul, (mul_assoc _ _ _).symm, C_mul.symm,
          mul_inv_cancel (show p.leading_coeff ≠ 0, from mt leading_coeff_eq_zero.1
            hp.ne_zero), one_mul],
      end⟩)

/-- Pick a root of a polynomial that splits. -/
def root_of_splits {f : polynomial K} (hf : f.splits i) (hfd : f.degree ≠ 0) : L :=
classical.some $ exists_root_of_splits i hf hfd

theorem map_root_of_splits {f : polynomial K} (hf : f.splits i) (hfd) :
  f.eval₂ i (root_of_splits i hf hfd) = 0 :=
classical.some_spec $ exists_root_of_splits i hf hfd

theorem roots_map {f : polynomial K} (hf : f.splits $ ring_hom.id K) :
  (f.map i).roots = (f.roots).map i :=
if hf0 : f = 0 then by rw [hf0, map_zero, roots_zero, roots_zero, multiset.map_zero] else
have hmf0 : f.map i ≠ 0 := map_ne_zero hf0,
let ⟨m, hm⟩ := exists_multiset_of_splits _ hf in
have h1 : (0 : polynomial K) ∉ m.map (λ r, X - C r),
  from zero_nmem_multiset_map_X_sub_C _ _,
have h2 : (0 : polynomial L) ∉ m.map (λ r, X - C (i r)),
  from zero_nmem_multiset_map_X_sub_C _ _,
begin
  rw map_id at hm, rw hm at hf0 hmf0 ⊢, rw map_mul at hmf0 ⊢,
  rw [roots_mul hf0, roots_mul hmf0, map_C, roots_C, zero_add, roots_C, zero_add,
      map_multiset_prod, multiset.map_map], simp_rw [(∘), map_sub, map_X, map_C],
  rw [roots_multiset_prod _ h2, multiset.bind_map,
      roots_multiset_prod _ h1, multiset.bind_map],
  simp_rw roots_X_sub_C,
  rw [multiset.bind_singleton, multiset.bind_singleton, multiset.map_id']
end

lemma eq_prod_roots_of_splits {p : polynomial K} {i : K →+* L}
  (hsplit : splits i p) :
  p.map i = C (i p.leading_coeff) * ((p.map i).roots.map (λ a, X - C a)).prod :=
begin
  by_cases p_eq_zero : p = 0,
  { rw [p_eq_zero, map_zero, leading_coeff_zero, i.map_zero, C.map_zero, zero_mul] },

  obtain ⟨s, hs⟩ := exists_multiset_of_splits i hsplit,
  have map_ne_zero : p.map i ≠ 0 := map_ne_zero (p_eq_zero),
  have prod_ne_zero : C (i p.leading_coeff) * (multiset.map (λ a, X - C a) s).prod ≠ 0 :=
    by rwa hs at map_ne_zero,

  have zero_nmem : (0 : polynomial L) ∉ s.map (λ a, X - C a),
    from zero_nmem_multiset_map_X_sub_C _ _,
  have map_bind_roots_eq : (s.map (λ a, X - C a)).bind (λ a, a.roots) = s,
  { refine multiset.induction_on s (by rw [multiset.map_zero, multiset.zero_bind]) _,
    intros a s ih,
    rw [multiset.map_cons, multiset.cons_bind, ih, roots_X_sub_C, multiset.singleton_add] },

  rw [hs, roots_mul prod_ne_zero, roots_C, zero_add,
      roots_multiset_prod _ zero_nmem,
      map_bind_roots_eq]
end

lemma eq_prod_roots_of_splits_id {p : polynomial K}
  (hsplit : splits (ring_hom.id K) p) :
  p = C (p.leading_coeff) * (p.roots.map (λ a, X - C a)).prod :=
by simpa using eq_prod_roots_of_splits hsplit

lemma eq_prod_roots_of_monic_of_splits_id {p : polynomial K}
  (m : monic p) (hsplit : splits (ring_hom.id K) p) :
  p = (p.roots.map (λ a, X - C a)).prod :=
begin
  convert eq_prod_roots_of_splits_id hsplit,
  simp [m],
end

lemma eq_X_sub_C_of_splits_of_single_root {x : K} {h : polynomial K} (h_splits : splits i h)
  (h_roots : (h.map i).roots = {i x}) : h = (C (leading_coeff h)) * (X - C x) :=
begin
  apply polynomial.map_injective _ i.injective,
  rw [eq_prod_roots_of_splits h_splits, h_roots],
  simp,
end

lemma nat_degree_eq_card_roots {p : polynomial K} {i : K →+* L}
  (hsplit : splits i p) : p.nat_degree = (p.map i).roots.card :=
begin
  by_cases p_eq_zero : p = 0,
  { rw [p_eq_zero, nat_degree_zero, map_zero, roots_zero, multiset.card_zero] },
  have map_ne_zero : p.map i ≠ 0 := map_ne_zero (p_eq_zero),
  rw eq_prod_roots_of_splits hsplit at map_ne_zero,

  conv_lhs { rw [← nat_degree_map i, eq_prod_roots_of_splits hsplit] },
  have : (0 : polynomial L) ∉ (map i p).roots.map (λ a, X - C a),
    from zero_nmem_multiset_map_X_sub_C _ _,
  simp [nat_degree_mul (left_ne_zero_of_mul map_ne_zero) (right_ne_zero_of_mul map_ne_zero),
        nat_degree_multiset_prod _ this]
end

lemma degree_eq_card_roots {p : polynomial K} {i : K →+* L} (p_ne_zero : p ≠ 0)
  (hsplit : splits i p) : p.degree = (p.map i).roots.card :=
by rw [degree_eq_nat_degree p_ne_zero, nat_degree_eq_card_roots hsplit]

section UFD

local attribute [instance, priority 10] principal_ideal_ring.to_unique_factorization_monoid
local infix ` ~ᵤ ` : 50 := associated

open unique_factorization_monoid associates

lemma splits_of_exists_multiset {f : polynomial K} {s : multiset L}
  (hs : f.map i = C (i f.leading_coeff) * (s.map (λ a : L, (X : polynomial L) - C a)).prod) :
  splits i f :=
if hf0 : f = 0 then or.inl hf0
else
  or.inr $ λ p hp hdp,
    have ht : multiset.rel associated
      (normalized_factors (f.map i)) (s.map (λ a : L, (X : polynomial L) - C a)) :=
    factors_unique
      (λ p hp, irreducible_of_normalized_factor _ hp)
      (λ p' m, begin
          obtain ⟨a,m,rfl⟩ := multiset.mem_map.1 m,
          exact irreducible_of_degree_eq_one (degree_X_sub_C _),
        end)
      (associated.symm $ calc _ ~ᵤ f.map i :
        ⟨(units.map C.to_monoid_hom : Lˣ →* (polynomial L)ˣ)
          (units.mk0 (f.map i).leading_coeff
            (mt leading_coeff_eq_zero.1 (map_ne_zero hf0))),
          by conv_rhs { rw [hs, ← leading_coeff_map i, mul_comm] }; refl⟩
        ... ~ᵤ _ : (unique_factorization_monoid.normalized_factors_prod (by simpa using hf0)).symm),
  let ⟨q, hq, hpq⟩ := exists_mem_normalized_factors_of_dvd (by simpa) hp hdp in
  let ⟨q', hq', hqq'⟩ := multiset.exists_mem_of_rel_of_mem ht hq in
  let ⟨a, ha⟩ := multiset.mem_map.1 hq' in
  by rw [← degree_X_sub_C a, ha.2];
    exact degree_eq_degree_of_associated (hpq.trans hqq')

lemma splits_of_splits_id {f : polynomial K} : splits (ring_hom.id _) f → splits i f :=
unique_factorization_monoid.induction_on_prime f (λ _, splits_zero _)
  (λ _ hu _, splits_of_degree_le_one _
    ((is_unit_iff_degree_eq_zero.1 hu).symm ▸ dec_trivial))
  (λ a p ha0 hp ih hfi, splits_mul _
    (splits_of_degree_eq_one _
      ((splits_of_splits_mul _ (mul_ne_zero hp.1 ha0) hfi).1.resolve_left
        hp.1 hp.irreducible (by rw map_id)))
    (ih (splits_of_splits_mul _ (mul_ne_zero hp.1 ha0) hfi).2))

end UFD

lemma splits_iff_exists_multiset {f : polynomial K} : splits i f ↔
  ∃ (s : multiset L), f.map i = C (i f.leading_coeff) *
  (s.map (λ a : L, (X : polynomial L) - C a)).prod :=
⟨exists_multiset_of_splits i, λ ⟨s, hs⟩, splits_of_exists_multiset i hs⟩

lemma splits_comp_of_splits (j : L →+* F) {f : polynomial K}
  (h : splits i f) : splits (j.comp i) f :=
begin
  change i with ((ring_hom.id _).comp i) at h,
  rw [← splits_map_iff],
  rw [← splits_map_iff i] at h,
  exact splits_of_splits_id _ h
end

/-- A monic polynomial `p` that has as many roots as its degree
can be written `p = ∏(X - a)`, for `a` in `p.roots`. -/
private lemma prod_multiset_X_sub_C_of_monic_of_roots_card_eq_of_field {p : polynomial K}
  (hmonic : p.monic) (hroots : p.roots.card = p.nat_degree) :
  (multiset.map (λ (a : K), X - C a) p.roots).prod = p :=
begin
  have hprodmonic : (multiset.map (λ (a : K), X - C a) p.roots).prod.monic,
  { simp only [prod_multiset_root_eq_finset_root,
      monic_prod_of_monic, monic_X_sub_C, monic_pow, forall_true_iff] },
  have hdegree : (multiset.map (λ (a : K), X - C a) p.roots).prod.nat_degree = p.nat_degree,
  { rw [← hroots, nat_degree_multiset_prod _ (zero_nmem_multiset_map_X_sub_C _ (λ a : K, a))],
    simp only [eq_self_iff_true, mul_one, nat.cast_id, nsmul_eq_mul, multiset.sum_repeat,
      multiset.map_const,nat_degree_X_sub_C, function.comp, multiset.map_map] },
  obtain ⟨q, hq⟩ := prod_multiset_X_sub_C_dvd p,
  have qzero : q ≠ 0,
  { rintro rfl, apply hmonic.ne_zero, simpa only [mul_zero] using hq },
  have degp :
    p.nat_degree = (multiset.map (λ (a : K), X - C a) p.roots).prod.nat_degree + q.nat_degree,
  { nth_rewrite 0 [hq],
    simp only [nat_degree_mul (ne_zero_of_monic hprodmonic) qzero] },
  have degq : q.nat_degree = 0,
  { rw hdegree at degp,
    rw [← add_right_inj p.nat_degree, ← degp, add_zero], },
  obtain ⟨u, hu⟩ := is_unit_iff_degree_eq_zero.2 ((degree_eq_iff_nat_degree_eq qzero).2 degq),
  have hassoc : associated (multiset.map (λ (a : K), X - C a) p.roots).prod p,
  { rw associated, use u, rw [hu, ← hq] },
  exact eq_of_monic_of_associated hprodmonic hmonic hassoc
end

lemma prod_multiset_X_sub_C_of_monic_of_roots_card_eq {K : Type*} [comm_ring K] [is_domain K]
  {p : polynomial K} (hmonic : p.monic) (hroots : p.roots.card = p.nat_degree) :
  (multiset.map (λ (a : K), X - C a) p.roots).prod = p :=
begin
  apply map_injective _ (is_fraction_ring.injective K (fraction_ring K)),
  rw map_multiset_prod,
  simp only [map_C, function.comp_app, map_X, multiset.map_map, map_sub],
  have : p.roots.map (algebra_map K (fraction_ring K)) =
    (map (algebra_map K (fraction_ring K)) p).roots :=
    roots_map_of_injective_card_eq_total_degree
      (is_fraction_ring.injective K (fraction_ring K)) hroots,
  rw ← prod_multiset_X_sub_C_of_monic_of_roots_card_eq_of_field
    (monic_map (algebra_map K (fraction_ring K)) hmonic),
  { simp only [map_C, function.comp_app, map_X, map_sub],
    congr' 1,
    rw ← this,
    simp, },
  { rw [nat_degree_map_eq_of_injective (is_fraction_ring.injective K (fraction_ring K)), ← this],
    simp only [←hroots, multiset.card_map], },
end

/-- A polynomial `p` that has as many roots as its degree
can be written `p = p.leading_coeff * ∏(X - a)`, for `a` in `p.roots`.
Used to prove the more general `C_leading_coeff_mul_prod_multiset_X_sub_C` below. -/
private lemma C_leading_coeff_mul_prod_multiset_X_sub_C_of_field {p : polynomial K}
  (hroots : p.roots.card = p.nat_degree) :
  C p.leading_coeff * (multiset.map (λ (a : K), X - C a) p.roots).prod = p :=
begin
  by_cases hzero : p = 0,
  { rw [hzero, leading_coeff_zero, ring_hom.map_zero, zero_mul], },
  { have hcoeff : p.leading_coeff ≠ 0,
    { intro h, exact hzero (leading_coeff_eq_zero.1 h) },
    have hrootsnorm : (normalize p).roots.card = (normalize p).nat_degree,
    { rw [roots_normalize, normalize_apply, nat_degree_mul hzero (units.ne_zero _), hroots,
          coe_norm_unit, nat_degree_C, add_zero], },
    have hprod := prod_multiset_X_sub_C_of_monic_of_roots_card_eq (monic_normalize hzero)
                    hrootsnorm,
    rw [roots_normalize, normalize_apply, coe_norm_unit_of_ne_zero hzero] at hprod,
    calc (C p.leading_coeff) * (multiset.map (λ (a : K), X - C a) p.roots).prod
        = p * C ((p.leading_coeff)⁻¹ * p.leading_coeff) :
        by rw [hprod, mul_comm, mul_assoc, ← C_mul]
    ... = p * C 1 : by field_simp
    ... = p : by simp only [mul_one, ring_hom.map_one], },
end

/-- A polynomial `p` that has as many roots as its degree
can be written `p = p.leading_coeff * ∏(X - a)`, for `a` in `p.roots`. -/
lemma C_leading_coeff_mul_prod_multiset_X_sub_C {K : Type*} [comm_ring K] [is_domain K]
  {p : polynomial K} (hroots : p.roots.card = p.nat_degree) :
  C p.leading_coeff * (multiset.map (λ (a : K), X - C a) p.roots).prod = p :=
begin
  by_cases hzero : p = 0,
  { rw [hzero, leading_coeff_zero, ring_hom.map_zero, zero_mul], },
  have hcoeff : p.leading_coeff ≠ 0,
  { intro h, exact hzero (leading_coeff_eq_zero.1 h) },
  apply map_injective _ (is_fraction_ring.injective K (fraction_ring K)),
  rw [map_mul, map_multiset_prod],
  simp only [map_C, function.comp_app, map_X, multiset.map_map, map_sub],
  have h : p.roots.map (algebra_map K (fraction_ring K)) =
    (map (algebra_map K (fraction_ring K)) p).roots :=
    roots_map_of_injective_card_eq_total_degree
      (is_fraction_ring.injective K (fraction_ring K)) hroots,
  have : multiset.card (map (algebra_map K (fraction_ring K)) p).roots =
    (map (algebra_map K (fraction_ring K)) p).nat_degree,
  { rw [nat_degree_map_eq_of_injective (is_fraction_ring.injective K (fraction_ring K)), ← h],
    simp only [←hroots, multiset.card_map], },
  rw [← C_leading_coeff_mul_prod_multiset_X_sub_C_of_field this],
  simp only [map_C, function.comp_app, map_X, map_sub],
  congr' 2,
  { rw leading_coeff_map_of_leading_coeff_ne_zero,
    intro hn,
    apply hcoeff,
    apply is_fraction_ring.injective K (fraction_ring K),
    simp [hn], },
  rw ← h,
  simp,
end

/-- A polynomial splits if and only if it has as many roots as its degree. -/
lemma splits_iff_card_roots {p : polynomial K} :
  splits (ring_hom.id K) p ↔ p.roots.card = p.nat_degree :=
begin
  split,
  { intro H, rw [nat_degree_eq_card_roots H, map_id] },
  { intro hroots,
    apply (splits_iff_exists_multiset (ring_hom.id K)).2,
    use p.roots,
    simp only [ring_hom.id_apply, map_id],
    exact (C_leading_coeff_mul_prod_multiset_X_sub_C hroots).symm },
end

lemma aeval_root_derivative_of_splits [algebra K L] {P : polynomial K} (hmo : P.monic)
  (hP : P.splits (algebra_map K L)) {r : L} (hr : r ∈ (P.map (algebra_map K L)).roots) :
  aeval r P.derivative =
  (multiset.map (λ a, r - a) ((P.map (algebra_map K L)).roots.erase r)).prod :=
begin
  replace hmo := monic_map (algebra_map K L) hmo,
  replace hP := (splits_id_iff_splits (algebra_map K L)).2 hP,
  rw [aeval_def, ← eval_map, ← derivative_map],
  nth_rewrite 0 [eq_prod_roots_of_monic_of_splits_id hmo hP],
  rw [eval_multiset_prod_X_sub_C_derivative hr]
end

/-- If `P` is a monic polynomial that splits, then `coeff P 0` equals the product of the roots. -/
lemma prod_roots_eq_coeff_zero_of_monic_of_split {P : polynomial K} (hmo : P.monic)
  (hP : P.splits (ring_hom.id K)) : coeff P 0 = (-1) ^ P.nat_degree * P.roots.prod :=
begin
  nth_rewrite 0 [eq_prod_roots_of_monic_of_splits_id hmo hP],
  rw [coeff_zero_eq_eval_zero, eval_multiset_prod, multiset.map_map],
  simp_rw [function.comp_app, eval_sub, eval_X, zero_sub, eval_C],
  conv_lhs { congr, congr, funext,
    rw [neg_eq_neg_one_mul] },
  rw [multiset.prod_map_mul, multiset.map_const, multiset.prod_repeat, multiset.map_id',
    splits_iff_card_roots.1 hP]
end

/-- If `P` is a monic polynomial that splits, then `P.next_coeff` equals the sum of the roots. -/
lemma sum_roots_eq_next_coeff_of_monic_of_split {P : polynomial K} (hmo : P.monic)
  (hP : P.splits (ring_hom.id K)) : P.next_coeff = - P.roots.sum :=
begin
  nth_rewrite 0 [eq_prod_roots_of_monic_of_splits_id hmo hP],
  rw [monic.next_coeff_multiset_prod _ _ (λ a ha, _)],
  { simp_rw [next_coeff_X_sub_C, multiset.sum_map_neg] },
  { exact monic_X_sub_C a }
end

end splits

end polynomial

section embeddings

variables (F) [field F]

/-- If `p` is the minimal polynomial of `a` over `F` then `F[a] ≃ₐ[F] F[x]/(p)` -/
def alg_equiv.adjoin_singleton_equiv_adjoin_root_minpoly
  {R : Type*} [comm_ring R] [algebra F R] (x : R) :
  algebra.adjoin F ({x} : set R) ≃ₐ[F] adjoin_root (minpoly F x) :=
alg_equiv.symm $ alg_equiv.of_bijective
  (alg_hom.cod_restrict
    (adjoin_root.lift_hom _ x $ minpoly.aeval F x) _
    (λ p, adjoin_root.induction_on _ p $ λ p,
      (algebra.adjoin_singleton_eq_range_aeval F x).symm ▸
        (polynomial.aeval _).mem_range.mpr ⟨p, rfl⟩))
  ⟨(alg_hom.injective_cod_restrict _ _ _).2 $ (alg_hom.injective_iff _).2 $ λ p,
    adjoin_root.induction_on _ p $ λ p hp, ideal.quotient.eq_zero_iff_mem.2 $
    ideal.mem_span_singleton.2 $ minpoly.dvd F x hp,
  λ y,
    let ⟨p, hp⟩ := (set_like.ext_iff.1
      (algebra.adjoin_singleton_eq_range_aeval F x) (y : R)).1 y.2 in
    ⟨adjoin_root.mk _ p, subtype.eq hp⟩⟩

open finset

/-- If a `subalgebra` is finite_dimensional as a submodule then it is `finite_dimensional`. -/
lemma finite_dimensional.of_subalgebra_to_submodule
  {K V : Type*} [field K] [ring V] [algebra K V] {s : subalgebra K V}
  (h : finite_dimensional K s.to_submodule) : finite_dimensional K s := h

/-- If `K` and `L` are field extensions of `F` and we have `s : finset K` such that
the minimal polynomial of each `x ∈ s` splits in `L` then `algebra.adjoin F s` embeds in `L`. -/
theorem lift_of_splits {F K L : Type*} [field F] [field K] [field L]
  [algebra F K] [algebra F L] (s : finset K) :
  (∀ x ∈ s, is_integral F x ∧ polynomial.splits (algebra_map F L) (minpoly F x)) →
  nonempty (algebra.adjoin F (↑s : set K) →ₐ[F] L) :=
begin
  refine finset.induction_on s (λ H, _) (λ a s has ih H, _),
  { rw [coe_empty, algebra.adjoin_empty],
    exact ⟨(algebra.of_id F L).comp (algebra.bot_equiv F K)⟩ },
  rw forall_mem_insert at H, rcases H with ⟨⟨H1, H2⟩, H3⟩, cases ih H3 with f,
  choose H3 H4 using H3,
  rw [coe_insert, set.insert_eq, set.union_comm, algebra.adjoin_union_eq_adjoin_adjoin],
  letI := (f : algebra.adjoin F (↑s : set K) →+* L).to_algebra,
  haveI : finite_dimensional F (algebra.adjoin F (↑s : set K)) := (
    (submodule.fg_iff_finite_dimensional _).1
      (fg_adjoin_of_finite (set.finite_mem_finset s) H3)).of_subalgebra_to_submodule,
  letI := field_of_finite_dimensional F (algebra.adjoin F (↑s : set K)),
  have H5 : is_integral (algebra.adjoin F (↑s : set K)) a := is_integral_of_is_scalar_tower a H1,
  have H6 : (minpoly (algebra.adjoin F (↑s : set K)) a).splits
    (algebra_map (algebra.adjoin F (↑s : set K)) L),
  { refine polynomial.splits_of_splits_of_dvd _
      (polynomial.map_ne_zero $ minpoly.ne_zero H1 :
        polynomial.map (algebra_map _ _) _ ≠ 0)
      ((polynomial.splits_map_iff _ _).2 _)
      (minpoly.dvd _ _ _),
    { rw ← is_scalar_tower.algebra_map_eq, exact H2 },
    { rw [← is_scalar_tower.aeval_apply, minpoly.aeval] } },
  obtain ⟨y, hy⟩ := polynomial.exists_root_of_splits _ H6 (ne_of_lt (minpoly.degree_pos H5)).symm,
  refine ⟨subalgebra.of_restrict_scalars _ _ _⟩,
  refine (adjoin_root.lift_hom (minpoly (algebra.adjoin F (↑s : set K)) a) y hy).comp _,
  exact alg_equiv.adjoin_singleton_equiv_adjoin_root_minpoly (algebra.adjoin F (↑s : set K)) a
end

end embeddings

namespace polynomial

variables [field K] [field L] [field F]
open polynomial

section splitting_field

/-- Non-computably choose an irreducible factor from a polynomial. -/
def factor (f : polynomial K) : polynomial K :=
if H : ∃ g, irreducible g ∧ g ∣ f then classical.some H else X

instance irreducible_factor (f : polynomial K) : irreducible (factor f) :=
begin
  rw factor, split_ifs with H, { exact (classical.some_spec H).1 }, { exact irreducible_X }
end

theorem factor_dvd_of_not_is_unit {f : polynomial K} (hf1 : ¬is_unit f) : factor f ∣ f :=
begin
  by_cases hf2 : f = 0, { rw hf2, exact dvd_zero _ },
  rw [factor, dif_pos (wf_dvd_monoid.exists_irreducible_factor hf1 hf2)],
  exact (classical.some_spec $ wf_dvd_monoid.exists_irreducible_factor hf1 hf2).2
end

theorem factor_dvd_of_degree_ne_zero {f : polynomial K} (hf : f.degree ≠ 0) : factor f ∣ f :=
factor_dvd_of_not_is_unit (mt degree_eq_zero_of_is_unit hf)

theorem factor_dvd_of_nat_degree_ne_zero {f : polynomial K} (hf : f.nat_degree ≠ 0) :
  factor f ∣ f :=
factor_dvd_of_degree_ne_zero (mt nat_degree_eq_of_degree_eq_some hf)

/-- Divide a polynomial f by X - C r where r is a root of f in a bigger field extension. -/
def remove_factor (f : polynomial K) : polynomial (adjoin_root $ factor f) :=
map (adjoin_root.of f.factor) f /ₘ (X - C (adjoin_root.root f.factor))

theorem X_sub_C_mul_remove_factor (f : polynomial K) (hf : f.nat_degree ≠ 0) :
  (X - C (adjoin_root.root f.factor)) * f.remove_factor = map (adjoin_root.of f.factor) f :=
let ⟨g, hg⟩ := factor_dvd_of_nat_degree_ne_zero hf in
mul_div_by_monic_eq_iff_is_root.2 $ by rw [is_root.def, eval_map, hg, eval₂_mul, ← hg,
    adjoin_root.eval₂_root, zero_mul]

theorem nat_degree_remove_factor (f : polynomial K) :
  f.remove_factor.nat_degree = f.nat_degree - 1 :=
by rw [remove_factor, nat_degree_div_by_monic _ (monic_X_sub_C _), nat_degree_map,
       nat_degree_X_sub_C]

theorem nat_degree_remove_factor' {f : polynomial K} {n : ℕ} (hfn : f.nat_degree = n+1) :
  f.remove_factor.nat_degree = n :=
by rw [nat_degree_remove_factor, hfn, n.add_sub_cancel]

/-- Auxiliary construction to a splitting field of a polynomial. Uses induction on the degree. -/
def splitting_field_aux (n : ℕ) : Π {K : Type u} [field K], by exactI Π (f : polynomial K),
  f.nat_degree = n → Type u :=
nat.rec_on n (λ K _ _ _, K) $ λ n ih K _ f hf, by exactI
ih f.remove_factor (nat_degree_remove_factor' hf)

namespace splitting_field_aux

theorem succ (n : ℕ) (f : polynomial K) (hfn : f.nat_degree = n + 1) :
  splitting_field_aux (n+1) f hfn =
    splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn) := rfl

instance field (n : ℕ) : Π {K : Type u} [field K], by exactI
  Π {f : polynomial K} (hfn : f.nat_degree = n), field (splitting_field_aux n f hfn) :=
nat.rec_on n (λ K _ _ _, ‹field K›) $ λ n ih K _ f hf, ih _

instance inhabited {n : ℕ} {f : polynomial K} (hfn : f.nat_degree = n) :
  inhabited (splitting_field_aux n f hfn) := ⟨37⟩

/-
Note that the recursive nature of this definition and `splitting_field_aux.field` creates
non-definitionally-equal diamonds in the `ℕ`- and `ℤ`- actions.
```lean
example (n : ℕ) {K : Type u} [field K] {f : polynomial K} (hfn : f.nat_degree = n) :
    (add_comm_monoid.nat_module : module ℕ (splitting_field_aux n f hfn)) =
  @algebra.to_module _ _ _ _ (splitting_field_aux.algebra n _ hfn) :=
rfl  -- fails
```
It's not immediately clear whether this _can_ be fixed; the failure is much the same as the reason
that the following fails:
```lean
def cases_twice {α} (a₀ aₙ : α) : ℕ → α × α
| 0 := (a₀, a₀)
| (n + 1) := (aₙ, aₙ)

example (x : ℕ) {α} (a₀ aₙ : α) : (cases_twice a₀ aₙ x).1 = (cases_twice a₀ aₙ x).2 := rfl  -- fails
```
We don't really care at this point because this is an implementation detail (which is why this is
not a docstring), but we do in `splitting_field.algebra'` below. -/
instance algebra (n : ℕ) : Π (R : Type*) {K : Type u} [comm_semiring R] [field K],
  by exactI Π [algebra R K] {f : polynomial K} (hfn : f.nat_degree = n),
    algebra R (splitting_field_aux n f hfn) :=
nat.rec_on n (λ R K _ _ _ _ _, by exactI ‹algebra R K›) $
         λ n ih R K _ _ _ f hfn, by exactI ih R (nat_degree_remove_factor' hfn)

instance is_scalar_tower (n : ℕ) : Π (R₁ R₂ : Type*) {K : Type u}
  [comm_semiring R₁] [comm_semiring R₂] [has_scalar R₁ R₂] [field K],
  by exactI Π [algebra R₁ K] [algebra R₂ K],
  by exactI Π [is_scalar_tower R₁ R₂ K] {f : polynomial K} (hfn : f.nat_degree = n),
    is_scalar_tower R₁ R₂ (splitting_field_aux n f hfn) :=
nat.rec_on n (λ R₁ R₂ K _ _ _ _ _ _ _ _ _, by exactI ‹is_scalar_tower R₁ R₂ K›) $
         λ n ih R₁ R₂ K _ _ _ _ _ _ _ f hfn, by exactI ih R₁ R₂ (nat_degree_remove_factor' hfn)

instance algebra''' {n : ℕ} {f : polynomial K} (hfn : f.nat_degree = n + 1) :
  algebra (adjoin_root f.factor)
    (splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn)) :=
splitting_field_aux.algebra n _ _

instance algebra' {n : ℕ} {f : polynomial K} (hfn : f.nat_degree = n + 1) :
  algebra (adjoin_root f.factor) (splitting_field_aux n.succ f hfn) :=
splitting_field_aux.algebra''' _

instance algebra'' {n : ℕ} {f : polynomial K} (hfn : f.nat_degree = n + 1) :
  algebra K (splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn)) :=
splitting_field_aux.algebra n K _

instance scalar_tower' {n : ℕ} {f : polynomial K} (hfn : f.nat_degree = n + 1) :
  is_scalar_tower K (adjoin_root f.factor)
    (splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn)) :=
begin
  -- finding this instance ourselves makes things faster
  haveI : is_scalar_tower K (adjoin_root f.factor) (adjoin_root f.factor) :=
    is_scalar_tower.right,
  exact
    splitting_field_aux.is_scalar_tower n K (adjoin_root f.factor) (nat_degree_remove_factor' hfn),
end

instance scalar_tower {n : ℕ} {f : polynomial K} (hfn : f.nat_degree = n + 1) :
  is_scalar_tower K (adjoin_root f.factor) (splitting_field_aux _ f hfn) :=
splitting_field_aux.scalar_tower' _

theorem algebra_map_succ (n : ℕ) (f : polynomial K) (hfn : f.nat_degree = n + 1) :
  by exact algebra_map K (splitting_field_aux _ _ hfn) =
    (algebra_map (adjoin_root f.factor)
        (splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn))).comp
      (adjoin_root.of f.factor) :=
is_scalar_tower.algebra_map_eq _ _ _

protected theorem splits (n : ℕ) : ∀ {K : Type u} [field K], by exactI
  ∀ (f : polynomial K) (hfn : f.nat_degree = n),
    splits (algebra_map K $ splitting_field_aux n f hfn) f :=
nat.rec_on n (λ K _ _ hf, by exactI splits_of_degree_le_one _
  (le_trans degree_le_nat_degree $ hf.symm ▸ with_bot.coe_le_coe.2 zero_le_one)) $ λ n ih K _ f hf,
by { resetI, rw [← splits_id_iff_splits, algebra_map_succ, ← map_map, splits_id_iff_splits,
    ← X_sub_C_mul_remove_factor f (λ h, by { rw h at hf, cases hf })],
exact splits_mul _ (splits_X_sub_C _) (ih _ _) }

theorem exists_lift (n : ℕ) : ∀ {K : Type u} [field K], by exactI
  ∀ (f : polynomial K) (hfn : f.nat_degree = n) {L : Type*} [field L], by exactI
    ∀ (j : K →+* L) (hf : splits j f), ∃ k : splitting_field_aux n f hfn →+* L,
      k.comp (algebra_map _ _) = j :=
nat.rec_on n (λ K _ _ _ L _ j _, by exactI ⟨j, j.comp_id⟩) $ λ n ih K _ f hf L _ j hj, by exactI
have hndf : f.nat_degree ≠ 0, by { intro h, rw h at hf, cases hf },
have hfn0 : f ≠ 0, by { intro h, rw h at hndf, exact hndf rfl },
let ⟨r, hr⟩ := exists_root_of_splits _ (splits_of_splits_of_dvd j hfn0 hj
  (factor_dvd_of_nat_degree_ne_zero hndf))
  (mt is_unit_iff_degree_eq_zero.2 f.irreducible_factor.1) in
have hmf0 : map (adjoin_root.of f.factor) f ≠ 0, from map_ne_zero hfn0,
have hsf : splits (adjoin_root.lift j r hr) f.remove_factor,
by { rw ← X_sub_C_mul_remove_factor _ hndf at hmf0, refine (splits_of_splits_mul _ hmf0 _).2,
  rwa [X_sub_C_mul_remove_factor _ hndf, ← splits_id_iff_splits, map_map, adjoin_root.lift_comp_of,
      splits_id_iff_splits] },
let ⟨k, hk⟩ := ih f.remove_factor (nat_degree_remove_factor' hf) (adjoin_root.lift j r hr) hsf in
⟨k, by rw [algebra_map_succ, ← ring_hom.comp_assoc, hk, adjoin_root.lift_comp_of]⟩

theorem adjoin_roots (n : ℕ) : ∀ {K : Type u} [field K], by exactI
  ∀ (f : polynomial K) (hfn : f.nat_degree = n),
    algebra.adjoin K (↑(f.map $ algebra_map K $ splitting_field_aux n f hfn).roots.to_finset :
      set (splitting_field_aux n f hfn)) = ⊤ :=
nat.rec_on n (λ K _ f hf, by exactI algebra.eq_top_iff.2 (λ x, subalgebra.range_le _ ⟨x, rfl⟩)) $
λ n ih K _ f hfn, by exactI
have hndf : f.nat_degree ≠ 0, by { intro h, rw h at hfn, cases hfn },
have hfn0 : f ≠ 0, by { intro h, rw h at hndf, exact hndf rfl },
have hmf0 : map (algebra_map K (splitting_field_aux n.succ f hfn)) f ≠ 0 := map_ne_zero hfn0,
by { rw [algebra_map_succ, ← map_map, ← X_sub_C_mul_remove_factor _ hndf, map_mul] at hmf0 ⊢,
rw [roots_mul hmf0, map_sub, map_X, map_C, roots_X_sub_C, multiset.to_finset_add, finset.coe_union,
    multiset.to_finset_singleton, finset.coe_singleton,
    algebra.adjoin_union_eq_adjoin_adjoin, ← set.image_singleton,
    algebra.adjoin_algebra_map K (adjoin_root f.factor)
      (splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn)),
    adjoin_root.adjoin_root_eq_top, algebra.map_top,
    is_scalar_tower.adjoin_range_to_alg_hom K (adjoin_root f.factor)
      (splitting_field_aux n f.remove_factor (nat_degree_remove_factor' hfn)),
    ih, subalgebra.restrict_scalars_top] }

end splitting_field_aux

/-- A splitting field of a polynomial. -/
def splitting_field (f : polynomial K) :=
splitting_field_aux _ f rfl

namespace splitting_field

variables (f : polynomial K)

instance : field (splitting_field f) :=
splitting_field_aux.field _ _

instance inhabited : inhabited (splitting_field f) := ⟨37⟩

/-- This should be an instance globally, but it creates diamonds with the `ℕ` and `ℤ` actions:

```lean
example :
  (add_comm_monoid.nat_module : module ℕ (splitting_field f)) =
    @algebra.to_module _ _ _ _ (splitting_field.algebra' f) :=
rfl  -- fails

example :
  (add_comm_group.int_module _ : module ℤ (splitting_field f)) =
    @algebra.to_module _ _ _ _ (splitting_field.algebra' f) :=
rfl  -- fails
```

Until we resolve these diamonds, it's more convenient to only turn this instance on with
`local attribute [instance]` in places where the benefit of having the instance outweighs the cost.

In the meantime, the `splitting_field.algebra` instance below is immune to these particular diamonds
since `K = ℕ` and `K = ℤ` are not possible due to the `field K` assumption. Diamonds in
`algebra ℚ (splitting_field f)` instances are still possible, but this is a problem throughout the
library and not unique to this `algebra` instance.
-/
instance algebra' {R} [comm_semiring R] [algebra R K] : algebra R (splitting_field f) :=
splitting_field_aux.algebra _ _ _

instance : algebra K (splitting_field f) :=
splitting_field_aux.algebra _ _ _

protected theorem splits : splits (algebra_map K (splitting_field f)) f :=
splitting_field_aux.splits _ _ _

variables [algebra K L] (hb : splits (algebra_map K L) f)

/-- Embeds the splitting field into any other field that splits the polynomial. -/
def lift : splitting_field f →ₐ[K] L :=
{ commutes' := λ r, by { have := classical.some_spec (splitting_field_aux.exists_lift _ _ _ _ hb),
    exact ring_hom.ext_iff.1 this r },
  .. classical.some (splitting_field_aux.exists_lift _ _ _ _ hb) }

theorem adjoin_roots : algebra.adjoin K
    (↑(f.map (algebra_map K $ splitting_field f)).roots.to_finset : set (splitting_field f)) = ⊤ :=
splitting_field_aux.adjoin_roots _ _ _

theorem adjoin_root_set : algebra.adjoin K (f.root_set f.splitting_field) = ⊤ :=
adjoin_roots f

end splitting_field

variables (K L) [algebra K L]
/-- Typeclass characterising splitting fields. -/
class is_splitting_field (f : polynomial K) : Prop :=
(splits [] : splits (algebra_map K L) f)
(adjoin_roots [] : algebra.adjoin K (↑(f.map (algebra_map K L)).roots.to_finset : set L) = ⊤)

namespace is_splitting_field

variables {K}
instance splitting_field (f : polynomial K) : is_splitting_field K (splitting_field f) f :=
⟨splitting_field.splits f, splitting_field.adjoin_roots f⟩

section scalar_tower

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

variables {K}
instance map (f : polynomial F) [is_splitting_field F L f] :
  is_splitting_field K L (f.map $ algebra_map F K) :=
⟨by { rw [splits_map_iff, ← is_scalar_tower.algebra_map_eq], exact splits L f },
 subalgebra.restrict_scalars_injective F $
  by { rw [map_map, ← is_scalar_tower.algebra_map_eq, subalgebra.restrict_scalars_top,
    eq_top_iff, ← adjoin_roots L f, algebra.adjoin_le_iff],
  exact λ x hx, @algebra.subset_adjoin K _ _ _ _ _ _ hx }⟩

variables {K} (L)
theorem splits_iff (f : polynomial K) [is_splitting_field K L f] :
  polynomial.splits (ring_hom.id K) f ↔ (⊤ : subalgebra K L) = ⊥ :=
⟨λ h, eq_bot_iff.2 $ adjoin_roots L f ▸ (roots_map (algebra_map K L) h).symm ▸
  algebra.adjoin_le_iff.2 (λ y hy,
    let ⟨x, hxs, hxy⟩ := finset.mem_image.1 (by rwa multiset.to_finset_map at hy) in
    hxy ▸ set_like.mem_coe.2 $ subalgebra.algebra_map_mem _ _),
 λ h, @ring_equiv.to_ring_hom_refl K _ ▸
  ring_equiv.self_trans_symm (ring_equiv.of_bijective _ $ algebra.bijective_algebra_map_iff.2 h) ▸
  by { rw ring_equiv.to_ring_hom_trans, exact splits_comp_of_splits _ _ (splits L f) }⟩

theorem mul (f g : polynomial F) (hf : f ≠ 0) (hg : g ≠ 0) [is_splitting_field F K f]
  [is_splitting_field K L (g.map $ algebra_map F K)] :
  is_splitting_field F L (f * g) :=
⟨(is_scalar_tower.algebra_map_eq F K L).symm ▸ splits_mul _
  (splits_comp_of_splits _ _ (splits K f))
  ((splits_map_iff _ _).1 (splits L $ g.map $ algebra_map F K)),
 by rw [map_mul, roots_mul (mul_ne_zero (map_ne_zero hf : f.map (algebra_map F L) ≠ 0)
        (map_ne_zero hg)), multiset.to_finset_add, finset.coe_union,
      algebra.adjoin_union_eq_adjoin_adjoin,
      is_scalar_tower.algebra_map_eq F K L, ← map_map,
      roots_map (algebra_map K L) ((splits_id_iff_splits $ algebra_map F K).2 $ splits K f),
      multiset.to_finset_map, finset.coe_image, algebra.adjoin_algebra_map, adjoin_roots,
      algebra.map_top, is_scalar_tower.adjoin_range_to_alg_hom, ← map_map, adjoin_roots,
      subalgebra.restrict_scalars_top]⟩

end scalar_tower

/-- Splitting field of `f` embeds into any field that splits `f`. -/
def lift [algebra K F] (f : polynomial K) [is_splitting_field K L f]
  (hf : polynomial.splits (algebra_map K F) f) : L →ₐ[K] F :=
if hf0 : f = 0 then (algebra.of_id K F).comp $
  (algebra.bot_equiv K L : (⊥ : subalgebra K L) →ₐ[K] K).comp $
  by { rw ← (splits_iff L f).1 (show f.splits (ring_hom.id K), from hf0.symm ▸ splits_zero _),
  exact algebra.to_top } else
alg_hom.comp (by { rw ← adjoin_roots L f, exact classical.choice (lift_of_splits _ $ λ y hy,
    have aeval y f = 0, from (eval₂_eq_eval_map _).trans $
      (mem_roots $ by exact map_ne_zero hf0).1 (multiset.mem_to_finset.mp hy),
    ⟨is_algebraic_iff_is_integral.1 ⟨f, hf0, this⟩,
      splits_of_splits_of_dvd _ hf0 hf $ minpoly.dvd _ _ this⟩) })
  algebra.to_top

theorem finite_dimensional (f : polynomial K) [is_splitting_field K L f] : finite_dimensional K L :=
⟨@algebra.top_to_submodule K L _ _ _ ▸ adjoin_roots L f ▸
  fg_adjoin_of_finite (set.finite_mem_finset _) (λ y hy,
  if hf : f = 0
  then by { rw [hf, map_zero, roots_zero] at hy, cases hy }
  else is_algebraic_iff_is_integral.1 ⟨f, hf, (eval₂_eq_eval_map _).trans $
    (mem_roots $ by exact map_ne_zero hf).1 (multiset.mem_to_finset.mp hy)⟩)⟩

instance (f : polynomial K) : _root_.finite_dimensional K f.splitting_field :=
finite_dimensional f.splitting_field f

/-- Any splitting field is isomorphic to `splitting_field f`. -/
def alg_equiv (f : polynomial K) [is_splitting_field K L f] : L ≃ₐ[K] splitting_field f :=
begin
  refine alg_equiv.of_bijective (lift L f $ splits (splitting_field f) f)
    ⟨ring_hom.injective (lift L f $ splits (splitting_field f) f).to_ring_hom, _⟩,
  haveI := finite_dimensional (splitting_field f) f,
  haveI := finite_dimensional L f,
  have : finite_dimensional.finrank K L = finite_dimensional.finrank K (splitting_field f) :=
  le_antisymm
    (linear_map.finrank_le_finrank_of_injective
      (show function.injective (lift L f $ splits (splitting_field f) f).to_linear_map, from
        ring_hom.injective (lift L f $ splits (splitting_field f) f : L →+* f.splitting_field)))
    (linear_map.finrank_le_finrank_of_injective
      (show function.injective (lift (splitting_field f) f $ splits L f).to_linear_map, from
        ring_hom.injective (lift (splitting_field f) f $ splits L f : f.splitting_field →+* L))),
  change function.surjective (lift L f $ splits (splitting_field f) f).to_linear_map,
  refine (linear_map.injective_iff_surjective_of_finrank_eq_finrank this).1 _,
  exact ring_hom.injective (lift L f $ splits (splitting_field f) f : L →+* f.splitting_field)
end

end is_splitting_field

end splitting_field

end polynomial