Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq paths div.
Require Import choice fintype finfun bigops ssralg finset prime binomial.
Require Import groups zmodp morphisms automorphism normal perm action gprod.
Require Import commutators cyclic center pgroups sylow nilpotent abelian.
Require Import maximal hall BGsection1.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

(* belongs in commutators.v *)
Lemma der1_mulgen_cycles : forall (gT : finGroupType) (x y : gT),
  let XY := <[x]> <*> <[y]> in let xy := [~ x, y] in
  xy \in 'C(XY) -> XY^`(1) = <[xy]>.
Proof.
move=> gT x y; rewrite mulgen_idl mulgen_idr /= -sub_cent1; move/norms_gen=> ?.
apply/eqP; rewrite eqEsubset cycle_subG mem_commg ?mem_gen ?set21 ?set22 //.
rewrite der1_min // quotient_gen -1?gen_subG // quotientU abelian_gen.
rewrite /abelian subUset centU !subsetI andbC centsC -andbA -!abelianE.
rewrite !quotient_abelian ?(abelianS (subset_gen _) (cycle_abelian _)) //=.
by rewrite andbb quotient_cents2r ?genS // /commg_set imset2_set1l imset_set1.
Qed.

Section Section4.

Implicit Type gT : finGroupType.
Implicit Type p : nat.

Lemma order_prime_squared_abelian : forall gT (G : {group gT}) p,
  prime p -> #|G| = (p ^ 2)%N -> abelian G.
Proof.
move=> gT G p primep orderG.
have pG: p.-group G by rewrite /pgroup orderG pnat_exp pnat_id.
by rewrite (p2group_abelian pG) // orderG pfactorK.
Qed.

Lemma four_dot_three : forall gT (R : {group gT}) p,
       p.-group R -> odd #|R| -> nil_class R <= 2 + (p > 3) ->
    exponent 'Ohm_1(R) %| p
 /\ (R^`(1) \subset 'Ohm_1(R) -> {in R &, {morph expgn^~ p : x y / x * y}}).
Proof.
move=> gT R p pR oddR classR.
pose f n := bin n 3; pose g n := (bin n 3).*2 + bin n 2.
have fS : forall n, f n.+1 = bin n 2 + f n.
  by move=> n; rewrite /f binS addnC.
have gS : forall n, g n.+1 = (bin n 2).*2 + bin n 1 + g n.
  by move=> n; rewrite /g !binS double_add -!addnA; do 3!nat_congr.
case: (eqsVneq R 1) => [-> |].
  rewrite Ohm1 exponent1 der_sub dvd1n; split=> // _ u v; do 2!move/set1P->.
  by rewrite !(mulg1, exp1gn).
case/(pgroup_pdiv pR)=> p_pr p_dv_R _.
have pdivbin2: p %| bin p 2.
  rewrite prime_dvd_bin //= ltn_neqAle prime_gt1 // andbT.
  by apply: contraL oddR; rewrite -dvdn2; move/eqP->.
have pdivfp : p > 3 -> p %| f p by move=> pgt3; apply: prime_dvd_bin.
have pdivgp : p > 3 -> p %| g p.
  by move=> pgt3; rewrite dvdn_add // -muln2 dvdn_mulr // pdivfp.
have exp_dv_p : forall x m (S : {group gT}),
  exponent S %| p -> p %| m -> x \in S -> x ^+ m = 1.
- move=> x m S expSp p_dv_m Sx; apply/eqP; rewrite -order_dvdn.
  by apply: dvdn_trans (dvdn_trans expSp p_dv_m); exact: dvdn_exponent.
have p3_L21: p <= 3 -> {in R & &, forall u v w, [~ u, v, w] = 1}.
  move=> lep3 u v w Ru Rv Rw; rewrite (ltnNge 3) lep3 nil_class2 in classR.
  apply/eqP; apply/commgP; red; rewrite (centerC Rw) //.
  by rewrite (subsetP classR) // mem_commg.
have{fS gS} eq44 : {in R &, forall u v n (r := [~ v, u]),
  (u * v) ^+ n = u ^+ n * v ^+ n * r ^+ bin n 2
                  * [~ r, u] ^+ f n * [~ r, v] ^+ g n}.
- move=> u v Ru Rv; move=> n r; have Rr: r \in R by exact: groupR.
  have cRr: {in R &, forall x y, commute x [~ r, y]}.
    move=> x y Rx Ry /=; red; rewrite (centerC Rx) //.
    have: [~ r, y] \in 'L_3(R) by rewrite !mem_commg.
    by apply: subsetP; rewrite -nil_class3 (leq_trans classR) // !ltnS leq_b1.
  elim: n => [| n IHn]; first by rewrite !mulg1.
  rewrite 3!expgSr {}IHn -!mulgA (mulgA (_ ^+ f n)); congr (_ * _).
  rewrite -commuteM; try by apply: commuteX; red; rewrite cRr ?groupM.
  rewrite -mulgA; do 2!rewrite (mulgA _ u) (commgC _ u) -2!mulgA.
  congr (_ * (_ * _)); rewrite (mulgA _ v).
  have ->: [~ v ^+ n, u] = r ^+ n * [~ r, v] ^+ bin n 2.
    elim: n => [|n IHn]; first by rewrite comm1g mulg1.
    rewrite !expgS commMgR -/r {}IHn commgX; last exact: cRr.
    rewrite binS bin1 addnC expgn_add -2!mulgA; congr (_ * _); rewrite 2!mulgA.
    by rewrite commuteX2 // /commute cRr.
  rewrite commXg 1?commuteX2 -?[_ * v]commuteX; try exact: cRr.
  rewrite mulgA {1}[mulg]lock mulgA -mulgA -(mulgA v) -!expgn_add -fS -lock.
  rewrite -{2}(bin1 n) addnC -binS -2!mulgA (mulgA _ v) (commgC _ v).
  rewrite -commuteX; last by red; rewrite cRr ?(Rr, groupR, groupX, groupM).
  rewrite -3!mulgA; congr (_ * (_ * _)); rewrite 2!mulgA.
  rewrite commXg 1?commuteX2; try by red; rewrite cRr 1?groupR.
  by rewrite -!mulgA -!expgn_add addnCA binS addnAC addnn addnC -gS.
have expR1p: exponent 'Ohm_1(R) %| p.
  elim: _.+1 {-2 4}R (ltnSn #|R|) (subxx R) => // n IHn Q leQn sQR.
  rewrite (OhmE 1 (pgroupS sQR pR)) expn1; apply/exponentP=> x.
  rewrite gen_set_id; first by case/setIdP; case: eqP.
  apply/group_setP; rewrite !inE group1 exp1gn /=; split=> {x}// x y.
  case/setIdP=> Qx; move/eqP=> xp1; case/setIdP=> Qy; case/eqP=> yp1.
  rewrite inE groupM //=; apply/eqP.
  have sxQ: <[x]> \subset Q by rewrite cycle_subG.
  have [[{sxQ}defQ]|[S maxS /= sxS]] := maximal_exists sxQ.
    rewrite expMgn; first by rewrite xp1 yp1 mulg1.
    by apply: (centsP (cycle_abelian x)); rewrite ?defQ.
  have:= maxgroupp maxS; rewrite properEcard; case/andP=> sSQ ltSQ.
  have pQ := pgroupS sQR pR; have pS := pgroupS sSQ pQ.
  have{ltSQ leQn} ltSn: #|S| < n by exact: leq_trans ltSQ _.
  have expS1p := IHn _ ltSn (subset_trans sSQ sQR).
  have defS1 := Ohm1Eexponent p_pr expS1p; move/exp_dv_p: expS1p => expS1p.
  have nS1Q: [~: Q, 'Ohm_1(S)] \subset 'Ohm_1(S).
    rewrite commg_subr (char_norm_trans (Ohm_char 1 S)) ?normal_norm //.
    exact: p_maximal_normal pQ maxS.
  have S1x : x \in 'Ohm_1(S) by rewrite defS1 inE -cycle_subG sxS xp1 /=.
  have S1yx : [~ y, x] \in 'Ohm_1(S) by rewrite (subsetP nS1Q) ?mem_commg.
  have S1yxx : [~ y, x, x] \in 'Ohm_1(S) by rewrite groupR.
  have S1yxy : [~ y, x, y] \in 'Ohm_1(S).
    by rewrite -invg_comm groupV (subsetP nS1Q) 1?mem_commg.
  rewrite eq44 ?(subsetP sQR) //= xp1 yp1 expS1p ?mul1g //.
  case: (leqP p 3) => [p_le3 | p_gt3]; last by rewrite ?expS1p ?mul1g; auto.
  by rewrite !p3_L21 // ?(subsetP sQR) // !exp1gn mulg1.
split=> // sR'R1 x y Rx Ry; rewrite -[x ^+ p * _]mulg1 eq44 // -2!mulgA //.
have expR'p := exp_dv_p _ _ _ (dvdn_trans (exponentS sR'R1) expR1p).
congr (_ * _); rewrite expR'p ?mem_commg // mul1g.
case: (leqP p 3) => [p_le3 | p_gt3].
  by rewrite !p3_L21 // ?(subsetP sQR) // !exp1gn mulg1.
by rewrite !expR'p 1?mem_commg ?groupR ?mulg1; auto.
Qed.

(* B & G 4.4b, G 7.6.5 *)
Lemma centralizer_scn_pgroup_eq : forall gT (R G A : {group gT}) p,
  p.-Sylow(G) R -> A \in 'SCN(R) -> 'O_p^'('C_G(A)) \x A = 'C_G(A).
Proof.
move=> gT R G A p sylR scnA; have [sRG _ _] := and3P sylR.
case/maxgroupP: (SCN_max scnA); case/andP=> nAG abelA maxA.
case/SCN_P: scnA => nAR CRA_A.
set C := 'C_G(A).
have CiP_eq : C :&: R = A by rewrite -CRA_A setIC setIA (setIidPl sRG).
have sylA: p.-Sylow(C) A.
  rewrite -CiP_eq; apply: (pSylow_normalI (subcent_normal _ _)).
  by apply: pHall_subl sylR; rewrite ?subsetIl // subsetI sRG normal_norm.
rewrite dprodEsdprod; last by rewrite (subset_trans (pcore_sub _ _)) ?subsetIr.
by apply: Burnside_normal_complement; rewrite // subIset ?subsetIr.
Qed.

Section Four_dot_Five_b.

Import GRing.Theory.

Lemma four_dot_five_b : forall gT (R : {group gT}) p x,
    p.-group R -> odd #|R| -> ~~ cyclic R -> x \in R -> #|R : <[x]>| = p ->
  ('Ohm_1(R))%G \in 'E_p^2(R).
Proof.
move=> gT R p x pR oddR ncycR Rx; set X := <[x]> => indexRX.
have sXR : <[x]> \subset R by [rewrite cycle_subG]; have pX := pgroupS sXR pR.
have [p_gt2 p_pr]: p > 2 /\ prime p.
  case: (eqsVneq R 1) ncycR oddR => [->|]; first by rewrite cyclic1.
  case/(pgroup_pdiv pR) => p_pr _ [k ->] _; rewrite odd_exp /= ltn_neqAle.
  by rewrite prime_gt1 //; case: eqP => // <-.
have maxX : maximal X R by rewrite p_index_maximal // indexRX.
have nXR : R \subset 'N(<[x]>) by rewrite normal_norm ?(p_maximal_normal pR).
case: (eqVneq X 1) => [X1 | ntX].
  by move: ncycR; rewrite prime_cyclic // -indexg1 -X1 indexRX.
have [_ _ [n oX]] := pgroup_pdiv pX ntX; rewrite -orderE in oX.
have: X != R by apply: contra ncycR; move/eqP <-; exact: cycle_cyclic.
rewrite eqEsubset sXR //=; case/subsetPn=> y Ry X'y.
have nXy := subsetP nXR y Ry; have Xyp: y ^+ p \in X.
  rewrite coset_idr ?groupX ?morphX // -indexRX; apply/eqP.
  by rewrite -order_dvdn -card_quotient ?order_dvdG ?mem_morphim.
have: x ^ y \in X by rewrite memJ_norm ?cycle_id.
case/cycleP=> k; case: (posnP k) => [-> | k_gt0] def_xy.
  by rewrite cycle_eq1 -(conjgK y x) def_xy conj1g eqxx in ntX.
have kp_modX: k ^ p == 1 %[mod p ^ n.+1].
  rewrite -oX -eq_expg_mod_order expg1; apply/eqP.
  transitivity (x ^ (y ^+ p)); last first.
    by rewrite /conjg -(centsP (cycle_abelian x) _ Xyp) ?cycle_id ?mulKg.
  elim: (p) => [|j IHj]; rewrite ?conjg1 // expnSr expgn_mul {}IHj.
  by rewrite expgS conjgM def_xy conjXg.
have{kp_modX} k_modZ: k == 1 %[mod p ^ n].
  have ki_gt0 : k ^ _ > 0 by move=> i; rewrite expn_gt0 k_gt0.
  have chFp := char_Fp p_pr; rewrite !eqn_mod_dvd // !subn1 in kp_modX *.
  have k1: (k%:R == 1 :> 'F_p)%R.
    rewrite -(Frobenius_aut_nat chFp) Frobenius_autE -natr_exp.
    rewrite -val_eqE /= val_Fp_nat ?Fp_cast // eqn_mod_dvd // subn1.
    by apply: dvdn_trans kp_modX; rewrite expnS dvdn_mulr.
  pose u := \sum_(i < p) \sum_(j < i) k ^ j.
  have u0: (u%:R == 0 :> 'F_p)%R.
    apply/eqP; rewrite -(@bin_lt_charf_0 _ _ chFp 2) //.
    have psum := (big_morph (fun m => m%:R : 'F_p)%R (@natr_add _) (mulr0n _)).
    rewrite -triangular_sum big_mkord !psum; apply: eq_bigr => i _.
    rewrite psum (eq_bigr (fun _ => 1%R)) ?sumr_const ?card_ord // => j _.
    by rewrite natr_exp (eqP k1) exp1rn.
  rewrite -!val_eqE /= !val_Fp_nat ?Fp_cast // !eqn_mod_dvd ?subn0 // in k1 u0.
  have def_kp: (k ^ p).-1 = (k.-1 * (k.-1 * u + 1 * p))%N.
    rewrite mul1n -{2}[p]card_ord -sum1_card predn_exp; congr (_ * _)%N.
    rewrite big_distrr -big_split; apply: eq_bigr => i _ /=.
    by rewrite -predn_exp addn1 prednK.
  case/dvdnP: u0 def_kp kp_modX => q -> ->; rewrite mulnA -muln_addl mulnCA.
  rewrite mulnA expnSr dvdn_pmul2r ?prime_gt0 ?gauss ?coprime_expl // -subn1.
  by case/dvdnP: k1 => q' ->; rewrite mulnAC /coprime gcdn_addl_mul gcdn1.
have: X :&: 'Z(R) != 1 by rewrite nil_meet_Z ?(pgroup_nil pR) /normal ?sXR.
case/(pgroup_pdiv (pgroupS (subsetIl _ _) pX)) => _; case/Cauchy=> // z.
case/setIP=> Xz; case/setIP=> Rz cRz oz _; set r := [~ x, y].
have def_z: <[z]> = 'Ohm_1(X).
  apply/eqP; rewrite eqEcard {1}(OhmE _ pX) cycle_subG.
  rewrite mem_gen /=; last by rewrite inE -oz Xz expg_order /=.
  rewrite (Ohm_p_cycle _ pX) subn1 -orderE orderXdiv ?pfactor_dvdn ?leq_pred //.
  by rewrite -orderE oz oX pfactorK // expnS mulnK // expn_gt0 prime_gt0.
have{k k_gt0 k_modZ def_xy} z_r: r \in <[z]>.
  rewrite def_z (OhmE _ pX) mem_gen //= /r commgEl def_xy -(subnKC k_gt0).
  rewrite expgS mulKg inE mem_cycle -expgn_mul -order_dvdn oX expnSr.
  by rewrite dvdn_pmul2r ?prime_gt0 // -eqn_mod_dvd.
have cRr: r \in 'C(R) by apply: subsetP z_r; rewrite cycle_subG.
have nrR: R \subset 'N(<[r]>) by rewrite cents_norm // centsC cycle_subG.
have defR: R :=: X <*> <[y]>.
  apply/eqP; rewrite eq_sym eqEproper mulgen_subG !cycle_subG Rx Ry /=.
  apply/negP; case/maxgroupP: maxX => _ maxX; move/maxX => /= defX.
  by rewrite -cycle_subG /= -defX ?mulgen_subl ?mulgen_subr in X'y.
have defR': R^`(1) = <[r]>.
  rewrite defR der1_mulgen_cycles // (subsetP _ _ cRr) // centS //.
  by rewrite mulgen_subG !cycle_subG Rx.
have sR1R': R^`(1) \subset 'Ohm_1(R).
  rewrite defR' (OhmE _ pR) genS // sub1set inE groupR //=.
  by rewrite -order_dvdn -oz order_dvdG.
case/four_dot_three: (pR) => // [|expR1p]; last move/(_ sR1R') => morphRp.
  apply: leq_trans _ (leq_addr _ _).
  by rewrite nil_class2 defR' cycle_subG inE cRr groupR.
case/cycleP: Xyp => qp def_yp; have: p %| qp.
  apply: contraR ncycR.
  rewrite -prime_coprime // -(@coprime_pexpl n.+1) // -oX => co_x_qp.
  apply/cyclicP; exists y; rewrite defR /mulgen (setUidPr _) ?genGid //.
  by rewrite cycle_subG -[x](expgnK co_x_qp) -?def_yp ?groupX ?cycle_id.
case/dvdnP => q def_qp; rewrite {qp}def_qp in def_yp.
pose t := y * x ^- q; have Rt: t \in R by rewrite groupM ?groupV ?groupX.
have{X'y} X't: t \notin X by rewrite groupMr ?groupV ?mem_cycle.
have{def_yp} ot: #[t] = p.
  apply/eqP; case: (eqVneq t 1) X't => [->|]; first by rewrite group1.
  rewrite -cycle_eq1 eqn_dvd; case/(pgroup_pdiv (mem_p_elt pR Rt)) => _ -> _ _.
  rewrite order_dvdn morphRp ?groupV ?groupX // expVgn -expgn_mul -def_yp.
  by rewrite mulgV eqxx.
have{defR} defR: X <*> <[t]> = R.
  apply/eqP; rewrite eqEproper mulgen_subG !cycle_subG Rx Rt /=.
  apply/negP; case/maxgroupP: maxX => _ maxX; move/maxX => /= defX.
  by rewrite -cycle_subG /= -defX ?mulgen_subl ?mulgen_subr in X't.
have nZt: <[t]> \subset 'N(<[z]>).
  rewrite cycle_subG; apply: subsetP Rt.
  by rewrite cents_norm // centsC cycle_subG.
pose R1 := <[z]> <*> <[t]>; rewrite !inE /= Ohm_sub /= -2!andbA expR1p.
have ->: 'Ohm_1(R) = R1.
  rewrite -(setIidPl (Ohm_sub _ _)) /R1 norm_mulgenEr //= -{2}defR.
  rewrite norm_mulgenEr ?cycle_subG ?(subsetP nXR) -?group_modr //=; last first.
    by rewrite (OhmE _ pR) genS //= sub1set inE Rt -ot expg_order /=.
  congr (_ * _); apply/eqP; rewrite eqEsubset andbC.
  rewrite def_z subsetI Ohm_sub OhmS //=.
  apply/subsetP=> u; case/setIP; move/(exponentP expR1p)=> up1 Xu.
  by rewrite (OhmE _ pX) mem_gen //= inE Xu up1 /=.
have oR1: #|R1| = (p ^ 2)%N.
  rewrite /R1 mulgenC norm_mulgenEl ?TI_cardMg ?prime_TIg -?orderE ?oz ?ot //.
  by apply: contra X't; rewrite cycle_subG; apply: subsetP; rewrite cycle_subG.
have pR1: p.-group R1 by rewrite /pgroup oR1 pnat_exp pnat_id.
by rewrite pR1 (p2group_abelian pR1) oR1 pfactorK.
Qed.

End Four_dot_Five_b.

Section Four_dot_Five_ac.

Variables (gT : finGroupType) (R : {group gT}) (p : nat).
Hypotheses (pR : p.-group R) (oddR : odd #|R|) (ncycR : ~~ cyclic R).

Lemma four_dot_five_a : exists2 S : {group gT}, S <| R & S \in 'E_p^2(R).
Proof.
have: exists G : {group gT}, (G <| R) && ~~ cyclic G.
  by exists R; rewrite normal_refl.
case/ex_mingroup=> M; case/mingroupP; case/andP=> nsMR ncycM minM.
have [sMR _] := andP nsMR; have pM := pgroupS sMR pR.
exists ('Ohm_1(M))%G; first exact: char_normal_trans (Ohm_char 1 M) nsMR.
apply: (subsetP (pnElemS _ _ sMR)).
case: (eqsVneq M 1) (ncycM) => [-> | ntM _]; first by rewrite cyclic1.
have{ntM} [p_pr _ [e oM]] := pgroup_pdiv pM ntM.
have le_e_M: e <= logn p #|M| by rewrite ltnW // oM pfactorK.
have{le_e_M} [N [sNM nsNR] oN] := normal_pgroup pR nsMR le_e_M.
have ltNM: ~~ (#|N| >= #|M|) by rewrite -ltnNge oM oN ltn_exp2l ?prime_gt1.
have cycN : cyclic N by apply: contraR ltNM => ncycN; rewrite minM //= nsNR.
case/cyclicP: cycN => x defN; have Mx : x \in M by rewrite -cycle_subG -defN.
apply: four_dot_five_b Mx _; rewrite ?(oddSg sMR) //.
by rewrite -divgS /= -defN // oM oN expnS mulnK // expn_gt0 prime_gt0.
Qed.

Let Z := 'Ohm_1('Z_2(R)).

Lemma four_dot_five_c : ~~ cyclic Z /\ exponent Z %| p.
Proof.
case: (four_dot_five_a) => S [nsSR]; case/pnElemP=> sSR abelS dimS2.
have [pS cSS expSp]:= and3P abelS; have nilR := pgroup_nil pR.
case: (eqsVneq S 1) dimS2 => [-> | ntS dimS2]; first by rewrite cards1 logn1.
have [p_pr _ _] :=  pgroup_pdiv pS ntS.
pose SR := [~: S, R]; pose SRR := [~: SR, R].
have sSR_S : SR \subset S by rewrite commg_subl normal_norm.
have sSRR_SR : SRR \subset SR by rewrite commSg.
have sSR_R := subset_trans sSR_S sSR.
(* shouldn't this be a separate lemma for nilpotent groups? *)
have{ntS} prSR: SR \proper S.
  rewrite properE sSR_S //=; apply: contraL (forallP nilR S).
  by rewrite (setIidPr sSR_R) => ->.
have SRR1 : SRR = 1.
  case: (eqVneq SR 1) => [SR1 | ntSR]; first by rewrite /SRR SR1 comm1G.
  have prSRR: SRR \proper SR.
    rewrite /proper sSRR_SR; apply: contra ntSR => sSR_SRR.
    by rewrite (implyP (forallP nilR _)) // subsetI sSR_R.
  have pSR := pgroupS sSR_R pR; have pSRR := pgroupS sSRR_SR pSR.
  have [_ _ [e oSR]] := pgroup_pdiv pSR ntSR; have [f oSRR] := p_natP pSRR.
  have e0 : e = 0.
    have:= proper_card prSR; rewrite oSR -(part_pnat pS) p_part dimS2.
    by rewrite ltn_exp2l ?prime_gt1 // !ltnS leqn0; move/eqP.
  apply/eqP; have:= proper_card prSRR; rewrite trivg_card1 oSR oSRR e0.
  by rewrite ltn_exp2l ?prime_gt1 // ltnS; case f.
have sSR_ZR : [~: S, R] \subset 'Z(R).
  by rewrite subsetI sSR_R /=; apply/commG1P.
have sS_Z2R : S \subset 'Z_2(R).
  rewrite ucnSnR; apply/subsetP=> s Ss; rewrite inE (subsetP sSR) //= ucn1.
  by apply: subset_trans sSR_ZR; rewrite commSg ?sub1set.
have sZ2R_R := ucn_sub 2 R; have pZ2R := pgroupS sZ2R_R pR.
have pZ : p.-group Z.
  apply: pgroupS pR; exact: subset_trans (Ohm_sub _ _) (ucn_sub 2 R).
have sSZ : S \subset Z.
  apply/subsetP=> s Ss; rewrite /Z (OhmE 1 pZ2R) mem_gen // inE.
  by rewrite (subsetP sS_Z2R) //= (exponentP expSp).
have ncycX: ~~ cyclic S by rewrite (abelem_cyclic abelS) dimS2.
split; first by apply: contra ncycX; exact: cyclicS.
(* should this be proved for arbitrary n? *)
have nilclassZ : nil_class 'Z_2(R) <= 2.
  rewrite nil_class2 subsetI der_sub /= (subset_trans (commgS _ sZ2R_R)) //.
  by apply: (subset_trans (ucn_comm _ _)); rewrite ucn1 subIset // centS ?orbT.
by case: (four_dot_three pZ2R (oddSg sZ2R_R oddR) (leq_trans nilclassZ _)).
Qed.

End Four_dot_Five_ac.

Lemma four_dot_six : forall gT (R S : {group gT}) p,
    p.-group R -> odd #|R| -> S <| R -> ~~ cyclic S ->
  exists H : {group gT}, H <| R /\ H \in 'E_p^2(R).
Proof.
move=> gT R S p pR oddR nsSR ncycS; pose Z := 'Ohm_1('Z_2(S)).
have nsZR: Z <| R.
  by rewrite (char_normal_trans (char_trans (Ohm_char 1 _) (ucn_char 2 S))).
have pZ: p.-group Z := pgroupS (normal_sub nsZR) pR.
have [sSR _] := andP nsSR; have pS := pgroupS sSR pR.
have [] := four_dot_five_c pS (oddSg sSR oddR) ncycS; rewrite -/Z.
case: (eqVneq Z 1) => [-> | ntZ ncycZ expZp]; first by rewrite cyclic1.
have [p_pr _ [e]] := pgroup_pdiv pZ ntZ; rewrite /= -/Z => cardZ.
have e_gt0 : 0 < e.
  by case: (posnP e) => // e0; rewrite prime_cyclic ?cardZ ?e0 in ncycZ.
have lognpZ : 2 <= logn p #|Z| by rewrite cardZ pfactorK.
case: (normal_pgroup pR nsZR lognpZ) => H [sHZ nHR cardH].
exists H; split; first done.
rewrite pnElemE // inE cardH eqxx andbT inE (normal_sub nHR) /=.
rewrite abelemE // (order_prime_squared_abelian p_pr) //=.
by apply: (dvdn_trans _ expZp); apply: exponentS.
Qed.

Lemma odd_pgroup_rank1_cyclic : forall gT (G : {group gT}) (p : nat),
  p.-group G -> odd #|G| -> cyclic G = ('r_p(G) <= 1).
Proof.
move=> gT G p pG oddG; apply/idP/idP=> [cycG | dimG1].
  have cGG := cyclic_abelian cycG; rewrite p_rank_abelian //.
  by rewrite -abelem_cyclic ?(cyclicS (Ohm_sub _ _)) ?Ohm1_abelem.
apply: contraLR dimG1 => ncycG; rewrite -ltnNge; apply/p_rank_geP.
by have [E _ EP2_E] := four_dot_five_a pG oddG ncycG; exists E.
Qed.

Lemma odd_rank1_Zgroup : forall gT (G : {group gT}),
  odd #|G| -> Zgroup G = ('r(G) <= 1).
Proof.
move=> gT G oddG; apply/forallP/idP=> [ZgG | rG_1 P].
  have [p p_pr ->]:= rank_witness G; have [P sylP]:= Sylow_exists p G.
  have [sPG pP _] := and3P sylP; have oddP := oddSg sPG oddG.
  rewrite (p_rank_Sylow sylP) -(odd_pgroup_rank1_cyclic pP) //.
  by apply: (implyP (ZgG P)); exact: (p_Sylow sylP).
apply/implyP; case/SylowP=> p p_pr; case/and3P=> sPG pP _.
rewrite (odd_pgroup_rank1_cyclic pP (oddSg sPG oddG)).
by apply: leq_trans (leq_trans (p_rank_le_rank p G) rG_1); exact: p_rankS.
Qed.

(* move this to action.v, or fold into the proof below? *)
Lemma astabsQR_point : forall gT (A H : {set gT}) (G : {group gT}),
    H \subset 'N(G) -> A \subset 'N(G) ->
  'C_H(A / G | 'Q) = H :&: [set x | (commg x @: A) \subset G].
Proof.
move=> gt A H G sH_NG sA_NG; apply/setP=> x.
case Hx : (x \in H); rewrite inE [x \in _ :&: _]inE Hx //=.
rewrite -sub1set astabsQR ?inE ?sub1set ?(subsetP sH_NG) //.
by rewrite gen_subG /commg_set imset2_set1l.
Qed.

Section Twenty_Three_dot_Fifteen. (* in Aschbacher *)

Variables (gT : finGroupType) (G A : {group gT}).
Hypothesis (SCN_A : A \in 'SCN(G)).

Let Z := 'Ohm_1(A).

Lemma der1_stab_Ohm1_SCN_series :
  ('C(Z) :&: 'C_G(A / Z | 'Q))^`(1) \subset A.
Proof.
case/SCN_P: SCN_A=> nsAG CGAeq; have nAG := (normal_norm nsAG).
have nZG := (normal_norm (char_normal_trans (Ohm_char 1 _) nsAG)).
rewrite -{4}CGAeq subsetI; apply/andP; split.
  by apply: (subset_trans (der_sub _ _)); rewrite subIset // subsetIl orbT.
rewrite gen_subG; apply/subsetP=> w; case/imset2P=> u v.
rewrite astabsQR_point ?(subset_trans (normal_sub nsAG)) // !inE.
case/andP; move/centP=> centuZ; case/andP=> Gu /= s_commguA_Z.
case/andP; move/centP=> centvZ; case/andP=> Gv /= s_commgvA_Z ->{w}.
apply/centP=> a Aa; symmetry; rewrite mulgA [a * _]commgC /conjg 2!mulgA.
have NZu : u \in 'N(Z) by apply: (subsetP nZG u Gu).
have Zauinv : [~ a, u^-1] \in Z.
  rewrite -(memJ_norm _ NZu); apply: (subsetP s_commguA_Z).
  by apply/imsetP; exists a => //; rewrite /conjg /commg !mulgA invgK mulgKV.
rewrite -(mulgA _ _ v^-1) (commuteV (commute_sym (centvZ _ Zauinv))).
rewrite !mulgA invgK mulgKV -(mulgA _ _ v^-1) [a * _]commgC 2!mulgA.
have NZv : v \in 'N(Z) by apply: (subsetP nZG v Gv).
have Zavinv : [~ a, v^-1] \in Z.
  rewrite -(memJ_norm _ NZv); apply: (subsetP s_commgvA_Z).
  by apply/imsetP; exists a => //; rewrite /conjg /commg !mulgA invgK mulgKV.
have cAA : A \subset 'C(A) by rewrite -abelianE; apply: (SCN_abelian SCN_A).
have sZA := (Ohm_sub 1 A).
rewrite -(mulgA _ _ a^-1) (centsP cAA _ (subsetP sZA _ Zavinv)) ?groupV //.
rewrite mulgA mulgK -(mulgA _ _ u) -(centuZ _ Zavinv) mulgA -(mulgA _ _ a).
rewrite (centsP cAA _ (subsetP sZA _ Zavinv)) // /commg /conjg !mulgA.
by rewrite mulgK mulgKV invgK.
Qed.

Variable (p : nat).
Hypotheses (oddp : odd p) (pgroupG : p.-group G).

Lemma Ohm1_stab_Ohm1_SCN_series : 'Ohm_1('C_G(Z)) \subset 'C_G(A / Z | 'Q).
Proof.
case Geq1 : (G == 1%G).
  rewrite (eqP Geq1) /= (subset_trans (Ohm_sub _ _)) //.
  by rewrite (subset_trans (subsetIl _ _)) // sub1set group1.
case: (pgroup_pdiv pgroupG (negbT Geq1)) => primep _ _.
case/SCN_P: SCN_A=> nAG CGAeq; have sGNA := (normal_norm nAG).
have sGNZ := (normal_norm (char_normal_trans (Ohm_char 1 _) nAG)).
have sANZ := (subset_trans (normal_sub nAG) sGNZ).
have sACA : A \subset 'C(A) by apply: (SCN_abelian SCN_A).
have pgroupCGZ : p.-group 'C_G(Z) by rewrite (pgroupS _ pgroupG) // subsetIl.
rewrite (OhmE 1 pgroupCGZ) gen_subG expn1; apply/subsetP=> x; rewrite 2!inE /=.
case/andP; case/andP=> Gx CZx xpeq1.
pose CA_XZ := 'C_A(<[x]> / Z | 'Q).
have CA_XZ_eq : CA_XZ = A :&: [set g | commg g @: <[x]> \subset Z].
  by rewrite /CA_XZ astabsQR_point //= ?gen_subG ?sub1set ?(subsetP sGNZ).
have sX_NCAXZ : <[x]> \subset 'N(CA_XZ).
  rewrite normsI //; first by rewrite cycle_subG (subsetP sGNA).
  rewrite normsG // astabsQ cycle_subG (subsetP (cent_sub _)) //.
  by rewrite -abelianE quotient_abelian // cycle_abelian.
pose Y := <[x]> <*> CA_XZ.
have sxG : <[x]> \subset G by rewrite cycle_subG.
have sCA_XZ_G : CA_XZ \subset G.
  exact: (subset_trans (subsetIl _ _) (normal_sub nAG)).
have sYG : Y \subset G by rewrite mulgen_subG sxG.
have pgroupY := (pgroupS sYG pgroupG).
have Yeq : Y = <[x]> * 'C_A(<[x]> / Z | 'Q) by apply: norm_mulgenEl.
have nZx : <[x]> \subset 'N(Z) by rewrite cents_norm ?cycle_subG.
have nZY : Y \subset 'N(Z).
  by rewrite mulgen_subG nZx (subset_trans (subsetIl _ _)).
have sY'_Z : Y^`(1) \subset Z.
  rewrite der1_min //= -/Y Yeq -/Z quotientMl // abelianM.
  rewrite !quotient_abelian ?cycle_abelian ?(abelianS _ sACA) ?subsetIl //.
  by rewrite /= quotientGI ?Ohm_sub // centsC quotient_astabQ subsetIr.
have {sY'_Z}nil_classY : nil_class Y <= 2.
  rewrite nil_class2 (subset_trans sY'_Z _) // subsetI.
  rewrite (subset_trans _ (mulgen_subr _ _)) /= 1?subsetI; last first.
    by rewrite Ohm_sub //= astabsQ normG /= trivg_quotient sub1set group1.
  rewrite centsC mulgen_subG cycle_subG CZx //=.
  rewrite (subset_trans (subsetIl _ _)) // centsC //.
  by rewrite (subset_trans (Ohm_sub _ _)).
pose XA := <[x]> <*> A.
rewrite -cycle_subG subsetI sxG /= astabsQ nZx /= centsC -/Z.
suffices: XA \subset Y.
  rewrite Yeq group_modl /=; last first.
    by rewrite astabsQ nZx; apply: quotient_abelian; apply: cycle_abelian.
  rewrite subsetI {1}[XA]norm_mulgenEl ?subxx /=; last first.
    by apply: (subset_trans _ sGNA); rewrite cycle_subG.
  rewrite astabsQ; case/andP=> _ /=; apply: subset_trans; apply: quotientS.
  exact: mulgen_subr.
have XAeq : XA = <[x]> * A.
  by apply: norm_mulgenEl; rewrite gen_subG sub1set (subsetP sGNA).
have sYXA : Y \subset XA.
  rewrite mulgen_subG mulgen_subl; apply: (subset_trans _ (mulgen_subr _ _)).
  exact: subsetIl.
have pgroupXA : p.-group XA.
  apply: (pgroupS _ pgroupG); rewrite mulgen_subG gen_subG sub1set Gx /=.
  exact: (normal_sub nAG).
have pgroupA := (pgroupS (normal_sub nAG) pgroupG).
have sY1_XZ : 'Ohm_1(Y) \subset <[x]> * Z.
  apply/subsetP=> w Y1w.
  move: (subsetP sYXA _ (subsetP (Ohm_sub _ _) _ Y1w)) (Y1w).
  rewrite XAeq; case/imset2P=> y a; case/cycleP=> i ->{y} Aa ->{Y1w w}.
  rewrite groupMl; last first.
    rewrite groupX //= (OhmE _ pgroupY) mem_gen // inE expn1 xpeq1 andbT.
    by apply: (subsetP (mulgen_subl _ _)); apply: cycle_id.
  pose expY1 := (exponentP (exponent_Ohm1_class2 oddp pgroupY nil_classY)).
  move/(expY1 _)=> apeq; apply: mem_imset2; first exact: mem_cycle.
  by rewrite [Z](OhmE 1 pgroupA) mem_gen // inE Aa expn1 apeq eq_refl.
suffices ->: XA = Y by rewrite subxx.
apply: (nilpotent_sub_norm (pgroup_nil pgroupXA)).
  rewrite mulgen_subG mulgen_subl; apply: (subset_trans _ (mulgen_subr _ _)).
  exact: subsetIl.
have sNXAY_NXAY1 : 'N_XA(Y) \subset 'N_XA('Ohm_1(Y)).
  rewrite subsetI subsetIl /=.
  apply: (subset_trans (normal_norm (normalSG sYXA))); apply normal_norm.
  by apply: (char_normal_trans (Ohm_char _ _)); apply: normalG.
apply: (subset_trans sNXAY_NXAY1) => {sNXAY_NXAY1}.
apply/subsetP=> w; case/setIP; rewrite XAeq; case/imset2P=> y a.
case/cycleP=> i ->{y} Aa -> NY1xi; rewrite /= [_ <*> _]Yeq.
rewrite mem_imset2 // ?mem_cycle //.
have Y1x : x \in 'Ohm_1(Y).
  rewrite (OhmE 1 pgroupY); apply: (subsetP (subset_gen _)).
  by rewrite inE expn1 (subsetP (mulgen_subl _ _)) //= cycle_id.
move: (Y1x); rewrite -(memJ_norm _ NY1xi) conjgM {NY1xi}.
rewrite (conjgE x) (commuteX i (commute_refl x)) mulgA mulVg mul1g.
move/(subsetP sY1_XZ _); case/imset2P=> y z; case/cycleP=> j ->{y} Zz xaeq.
have xjorda : x^+(j ^ #[a]) = x^+j.
  case/p_natP: (mem_p_elt pgroupA Aa) => n ->; rewrite (divn_eq (j^_) p).
  rewrite expgn_add mulnC expgn_mul (eqP xpeq1) exp1gn mul1g.
  rewrite {2}(divn_eq j p) expgn_add mulnC expgn_mul (eqP xpeq1) exp1gn mul1g.
  apply: congr1; elim: n => [|n ih]; first by rewrite expn0 expn1.
  rewrite expnSr expn_mulr -modn_exp ih modn_exp.
  case pdivj : (p %| j).
    case/dvdnP: pdivj=> k ->; rewrite -modn_exp modn_mull.
    by rewrite exp0n ?prime_gt0 // mod0n.
  rewrite -{1}(prednK (prime_gt0 primep)) expnS.
  have phip : phi p = p.-1.
    by rewrite -{1}(expn1 p) phi_pfactor //= expn0 muln1.
  rewrite -modn_mulmr -phip Euler 1?coprime_sym ?prime_coprime ?pdivj //.
  by rewrite modn_mulmr muln1.
have x1j : x *  x^-j \in Z.
  rewrite -{1}(conjg1 x) -(expg_order a) -xjorda {xjorda}.
  elim: #[a] => [|n ih].
    by rewrite expn0 !expg0 expg1 conjg1 mulgV group1.
  rewrite expgS conjgM xaeq conjMg conjXg expnSr expgn_mul -expVgn.
  have centzA := (centP (subsetP sACA _ (subsetP (Ohm_sub 1 A) z Zz))).
  rewrite [z^_]mulgA -centzA ?groupV ?groupX // mulgKV.
  rewrite -mulgA commuteX; last first.
    apply: commuteV; apply: commuteX; apply: commute_sym.
    by apply: (centP CZx).
  rewrite mulgA groupM // -expMgn ?groupX //.
  pose x1 := x ^ a ^+ n; pose x2 := x ^- (j ^n); rewrite -[x^_](mulgK x2 x1).
  apply: commuteV; apply: commuteX; apply: commute_sym.
  apply: commuteM; by [ apply: (centP CZx) | rewrite invgK; apply: commuteX].
rewrite ['C__(_|_)]CA_XZ_eq inE Aa /=; rewrite inE; apply/subsetP=> h.
case/imsetP=> y; case/cycleP=> k ->{y} ->{h}.
rewrite commgEr conjVg conjXg xaeq expMgn; last first.
  by apply: commute_sym; apply: commuteX; rewrite /commute (centP CZx).
rewrite invMg -mulgA groupM ?groupV ?groupX // -expVgn -expMgn.
  by rewrite groupX // (commute_sym _) //; apply: commuteV; apply: commuteX.
by apply: commute_sym; apply: commuteV; apply: commuteX.
Qed.

End Twenty_Three_dot_Fifteen.

Section Twenty_Three_dot_Sixteen.

Variables (gT : finGroupType) (G Z : {group gT}) (p : nat).
Hypotheses (oddp : odd p) (pgroupG : p.-group G).
Hypothesis (max_pabelem_normal_Z : [max Z | (Z <| G) && p.-abelem Z]).

Let X := ('Ohm_1('C_G(Z)))%G.

Lemma max_pabelem_normal_eq_Ohm1_cent : Z = X.
Proof.
case/maxgroupP: max_pabelem_normal_Z; case/andP=> nZG pabelemZ maxZ.
have sG_NZ := (normal_norm nZG).
case Geq1 : (G == 1%G).
  apply/eqP; rewrite [_ == _]eqEsubset (subset_trans (normal_sub nZG)) /=.
    rewrite (subset_trans (Ohm_sub _ _)) // (subset_trans (subsetIl _ _)) //.
    by rewrite (eqP Geq1) sub1set group1 //=.
  by rewrite (eqP Geq1) sub1set group1 //=.
case: (pgroup_pdiv pgroupG (negbT Geq1)) => primep _ _ {Geq1}.
case: (abelemP primep pabelemZ)=> abelZ expZp.
move: (abelZ); rewrite abelianE => sZ_CZ.
have nXG : X <| G.
  apply: (char_normal_trans (Ohm_char 1 'C_G(Z))).
  apply: (normalS _ _ (subcent_normal _ _)); first exact: subsetIl.
  by rewrite subsetI subxx (normal_norm nZG).
have sXG := (normal_sub nXG).
have sX_CZ : X \subset 'C(Z).
  by apply: (subset_trans (Ohm_sub _ _)); rewrite subsetIr.
have sZX : Z \subset X.
  rewrite /X /= (OhmE 1 (pgroupS (subsetIl _ _) pgroupG)).
  apply: (subset_trans _ (subset_gen _)); apply/subsetP=> x Zx.
  rewrite !inE expn1 expZp // eq_refl (subsetP (normal_sub nZG)) //= andbT.
  exact: (subsetP abelZ _ Zx).
have nZX := (normalS sZX (normal_sub nXG) nZG).
suffices expXp : exponent X %| p.
  have sXZ_G : X <*> Z \subset G by rewrite mulgen_subG (subset_trans sZX) sXG.
  have nZ_XZ := (normalS (mulgen_subr _ _) sXZ_G nZG).
  suffices Zeq : Z = (X <*> Z)%G.
    by apply/eqP; rewrite [_ == _]eqEsubset (normal_sub nZX) Zeq mulgen_subl.
  apply: (quotient_injG (normal_refl Z) nZ_XZ); symmetry.
  rewrite trivg_quotient quotient_mulgen ?(normal_norm nZX) //.
  apply: (nil_TI_Z (pgroup_nil (quotient_pgroup Z pgroupG))) => /=.
    by apply: quotient_normal.
  apply/eqP; rewrite eqEsubset sub1G andbT; apply/subsetP=> xbar.
  rewrite inE; case/andP; case/imsetP=> x; case/setIP => NZx Xx ->{xbar} /=.
  rewrite inE; case/andP=> _ CZ_xZ; rewrite inE; apply/eqP; apply: coset_id.
  suffices Zeq : <[x]> <*> Z = Z.
    by rewrite -Zeq (subsetP (mulgen_subl _ _)) ?cycle_id //.
  have sxZ_G : <[x]> <*> Z \subset G.
    by rewrite mulgen_subG (normal_sub nZG) gen_subG sub1set (subsetP sXG).
  have sZ_CxZ : Z \subset 'C(<[x]> <*> Z).
    rewrite cent_mulgen subsetI sZ_CZ centsC gen_subG sub1set.
    by rewrite (subsetP sX_CZ).
  have nZ_xZ : Z <| <[x]> <*> Z by apply: (normalS (mulgen_subr _ _) sxZ_G nZG).
  have nxZ_G : <[x]> <*> Z <| G.
    rewrite /normal sxZ_G -(quotientSGK sG_NZ) /=; last by apply: cents_norm.
    rewrite quotient_normG //= quotient_mulgen /= ?gen_subG ?sub1set //.
    rewrite quotient_cycle //; apply: cents_norm; rewrite centsC.
    by rewrite gen_subG sub1set.
  have abel_xZ : abelian (<[x]> <*> Z).
    rewrite abelianE cent_mulgen subsetI centsC cent_mulgen subsetI.
    rewrite cents_cycle ?commutexx //= gen_subG sub1set (subsetP sX_CZ) //=.
    rewrite centsC cent_mulgen subsetI sZ_CZ centsC gen_subG sub1set.
    by rewrite (subsetP sX_CZ) //=.
  apply: maxZ => /=; rewrite ?(normal_sub nZ_xZ) // nxZ_G /=.
  rewrite abelemE // abel_xZ /=.
  apply/exponentP=> g; rewrite /= norm_mulgenEl; last first.
    by apply: (subset_trans _ sG_NZ); rewrite gen_subG sub1set (subsetP sXG).
  case/mulsgP=> y z xy Zz ->; rewrite expMgn; last first.
    apply: (centsP sX_CZ) => //; apply: (subsetP _ _ xy).
    by rewrite gen_subG sub1set.
  rewrite (expZp _ Zz) mulg1.
  move/exponentP: expXp; apply; apply: (subsetP _ _ xy).
  by rewrite gen_subG sub1set.
pose normal_abelian := [pred A | ((A : {group gT}) <| G) && (abelian A)].
have normal_abelian_Z : normal_abelian Z.
  by rewrite /normal_abelian /= nZG abelZ.
case: (maxgroup_exists normal_abelian_Z) => A max_normal_abelian_A.
have SCNG_A : A \in 'SCN(G) by apply: (max_SCN pgroupG max_normal_abelian_A).
move: max_normal_abelian_A; case/maxgroupP; case/andP=> nAG abelA maxA sZA.
have pgroupA := (pgroupS (normal_sub nAG) pgroupG).
have OhmAeqZ : 'Ohm_1(A) = Z.
  apply: maxZ => /=; last by rewrite -(Ohm1_id pabelemZ) OhmS.
  by rewrite Ohm1_abelem // andbT (char_normal_trans (Ohm_char _ _) nAG).
pose W := 'C_G(A / 'Ohm_1(A) | 'Q).
have sX_CWOhmA : X \subset 'C('Ohm_1(A)) :&: W.
  rewrite subsetI /X /W -OhmAeqZ.
  rewrite (Ohm1_stab_Ohm1_SCN_series SCNG_A oddp pgroupG) andbT /=.
  by apply: (subset_trans (Ohm_sub _ _)); apply: subsetIr.
have {sX_CWOhmA} sX1_A : X^`(1) \subset A.
  rewrite (subset_trans _ (der1_stab_Ohm1_SCN_series SCNG_A)) //.
  by rewrite !derg1 commgSS.
case expX : (exponent X %| p) => //.
pose Uprop := [pred U | ('Ohm_1(U : {group gT}) == U) && ~~(exponent U %| p)].
have UpropX : Uprop X by rewrite inE expX /= Ohm_id eq_refl.
case: (mingroup_exists UpropX)=> U; case/mingroupP; case/andP.
case/eqP=> OhmUeqU; move/negP=> expU minU sUX.
have pgroupU := (pgroupS (subset_trans sUX sXG) pgroupG).
have existsxy : existsb x, existsb y,
  [&& (x \in U), (y \in U), x^+p == 1, y^+p == 1 & (x * y)^+p != 1].
  apply: negbNE; apply/negP; rewrite negb_exists; move/forallP => forall_hyp.
  pose UU := [set x \in U | x^+p==1].
  have group_set_UU : group_set UU.
    apply/group_setP; split; first by rewrite inE group1 exp1gn eq_refl.
    move=> x y; rewrite inE; case/andP=> Ux xp1.
    rewrite inE; case/andP=> Uy yp1; rewrite inE groupM //=.
    move: (forall_hyp x); rewrite negb_exists; move/forallP; move/(_ y).
    by rewrite Ux Uy xp1 yp1 /=; apply: negbNE.
  have sU_UU : U \subset UU.
    rewrite -OhmUeqU -(gen_set_id group_set_UU) (OhmE 1 pgroupU) gen_subG /=.
    by apply: sub_gen; apply/subsetP=> x; rewrite !inE expn1.
  apply: expU; apply/exponentP=> x Ux; move: (subsetP sU_UU x Ux).
  by rewrite inE; case/andP => _; case/eqP.
case/existsP: existsxy=> x; case/existsP=> y; case/and5P=> Ux Uy xp1 yp1.
move/negP=> xyp_ne1; pose XY := << [set x; y] >>.
have sXY_U : XY \subset U by rewrite gen_subG subUset !sub1set Ux Uy.
have pgroupXY := (pgroupS sXY_U pgroupU).
have XYx : x \in XY by rewrite mem_gen // !inE eq_refl.
have XYy : y \in XY by rewrite mem_gen // !inE eq_refl orbT.
have XYeqU : XY = U.
  apply: minU => //; rewrite inE; apply/andP; split.
    rewrite eqEsubset Ohm_sub /= gen_subG /= (OhmE 1 pgroupXY) sub_gen //.
    by rewrite expn1 subUset !sub1set !inE XYx XYy xp1 yp1.
  apply/negP; move/exponentP; move/(_ (x * y)); rewrite groupM //=.
  by move/(_ is_true_true)=> xyp1; apply: xyp_ne1; rewrite xyp1 eq_refl.
pose V := << class_support <[x]> U >>%G.
have xx_subnormal_U : <[x]> <|<| U.
  apply: (nilpotent_subnormal (pgroup_nil pgroupU)).
  by rewrite gen_subG sub1set.
case: (subnormalEsupport xx_subnormal_U) => /= [Ueq | VproperU].
  case: xyp_ne1; apply/eqP; rewrite expMgn ?(eqP xp1) ?(eqP yp1) ?mulg1 //.
  by move: Uy; rewrite -Ueq; case/cycleP=> i ->; apply: commuteX.
have sVU := proper_sub VproperU.
case expV : (exponent V %| p); last first.
  move: VproperU; rewrite properEneq; case/andP; case/negP; apply/eqP.
  apply: minU; rewrite /Uprop ?sVU //= expV andbT eqEsubset.
  rewrite Ohm_sub /= gen_subG /= (OhmE 1 (pgroupS sVU pgroupU)).
  apply: sub_gen; apply/subsetP=> v Vv; rewrite inE expn1 mem_gen ?Vv //=.
  move: Vv; rewrite class_supportEl; case/bigcupP=> z; case/cycleP=> j ->{z}.
  case/imsetP=> u Uu ->; rewrite -conjXg -expgn_mul mulnC expgn_mul.
  by rewrite (eqP xp1) exp1gn conj1g eq_refl.
have Zcommxy : [~ x, y] \in Z.
  rewrite -OhmAeqZ (OhmE 1 pgroupA) mem_gen // inE expn1.
  rewrite (subsetP sX1_A) /=; last first.
    by rewrite derg1 mem_gen //; apply: mem_imset2; rewrite (subsetP sUX).
  apply/eqP; apply: (exponentP expV); rewrite commgEl groupM ?groupV //.
    apply: (subsetP _ _ (cycle_id _)); apply: sub_gen.
    by apply: (sub_class_support U <[x]>).
  rewrite mem_gen // class_supportEl; apply/bigcupP.
  by exists x; [apply: cycle_id | apply: mem_imset].
move: xyp_ne1; case; rewrite expMg_Rmul -1?invg_comm; first last.
  - by apply: commuteV; apply: (centsP sX_CZ _ (subsetP sUX _ Ux) _ Zcommxy).
  by apply: commuteV; apply: (centsP sX_CZ _ (subsetP sUX _ Uy) _ Zcommxy).
rewrite (eqP xp1) (eqP yp1) !mul1g.
have p_dvd_bin : p %| bin p 2.
  rewrite prime_dvd_bin //=.
  move: (prime_gt1 primep); rewrite leq_eqVlt; case/orP => //.
  by move/eqP => p_eq; move: oddp; rewrite -p_eq.
case/dvdnP: p_dvd_bin=> i ->; rewrite mulnC expgn_mul expZp ?exp1gn ?eqxx //.
by rewrite groupV.
Qed.

End Twenty_Three_dot_Sixteen.

Lemma pgroup_odd_card: forall (gT : finGroupType) (P : {group gT}) p,
  p.-group P -> odd p -> odd #|P|.
Proof.
move=> gT P p pP oddp; rewrite odd_2'nat (pi_pnat pP) //; apply: contraL oddp.
by move/eqnP->.
Qed.

Lemma pgroup_proper_logn_card: forall (gT : finGroupType) (P Q : {group gT}) p,
  p.-group P -> Q \proper P -> logn p #|Q| < logn p #|P|.
Proof.
move=> gT P Q p pP; rewrite properEneq eqEcard andbC ltnNge; case/andP=> sQP.
rewrite sQP /= -{1}(part_pnat pP) -{1}(part_pnat (pgroupS sQP pP)) !p_part {pP}.
by apply: contra; case: p => [|p] lePQ; rewrite ?logn0 // leq_pexp2l.
Qed.

Lemma SCN3_empty_iff : forall (gT : finGroupType) (R : {group gT}) p,
  p.-group R -> odd p -> ('SCN_3(R) == set0) = ('r(R) <= 2).
Proof.
move=> gT R p pgroupR oddp; have oddR := (pgroup_odd_card pgroupR oddp).
case SCN3empty: ('SCN_3(R) == set0); last first.
  symmetry; apply/negP => lrR2; case/set0Pn: (negbT SCN3empty) => A.
  rewrite inE; case/andP; case/SCN_P=> nsAR _=> l2rR.
  by move: (leq_trans (leq_trans l2rR (rankS (normal_sub nsAR))) lrR2).
case cyclicR : (cyclic R); symmetry.
  move: cyclicR; rewrite (odd_pgroup_rank1_cyclic pgroupR oddR) -rank_pgroup //.
  by move/leq_trans; apply.
rewrite (rank_pgroup pgroupR) leqNgt; apply/negP; case/p_rank_geP => A.
rewrite !inE; case/andP; case/andP => sAR pabelemA logpA.
case: (four_dot_five_a pgroupR oddR (negbT cyclicR))=> Z nsZR; rewrite !inE.
case/andP; case/andP=> sZR pabelemZ; move/eqP=> logpZ.
have Zeq : Z = 'Ohm_1('C_R(Z))%G.
  apply: (max_pabelem_normal_eq_Ohm1_cent oddp pgroupR).
  apply/maxgroupP; split => [|H]; first by rewrite nsZR pabelemZ.
  case/andP=> nsHR pabelemH sZH; apply/eqP; rewrite eq_sym eqEproper sZH /=.
  apply/negP=> pZH.
  pose normal_abelian := [pred K | ((K : {group gT}) <| R) && (abelian K)].
  have naH : normal_abelian H
    by rewrite /normal_abelian /= nsHR (abelem_abelian pabelemH).
  case: (maxgroup_exists naH)=> K maxK sHK.
  move: (max_SCN pgroupR maxK) => SCN_K{maxK}.
  suffices: K \in 'SCN_3(R) by rewrite (eqP SCN3empty) inE.
  rewrite inE SCN_K /= -logpZ (leq_trans _ (rankS sHK)) //.
  rewrite (rank_abelem pabelemH).
  exact: (pgroup_proper_logn_card (pgroupS (normal_sub nsHR) pgroupR) pZH).
have nZA : A \subset 'N(Z) by apply: (subset_trans sAR (normal_norm nsZR)).
pose H:= 'C_A(Z); have sHA : H \subset A by apply: subsetIl.
have logpHge2: logn p #|H| >= 2.
  rewrite -(leq_add2r 1) addn1 /= -(eqP logpA) -(LaGrange sHA) logn_mul //.
  by rewrite leq_add2l (logn_quotient_cent_abelem nZA pabelemZ) // logpZ.
pose K := 'C_A(Z) <*> Z.
have cprodK : 'C_A(Z) \* Z = K by apply: cprodEgen; apply: subsetIr.
have sKR : K \subset R by rewrite mulgen_subG (subset_trans (subsetIl _ _)).
have sK_CRZ: K \subset 'C_R(Z).
  by rewrite subsetI sKR mulgen_subG subsetIr; apply: (abelem_abelian pabelemZ).
have pabelemK : p.-abelem K.
  by rewrite (cprod_abelem _ cprodK) pabelemZ andbT (abelemS (subsetIl _ _)).
suffices : 'r(Z) >= 3 by rewrite (rank_abelem pabelemZ) logpZ.
rewrite Zeq rank_Ohm1 (leq_trans _ (rankS sK_CRZ)) //.
case sZA : (Z \subset A).
  rewrite -(eqP logpA) -rank_abelem // rankS //.
  rewrite (subset_trans _ (mulgen_subl _ _)) // subsetI subxx /=.
  by rewrite (subset_trans (abelem_abelian pabelemA)) // centS.
rewrite (leq_ltn_trans logpHge2) // (rank_abelem pabelemK).
rewrite (pgroup_proper_logn_card) //=; first exact: (pgroupS _ pgroupR).
by rewrite properE (mulgen_subl _ _) /= mulgen_subG !subsetI sZA !andbF.
Qed.

End Section4.

(*
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Arith_base.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Le.
Require Export Lt.
Require Export Plus.
Require Export Gt.
Require Export Minus.
Require Export Mult.
Require Export Between.
Require Export Peano_dec.
Require Export Compare_dec.
Require Export Factorial.
Require Export EqNat.
Require Export Wf_nat.


(** BZ 4852 : unsatisfactory Extraction Implicit for a fixpoint defined via wf *)

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Omega.

Definition wfi_lt := well_founded_induction_type Wf_nat.lt_wf.

Tactic Notation "wfinduction" constr(term) "on" ne_hyp_list(Hs) "as" ident(H) :=
  let R := fresh in
  let E := fresh in
  remember term as R eqn:E;
  revert E; revert Hs;
  induction R as [R H] using wfi_lt;
  intros; subst R.

Hint Rewrite @app_comm_cons @app_assoc @app_length : app_rws.

Ltac solve_nat := autorewrite with app_rws in *; cbn in *; omega.

Notation "| x |" := (length x) (at level 11, no associativity, format "'|' x '|'").

Definition split_acc (ls : list nat) : forall acc1 acc2,
    (|acc1| = |acc2| \/ |acc1| = S (|acc2|)) ->
    { lss : list nat * list nat |
      let '(ls1, ls2) := lss in |ls1++ls2| = |ls++acc1++acc2| /\ (|ls1| = |ls2| \/ |ls1| = S (|ls2|))}.
Proof.
  induction ls as [|a ls IHls]. all:intros acc1 acc2 H.
  { exists (acc1, acc2). cbn. intuition reflexivity. }
  destruct (IHls (a::acc2) acc1) as [[ls1 ls2] (H1 & H2)]. 1:solve_nat.
  exists (ls1, ls2). cbn. intuition solve_nat.
Defined.

Definition join(ls : list nat) : { rls : list nat | |rls| = |ls| }.
Proof.
  wfinduction (|ls|) on ls as IH.
  case (split_acc ls [] []). 1:solve_nat.
  intros (ls1 & ls2) (H1 & H2).
  destruct ls2 as [|a ls2].
  - exists ls1. solve_nat.
  - unshelve eelim (IH _ _ ls1 eq_refl). 1:solve_nat. intros rls1 H3.
    unshelve eelim (IH _ _ ls2 eq_refl). 1:solve_nat. intros rls2 H4.
    exists (a :: rls1 ++ rls2). solve_nat.
Defined.

Require Import ExtrOcamlNatInt.
Extract Inlined Constant length => "List.length".
Extract Inlined Constant app => "List.append".

Extraction Inline wfi_lt.
Extraction Implicit wfi_lt [1 3].
Recursive Extraction join. (* was: Error: An implicit occurs after extraction *)
Extraction TestCompile join.


Require Import String List.
Import ListNotations.

From ASUB Require Import HOASParser monad.
Import HOASNotation.
Open Scope string.
Open Scope hoas_scope.

Definition test_5_3_sorts :=
  [ "sort0" := Sort
; "sort1" := Sort
; "sort2" := Sort
; "sort3" := Sort
; "sort4" := Sort
; "sort5" := Sort
; "sort6" := Sort
; "sort7" := Sort
; "sort8" := Sort
; "sort9" := Sort
; "sort10" := Sort
; "sort11" := Sort
; "sort12" := Sort
; "sort13" := Sort
; "sort14" := Sort ].

Definition test_5_3_ctors :=
  [ "cmix0" := "sort0" -> "sort1" -> "sort2" -> "sort3" -> "sort4" -> "sort0"
; "cmix1" := "sort0" -> "sort1" -> "sort2" -> "sort3" -> "sort4" -> "sort1"
; "cmix2" := "sort0" -> "sort1" -> "sort2" -> "sort3" -> "sort4" -> "sort2"
; "cmix3" := "sort0" -> "sort1" -> "sort2" -> "sort3" -> "sort4" -> "sort3"
; "cmix4" := "sort0" -> "sort1" -> "sort2" -> "sort3" -> "sort4" -> "sort4"
; "cmix5" := "sort5" -> "sort6" -> "sort7" -> "sort8" -> "sort9" -> "sort5"
; "cmix6" := "sort5" -> "sort6" -> "sort7" -> "sort8" -> "sort9" -> "sort6"
; "cmix7" := "sort5" -> "sort6" -> "sort7" -> "sort8" -> "sort9" -> "sort7"
; "cmix8" := "sort5" -> "sort6" -> "sort7" -> "sort8" -> "sort9" -> "sort8"
; "cmix9" := "sort5" -> "sort6" -> "sort7" -> "sort8" -> "sort9" -> "sort9"
; "cmix10" := "sort10" -> "sort11" -> "sort12" -> "sort13" -> "sort14" -> "sort10"
; "cmix11" := "sort10" -> "sort11" -> "sort12" -> "sort13" -> "sort14" -> "sort11"
; "cmix12" := "sort10" -> "sort11" -> "sort12" -> "sort13" -> "sort14" -> "sort12"
; "cmix13" := "sort10" -> "sort11" -> "sort12" -> "sort13" -> "sort14" -> "sort13"
; "cmix14" := "sort10" -> "sort11" -> "sort12" -> "sort13" -> "sort14" -> "sort14"
; "clam5" := {{"sort2" -> "sort3"}} -> "sort1"
; "clam10" := {{"sort9" -> "sort6"}} -> "sort7"
; "clam15" := {{"sort10" -> "sort11"}} -> "sort12" ].


(** * ∑-categories on morphisms - a category with the same objects, but a ∑ type for morphisms *)
Require Import HoTT.Tactics Types.Forall Types.Sigma Basics.Trunc.
Require Import Category.Core Functor.Core Category.Sigma.Core.
Require Functor.Composition.Core Functor.Identity.
Require Import Functor.Paths.
Import Functor.Identity.FunctorIdentityNotations.
Import Functor.Composition.Core.FunctorCompositionCoreNotations.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Notation sig_type := Overture.sig.
Local Notation pr1_type := Overture.pr1.

Local Open Scope morphism_scope.
Local Open Scope functor_scope.

Section sig_mor.
  Variable A : PreCategory.
  Variable Pmor : forall s d, morphism A s d -> Type.

  Local Notation mor s d := (sig_type (Pmor s d)).
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  (** ** Definition of [sig_mor]-precategory *)
  Definition sig_mor' : PreCategory.
  Proof.
    refine (@Build_PreCategory
              (object A)
              (fun s d => mor s d)
              (fun x => identity x)
              (fun s d d' m1 m2 => compose m1 m2)
              _
              _
              _
              _);
    assumption.
  Defined.

  (** ** First projection functor *)
  Definition pr1_mor : Functor sig_mor' A
    := Build_Functor
         sig_mor' A
         idmap
         (fun _ _ => @pr1_type _ _)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Definition sig_mor_as_sig : PreCategory.
  Proof.
    refine (@sig' A (fun _ => Unit) (fun s d => @Pmor (pr1_type s) (pr1_type d)) _ (fun _ => Pidentity _) (fun _ _ _ _ _ m1 m2 => Pcompose m1 m2) _ _ _);
    intros; trivial.
  Defined.

  Definition sig_functor_mor : Functor sig_mor_as_sig sig_mor'
    := Build_Functor
         sig_mor_as_sig sig_mor'
         (@pr1_type _ _)
         (fun _ _ => idmap)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Definition sig_functor_mor_inv : Functor sig_mor' sig_mor_as_sig
    := Build_Functor
         sig_mor' sig_mor_as_sig
         (fun x => exist _ x tt)
         (fun _ _ => idmap)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Local Open Scope functor_scope.

  Lemma sig_mor_eq `{Funext}
  : sig_functor_mor o sig_functor_mor_inv = 1
    /\ sig_functor_mor_inv o sig_functor_mor = 1.
  Proof.
    split; path_functor; simpl; trivial.
    refine (exist
              _
              (path_forall
                 _
                 _
                 (fun x
                  => match x as x return (x.1; tt) = x with
                       | (_; tt) => idpath
                     end))
              _).
    repeat (apply path_forall; intro).
    destruct_head @sig_type.
    destruct_head Unit.
    rewrite !transport_forall_constant.
    transport_path_forall_hammer.
    reflexivity.
  Qed.

  Definition sig_mor_compat : pr1_mor o sig_functor_mor = pr1'
    := idpath.
End sig_mor.

Arguments pr1_mor {A Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity}.

Section sig_mor_hProp.
  Variable A : PreCategory.
  Variable Pmor : forall s d, morphism A s d -> Type.

  Local Notation mor s d := (sig_type (Pmor s d)).
  Context `(HPmor : forall s d m, IsHProp (Pmor s d m)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Local Ltac t ex_tac :=
    intros;
    simpl;
    apply path_sigma_uncurried;
    simpl;
    ex_tac;
    apply path_ishprop.

  Let P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).
  Proof.
    abstract t ltac:(exists (associativity _ _ _ _ _ _ _ _))
      using P_associativity_on_morphisms_subproof.
  Defined.

  Let P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.
  Proof.
    clear P_associativity.
    abstract t ltac:(exists (left_identity _ _ _ _))
      using P_left_identity_on_morphisms_subproof.
  Defined.

  Let P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.
  Proof.
    clear P_associativity P_left_identity.
    abstract t ltac:(exists (right_identity _ _ _ _))
      using P_right_identity_on_morphisms_subproof.
  Defined.

  (** ** Definition of [sig_mor]-precategory *)
  Definition sig_mor : PreCategory
    := Eval cbv delta [P_associativity P_left_identity P_right_identity]
      in @sig_mor' A Pmor _ Pidentity Pcompose P_associativity P_left_identity P_right_identity.

  (** ** First projection functor *)
  Definition proj1_sig_mor : Functor sig_mor A
    := pr1_mor.
End sig_mor_hProp.

Arguments proj1_sig_mor {A Pmor HPmor Pidentity Pcompose}.


(*******************************************************************************************
* Formalization of lambda						                   *
*									                   *
* Brian Aydemir & Arthur Chargueraud, July 2007                                  	   *
* Flavio L. C. de Moura & Daniel L. Ventura, 2012                                          *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2014                  *
********************************************************************************************)

Set Implicit Arguments.
Require Import Metatheory LambdaES_Defs.
Require Import Rewriting LambdaES_Infra LambdaES_FV.
Require Import Arith List.

(** The beta rule of the lambda calculus. **)
Inductive rule_beta : pterm -> pterm -> Prop :=
   reg_rule_beta : forall (t u:pterm),  Lbody t -> Lterm u ->
     rule_beta (pterm_app (pterm_abs t) u) (t^^u).

Definition Beta t u := (L_contextual_closure rule_beta) t u.
Notation "t -->Beta u" := (Beta t u) (at level 66).

Definition Beta_trs t u := trans_closure Beta t u.
Notation "t -->Beta+ u" := (Beta_trs t u) (at level 66).

Definition Beta_str t u := star_closure Beta t u.
Notation "t -->Beta* u" := (Beta_str t u) (at level 66).

(* ********************************************************************** *)
(** Properties of the  beta reduction **)

Lemma Lterm_is_term: forall t, Lterm t -> term t.
Proof.
 intros. induction H; trivial.
 apply term_distribute_over_application; split; trivial.
 apply body_to_term_abs; trivial. unfold body.
 exists L; trivial.
Qed.

Lemma Lbody_is_body: forall t, Lbody t -> body t.
Proof.
 intros. unfold body. unfold Lbody in H.
 case H; clear H; intros L H. exists L.
 intros x H'. apply Lterm_is_term.
 apply H; trivial.
Qed.

Lemma subst_Lterm : forall t z u,
  Lterm u -> Lterm t -> Lterm ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*. apply_fresh Lterm_abs. rewrite* subst_open_var. apply Lterm_is_term; trivial.
Qed.
Hint Resolve subst_Lterm.

Lemma Lbody_open_term : forall t u, Lbody t -> Lterm u -> Lterm (t ^^ u).
Proof.
 intros. destruct H. case var_fresh with (L := x \u (fv t)).
 intros y Fr. rewrite* (@subst_intro y).
Qed.

Lemma not_Lbody_Sn: forall n, ~(Lbody (pterm_bvar (S n))).
Proof.
  intro n.
  intro H.
  elim H.
  intro L.
  intro H1.
  pick_fresh z.
  assert (z \notin L). auto.
  assert (Lterm (pterm_bvar (S n) ^ z)).
  apply H1.
  assumption.
  inversion H2.
Qed.

(* ********************************************************************** *)
(** Properties of reduction *)
(* Definition L_red_regular (R : pterm -> pterm -> Prop) := *)
(*   forall t t', R t t' -> Lterm t /\ Lterm t'. *)

(* Definition L_red_regular' (R : pterm -> pterm -> Prop) := *)
(*   forall t t', R t t' -> (Lterm t <-> Lterm t'). *)

(* Definition L_red_refl (R : pterm -> pterm -> Prop) := *)
(*   forall t, Lterm t -> R t t. *)

(* Definition L_red_in (R : pterm -> pterm -> Prop) := *)
(*   forall t x u u', Lterm t -> R u u' -> *)
(*   R ([x ~> u]t) ([x ~> u']t). *)

(* Definition L_red_out (R : pterm -> pterm -> Prop) := *)
(*   forall x u t t', Lterm u -> R t t' ->  *)
(*   R ([x~>u]t) ([x~>u]t'). *)

(* Lemma L_beta_regular : L_red_regular rule_beta. *)
(* Proof.  *)
(*  intros_all. induction H. split. *)
(*  apply Lterm_app; trivial. inversion H.  *)
(*  apply Lterm_abs with (L := x); trivial. *)
(*  apply Lbody_open_term; trivial.  *)
(* Qed. *)

(* Lemma L_beta_red_out : L_red_out rule_beta. *)
(* Proof. *)
(*  intros_all. destruct H0. simpl. *)
(*  assert (Q : term u). apply Lterm_is_term; trivial. *)
(*  rewrite subst_open; trivial. *)
(*  apply reg_rule_beta; trivial. *)
(*  unfold Lbody in *|-*. case H0; clear H0. *)
(*  intros L H0. exists (L \u {{x}}). *)
(*  intros x1 H2. apply notin_union in H2. destruct H2. *)
(*  apply notin_singleton in H3. rewrite subst_open_var; trivial. *)
(*  apply subst_Lterm; trivial. apply H0; trivial. Print subst_Lterm. *)
(*  apply subst_Lterm; trivial.  *)
(* Qed. *)

(* Lemma L_red_out_to_rename : forall (R : pterm -> pterm -> Prop), *)
(*   L_red_out R -> red_rename R.  *)
(* Proof. *)
(*   intros_all. *)
(*   rewrite* (@subst_intro x t).  *)
(*   rewrite* (@subst_intro x t'). *)
(* Qed. *)

(* Lemma beta_rename : red_rename rule_beta. *)
(* Proof. *)
(*  apply L_red_out_to_rename. *)
(*  apply L_beta_red_out. *)
(* Qed. *)

(* Lemma red_regular_Lctx : forall (R : pterm -> pterm -> Prop), *)
(*   L_red_regular R -> L_red_regular (L_contextual_closure R). *)
(* Proof. (*aqui*) *)
(*   intros_all. induction H0. *)
(*   apply H; trivial.  *)
(*   case IHL_contextual_closure. *)
(*   intros H2 H3. *)
(*   split; apply Lterm_app; trivial. split; apply Lterm_app; trivial. *)
(*   apply IHL_contextual_closure. apply IHL_contextual_closure. *)
(*   split; apply Lterm_abs with (L := L); apply H1; trivial. *)
(* Qed. *)

(* Lemma red_out_Lctx : forall (R : pterm -> pterm -> Prop), *)
(*   L_red_out R -> L_red_out (L_contextual_closure R). *)
(* Proof. *)
(*  intros_all. induction H1. *)
(*  apply L_redex. apply H; trivial. *)
(*  simpl. apply L_app_left; trivial. *)
(*  apply subst_Lterm; trivial. *)
(*  simpl. apply L_app_right; trivial. *)
(*  apply subst_Lterm; trivial. *)
(*  simpl. apply L_abs_in with (L := L \u {{x}}).  *)
(*  intros x0 Fr. apply notin_union in Fr. destruct Fr.  *)
(*  apply notin_singleton in H4. *)
(*  assert (Q: term u). apply Lterm_is_term; trivial. *)
(*  rewrite subst_open_var; trivial. *)
(*  rewrite subst_open_var; trivial. *)
(*  apply H2; trivial. *)
(* Qed. *)

Lemma Lbody_distribute_over_application : forall t u, Lbody (pterm_app t u) <-> Lbody t /\ Lbody u.
Proof.
  split.
    (* -> *)
    unfold body; unfold open; simpl ; intros; elim H; intros.
    split ; exists x; intros; specialize (H0 x0); specialize (H0 H1) ;
    inversion H0 ; assumption.
    (* <- *)
    intros. unfold body in H. unfold body. destruct H.
    destruct H. destruct H0.
    exists (x \u x0). intros.
    unfold open.  simpl. constructor.
      specialize (H x1) . auto.
      specialize (H0 x1) . auto.
Qed.

(** Reduction on lists **)

(* Lemma Lterm_mult_app : forall t lu, Lterm (t // lu) <-> Lterm t /\ (Lterm %% lu). *)
(* Proof. *)
(*  intros t lu. induction lu; simpl; split;  *)
(*  intro H;  try apply H; try split; trivial. *)
(*  inversion H. apply IHlu; trivial. *)
(*  inversion H. split; trivial. apply IHlu; trivial. *)
(*  destruct H. destruct H0. apply Lterm_app; trivial. *)
(*  apply IHlu; split; trivial. *)
(* Qed. *)

(* ********************************************************************** *)
(** Local closure for Lambda terms, recursively defined *)

Fixpoint Llc_at (k:nat) (t:pterm) {struct t} : Prop :=
  match t with
  | pterm_bvar i    => i < k
  | pterm_fvar x    => True
  | pterm_app t1 t2 => Llc_at k t1 /\ Llc_at k t2
  | pterm_abs t1    => Llc_at (S k) t1
  | pterm_sub t1 t2 => False
  | pterm_sub' t1 t2 => False
  end.

Definition Lterm' t := Llc_at 0 t.

Definition Lbody' t := Llc_at 1 t.

(* ********************************************************************** *)
(** Equivalence of [Lterm and [Lterm'] *)

Lemma Llc_rec_open_var_rec : forall x t k,
  Llc_at k (open_rec k x t) -> Llc_at (S k) t.
Proof.
  induction t; simpl; introv H; auto*.
  case_nat; simpls~.
Qed.

Lemma Lterm_to_Lterm' : forall t,
  Lterm t -> Lterm' t.
Proof.
  introv T. induction T; unfold Lterm'; simple~.
  pick_fresh x. apply~ (@Llc_rec_open_var_rec (pterm_fvar x)). apply~ H0.
Qed.

Lemma Llc_at_open_var_rec : forall x t k,
  Llc_at (S k) t -> Llc_at k (open_rec k (pterm_fvar x) t).
Proof.
  induction t; simpl; introv H; auto*.
  case_nat; simpls~.
  unfold lt in *|-.
  apply le_lt_or_eq in H.
  case H.
  intro H1. apply lt_S_n in H1; trivial.
  intro H1. assert (n = k).
  auto. assert (k = n). auto.
  contradiction.
Qed.

Lemma Lterm'_to_Lterm : forall t,
  Lterm' t -> Lterm t.
Proof.
  introv. unfold Lterm'.
  apply pterm_size_induction with (t := t).
  (* bvar *)
  simpl. intros.
  assert (~ n < 0). auto with arith.
  contradiction.
  (* fvar *)
  simpl. intros.
  apply Lterm_var.
  (* abs *)
  simpl. intros.
  apply Lterm_abs with (L := fv t1).
  intros x Fr.
  apply (H t1); trivial.
  unfold open.
  apply Llc_at_open_var_rec; trivial.
  (* app *)
  intros t1 t2 IHt1 IHt2 H.
  simpl in H. apply Lterm_app.
  apply IHt1; apply H.
  apply IHt2; apply H.
  (* sub *)
  intros. simpl in H1. contradiction.
  (* sub' *)
  intros. simpl in H1. contradiction.
Qed.

Lemma Lterm_eq_Lterm' : forall t, Lterm t <-> Lterm' t.
Proof. intros. split. apply Lterm_to_Lterm'. apply Lterm'_to_Lterm. Qed.

(* ********************************************************************** *)
(** Equivalence of [Lbody] and [Lbody'] *)

Lemma Lbody_to_Lbody' : forall t,
  Lbody t -> Lbody' t.
Proof.
  introv [L H]. pick_fresh x.
  applys (@Llc_rec_open_var_rec (pterm_fvar x)).
  apply Lterm_to_Lterm'. apply~ H.
Qed.

Lemma Lbody'_to_Lbody : forall t,
  Lbody' t -> Lbody t.
Proof.
  introv B. exists ({}:vars). introv F.
  apply Lterm'_to_Lterm. apply~ Llc_at_open_var_rec.
Qed.

Lemma Lbody_eq_Lbody' : forall t, Lbody t <-> Lbody' t.
Proof. intros. split. apply Lbody_to_Lbody'. apply Lbody'_to_Lbody. Qed.

(* ********************************************************************** *)
(** Weakening property of [Llc_at] *)

Lemma Llc_at_weaken_ind : forall k1 k2 t,
  Llc_at k1 t -> k1 <= k2 -> Llc_at k2 t.
Proof. introv. gen k1 k2. induction t; simpl; introv T Lt; auto*.
       omega. apply (IHt (S k1) (S k2)); trivial; try omega.
Qed.

Lemma Llc_at_weaken : forall k t,
  Lterm' t -> Llc_at k t.
Proof. introv H. apply~ (@Llc_at_weaken_ind 0). omega. Qed.

Lemma trs_Lctx_app_left : forall R t t' u, Lterm u ->
                       trans_closure (L_contextual_closure R) t t' ->
                       trans_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t' u).
Proof.
 intros. induction H0. apply one_step_reduction.
 apply L_app_left; trivial.
 apply transitive_reduction with (u := pterm_app u0 u); trivial.
 apply L_app_left; trivial.
Qed.

Lemma str_Lctx_app_left : forall R t t' u, Lterm u ->
                       star_closure (L_contextual_closure R) t t' ->
                       star_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t' u).
Proof.
 intros. induction H0. apply reflexive_reduction. apply star_trans_reduction.
 apply trs_Lctx_app_left; trivial.
Qed.

Lemma trs_Lctx_app_right : forall R t u u', Lterm t ->
                       trans_closure (L_contextual_closure R) u u' ->
                       trans_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t u').
Proof.
 intros. induction H0. apply one_step_reduction.
 apply L_app_right; trivial.
 apply transitive_reduction with (u := pterm_app t u); trivial.
 apply L_app_right; trivial.
Qed.

Lemma str_Lctx_app_right : forall R t u u', Lterm t ->
                       star_closure (L_contextual_closure R) u u' ->
                       star_closure (L_contextual_closure R) (pterm_app t u) (pterm_app t u').
Proof.
 intros. induction H0. apply reflexive_reduction. apply star_trans_reduction.
 apply trs_Lctx_app_right; trivial.
Qed.

(* Lemma Lctx_abs_in_close : forall x R L t t', L_red_regular R -> L_red_out R -> *)
(*                          L_contextual_closure R t t' -> x \notin L -> *)
(*                          L_contextual_closure R (pterm_abs (close t x)) (pterm_abs (close t' x)). *)
(* Proof. *)
(*  intros x R L t t' H0 H1 H2 Fr. *)
(*  apply L_abs_in with (L := L). intros z Fr'.  *)
(*  apply red_out_Lctx in H1. apply L_red_out_to_rename in H1. *)
(*  apply H1 with (x := x). apply fv_close'. apply fv_close'. *)
(*  replace (close t x ^ x) with t. replace (close t' x ^ x) with t'; trivial. *)
(*  apply open_close_var. apply red_regular_Lctx in H0. apply H0 in H2. apply Lterm_is_term. apply H2. *)
(*  apply open_close_var. apply red_regular_Lctx in H0. apply H0 in H2. apply Lterm_is_term. apply H2. *)
(* Qed. *)

(* Lemma trs_Lctx_abs_in : forall R L t t', L_red_regular R -> L_red_out R ->  *)
(*                        (forall x, x \notin L ->  trans_closure (L_contextual_closure R) (t ^ x) (t' ^ x)) -> trans_closure (L_contextual_closure R) (pterm_abs t) (pterm_abs t'). *)
(* Proof. *)
(*  intros R L t t' H0 H1 H2.  case var_fresh with (L := L \u (fv t) \u (fv t')). intros x Fr. *)
(*  apply notin_union in Fr. destruct Fr. apply notin_union in H. destruct H. *)
(*  assert (Q: trans_closure (L_contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2. *)
(*  gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht0 Ht1. *)
(*  replace t with (close t0 x). replace t' with (close t1 x). clear Ht0 Ht1. induction Q. *)
(*  apply one_step_reduction. apply Lctx_abs_in_close with (L := L); trivial. *)
(*  apply transitive_reduction with (u := pterm_abs (close u x)); trivial. *)
(*  apply Lctx_abs_in_close with (L := L); trivial. *)
(*  rewrite Ht0. rewrite <- close_open_term; trivial.  *)
(*  rewrite Ht1. rewrite <- close_open_term; trivial. *)
(* Qed. *)

(* Lemma str_Lctx_abs_in : forall R L t t', L_red_regular R -> L_red_out R ->  *)
(*                        (forall x, x \notin L ->  star_closure (L_contextual_closure R) (t ^ x) (t' ^ x)) -> star_closure (L_contextual_closure R) (pterm_abs t) (pterm_abs t'). *)
(* Proof. *)
(*  intros R L t t' H0 H1 H2.  case var_fresh with (L := L \u (fv t) \u (fv t')). intros x Fr. *)
(*  apply notin_union in Fr. destruct Fr. apply notin_union in H. destruct H. *)
(*  assert (Q: star_closure (L_contextual_closure R) (t ^ x) (t' ^ x)). apply H2; trivial. clear H2. *)
(*  gen_eq t0 : (t ^ x). gen_eq t1 : (t' ^ x). intros Ht0 Ht1. *)
(*  replace t with (close t0 x). replace t' with (close t1 x). clear Ht0 Ht1. induction Q. *)
(*  apply reflexive_reduction. apply star_trans_reduction. induction H2. *)
(*  apply one_step_reduction. apply Lctx_abs_in_close with (L := L); trivial. *)
(*  apply transitive_reduction with (u := pterm_abs (close u x)); trivial. *)
(*  apply Lctx_abs_in_close with (L := L); trivial. *)
(*  rewrite Ht0. rewrite <- close_open_term; trivial.  *)
(*  rewrite Ht1. rewrite <- close_open_term; trivial. *)
(* Qed. *)

(******)

Lemma left_trans_app_Beta: forall t u v,  Lterm t  ->
      u -->Beta+ v -> pterm_app u t -->Beta+ pterm_app v t.
Proof.
  intros.
  apply trs_Lctx_app_left; assumption.
Qed.

Lemma left_star_app_Beta: forall t u v,  Lterm t  ->
      u -->Beta* v -> pterm_app u t -->Beta* pterm_app v t.
Proof.
  intros; apply str_Lctx_app_left; trivial.
Qed.

Lemma right_trans_app_Beta: forall t u v,  Lterm t  ->
      u -->Beta+ v -> pterm_app t u -->Beta+ pterm_app t v.
Proof.
   intros; apply trs_Lctx_app_right; trivial.
Qed.

Lemma right_star_app_Beta: forall t u v,  Lterm t  ->
      u -->Beta* v -> pterm_app t u -->Beta* pterm_app t v.
Proof.
   intros; apply str_Lctx_app_right; trivial.
Qed.

Lemma in_trans_abs_Beta: forall L u v,  (forall x, x \notin L -> (u ^ x) -->Beta+ (v ^ x)) ->
  ((pterm_abs u) -->Beta+ (pterm_abs v)).
Proof.
(*  intros; apply trs_Lctx_abs_in with (L := L); trivial. *)
(*  apply L_beta_regular. *)
(*  apply L_beta_red_out. *)
(* Qed. *) Admitted.

Lemma in_star_abs_Beta: forall L u v,  (forall x, x \notin L -> (u ^ x) -->Beta* (v ^ x)) ->
  ((pterm_abs u) -->Beta* (pterm_abs v)).
Proof.
(*  intros; apply str_Lctx_abs_in with (L := L); trivial. *)
(*  apply L_beta_regular. *)
(*  apply L_beta_red_out. *)
  (* Qed. *)
Admitted.

(** Induction Principles *)

Lemma Lbody_size_induction :
 forall P : pterm -> Prop,
 (P (pterm_bvar 0)) ->
 (forall x, P (pterm_fvar x)) ->
 (forall t1, (Llc_at 2 t1) ->
    (forall t2 x, x \notin fv t2 -> pterm_size t2 = pterm_size t1 ->
    Lbody (open_rec 1 (pterm_fvar x) t2) -> P (open_rec 1 (pterm_fvar x) t2)) -> P (pterm_abs t1)) ->
 (forall t1 t2, Lbody t1 -> Lbody t2 -> P t1 -> P t2 -> P (pterm_app t1 t2)) ->
 (forall t, Lbody t -> P t).
Proof.
  intros P Ha Hb Hc Hd t.
  gen_eq n: (pterm_size t). gen t.
  induction n using peano_induction.
  introv Eq B. subst. destruct t.
     (* bvar *)
     generalize B; clear B; case n.
     intro B; apply Ha.
     intros n' H'; apply not_Lbody_Sn in H'; contradiction.
     (* fvar *)
     apply Hb.
     (* app *)
     apply~ Hd;
     apply Lbody_distribute_over_application in B.
     apply B. apply B.
     apply~ H. simpl; omega.
     apply B. apply~ H. simpl; omega.
     apply B.
     (* abs *)
     apply* Hc.
     apply Lbody_to_Lbody' in B.
     unfold Lbody' in B. simpl in B; trivial.
     introv Fr Eq.
     apply~ H. rewrite <- pterm_size_open_var. simpl. omega.
     (* sub *)
     apply Lbody_to_Lbody' in B. unfold Lbody' in B. simpl in B.
     contradiction.
     (* sub' *)
     apply Lbody_to_Lbody' in B. unfold Lbody' in B. simpl in B.
     contradiction.
Qed.

Lemma Lterm_size_induction :
 forall P : pterm -> Prop,
 (forall x, P (pterm_fvar x)) ->
 (forall t1 t2,
    Lterm t1 -> P t1 -> Lterm t2 -> P t2 -> P (pterm_app t1 t2)) ->
 (forall t1,
    Lbody t1 ->
    (forall t2 x, x \notin fv t2 -> pterm_size t2 = pterm_size t1 ->
      Lterm (t2 ^ x) -> P (t2 ^ x)) ->
    P (pterm_abs t1)) ->
 (forall t, Lterm t -> P t).
Proof.
  intros P Ha Hb Hc t.
  gen_eq n: (pterm_size t). gen t.
  induction n using peano_induction.
  introv Eq T. subst. inverts T.
     apply Ha.
     (* app *)
     apply~ Hb. apply~ H. simpl; omega. apply~ H. simpl; omega.
     (* abs *)
     apply* Hc.
       introv. exists L. trivial.
       introv Fr Eq T.
       apply~ H. unfold open.
      rewrite <- pterm_size_open_var. simpl. omega.
 Qed.

Lemma Lterm_size_induction2 :
 forall P : pterm -> Prop,
 (forall x l, (forall u, In u l -> (Lterm u /\ P u)) -> P ((pterm_fvar x) // l)) ->
 (forall t1 l, (forall u, In u l -> (Lterm u /\ P u)) -> Lbody t1 ->
  (forall t2 x, x \notin fv t2 -> pterm_size t2 = pterm_size t1 -> Lterm (t2 ^ x) -> P (t2 ^ x)) ->
      P ((pterm_abs t1) // l)) ->
 (forall l t, (forall u, In u l -> (Lterm u /\ P u)) -> Lterm t -> P (t // l)).
Proof.
 intros. generalize H2.  intro T. generalize l H1 H2. clear l H1 H2.
 apply Lterm_size_induction with (t := t); trivial; intros.
 apply H; trivial.
 replace (pterm_app t1 t2 // l) with (t1 // l ++ (t2 :: nil)).
 apply H2. intros. apply in_app_iff in H7. destruct H7.
 apply H5; trivial. simpl in H7. destruct H7; try contradiction.
 rewrite <- H7. clear H7. inversion H6. split; trivial.
 assert (Q : P (t2 // nil)).
   apply H4; simpl; trivial; intros. contradiction.
 simpl in Q. trivial. trivial.
(*  rewrite mult_app_append. trivial. *)
(*  apply H0; trivial. intros. *)
(*  assert (Q : P (t2 ^ x // nil)). *)
(*    apply H2; simpl; trivial; intros. contradiction. *)
(*  simpl in Q. trivial. *)
(* Qed. *)
Admitted.

Lemma Lterm_size_induction3 :
 forall P : pterm -> Prop,
 (forall x l, (forall u, In u l -> (Lterm u /\ P u)) -> P ((pterm_fvar x) // l)) ->
 (forall t1 l, (forall u, In u l -> (Lterm u /\ P u)) -> Lbody t1 ->
  (forall t2 x, x \notin fv t2 -> pterm_size t2 = pterm_size t1 -> Lterm (t2 ^ x) -> P (t2 ^ x)) ->
      P ((pterm_abs t1) // l)) ->
 (forall t, Lterm t -> P t).
Proof.
 intros. replace t with (t // nil).
 apply Lterm_size_induction2; simpl; trivial.
 intros; contradiction.
 simpl. trivial.
Qed.

Lemma Llc_at_bswap : forall n k t, S k < n -> Llc_at n t -> Llc_at n (bswap_rec k t).
Proof.
 intros n k t.
 generalize n k; clear n k.
 induction t.
 (* bvar *)
 intros n' k H0 H1. simpl in H1.
 unfolds bswap_rec.
 case (k === n). intro H2.
 rewrite H2. simpl. omega. intro H2.
 case (S k === n). intro H3. simpl. omega. intro H3.
 simpl. trivial.
 (* fvar *)
 intros n k H0 H1. simpl in *|-*. trivial.
 (* app *)
 intros n k H0 H1. simpl in *|-*. destruct H1. split.
 apply IHt1; trivial. apply IHt2; trivial.
 (* abs *)
 intros n k H0 H1. simpl in *|-*.
 apply IHt; try omega; trivial.
 (* sub *)
 intros n k H0 H1. simpl in *|-*. contradiction.
 (* sub' *)
 intros n k H0 H1. simpl in *|-*. contradiction.
Qed.

Lemma Llc_at_open : forall n t u, Lterm u -> (Llc_at (S n) t <-> Llc_at n (open_rec n u t)).
Proof.
 intros n t u T. split.
(* -> *)
 generalize n; clear n.
 induction t.
 (* bvar *)
 intros n' H0. unfolds open_rec.
 case (n' === n). intro H1.
 rewrite H1 in H0. rewrite H1. simpl in *|-*.
 apply Lterm_to_Lterm' in T. unfold Lterm' in T.
 apply Llc_at_weaken_ind with (k1 := 0); try omega; trivial.
 intro H1. simpl in *|-*. omega.
 (* fvar *)
 intros n H. simpl. trivial.
 (* app *)
 intros n H. simpl in *|-*.
 case H; clear H; intros Ht1 Ht2; split.
 apply (IHt1 n Ht1).
 apply (IHt2 n Ht2).
 (* abs *)
 intros n H. simpl in *|-*.
 apply (IHt (S n) H).
 (* sub *)
 intros n H. simpl in *|-*. contradiction.
 (* sub' *)
 intros n H. simpl in *|-*. contradiction.
(* <- *)
 generalize n; clear n.
 induction t.
 (* bvar *)
 intros n' H0. simpl in H0.
 case (n' === n) in H0. simpl. omega.
 simpl in *|-*. omega.
 (* fvar *)
 simpl. trivial.
 (* app *)
 simpl in *|-*. intros n H.
 case H; clear H; intros Ht1 Ht2; split.
 apply (IHt1 n Ht1).
 apply (IHt2 n Ht2).
 (* abs *)
 simpl in *|-*. intros n H.
 apply (IHt (S n) H).
 (* sub *)
 simpl in *|-*. intros n H. contradiction.
 (* sub' *)
 simpl in *|-*. intros n H. contradiction.
Qed.

(* Lemma L_SN_app : forall n R t u, L_red_regular R ->  Lterm t -> Lterm u ->  *)
(*                SN_ind n (L_contextual_closure R) (pterm_app t u) -> *)
(*                SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) u. *)
(*  Proof. *)
(*  intros n R t u Reg.  *)
(*  generalize t u; clear t u.   *)
(*  induction n.  intros. split; rewrite <- NF_eq_SN0 in *|-*; unfold NF in *|-*.  *)
(*  intros t' H'. apply (H1 (pterm_app t' u)). apply L_app_left; trivial. *)
(*  intros u' H'. apply (H1 (pterm_app t u')). apply L_app_right; trivial. *)
(*  intros t u Tt Tu H. destruct H. split.  *)
(*  apply SN_intro. intros t' H'. exists n. split; try omega.  *)
(*  apply IHn with (t := t') (u := u); trivial. apply red_regular_Lctx in Reg. *)
(*  apply Reg in H'. apply H'. case (H (pterm_app t' u)). apply L_app_left; trivial.  *)
(*  intros k H''. apply WSN with (k := k). omega. apply H''. *)
(*  apply SN_intro. intros u' H'. exists n. split; try omega.  *)
(*  apply IHn with (t := t) (u := u'); trivial. apply red_regular_Lctx in Reg. *)
(*  apply Reg in H'. apply H'. case (H (pterm_app t u')). apply L_app_right; trivial.  *)
(*  intros k H''. apply WSN with (k := k). omega. apply H''. *)
(* Qed.  *)

(* Lemma L_SN_abs : forall x n R t, L_red_regular R -> L_red_out R ->  *)
(*                SN_ind n (L_contextual_closure R) (pterm_abs t) -> *)
(*                x \notin (fv t) -> SN_ind n (L_contextual_closure R) (t ^ x). *)
(* Proof. *)
(*  intros x n R t Reg Out. *)
(*  generalize t; clear t. *)
(*  apply red_regular_Lctx in Reg.  *)
(*  apply red_out_Lctx in Out.  *)
(*  apply L_red_out_to_rename in Out. *)
(*  induction n. intros.  *)
(*  apply SN0_to_NF in H.  *)
(*  apply NF_to_SN0; unfold NF in *|-*. *)
(*  intros t' H'. gen_eq t0 : (close t' x). intro H1. *)
(*  replace t' with (t0 ^ x) in H'. *)
(*  assert (Q: L_contextual_closure R (pterm_abs t) (pterm_abs t0)). *)
(*     apply L_abs_in with (L := {{x}}). intros z H2.  *)
(*     apply notin_singleton in H2. apply Out with (x := x); trivial. *)
(*     rewrite H1. apply fv_close'. *)
(*  assert (Q': ~ L_contextual_closure R (pterm_abs t) (pterm_abs t0)). *)
(*     apply H. *)
(*  contradiction. rewrite H1. rewrite open_close_var with (x := x). *)
(*  reflexivity. apply Reg in H'. apply Lterm_is_term. apply H'. *)
(*  intros. destruct H. apply SN_intro. *)
(*  intros. exists n. split; try omega. *)
(*  gen_eq t0 : (close t' x). intro H2. *)
(*  replace t' with (t0 ^ x). replace t' with (t0 ^ x) in H1. *)
(*  apply IHn; trivial. case (H (pterm_abs t0)); trivial. *)
(*  apply L_abs_in with (L := {{x}}). *)
(*  intros z H3. apply notin_singleton in H3.  *)
(*  apply Out with (x := x); trivial. *)
(*  rewrite H2. apply fv_close'. *)
(*  intros k H3. apply WSN with (k := k); try omega. *)
(*  apply H3. rewrite H2. apply fv_close'. *)
(*  rewrite H2. rewrite open_close_var with (x := x). *)
(*  reflexivity. apply Lterm_is_term. apply Reg in H1. apply H1. *)
(*  rewrite H2. rewrite open_close_var with (x := x). *)
(*  reflexivity. apply Lterm_is_term. apply Reg in H1. apply H1.  *)
(* Qed. *)

(* Lemma L_SN_mult_app : forall n R t l, L_red_regular R ->  Lterm t -> Lterm %% l ->  *)
(*                SN_ind n (L_contextual_closure R) (t // l) -> *)
(*                SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) %% l. *)
(* Proof. *)
(*  intros n R t l Reg. generalize n t; clear n t. *)
(*  induction l; simpl. intros n t T H0 H. split; trivial. *)
(*  intros n t T H0 H. destruct H0. apply L_SN_app in H; trivial. destruct H. *)
(*  assert (Q : SN_ind n (L_contextual_closure R) t /\ SN_ind n (L_contextual_closure R) %% l).  *)
(*   apply IHl; trivial. *)
(*  clear IHl. destruct Q. split; trivial. split; trivial. *)
(*  rewrite Lterm_mult_app. split; trivial.  *)
(* Qed.  *)

Lemma Lctx_red_h_mult_app : forall R t t' lu, Lterm %% lu -> (L_contextual_closure R) t t' -> (L_contextual_closure R) (t // lu) (t' // lu).
Proof.
 intros R t t' lu Tlu H. induction lu; simpl in *|-*; trivial.
 destruct Tlu. apply L_app_left; trivial.
 apply IHlu; trivial.
Qed.

(* Lemma Lctx_red_t_mult_app : forall R t lu lu', Lterm t -> Lterm %% lu -> R_list (L_contextual_closure R) lu lu' -> (L_contextual_closure R) (t // lu) (t // lu'). *)
(* Proof. *)
(*  intros R t lu lu' Tt Tlu H. unfold R_list in H. *)
(*  case H; clear H; intros t0 H. *)
(*  case H; clear H; intros t1 H. *)
(*  case H; clear H; intros l0 H. *)
(*  case H; clear H; intros l1 H. *)
(*  destruct H. destruct H0.  *)
(*  rewrite H. rewrite H0. rewrite H in Tlu.  *)
(*  clear H H0. induction l0; simpl. destruct l1; simpl.  *)
(*  apply L_app_right; trivial. *)
(*  apply L_app_right; trivial.  *)
(*  simpl in Tlu. apply Lterm_app. rewrite Lterm_mult_app.  *)
(*  destruct Tlu. destruct H0. *)
(*  split; trivial. apply Tlu. *)
(*  simpl in Tlu. destruct Tlu.  *)
(*  apply L_app_left; trivial. *)
(*  apply IHl0; trivial.  *)
(* Qed. *)

(** Inductive Characterisation of NF Beta **)

(* Lemma NF_ind_eq_Beta : forall t, Lterm t -> (NF_ind Beta t <-> NF Beta t). *)
(* Proof. *)
(*  intros. split.  *)
(*  intro H'. induction H'. *)
(*  induction l; simpl in *|-*. *)
(*  intros t H2. inversion H2. inversion H3. *)
(*  intros t H2. inversion H2. inversion H3. *)
(*  case eqdec_nil with (l := l). intro. rewrite H11 in H6. simpl in H6. *)
(*  generalize H6. discriminate. *)
(*  intro H11. case  m_app_eq_app with (t := (pterm_fvar x)) (lu := l); trivial. *)
(*  intros t2 H12. case H12; clear H12; intros t3 H12.  *)
(*  generalize H6. rewrite H12. discriminate. *)
(*  unfold NF in IHl. apply IHl with (t' := t'). inversion H. trivial. *)
(*  intros u' H'. apply H0. right; trivial. *)
(*  intros u' H8 Tu' t1.  apply H1; trivial. right; trivial. trivial. *)
(*  unfold NF in H1. apply H1 with (u := a) (t' := u'). *)
(*  left; trivial. inversion H; trivial. trivial. *)
(*  intros t' H2. inversion H2. inversion H3. inversion H. *)
(*  unfold NF in H1. case var_fresh with (L := L \u L0 \u L1). *)
(*  intros x Fr. apply notin_union in Fr. destruct Fr. apply notin_union in H8; destruct H8. *)
(*  apply H1 with (x := x) (t' := t'0 ^x); trivial.  *)
(*  apply H7; trivial. apply H4; trivial.  *)
(*  assert (Reg : L_red_regular rule_beta). apply L_beta_regular. *)
(*  assert (Out : L_red_out rule_beta). apply L_beta_red_out. *)
(*  apply Lterm_size_induction3 with (t := t); trivial; intros. *)
(*  apply NF_ind_app; intros. *)
(*  apply H0; trivial. rewrite NF_eq_SN0 in H1|-*. apply L_SN_mult_app in H1; trivial. *)
(*  destruct H1. rewrite <- P_list_eq with (P := SN_ind 0 (L_contextual_closure rule_beta)) in H3. *)
(*  apply H3; trivial.  rewrite <- P_list_eq with (P := Lterm). intros.  *)
(*  apply H0; trivial. case eqdec_nil with (l := l); intro. *)
(*  rewrite H4 in *|-*. simpl in *|-*. unfold Lbody in H1. *)
(*  case H1; clear H1; intros L H1. apply NF_ind_abs with (L := fv t1 \u L). *)
(*  intros x Fr. apply notin_union in Fr. destruct Fr. apply H2; trivial. *)
(*  apply H1; trivial. rewrite NF_eq_SN0 in H3. apply L_SN_abs with (x := x) in H3; trivial. *)
(*  rewrite <- NF_eq_SN0 in H3. trivial.  *)
(*  apply False_ind. case not_nil_append with (l := l); trivial. *)
(*  intros t0 H5. case H5; clear H5; intros l' H5.  rewrite H5 in H3. *)
(*  rewrite <- mult_app_append in H3. unfold NF in H3. apply (H3 ((t1 ^^ t0) // l')). *)
(*  apply Lctx_red_h_mult_app. rewrite <- P_list_eq with (P := Lterm). intros. *)
(*  apply H0. rewrite H5. apply in_or_app. left; trivial. *)
(*  apply L_redex. apply reg_rule_beta; trivial. unfold body. unfold Lbody in H1. *)
(*  case H1; clear H1; intros L H1. apply H0. rewrite H5. *)
(*  apply in_or_app. right. simpl. left; trivial. *)
(* Qed. *)

(** Inductive Characterisation of SN Beta **)

 Inductive SN_Beta : pterm -> Prop :=

  | sn_beta_var : forall (x : var) (lu : list pterm),

                      (forall u, (In u lu) -> SN_Beta u) ->
(*-------------------------------------------------------------------------*)
                         SN_Beta ((pterm_fvar x) // lu)

  | sn_beta_abs : forall L (u : pterm),

                      (forall x, x \notin L -> SN_Beta (u ^ x))->
(*-------------------------------------------------------------------------*)
                             SN_Beta (pterm_abs u)

  | sn_beta_meta_sub : forall  (t u : pterm) (lv : list pterm),

                          SN_Beta u -> SN_Beta ((t ^^ u) // lv) ->
(*-------------------------------------------------------------------------*)
                    SN_Beta ((pterm_app (pterm_abs t)  u) // lv)
.

Theorem SN_Beta_prop : forall t, Lterm t -> SN Beta t -> SN_Beta t.
Proof.
 intros t T.

 intro H. case H; clear H; intros n H.
 generalize t T H; clear T t H. induction n; intros.
(*  rewrite <- NF_eq_SN0 in H. rewrite <- NF_ind_eq_Beta in H; trivial. *)
(*  induction H. apply sn_beta_var; intros. *)
(*  apply H0; trivial. rewrite Lterm_mult_app in T. destruct T. *)
(*  rewrite <- P_list_eq in H3. apply H3; trivial. *)
(*  inversion T; clear T. apply sn_beta_abs with (L := L \u L0); intros. *)
(*  apply notin_union in H3. destruct H3. apply H0; trivial. apply H2; trivial. *)
(*  assert (Reg : L_red_regular rule_beta); try apply L_beta_regular. *)
(*  assert (Out : L_red_out rule_beta); try apply  L_beta_red_out. *)
(*  generalize H; clear H. apply Lterm_size_induction3 with (t := t); intros; trivial.  *)
(*  apply sn_beta_var; intros. *)
(*  assert (Q : SN_ind (S n) Beta  %% l).  *)
(*     apply L_SN_mult_app in H0; trivial. apply H0.  *)
(*     rewrite <- P_list_eq with (P := Lterm).       *)
(*     intros u' H2. apply H; trivial.   *)
(*  apply H; trivial. rewrite <- P_list_eq with (P := SN_ind (S n) Beta) in Q. *)
(*  apply Q; trivial.  *)
(*  case eqdec_nil with (l := l).  *)
(*  intro H3. rewrite H3 in *|-*. simpl in *|-*. clear H H3. *)
(*  inversion H0; clear H0. *)
(*  apply sn_beta_abs  with (L := fv t1 \u x). intros y Fr. *)
(*  apply notin_union in Fr. destruct Fr. *)
(*  apply H1; trivial. apply H; trivial. apply L_SN_abs; trivial. *)
(*  intro H3. case not_nil_append with (l := l); trivial. *)
(*  intros a Hl. case Hl; clear Hl. intros l' Hl. *)
(*  rewrite Hl in *|-*. rewrite <- mult_app_append in *|-*. *)
(*  clear H3 Hl.  *)
(*  assert (Tl : Lterm a /\ Lterm %% l'). *)
(*    split. apply H. apply in_or_app. right.  *)
(*    simpl; left; trivial. *)
(*    apply P_list_eq with (P := Lterm). *)
(*    intros u Hu. apply H. apply in_or_app. left. *)
(*    trivial.   *)
(*  destruct Tl. apply sn_beta_meta_sub. apply H. *)
(*  apply in_or_app. simpl. right. left; trivial. *)
(*  apply L_SN_mult_app in H2; trivial. destruct H2. apply L_SN_app in H2; trivial. *)
(*  destruct H2; trivial. *)
(*  inversion H0. apply Lterm_abs with (L := x); intros.  *)
(*  apply H6; trivial.  apply Lterm_app. inversion H0. apply Lterm_abs with (L := x); intros.  *)
(*  apply H5; trivial. trivial. apply IHn. rewrite  Lterm_mult_app. split; trivial. *)
(*  apply Lbody_open_term; trivial. *)
(*  apply SN_one_step with (t := pterm_app (pterm_abs t1) a // l'); trivial. *)
(*  apply Lctx_red_h_mult_app; trivial. apply L_redex. apply reg_rule_beta. *)
(*  unfold Lbody in H0. case H0; clear H0; intros L H0. exists L. intros. *)
(*  apply H0; trivial. trivial. *)
(* Qed. *)
Admitted.


Require Import List.
Import ListNotations.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.BuiltinSyntax.
Require Import Cryptol.SimpleValues.
Require Import Cryptol.Bitstream.
Require Import Cryptol.Lib.
Require Import Cryptol.GlobalExtends.
Require Import Cryptol.GetEachN.

Require Import Cryptol.EvalTac.
Require Import Cryptol.Eager.

Require Import Cryptol.Prims.
Require Import SHA256.SHA256.

Definition preprocess_spec (padding msglen : Z) (msg : ext_val) : ext_val :=
  match msg with
  | eseq l =>
    (split_ev (Z.to_nat 512)
            (eseq
               (l ++
                  [ebit true] ++
                  repeat (ebit false) (Z.to_nat padding) ++
                  from_bitlist ext_val ebit (Z.to_nat 64) msglen)))
  | _ => eseq nil
  end.

Lemma strict_ext_from_bitlist :
  forall T1 T2 b1 b2 f width v,
    (forall b, f (b1 b) = b2 b) ->
    SimpleValues.from_bitlist T2 b2 width v = map f (SimpleValues.from_bitlist T1 b1 width v).
Proof.
  induction width; intros; simpl; auto.
  rewrite H. f_equal. eauto.
Qed.

Lemma from_bitlist_ext_type :
  forall width v,
    Forall (fun x => has_type x tbit) (from_bitlist ext_val ebit width v).
Proof.
  induction width; intros; repeat econstructor; eauto.
Qed.

Lemma preprocess_eval :
  forall msg len,
    has_type msg (tseq len tbit) ->
    forall GE TE SE,
      wf_env ge GE TE SE ->
      forall ta1 ta2 ta3 ta4 msglen contentlen chunks padding emsg,
        eager_eval_type GE TE ta1 (tvnum msglen) ->
        eager_eval_type GE TE ta2 (tvnum contentlen) ->
        eager_eval_type GE TE ta3 (tvnum chunks) ->
        eager_eval_type GE TE ta4 (tvnum padding) ->
        eager_eval_expr GE TE SE emsg (to_sval msg) ->
        forall res,
          res = to_sval (preprocess_spec padding msglen msg) ->
          eager_eval_expr GE TE SE (EApp (ETApp (ETApp (ETApp (ETApp (EVar preprocess) (ETyp ta1)) (ETyp ta2)) (ETyp ta3)) (ETyp ta4)) emsg) res.
Proof.
  intros.
  gen_global preprocess.
  gen_global (37,"split").
  gen_global (34,"#").
  gen_global (29,"zero").
  gen_global (0,"demote").
  gen_global (9,"True").
  inversion H. subst len msg t.
  e. e. e. e. e. ag.
  e. e. e. e.
  all: clear H7.

  e.
  use split_eval.

  use append_eval; try lv.
  use append_eval; try lv.
  simpl.
  instantiate (1 := (ebit true) :: nil).
  simpl. e.
  ag.
  e. reflexivity. reflexivity.

  use append_eval; try lv.
  use zero_eval; try lv.

  simpl. reflexivity.
  use demote_eval; try lv.
  simpl. unfold strictnum.
  f_equal. f_equal.

  erewrite strict_ext_from_bitlist.

  reflexivity. instantiate (1 := ebit). intros. reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  econstructor.
  eapply Forall_app; split.
  inversion H. eauto.
  eapply Forall_app; split.
  repeat econstructor.
  eapply Forall_app; split.
  eapply repeat_Forall. econstructor.

  eapply from_bitlist_ext_type; eauto.

  subst res.
  reflexivity.

Qed.


Require Import ROSCOQ.Vector.

Require Export ROSCOQ.fastReals.interface.

Set Implicit Arguments.

Definition unitVec {R:Type} `{SinClass R}`{CosClass R} (θ : R) : Cart2D R
  := {| X := cos θ; Y := sin θ |}.

Record Rigid2DState (A:Type): Type :=
{
  pos2D : Cart2D A;
  θ2D :  A
}.

Require Import MathClasses.interfaces.functors.

Global Instance SFmapCart2D : SFmap Cart2D :=
fun _ _ f c => {|X:= f (X c); Y:= f (Y c)|}.

Global Instance SFmapRigid2D : SFmap Rigid2DState :=
fun _ _ f c => {|pos2D := sfmap f (pos2D c); θ2D := f (θ2D c)|}.

Require Import MCMisc.PairLike.

Section Rigid2DStateInstances.
Context `{Ring A}.

Global Instance PairLikeRigid2DState (A:Type):
    PairLike  (@Build_Rigid2DState A) (@pos2D A) (@θ2D  A).
Proof.
  constructor; auto.
Qed.

Global Instance EquivRigid2D : Equiv (Rigid2DState A) :=
  @EquivPairLike _ _ _ _ _ _ (PairLikeRigid2DState A) _ _.

Global Instance EquivalenceRigid2D
 : Equivalence (@equiv  (Rigid2DState A) _).
  apply (@EquivalencePairLike _ _ _ _ _ _ (PairLikeRigid2DState A)).
  eauto using Equivalence_instance_Cart2D2.
  split; auto.
Qed.

Global Instance ProperPos2D : Proper (equiv ==> equiv) (@pos2D A).
 eapply ProperPairLikeFst; eauto using typeclass_instances.
Qed.

Global Instance Properθ2D : Proper (equiv ==> equiv) (@θ2D A).
 eapply ProperPairLikeSnd; eauto using typeclass_instances.
Qed.

Global Instance ZeroRigid2D : Zero (Rigid2DState A).
  eapply ZeroPairLike; eauto.
Defined.

Global Instance OneRigid2D : One (Rigid2DState A).
 apply (@OnePairLike _ _ _ _ _ _  (PairLikeRigid2DState A));
   eauto with typeclass_instances.
Defined.

Global Instance PlusRigid2D : Plus (Rigid2DState A).
 apply (@PlusPairLike _ _ _ _ _ _  (PairLikeRigid2DState A));
  [apply Plus_instance_Cart2D| assumption].
Defined.

Global Instance MultRigid2D : Mult (Rigid2DState A).
 apply (@MultPairLike _ _ _ _ _ _  (PairLikeRigid2DState A));
  [apply Mutt_instance_Cart2D| assumption].
Defined.

Global Instance NegateRigid2D : Negate (Rigid2DState A).
 apply (@NegatePairLike _ _ _ _ _ _  (PairLikeRigid2DState A));
   eauto with typeclass_instances.
Defined.

Global Instance RingRigid2D : Ring (Rigid2DState A).
 apply (@RingPairLike _ _ _ _ _ _  (PairLikeRigid2DState A)
  _ _ _ _ _ _   Ring_instance_Cart2D
  _ _ _ _ _ _   _).
Qed.

Global Instance ProperRigid2DState :
  Proper (equiv ==> equiv  ==> equiv) (@Build_Rigid2DState A).
Proof.
  intros ? ? h1  ? ? h2. split; simpl; assumption.
Qed.

End Rigid2DStateInstances.

Record Line2D (A:Type):=
{
  lstart : Cart2D A;
  lend : Cart2D A
}.

Global Instance PairLikeLine2D (A:Type):
    PairLike  (@Build_Line2D A) (@lstart A) (@lend A).
Proof.
  constructor; auto.
Qed.

Section LineInstances.
Context `{Ring A}.

Global Instance llll1 : Cast (Cart2D A) (Line2D A) :=
  @CastPairLikeSame _ _ _ _ _ (PairLikeLine2D A).

Global Instance llll2 : Equiv (Line2D A) :=
  @EquivPairLike _ _ _ _ _ _ (PairLikeLine2D A) _ _.

Global Instance llll3
 : Equivalence (@equiv  (Line2D A) _).
  apply (@EquivalencePairLike _ _ _ _ _ _ (PairLikeLine2D A));
  apply Equivalence_instance_Cart2D2.
Qed.

Global Instance llll4 : Proper (equiv ==> equiv) (@lstart A).
 eapply ProperPairLikeFst; eauto using typeclass_instances.
Qed.

Global Instance llll5 : Proper (equiv ==> equiv) (@lend A).
 eapply ProperPairLikeSnd; eauto using typeclass_instances.
Qed.

Global Instance llll6 : Zero (Line2D A).
  eapply ZeroPairLike; eauto.
Defined.

Global Instance llll7 : One (Line2D A).
 apply (@OnePairLike _ _ _ _ _ _  (PairLikeLine2D A));
   eauto with typeclass_instances.
Defined.

Global Instance llll8 : Plus (Line2D A).
 apply (@PlusPairLike _ _ _ _ _ _  (PairLikeLine2D A));
  apply Plus_instance_Cart2D.
Defined.

Global Instance MultLine : Mult (Line2D A).
 apply (@MultPairLike _ _ _ _ _ _  (PairLikeLine2D A));
  apply Mutt_instance_Cart2D.
Defined.

Global Instance NegateLine : Negate (Line2D A).
 apply (@NegatePairLike _ _ _ _ _ _  (PairLikeLine2D A));
   eauto with typeclass_instances.
Defined.

Global Instance RingLine : Ring (Line2D A).
 apply (@RingPairLike _ _ _ _ _ _  (PairLikeLine2D A)
  _ _ _ _ _ _   Ring_instance_Cart2D
  _ _ _ _ _ _   Ring_instance_Cart2D).
Qed.

Global Instance ProperCastCartLine :
 Proper (equiv ==> equiv) (cast  (Cart2D A) (Line2D A)).
apply ProperCastPairLikeSame.
Qed.

Global Instance ProperLine2D :
  Proper (equiv ==> equiv  ==> equiv) (@Build_Line2D A).
Proof.
  intros ? ? h1  ? ? h2. split; simpl; assumption.
Qed.

End LineInstances.

Instance srmSameStartEnd `{Ring A} : SemiRing_Morphism (cast (Cart2D A) (Line2D A)).
Proof.
repeat (split; try apply _); reflexivity.
Qed.

Definition centredLineAtAngle {R:Type} `{SinClass R}`{CosClass R} `{Ring R}
  (angle halfLength : R) (p: Cart2D R)
   : (Line2D R) :=
   let v := 'halfLength * (unitVec angle) in
   {| lstart := p-v ; lend := p+v |}.

Fixpoint linesConsecutive {A:Type}
   (pts : list (Cart2D A)): list (Line2D A) :=
match pts with
| nil => []
| h1::tl => match tl with
            | nil => []
            | h2::_ =>  {|lstart := h1 ; lend := h2|}::(linesConsecutive tl)
            end
end.

Definition BoundingRectangle := Line2D.

Global Instance LeAsSubset `{Le A} : Le (Line2D A) :=
  fun a b => lstart b ≤ lstart a /\ lend a ≤ lend b.

Definition minCart `{MinClass A} (a b : Cart2D A) :=
  {|X:= min (X a) (X b); Y:= min (Y a) (Y b)|}.

Definition maxCart `{MaxClass A} (a b : Cart2D A) :=
  {|X:= max (X a) (X b); Y:= max (Y a) (Y b)|}.

Definition boundingUnion `{MinClass A}`{MaxClass A}
 (a b : Line2D A) : Line2D A:=
  {|lstart := minCart (lstart a) (lstart b);
    lend := maxCart  (lend a) (lend b)|}.

Typeclasses Transparent BoundingRectangle.

Fixpoint computeBoundingRect `{MinClass A}`{MaxClass A} `{Zero A}
  (pts : list (Cart2D A)) : BoundingRectangle A :=
match pts with
| pt::[] => {|lstart := pt; lend := pt|}
| h::tl => let b := computeBoundingRect tl in
        boundingUnion b {|lstart := h; lend := h|}
| [] => {|lstart := 0; lend := 0|}
end.

Require Import CoRN.logic.Stability.

Global Instance StableSubsetLine2D `{Le A} :
    (forall x y : A, Stable (x≤y))
    -> (forall a b : Line2D A, Stable (a ≤ b)).
Proof.
     intros Hc a b.
     apply stable_conjunction; eauto using StableLeCart2D.
Qed.

Require Import MathClasses.interfaces.orders.

Global Instance LeRigid2DState  `{Le A}: Le (Rigid2DState A).
Proof.
  apply pair_instance_le.
Defined.

Global Instance LeRigid2DStatePreorder `{Ring A}
  `{l:Le A} `{PreOrder A l}
  : @PreOrder _ LeRigid2DState.
Proof.
  apply LePairPreorder.
Qed.

Global Instance LeRigid2DStatePartialOrder `{Ring A}  `{l: Le A}
  `{@PartialOrder A equiv l} :
      @PartialOrder (Rigid2DState A) _ _.
Proof.
  apply LePairPartialOrder.
Qed.

Global Instance PairSemiringOrder
`{Ring A}
`{Le A}
    `{@orders.SemiRingOrder A equiv plus mult zero one le} :
    `{@orders.SemiRingOrder (Rigid2DState A) _ _ _ _ _ _}.
Proof.
  apply PairSemiringOrder.
Qed.

Global Instance StableLeRigid2DState `{Le A} :
    (forall x y : A, Stable (x≤y))
    -> (forall a b : Rigid2DState A, Stable (a ≤ b)).
Proof.
  intros Hh. apply StableLePair; auto.
  apply StableLeCart2D. auto.
Qed.

Infix "⊆" := (@le _ LeAsSubset)  (at level 70, no associativity): mc_scope.

Global Instance LeSubsetPreorder `{Ring A}
  `{l:Le A} `{PreOrder A l}
  : @PreOrder (Line2D A) LeAsSubset.
Proof.
  split; intros ?; unfold le, LeAsSubset;
   eauto 2 with typeclass_instances;[].
  intros a b ? ?. repnd. split;
  eauto with relations typeclass_instances.
Qed.

Global Instance PartialOrderSubset `{Ring A}  `{l: Le A}
  `{@PartialOrder A equiv l} :
      @PartialOrder (Line2D A) _ _.
Proof.
  split; eauto with typeclass_instances.
  - split; eauto with typeclass_instances.
  - intros ? ? H1e ? ? H2e; unfold le,LeAsSubset.
    rewrite H1e,  H2e. tauto.
  - intros ? ?. unfold le, LeAsSubset. intros ? ?.
    repnd. split; simpl; eapply  po_antisym; eauto.
Qed.

(* Exact same proof as Vector.MultLeSemiRingOrderCart2D,
    except for LeAsSubset *)
Global Instance OrderPreservingLePlusCart2D
  `{Ring A} `{Le A}
    `{@orders.SemiRingOrder A equiv plus mult zero one le}
  (z : Line2D A):
  OrderPreserving (plus z).
Proof.
  split; eauto  with typeclass_instances.
  - split; eauto with typeclass_instances.
    split;  eauto with typeclass_instances;
    split;  eauto with typeclass_instances.
  - intros ? ?. unfold le, LeAsSubset.
    intros. repnd;
    simpl.
    split;
    eauto with typeclass_instances.
Qed.

Require Import MathClasses.orders.rings.
(** does not hold for subset
Global Instance MultLeSemiRingOrderCart2D
  `{Ring A} `{Le A}
    `{@orders.SemiRingOrder A equiv plus mult zero one le} :
  ∀ x y : (Line2D A) , PropHolds (0 ≤ x)
      → PropHolds (0 ≤ y) → PropHolds (0 ≤ x * y)
 .
Proof.
    unfold le, LeAsSubset, PropHolds.
    simpl.
    intros. repnd;
    simpl.
    split.
    - NOT TRUE
    - eapply nonneg_mult_compat; assumption.
Qed.
*)

Lemma foldPlusLine `{Ring A} : forall xa xb ya yb: Cart2D A,
   {| lstart := xa + xb; lend :=ya + yb |} = {|lstart :=xa; lend :=ya|}
    + {|lstart:=xb; lend:=yb|}.
  Proof.
    intros. reflexivity.
  Qed.

Require Import MathClasses.interfaces.vectorspace.

Global Instance InProductCart2D `{Ring A} : Inproduct A (Cart2D A) :=
  λ a b, (X a)*(X b) + (Y a)*(Y b).

Global Instance ProperInProductCart2D `{Ring A}  :
  Proper (equiv ==> equiv ==> equiv) (@inprod A (Cart2D A) _).
Proof using .
  intros ? ? H1 ? ? H2.
  unfold inprod, InProductCart2D.
  rewrite H1. rewrite H2.
  reflexivity.
Qed.

(*Move *)

(** This operation shows up again and again.
Is there a good name for it?*)
Definition nflip `{Negate R} (p : Cart2D R) :=
{| X:= Y p ; Y:= -X p|}.

Definition rotateAxis `{Ring R} `{CosClass R} `{SinClass R}
(θ:R) (p : Cart2D R)  :=
{|X := ⟨p, unitVec θ⟩;
  Y:= ⟨nflip p, unitVec θ⟩ |}.

Global Instance srm_CastCart `{c:Cast A B}
 `{@Ring A ae apl am az ao an}
 `{@Ring B be bp bm bz bo bn}
  `{@SemiRing_Morphism A B ae be apl am az ao bp bm bz bo c}:
    SemiRing_Morphism (@cast (Cart2D A) (Cart2D B) _).
Proof using.
repeat (split; unfold cast, castCart; simpl; try apply _);
try rewrite H2; try reflexivity.
- apply preserves_plus.
- apply preserves_plus.
- apply preserves_0.
- apply preserves_0.
- apply preserves_mult.
- apply preserves_mult.
- apply preserves_1.
- apply preserves_1.
Qed.

(*
Not useful because typically A and B will be a ring, so the above
Instance can be used instead. SemiRing_Morphism implies Setoid_Morphism

Global Instance ProperCastCart `{c:Cast A B}
 `{H:Setoid_Morphism A B c}  :
    Setoid_Morphism (@cast (Cart2D A) (Cart2D B) _).
Proof using.
  destruct H.
  split; unfold Setoid;  eauto 2 with typeclass_instances.
  intros ? ? H1.
  unfold cast, castCart.
  rewrite H1.
  reflexivity.
Qed.
*)

Lemma castCartCommute `{c:Cast A B} `{e:Equiv B} `{Equivalence B e}:
 forall a:A,
  @cast B (Cart2D B) _ ('a) =  '(@cast A (Cart2D A) _ a).
Proof.
  intros ?.
  split; reflexivity.
Qed.

Lemma transposeCastCommute `{c:Cast A B} `{e:Equiv B} `{Equivalence B e}:
 forall a: Cart2D A,
  transpose ('a) =  '(transpose a).
Proof.
  intros ?.
  split; reflexivity.
Qed.