(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From HB Require Import structures.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop finset prime.
From mathcomp Require Import binomial ssralg poly polydiv fingroup perm.
From mathcomp Require Import morphism quotient gproduct finalg zmodp cyclic.
From mathcomp Require Import matrix mxalgebra mxpoly polyXY vector falgebra.
From mathcomp Require Import fieldext.

(******************************************************************************)
(* This file provides a theory of separable and inseparable field extensions. *)
(*                                                                            *)
(*      separable_poly p <=> p has no multiple roots in any field extension.  *)
(* separable_element K x <=> the minimal polynomial of x over K is separable. *)
(*         separable K E <=> every member of E is separable over K.           *)
(* separable_generator K E == some x \in E that generates the largest         *)
(*                           subfield K[x] that is separable over K.          *)
(* purely_inseparable_element K x <=> there is a [pchar L].-nat n such that    *)
(*                           x ^+ n \in K.                                    *)
(* purely_inseparable K E <=> every member of E is purely inseparable over K. *)
(*                                                                            *)
(*  Derivations are introduced to prove the adjoin_separableP Lemma:          *)
(*        Derivation K D <=> the linear operator D satisfies the Leibniz      *)
(*                           product rule inside K.                           *)
(* extendDerivation x D K == given a derivation D on K and a separable        *)
(*                           element x over K, this function returns the      *)
(*                           unique extension of D to K(x).                   *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.
Import GRing.Theory.

HB.lock
Definition separable_poly {R : idomainType} (p : {poly R}) := coprimep p p^`().
Canonical separable_poly_unlockable := Unlockable separable_poly.unlock.

Section SeparablePoly.

Variable R : idomainType.
Implicit Types p q d u v : {poly R}.

Local Notation separable := (@separable_poly R).
Local Notation lcn_neq0 := (Pdiv.Idomain.lc_expn_scalp_neq0 _).

Lemma separable_poly_neq0 p : separable p -> p != 0.
Proof.
by apply: contraTneq => ->; rewrite unlock deriv0 coprime0p eqp01.
Qed.

Lemma poly_square_freeP p :
  (forall u v, u * v %| p -> coprimep u v)
  <-> (forall u, size u != 1 -> ~~ (u ^+ 2 %| p)).
Proof.
split=> [sq'p u | sq'p u v dvd_uv_p].
  by apply: contra => /sq'p; rewrite coprimepp.
rewrite coprimep_def (contraLR (sq'p _)) // (dvdp_trans _ dvd_uv_p) //.
by rewrite dvdp_mul ?dvdp_gcdl ?dvdp_gcdr.
Qed.

Lemma separable_polyP {p} :
  reflect [/\ forall u v, u * v %| p -> coprimep u v
            & forall u, u %| p -> 1 < size u -> u^`() != 0]
          (separable p).
Proof.
apply: (iffP idP) => [sep_p | [sq'p nz_der1p]].
  split=> [u v | u u_dv_p]; last first.
    apply: contraTneq => u'0; rewrite unlock in sep_p; rewrite -leqNgt -(eqnP sep_p).
    rewrite dvdp_leq -?size_poly_eq0 ?(eqnP sep_p) // dvdp_gcd u_dv_p.
    have /dvdpZr <-: lead_coef u ^+ scalp p u != 0 by rewrite lcn_neq0.
    by rewrite -derivZ -Pdiv.Idomain.divpK //= derivM u'0 mulr0 addr0 dvdp_mull.
  rewrite Pdiv.Idomain.dvdp_eq mulrCA mulrA; set c := _ ^+ _ => /eqP Dcp.
  have nz_c: c != 0 by rewrite lcn_neq0.
  move: sep_p; rewrite coprimep_sym unlock -(coprimepZl _ _ nz_c).
  rewrite -(coprimepZr _ _ nz_c) -derivZ Dcp derivM coprimepMl.
  by rewrite coprimep_addl_mul !coprimepMr -andbA => /and4P[].
rewrite unlock coprimep_def eqn_leq size_poly_gt0; set g := gcdp _ _.
have nz_g: g != 0.
  rewrite -dvd0p dvdp_gcd -(mulr0 0); apply/nandP; left.
  by have /poly_square_freeP-> := sq'p; rewrite ?size_poly0.
have [g_p]: g %| p /\ g %| p^`() by rewrite dvdp_gcdr ?dvdp_gcdl.
pose c := lead_coef g ^+ scalp p g; have nz_c: c != 0 by rewrite lcn_neq0.
have Dcp: c *: p = p %/ g * g by rewrite Pdiv.Idomain.divpK.
rewrite nz_g andbT leqNgt -(dvdpZr _ _ nz_c) -derivZ Dcp derivM.
rewrite dvdp_addr; last by rewrite dvdp_mull.
rewrite Gauss_dvdpr; last by rewrite sq'p // mulrC -Dcp dvdpZl.
by apply: contraL => /nz_der1p nz_g'; rewrite gtNdvdp ?nz_g' ?lt_size_deriv.
Qed.

Lemma separable_coprime p u v : separable p -> u * v %| p -> coprimep u v.
Proof. by move=> /separable_polyP[sq'p _] /sq'p. Qed.

Lemma separable_nosquare p u k :
  separable p -> 1 < k -> size u != 1 -> (u ^+ k %| p) = false.
Proof.
move=> /separable_polyP[/poly_square_freeP sq'p _] /subnKC <- /sq'p.
by apply: contraNF; apply: dvdp_trans; rewrite exprD dvdp_mulr.
Qed.

Lemma separable_deriv_eq0 p u :
  separable p -> u %| p -> 1 < size u -> (u^`() == 0) = false.
Proof. by move=> /separable_polyP[_ nz_der1p] u_p /nz_der1p/negPf->. Qed.

Lemma dvdp_separable p q : q %| p -> separable p -> separable q.
Proof.
move=> /(dvdp_trans _)q_dv_p /separable_polyP[sq'p nz_der1p].
by apply/separable_polyP; split=> [u v /q_dv_p/sq'p | u /q_dv_p/nz_der1p].
Qed.

Lemma separable_mul p q :
  separable (p * q) = [&& separable p, separable q & coprimep p q].
Proof.
apply/idP/and3P => [sep_pq | [sep_p sep_q co_pq]].
  rewrite !(dvdp_separable _ sep_pq) ?dvdp_mulIr ?dvdp_mulIl //.
  by rewrite (separable_coprime sep_pq).
rewrite unlock in sep_p sep_q *.
rewrite derivM coprimepMl {1}addrC mulrC !coprimep_addl_mul.
by rewrite !coprimepMr (coprimep_sym q p) co_pq !andbT; apply/andP.
Qed.

Lemma eqp_separable p q : p %= q -> separable p = separable q.
Proof. by case/andP=> p_q q_p; apply/idP/idP=> /dvdp_separable->. Qed.

Lemma separable_root p x :
  separable (p * ('X - x%:P)) = separable p && ~~ root p x.
Proof.
rewrite separable_mul; apply: andb_id2l => seq_p.
by rewrite unlock derivXsubC coprimep1 coprimep_XsubC.
Qed.

Lemma separable_prod_XsubC (r : seq R) :
  separable (\prod_(x <- r) ('X - x%:P)) = uniq r.
Proof.
elim: r => [|x r IH]; first by rewrite big_nil unlock /separable_poly coprime1p.
by rewrite big_cons mulrC separable_root IH root_prod_XsubC andbC.
Qed.

Lemma make_separable p : p != 0 -> separable (p %/ gcdp p p^`()).
Proof.
set g := gcdp p p^`() => nz_p; apply/separable_polyP.
have max_dvd_u (u : {poly R}): 1 < size u -> exists k, ~~ (u ^+ k %| p).
  move=> u_gt1; exists (size p); rewrite gtNdvdp // polySpred //.
  by rewrite -(ltn_subRL 1) subn1 size_exp leq_pmull // -(subnKC u_gt1).
split=> [|u u_pg u_gt1]; last first.
  apply/eqP=> u'0 /=; have [k /negP[]] := max_dvd_u u u_gt1.
  elim: k => [|k IHk]; first by rewrite dvd1p.
  suffices: u ^+ k.+1 %| (p %/ g) * g.
    by rewrite Pdiv.Idomain.divpK ?dvdp_gcdl // dvdpZr ?lcn_neq0.
  rewrite exprS dvdp_mul // dvdp_gcd IHk //=.
  suffices: u ^+ k %| (p %/ u ^+ k * u ^+ k)^`().
    by rewrite Pdiv.Idomain.divpK // derivZ dvdpZr ?lcn_neq0.
  by rewrite !derivCE u'0 mul0r mul0rn mulr0 addr0 dvdp_mull.
have pg_dv_p: p %/ g %| p by rewrite divp_dvd ?dvdp_gcdl.
apply/poly_square_freeP=> u; rewrite neq_ltn ltnS leqn0 size_poly_eq0.
case/predU1P=> [-> | /max_dvd_u[k]].
  by apply: contra nz_p; rewrite expr0n -dvd0p => /dvdp_trans->.
apply: contra => u2_dv_pg; case: k; [by rewrite dvd1p | elim=> [|n IHn]].
  exact: dvdp_trans (dvdp_mulr _ _) (dvdp_trans u2_dv_pg pg_dv_p).
suff: u ^+ n.+2 %| (p %/ g) * g.
  by rewrite Pdiv.Idomain.divpK ?dvdp_gcdl // dvdpZr ?lcn_neq0.
rewrite -add2n exprD dvdp_mul // dvdp_gcd.
rewrite (dvdp_trans _ IHn) ?exprS ?dvdp_mull //=.
suff: u ^+ n %| ((p %/ u ^+ n.+1) * u ^+ n.+1)^`().
  by rewrite Pdiv.Idomain.divpK // derivZ dvdpZr ?lcn_neq0.
by rewrite !derivCE dvdp_add // -1?mulr_natl ?exprS !dvdp_mull.
Qed.

End SeparablePoly.

Arguments separable_polyP {R p}.

Lemma separable_map (F : fieldType) (R : idomainType)
                    (f : {rmorphism F -> R}) (p : {poly F}) :
  separable_poly (map_poly f p) = separable_poly p.
Proof.
by rewrite unlock deriv_map /coprimep -gcdp_map size_map_poly.
Qed.

Section InfinitePrimitiveElementTheorem.

Local Notation "p ^ f" := (map_poly f p) : ring_scope.

Variables (F L : fieldType) (iota : {rmorphism F -> L}).
Variables (x y : L) (p : {poly F}).
Hypotheses (nz_p : p != 0) (px_0 : root (p ^ iota) x).

Let inFz z w := exists q, (q ^ iota).[z] = w.

Lemma large_field_PET q :
    root (q ^ iota) y -> separable_poly q ->
  exists2 r, r != 0
  & forall t (z := iota t * y - x), ~~ root r (iota t) -> inFz z x /\ inFz z y.
Proof.
move=> qy_0 sep_q; have nz_q := separable_poly_neq0 sep_q.
have /factor_theorem[q0 Dq] := qy_0.
set p1 := p ^ iota \Po ('X + x%:P); set q1 := q0 \Po ('X + y%:P).
have nz_p1: p1 != 0.
  apply: contraNneq nz_p => /(canRL (fun r => comp_polyXaddC_K r _))/eqP.
  by rewrite comp_poly0 map_poly_eq0.
have{sep_q} nz_q10: q1.[0] != 0.
  move: sep_q; rewrite -(separable_map iota) Dq separable_root => /andP[_].
  by rewrite horner_comp !hornerE.
have nz_q1: q1 != 0 by apply: contraNneq nz_q10 => ->; rewrite horner0.
pose p2 := p1 ^ polyC \Po ('X * 'Y); pose q2 := q1 ^ polyC.
have /Bezout_coprimepP[[u v]]: coprimep p2 q2.
  rewrite coprimep_def eqn_leq leqNgt andbC size_poly_gt0 gcdp_eq0 poly_XmY_eq0.
  by rewrite map_polyC_eq0 (negPf nz_p1) -resultant_eq0 div_annihilant_neq0.
rewrite -size_poly_eq1 => /size_poly1P[r nzr Dr]; exists r => {nzr}// t z nz_rt.
have [r1 nz_r1 r1z_0]: algebraicOver iota z.
  apply/algebraic_sub; last by exists p.
  by apply: algebraic_mul; [apply: algebraic_id | exists q].
pose Fz := subFExtend iota z r1; pose kappa : Fz -> L := subfx_inj.
pose kappa' := inj_subfx iota z r1.
have /eq_map_poly Diota: kappa \o kappa' =1 iota.
  by move=> w; rewrite /kappa /= subfx_inj_eval // map_polyC hornerC.
suffices [y3]: exists y3, y = kappa y3.
  have [q3 ->] := subfxE y3; rewrite /kappa subfx_inj_eval // => Dy.
  split; [exists (t *: q3 - 'X) | by exists q3].
  by rewrite rmorphB /= linearZ map_polyX !hornerE -Dy opprB addrC addrNK.
pose p0 := p ^ iota \Po (iota t *: 'X - z%:P).
have co_p0_q0: coprimep p0 q0.
  pose at_t := horner_eval (iota t); have at_t0: at_t 0 = 0 by apply: rmorph0.
  have /map_polyK polyCK: cancel polyC at_t by move=> w; apply: hornerC.
  have ->: p0 = p2 ^ at_t \Po ('X - y%:P).
    rewrite map_comp_poly polyCK // rmorphM /= map_polyC map_polyX /=.
    rewrite horner_evalE hornerX.
    rewrite -!comp_polyA comp_polyM comp_polyD !comp_polyC !comp_polyX.
    by rewrite mulrC mulrBr mul_polyC addrAC -addrA -opprB -rmorphM -rmorphB.
  have ->: q0 = q2 ^ at_t \Po ('X - y%:P) by rewrite polyCK ?comp_polyXaddC_K.
  apply/coprimep_comp_poly/Bezout_coprimepP; exists (u ^ at_t, v ^ at_t).
  by rewrite /= -!rmorphM -rmorphD Dr /= map_polyC polyC_eqp1.
have{co_p0_q0}: gcdp p0 (q ^ iota) %= 'X - y%:P.
  rewrite /eqp Dq (eqp_dvdl _ (Gauss_gcdpr _ _)) // dvdp_gcdr dvdp_gcd.
  rewrite dvdp_mull // -root_factor_theorem rootE horner_comp !hornerE.
  by rewrite opprB addrC subrK.
have{p0} [p3 ->]: exists p3, p0 = p3 ^ kappa.
  exists (p ^ kappa' \Po (kappa' t *: 'X - (subfx_eval iota z r1 'X)%:P)).
  rewrite map_comp_poly rmorphB /= linearZ /= map_polyC map_polyX /=.
  rewrite !subfx_inj_eval // map_polyC hornerC map_polyX hornerX.
  by rewrite -map_poly_comp Diota.
rewrite -Diota map_poly_comp -gcdp_map /= -/kappa.
move: (gcdp _ _) => r3 /eqpf_eq[c nz_c Dr3].
exists (- (r3`_0 / r3`_1)); rewrite [kappa _]rmorphN fmorph_div -!coef_map Dr3.
by rewrite !coefZ polyseqXsubC mulr1 mulrC mulKf ?opprK.
Qed.

Lemma pchar0_PET (q : {poly F}) :
    q != 0 -> root (q ^ iota) y -> [pchar F] =i pred0 ->
  exists n, let z := y *+ n - x in inFz z x /\ inFz z y.
Proof.
move=> nz_q qy_0 /pcharf0P pcharF0.
without loss{nz_q} sep_q: q qy_0 / separable_poly q.
  move=> IHq; apply: IHq (make_separable nz_q).
  have /dvdpP[q1 Dq] := dvdp_gcdl q q^`().
  rewrite {1}Dq mulpK ?gcdp_eq0; last by apply/nandP; left.
  have [n [r nz_ry Dr]] := multiplicity_XsubC (q ^ iota) y.
  rewrite map_poly_eq0 nz_q /= in nz_ry.
  case: n => [|n] in Dr; first by rewrite Dr mulr1 (negPf nz_ry) in qy_0.
  have: ('X - y%:P) ^+ n.+1 %| q ^ iota by rewrite Dr dvdp_mulIr.
  rewrite Dq rmorphM /= gcdp_map -(eqp_dvdr _ (gcdp_mul2l _ _ _)) -deriv_map Dr.
  rewrite dvdp_gcd derivM deriv_exp derivXsubC mul1r !mulrA dvdp_mulIr /=.
  rewrite mulrDr mulrA dvdp_addr ?dvdp_mulIr // exprS -scaler_nat -!scalerAr.
  rewrite dvdpZr -?(rmorph_nat iota) ?fmorph_eq0 ?pcharF0 //.
  rewrite mulrA dvdp_mul2r ?expf_neq0 ?polyXsubC_eq0 //.
  by rewrite Gauss_dvdpl ?dvdp_XsubCl // coprimep_sym coprimep_XsubC.
have [r nz_r PETxy] := large_field_PET qy_0 sep_q.
pose ts := mkseq (fun n => iota n%:R) (size r).
have /(max_ring_poly_roots nz_r)/=/implyP: uniq_roots ts.
  rewrite uniq_rootsE mkseq_uniq // => m n eq_mn; apply/eqP; rewrite eqn_leq.
  wlog suffices: m n eq_mn / m <= n by move=> IHmn; rewrite !IHmn.
  move/fmorph_inj/eqP: eq_mn; rewrite -subr_eq0 leqNgt; apply: contraL => lt_mn.
  by rewrite -natrB ?(ltnW lt_mn) // pcharF0 -lt0n subn_gt0.
rewrite size_mkseq ltnn implybF all_map => /allPn[n _ /= /PETxy].
by rewrite rmorph_nat mulr_natl; exists n.
Qed.

End InfinitePrimitiveElementTheorem.

#[deprecated(since="mathcomp 2.4.0", note="Use pchar0_PET instead.")]
Notation char0_PET := (pchar0_PET) (only parsing).

Section Separable.

Variables (F : fieldType) (L : fieldExtType F).
Implicit Types (U V W : {vspace L}) (E K M : {subfield L}) (D : 'End(L)).

Section Derivation.

Variables (K : {vspace L}) (D : 'End(L)).

(* A deriviation only needs to be additive and satisfy Lebniz's law, but all  *)
(* the deriviations used here are going to be linear, so we only define       *)
(* the Derivation predicate for linear endomorphisms.                         *)
Definition Derivation : bool :=
  all2rel (fun u v => D (u * v) == D u * v + u * D v) (vbasis K).

Hypothesis derD : Derivation.

Lemma Derivation_mul : {in K &, forall u v, D (u * v) = D u * v + u * D v}.
Proof.
move=> u v /coord_vbasis-> /coord_vbasis->.
rewrite !(mulr_sumr, linear_sum) -big_split; apply: eq_bigr => /= j _.
rewrite !mulr_suml linear_sum -big_split; apply: eq_bigr => /= i _.
rewrite !(=^~ scalerAl, linearZZ) -!scalerAr linearZZ -!scalerDr !scalerA /=.
by congr (_ *: _); apply/eqP/(allrelP derD); exact: memt_nth.
Qed.

Lemma Derivation_mul_poly (Dp := map_poly D) :
  {in polyOver K &, forall p q, Dp (p * q) = Dp p * q + p * Dp q}.
Proof.
move=> p q Kp Kq; apply/polyP=> i; rewrite {}/Dp coefD coef_map /= !coefM.
rewrite linear_sum -big_split; apply: eq_bigr => /= j _.
by rewrite !{1}coef_map Derivation_mul ?(polyOverP _).
Qed.

End Derivation.

Lemma DerivationS E K D : (K <= E)%VS -> Derivation E D -> Derivation K D.
Proof.
move/subvP=> sKE derD; apply/allrelP=> x y Kx Ky; apply/eqP.
by rewrite (Derivation_mul derD) ?sKE // vbasis_mem.
Qed.

Section DerivationAlgebra.

Variables (E : {subfield L}) (D : 'End(L)).
Hypothesis derD : Derivation E D.

Lemma Derivation1 : D 1 = 0.
Proof.
apply: (addIr (D (1 * 1))); rewrite add0r {1}mul1r.
by rewrite (Derivation_mul derD) ?mem1v // mulr1 mul1r.
Qed.

Lemma Derivation_scalar x : x \in 1%VS -> D x = 0.
Proof. by case/vlineP=> y ->; rewrite linearZ /= Derivation1 scaler0. Qed.

Lemma Derivation_exp x m : x \in E -> D (x ^+ m) = x ^+ m.-1 *+ m * D x.
Proof.
move=> Ex; case: m; first by rewrite expr0 mulr0n mul0r Derivation1.
elim=> [|m IHm]; first by rewrite mul1r.
rewrite exprS (Derivation_mul derD) //; last by apply: rpredX.
by rewrite mulrC IHm mulrA mulrnAr -exprS -mulrDl.
Qed.

Lemma Derivation_horner p x :
    p \is a polyOver E -> x \in E ->
  D p.[x] = (map_poly D p).[x] + p^`().[x] * D x.
Proof.
move=> Ep Ex; elim/poly_ind: p Ep => [|p c IHp] /polyOverP EpXc.
  by rewrite !(raddf0, horner0) mul0r add0r.
have Ep: p \is a polyOver E.
  by apply/polyOverP=> i; have:= EpXc i.+1; rewrite coefD coefMX coefC addr0.
have->: map_poly D (p * 'X + c%:P) = map_poly D p * 'X + (D c)%:P.
  apply/polyP=> i; rewrite !(coefD, coefMX, coef_map) /= linearD /= !coefC.
  by rewrite !(fun_if D) linear0.
rewrite derivMXaddC !hornerE mulrDl mulrAC addrAC linearD /=; congr (_ + _).
by rewrite addrCA -mulrDl -IHp // addrC (Derivation_mul derD) ?rpred_horner.
Qed.

End DerivationAlgebra.

Definition separable_element U x := separable_poly (minPoly U x).

Section SeparableElement.

Variables (K : {subfield L}) (x : L).
(* begin hide *)
Let sKxK : (K <= <<K; x>>)%VS := subv_adjoin K x.
Let Kx_x : x \in <<K; x>>%VS := memv_adjoin K x.
(* end hide *)

Lemma separable_elementP :  
  reflect (exists f, [/\ f \is a polyOver K, root f x & separable_poly f])
          (separable_element K x).
Proof.
apply: (iffP idP) => [sep_x | [f [Kf /(minPoly_dvdp Kf)/dvdpP[g ->]]]].
  by exists (minPoly K x); rewrite minPolyOver root_minPoly.
by rewrite separable_mul => /and3P[].
Qed.

Lemma base_separable : x \in K -> separable_element K x.
Proof.
move=> Kx; apply/separable_elementP; exists ('X - x%:P).
by rewrite polyOverXsubC root_XsubC unlock !derivCE coprimep1.
Qed.

Lemma separable_nz_der : separable_element K x = ((minPoly K x)^`() != 0).
Proof.
rewrite /separable_element unlock.
apply/idP/idP=> [|nzPx'].
  by apply: contraTneq => ->; rewrite coprimep0 -size_poly_eq1 size_minPoly.
have gcdK : gcdp (minPoly K x) (minPoly K x)^`() \in polyOver K.
  by rewrite gcdp_polyOver ?polyOver_deriv // minPolyOver.
rewrite -gcdp_eqp1 -size_poly_eq1 -dvdp1.
have /orP[/andP[_]|/andP[]//] := minPoly_irr gcdK (dvdp_gcdl _ _).
rewrite dvdp_gcd dvdpp /= => /(dvdp_leq nzPx')/leq_trans/(_ (size_poly _ _)).
by rewrite size_minPoly ltnn.
Qed.

Lemma separablePn_pchar :
  reflect (exists2 p, p \in [pchar L] &
            exists2 g, g \is a polyOver K & minPoly K x = g \Po 'X^p)
          (~~ separable_element K x).
Proof.
rewrite separable_nz_der negbK; set f := minPoly K x.
apply: (iffP eqP) => [f'0 | [p Hp [g _ ->]]]; last first.
  by rewrite deriv_comp derivXn -scaler_nat (pcharf0 Hp) scale0r mulr0.
pose n := adjoin_degree K x; have sz_f: size f = n.+1 := size_minPoly K x.
have fn1: f`_n = 1 by rewrite -(monicP (monic_minPoly K x)) lead_coefE sz_f.
have dimKx: (adjoin_degree K x)%:R == 0 :> L.
  by rewrite -(coef0 _ n.-1) -f'0 coef_deriv fn1.
have /natf0_pchar[// | p pcharLp] := dimKx.
have /dvdnP[r Dn]: (p %| n)%N by rewrite (dvdn_pcharf pcharLp).
exists p => //; exists (\poly_(i < r.+1) f`_(i * p)).
  by apply: polyOver_poly => i _; rewrite (polyOverP _) ?minPolyOver.
rewrite comp_polyE size_poly_eq -?Dn ?fn1 ?oner_eq0 //.
have pr_p := pcharf_prime pcharLp; have p_gt0 := prime_gt0 pr_p.
apply/polyP=> i; rewrite coef_sum.
have [[{}i ->] | p'i] := altP (@dvdnP p i); last first.
  rewrite big1 => [|j _]; last first.
    rewrite coefZ -exprM coefXn [_ == _](contraNF _ p'i) ?mulr0 // => /eqP->.
    by rewrite dvdn_mulr.
  rewrite (dvdn_pcharf pcharLp) in p'i; apply: mulfI p'i _ _ _.
  by rewrite mulr0 mulr_natl; case: i => // i; rewrite -coef_deriv f'0 coef0.
have [ltri | leir] := leqP r.+1 i.
  rewrite nth_default ?sz_f ?Dn ?ltn_pmul2r ?big1 // => j _.
  rewrite coefZ -exprM coefXn mulnC gtn_eqF ?mulr0 //.
  by rewrite ltn_pmul2l ?(leq_trans _ ltri).
rewrite (bigD1 (Sub i _)) //= big1 ?addr0 => [|j i'j]; last first.
  by rewrite coefZ -exprM coefXn mulnC eqn_pmul2l // mulr_natr mulrb ifN_eqC.
by rewrite coef_poly leir coefZ -exprM coefXn mulnC eqxx mulr1.
Qed.

Lemma separable_root_der : separable_element K x (+) root (minPoly K x)^`() x.
Proof.
have KpKx': _^`() \is a polyOver K := polyOver_deriv (minPolyOver K x).
rewrite separable_nz_der addNb (root_small_adjoin_poly KpKx') ?addbb //.
by rewrite (leq_trans (size_poly _ _)) ?size_minPoly.
Qed.

Lemma Derivation_separable D :
    Derivation <<K; x>> D -> separable_element K x ->
  D x = - (map_poly D (minPoly K x)).[x] / (minPoly K x)^`().[x].
Proof.
move=> derD sepKx; have:= separable_root_der; rewrite {}sepKx -sub0r => nzKx'x.
apply: canRL (mulfK nzKx'x) (canRL (addrK _) _); rewrite mulrC addrC.
rewrite -(Derivation_horner derD) ?minPolyxx ?linear0 //.
exact: polyOverSv sKxK _ (minPolyOver _ _).
Qed.

Section ExtendDerivation.

Variable D : 'End(L).

Let Dx E := - (map_poly D (minPoly E x)).[x] / ((minPoly E x)^`()).[x].

Fact extendDerivation_zmod_morphism_subproof E (adjEx := Fadjoin_poly E x) :
  let body y (p := adjEx y) := (map_poly D p).[x] + p^`().[x] * Dx E in
  zmod_morphism body.
Proof.
move: Dx => C /= u v; rewrite /adjEx.
rewrite raddfB /= derivB -/adjEx !hornerE /= raddfB /= !hornerE.
by rewrite mulrBl addrACA opprD.
Qed.

Fact extendDerivation_scalable_subproof E (adjEx := Fadjoin_poly E x) :
  let body y (p := adjEx y) := (map_poly D p).[x] + p^`().[x] * Dx E in
  scalable body.
Proof.
move: Dx => C /= a u; rewrite /adjEx linearZ /= derivZ -/adjEx.
rewrite hornerE -[RHS]mulr_algl mulrDr mulrA -[in RHS]hornerZ.
congr (_.[x] + _); apply/polyP=> i.
by rewrite coefZ !coef_map coefZ !mulr_algl /= linearZ.
Qed.

Section DerivationLinear.
Variable (E : {subfield L}).
Let body (y : L) (p := Fadjoin_poly E x y) : L :=
  (map_poly D p).[x] + p^`().[x] * Dx E.
HB.instance Definition _ := @GRing.isZmodMorphism.Build _ _ body
  (extendDerivation_zmod_morphism_subproof E).
HB.instance Definition _ := @GRing.isScalable.Build _ _ _ _ body
  (extendDerivation_scalable_subproof E).
Let extendDerivationLinear := Eval hnf in (body : {linear _ -> _}).
Definition extendDerivation : 'End(L) := linfun extendDerivationLinear.
End DerivationLinear.

Hypothesis derD : Derivation K D.

Lemma extendDerivation_id y : y \in K -> extendDerivation K y = D y.
Proof.
move=> yK; rewrite lfunE /= Fadjoin_polyC // derivC map_polyC hornerC.
by rewrite horner0 mul0r addr0.
Qed.

Lemma extendDerivation_horner p :
    p \is a polyOver K -> separable_element K x ->
  extendDerivation K p.[x] = (map_poly D p).[x] + p^`().[x] * Dx K.
Proof.
move=> Kp sepKx; have:= separable_root_der; rewrite {}sepKx /= => nz_pKx'x.
rewrite [in RHS](divp_eq p (minPoly K x)) lfunE /= Fadjoin_poly_mod ?raddfD //=.
rewrite (Derivation_mul_poly derD) ?divp_polyOver ?minPolyOver //.
rewrite derivM !{1}hornerD !{1}hornerM minPolyxx !{1}mulr0 !{1}add0r.
rewrite mulrDl addrA [_ + (_ * _ * _)]addrC {2}/Dx -mulrA -/Dx.
by rewrite [_ / _]mulrC (mulVKf nz_pKx'x) mulrN addKr.
Qed.

Lemma extendDerivationP :
  separable_element K x -> Derivation <<K; x>> (extendDerivation K).
Proof.
move=> sep; apply/allrelP=> u v /vbasis_mem Hu /vbasis_mem Hv; apply/eqP.
rewrite -(Fadjoin_poly_eq Hu) -(Fadjoin_poly_eq Hv) -hornerM.
rewrite !{1}extendDerivation_horner ?{1}rpredM ?Fadjoin_polyOver //.
rewrite (Derivation_mul_poly derD) ?Fadjoin_polyOver //.
rewrite derivM !{1}hornerD !{1}hornerM !{1}mulrDl !{1}mulrDr -!addrA.
congr (_ + _); rewrite [Dx K]lock -!{1}mulrA !{1}addrA; congr (_ + _).
by rewrite addrC; congr (_ * _ + _); rewrite mulrC.
Qed.

End ExtendDerivation.

(* Reference: 
http://www.math.uconn.edu/~kconrad/blurbs/galoistheory/separable2.pdf *)
Lemma Derivation_separableP :
  reflect
    (forall D, Derivation <<K; x>> D -> K <= lker D -> <<K; x>> <= lker D)%VS
    (separable_element K x).
Proof.
apply: (iffP idP) => [sepKx D derD /subvP DK_0 | derKx_0].
  have{} DK_0 q: q \is a polyOver K -> map_poly D q = 0.
    move=> /polyOverP Kq; apply/polyP=> i; apply/eqP.
    by rewrite coef0 coef_map -memv_ker DK_0.
  apply/subvP=> _ /Fadjoin_polyP[p Kp ->]; rewrite memv_ker.
  rewrite (Derivation_horner derD) ?(polyOverSv sKxK) //.
  rewrite (Derivation_separable derD sepKx) !DK_0 ?minPolyOver //.
  by rewrite horner0 oppr0 mul0r mulr0 addr0.
apply: wlog_neg; rewrite {1}separable_nz_der negbK => /eqP pKx'_0.
pose Df := fun y => (Fadjoin_poly K x y)^`().[x].
have Dlin: linear Df.
  move=> a u v; rewrite /Df linearP /= -mul_polyC derivD derivM derivC.
  by rewrite mul0r add0r hornerD hornerM hornerC -scalerAl mul1r.
pose DlinM := GRing.isLinear.Build _ _ _ _ Df Dlin.
pose DL : {linear _ -> _} := HB.pack Df DlinM.
pose D := linfun DL; apply: base_separable.
have DK_0: (K <= lker D)%VS.
  apply/subvP=> v Kv; rewrite memv_ker lfunE /= /Df Fadjoin_polyC //.
  by rewrite derivC horner0.
have Dder: Derivation <<K; x>> D.
  apply/allrelP=> u v /vbasis_mem Kx_u /vbasis_mem Kx_v; apply/eqP.
  rewrite !lfunE /= /Df; set Px := Fadjoin_poly K x.
  set Px_u := Px u; rewrite -(Fadjoin_poly_eq Kx_u) -/Px -/Px_u.
  set Px_v := Px v; rewrite -(Fadjoin_poly_eq Kx_v) -/Px -/Px_v.
  rewrite -!hornerM -hornerD -derivM.
  rewrite /Px Fadjoin_poly_mod ?rpredM ?Fadjoin_polyOver //.
  rewrite [in RHS](divp_eq (Px_u * Px_v) (minPoly K x)) derivD derivM.
  by rewrite pKx'_0 mulr0 addr0 hornerD hornerM minPolyxx mulr0 add0r.
have{Dder DK_0}: x \in lker D by apply: subvP Kx_x; apply: derKx_0.
apply: contraLR => K'x; rewrite memv_ker lfunE /= /Df Fadjoin_polyX //.
by rewrite derivX hornerC oner_eq0.
Qed.

End SeparableElement.

#[deprecated(since="mathcomp 2.4.0", note="Use separablePn_pchar instead.")]
Notation separablePn := (separablePn_pchar) (only parsing).

Arguments separable_elementP {K x}.

Lemma separable_elementS K E x :
  (K <= E)%VS -> separable_element K x -> separable_element E x.
Proof.
move=> sKE /separable_elementP[f [fK rootf sepf]]; apply/separable_elementP.
by exists f; rewrite (polyOverSv sKE).
Qed.

Lemma adjoin_separableP {K x} :
  reflect (forall y, y \in <<K; x>>%VS -> separable_element K y)
          (separable_element K x).
Proof.
apply: (iffP idP) => [sepKx | -> //]; last exact: memv_adjoin.
move=> _ /Fadjoin_polyP[q Kq ->]; apply/Derivation_separableP=> D derD DK_0.
apply/subvP=> _ /Fadjoin_polyP[p Kp ->].
rewrite memv_ker -(extendDerivation_id x D (mempx_Fadjoin _ Kp)).
have sepFyx: (separable_element <<K; q.[x]>> x).
  by apply: (separable_elementS (subv_adjoin _ _)).
have KyxEqKx: (<< <<K; q.[x]>>; x>> = <<K; x>>)%VS.
  apply/eqP; rewrite eqEsubv andbC adjoinSl ?subv_adjoin //=.
  apply/FadjoinP/andP; rewrite memv_adjoin andbT.
  by apply/FadjoinP/andP; rewrite subv_adjoin mempx_Fadjoin.
have /[!KyxEqKx] derDx := extendDerivationP derD sepFyx.
rewrite -horner_comp (Derivation_horner derDx) ?memv_adjoin //; last first.
  by apply: (polyOverSv (subv_adjoin _ _)); apply: polyOver_comp.
set Dx_p := map_poly _; have Dx_p_0 t: t \is a polyOver K -> (Dx_p t).[x] = 0.
  move/polyOverP=> Kt; congr (_.[x] = 0): (horner0 x); apply/esym/polyP => i.
  have /eqP Dti_0: D t`_i == 0 by rewrite -memv_ker (subvP DK_0) ?Kt.
  by rewrite coef0 coef_map /= {1}extendDerivation_id ?subvP_adjoin.
rewrite (Derivation_separable derDx sepKx) -/Dx_p Dx_p_0 ?polyOver_comp //.
by rewrite add0r mulrCA Dx_p_0 ?minPolyOver ?oppr0 ?mul0r.
Qed.

Lemma separable_exponent_pchar K x :
  exists n, [pchar L].-nat n && separable_element K (x ^+ n).
Proof.
pose d := adjoin_degree K x; move: {2}d.+1 (ltnSn d) => n.
elim: n => // n IHn in x @d *; rewrite ltnS => le_d_n.
have [[p pcharLp]|] := altP (separablePn_pchar K x); last by rewrite negbK; exists 1.
case=> g Kg defKx; have p_pr := pcharf_prime pcharLp.
suffices /IHn[m /andP[pcharLm sepKxpm]]: adjoin_degree K (x ^+ p) < n.
  by exists (p * m)%N; rewrite pnatM pnatE // pcharLp pcharLm exprM.
apply: leq_trans le_d_n; rewrite -ltnS -!size_minPoly.
have nzKx: minPoly K x != 0 by rewrite monic_neq0 ?monic_minPoly.
have nzg: g != 0 by apply: contra_eqN defKx => /eqP->; rewrite comp_poly0.
apply: leq_ltn_trans (dvdp_leq nzg _) _.
  by rewrite minPoly_dvdp // rootE -hornerXn -horner_comp -defKx minPolyxx.
rewrite (polySpred nzKx) ltnS defKx size_comp_poly size_polyXn /=.
suffices g_gt1: 1 < size g by rewrite -(subnKC g_gt1) ltn_Pmulr ?prime_gt1.
apply: contra_eqT (size_minPoly K x); rewrite defKx -leqNgt => /size1_polyC->.
by rewrite comp_polyC size_polyC; case: (_ != 0).
Qed.

#[deprecated(since="mathcomp 2.4.0", note="Use separable_exponent_pchar instead.")]
Notation separable_exponent := (separable_exponent_pchar) (only parsing).

Lemma pcharf0_separable K : [pchar L] =i pred0 -> forall x, separable_element K x.
Proof.
move=> pcharL0 x; have [n /andP[pcharLn]] := separable_exponent_pchar K x.
by rewrite (pnat_1 pcharLn (sub_in_pnat _ pcharLn)) // => p _; rewrite pcharL0.
Qed.

#[deprecated(since="mathcomp 2.4.0", note="Use pcharf0_separable instead.")]
Notation charf0_separable := (pcharf0_separable) (only parsing).

Lemma pcharf_p_separable K x e p :
  p \in [pchar L] -> separable_element K x = (x \in <<K; x ^+ (p ^ e.+1)>>%VS).
Proof.
move=> pcharLp; apply/idP/idP=> [sepKx | /Fadjoin_poly_eq]; last first.
  set m := p ^ _; set f := Fadjoin_poly K _ x => Dx; apply/separable_elementP.
  have mL0: m%:R = 0 :> L by apply/eqP; rewrite -(dvdn_pcharf pcharLp) dvdn_exp.
  exists ('X - (f \Po 'X^m)); split.
  - by rewrite rpredB ?polyOver_comp ?rpredX ?polyOverX ?Fadjoin_polyOver.
  - by rewrite rootE !hornerE horner_comp hornerXn Dx subrr.
  rewrite unlock !(derivE, deriv_comp) -mulr_natr -rmorphMn /= mL0.
  by rewrite !mulr0 subr0 coprimep1.
without loss{e} ->: e x sepKx / e = 0.
  move=> IH; elim: {e}e.+1 => [|e]; [exact: memv_adjoin | apply: subvP].
  apply/FadjoinP/andP; rewrite subv_adjoin expnSr exprM (IH 0) //.
  by have /adjoin_separableP-> := sepKx; rewrite ?rpredX ?memv_adjoin.
set K' := <<K; x ^+ p>>%VS; have sKK': (K <= K')%VS := subv_adjoin _ _.
pose q := minPoly K' x; pose g := 'X^p - (x ^+ p)%:P.
have [K'g]: g \is a polyOver K' /\ q \is a polyOver K'.
  by rewrite minPolyOver rpredB ?rpredX ?polyOverX // polyOverC memv_adjoin.
have /dvdpP[c Dq]: 'X - x%:P %| q by rewrite dvdp_XsubCl root_minPoly.
have co_c_g: coprimep c g.
  have pcharPp: p \in [pchar {poly L}] := rmorph_pchar polyC pcharLp.
  rewrite /g polyC_exp -!(pFrobenius_autE pcharPp) -rmorphB coprimep_expr //.
  have: separable_poly q := separable_elementS sKK' sepKx.
  by rewrite Dq separable_mul => /and3P[].
have{g K'g co_c_g} /size_poly1P[a nz_a Dc]: size c == 1.
  suffices c_dv_g: c %| g by rewrite -(eqp_size (dvdp_gcd_idl c_dv_g)).
  have: q %| g by rewrite minPoly_dvdp // rootE !hornerE subrr.
  by apply: dvdp_trans; rewrite Dq dvdp_mulIl.
rewrite {q}Dq {c}Dc mulrBr -rmorphM -rmorphN -cons_poly_def qualifE /=.
by rewrite polyseq_cons !polyseqC nz_a /= rpredN andbCA => /and3P[/fpredMl->].
Qed.

#[deprecated(since="mathcomp 2.4.0", note="Use pcharf_p_separable instead.")]
Notation charf_p_separable := (pcharf_p_separable) (only parsing).

Lemma pcharf_n_separable K x n :
  [pchar L].-nat n -> 1 < n -> separable_element K x = (x \in <<K; x ^+ n>>%VS).
Proof.
rewrite -pi_pdiv; set p := pdiv n => pcharLn pi_n_p.
have pcharLp: p \in [pchar L] := pnatPpi pcharLn pi_n_p.
have <-: (n`_p)%N = n by rewrite -(eq_partn n (pcharf_eq pcharLp)) part_pnat_id.
by rewrite p_part lognE -mem_primes pi_n_p -pcharf_p_separable.
Qed.

#[deprecated(since="mathcomp 2.4.0", note="Use pcharf_n_separable instead.")]
Notation charf_n_separable := (pcharf_n_separable) (only parsing).

Definition purely_inseparable_element U x :=
  x ^+ ex_minn (separable_exponent_pchar <<U>> x) \in U.

Lemma purely_inseparable_elementP_pchar {K x} :
  reflect (exists2 n, [pchar L].-nat n & x ^+ n \in K)
          (purely_inseparable_element K x).
Proof.
rewrite /purely_inseparable_element.
case: ex_minnP => n /andP[pcharLn /=]; rewrite subfield_closed => sepKxn min_xn.
apply: (iffP idP) => [Kxn | [m pcharLm Kxm]]; first by exists n.
have{min_xn}: n <= m by rewrite min_xn ?pcharLm ?base_separable.
rewrite leq_eqVlt => /predU1P[-> // | ltnm]; pose p := pdiv m.
have m_gt1: 1 < m by have [/leq_ltn_trans->] := andP pcharLn.
have pcharLp: p \in [pchar L] by rewrite (pnatPpi pcharLm) ?pi_pdiv.
have [/p_natP[em Dm] /p_natP[en Dn]]: p.-nat m /\ p.-nat n.
  by rewrite -!(eq_pnat _ (pcharf_eq pcharLp)).
rewrite Dn Dm ltn_exp2l ?prime_gt1 ?pdiv_prime // in ltnm.
rewrite -(Fadjoin_idP Kxm) Dm -(subnKC ltnm) addSnnS expnD exprM -Dn.
by rewrite -pcharf_p_separable.
Qed.

#[deprecated(since="mathcomp 2.4.0", note="Use purely_inseparable_elementP_pchar instead.")]
Notation purely_inseparable_elementP := (purely_inseparable_elementP_pchar) (only parsing).

Lemma separable_inseparable_element K x :
  separable_element K x && purely_inseparable_element K x = (x \in K).
Proof.
rewrite /purely_inseparable_element; case: ex_minnP => [[|m]] //=.
rewrite subfield_closed; case: m => /= [-> //| m _ /(_ 1)/implyP/= insepKx].
by rewrite (negPf insepKx) (contraNF (@base_separable K x) insepKx).
Qed.

Lemma base_inseparable K x : x \in K -> purely_inseparable_element K x.
Proof. by rewrite -separable_inseparable_element => /andP[]. Qed.

Lemma sub_inseparable K E x :
    (K <= E)%VS -> purely_inseparable_element K x ->
 purely_inseparable_element E x.
Proof.
move/subvP=> sKE /purely_inseparable_elementP_pchar[n pcharLn /sKE Exn].
by apply/purely_inseparable_elementP_pchar; exists n.
Qed.

Section PrimitiveElementTheorem.

Variables (K : {subfield L}) (x y : L).

Section FiniteCase.

Variable N : nat.

Let K_is_large := exists s, [/\ uniq s, {subset s <= K} & N < size s].

Let cyclic_or_large (z : L) : z != 0 -> K_is_large \/ exists a, z ^+ a.+1 = 1.
Proof.
move=> nz_z; pose d := adjoin_degree K z.
pose h0 (i : 'I_(N ^ d).+1) (j : 'I_d) := (Fadjoin_poly K z (z ^+ i))`_j.
pose s := undup [seq h0 i j | i <- enum 'I_(N ^ d).+1, j <- enum 'I_d].
have s_h0 i j: h0 i j \in s.
  by rewrite mem_undup; apply/allpairsP; exists (i, j); rewrite !mem_enum.
pose h i := [ffun j => Ordinal (etrans (index_mem _ _) (s_h0 i j))].
pose h' (f : {ffun 'I_d -> 'I_(size s)}) := \sum_(j < d) s`_(f j) * z ^+ j.
have hK i: h' (h i) = z ^+ i.
  have Kz_zi: z ^+ i \in <<K; z>>%VS by rewrite rpredX ?memv_adjoin.
  rewrite -(Fadjoin_poly_eq Kz_zi) (horner_coef_wide z (size_poly _ _)) -/d.
  by apply: eq_bigr => j _; rewrite ffunE /= nth_index.
have [inj_h | ] := altP (@injectiveP _ _ h).
  left; exists s; split=> [|zi_j|]; rewrite ?undup_uniq ?mem_undup //=.
    by case/allpairsP=> ij [_ _ ->]; apply/polyOverP/Fadjoin_polyOver.
  rewrite -[size s]card_ord -(@ltn_exp2r _ _ d) // -{2}[d]card_ord -card_ffun.
  by rewrite -[_.+1]card_ord -(card_image inj_h) max_card.
case/injectivePn=> i1 [i2 i1'2 /(congr1 h')]; rewrite !hK => eq_zi12; right.
without loss{i1'2} lti12: i1 i2 eq_zi12 / i1 < i2.
  by move=> IH; move: i1'2; rewrite neq_ltn => /orP[]; apply: IH.
by exists (i2 - i1.+1)%N; rewrite subnSK ?expfB // eq_zi12 divff ?expf_neq0.
Qed.

Lemma finite_PET : K_is_large \/ exists z, (<< <<K; y>>; x>> = <<K; z>>)%VS.
Proof.
have [-> | /cyclic_or_large[|[a Dxa]]] := eqVneq x 0; first 2 [by left].
  by rewrite addv0 subfield_closed; right; exists y.
have [-> | /cyclic_or_large[|[b Dyb]]] := eqVneq y 0; first 2 [by left].
  by rewrite addv0 subfield_closed; right; exists x.
pose h0 (ij : 'I_a.+1 * 'I_b.+1) := x ^+ ij.1 * y ^+ ij.2.
pose H := <<[set ij | h0 ij == 1%R]>>%G; pose h (u : coset_of H) := h0 (repr u).
have h0M: {morph h0: ij1 ij2 / (ij1 * ij2)%g >-> ij1 * ij2}.
  by rewrite /h0 => [] [i1 j1] [i2 j2] /=; rewrite mulrACA -!exprD !expr_mod.
have memH ij: (ij \in H) = (h0 ij == 1).
  rewrite /= gen_set_id ?inE //; apply/group_setP; rewrite inE [h0 _]mulr1.
  by split=> // ? ? /[!(inE, h0M)] /eqP-> /eqP->; rewrite mulr1.
have nH ij: ij \in 'N(H)%g.
  by apply/(subsetP (cent_sub _))/centP=> ij1 _; congr (_, _); rewrite Zp_mulgC.
have hE ij: h (coset H ij) = h0 ij.
  rewrite /h val_coset //; case: repr_rcosetP => ij1.
  by rewrite memH h0M => /eqP->; rewrite mul1r.
have h1: h 1%g = 1 by rewrite /h repr_coset1 [h0 _]mulr1.
have hM: {morph h: u v / (u * v)%g >-> u * v}.
  by do 2![move=> u; have{u} [? _ ->] := cosetP u]; rewrite -morphM // !hE h0M.
have /cyclicP[w defW]: cyclic [set: coset_of H].
  apply: field_mul_group_cyclic (in2W hM) _ => u _; have [ij _ ->] := cosetP u.
  by split=> [/eqP | -> //]; rewrite hE -memH => /coset_id.
have Kw_h ij t: h0 ij = t -> t \in <<K; h w>>%VS.
  have /cycleP[k Dk]: coset H ij \in <[w]>%g by rewrite -defW inE.
  rewrite -hE {}Dk => <-; elim: k => [|k IHk]; first by rewrite h1 rpred1.
  by rewrite expgS hM rpredM // memv_adjoin.
right; exists (h w); apply/eqP; rewrite eqEsubv !(sameP FadjoinP andP).
rewrite subv_adjoin (subv_trans (subv_adjoin K y)) ?subv_adjoin //=.
rewrite (Kw_h (0, inZp 1)) 1?(Kw_h (inZp 1, 0)) /h0 ?mulr1 ?mul1r ?expr_mod //=.
by rewrite rpredM ?rpredX ?memv_adjoin // subvP_adjoin ?memv_adjoin.
Qed.

End FiniteCase.

Hypothesis sepKy : separable_element K y.

Lemma Primitive_Element_Theorem : exists z, (<< <<K; y>>; x>> = <<K; z>>)%VS.
Proof.
have /polyOver_subvs[p Dp]: minPoly K x \is a polyOver K := minPolyOver K x.
have nz_pKx: minPoly K x != 0 by rewrite monic_neq0 ?monic_minPoly.
have{nz_pKx} nz_p: p != 0 by rewrite Dp map_poly_eq0 in nz_pKx.
have{Dp} px0: root (map_poly vsval p) x by rewrite -Dp root_minPoly.
have [q0 [Kq0 q0y0 sepKq0]] := separable_elementP sepKy.
have /polyOver_subvs[q Dq]: minPoly K y \is a polyOver K := minPolyOver K y.
have qy0: root (map_poly vsval q) y by rewrite -Dq root_minPoly.
have sep_pKy: separable_poly (minPoly K y).
  by rewrite (dvdp_separable _ sepKq0) ?minPoly_dvdp.
have{sep_pKy} sep_q: separable_poly q by rewrite Dq separable_map in sep_pKy.
have [r nz_r PETr] := large_field_PET nz_p px0 qy0 sep_q.
have [[s [Us Ks /ltnW leNs]] | //] := finite_PET (size r).
have{s Us leNs} /allPn[t {}/Ks Kt nz_rt]: ~~ all (root r) s.
  by apply: contraTN leNs; rewrite -ltnNge => /max_poly_roots->.
have{PETr} [/= [p1 Dx] [q1 Dy]] := PETr (Subvs Kt) nz_rt.
set z := t * y - x in Dx Dy; exists z; apply/eqP.
rewrite eqEsubv !(sameP FadjoinP andP) subv_adjoin.
have Kz_p1z (r1 : {poly subvs_of K}): (map_poly vsval r1).[z] \in <<K; z>>%VS.
  rewrite rpred_horner ?memv_adjoin ?(polyOverSv (subv_adjoin K z)) //.
  by apply/polyOver_subvs; exists r1.
rewrite -{1}Dx -{1}Dy !{Dx Dy}Kz_p1z /=.
rewrite (subv_trans (subv_adjoin K y)) ?subv_adjoin // rpredB ?memv_adjoin //.
by rewrite subvP_adjoin // rpredM ?memv_adjoin ?subvP_adjoin.
Qed.

Lemma adjoin_separable : separable_element <<K; y>> x -> separable_element K x.
Proof.
have /Derivation_separableP derKy := sepKy => /Derivation_separableP derKy_x.
have [z defKz] := Primitive_Element_Theorem.
suffices /adjoin_separableP: separable_element K z.
  by apply; rewrite -defKz memv_adjoin.
apply/Derivation_separableP=> D; rewrite -defKz => derKxyD DK_0.
suffices derKyD: Derivation <<K; y>>%VS D by rewrite derKy_x // derKy.
by apply: DerivationS derKxyD; apply: subv_adjoin.
Qed.

End PrimitiveElementTheorem.

Lemma strong_Primitive_Element_Theorem K x y :
    separable_element <<K; x>> y ->
  exists2 z : L, (<< <<K; y>>; x>> = <<K; z>>)%VS
               & separable_element K x -> separable_element K y.
Proof.
move=> sepKx_y; have [n /andP[pcharLn sepKyn]] := separable_exponent_pchar K y.
have adjK_C z t: (<<<<K; z>>; t>> = <<<<K; t>>; z>>)%VS.
  by rewrite !agenv_add_id -!addvA (addvC <[_]>%VS).
have [z defKz] := Primitive_Element_Theorem x sepKyn.
exists z => [|/adjoin_separable->]; rewrite ?sepKx_y // -defKz.
have [|n_gt1|-> //] := ltngtP n 1; first by case: (n) pcharLn.
apply/eqP; rewrite !(adjK_C _ x) eqEsubv; apply/andP.
split; apply/FadjoinP/andP; rewrite subv_adjoin ?rpredX ?memv_adjoin //=.
by rewrite -pcharf_n_separable ?sepKx_y.
Qed.

Definition separable U W : bool :=
  all (separable_element U) (vbasis W).

Definition purely_inseparable U W : bool :=
  all (purely_inseparable_element U) (vbasis W).

Lemma separable_add K x y :
  separable_element K x -> separable_element K y -> separable_element K (x + y).
Proof.
move/(separable_elementS (subv_adjoin K y))=> sepKy_x sepKy.
have [z defKz] := Primitive_Element_Theorem x sepKy.
have /(adjoin_separableP _): x + y \in <<K; z>>%VS.
  by rewrite -defKz rpredD ?memv_adjoin // subvP_adjoin ?memv_adjoin.
apply; apply: adjoin_separable sepKy (adjoin_separable sepKy_x _).
by rewrite defKz base_separable ?memv_adjoin.
Qed.

Lemma separable_sum I r (P : pred I) (v_ : I -> L) K :
    (forall i, P i -> separable_element K (v_ i)) ->
  separable_element K (\sum_(i <- r | P i) v_ i).
Proof.
move=> sepKi.
by elim/big_ind: _; [apply/base_separable/mem0v | apply: separable_add |].
Qed.

Lemma inseparable_add K x y :
    purely_inseparable_element K x -> purely_inseparable_element K y ->
  purely_inseparable_element K (x + y).
Proof.
have insepP := purely_inseparable_elementP_pchar.
move=> /insepP[n pcharLn Kxn] /insepP[m pcharLm Kym]; apply/insepP.
have pcharLnm: [pchar L].-nat (n * m)%N by rewrite pnatM pcharLn.
by exists (n * m)%N; rewrite ?exprDn_pchar // {2}mulnC !exprM memvD // rpredX.
Qed.

Lemma inseparable_sum I r (P : pred I) (v_ : I -> L) K :
    (forall i, P i -> purely_inseparable_element K (v_ i)) ->
  purely_inseparable_element K (\sum_(i <- r | P i) v_ i).
Proof.
move=> insepKi.
by elim/big_ind: _; [apply/base_inseparable/mem0v | apply: inseparable_add |].
Qed.

Lemma separableP {K E} :
  reflect (forall y, y \in E -> separable_element K y) (separable K E).
Proof.
apply/(iffP idP)=> [/allP|] sepK_E; last by apply/allP=> x /vbasis_mem/sepK_E.
move=> y /coord_vbasis->; apply/separable_sum=> i _.
have: separable_element K (vbasis E)`_i by apply/sepK_E/memt_nth.
by move/adjoin_separableP; apply; rewrite rpredZ ?memv_adjoin.
Qed.

Lemma purely_inseparableP {K E} :
  reflect (forall y, y \in E -> purely_inseparable_element K y)
          (purely_inseparable K E).
Proof.
apply/(iffP idP)=> [/allP|] sep'K_E; last by apply/allP=> x /vbasis_mem/sep'K_E.
move=> y /coord_vbasis->; apply/inseparable_sum=> i _.
have: purely_inseparable_element K (vbasis E)`_i by apply/sep'K_E/memt_nth.
case/purely_inseparable_elementP_pchar=> n pcharLn K_Ein.
by apply/purely_inseparable_elementP_pchar; exists n; rewrite // exprZn rpredZ.
Qed.

Lemma adjoin_separable_eq K x : separable_element K x = separable K <<K; x>>%VS.
Proof. exact: sameP adjoin_separableP separableP. Qed.

Lemma separable_inseparable_decomposition E K :
  {x | x \in E /\ separable_element K x & purely_inseparable <<K; x>> E}.
Proof.
without loss sKE: K / (K <= E)%VS.
  case/(_ _ (capvSr K E)) => x [Ex sepKEx] /purely_inseparableP sep'KExE.
  exists x; first by split; last exact/(separable_elementS _ sepKEx)/capvSl.
  apply/purely_inseparableP=> y /sep'KExE; apply: sub_inseparable.
  exact/adjoinSl/capvSl.
pose E_ i := (vbasis E)`_i; pose fP i := separable_exponent_pchar K (E_ i).
pose f i := E_ i ^+ ex_minn (fP i); pose s := mkseq f (\dim E).
pose K' := <<K & s>>%VS.
have sepKs: all (separable_element K) s.
  by rewrite all_map /f; apply/allP=> i _ /=; case: ex_minnP => m /andP[].
have [x sepKx defKx]: {x | x \in E /\ separable_element K x & K' = <<K; x>>%VS}.
  have: all [in E] s.
    rewrite all_map; apply/allP=> i; rewrite mem_iota => ltis /=.
    by rewrite rpredX // vbasis_mem // memt_nth.
  rewrite {}/K'; elim/last_ind: s sepKs => [|s t IHs].
    by exists 0; [rewrite base_separable mem0v | rewrite adjoin_nil addv0].
  rewrite adjoin_rcons !all_rcons => /andP[sepKt sepKs] /andP[/= Et Es].
  have{IHs sepKs Es} [y [Ey sepKy] ->{s}] := IHs sepKs Es.
  have /sig_eqW[x defKx] := Primitive_Element_Theorem t sepKy.
  exists x; [split | exact: defKx].
    suffices: (<<K; x>> <= E)%VS by case/FadjoinP.
    by rewrite -defKx !(sameP FadjoinP andP) sKE Ey Et.
  apply/adjoin_separableP=> z; rewrite -defKx => Kyt_z.
  apply: adjoin_separable sepKy _; apply: adjoin_separableP Kyt_z.
  exact: separable_elementS (subv_adjoin K y) sepKt.
exists x; rewrite // -defKx; apply/(all_nthP 0)=> i; rewrite size_tuple => ltiE.
apply/purely_inseparable_elementP_pchar.
exists (ex_minn (fP i)); first by case: ex_minnP => n /andP[].
by apply/seqv_sub_adjoin/map_f; rewrite mem_iota.
Qed.

Definition separable_generator K E : L :=
   s2val (locked (separable_inseparable_decomposition E K)).

Lemma separable_generator_mem E K : separable_generator K E \in E.
Proof. by rewrite /separable_generator; case: (locked _) => ? []. Qed.

Lemma separable_generatorP E K : separable_element K (separable_generator K E).
Proof. by rewrite /separable_generator; case: (locked _) => ? []. Qed.

Lemma separable_generator_maximal E K :
  purely_inseparable <<K; separable_generator K E>> E.
Proof. by rewrite /separable_generator; case: (locked _). Qed.

Lemma sub_adjoin_separable_generator E K :
  separable K E -> (E <= <<K; separable_generator K E>>)%VS.
Proof.
move/separableP=> sepK_E; apply/subvP=> v Ev.
rewrite -separable_inseparable_element.
have /purely_inseparableP-> // := separable_generator_maximal E K.
by rewrite (separable_elementS _ (sepK_E _ Ev)) // subv_adjoin.
Qed.

Lemma eq_adjoin_separable_generator E K :
    separable K E -> (K <= E)%VS ->
  E = <<K; separable_generator K E>>%VS :> {vspace _}.
Proof.
move=> sepK_E sKE; apply/eqP; rewrite eqEsubv sub_adjoin_separable_generator //.
by apply/FadjoinP/andP; rewrite sKE separable_generator_mem.
Qed.

Lemma separable_refl K : separable K K.
Proof. exact/separableP/base_separable. Qed.

Lemma separable_trans M K E : separable K M -> separable M E -> separable K E.
Proof.
move/sub_adjoin_separable_generator.
set x := separable_generator K M => sMKx /separableP sepM_E.
apply/separableP => w /sepM_E/(separable_elementS sMKx).
case/strong_Primitive_Element_Theorem => _ _ -> //.
exact: separable_generatorP.
Qed.

Lemma separableS K1 K2 E2 E1 : 
  (K1 <= K2)%VS -> (E2 <= E1)%VS -> separable K1 E1 -> separable K2 E2.
Proof.
move=> sK12 /subvP sE21 /separableP sepK1_E1.
by apply/separableP=> y /sE21/sepK1_E1/(separable_elementS sK12).
Qed.

Lemma separableSl K M E : (K <= M)%VS -> separable K E -> separable M E.
Proof. by move/separableS; apply. Qed.

Lemma separableSr K M E : (M <= E)%VS -> separable K E -> separable K M.
Proof. exact: separableS. Qed.

Lemma separable_Fadjoin_seq K rs :
  all (separable_element K) rs -> separable K <<K & rs>>.
Proof.
elim/last_ind: rs => [|s x IHs] in K *.
  by rewrite adjoin_nil subfield_closed separable_refl.
rewrite all_rcons adjoin_rcons => /andP[sepKx /IHs/separable_trans-> //].
by rewrite -adjoin_separable_eq (separable_elementS _ sepKx) ?subv_adjoin_seq.
Qed.

Lemma purely_inseparable_refl K : purely_inseparable K K.
Proof. by apply/purely_inseparableP; apply: base_inseparable. Qed.

Lemma purely_inseparable_trans M K E :
  purely_inseparable K M -> purely_inseparable M E -> purely_inseparable K E.
Proof.
have insepP := purely_inseparableP => /insepP insepK_M /insepP insepM_E.
have insepPe := purely_inseparable_elementP_pchar.
apply/insepP=> x /insepM_E/insepPe[n pcharLn /insepK_M/insepPe[m pcharLm Kxnm]].
by apply/insepPe; exists (n * m)%N; rewrite ?exprM // pnatM pcharLn pcharLm.
Qed.

End Separable.

Arguments separable_elementP {F L K x}.
Arguments separablePn_pchar {F L K x}.
Arguments Derivation_separableP {F L K x}.
Arguments adjoin_separableP {F L K x}.
Arguments purely_inseparable_elementP_pchar {F L K x}.
Arguments separableP {F L K E}.
Arguments purely_inseparableP {F L K E}.
