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

import linear_algebra.free_module.finite.basic
import linear_algebra.matrix.charpoly.coeff
import field_theory.minpoly

/-!

# Characteristic polynomial

We define the characteristic polynomial of `f : M →ₗ[R] M`, where `M` is a finite and
free `R`-module. The proof that `f.charpoly` is the characteristic polynomial of the matrix of `f`
in any basis is in `linear_algebra/charpoly/to_matrix`.

## Main definition

* `linear_map.charpoly f` : the characteristic polynomial of `f : M →ₗ[R] M`.

-/

universes u v w

variables {R : Type u} {M : Type v} [comm_ring R] [nontrivial R]
variables [add_comm_group M] [module R M] [module.free R M] [module.finite R M] (f : M →ₗ[R] M)

open_locale classical matrix polynomial

noncomputable theory

open module.free polynomial matrix

namespace linear_map

section basic

/-- The characteristic polynomial of `f : M →ₗ[R] M`. -/
def charpoly : R[X] :=
(to_matrix (choose_basis R M) (choose_basis R M) f).charpoly

end basic

section coeff

lemma charpoly_monic : f.charpoly.monic := charpoly_monic _

end coeff

section cayley_hamilton

/-- The **Cayley-Hamilton Theorem**, that the characteristic polynomial of a linear map, applied
to the linear map itself, is zero.

See `matrix.aeval_self_charpoly` for the equivalent statement about matrices. -/
lemma aeval_self_charpoly : aeval f f.charpoly = 0 :=
begin
  apply (linear_equiv.map_eq_zero_iff (alg_equiv_matrix _).to_linear_equiv).1,
  rw [alg_equiv.to_linear_equiv_apply, ← alg_equiv.coe_alg_hom,
    ← polynomial.aeval_alg_hom_apply _ _ _, charpoly_def],
  exact aeval_self_charpoly _,
end

lemma is_integral : is_integral R f := ⟨f.charpoly, ⟨charpoly_monic f, aeval_self_charpoly f⟩⟩

lemma minpoly_dvd_charpoly {K : Type u} {M : Type v} [field K] [add_comm_group M] [module K M]
  [finite_dimensional K M] (f : M →ₗ[K] M) : minpoly K f ∣ f.charpoly :=
minpoly.dvd _ _ (aeval_self_charpoly f)

/-- Any endomorphism polynomial `p` is equivalent under evaluation to `p %ₘ f.charpoly`; that is,
`p` is equivalent to a polynomial with degree less than the dimension of the module. -/
lemma aeval_eq_aeval_mod_charpoly (p : R[X]) : aeval f p = aeval f (p %ₘ f.charpoly) :=
(aeval_mod_by_monic_eq_self_of_root f.charpoly_monic f.aeval_self_charpoly).symm

/-- Any endomorphism power can be computed as the sum of endomorphism powers less than the
dimension of the module. -/
lemma pow_eq_aeval_mod_charpoly (k : ℕ) : f^k = aeval f (X^k %ₘ f.charpoly) :=
by rw [←aeval_eq_aeval_mod_charpoly, map_pow, aeval_X]

variable {f}

lemma minpoly_coeff_zero_of_injective (hf : function.injective f) : (minpoly R f).coeff 0 ≠ 0 :=
begin
  intro h,
  obtain ⟨P, hP⟩ := X_dvd_iff.2 h,
  have hdegP : P.degree < (minpoly R f).degree,
  { rw [hP, mul_comm],
    refine degree_lt_degree_mul_X (λ h, _),
    rw [h, mul_zero] at hP,
    exact minpoly.ne_zero (is_integral f) hP },
  have hPmonic : P.monic,
  { suffices : (minpoly R f).monic,
    { rwa [monic.def, hP, mul_comm, leading_coeff_mul_X, ← monic.def] at this },
    exact minpoly.monic (is_integral f) },
  have hzero : aeval f (minpoly R f) = 0 := minpoly.aeval _ _,
  simp only [hP, mul_eq_comp, ext_iff, hf, aeval_X, map_eq_zero_iff, coe_comp, alg_hom.map_mul,
    zero_apply] at hzero,
  exact not_le.2 hdegP (minpoly.min _ _ hPmonic (ext hzero)),
end

end cayley_hamilton

end linear_map


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import data.vector.basic
/-!
# Theorems about membership of elements in vectors

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

This file contains theorems for membership in a `v.to_list` for a vector `v`.
Having the length available in the type allows some of the lemmas to be
  simpler and more general than the original version for lists.
In particular we can avoid some assumptions about types being `inhabited`,
  and make more general statements about `head` and `tail`.
-/

namespace vector
variables {α β : Type*} {n : ℕ} (a a' : α)

@[simp] lemma nth_mem (i : fin n) (v : vector α n) : v.nth i ∈ v.to_list :=
by { rw nth_eq_nth_le,  exact list.nth_le_mem _ _ _ }

lemma mem_iff_nth (v : vector α n) : a ∈ v.to_list ↔ ∃ i, v.nth i = a :=
by simp only [list.mem_iff_nth_le, fin.exists_iff, vector.nth_eq_nth_le];
  exact ⟨λ ⟨i, hi, h⟩, ⟨i, by rwa to_list_length at hi, h⟩,
    λ ⟨i, hi, h⟩, ⟨i, by rwa to_list_length, h⟩⟩

lemma not_mem_zero (v : vector α 0) : a ∉ v.to_list :=
(vector.eq_nil v).symm ▸ (not_mem_nil a)

lemma mem_cons_iff (v : vector α n) :
  a' ∈ (a ::ᵥ v).to_list ↔ a' = a ∨ a' ∈ v.to_list :=
by rw [vector.to_list_cons, list.mem_cons_iff]

lemma mem_succ_iff (v : vector α (n + 1)) :
  a ∈ v.to_list ↔ a = v.head ∨ a ∈ v.tail.to_list :=
begin
  obtain ⟨a', v', h⟩ := exists_eq_cons v,
  simp_rw [h, vector.mem_cons_iff, vector.head_cons, vector.tail_cons],
end

lemma mem_cons_self (v : vector α n) : a ∈ (a ::ᵥ v).to_list :=
(vector.mem_iff_nth a (a ::ᵥ v)).2 ⟨0, vector.nth_cons_zero a v⟩

@[simp] lemma head_mem (v : vector α (n + 1)) : v.head ∈ v.to_list :=
(vector.mem_iff_nth v.head v).2 ⟨0, vector.nth_zero v⟩

lemma mem_cons_of_mem (v : vector α n) (ha' : a' ∈ v.to_list) : a' ∈ (a ::ᵥ v).to_list :=
(vector.mem_cons_iff a a' v).2 (or.inr ha')

lemma mem_of_mem_tail (v : vector α n) (ha : a ∈ v.tail.to_list) : a ∈ v.to_list :=
begin
  induction n with n hn,
  { exact false.elim (vector.not_mem_zero a v.tail ha) },
  { exact (mem_succ_iff a v).2 (or.inr ha) }
end

lemma mem_map_iff (b : β) (v : vector α n) (f : α → β) :
  b ∈ (v.map f).to_list ↔ ∃ (a : α), a ∈ v.to_list ∧ f a = b :=
by rw [vector.to_list_map, list.mem_map]

lemma not_mem_map_zero (b : β) (v : vector α 0) (f : α → β) : b ∉ (v.map f).to_list :=
by simpa only [vector.eq_nil v, vector.map_nil, vector.to_list_nil] using list.not_mem_nil b

lemma mem_map_succ_iff (b : β) (v : vector α (n + 1)) (f : α → β) :
  b ∈ (v.map f).to_list ↔ f v.head = b ∨ ∃ (a : α), a ∈ v.tail.to_list ∧ f a = b :=
by rw [mem_succ_iff, head_map, tail_map, mem_map_iff, @eq_comm _ b]

end vector


import ring_theory.ideals linear_algebra.quotient_module tactic.ring

open set function

universes u v w
variables {α : Type u} {β : Type v} [comm_ring α] [comm_ring β] {a b : α}

namespace is_ideal

lemma zero (S : set α) [is_ideal S] : (0 : α) ∈ S := is_submodule.zero_ α S

lemma add {S : set α} [is_ideal S] : a ∈ S → b ∈ S → a + b ∈ S := is_submodule.add_ α

lemma neg_iff {S : set α} [is_ideal S] : a ∈ S ↔ -a ∈ S := ⟨is_submodule.neg, λ h, neg_neg a ▸ is_submodule.neg h⟩

lemma sub {S : set α} [is_ideal S] : a ∈ S → b ∈ S → a - b ∈ S := is_submodule.sub

lemma mul_left {S : set α} [is_ideal S] : b ∈ S → a * b ∈ S := @is_submodule.smul α α _ _ _ _ a _

lemma mul_right {S : set α} [is_ideal S] : a ∈ S → a * b ∈ S := mul_comm b a ▸ mul_left

def quotient_rel (S : set α) [is_ideal S] := is_submodule.quotient_rel S

local attribute [instance] quotient_rel

def quotient (S : set α) [is_ideal S] := quotient (quotient_rel S)

instance (S : set α) [is_ideal S] : comm_ring (quotient S) :=
{ mul := λ a b, quotient.lift_on₂ a b (λ a b, ⟦a * b⟧)
  (λ a₁ a₂ b₁ b₂ (h₁ : a₁ - b₁ ∈ S) (h₂ : a₂ - b₂ ∈ S),
    quotient.sound
    (show a₁ * a₂ - b₁ * b₂ ∈ S, from
    have h : a₂ * (a₁ - b₁) + (a₂ - b₂) * b₁ =
      a₁ * a₂ - b₁ * b₂, by ring,
    h ▸ add (mul_left h₁) (mul_right h₂))),
  mul_assoc := λ a b c, quotient.induction_on₃ a b c $
    λ a b c, show ⟦_⟧ = ⟦_⟧, by rw mul_assoc,
  mul_comm := λ a b, quotient.induction_on₂ a b $
    λ a b, show ⟦_⟧ = ⟦_⟧, by rw mul_comm,
  one := ⟦1⟧,
  one_mul := λ a, quotient.induction_on a $
    λ a, show ⟦_⟧ = ⟦_⟧, by rw one_mul,
  mul_one := λ a, quotient.induction_on a $
    λ a, show ⟦_⟧ = ⟦_⟧, by rw mul_one,
  left_distrib := λ a b c, quotient.induction_on₃ a b c $
    λ a b c, show ⟦_⟧ = ⟦_⟧, by rw mul_add,
  right_distrib := λ a b c, quotient.induction_on₃ a b c $
    λ a b c, show ⟦_⟧ = ⟦_⟧, by rw add_mul,
  ..is_submodule.quotient.add_comm_group S }

lemma is_proper_ideal_iff_one_not_mem {S : set α} [hS : is_ideal S] :
  is_proper_ideal S ↔ (1 : α) ∉ S :=
⟨λ h h1, by exactI is_proper_ideal.ne_univ S
  (eq_univ_iff_forall.2 (λ a, mul_one a ▸ mul_left h1)),
λ h, {ne_univ := mt eq_univ_iff_forall.1 (λ ha, h (ha _)), ..hS}⟩

lemma quotient_eq_zero_iff_mem {S : set α} [is_ideal S] : ⟦a⟧ = (0 : quotient S) ↔ a ∈ S :=
by conv {to_rhs, rw ← sub_zero a }; exact quotient.eq

instance (S : set α) [is_prime_ideal S] : integral_domain (quotient S) :=
{ zero_ne_one := ne.symm $ mt quotient_eq_zero_iff_mem.1
    (is_proper_ideal_iff_one_not_mem.1 (by apply_instance)),
  eq_zero_or_eq_zero_of_mul_eq_zero := λ a b,
    quotient.induction_on₂ a b $ λ a b hab,
      (is_prime_ideal.mem_or_mem_of_mul_mem
        (quotient_eq_zero_iff_mem.1 hab)).elim
      (or.inl ∘ quotient_eq_zero_iff_mem.2)
      (or.inr ∘ quotient_eq_zero_iff_mem.2),
  ..is_ideal.comm_ring S }

instance (S : set α) : is_ideal (span S) :=
{ ..show is_submodule (span S), by apply_instance }

lemma exists_inv {S : set α} [is_maximal_ideal S] {a : quotient S} : a ≠ 0 →
  ∃ b : quotient S, a * b = 1 :=
quotient.induction_on  a $ λ a ha,
classical.by_contradiction $ λ h,
have haS : a ∉ S := mt quotient_eq_zero_iff_mem.2 ha,
by haveI hS : is_proper_ideal (span (set.insert a S)) :=
  is_proper_ideal_iff_one_not_mem.2
  (mt mem_span_insert.1 $ λ ⟨b, hb⟩,
  h ⟨-⟦b⟧, quotient.sound (show a * -b - 1 ∈ S,
    from neg_iff.2 (begin
      rw [neg_sub, mul_neg_eq_neg_mul_symm, sub_eq_add_neg, neg_neg, mul_comm],
      rw span_eq_of_is_submodule (show is_submodule S, by apply_instance) at hb,
      exact hb
    end))⟩);
exact
  have span (set.insert a S) = S :=
    or.resolve_right (is_maximal_ideal.eq_or_univ_of_subset (span (set.insert a S))
    (subset.trans (subset_insert _ _) subset_span)) (is_proper_ideal.ne_univ _),
  haS (this ▸ subset_span (mem_insert _ _))

local attribute [instance] classical.prop_decidable

/-- quotient by maximal ideal is a field. A definition rather than an instance, since
it is noncomputable, and users may have a computable inverse in some applications-/
noncomputable def field (S : set α) [is_maximal_ideal S] : field (quotient S) :=
{ zero_ne_one := ne.symm $ mt quotient_eq_zero_iff_mem.1
    (is_proper_ideal_iff_one_not_mem.1 (by apply_instance)),
  inv := λ a, if ha : a = 0 then 0 else classical.some (exists_inv ha),
  mul_inv_cancel := λ a (ha : a ≠ 0), show a * dite _ _ _ = _,
    by rw dif_neg ha;
    exact classical.some_spec (exists_inv ha),
  inv_mul_cancel := λ a (ha : a ≠ 0), show dite _ _ _ * a = _,
    by rw [mul_comm, dif_neg ha];
    exact classical.some_spec (exists_inv ha),
  ..is_ideal.comm_ring S }

instance is_ring_hom_quotient_mk (S : set α) [is_ideal S] :
  @is_ring_hom _ (quotient S) _ _ quotient.mk :=
by refine {..}; intros; refl

end is_ideal


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

import algebra.group.defs
import order.basic
import order.monotone

/-!

# Covariants and contravariants

This file contains general lemmas and instances to work with the interactions between a relation and
an action on a Type.

The intended application is the splitting of the ordering from the algebraic assumptions on the
operations in the `ordered_[...]` hierarchy.

The strategy is to introduce two more flexible typeclasses, `covariant_class` and
`contravariant_class`:

* `covariant_class` models the implication `a ≤ b → c * a ≤ c * b` (multiplication is monotone),
* `contravariant_class` models the implication `a * b < a * c → b < c`.

Since `co(ntra)variant_class` takes as input the operation (typically `(+)` or `(*)`) and the order
relation (typically `(≤)` or `(<)`), these are the only two typeclasses that I have used.

The general approach is to formulate the lemma that you are interested in and prove it, with the
`ordered_[...]` typeclass of your liking.  After that, you convert the single typeclass,
say `[ordered_cancel_monoid M]`, into three typeclasses, e.g.
`[left_cancel_semigroup M] [partial_order M] [covariant_class M M (function.swap (*)) (≤)]`
and have a go at seeing if the proof still works!

Note that it is possible to combine several co(ntra)variant_class assumptions together.
Indeed, the usual ordered typeclasses arise from assuming the pair
`[covariant_class M M (*) (≤)] [contravariant_class M M (*) (<)]`
on top of order/algebraic assumptions.

A formal remark is that normally `covariant_class` uses the `(≤)`-relation, while
`contravariant_class` uses the `(<)`-relation. This need not be the case in general, but seems to be
the most common usage. In the opposite direction, the implication
```lean
[semigroup α] [partial_order α] [contravariant_class α α (*) (≤)] => left_cancel_semigroup α
```
holds -- note the `co*ntra*` assumption on the `(≤)`-relation.

# Formalization notes

We stick to the convention of using `function.swap (*)` (or `function.swap (+)`), for the
typeclass assumptions, since `function.swap` is slightly better behaved than `flip`.
However, sometimes as a **non-typeclass** assumption, we prefer `flip (*)` (or `flip (+)`),
as it is easier to use. -/

-- TODO: convert `has_exists_mul_of_le`, `has_exists_add_of_le`?
-- TODO: relationship with `con/add_con`
-- TODO: include equivalence of `left_cancel_semigroup` with
-- `semigroup partial_order contravariant_class α α (*) (≤)`?
-- TODO : use ⇒, as per Eric's suggestion?  See
-- https://leanprover.zulipchat.com/#narrow/stream/116395-maths/topic/ordered.20stuff/near/236148738
-- for a discussion.

open function

section variants
variables {M N : Type*} (μ : M → N → N) (r : N → N → Prop)

variables (M N)
/-- `covariant` is useful to formulate succintly statements about the interactions between an
action of a Type on another one and a relation on the acted-upon Type.

See the `covariant_class` doc-string for its meaning. -/
def covariant     : Prop := ∀ (m) {n₁ n₂}, r n₁ n₂ → r (μ m n₁) (μ m n₂)

/-- `contravariant` is useful to formulate succintly statements about the interactions between an
action of a Type on another one and a relation on the acted-upon Type.

See the `contravariant_class` doc-string for its meaning. -/
def contravariant : Prop := ∀ (m) {n₁ n₂}, r (μ m n₁) (μ m n₂) → r n₁ n₂

/--  Given an action `μ` of a Type `M` on a Type `N` and a relation `r` on `N`, informally, the
`covariant_class` says that "the action `μ` preserves the relation `r`."

More precisely, the `covariant_class` is a class taking two Types `M N`, together with an "action"
`μ : M → N → N` and a relation `r : N → N → Prop`.  Its unique field `elim` is the assertion that
for all `m ∈ M` and all elements `n₁, n₂ ∈ N`, if the relation `r` holds for the pair
`(n₁, n₂)`, then, the relation `r` also holds for the pair `(μ m n₁, μ m n₂)`,
obtained from `(n₁, n₂)` by acting upon it by `m`.

If `m : M` and `h : r n₁ n₂`, then `covariant_class.elim m h : r (μ m n₁) (μ m n₂)`.
-/
@[protect_proj] class covariant_class : Prop :=
(elim :  covariant M N μ r)

/--  Given an action `μ` of a Type `M` on a Type `N` and a relation `r` on `N`, informally, the
`contravariant_class` says that "if the result of the action `μ` on a pair satisfies the
relation `r`, then the initial pair satisfied the relation `r`."

More precisely, the `contravariant_class` is a class taking two Types `M N`, together with an
"action" `μ : M → N → N` and a relation `r : N → N → Prop`.  Its unique field `elim` is the
assertion that for all `m ∈ M` and all elements `n₁, n₂ ∈ N`, if the relation `r` holds for the
pair `(μ m n₁, μ m n₂)` obtained from `(n₁, n₂)` by acting upon it by `m`, then, the relation
`r` also holds for the pair `(n₁, n₂)`.

If `m : M` and `h : r (μ m n₁) (μ m n₂)`, then `contravariant_class.elim m h : r n₁ n₂`.
-/
@[protect_proj] class contravariant_class : Prop :=
(elim : contravariant M N μ r)

lemma rel_iff_cov [covariant_class M N μ r] [contravariant_class M N μ r] (m : M) {a b : N} :
  r (μ m a) (μ m b) ↔ r a b :=
⟨contravariant_class.elim _, covariant_class.elim _⟩

section flip

variables {M N μ r}

lemma covariant.flip (h : covariant M N μ r) : covariant M N μ (flip r) :=
λ a b c hbc, h a hbc

lemma contravariant.flip (h : contravariant M N μ r) : contravariant M N μ (flip r) :=
λ a b c hbc, h a hbc

end flip

section covariant
variables {M N μ r} [covariant_class M N μ r]

lemma act_rel_act_of_rel (m : M) {a b : N} (ab : r a b) :
  r (μ m a) (μ m b) :=
covariant_class.elim _ ab

@[to_additive]
lemma group.covariant_iff_contravariant [group N] :
  covariant N N (*) r ↔ contravariant N N (*) r :=
begin
  refine ⟨λ h a b c bc, _, λ h a b c bc, _⟩,
  { rw [← inv_mul_cancel_left a b, ← inv_mul_cancel_left a c],
    exact h a⁻¹ bc },
  { rw [← inv_mul_cancel_left a b, ← inv_mul_cancel_left a c] at bc,
    exact h a⁻¹ bc }
end

@[to_additive]
lemma group.covconv [group N] [covariant_class N N (*) r] :
  contravariant_class N N (*) r :=
⟨group.covariant_iff_contravariant.mp covariant_class.elim⟩

section is_trans
variables [is_trans N r] (m n : M) {a b c d : N}

/-  Lemmas with 3 elements. -/
lemma act_rel_of_rel_of_act_rel (ab : r a b) (rl : r (μ m b) c) :
  r (μ m a) c :=
trans (act_rel_act_of_rel m ab) rl

lemma rel_act_of_rel_of_rel_act (ab : r a b) (rr : r c (μ m a)) :
  r c (μ m b) :=
trans rr (act_rel_act_of_rel _ ab)

end is_trans

end covariant

/-  Lemma with 4 elements. -/
section M_eq_N
variables {M N μ r} {mu : N → N → N} [is_trans N r]
  [covariant_class N N mu r] [covariant_class N N (swap mu) r] {a b c d : N}

lemma act_rel_act_of_rel_of_rel (ab : r a b) (cd : r c d) :
  r (mu a c) (mu b d) :=
trans (act_rel_act_of_rel c ab : _) (act_rel_act_of_rel b cd)

end M_eq_N

section contravariant
variables {M N μ r} [contravariant_class M N μ r]

lemma rel_of_act_rel_act (m : M) {a b : N} (ab : r (μ m a) (μ m b)) :
  r a b :=
contravariant_class.elim _ ab

section is_trans
variables [is_trans N r] (m n : M) {a b c d : N}

/-  Lemmas with 3 elements. -/
lemma act_rel_of_act_rel_of_rel_act_rel (ab : r (μ m a) b) (rl : r (μ m b) (μ m c)) :
  r (μ m a) c :=
trans ab (rel_of_act_rel_act m rl)

lemma rel_act_of_act_rel_act_of_rel_act (ab : r (μ m a) (μ m b)) (rr : r b (μ m c)) :
  r a (μ m c) :=
trans (rel_of_act_rel_act m ab) rr

end is_trans

end contravariant

section monotone

variables {α : Type*} {M N μ} [preorder α] [preorder N]
variable {f : N → α}

/-- The partial application of a constant to a covariant operator is monotone. -/
lemma covariant.monotone_of_const [covariant_class M N μ (≤)] (m : M) : monotone (μ m) :=
λ a b ha, covariant_class.elim m ha

/-- A monotone function remains monotone when composed with the partial application
of a covariant operator. E.g., `∀ (m : ℕ), monotone f → monotone (λ n, f (m + n))`. -/
lemma monotone.covariant_of_const [covariant_class M N μ (≤)] (hf : monotone f) (m : M) :
  monotone (λ n, f (μ m n)) :=
hf.comp $ covariant.monotone_of_const m

/-- Same as `monotone.covariant_of_const`, but with the constant on the other side of
the operator.  E.g., `∀ (m : ℕ), monotone f → monotone (λ n, f (n + m))`. -/
lemma monotone.covariant_of_const' {μ : N → N → N} [covariant_class N N (swap μ) (≤)]
  (hf : monotone f) (m : N) :
  monotone (λ n, f (μ n m)) :=
hf.comp $ covariant.monotone_of_const m

/-- Dual of `monotone.covariant_of_const` -/
lemma antitone.covariant_of_const [covariant_class M N μ (≤)] (hf : antitone f) (m : M) :
  antitone (λ n, f (μ m n)) :=
hf.comp_monotone $ covariant.monotone_of_const m

/-- Dual of `monotone.covariant_of_const'` -/
lemma antitone.covariant_of_const' {μ : N → N → N} [covariant_class N N (swap μ) (≤)]
  (hf : antitone f) (m : N) :
  antitone (λ n, f (μ n m)) :=
hf.comp_monotone $ covariant.monotone_of_const m

end monotone

lemma covariant_le_of_covariant_lt [partial_order N] :
  covariant M N μ (<) → covariant M N μ (≤) :=
begin
  refine λ h a b c bc, _,
  rcases le_iff_eq_or_lt.mp bc with rfl | bc,
  { exact rfl.le },
  { exact (h _ bc).le }
end

lemma contravariant_lt_of_contravariant_le [partial_order N] :
  contravariant M N μ (≤) → contravariant M N μ (<) :=
begin
  refine λ h a b c bc, lt_iff_le_and_ne.mpr ⟨h a bc.le, _⟩,
  rintro rfl,
  exact lt_irrefl _ bc,
end

lemma covariant_le_iff_contravariant_lt [linear_order N] :
  covariant M N μ (≤) ↔ contravariant M N μ (<) :=
⟨ λ h a b c bc, not_le.mp (λ k, not_le.mpr bc (h _ k)),
  λ h a b c bc, not_lt.mp (λ k, not_lt.mpr bc (h _ k))⟩

lemma covariant_lt_iff_contravariant_le [linear_order N] :
  covariant M N μ (<) ↔ contravariant M N μ (≤) :=
⟨ λ h a b c bc, not_lt.mp (λ k, not_lt.mpr bc (h _ k)),
  λ h a b c bc, not_le.mp (λ k, not_le.mpr bc (h _ k))⟩

@[to_additive]
lemma covariant_flip_mul_iff [comm_semigroup N] :
  covariant N N (flip (*)) (r) ↔ covariant N N (*) (r) :=
by rw is_symm_op.flip_eq

@[to_additive]
lemma contravariant_flip_mul_iff [comm_semigroup N] :
  contravariant N N (flip (*)) (r) ↔ contravariant N N (*) (r) :=
by rw is_symm_op.flip_eq

@[to_additive]
instance contravariant_mul_lt_of_covariant_mul_le [has_mul N] [linear_order N]
  [covariant_class N N (*) (≤)] : contravariant_class N N (*) (<) :=
{ elim := (covariant_le_iff_contravariant_lt N N (*)).mp covariant_class.elim }

@[to_additive]
instance covariant_mul_lt_of_contravariant_mul_le [has_mul N] [linear_order N]
  [contravariant_class N N (*) (≤)] : covariant_class N N (*) (<) :=
{ elim := (covariant_lt_iff_contravariant_le N N (*)).mpr contravariant_class.elim }

@[to_additive]
instance covariant_swap_mul_le_of_covariant_mul_le [comm_semigroup N] [has_le N]
  [covariant_class N N (*) (≤)] : covariant_class N N (swap (*)) (≤) :=
{ elim := (covariant_flip_mul_iff N (≤)).mpr covariant_class.elim }

@[to_additive]
instance contravariant_swap_mul_le_of_contravariant_mul_le [comm_semigroup N] [has_le N]
  [contravariant_class N N (*) (≤)] : contravariant_class N N (swap (*)) (≤) :=
{ elim := (contravariant_flip_mul_iff N (≤)).mpr contravariant_class.elim }

@[to_additive]
instance contravariant_swap_mul_lt_of_contravariant_mul_lt [comm_semigroup N] [has_lt N]
  [contravariant_class N N (*) (<)] : contravariant_class N N (swap (*)) (<) :=
{ elim := (contravariant_flip_mul_iff N (<)).mpr contravariant_class.elim }

@[to_additive]
instance covariant_swap_mul_lt_of_covariant_mul_lt [comm_semigroup N] [has_lt N]
  [covariant_class N N (*) (<)] : covariant_class N N (swap (*)) (<) :=
{ elim := (covariant_flip_mul_iff N (<)).mpr covariant_class.elim }

@[to_additive]
instance left_cancel_semigroup.covariant_mul_lt_of_covariant_mul_le
  [left_cancel_semigroup N] [partial_order N] [covariant_class N N (*) (≤)] :
  covariant_class N N (*) (<) :=
{ elim := λ a b c bc, by { cases lt_iff_le_and_ne.mp bc with bc cb,
    exact lt_iff_le_and_ne.mpr ⟨covariant_class.elim a bc, (mul_ne_mul_right a).mpr cb⟩ } }

@[to_additive]
instance right_cancel_semigroup.covariant_swap_mul_lt_of_covariant_swap_mul_le
  [right_cancel_semigroup N] [partial_order N] [covariant_class N N (swap (*)) (≤)] :
  covariant_class N N (swap (*)) (<) :=
{ elim := λ a b c bc, by { cases lt_iff_le_and_ne.mp bc with bc cb,
    exact lt_iff_le_and_ne.mpr ⟨covariant_class.elim a bc, (mul_ne_mul_left a).mpr cb⟩ } }

@[to_additive]
instance left_cancel_semigroup.contravariant_mul_le_of_contravariant_mul_lt
  [left_cancel_semigroup N] [partial_order N] [contravariant_class N N (*) (<)] :
  contravariant_class N N (*) (≤) :=
{ elim := λ a b c bc, by { cases le_iff_eq_or_lt.mp bc with h h,
    { exact ((mul_right_inj a).mp h).le },
    { exact (contravariant_class.elim _ h).le } } }

@[to_additive]
instance right_cancel_semigroup.contravariant_swap_mul_le_of_contravariant_swap_mul_lt
  [right_cancel_semigroup N] [partial_order N] [contravariant_class N N (swap (*)) (<)] :
  contravariant_class N N (swap (*)) (≤) :=
{ elim := λ a b c bc, by { cases le_iff_eq_or_lt.mp bc with h h,
    { exact ((mul_left_inj a).mp h).le },
    { exact (contravariant_class.elim _ h).le } } }

end variants


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

import Mathlib.Tactic.SimpRw

-- `simp_rw` can perform rewrites under binders:
example : (λ (x y : Nat) => x + y) = (λ x y => y + x) := by simp_rw [Nat.add_comm]

-- `simp_rw` can apply reverse rules:
example (f : Nat → Nat) {a b c : Nat} (ha : f b = a) (hc : f b = c) : a = c := by simp_rw [← ha, hc]

-- `simp_rw` applies rewrite rules multiple times:
example (a b c d : Nat) : a + (b + (c + d)) = ((d + c) + b) + a := by simp_rw [Nat.add_comm]

-- `simp_rw` can also rewrite in assumptions:
example (p : Nat → Prop) (a b : Nat) (h : p (a + b)) : p (b + a) :=
by {simp_rw [Nat.add_comm a b] at h; exact h}
-- or at multiple assumptions:
example (p : Nat → Prop) (a b : Nat) (h₁ : p (b + a) → p (a + b))  (h₂ : p (a + b)) : p (b + a) :=
by {simp_rw [Nat.add_comm a b] at h₁ h₂; exact h₁ h₂}
-- or everywhere:
example (p : Nat → Prop) (a b : Nat) (h₁ : p (b + a) → p (a + b))  (h₂ : p (a + b)) : p (a + b) :=
by {simp_rw [Nat.add_comm a b] at *; exact h₁ h₂}

-- `simp` and `rw`, alone, can't close this goal. But `simp_rw` can
example {a : Nat}
  (h1 : ∀ a b : Nat, a - 1 ≤ b ↔ a ≤ b + 1)
  (h2 : ∀ a b : Nat, a ≤ b ↔ ∀ c, c < a → c < b) :
  (∀ b, a - 1 ≤ b) = ∀ b c : Nat, c < a → c < b + 1 :=
by simp_rw [h1, h2]


import algebra.module

open list

-- The binomial coefficient, defined recursively on the natural numbers
def B : ℕ → ℕ → ℕ
| _ 0 := 1
| 0 _ := 0
| (n+1) (k+1) := B n (k+1) + B n k

-- This _almost_ holds definitionally, but requires cases on n
@[simp] lemma B.zero : Π {n : ℕ}, B n 0 = 1
| 0 := rfl
| (n+1) := rfl

@[simp] lemma B.gt : Π {n k : ℕ}, k > n → B n k = 0
| 0 0 h := absurd h (lt_irrefl 0)
| 0 (m+1) h := rfl
| (n+1) (m+1) h :=
    begin
    unfold B,
    rw [B.gt (nat.lt_of_succ_lt h), B.gt (nat.lt_of_succ_lt_succ h)],
    end

@[simp] lemma B.self : Π {n : ℕ}, B n n = 1
| 0 := rfl
| (n+1) :=
    begin
    unfold B,
    rw [@B.self n, B.gt (le_refl (nat.succ n))],
    end

lemma B.symm : Π {n k : ℕ}, k ≤ n → B n k = B n (n-k)
| 0 0 h := rfl
| (n+1) 0 h := by unfold B; simp
| (n+1) (k+1) h :=
    begin
    unfold B, simp,
    by_cases honk : n = k,
    { rw honk, simp [nat.sub_self], rw [B.gt (le_refl (nat.succ k))] },
    have : k < n,
        cases lt_or_eq_of_le (nat.le_of_succ_le_succ h),
        exact h_1, exfalso, cc,
    rw [B.symm (nat.le_of_succ_le_succ h), B.symm this],
    cases heckin : (n-k),
    exfalso, have := nat.sub_pos_of_lt this, exact ne_of_gt this heckin,
    unfold B,
    congr, rw [nat.sub_succ, heckin], refl,
    end

lemma list.range_core.concat : Π {n : ℕ} {l : list ℕ},
    range_core n l = range_core n [] ++ l
| 0 l := rfl
| (n+1) [] := by simp
| (n+1) (hd :: tl) :=
    begin
    unfold1 range_core,
    rw [@list.range_core.concat n [n]],
    rw [@list.range_core.concat n (n :: hd :: tl)],
    simp,
    end

-- Split apart a range into lower and upper parts, where the upper part
-- is a range that is mapped using addition.
lemma list.range_core.split {n m : ℕ} :
    range (n+m) = range n ++ map (λ i, i+n) (range m) :=
    begin
    induction m with m, simp [range, range_core],
    unfold1 range, unfold1 range_core,
    rw [@list.range_core.concat (n+m), @list.range_core.concat m],
    rw [map_append, ← list.append_assoc],
    unfold map, tactic.congr_core, exact m_ih, rw add_comm,
    end

lemma range_core.step {n : ℕ} :
    range (nat.succ n) = range n ++ [n] :=
    have this : map (λ (i : ℕ), i + n) (range 1) = [n]
      := by simp [range, range_core],
    eq.subst this (@list.range_core.split n 1)

-- A product distributes across each term of the sum.
lemma list.sum.distrib {α : Type} [semiring α] {a : α} {l : list α} :
    a * sum l = sum (map (λ b, a*b) l) :=
    begin
    induction l, simp,
    rw [sum_cons, left_distrib, map_cons, sum_cons, l_ih],
    end

-- Sums mapped over the same list can be combined pairwise,
-- when commutativity holds.
lemma list.sum.combine {α β : Type} [add_comm_monoid β] {f g : α → β} {l : list α} :
    sum (map f l) + sum (map g l) = sum (map (λ a, f a+g a) l) :=
    begin
    induction l, { simp },
    unfold map, rw [sum_cons, sum_cons, sum_cons],
    transitivity,
    show f l_hd + sum (map f l_tl) + (g l_hd + sum (map g l_tl))
        = f l_hd + g l_hd + (sum (map f l_tl) + sum (map g l_tl)), ac_refl,
    rw l_ih,
    end

-- This is the formula for the expansion of the power `n` of a binomial `(a+b)`,
-- where `a` and `b` are in some commutative semiring
def binomial.expansion {α : Type} [comm_semiring α] (a b : α) (n : ℕ) : α
    := sum (map (λ i, B n i * a^i * b^(n-i)) (range (n+1)))

-- The theorem that the expansion is correct
theorem binomial_theorem {α : Type} [comm_semiring α] (a b : α) (n : ℕ) :
    (a+b)^n = binomial.expansion a b n :=
    begin
    -- Classic induction on ℕ, of course!
    induction n with n ih,
    -- Base case is trivial, after unfolding some definitions
    { simp [range, range_core, binomial.expansion] },
    -- unfold the definition
    unfold binomial.expansion,
    -- split off the first binomial
    transitivity, apply pow_succ, transitivity,
    calc (a+b)*(a+b)^n
        -- start by expanding using induction hypothesis
        = (a+b) * binomial.expansion a b n : by rw ih
    ... = a * binomial.expansion a b n
        + b * binomial.expansion a b n : by rw right_distrib
        -- we will need to work with the sums separately
    ... = a*sum (map (λ i, B n i * a^i * b^(n-i)) (range (n+1)))
        + b*sum (map (λ i, B n i * a^i * b^(n-i)) (range (n+1))) : rfl
        -- distribute the `a` and `b` factors towards the inside
    ... = sum (map (λ i, a * (B n i * a^i * b^(n-i))) (range (n+1)))
        + sum (map (λ i, b * (B n i * a^i * b^(n-i))) (range (n+1))) :
        by rw [list.sum.distrib, list.sum.distrib, list.map_map, list.map_map]
        -- and add them to the exponents
    ... = sum (map (λ i, B n i * a^(i+1) * b^(n-i))   (range (n+1)))
        + sum (map (λ i, B n i * a^i     * b^(n-i+1)) (range (n+1))) :
        begin
        have : ∀ (c : α) (i : ℕ), c^(i+1) = c*c^i, intros, refl,
        -- simp reduces inside lambdas
        simp only [this a, this b],
        -- just focus on those lambdas
        congr,
        -- funny rearrangement of terms
        apply funext, intro i, simp [mul_comm, mul_assoc],
        apply funext, intro i, simp [mul_comm],
        rw [← mul_assoc, ← mul_assoc]
        end
        -- split off the `a` term
    ... = a^(n+1)
        + sum (map (λ i, B n i * a^(i+1) * b^(n-i))   (range n))
        + sum (map (λ i, B n i * a^i     * b^(n-i+1)) (range (n+1))) :
        begin
        rw [@range_core.step n, map_append, sum_append],
        simp [nat.sub_self],
        end
        -- split off the `b` term
    ... = a^(n+1)
        + sum (map (λ i, B n i     * a^(i+1) * b^(n-i))       (range n))
        + b^(n+1)
        + sum (map (λ i, B n (i+1) * a^(i+1) * b^(n-(i+1)+1)) (range n)) :
        begin
        rw [add_comm n 1, @list.range_core.split 1 n, map_append, sum_append],
        unfold1 range, unfold1 range_core, unfold1 range_core,
        unfold map, simp,
        end
        -- move them to the front, group the sums
    ... = a^(n+1) + b^(n+1)
        + (sum (map (λ i, B n i     * a^(i+1) * b^(n-i))       (range n))
        +  sum (map (λ i, B n (i+1) * a^(i+1) * b^(n-(i+1)+1)) (range n))) :
        by ac_refl
        -- simplify the exponent: `n-(i+1)+1 = n-i` for `i ∈ range n`
    ... = a^(n+1) + b^(n+1)
        + (sum (map (λ i, B n i     * a^(i+1) * b^(n-i)) (range n))
        +  sum (map (λ i, B n (i+1) * a^(i+1) * b^(n-i)) (range n))) :
        begin
            -- `n-(i+1)+1 = nat.pred (n - i) + 1`
            simp only [nat.sub_succ, nat.pred_succ],
            -- focus on this term
            suffices
                : map (λ i, ↑(B n (i + 1)) * a^(i+1) * b^(nat.pred (n-i) + 1)) (range n)
                = map (λ i, ↑(B n (i + 1)) * a^(i+1) * b^(n-i)) (range n),
                by rw this,
            -- which we can apply the special_map lemma to
            apply map_congr, intro i, intro ismem,
            -- and now we focus on this part
            suffices : nat.pred (n - i) + 1 = n - i, by rw this,
            -- `i ∈ range n ↔ i < n`
            rw list.mem_range at ismem,
            apply nat.succ_pred_eq_of_pos,
            exact nat.sub_pos_of_lt ismem,
        end
        -- okay, now we can combine the sums, since they range over the same list
    ... = a^(n+1) + b^(n+1)
        + sum (map (λ i, B n i     * a^(i+1) * b^(n-i)
                       + B n (i+1) * a^(i+1) * b^(n-i)) (range n)) :
        by rw list.sum.combine
        -- and they simplify nicely using the inductive definition of B
    ... = a^(n+1) + b^(n+1)
        + (sum (map (λ i, B (n+1) (i+1) * a^(i+1) * b^(n-i)) (range n))) :
        begin
            simp [mul_assoc, right_distrib, B.equations._eqn_4]
        end,
    -- split off the term a^(n+1) on the RHS to match the LHS
    rw [@range_core.step (n+1), map_append, sum_append],
    simp [nat.sub_self],
    -- and prove that the rest should be equal
    tactic.congr_core, refl,
    -- split off the first term on the RHS now
    rw [add_comm n 1],
    rw [@list.range_core.split 1 n, map_append, sum_append],
    unfold range range_core,
    simp, congr,
    -- prove that the mapping functions are equal
    -- simp helps with `(n+1)-(i+1) = n-i` in particular, yay!
    apply funext, intro i, simp,
    end


import tactic
import data.rat.default
import data.real.basic
import data.real.irrational
import analysis.inner_product_space.basic
import analysis.inner_product_space.pi_L2

open complex
open_locale big_operators
open_locale complex_conjugate

theorem rudin_1_1a (x : ℝ) (y : ℚ) :
  ( irrational x ) -> irrational ( x + y ) :=
begin
  apply irrational.add_rat,
end

theorem rudin_1_1b (x : ℝ) (y : ℚ) (h : y ≠ 0) :
  ( irrational x ) -> irrational ( x * y ) :=
begin
  intro g,
  apply irrational.mul_rat g h,
end

theorem rudin_1_2 :
  ¬ ∃ (x : ℚ), ( x ^ 2 = 12 ) :=
begin
  sorry,
end

theorem rudin_1_4 (α : Type*) [partial_order α] (s : set α) (x y : α)
  (h₀ : set.nonempty s) (h₁ : x ∈ lower_bounds s)
  (h₂ : y ∈ upper_bounds s) :
  x ≤ y :=
begin
  have h : ∃ z, z ∈ s := h₀,
  cases h with z,
  have xlez : x ≤ z :=
  begin
    apply h₁,
    assumption,
  end,
  have zley : z ≤ y :=
  begin
    apply h₂,
    assumption,
  end,
  exact xlez.trans zley,
end

theorem rudin_1_11 (z : ℂ) :
  ∃ (r : ℝ) (w : ℂ), abs w = 1 ∧ z = r * w :=
begin
  by_cases h : z = 0,
  {
    use [0, 1],
    simp,
    assumption,
  },
  {
    use abs z,
    use z / ↑(abs z),
    split,
    {
      simp,
      field_simp [h],
    },
    {
      field_simp [h],
      apply mul_comm,
    },
  },
end

theorem rudin_1_12 (n : ℕ) (f : ℕ → ℂ):
  abs (∑ i in finset.range n, f i) ≤ ∑ i in finset.range n,
  abs (f i) :=
begin
  induction n with n ih, simp,
  rw finset.range_succ,
  simp, transitivity,
  apply complex.abs_add,
  apply add_le_add_left,
  exact ih,
end

theorem rudin_1_13 (x y : ℂ) :
  |(abs x) - (abs y)| ≤ abs (x - y) :=
begin
  sorry,
end

theorem rudin_1_14 (z : ℂ) (h : abs z = 1) :
  (abs (1 + z)) ^ 2 + (abs (1 - z)) ^ 2 = 4 :=
begin
  sorry,
end

theorem rudina_1_16a (n : ℕ) (d r : ℝ) (x y z : euclidean_space ℝ (fin n))
  (h₁ : n ≥ 3) (h₂ : ∥x - y∥ = d) (h₃ : d > 0) (h₄ : r > 0) (h₅ : 2 * r > d) :
  set.infinite {z : euclidean_space ℝ (fin n) | ∥z - x∥ = r ∧ ∥z - y∥ = r} :=
begin
  sorry,
end

theorem rudin_1_17 (n : ℕ) (x y : euclidean_space ℝ (fin n)) :
  ∥x + y∥^2 + ∥x - y∥^2 = 2*∥x∥^2 + 2*∥y∥^2 :=
begin
  sorry,
end

theorem rudin_1_18a (n : ℕ) (h : n > 1) (x : euclidean_space ℝ (fin n)) :
  ∃ (y : euclidean_space ℝ (fin n)), y ≠ 0 ∧ (inner x y) = (0 : ℝ) :=
begin
  sorry,
end

theorem rudin_1_18b :
  ¬ ∀ (x : ℝ), ∃ (y : ℝ), y ≠ 0 ∧ x * y = 0 :=
begin
  simp,
  use 1,
  intros x h₁ h₂,
  cases h₂,
  {norm_num at h₂},
  {exact absurd h₂ h₁},
end

theorem rudin_1_19 (n : ℕ) (a b c x : euclidean_space ℝ (fin n)) (r : ℝ)
  (h₁ : r > 0) (h₂ : 3 • c = 4 • b - a) (h₃ : 3 * r = 2 * ∥x - b∥) :
  ∥x - a∥ = 2 * ∥x - b∥ ↔ ∥x - c∥ = r :=
begin
  sorry,
end


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

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

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 : K[X]) : Prop :=
f = 0 ∨ ∀ {g : L[X]}, irreducible g → g ∣ f.map i → degree g = 1

@[simp] lemma splits_zero : splits i (0 : K[X]) := 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 ((injective_iff_map_eq_zero i).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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (hf : nat_degree f = 1) : splits i f :=
splits_of_nat_degree_le_one i (le_of_eq hf)

lemma splits_mul {f g : K[X]} (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 : K[X]} (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 polynomial.map_mul; exact hg.trans (dvd_mul_right _ _)),
 or.inr $ λ g hgi hg, or.resolve_left h hfg hgi
   (by rw polynomial.map_mul; exact hg.trans (dvd_mul_left _ _))⟩

lemma splits_of_splits_of_dvd {f g : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} :
  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 : K[X]} (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 : K[X]} :
  (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 : K[X]} (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 : ι → K[X]} {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 : K[X]} (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 : ι → K[X]} {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 : L[X]}
  (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 : K[X]} (hs : splits i f) (hf0 : degree f ≠ 0) :
  ∃ x, eval₂ i x f = 0 :=
if hf0 : f = 0 then 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 roots_ne_zero_of_splits {f : K[X]} (hs : splits i f) (hf0 : nat_degree f ≠ 0) :
  (f.map i).roots ≠ 0 :=
let ⟨x, hx⟩ := exists_root_of_splits i hs (λ h, hf0 $ nat_degree_eq_of_degree_eq_some h) in
λ h, by { rw ← eval_map at hx,
  cases h.subst ((mem_roots _).2 hx), exact map_ne_zero (λ h, (h.subst hf0) rfl) }

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

theorem map_root_of_splits {f : K[X]} (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

lemma nat_degree_eq_card_roots {p : K[X]} {i : K →+* L}
  (hsplit : splits i p) : p.nat_degree = (p.map i).roots.card :=
begin
  by_cases hp : p = 0,
  { rw [hp, nat_degree_zero, polynomial.map_zero, roots_zero, multiset.card_zero] },
  obtain ⟨q, he, hd, hr⟩ := exists_prod_multiset_X_sub_C_mul (p.map i),
  rw [← splits_id_iff_splits, ← he] at hsplit,
  have hpm : p.map i ≠ 0 := map_ne_zero hp, rw ← he at hpm,
  have hq : q ≠ 0 := λ h, hpm (by rw [h, mul_zero]),
  rw [← nat_degree_map i, ← hd, add_right_eq_self],
  by_contra,
  have := roots_ne_zero_of_splits (ring_hom.id L) (splits_of_splits_mul _ _ hsplit).2 h,
  { rw map_id at this, exact this hr },
  { exact mul_ne_zero monic_prod_multiset_X_sub_C.ne_zero hq },
end

lemma degree_eq_card_roots {p : K[X]} {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]

theorem roots_map {f : K[X]} (hf : f.splits $ ring_hom.id K) :
  (f.map i).roots = f.roots.map i :=
(roots_map_of_injective_card_eq_total_degree i.injective $
  by { convert (nat_degree_eq_card_roots hf).symm, rw map_id }).symm

lemma eq_prod_roots_of_splits {p : K[X]} {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
  rw ← leading_coeff_map, symmetry,
  apply C_leading_coeff_mul_prod_multiset_X_sub_C,
  rw nat_degree_map, exact (nat_degree_eq_card_roots hsplit).symm,
end

lemma eq_prod_roots_of_splits_id {p : K[X]}
  (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 : K[X]}
  (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 : K[X]} (h_splits : splits i h)
  (h_roots : (h.map i).roots = {i x}) : h = C h.leading_coeff * (X - C x) :=
begin
  apply polynomial.map_injective _ i.injective,
  rw [eq_prod_roots_of_splits h_splits, h_roots],
  simp,
end

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 : K[X]} {s : multiset L}
  (hs : f.map i = C (i f.leading_coeff) * (s.map (λ a : L, X - C a)).prod) :
  splits i f :=
if hf0 : f = 0 then or.inl hf0
else or.inr $ λ p hp hdp, begin
  rw irreducible_iff_prime at hp,
  rw [hs, ← multiset.prod_to_list] at hdp,
  obtain (hd|hd) := hp.2.2 _ _ hdp,
  { refine (hp.2.1 $ is_unit_of_dvd_unit hd _).elim,
    exact is_unit_C.2 ((leading_coeff_ne_zero.2 hf0).is_unit.map i) },
  { obtain ⟨q, hq, hd⟩ := hp.dvd_prod_iff.1 hd,
    obtain ⟨a, ha, rfl⟩ := multiset.mem_map.1 ((multiset.mem_to_list _ _).1 hq),
    rw degree_eq_degree_of_associated ((hp.dvd_prime_iff_associated $ prime_X_sub_C a).1 hd),
    exact degree_X_sub_C a },
end

lemma splits_of_splits_id {f : K[X]} : 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 : K[X]} : splits i f ↔
  ∃ (s : multiset L), f.map i = C (i f.leading_coeff) * (s.map (λ a : L, X - C a)).prod :=
⟨λ hf, ⟨(f.map i).roots, eq_prod_roots_of_splits hf⟩, λ ⟨s, hs⟩, splits_of_exists_multiset i hs⟩

lemma splits_comp_of_splits (j : L →+* F) {f : K[X]}
  (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 polynomial splits if and only if it has as many roots as its degree. -/
lemma splits_iff_card_roots {p : K[X]} :
  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,
    rw splits_iff_exists_multiset (ring_hom.id K),
    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 : K[X]} (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 = (((P.map $ algebra_map K L).roots.erase r).map (λ a, r - a)).prod :=
begin
  replace hmo := hmo.map (algebra_map K L),
  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 : K[X]} (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 : K[X]} (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 $ (injective_iff_map_eq_zero _).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 : K[X]) : K[X] :=
if H : ∃ g, irreducible g ∧ g ∣ f then classical.some H else X

instance irreducible_factor (f : K[X]) : 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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]) : 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 : K[X]) (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 : K[X]) :
  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 : K[X]} {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 : K[X]),
  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 : K[X]) (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]} (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 : K[X]) (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 : K[X]) (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 : K[X]) (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 : K[X]) (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,
         polynomial.map_mul] at hmf0 ⊢,
rw [roots_mul hmf0, polynomial.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 : K[X]) :=
splitting_field_aux _ f rfl

namespace splitting_field

variables (f : K[X])

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 : K[X]) : 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 : K[X]) : 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 : F[X]) [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 : K[X]) [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 : F[X]) (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 [polynomial.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 : K[X]) [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 : K[X]) [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, polynomial.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 : K[X]) : _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 : K[X]) [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


import linear_algebra.determinant
import linear_algebra.matrix
open linear_map
notation f ` ⊚ `:80 g:80  := linear_map.comp f g
universe variables u v w  w'
open matrix
open_locale big_operators matrix

variables {R : Type v} [comm_ring R]
variables {X : Type w} [fintype X] [decidable_eq X]
variables {Y : Type w} [fintype Y] [decidable_eq Y]
variables {Z : Type w} [fintype Z] [decidable_eq Z]
/-!
   Study of the operation `to_matrix`.
   The file contain the classical operation of this function.
-/
lemma proof_strategy (A B : matrix X Y R) : to_lin A = to_lin B → A = B :=
begin
    intro hyp,
    have RR : to_matrix (to_lin A) = to_matrix (to_lin B),
        congr',
    iterate 2 {rw  to_lin_to_matrix  at RR},
    exact RR,
end
/--
    `(a * b) • M = a • (b • M)`
-/
lemma mul_smul_mat (a b : R ) (M : matrix X X R ) : (a * b) • M = a • (b • M) :=
begin
    apply matrix.ext, intros, exact mul_smul a b (M i j),
end
/--
    For composable morphism :
    `to_matrix (ψ ⊚ φ) =   to_matrix ψ  ⬝ to_matrix φ`
-/
@[simp]lemma to_matrix_mul (φ : (X → R) →ₗ[R] (Y → R))(ψ : (Y → R) →ₗ[R] (Z → R))  :
   to_matrix (ψ ⊚ φ) =   to_matrix ψ  ⬝ to_matrix φ :=
begin
    apply proof_strategy, erw to_matrix_to_lin,
    rw mul_to_lin, rw to_matrix_to_lin, rw to_matrix_to_lin,
end
/--
    `to_matrix (ψ + φ) =   to_matrix ψ  + to_matrix φ`
-/
@[simp]lemma to_matrix_add (φ ψ  : (X → R) →ₗ[R] (Y → R)) :
            to_matrix (φ + ψ ) = to_matrix (φ )+ to_matrix(ψ) :=
begin
    --change linear_equiv_matrix'.to_fun _ = _ ,
    --erw linear_equiv_matrix'.add, exact rfl,
    apply proof_strategy,
    rw to_matrix_to_lin,
    rw to_lin_add,
    rw to_matrix_to_lin, rw to_matrix_to_lin,
end
/-!
    For composable morphism :
    `to_matrix (ψ ⊚ φ) =   to_matrix ψ  ⬝ to_matrix φ`
-/

@[simp]lemma to_matrix_smul (r : R) (φ : (X → R) →ₗ[R] (Y → R))  :
   to_matrix (r •  φ) =   r •  (to_matrix φ) :=
begin
    apply proof_strategy,
    rw to_matrix_to_lin,
    erw is_linear_map.smul (to_lin) (r) (to_matrix (φ )),
    rw to_matrix_to_lin,
end
/-!
    `to_matrix (0) =   0`
-/
@[simp] lemma to_matrix_zero : to_matrix (0 : (X → R) →ₗ[R] (Y → R)) = 0 :=
begin
    apply proof_strategy, rw to_matrix_to_lin, rw to_lin_zero,
end
/-!
    `to_matrix (1) =   1`
-/
@[simp] lemma to_matrix_one  : to_matrix (1 : (X → R) →ₗ[R] (X → R)) = 1 :=
begin
    apply proof_strategy,
    rw to_matrix_to_lin,
    rw to_lin_one, exact rfl,
end
/-!
    `matrix.trace X R R (to_matrix (ψ  ⊚ φ )) =  matrix.trace Y R R (to_matrix (φ ⊚ ψ ))`
-/
@[simp]lemma to_matrix_trace_comm (φ : (X → R) →ₗ[R] (Y → R))(ψ : (Y → R) →ₗ[R] (X → R)) :
matrix.trace X R R (to_matrix (ψ  ⊚ φ )) =  matrix.trace Y R R (to_matrix (φ ⊚ ψ )) :=
begin
    rw to_matrix_mul,
    rw trace_mul_comm, rw ← to_matrix_mul,
end
/--
    `to_matrix (∑ w, φ w) = ∑ w, to_matrix (φ w)`
-/
lemma to_matrix_sum {W : Type w'} [fintype W][decidable_eq W] (φ : W → (X → R) →ₗ[R] (Y → R) ) :
to_matrix (∑ w, φ w) = ∑ w, to_matrix (φ w) :=
begin
    apply proof_strategy, rw to_matrix_to_lin,
    rw ←  finset.sum_hom finset.univ  to_lin,
    congr,funext,rw to_matrix_to_lin, by apply_instance,
end
/-!
    `trace  (∑ w, φ w) = ∑ w, trace (φ w)`
-/
lemma sum_trace {W : Type w'} [fintype W][decidable_eq W] (φ : W → (matrix X X R )) :
matrix.trace X R R (∑ w, φ w) = ∑ w, matrix.trace X R R (φ w) :=
begin
    rw ← finset.sum_hom finset.univ (matrix.trace X R R),
end
/--
    `trace (to_matrix ( ∑ w, φ w ) ) =  ∑ w, trace (to_matrix (  φ w ) )`
-/
lemma to_matrix_sum_trace {W : Type w'} [fintype W][decidable_eq W] (φ : W → (X → R) →ₗ[R] (X → R) ) :
matrix.trace X R R (to_matrix ( ∑ w, φ w ) ) =  ∑ w, matrix.trace X R R (to_matrix (  φ w ) ) :=
eq.trans  (congr_arg (matrix.trace X R R) (to_matrix_sum φ)) (sum_trace (λ w, to_matrix (φ w)))

/--
    For `φ : W → matrix Y X R ` we have  `(∑ s, φ s )  y x = ∑ s, (φ s y x)`
-/
lemma sum_apply_mat {W : Type w'} [fintype W][decidable_eq W] (φ : W → matrix Y X R )(x : X) (y : Y) : (∑ s, φ s )  y x = ∑ s, (φ s y x) :=
begin
    rw finset.sum_apply, rw finset.sum_apply,
end
/--
    `trace  M = ∑ i, M i i`
-/
lemma trace_value (M : matrix X X R) : matrix.trace X R R M = ∑ i, M i i := rfl

lemma homo_eq_diag (f : (X → R) →ₗ[R] (X → R))(t :R) (hyp : f + t • 1 = 0) :
to_matrix f = (- t) • (1 : matrix X X R ) :=
begin
    have : f = f+ t• 1+ (-t) • 1,
        simp,
    rw this, rw hyp,rw zero_add, rw to_matrix_smul, rw to_matrix_one,
end


class Semigroup (α : Type u) extends Mul α where
  mul_assoc (a b c : α) : a * b * c = a * (b * c)

export Semigroup (mul_assoc)

class MulComm (α : Type u)  extends Mul α where
  mul_comm (a b : α) : a * b = b * a

export MulComm (mul_comm)

class CommSemigroup (α : Type u) extends Semigroup α where
  mul_comm (a b : α) : a * b = b * a

instance [CommSemigroup α] : MulComm α where
  mul_comm := CommSemigroup.mul_comm

class One (α : Type u) where
  one : α

instance [One α] : OfNat α (nat_lit 1) where
  ofNat := One.one

class Monoid (α : Type u) extends Semigroup α, One α where
  one_mul (a : α) : 1 * a = a
  mul_one (a : α) : a * 1 = a

export Monoid (one_mul mul_one)

class CommMonoid (α : Type u) extends Monoid α where
  mul_comm (a b : α) : a * b = b * a

instance [CommMonoid α] : CommSemigroup α where
  mul_comm := CommMonoid.mul_comm

instance [CommMonoid α] : MulComm α where
  mul_comm := CommSemigroup.mul_comm

class Inv (α : Type u) where
  inv : α → α

postfix:max "⁻¹" => Inv.inv

class Group (α : Type u) extends Monoid α, Inv α where
  mul_left_inv (a : α) : a⁻¹ * a = 1

export Group (mul_left_inv)

class CommGroup (α : Type u) extends Group α where
  mul_comm (a b : α) : a * b = b * a

instance [CommGroup α] : CommMonoid α where
  mul_comm := CommGroup.mul_comm

instance [CommGroup α] : MulComm α where
  mul_comm := CommGroup.mul_comm

theorem inv_mul_cancel_left [Group α] (a b : α) : a⁻¹ * (a * b) = b := by
  rw [← mul_assoc, mul_left_inv, one_mul]

theorem inv_eq_of_mul_eq_one [Group α] {a b : α} (h : a * b = 1) : a⁻¹ = b := by
  rw [← mul_one a⁻¹, ←h, ←mul_assoc, mul_left_inv, one_mul]

theorem inv_inv [Group α] (a : α) : (a⁻¹)⁻¹ = a :=
  inv_eq_of_mul_eq_one (mul_left_inv a)

theorem mul_right_inv [Group α] (a : α) : a * a⁻¹ = 1 := by
  have : a⁻¹⁻¹ * a⁻¹ = 1 := by rw [mul_left_inv]
  rw [inv_inv] at this
  assumption

theorem mul_inv_rev [Group α] (a b : α) : (a * b)⁻¹ = b⁻¹ * a⁻¹ := by
  apply inv_eq_of_mul_eq_one
  rw [mul_assoc, ← mul_assoc b, mul_right_inv, one_mul, mul_right_inv]

theorem mul_inv [CommGroup α] (a b : α) : (a * b)⁻¹ = a⁻¹ * b⁻¹ := by
  rw [mul_inv_rev, mul_comm]


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Zorn's lemmas.

Ported from Isabelle/HOL (written by Jacques D. Fleuriot, Tobias Nipkow, and Christian Sternagel).
-/
import data.set.lattice
noncomputable theory

universes u
open set classical
open_locale classical

namespace zorn

section chain
parameters {α : Type u} (r : α → α → Prop)
local infix ` ≺ `:50  := r

/-- A chain is a subset `c` satisfying
  `x ≺ y ∨ x = y ∨ y ≺ x` for all `x y ∈ c`. -/
def chain (c : set α) := pairwise_on c (λ x y, x ≺ y ∨ y ≺ x)
parameters {r}

theorem chain.total_of_refl [is_refl α r]
  {c} (H : chain c) {x y} (hx : x ∈ c) (hy : y ∈ c) :
  x ≺ y ∨ y ≺ x :=
if e : x = y then or.inl (e ▸ refl _) else H _ hx _ hy e

theorem chain.mono {c c'} :
  c' ⊆ c → chain c → chain c' :=
pairwise_on.mono

theorem chain.directed_on [is_refl α r] {c} (H : chain c) :
  directed_on (≺) c :=
assume x hx y hy,
match H.total_of_refl hx hy with
| or.inl h := ⟨y, hy, h, refl _⟩
| or.inr h := ⟨x, hx, refl _, h⟩
end

theorem chain_insert {c : set α} {a : α} (hc : chain c) (ha : ∀ b ∈ c, b ≠ a → a ≺ b ∨ b ≺ a) :
  chain (insert a c) :=
forall_insert_of_forall
  (assume x hx, forall_insert_of_forall (hc x hx) (assume hneq, (ha x hx hneq).symm))
  (forall_insert_of_forall
    (assume x hx hneq, ha x hx $ assume h', hneq h'.symm) (assume h, (h rfl).rec _))

/-- `super_chain c₁ c₂` means that `c₂ is a chain that strictly includes `c₁`. -/
def super_chain (c₁ c₂ : set α) : Prop := chain c₂ ∧ c₁ ⊂ c₂

/-- A chain `c` is a maximal chain if there does not exists a chain strictly including `c`. -/
def is_max_chain (c : set α) := chain c ∧ ¬ (∃ c', super_chain c c')

/-- Given a set `c`, if there exists a chain `c'` strictly including `c`, then `succ_chain c`
is one of these chains. Otherwise it is `c`. -/
def succ_chain (c : set α) : set α :=
if h : ∃ c', chain c ∧ super_chain c c' then some h else c

theorem succ_spec {c : set α} (h : ∃ c', chain c ∧ super_chain c c') :
  super_chain c (succ_chain c) :=
let ⟨c', hc'⟩ := h in
have chain c ∧ super_chain c (some h),
  from @some_spec _ (λc', chain c ∧ super_chain c c') _,
by simp [succ_chain, dif_pos, h, this.right]

theorem chain_succ {c : set α} (hc : chain c) :
  chain (succ_chain c) :=
if h : ∃ c', chain c ∧ super_chain c c' then
  (succ_spec h).left
else
  by simp [succ_chain, dif_neg, h]; exact hc

theorem super_of_not_max {c : set α} (hc₁ : chain c) (hc₂ : ¬ is_max_chain c) :
  super_chain c (succ_chain c) :=
begin
  simp [is_max_chain, not_and_distrib, not_forall_not] at hc₂,
  cases hc₂.neg_resolve_left hc₁ with c' hc',
  exact succ_spec ⟨c', hc₁, hc'⟩
end

theorem succ_increasing {c : set α} :
  c ⊆ succ_chain c :=
if h : ∃ c', chain c ∧ super_chain c c' then
  have super_chain c (succ_chain c), from succ_spec h,
  this.right.left
else by simp [succ_chain, dif_neg, h, subset.refl]

/-- Set of sets reachable from `∅` using `succ_chain` and `⋃₀`. -/
inductive chain_closure : set α → Prop
| succ : ∀ {s}, chain_closure s → chain_closure (succ_chain s)
| union : ∀ {s}, (∀ a ∈ s, chain_closure a) → chain_closure (⋃₀ s)

theorem chain_closure_empty :
  chain_closure ∅ :=
have chain_closure (⋃₀ ∅),
  from chain_closure.union $ assume a h, h.rec _,
by simp at this; assumption

theorem chain_closure_closure :
  chain_closure (⋃₀ chain_closure) :=
chain_closure.union $ assume s hs, hs

variables {c c₁ c₂ c₃ : set α}

private lemma chain_closure_succ_total_aux (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂)
  (h : ∀ {c₃}, chain_closure c₃ → c₃ ⊆ c₂ → c₂ = c₃ ∨ succ_chain c₃ ⊆ c₂) :
  c₁ ⊆ c₂ ∨ succ_chain c₂ ⊆ c₁ :=
begin
  induction hc₁,
  case succ : c₃ hc₃ ih {
    cases ih with ih ih,
    { have h := h hc₃ ih,
      cases h with h h,
      { exact or.inr (h ▸ subset.refl _) },
      { exact or.inl h } },
    { exact or.inr (subset.trans ih succ_increasing) } },
  case union : s hs ih {
    refine (or_iff_not_imp_right.2 $ λ hn, sUnion_subset $ λ a ha, _),
    apply (ih a ha).resolve_right,
    apply mt (λ h, _) hn,
    exact subset.trans h (subset_sUnion_of_mem ha) }
end

private lemma chain_closure_succ_total (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂)
  (h : c₁ ⊆ c₂) :
  c₂ = c₁ ∨ succ_chain c₁ ⊆ c₂ :=
begin
  induction hc₂ generalizing c₁ hc₁ h,
  case succ : c₂ hc₂ ih {
    have h₁ : c₁ ⊆ c₂ ∨ @succ_chain α r c₂ ⊆ c₁ :=
      (chain_closure_succ_total_aux hc₁ hc₂ $ assume c₁, ih),
    cases h₁ with h₁ h₁,
    { have h₂ := ih hc₁ h₁,
      cases h₂ with h₂ h₂,
      { exact (or.inr $ h₂ ▸ subset.refl _) },
      { exact (or.inr $ subset.trans h₂ succ_increasing) } },
    { exact (or.inl $ subset.antisymm h₁ h) } },
  case union : s hs ih {
    apply or.imp_left (assume h', subset.antisymm h' h),
    apply classical.by_contradiction,
    simp [not_or_distrib, sUnion_subset_iff, not_forall],
    intros c₃ hc₃ h₁ h₂,
    have h := chain_closure_succ_total_aux hc₁ (hs c₃ hc₃) (assume c₄, ih _ hc₃),
    cases h with h h,
    { have h' := ih c₃ hc₃ hc₁ h,
      cases h' with h' h',
      { exact (h₁ $ h' ▸ subset.refl _) },
      { exact (h₂ $ subset.trans h' $ subset_sUnion_of_mem hc₃) } },
    { exact (h₁ $ subset.trans succ_increasing h) } }
end

theorem chain_closure_total (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂) :
  c₁ ⊆ c₂ ∨ c₂ ⊆ c₁ :=
have c₁ ⊆ c₂ ∨ succ_chain c₂ ⊆ c₁,
  from chain_closure_succ_total_aux hc₁ hc₂ $ assume c₃ hc₃, chain_closure_succ_total hc₃ hc₂,
or.imp_right (assume : succ_chain c₂ ⊆ c₁, subset.trans succ_increasing this) this

theorem chain_closure_succ_fixpoint (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂)
  (h_eq : succ_chain c₂ = c₂) :
  c₁ ⊆ c₂ :=
begin
  induction hc₁,
  case succ : c₁ hc₁ h {
    exact or.elim (chain_closure_succ_total hc₁ hc₂ h)
      (assume h, h ▸ h_eq.symm ▸ subset.refl c₂) id },
  case union : s hs ih {
    exact (sUnion_subset $ assume c₁ hc₁, ih c₁ hc₁) }
end

theorem chain_closure_succ_fixpoint_iff (hc : chain_closure c) :
  succ_chain c = c ↔ c = ⋃₀ chain_closure :=
⟨assume h, subset.antisymm
    (subset_sUnion_of_mem hc)
    (chain_closure_succ_fixpoint chain_closure_closure hc h),
  assume : c = ⋃₀{c : set α | chain_closure c},
  subset.antisymm
    (calc succ_chain c ⊆ ⋃₀{c : set α | chain_closure c} :
        subset_sUnion_of_mem $ chain_closure.succ hc
      ... = c : this.symm)
    succ_increasing⟩

theorem chain_chain_closure (hc : chain_closure c) :
  chain c :=
begin
  induction hc,
  case succ : c hc h {
    exact chain_succ h },
  case union : s hs h {
    have h : ∀ c ∈ s, zorn.chain c := h,
    exact assume c₁ ⟨t₁, ht₁, (hc₁ : c₁ ∈ t₁)⟩ c₂ ⟨t₂, ht₂, (hc₂ : c₂ ∈ t₂)⟩ hneq,
      have t₁ ⊆ t₂ ∨ t₂ ⊆ t₁, from chain_closure_total (hs _ ht₁) (hs _ ht₂),
      or.elim this
        (assume : t₁ ⊆ t₂, h t₂ ht₂ c₁ (this hc₁) c₂ hc₂ hneq)
        (assume : t₂ ⊆ t₁, h t₁ ht₁ c₁ hc₁ c₂ (this hc₂) hneq) }
end

/-- `max_chain` is the union of all sets in the chain closure. -/
def max_chain := ⋃₀ chain_closure

/-- Hausdorff's maximality principle

There exists a maximal totally ordered subset of `α`.
Note that we do not require `α` to be partially ordered by `r`. -/
theorem max_chain_spec :
  is_max_chain max_chain :=
classical.by_contradiction $
assume : ¬ is_max_chain (⋃₀ chain_closure),
have super_chain (⋃₀ chain_closure) (succ_chain (⋃₀ chain_closure)),
  from super_of_not_max (chain_chain_closure chain_closure_closure) this,
let ⟨h₁, H⟩ := this,
  ⟨h₂, (h₃ : (⋃₀ chain_closure) ≠ succ_chain (⋃₀ chain_closure))⟩ := ssubset_iff_subset_ne.1 H in
have succ_chain (⋃₀ chain_closure) = (⋃₀ chain_closure),
  from (chain_closure_succ_fixpoint_iff chain_closure_closure).mpr rfl,
h₃ this.symm

/-- Zorn's lemma

If every chain has an upper bound, then there is a maximal element -/
theorem exists_maximal_of_chains_bounded (h : ∀ c, chain c → ∃ ub, ∀ a ∈ c, a ≺ ub)
  (trans : ∀ {a b c}, a ≺ b → b ≺ c → a ≺ c) :
  ∃ m, ∀ a, m ≺ a → a ≺ m :=
have ∃ ub, ∀ a ∈ max_chain, a ≺ ub,
  from h _ $ max_chain_spec.left,
let ⟨ub, (hub : ∀ a ∈ max_chain, a ≺ ub)⟩ := this in
⟨ub, assume a ha,
  have chain (insert a max_chain),
    from chain_insert max_chain_spec.left $ assume b hb _, or.inr $ trans (hub b hb) ha,
  have a ∈ max_chain, from
    classical.by_contradiction $ assume h : a ∉ max_chain,
    max_chain_spec.right $ ⟨insert a max_chain, this, ssubset_insert h⟩,
  hub a this⟩

/--
If every nonempty chain of a nonempty type has an upper bound, then there is a maximal element.
(A variant of Zorn's lemma.)
-/
theorem exists_maximal_of_nonempty_chains_bounded [nonempty α]
  (h : ∀ c, chain c → c.nonempty → ∃ ub, ∀ a ∈ c, a ≺ ub)
  (trans : ∀ {a b c}, a ≺ b → b ≺ c → a ≺ c) :
  ∃ m, ∀ a, m ≺ a → a ≺ m :=
exists_maximal_of_chains_bounded
  (λ c hc,
    (eq_empty_or_nonempty c).elim
      (λ h, ⟨classical.arbitrary α, λ x hx, (h ▸ hx : x ∈ (∅ : set α)).elim⟩)
      (h c hc))
  (λ a b c, trans)

end chain

--This lemma isn't under section `chain` because `parameters` messes up with it. Feel free to fix it
/-- This can be used to turn `zorn.chain (≥)` into `zorn.chain (≤)` and vice-versa. -/
theorem chain.symm {α : Type u} {s : set α} {q : α → α → Prop} (h : chain q s) :
  chain (flip q) s :=
h.mono' (λ _ _, or.symm)

theorem zorn_partial_order {α : Type u} [partial_order α]
  (h : ∀ c : set α, chain (≤) c → ∃ ub, ∀ a ∈ c, a ≤ ub) :
  ∃ m : α, ∀ a, m ≤ a → a = m :=
let ⟨m, hm⟩ := @exists_maximal_of_chains_bounded α (≤) h (assume a b c, le_trans) in
⟨m, assume a ha, le_antisymm (hm a ha) ha⟩

theorem zorn_nonempty_partial_order {α : Type u} [partial_order α] [nonempty α]
  (h : ∀ (c : set α), chain (≤) c → c.nonempty → ∃ ub, ∀ a ∈ c, a ≤ ub) :
  ∃ (m : α), ∀ a, m ≤ a → a = m :=
let ⟨m, hm⟩ := @exists_maximal_of_nonempty_chains_bounded α (≤) _ h (λ a b c, le_trans) in
⟨m, λ a ha, le_antisymm (hm a ha) ha⟩

theorem zorn_partial_order₀ {α : Type u} [partial_order α] (s : set α)
  (ih : ∀ c ⊆ s, chain (≤) c → ∃ ub ∈ s, ∀ z ∈ c, z ≤ ub) :
  ∃ m ∈ s, ∀ z ∈ s, m ≤ z → z = m :=
let ⟨⟨m, hms⟩, h⟩ := @zorn_partial_order {m // m ∈ s} _
  (λ c hc,
    let ⟨ub, hubs, hub⟩ := ih (subtype.val '' c) (λ _ ⟨⟨x, hx⟩, _, h⟩, h ▸ hx)
      (by { rintro _ ⟨p, hpc, rfl⟩ _ ⟨q, hqc, rfl⟩ hpq;
        refine hc _ hpc _ hqc (λ t, hpq (subtype.ext_iff.1 t)) })
    in ⟨⟨ub, hubs⟩, λ ⟨y, hy⟩ hc, hub _ ⟨_, hc, rfl⟩⟩)
in ⟨m, hms, λ z hzs hmz, congr_arg subtype.val (h ⟨z, hzs⟩ hmz)⟩

theorem zorn_nonempty_partial_order₀ {α : Type u} [partial_order α] (s : set α)
  (ih : ∀ c ⊆ s, chain (≤) c → ∀ y ∈ c, ∃ ub ∈ s, ∀ z ∈ c, z ≤ ub) (x : α) (hxs : x ∈ s) :
  ∃ m ∈ s, x ≤ m ∧ ∀ z ∈ s, m ≤ z → z = m :=
let ⟨⟨m, hms, hxm⟩, h⟩ := @zorn_partial_order {m // m ∈ s ∧ x ≤ m} _
  (λ c hc, c.eq_empty_or_nonempty.elim
    (assume hce, hce.symm ▸ ⟨⟨x, hxs, le_refl _⟩, λ _, false.elim⟩)
    (assume ⟨m, hmc⟩,
      let ⟨ub, hubs, hub⟩ := ih (subtype.val '' c) (image_subset_iff.2 $ λ z hzc, z.2.1)
        (by rintro _ ⟨p, hpc, rfl⟩ _ ⟨q, hqc, rfl⟩ hpq;
          exact hc p hpc q hqc (mt (by rintro rfl; refl) hpq)) m.1 (mem_image_of_mem _ hmc) in
    ⟨⟨ub, hubs, le_trans m.2.2 $ hub m.1 $ mem_image_of_mem _ hmc⟩,
      λ a hac, hub a.1 ⟨a, hac, rfl⟩⟩)) in
⟨m, hms, hxm, λ z hzs hmz, congr_arg subtype.val $ h ⟨z, hzs, le_trans hxm hmz⟩ hmz⟩

theorem zorn_subset {α : Type u} (S : set (set α))
  (h : ∀ c ⊆ S, chain (⊆) c → ∃ ub ∈ S, ∀ s ∈ c, s ⊆ ub) :
  ∃ m ∈ S, ∀ a ∈ S, m ⊆ a → a = m :=
zorn_partial_order₀ S h

theorem zorn_subset_nonempty {α : Type u} (S : set (set α))
  (H : ∀ c ⊆ S, chain (⊆) c → c.nonempty → ∃ ub ∈ S, ∀ s ∈ c, s ⊆ ub) (x) (hx : x ∈ S) :
  ∃ m ∈ S, x ⊆ m ∧ ∀ a ∈ S, m ⊆ a → a = m :=
zorn_nonempty_partial_order₀ _ (λ c cS hc y yc, H _ cS hc ⟨y, yc⟩) _ hx

theorem zorn_superset {α : Type u} (S : set (set α))
  (h : ∀ c ⊆ S, chain (⊆) c → ∃ lb ∈ S, ∀ s ∈ c, lb ⊆ s) :
  ∃ m ∈ S, ∀ a ∈ S, a ⊆ m → a = m :=
@zorn_partial_order₀ (order_dual (set α)) _ S $ λ c cS hc, h c cS hc.symm

theorem zorn_superset_nonempty {α : Type u} (S : set (set α))
  (H : ∀ c ⊆ S, chain (⊆) c → c.nonempty → ∃ lb ∈ S, ∀ s ∈ c, lb ⊆ s) (x) (hx : x ∈ S) :
  ∃ m ∈ S, m ⊆ x ∧ ∀ a ∈ S, a ⊆ m → a = m :=
@zorn_nonempty_partial_order₀ (order_dual (set α)) _ S (λ c cS hc y yc, H _ cS
  hc.symm ⟨y, yc⟩) _ hx

theorem chain.total {α : Type u} [preorder α] {c : set α} (H : chain (≤) c) :
  ∀ {x y}, x ∈ c → y ∈ c → x ≤ y ∨ y ≤ x :=
λ x y, H.total_of_refl

theorem chain.image {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) (f : α → β)
  (h : ∀ x y, r x y → s (f x) (f y)) {c : set α} (hrc : chain r c) :
  chain s (f '' c) :=
λ x ⟨a, ha₁, ha₂⟩ y ⟨b, hb₁, hb₂⟩, ha₂ ▸ hb₂ ▸ λ hxy,
  (hrc a ha₁ b hb₁ (mt (congr_arg f) $ hxy)).elim
    (or.inl ∘ h _ _) (or.inr ∘ h _ _)

end zorn

theorem directed_of_chain {α β r} [is_refl β r] {f : α → β} {c : set α}
  (h : zorn.chain (f ⁻¹'o r) c) :
  directed r (λ x : {a : α // a ∈ c}, f x) :=
assume ⟨a, ha⟩ ⟨b, hb⟩, classical.by_cases
  (assume : a = b, by simp only [this, exists_prop, and_self, subtype.exists];
    exact ⟨b, hb, refl _⟩)
  (assume : a ≠ b, (h a ha b hb this).elim
    (λ h : r (f a) (f b), ⟨⟨b, hb⟩, h, refl _⟩)
    (λ h : r (f b) (f a), ⟨⟨a, ha⟩, refl _, h⟩))