/-
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 isomorpic
  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_refl _))];
      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}
  (h_nz : p ≠ 0) (hp : irreducible p) (hp_splits : splits (ring_hom.id L) p) :
  p.degree = 1 :=
begin
  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 : units L →* units (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`. -/
lemma prod_multiset_X_sub_C_of_monic_of_roots_card_eq {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 (ne_zero_of_monic hmonic),
      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,
    exact (add_right_inj p.nat_degree).mp (tactic.ring_exp.add_pf_sum_z degp rfl).symm },
  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

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

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


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module linear_algebra.tensor_algebra.grading
! leanprover-community/mathlib commit 2a7ceb0e411e459553a303d48eecdbb8553bd7ed
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.TensorAlgebra.Basic
import Mathbin.RingTheory.GradedAlgebra.Basic

/-!
# Results about the grading structure of the tensor algebra

The main result is `tensor_algebra.graded_algebra`, which says that the tensor algebra is a
ℕ-graded algebra.
-/

namespace TensorAlgebra

variable {R M : Type _} [CommSemiring R] [AddCommMonoid M] [Module R M]

open DirectSum

variable (R M)

/-- A version of `tensor_algebra.ι` that maps directly into the graded structure. This is
primarily an auxiliary construction used to provide `tensor_algebra.graded_algebra`. -/
def GradedAlgebra.ι : M →ₗ[R] ⨁ i : ℕ, ↥((ι R : M →ₗ[_] _).range ^ i) :=
  DirectSum.lof R ℕ (fun i => ↥((ι R : M →ₗ[_] _).range ^ i)) 1 ∘ₗ
    (ι R).codRestrict _ fun m => by simpa only [pow_one] using LinearMap.mem_range_self _ m
#align tensor_algebra.graded_algebra.ι TensorAlgebra.GradedAlgebra.ι

theorem GradedAlgebra.ι_apply (m : M) :
    GradedAlgebra.ι R M m =
      DirectSum.of (fun i => ↥((ι R : M →ₗ[_] _).range ^ i)) 1
        ⟨ι R m, by simpa only [pow_one] using LinearMap.mem_range_self _ m⟩ :=
  rfl
#align tensor_algebra.graded_algebra.ι_apply TensorAlgebra.GradedAlgebra.ι_apply

variable {R M}

/-- The tensor algebra is graded by the powers of the submodule `(tensor_algebra.ι R).range`. -/
instance gradedAlgebra :
    GradedAlgebra ((· ^ ·) (ι R : M →ₗ[R] TensorAlgebra R M).range : ℕ → Submodule R _) :=
  GradedAlgebra.ofAlgHom _ (lift R <| GradedAlgebra.ι R M)
    (by
      ext m
      dsimp only [LinearMap.comp_apply, AlgHom.toLinearMap_apply, AlgHom.comp_apply,
        AlgHom.id_apply]
      rw [lift_ι_apply, graded_algebra.ι_apply R M, DirectSum.coeAlgHom_of, Subtype.coe_mk])
    fun i x => by
    cases' x with x hx
    dsimp only [Subtype.coe_mk, DirectSum.lof_eq_of]
    refine'
      Submodule.pow_induction_on_left' _ (fun r => _) (fun x y i hx hy ihx ihy => _)
        (fun m hm i x hx ih => _) hx
    · rw [AlgHom.commutes, DirectSum.algebraMap_apply]
      rfl
    · rw [AlgHom.map_add, ihx, ihy, ← map_add]
      rfl
    · obtain ⟨_, rfl⟩ := hm
      rw [AlgHom.map_mul, ih, lift_ι_apply, graded_algebra.ι_apply R M, DirectSum.of_mul_of]
      exact DirectSum.of_eq_of_gradedMonoid_eq (Sigma.subtype_ext (add_comm _ _) rfl)
#align tensor_algebra.graded_algebra TensorAlgebra.gradedAlgebra

end TensorAlgebra


import game.world10.level15 -- hide
namespace mynat -- hide
/-

# Inequality world.

## Level 16: equivalence of two definitions of `<`

Now let's go the other way.
-/

/- Lemma :
For all naturals $a$ and $b$,
$$
\operatorname{succ}(a)\le b
\implies
a\le b\land\lnot(b\le a).$$
-/
lemma lt_aux_two (a b : mynat) : succ a ≤ b → a ≤ b ∧ ¬ (b ≤ a) :=
begin [nat_num_game]
  intro h,
  split,
  { apply le_trans a (succ a) b,
    exact le_succ_self a,
    exact h,
  },
  intro nh,
  apply ne_succ_self a,
  apply le_antisymm a (succ a),
  exact le_succ_self a,
  exact le_trans (succ a) b a h nh,

end

/-
Now for the payoff.
-/
end mynat -- hide


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yury Kudryashov
-/
import algebra.algebra.basic
import algebra.hom.iterate
import algebra.hom.non_unital_alg
import linear_algebra.tensor_product

/-!
# Facts about algebras involving bilinear maps and tensor products

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

We move a few basic statements about algebras out of `algebra.algebra.basic`,
in order to avoid importing `linear_algebra.bilinear_map` and
`linear_algebra.tensor_product` unnecessarily.
-/

open_locale tensor_product
open module

namespace linear_map

section non_unital_non_assoc

variables (R A : Type*) [comm_semiring R] [non_unital_non_assoc_semiring A]
  [module R A] [smul_comm_class R A A] [is_scalar_tower R A A]

/-- The multiplication in a non-unital non-associative algebra is a bilinear map.

A weaker version of this for semirings exists as `add_monoid_hom.mul`. -/
def mul : A →ₗ[R] A →ₗ[R] A := linear_map.mk₂ R (*) add_mul smul_mul_assoc mul_add mul_smul_comm

/-- The multiplication map on a non-unital algebra, as an `R`-linear map from `A ⊗[R] A` to `A`. -/
def mul' : A ⊗[R] A →ₗ[R] A :=
tensor_product.lift (mul R A)

variables {A}

/-- The multiplication on the left in a non-unital algebra is a linear map. -/
def mul_left (a : A) : A →ₗ[R] A := mul R A a

/-- The multiplication on the right in an algebra is a linear map. -/
def mul_right (a : A) : A →ₗ[R] A := (mul R A).flip a

/-- Simultaneous multiplication on the left and right is a linear map. -/
def mul_left_right (ab : A × A) : A →ₗ[R] A := (mul_right R ab.snd).comp (mul_left R ab.fst)

@[simp] lemma mul_left_to_add_monoid_hom (a : A) :
  (mul_left R a : A →+ A) = add_monoid_hom.mul_left a := rfl

@[simp] lemma mul_right_to_add_monoid_hom (a : A) :
  (mul_right R a : A →+ A) = add_monoid_hom.mul_right a := rfl

variables {R}

@[simp] lemma mul_apply' (a b : A) : mul R A a b = a * b := rfl
@[simp] lemma mul_left_apply (a b : A) : mul_left R a b = a * b := rfl
@[simp] lemma mul_right_apply (a b : A) : mul_right R a b = b * a := rfl
@[simp] lemma mul_left_right_apply (a b x : A) : mul_left_right R (a, b) x = a * x * b := rfl

@[simp] lemma mul'_apply {a b : A} : mul' R A (a ⊗ₜ b) = a * b := rfl

@[simp] lemma mul_left_zero_eq_zero :
  mul_left R (0 : A) = 0 :=
(mul R A).map_zero

@[simp] lemma mul_right_zero_eq_zero :
  mul_right R (0 : A) = 0 :=
(mul R A).flip.map_zero

end non_unital_non_assoc

section non_unital

variables (R A : Type*) [comm_semiring R] [non_unital_semiring A]
  [module R A] [smul_comm_class R A A] [is_scalar_tower R A A]

/-- The multiplication in a non-unital algebra is a bilinear map.

A weaker version of this for non-unital non-associative algebras exists as `linear_map.mul`. -/
def _root_.non_unital_alg_hom.lmul : A →ₙₐ[R] (End R A) :=
{ map_mul' := by { intros a b, ext c, exact mul_assoc a b c },
  map_zero' := by { ext a, exact zero_mul a },
  .. (mul R A) }

variables {R A}

@[simp]
lemma _root_.non_unital_alg_hom.coe_lmul_eq_mul : ⇑(non_unital_alg_hom.lmul R A) = mul R A := rfl

lemma commute_mul_left_right (a b : A) :
  commute (mul_left R a) (mul_right R b) :=
by { ext c, exact (mul_assoc a c b).symm, }

@[simp] lemma mul_left_mul (a b : A) :
  mul_left R (a * b) = (mul_left R a).comp (mul_left R b) :=
by { ext, simp only [mul_left_apply, comp_apply, mul_assoc] }

@[simp] lemma mul_right_mul (a b : A) :
  mul_right R (a * b) = (mul_right R b).comp (mul_right R a) :=
by { ext, simp only [mul_right_apply, comp_apply, mul_assoc] }

end non_unital

section semiring

variables (R A : Type*) [comm_semiring R] [semiring A] [algebra R A]

/-- The multiplication in an algebra is an algebra homomorphism into the endomorphisms on
the algebra.

A weaker version of this for non-unital algebras exists as `non_unital_alg_hom.mul`. -/
def _root_.algebra.lmul : A →ₐ[R] (End R A) :=
{ map_one' := by { ext a, exact one_mul a },
  map_mul' := by { intros a b, ext c, exact mul_assoc a b c },
  map_zero' := by { ext a, exact zero_mul a },
  commutes' := by { intro r, ext a, exact (algebra.smul_def r a).symm, },
  .. (linear_map.mul R A) }

variables {R A}

@[simp] lemma _root_.algebra.coe_lmul_eq_mul : ⇑(algebra.lmul R A) = mul R A := rfl

@[simp] lemma mul_left_eq_zero_iff (a : A) :
  mul_left R a = 0 ↔ a = 0 :=
begin
  split; intros h,
  { rw [← mul_one a, ← mul_left_apply a 1, h, linear_map.zero_apply], },
  { rw h, exact mul_left_zero_eq_zero, },
end

@[simp] lemma mul_right_eq_zero_iff (a : A) :
  mul_right R a = 0 ↔ a = 0 :=
begin
  split; intros h,
  { rw [← one_mul a, ← mul_right_apply a 1, h, linear_map.zero_apply], },
  { rw h, exact mul_right_zero_eq_zero, },
end

@[simp] lemma mul_left_one : mul_left R (1:A) = linear_map.id :=
by { ext, simp only [linear_map.id_coe, one_mul, id.def, mul_left_apply] }

@[simp] lemma mul_right_one : mul_right R (1:A) = linear_map.id :=
by { ext, simp only [linear_map.id_coe, mul_one, id.def, mul_right_apply] }

@[simp] lemma pow_mul_left (a : A) (n : ℕ) :
  (mul_left R a) ^ n = mul_left R (a ^ n) :=
by simpa only [mul_left, ←algebra.coe_lmul_eq_mul] using ((algebra.lmul R A).map_pow a n).symm

@[simp] lemma pow_mul_right (a : A) (n : ℕ) :
  (mul_right R a) ^ n = mul_right R (a ^ n) :=
begin
  simp only [mul_right, ←algebra.coe_lmul_eq_mul],
  exact linear_map.coe_injective
    (((mul_right R a).coe_pow n).symm ▸ (mul_right_iterate a n)),
end

end semiring

section ring

variables {R A : Type*} [comm_semiring R] [ring A] [algebra R A]

lemma mul_left_injective [no_zero_divisors A] {x : A} (hx : x ≠ 0) :
  function.injective (mul_left R x) :=
begin
  letI : nontrivial A := ⟨⟨x, 0, hx⟩⟩,
  letI := no_zero_divisors.to_is_domain A,
  exact mul_right_injective₀ hx,
end

lemma mul_right_injective [no_zero_divisors A] {x : A} (hx : x ≠ 0) :
  function.injective (mul_right R x) :=
begin
  letI : nontrivial A := ⟨⟨x, 0, hx⟩⟩,
  letI := no_zero_divisors.to_is_domain A,
  exact mul_left_injective₀ hx,
end

lemma mul_injective [no_zero_divisors A] {x : A} (hx : x ≠ 0) :
  function.injective (mul R A x) :=
begin
  letI : nontrivial A := ⟨⟨x, 0, hx⟩⟩,
  letI := no_zero_divisors.to_is_domain A,
  exact mul_right_injective₀ hx,
end

end ring

end linear_map


import data.fintype.card
import algebra.module.hom
import algebra.big_operators.fin
import algebraic_topology.simplicial_object

import algebra.homology.homological_complex

import for_mathlib.unop

namespace category_theory

variables {C : Type*} [category C] [preadditive C] (M : cosimplicial_object C)

namespace cosimplicial_object

open simplex_category finset add_monoid_hom category_theory.preadditive
open_locale simplicial big_operators

/-- The coboundary map in the alternating face map cochain complex. -/
def coboundary (n : ℕ) : M.obj [n] ⟶ M.obj [n+1] :=
∑ i : fin (n+2), (-1:ℤ)^(i:ℕ) • (M.δ i)

lemma coboundary_zero : coboundary M 0 = (M.δ 0) - (M.δ 1) :=
begin
  simp only [coboundary, fin.sum_univ_succ, fin.default_eq_zero, fin.coe_zero, one_zsmul,
    fin.coe_succ, univ_unique, neg_zsmul, pow_one, fin.succ_zero_eq_one, sum_singleton,
    pow_zero, sub_eq_add_neg]
end

@[reassoc]
lemma coboundary_coboundary (n : ℕ) : coboundary M n ≫ coboundary M (n+1) = 0 :=
begin
  let s : finset (fin (n+2) × fin (n+3)) := univ.filter (λ ij, (ij.2:ℕ) ≤ ij.1),
  calc coboundary M n ≫ coboundary M (n+1)
      = comp_hom (∑ (i:fin (n+2)), (-1:ℤ)^(i:ℕ) • (M.δ i))
                 (∑ (i:fin (n+3)), (-1:ℤ)^(i:ℕ) • (M.δ i)) : rfl
  ... = ∑ (i : fin (n+2)) (j : fin (n+3)), (-1:ℤ)^(i+j:ℕ) • ((M.δ i) ≫ (M.δ j)) : _
  ... = ∑ ij : fin (n+2) × fin (n+3), (-1:ℤ)^(ij.1+ij.2:ℕ) • ((M.δ ij.1) ≫ (M.δ ij.2)) :
        by rw [← univ_product_univ, sum_product]
  ... =   (∑ ij in s,  (-1:ℤ)^(ij.1+ij.2:ℕ) • ((M.δ ij.1) ≫ (M.δ ij.2)))
        + (∑ ij in sᶜ, (-1:ℤ)^(ij.1+ij.2:ℕ) • ((M.δ ij.1) ≫ (M.δ ij.2))) :
        by rw sum_add_sum_compl
  ... = 0 : _,
  { simp only [map_sum, map_zsmul, finset_sum_apply, smul_apply, smul_sum, pow_add, mul_smul],
    refl, },
  erw [← eq_neg_iff_add_eq_zero, ← finset.sum_neg_distrib],
  -- The sums are equal because we can give a bijection
  -- between the indexing sets, such that corresponding terms are equal.
  -- We get 4 goals. All the substance is in the second goal.
  refine (finset.sum_bij (λ (ij : fin (n+2) × fin (n+3)) hij,
    (ij.2.cast_lt (lt_of_le_of_lt (mem_filter.mp hij).right ij.1.is_lt), ij.1.succ))
    _ _ _ _),
  { -- Show that our function is well-defined
    rintro ⟨i,j⟩ hij, simp only [mem_filter, true_and, mem_univ, not_le, mem_compl, fin.coe_succ],
    dsimp [s] at hij ⊢, simp only [true_and, mem_filter, mem_univ] at hij,
    apply nat.lt_of_succ_le, apply nat.succ_le_succ, exact hij, },
  { -- The core of the proof.
    -- After all, we have to use the simplicial identity somewhere.
    rintros ⟨i,j⟩ hij_aux,
    have hij := (mem_filter.mp hij_aux).2,
    dsimp at hij ⊢,
    rw [δ_comp_δ], swap,
    { rwa ← fin.coe_fin_le },
    rw [← neg_zsmul],
    congr' 1,
    calc (-1) ^ (i + j : ℕ)
        = - (-1) ^ (i + j + 1 : ℕ) : _
    ... = - (-1) ^ (j + (i + 1) : ℕ) : _
    ... = _ : _,
    { rw [pow_succ, neg_one_mul, neg_neg] },
    { rw [add_assoc, add_left_comm] },
    { simp only [fin.coe_succ] } },
  { -- Show that our function is injective
    rintro ⟨i₁, j₁⟩ ⟨i₂, j₂⟩ hij₁ hij₂ h,
    rw [prod.mk.inj_iff, fin.eq_iff_veq, fin.eq_iff_veq] at h ⊢,
    simp at h,
    rwa [and_comm] at h, },
  { -- Show that our function is surjective
    rintro ⟨i,j⟩ hij,
    refine ⟨⟨j.pred _, i.cast_succ⟩, _, _⟩,
    { intro H,
      rw [H, mem_compl, mem_filter, not_and] at hij,
      exact hij (mem_univ _) (nat.zero_le _) },
    { cases i,
      simp only [true_and, mem_compl, mem_filter, mem_univ, not_le, fin.coe_pred] at hij ⊢,
      exact nat.le_pred_of_lt hij, },
    { ext; simp only [fin.succ_pred, fin.pred_succ, fin.cast_lt_cast_succ], }, },
end

/-- Make a cochain complex from a cosimplicial object. -/
def to_cocomplex : cochain_complex C ℕ := cochain_complex.of
(λ n, M.obj [n]) (λ n, M.coboundary n) M.coboundary_coboundary

/-- A functorial version of `to_cocomplex`. -/
def cocomplex : cosimplicial_object C ⥤ cochain_complex C ℕ :=
{ obj := to_cocomplex,
  map := λ M N f,
  { f := λ i, f.app _,
    comm' := begin
      rintro i j (rfl : i + 1 = j),
      dsimp [to_cocomplex, cochain_complex.of],
      simp only [if_pos rfl, category.comp_id, eq_to_hom_refl, coboundary, δ,
        preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp, nat_trans.naturality],
    end } }

namespace augmented

/-- The objects defining the cochain complex associated to an augmented cosimplicial object. -/
@[nolint unused_arguments]
def to_cocomplex_obj (M : augmented C) : ℕ → C
| 0 := augmented.point.obj M
| (n+1) := (augmented.drop.obj M).obj [n]

/-- The boundary maps defining the cochain complex associated to an augmented cosimplicial object.-/
def to_cocomplex_d {M : augmented C} : Π (n : ℕ), to_cocomplex_obj M n ⟶ to_cocomplex_obj M (n+1)
| 0 := M.hom.app _
| (n+1) := (augmented.drop.obj M).coboundary _

/-- The cochain complex associated to an augmented cosimplicial object. -/
@[simps]
def to_cocomplex (M : augmented C) : cochain_complex C ℕ := cochain_complex.of
(to_cocomplex_obj M) to_cocomplex_d
begin
  rintros (_|_),
  { dsimp [to_cocomplex_d],
    erw [coboundary_zero, preadditive.comp_sub, sub_eq_zero,
      ← M.hom.naturality, ← M.hom.naturality],
    refl },
  { apply coboundary_coboundary }
end

/-- A functorial version of to_cocomplex. -/
def cocomplex : augmented C ⥤ cochain_complex C ℕ :=
{ obj := to_cocomplex,
  map := λ M N f,
  { f := λ i,
    match i with
    | 0 := point.map f
    | (n+1) := (drop.map f).app _
    end,
    comm' := begin
      rintro i j (rfl : i + 1 = j),
      dsimp [to_cocomplex, cochain_complex.of],
      simp only [if_pos rfl, eq_to_hom_refl, category.comp_id],
      cases i,
      { dsimp [to_cocomplex_d],
        erw [← nat_trans.comp_app, ← f.w],
        refl },
      { dsimp [to_cocomplex_d, coboundary],
        simp only [preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp],
        apply fintype.sum_congr,
        intro i,
        erw (drop.map f).naturality,
        refl }
    end },
  map_id' := λ M, by { ext (_|_), tidy },
  map_comp' := λ M N K f g, by { ext (_|_), tidy } }

end augmented

end cosimplicial_object

end category_theory

namespace category_theory

variables {C : Type*} [category C] [preadditive C] (M : simplicial_object C)

namespace simplicial_object

open simplex_category finset category_theory.preadditive opposite
open_locale simplicial big_operators

/-- The boundary map in the alternating face map chain complex. -/
def boundary (n : ℕ) : M.obj (opposite.op [n+1]) ⟶ M.obj (opposite.op [n]) :=
∑ i : fin (n+2), (-1:ℤ)^(i:ℕ) • (M.δ i)

lemma boundary_zero : boundary M 0 = (M.δ 0) - (M.δ 1) :=
begin
  simp only [boundary, fin.sum_univ_succ, fin.default_eq_zero, fin.coe_zero, one_zsmul,
    fin.coe_succ, univ_unique, neg_zsmul, pow_one, fin.succ_zero_eq_one, sum_singleton,
    pow_zero, sub_eq_add_neg]
end

lemma coboundary_right_op (n : ℕ) :
  (cosimplicial_object.coboundary (M.right_op) n).unop = boundary M n :=
begin
  dsimp only [cosimplicial_object.coboundary, boundary],
  simp only [unop_sum, unop_zsmul],
  refl
end

@[reassoc]
lemma boundary_boundary (n : ℕ) : boundary M (n+1) ≫ boundary M n = 0 :=
begin
  rw [← coboundary_right_op, ← coboundary_right_op, ← unop_comp,
    cosimplicial_object.coboundary_coboundary, unop_zero],
end

/-- Make a chain complex from a simplicial object. -/
def to_complex : chain_complex C ℕ := chain_complex.of
(λ n, M.obj (opposite.op [n])) (λ n, M.boundary n) M.boundary_boundary

/-- A functorial version of `to_complex`. -/
def complex : simplicial_object C ⥤ chain_complex C ℕ :=
{ obj := to_complex,
  map := λ M N f,
  { f := λ i, f.app _,
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      dsimp [to_complex, chain_complex.of],
      simp only [if_pos rfl, category.id_comp, eq_to_hom_refl, boundary, δ,
        preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp, nat_trans.naturality],
    end } }

namespace augmented

/-- The objects defining the chain complex associated to an augmented simplicial object. -/
@[nolint unused_arguments]
def to_complex_obj (M : augmented C) : ℕ → C
| 0 := augmented.point.obj M
| (n+1) := (augmented.drop.obj M).obj (opposite.op [n])

/-- The boundary maps defining the chain complex associated to an augmented simplicial object.-/
def to_complex_d {M : augmented C} : Π (n : ℕ), to_complex_obj M (n+1) ⟶ to_complex_obj M n
| 0 := M.hom.app _
| (n+1) := (augmented.drop.obj M).boundary _

/-- The chain complex associated to an augmented simplicial object. -/
@[simps]
def to_complex (M : augmented C) : chain_complex C ℕ := chain_complex.of
(to_complex_obj M) to_complex_d
begin
  rintros (_|_),
  { dsimp [to_complex_d],
    erw [boundary_zero, preadditive.sub_comp, sub_eq_zero,
      M.hom.naturality, M.hom.naturality],
    refl },
  { apply boundary_boundary }
end

/-- A functorial version of to_complex. -/
def complex : augmented C ⥤ chain_complex C ℕ :=
{ obj := to_complex,
  map := λ M N f,
  { f := λ i,
    match i with
    | 0 := point.map f
    | (n+1) := (drop.map f).app _
    end,
    comm' := begin
      rintro i j (rfl : j + 1 = i),
      dsimp [to_complex, chain_complex.of],
      simp only [if_pos rfl, eq_to_hom_refl, category.id_comp],
      cases j,
      { dsimp [to_complex_d],
        erw [← nat_trans.comp_app, f.w],
        refl },
      { dsimp [to_complex_d, boundary],
        simp only [preadditive.sum_comp, preadditive.comp_sum, comp_zsmul, zsmul_comp],
        apply fintype.sum_congr,
        intro i,
        erw (drop.map f).naturality,
        refl }
    end },
  map_id' := λ M, by { ext (_|_), tidy },
  map_comp' := λ M N K f g, by { ext (_|_), tidy } }

end augmented

end simplicial_object

end category_theory


def piles : Type := (ℕ × ℕ × ℕ)

inductive take2 : piles → piles → Prop
| take12 : ∀ p q r : ℕ, take2 (nat.succ p, nat.succ q, r) (p, q, r)
| take13 : ∀ p q r : ℕ, take2 (nat.succ p, q, nat.succ r) (p, q, r)
| take23 : ∀ p q r : ℕ, take2 (p, nat.succ q, nat.succ r) (p, q, r)

inductive takeAll : piles → Prop
| takeAllEmpty : takeAll (0, 0, 0)
| takeAllStep : ∀ a b : piles, take2 a b → takeAll b → takeAll a

open nat

def isEven : ℕ → bool
| 0 := true
| 1 := false
| (succ (succ n)) := isEven n

def isTriangular (sum mx : ℕ) : bool :=
    sum ≥ mx * 2

def f (sum mx : ℕ) : bool :=
    isEven sum && isTriangular sum mx

theorem dicidability_of_take_all :
    ∃ f : ℕ → ℕ → bool,
        ∀ p q r, (f (p + q + r) (max p (max q r)) = true) ↔ takeAll (p, q, r)
        := begin
            existsi f,
            sorry
        end


import tactic
import data.real.basic data.int.basic init.data.int.basic
import data.complex.exponential
import analysis.special_functions.trigonometric

-- local imports
 import wonky_sq.basic

open real

/- 033
Let us try to prove some stuff just about radius (x + y), just to make it easier tp rove 032
-/

@[simp] lemma radius_add (a b m : ℝ) : radius (a + b) m = 1 / (|sin a * cos b + cos a * sin b| ^ m + |cos a * cos b - sin a * sin b| ^ m) ^ (1 / m) :=
begin
  unfold radius,
  rw [sin_add, cos_add],
  ---- rw pow_abs (sin a * cos b + cos a * sin b) m,
end

/- 031
Let us do the cosₘ x addition formula
-/

-- Thanks, I hate it.
@[simp] lemma cosm_add ( x y m : ℝ) : cosm (x + y) m = (cos x * cos y - sin x * sin y) / (|cos x * cos y - sin x * sin y| ^ m + |sin x * cos y + cos x * sin y|^m)^ (1/m) :=
begin
  unfold cosm,
  rw [radius_add, cos_add],
  simp,
  rw div_eq_inv_mul,
  rw [mul_comm, add_comm],
  -- nah, this is yuck. I think this is the most cursed thing in lean.
  -- it's worse.
  -- What have I proved: That this definition is just awful.
end

 -- that worked?!? No errors!

/- 032
Now, for the sinₘ x one!
-/

@[simp] lemma sinm_add (x y m : ℝ) : sinm (x + y) m = (sin x * cos y + cos x * sin y)/(|cos x * cos y - sin x * sin y|^m + |sin x * cos y + cos x * sin y|^m)^(1/m) :=
begin
  unfold sinm,
  rw [radius_add, sin_add],
  simp,
  rw div_eq_inv_mul,
  rw [mul_comm, add_comm],
end

/- 035

-/

@[simp] lemma sinm_2x (x m : ℝ) : sinm (2*x) m = (2 * sin x * cos x) / (|(cos x) ^2 - (sin x) ^2| ^ m + |2 * sin x * cos x|^m)^ (1/m)  :=
begin
  rw [mul_comm, mul_two, sinm_add];
  repeat {rw [mul_comm, ←mul_two, ←pow_two, ←pow_two]},
  rw [mul_comm], rw mul_assoc, rw mul_comm (sin x) (cos x),
end

/- 036

-/

@[simp] lemma cosm_2x (x m : ℝ) : cosm (2*x) m = ((cos x) ^ 2 - (sin x) ^ 2) / (|(cos x) ^2 - (sin x) ^2| ^ m + |2 * sin x * cos x|^m)^ (1/m)  :=
begin
  rw [mul_comm, mul_two, cosm_add];
  repeat {rw [←pow_two]},
  rw [mul_comm (sin x) (cos x), ←mul_two],
  rw [mul_comm (cos x) (sin x), mul_comm (sin x * cos x) 2, mul_assoc],
end

/- 036

-/

@[simp] lemma sinm_sub (x m y : ℝ) : sinm (x - y) m = (sin x * cos y - cos x * sin y)/(|cos x * cos y + sin x * sin y|^m + |sin x * cos y - cos x * sin y|^m)^(1/m) :=
begin
  rw sub_eq_add_neg,
  rw [sinm_add x (-y), cos_neg, sin_neg],
  repeat {rw ←neg_mul_eq_mul_neg},
  rw [one_div_eq_inv, sub_neg_eq_add],
  ring,
end

/- 039

-/

@[simp] lemma cosm_sub (x m y : ℝ) : cosm (x - y) m = (cos x * cos y + sin x * sin y) / (|cos x * cos y + sin x * sin y| ^ m + |sin x * cos y - cos x * sin y|^m)^ (1/m) :=
begin
  rw sub_eq_add_neg,
  rw [cosm_add x (-y), cos_neg, sin_neg],
  repeat {rw ←neg_mul_eq_mul_neg},
  rw [one_div_eq_inv, sub_neg_eq_add],
  ring,
end

/- 043

-/

@[simp] lemma cosm_sq_plus_sinm_sq (x m : ℝ) : cosm x m ^ 2 + sinm x m ^ 2 = radius x m ^ 2 :=
begin
  unfold sinm cosm,
  ring,
  rw [mul_comm (sin x ^2), ←mul_add (radius x m ^2) (cos x ^ 2) (sin x ^2), add_comm, sin_sq_add_cos_sq x, mul_one],
end

/- 045

-/

@[simp] lemma radius_nonneg (x m : ℝ) : 0 ≤ radius x m :=
begin
  unfold radius,
  ring,
  rw inv_nonneg,
  rw ←inv_eq_one_div,
  apply rpow_nonneg_of_nonneg,
  apply add_nonneg,
  repeat {apply rpow_nonneg_of_nonneg, apply abs_nonneg},
end

@[simp] lemma abs_radius_eq_radius (x m : ℝ) (H: 0 ≤ radius x m): |radius x m| = radius x m := abs_of_nonneg H

lemma cos_zero_im_sin_one (x : ℝ) (F : 0 ≤ sin x) : cos x = 0 → sin x = 1 :=
begin
   have H : sin x ^ 2 + cos x ^2 = 1,
   {rw sin_sq_add_cos_sq},
  intros,
  {
    rw a at H,
    norm_num at H,
    apply_fun sqrt at H,
    rw sqrt_sqr at H,
    rw sqrt_one at H,
    rw H,
    exact F,
  },
end

/- 044

-/

lemma cosm_powm_plus_sinm_powm (m n x : ℝ) (H : m ≠ 0) (F : 0 ≤ sin x) : |sinm x m|^m + |cosm x m|^m = 1 :=
begin
  unfold sinm cosm,
  repeat {rw [abs_mul, mul_rpow]},
  repeat{apply abs_nonneg,},
  --have H : radius_nonneg,
  rw abs_radius_eq_radius,
  rw ←add_mul,
  rw radius_powm m x m,
  rw ←div_eq_mul_one_div,
  rw div_self,
  {
    -- this looks like hell
    by_cases h : cos x = 0,
    {
      have fs : |sin x| = 1,
      {
        have f := sin_sq_add_cos_sq x,
        rw [h] at f,
        norm_num at f,
        apply_fun sqrt at f,
        rw [sqrt_sqr_eq_abs, sqrt_one] at f,
        exact f,
      },
      {
        rw [h, fs, abs_zero, zero_rpow],
        norm_num,
        exact H,
      },
    },
    {
      have hcpos : 0 < | cos x | ^ m := rpow_pos_of_pos (abs_pos_of_ne_zero h) _,
      have hsnn : 0 ≤ | sin x | ^ m := rpow_nonneg_of_nonneg (abs_nonneg _) _,
      linarith,
    },
  },
  {exact H},
  {apply radius_nonneg},
end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.products
import Mathlib.category_theory.discrete_category
import Mathlib.PostPort

universes v u

namespace Mathlib

namespace category_theory.limits

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a colimit, we can construct a limit for `F : J ⥤ Cᵒᵖ`.
-/
theorem has_limit_of_has_colimit_left_op {C : Type u} [category C] {J : Type v} [small_category J]
    (F : J ⥤ (Cᵒᵖ)) [has_colimit (functor.left_op F)] : has_limit F :=
  has_limit.mk
    (limit_cone.mk (cone_of_cocone_left_op (colimit.cocone (functor.left_op F)))
      (is_limit.mk
        fun (s : cone F) =>
          has_hom.hom.op (colimit.desc (functor.left_op F) (cocone_left_op_of_cone s))))

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
theorem has_limits_of_shape_op_of_has_colimits_of_shape {C : Type u} [category C] {J : Type v}
    [small_category J] [has_colimits_of_shape (Jᵒᵖ) C] : has_limits_of_shape J (Cᵒᵖ) :=
  has_limits_of_shape.mk fun (F : J ⥤ (Cᵒᵖ)) => has_limit_of_has_colimit_left_op F

/--
If `C` has colimits, we can construct limits for `Cᵒᵖ`.
-/
theorem has_limits_op_of_has_colimits {C : Type u} [category C] [has_colimits C] :
    has_limits (Cᵒᵖ) :=
  has_limits.mk
    fun (J : Type v) (𝒥 : small_category J) => has_limits_of_shape_op_of_has_colimits_of_shape

/--
If `F.left_op : Jᵒᵖ ⥤ C` has a limit, we can construct a colimit for `F : J ⥤ Cᵒᵖ`.
-/
theorem has_colimit_of_has_limit_left_op {C : Type u} [category C] {J : Type v} [small_category J]
    (F : J ⥤ (Cᵒᵖ)) [has_limit (functor.left_op F)] : has_colimit F :=
  has_colimit.mk
    (colimit_cocone.mk (cocone_of_cone_left_op (limit.cone (functor.left_op F)))
      (is_colimit.mk
        fun (s : cocone F) =>
          has_hom.hom.op (limit.lift (functor.left_op F) (cone_left_op_of_cocone s))))

/--
If `C` has colimits of shape `Jᵒᵖ`, we can construct limits in `Cᵒᵖ` of shape `J`.
-/
theorem has_colimits_of_shape_op_of_has_limits_of_shape {C : Type u} [category C] {J : Type v}
    [small_category J] [has_limits_of_shape (Jᵒᵖ) C] : has_colimits_of_shape J (Cᵒᵖ) :=
  has_colimits_of_shape.mk fun (F : J ⥤ (Cᵒᵖ)) => has_colimit_of_has_limit_left_op F

/--
If `C` has limits, we can construct colimits for `Cᵒᵖ`.
-/
theorem has_colimits_op_of_has_limits {C : Type u} [category C] [has_limits C] :
    has_colimits (Cᵒᵖ) :=
  has_colimits.mk
    fun (J : Type v) (𝒥 : small_category J) => has_colimits_of_shape_op_of_has_limits_of_shape

/--
If `C` has products indexed by `X`, then `Cᵒᵖ` has coproducts indexed by `X`.
-/
theorem has_coproducts_opposite {C : Type u} [category C] (X : Type v) [has_products_of_shape X C] :
    has_coproducts_of_shape X (Cᵒᵖ) :=
  has_colimits_of_shape_op_of_has_limits_of_shape

/--
If `C` has coproducts indexed by `X`, then `Cᵒᵖ` has products indexed by `X`.
-/
theorem has_products_opposite {C : Type u} [category C] (X : Type v) [has_coproducts_of_shape X C] :
    has_products_of_shape X (Cᵒᵖ) :=
  has_limits_of_shape_op_of_has_colimits_of_shape

end Mathlib


/-
Copyright (c) 2021 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca

! This file was ported from Lean 3 source module linear_algebra.free_module.rank
! leanprover-community/mathlib commit 1cfdf5f34e1044ecb65d10be753008baaf118edf
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.FreeModule.Basic
import Mathbin.LinearAlgebra.FinsuppVectorSpace

/-!

# Rank of free modules

This is a basic API for the rank of free modules.

-/

universe u v w

variable (R : Type u) (M : Type v) (N : Type w)

open TensorProduct DirectSum BigOperators Cardinal

open Cardinal

namespace Module.Free

section Ring

variable [Ring R] [StrongRankCondition R]

variable [AddCommGroup M] [Module R M] [Module.Free R M]

variable [AddCommGroup N] [Module R N] [Module.Free R N]

/-- The rank of a free module `M` over `R` is the cardinality of `choose_basis_index R M`. -/
theorem rank_eq_card_chooseBasisIndex : Module.rank R M = (#ChooseBasisIndex R M) :=
  (chooseBasis R M).mk_eq_dim''.symm
#align module.free.rank_eq_card_choose_basis_index Module.Free.rank_eq_card_chooseBasisIndex

/-- The rank of `(ι →₀ R)` is `(# ι).lift`. -/
@[simp]
theorem rank_finsupp {ι : Type v} : Module.rank R (ι →₀ R) = (#ι).lift := by
  simpa [lift_id', lift_umax] using (Basis.ofRepr (LinearEquiv.refl _ (ι →₀ R))).mk_eq_dim.symm
#align module.free.rank_finsupp Module.Free.rank_finsupp

/-- If `R` and `ι` lie in the same universe, the rank of `(ι →₀ R)` is `# ι`. -/
theorem rank_finsupp' {ι : Type u} : Module.rank R (ι →₀ R) = (#ι) := by simp
#align module.free.rank_finsupp' Module.Free.rank_finsupp'

/-- The rank of `M × N` is `(module.rank R M).lift + (module.rank R N).lift`. -/
@[simp]
theorem rank_prod :
    Module.rank R (M × N) = lift.{w, v} (Module.rank R M) + lift.{v, w} (Module.rank R N) := by
  simpa [rank_eq_card_choose_basis_index R M, rank_eq_card_choose_basis_index R N, lift_umax,
    lift_umax'] using ((choose_basis R M).Prod (choose_basis R N)).mk_eq_dim.symm
#align module.free.rank_prod Module.Free.rank_prod

/-- If `M` and `N` lie in the same universe, the rank of `M × N` is
  `(module.rank R M) + (module.rank R N)`. -/
theorem rank_prod' (N : Type v) [AddCommGroup N] [Module R N] [Module.Free R N] :
    Module.rank R (M × N) = Module.rank R M + Module.rank R N := by simp
#align module.free.rank_prod' Module.Free.rank_prod'

/-- The rank of the direct sum is the sum of the ranks. -/
@[simp]
theorem rank_directSum {ι : Type v} (M : ι → Type w) [∀ i : ι, AddCommGroup (M i)]
    [∀ i : ι, Module R (M i)] [∀ i : ι, Module.Free R (M i)] :
    Module.rank R (⨁ i, M i) = Cardinal.sum fun i => Module.rank R (M i) :=
  by
  let B i := choose_basis R (M i)
  let b : Basis _ R (⨁ i, M i) := Dfinsupp.basis fun i => B i
  simp [← b.mk_eq_dim'', fun i => (B i).mk_eq_dim'']
#align module.free.rank_direct_sum Module.Free.rank_directSum

/-- The rank of a finite product is the sum of the ranks. -/
@[simp]
theorem rank_pi_finite {ι : Type v} [Finite ι] {M : ι → Type w} [∀ i : ι, AddCommGroup (M i)]
    [∀ i : ι, Module R (M i)] [∀ i : ι, Module.Free R (M i)] :
    Module.rank R (∀ i, M i) = Cardinal.sum fun i => Module.rank R (M i) :=
  by
  cases nonempty_fintype ι
  rw [← (DirectSum.linearEquivFunOnFintype _ _ M).dim_eq, rank_direct_sum]
#align module.free.rank_pi_finite Module.Free.rank_pi_finite

/-- If `m` and `n` are `fintype`, the rank of `m × n` matrices is `(# m).lift * (# n).lift`. -/
@[simp]
theorem rank_matrix (m : Type v) (n : Type w) [Finite m] [Finite n] :
    Module.rank R (Matrix m n R) = lift.{max v w u, v} (#m) * lift.{max v w u, w} (#n) :=
  by
  cases nonempty_fintype m
  cases nonempty_fintype n
  have h := (Matrix.stdBasis R m n).mk_eq_dim
  rw [← lift_lift.{max v w u, max v w}, lift_inj] at h
  simpa using h.symm
#align module.free.rank_matrix Module.Free.rank_matrix

/-- If `m` and `n` are `fintype` that lie in the same universe, the rank of `m × n` matrices is
  `(# n * # m).lift`. -/
@[simp]
theorem rank_matrix' (m n : Type v) [Finite m] [Finite n] :
    Module.rank R (Matrix m n R) = ((#m) * (#n)).lift := by rw [rank_matrix, lift_mul, lift_umax]
#align module.free.rank_matrix' Module.Free.rank_matrix'

/-- If `m` and `n` are `fintype` that lie in the same universe as `R`, the rank of `m × n` matrices
  is `# m * # n`. -/
@[simp]
theorem rank_matrix'' (m n : Type u) [Finite m] [Finite n] :
    Module.rank R (Matrix m n R) = (#m) * (#n) := by simp
#align module.free.rank_matrix'' Module.Free.rank_matrix''

end Ring

section CommRing

variable [CommRing R] [StrongRankCondition R]

variable [AddCommGroup M] [Module R M] [Module.Free R M]

variable [AddCommGroup N] [Module R N] [Module.Free R N]

/-- The rank of `M ⊗[R] N` is `(module.rank R M).lift * (module.rank R N).lift`. -/
@[simp]
theorem rank_tensorProduct :
    Module.rank R (M ⊗[R] N) = lift.{w, v} (Module.rank R M) * lift.{v, w} (Module.rank R N) :=
  by
  let ιM := choose_basis_index R M
  let ιN := choose_basis_index R N
  have h₁ := LinearEquiv.lift_dim_eq (TensorProduct.congr (repr R M) (repr R N))
  let b : Basis (ιM × ιN) R (_ →₀ R) := Finsupp.basisSingleOne
  rw [LinearEquiv.dim_eq (finsuppTensorFinsupp' R ιM ιN), ← b.mk_eq_dim, mk_prod] at h₁
  rw [lift_inj.1 h₁, rank_eq_card_choose_basis_index R M, rank_eq_card_choose_basis_index R N]
#align module.free.rank_tensor_product Module.Free.rank_tensorProduct

/-- If `M` and `N` lie in the same universe, the rank of `M ⊗[R] N` is
  `(module.rank R M) * (module.rank R N)`. -/
theorem rank_tensor_product' (N : Type v) [AddCommGroup N] [Module R N] [Module.Free R N] :
    Module.rank R (M ⊗[R] N) = Module.rank R M * Module.rank R N := by simp
#align module.free.rank_tensor_product' Module.Free.rank_tensor_product'

end CommRing

end Module.Free