feat(field_theory/polynomial_galois_group): New file (#5861)

This PR adds the file `polynomial_galois_group`. It contains some of the groundwork needed for proving the Abel-Ruffini theorem.



Co-authored-by: tb65536 <tb65536@users.noreply.github.com>

Author: tb65536

src/data/polynomial/field_division.lean

@@ -276,6 +276,10 @@ begin
   rw polynomial.eval_map,
 end
 
+lemma mem_root_set [field k] [algebra R k] {x : k} (hp : p ≠ 0) :
+  x ∈ p.root_set k ↔ aeval x p = 0 :=
+iff.trans multiset.mem_to_finset (mem_roots_map hp)
+
 lemma exists_root_of_degree_eq_one (h : degree p = 1) : ∃ x, is_root p x :=
 ⟨-(p.coeff 0 / p.coeff 1),
   have p.coeff 1 ≠ 0,

src/data/polynomial/ring_division.lean

@@ -488,6 +488,21 @@ begin
   rw [eval_sub, sub_eq_zero, ext],
 end
 
+/-- The set of distinct roots of `p` in `E`.
+
+If you have a non-separable polynomial, use `polynomial.roots` for the multiset
+where multiple roots have the appropriate multiplicity. -/
+def root_set (p : polynomial R) (S) [integral_domain S] [algebra R S] : set S :=
+(p.map (algebra_map R S)).roots.to_finset
+
+lemma root_set_def (p : polynomial R) (S) [integral_domain S] [algebra R S] :
+  p.root_set S = (p.map (algebra_map R S)).roots.to_finset :=
+rfl
+
+@[simp] lemma root_set_zero (S) [integral_domain S] [algebra R S] :
+  (0 : polynomial R).root_set S = ∅ :=
+by rw [root_set_def, polynomial.map_zero, roots_zero, to_finset_zero, finset.coe_empty]
+
 end roots
 
 theorem is_unit_iff {f : polynomial R} : is_unit f ↔ ∃ r : R, is_unit r ∧ C r = f :=

src/field_theory/normal.lean

@@ -97,7 +97,7 @@ end
 lemma alg_equiv.transfer_normal (f : E ≃ₐ[F] E') : normal F E ↔ normal F E' :=
 ⟨λ h, by exactI normal.of_alg_equiv f, λ h, by exactI normal.of_alg_equiv f.symm⟩
 
-lemma normal.of_is_splitting_field {p : polynomial F} [hFEp : is_splitting_field F E p] :
+lemma normal.of_is_splitting_field (p : polynomial F) [hFEp : is_splitting_field F E p] :
   normal F E :=
 begin
   by_cases hp : p = 0,
@@ -160,6 +160,8 @@ begin
   rw [set.image_singleton, ring_hom.algebra_map_to_algebra, adjoin_root.lift_root]
 end
 
+instance (p : polynomial F) : normal F p.splitting_field := normal.of_is_splitting_field p
+
 end normal_tower
 
 variables {F} {K} (ϕ ψ : K →ₐ[F] K) (χ ω : K ≃ₐ[F] K)

src/field_theory/polynomial_galois_group.lean

@@ -0,0 +1,237 @@
+/-
+Copyright (c) 2020 Thomas Browning and Patrick Lutz. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Thomas Browning and Patrick Lutz
+-/
+
+import field_theory.galois
+
+/-!
+# Galois Groups of Polynomials
+
+In this file we introduce the Galois group of a polynomial, defined as
+the automorphism group of the splitting field.
+
+## Main definitions
+
+- `gal p`: the Galois group of a polynomial p.
+- `restrict p E`: the restriction homomorphism `(E ≃ₐ[F] E) → gal p`.
+- `gal_action p E`: the action of `gal p` on the roots of `p` in `E`.
+
+## Main results
+
+- `restrict_smul`: `restrict p E` is compatible with `gal_action p E`.
+- `gal_action_hom_injective`: the action of `gal p` on the roots of `p` in `E` is faithful.
+- `restrict_prod_inj`: `gal (p * q)` embeds as a subgroup of `gal p × gal q`.
+-/
+
+noncomputable theory
+open_locale classical
+
+open finite_dimensional
+
+namespace polynomial
+
+variables {F : Type*} [field F] (p q : polynomial F) (E : Type*) [field E] [algebra F E]
+
+/-- The Galois group of a polynomial -/
+@[derive [has_coe_to_fun, group, fintype]]
+def gal := p.splitting_field ≃ₐ[F] p.splitting_field
+
+namespace gal
+
+instance [h : fact (p.splits (ring_hom.id F))] : unique p.gal :=
+{ default := 1,
+  uniq := λ f, alg_equiv.ext (λ x, by { obtain ⟨y, rfl⟩ := algebra.mem_bot.mp
+    ((subalgebra.ext_iff.mp ((is_splitting_field.splits_iff _ p).mp h) x).mp algebra.mem_top),
+    rw [alg_equiv.commutes, alg_equiv.commutes] }) }
+
+instance : unique (0 : polynomial F).gal :=
+begin
+  haveI : fact ((0 : polynomial F).splits (ring_hom.id F)) := splits_zero _,
+  apply_instance,
+end
+
+instance [h : fact (p.splits (algebra_map F E))] : algebra p.splitting_field E :=
+(is_splitting_field.lift p.splitting_field p h).to_ring_hom.to_algebra
+
+instance [h : fact (p.splits (algebra_map F E))] : is_scalar_tower F p.splitting_field E :=
+is_scalar_tower.of_algebra_map_eq
+  (λ x, ((is_splitting_field.lift p.splitting_field p h).commutes x).symm)
+
+/-- The restriction homomorphism -/
+def restrict [h : fact (p.splits (algebra_map F E))] : (E ≃ₐ[F] E) →* p.gal :=
+alg_equiv.restrict_normal_hom p.splitting_field
+
+section roots_action
+
+/-- The function from `roots p p.splitting_field` to `roots p E` -/
+def map_roots [h : fact (p.splits (algebra_map F E))] :
+  root_set p p.splitting_field → root_set p E :=
+λ x, ⟨is_scalar_tower.to_alg_hom F p.splitting_field E x, begin
+  have key := subtype.mem x,
+  by_cases p = 0,
+  { simp only [h, root_set_zero] at key,
+    exact false.rec _ key },
+  { rw [mem_root_set h, aeval_alg_hom_apply, (mem_root_set h).mp key, alg_hom.map_zero] } end⟩
+
+lemma map_roots_bijective [h : fact (p.splits (algebra_map F E))] :
+  function.bijective (map_roots p E) :=
+begin
+  split,
+  { exact λ _ _ h, subtype.ext (ring_hom.injective _ (subtype.ext_iff.mp h)) },
+  { intro y,
+    have key := roots_map
+      (is_scalar_tower.to_alg_hom F p.splitting_field E : p.splitting_field →+* E)
+      ((splits_id_iff_splits _).mpr (is_splitting_field.splits p.splitting_field p)),
+    rw [map_map, alg_hom.comp_algebra_map] at key,
+    have hy := subtype.mem y,
+    simp only [root_set, finset.mem_coe, multiset.mem_to_finset, key, multiset.mem_map] at hy,
+    rcases hy with ⟨x, hx1, hx2⟩,
+    exact ⟨⟨x, multiset.mem_to_finset.mpr hx1⟩, subtype.ext hx2⟩ }
+end
+
+/-- The bijection between `root_set p p.splitting_field` and `root_set p E` -/
+def roots_equiv_roots [h : fact (p.splits (algebra_map F E))] :
+  (root_set p p.splitting_field) ≃ (root_set p E) :=
+equiv.of_bijective (map_roots p E) (map_roots_bijective p E)
+
+instance gal_action_aux : mul_action p.gal (root_set p p.splitting_field) :=
+{ smul := λ ϕ x, ⟨ϕ x, begin
+    have key := subtype.mem x,
+    --simp only [root_set, finset.mem_coe, multiset.mem_to_finset] at *,
+    by_cases p = 0,
+    { simp only [h, root_set_zero] at key,
+      exact false.rec _ key },
+    { rw mem_root_set h,
+      change aeval (ϕ.to_alg_hom x) p = 0,
+      rw [aeval_alg_hom_apply, (mem_root_set h).mp key, alg_hom.map_zero] } end⟩,
+  one_smul := λ _, by { ext, refl },
+  mul_smul := λ _ _ _, by { ext, refl } }
+
+instance gal_action [h : fact (p.splits (algebra_map F E))] : mul_action p.gal (root_set p E) :=
+{ smul := λ ϕ x, roots_equiv_roots p E (ϕ • ((roots_equiv_roots p E).symm x)),
+  one_smul := λ _, by simp only [equiv.apply_symm_apply, one_smul],
+  mul_smul := λ _ _ _, by simp only [equiv.apply_symm_apply, equiv.symm_apply_apply, mul_smul] }
+
+variables {p E}
+
+@[simp] lemma restrict_smul [h : fact (p.splits (algebra_map F E))]
+  (ϕ : E ≃ₐ[F] E) (x : root_set p E) : ↑((restrict p E ϕ) • x) = ϕ x :=
+begin
+  let ψ := alg_hom.alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F p.splitting_field E),
+  change ↑(ψ (ψ.symm _)) = ϕ x,
+  rw alg_equiv.apply_symm_apply ψ,
+  change ϕ (roots_equiv_roots p E ((roots_equiv_roots p E).symm x)) = ϕ x,
+  rw equiv.apply_symm_apply (roots_equiv_roots p E),
+end
+
+variables (p E)
+
+/-- `gal_action` as a permutation representation -/
+def gal_action_hom [h : fact (p.splits (algebra_map F E))] : p.gal →* equiv.perm (root_set p E) :=
+{ to_fun := λ ϕ, equiv.mk (λ x, ϕ • x) (λ x, ϕ⁻¹ • x)
+  (λ x, inv_smul_smul ϕ x) (λ x, smul_inv_smul ϕ x),
+  map_one' := by { ext1 x, exact mul_action.one_smul x },
+  map_mul' := λ x y, by { ext1 z, exact mul_action.mul_smul x y z } }
+
+lemma gal_action_hom_injective [h : fact (p.splits (algebra_map F E))] :
+  function.injective (gal_action_hom p E) :=
+begin
+  rw monoid_hom.injective_iff,
+  intros ϕ hϕ,
+  let equalizer := alg_hom.equalizer ϕ.to_alg_hom (alg_hom.id F p.splitting_field),
+  suffices : equalizer = ⊤,
+  { exact alg_equiv.ext (λ x, (subalgebra.ext_iff.mp this x).mpr algebra.mem_top) },
+  rw [eq_top_iff, ←splitting_field.adjoin_roots, algebra.adjoin_le_iff],
+  intros x hx,
+  have key := equiv.perm.ext_iff.mp hϕ (roots_equiv_roots p E ⟨x, hx⟩),
+  change roots_equiv_roots p E (ϕ • (roots_equiv_roots p E).symm
+    (roots_equiv_roots p E ⟨x, hx⟩)) = roots_equiv_roots p E ⟨x, hx⟩ at key,
+  rw equiv.symm_apply_apply at key,
+  exact subtype.ext_iff.mp (equiv.injective (roots_equiv_roots p E) key),
+end
+
+end roots_action
+
+variables {p q}
+
+/-- The restriction homomorphism between Galois groups -/
+def restrict_dvd (hpq : p ∣ q) : q.gal →* p.gal :=
+if hq : q = 0 then 1 else @restrict F _ p _ _ _
+  (splits_of_splits_of_dvd (algebra_map F q.splitting_field) hq (splitting_field.splits q) hpq)
+
+variables (p q)
+
+/-- The Galois group of a product embeds into the product of the Galois groups  -/
+def restrict_prod : (p * q).gal →* p.gal × q.gal :=
+monoid_hom.prod (restrict_dvd (dvd_mul_right p q)) (restrict_dvd (dvd_mul_left q p))
+
+lemma restrict_prod_injective : function.injective (restrict_prod p q) :=
+begin
+  by_cases hpq : (p * q) = 0,
+  { haveI : unique (gal (p * q)) := by { rw hpq, apply_instance },
+    exact λ f g h, eq.trans (unique.eq_default f) (unique.eq_default g).symm },
+  intros f g hfg,
+  dsimp only [restrict_prod, restrict_dvd] at hfg,
+  simp only [dif_neg hpq, monoid_hom.prod_apply, prod.mk.inj_iff] at hfg,
+  suffices : alg_hom.equalizer f.to_alg_hom g.to_alg_hom = ⊤,
+  { exact alg_equiv.ext (λ x, (subalgebra.ext_iff.mp this x).mpr algebra.mem_top) },
+  rw [eq_top_iff, ←splitting_field.adjoin_roots, algebra.adjoin_le_iff],
+  intros x hx,
+  rw [map_mul, polynomial.roots_mul] at hx,
+  cases multiset.mem_add.mp (multiset.mem_to_finset.mp hx) with h h,
+  { change f x = g x,
+    haveI : fact (p.splits (algebra_map F (p * q).splitting_field)) :=
+      splits_of_splits_of_dvd _ hpq (splitting_field.splits (p * q)) (dvd_mul_right p q),
+    have key : x = algebra_map (p.splitting_field) (p * q).splitting_field
+      ((roots_equiv_roots p _).inv_fun ⟨x, multiset.mem_to_finset.mpr h⟩) :=
+      subtype.ext_iff.mp (equiv.apply_symm_apply (roots_equiv_roots p _) ⟨x, _⟩).symm,
+    rw [key, ←alg_equiv.restrict_normal_commutes, ←alg_equiv.restrict_normal_commutes],
+    exact congr_arg _ (alg_equiv.ext_iff.mp hfg.1 _) },
+  { change f x = g x,
+    haveI : fact (q.splits (algebra_map F (p * q).splitting_field)) :=
+      splits_of_splits_of_dvd _ hpq (splitting_field.splits (p * q)) (dvd_mul_left q p),
+    have key : x = algebra_map (q.splitting_field) (p * q).splitting_field
+      ((roots_equiv_roots q _).inv_fun ⟨x, multiset.mem_to_finset.mpr h⟩) :=
+      subtype.ext_iff.mp (equiv.apply_symm_apply (roots_equiv_roots q _) ⟨x, _⟩).symm,
+    rw [key, ←alg_equiv.restrict_normal_commutes, ←alg_equiv.restrict_normal_commutes],
+    exact congr_arg _ (alg_equiv.ext_iff.mp hfg.2 _) },
+  { rwa [ne.def, mul_eq_zero, map_eq_zero, map_eq_zero, ←mul_eq_zero] }
+end
+
+variables {p q}
+
+lemma card_of_separable (hp : p.separable) :
+  fintype.card p.gal = findim F p.splitting_field :=
+begin
+  haveI : is_galois F p.splitting_field := is_galois.of_separable_splitting_field hp,
+  exact is_galois.card_aut_eq_findim F p.splitting_field,
+end
+
+lemma prime_degree_dvd_card [char_zero F] (p_irr : irreducible p) (p_deg : p.nat_degree.prime) :
+  p.nat_degree ∣ fintype.card p.gal :=
+begin
+  rw gal.card_of_separable p_irr.separable,
+  have hp : p.degree ≠ 0 :=
+    λ h, nat.prime.ne_zero p_deg (nat_degree_eq_zero_iff_degree_le_zero.mpr (le_of_eq h)),
+  let α : p.splitting_field := root_of_splits (algebra_map F p.splitting_field)
+    (splitting_field.splits p) hp,
+  have hα : is_integral F α :=
+    (is_algebraic_iff_is_integral F).mp (algebra.is_algebraic_of_finite α),
+  use finite_dimensional.findim F⟮α⟯ p.splitting_field,
+  suffices : (minpoly F α).nat_degree = p.nat_degree,
+  { rw [←finite_dimensional.findim_mul_findim F F⟮α⟯ p.splitting_field,
+        intermediate_field.adjoin.findim hα, this] },
+  suffices : minpoly F α ∣ p,
+  { have key := dvd_symm_of_irreducible (minpoly.irreducible hα) p_irr this,
+    apply le_antisymm,
+    { exact nat_degree_le_of_dvd this p_irr.ne_zero },
+    { exact nat_degree_le_of_dvd key (minpoly.ne_zero hα) } },
+  apply minpoly.dvd F α,
+  rw [aeval_def, map_root_of_splits _ (splitting_field.splits p) hp],
+end
+
+end gal
+
+end polynomial

src/field_theory/splitting_field.lean

@@ -641,6 +641,9 @@ theorem adjoin_roots : algebra.adjoin α
     (↑(f.map (algebra_map α $ splitting_field f)).roots.to_finset : set (splitting_field f)) = ⊤ :=
 splitting_field_aux.adjoin_roots _ _ _
 
+theorem adjoin_root_set : algebra.adjoin α (f.root_set f.splitting_field) = ⊤ :=
+adjoin_roots f
+
 end splitting_field
 
 variables (α β) [algebra α β]
@@ -716,6 +719,9 @@ finite_dimensional.iff_fg.2 $ @algebra.coe_top α β _ _ _ ▸ adjoin_roots β f
   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 α) : _root_.finite_dimensional α f.splitting_field :=
+finite_dimensional f.splitting_field f
+
 /-- Any splitting field is isomorphic to `splitting_field f`. -/
 def alg_equiv (f : polynomial α) [is_splitting_field α β f] : β ≃ₐ[α] splitting_field f :=
 begin