(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
Require Import bigop finset prime binomial fingroup morphism perm automorphism.
Require Import presentation quotient action commutator gproduct gfunctor.
Require Import ssralg finalg zmodp cyclic pgroup center gseries.
Require Import nilpotent sylow abelian finmodule matrix maximal extremal.

(******************************************************************************)
(* This file contains the fine structure thorems for extraspecial p-groups.   *)
(* Together with the material in the maximal and extremal libraries, it       *)
(* completes the coverage of Aschbacher, section 23.                          *)
(* We define canonical representatives for the group classes that cover the   *)
(* extremal p-groups (non-abelian p-groups with a cyclic maximal subgroup):   *)
(* 'Mod_m == the modular group of order m, for m = p ^ n, p prime and n >= 3. *)
(*   'D_m == the dihedral group of order m, for m = 2n >= 4.                  *)
(*   'Q_m == the generalized quaternion group of order m, for q = 2 ^ n >= 8. *)
(*  'SD_m == the semi-dihedral group of order m, for m = 2 ^ n >= 16.         *)
(* In each case the notation is defined in the %type, %g and %G scopes, where *)
(* it denotes a finGroupType, a full gset and the full group for that type.   *)
(* However each notation is only meaningful under the given conditions, in    *)
(*   We construct and study the following extraspecial groups:                *)
(*    p^{1+2} == if p is prime, an extraspecial group of order p^3 that has   *)
(*               exponent p or 4, and p-rank 2: thus p^{1+2} is isomorphic to *)
(*               'D_8 if p - 2, and NOT isomorphic to 'Mod_(p^3) if p is odd. *)
(*  p^{1+2*n} == the central product of n copies of p^{1+2}, thus of order    *)
(*               p^(1+2*n) if p is a prime, and, when n > 0, a representative *)
(*               of the (unique) isomorphism class of extraspecial groups of  *)
(*               order p^(1+2*n), of exponent p or 4, and p-rank n+1.         *)
(*       'D^n == an alternative (and preferred) notation for 2^{1+2*n}, which *)
(*               is isomorphic to the central product of n copies od 'D_8.    *)
(*     'D^n*Q == the central product of 'D^n with 'Q_8, thus isomorphic to    *)
(*               all extraspecial groups of order 2 ^ (2 * n + 3) that are    *)
(*               not isomorphic to 'D^n.+1 (or, equivalently, have 2-rank n). *)
(* As in extremal.v, these notations are simultaneously defined in the %type, *)
(* %g and %G scopes -- depending on the syntactic context, they denote either *)
(* a finGroupType, the set, or the group of all its elements.                 *)
(******************************************************************************)

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

Local Open Scope ring_scope.
Import GroupScope GRing.Theory.

Reserved Notation "p ^{1+2}" (at level 2, format "p ^{1+2}").
Reserved Notation "p ^{1+2* n }"
  (at level 2, n at level 2, format "p ^{1+2* n }").
Reserved Notation "''D^' n" (at level 8, n at level 2, format "''D^' n").
Reserved Notation "''D^' n * 'Q'"
  (at level 8, n at level 2, format "''D^' n * 'Q'").

Module Pextraspecial.

Section Construction.

Variable p : nat.

Definition act ij (k : 'Z_p) := let: (i, j) := ij in (i + k * j, j).
Lemma actP : is_action [set: 'Z_p] act.
Proof.
apply: is_total_action=> [] [i j] => [|k1 k2] /=; first by rewrite mul0r addr0.
by rewrite mulrDl addrA.
Qed.
Canonical action := Action actP.

Lemma gactP : is_groupAction [set: 'Z_p * 'Z_p] action.
Proof.
move=> k _ /=; rewrite inE.
apply/andP; split; first by apply/subsetP=> ij _; rewrite inE.
apply/morphicP=> /= [[i1 j1] [i2 j2] _ _].
by rewrite !permE /= mulrDr -addrA (addrCA i2) (addrA i1).
Qed.
Definition groupAction := GroupAction gactP.

Fact gtype_key : unit. Proof. by []. Qed.
Definition gtype := locked_with gtype_key (sdprod_groupType groupAction).

Definition ngtype := ncprod [set: gtype].

End Construction.

Definition ngtypeQ n := xcprod [set: ngtype 2 n] 'Q_8.

End Pextraspecial.

Notation "p ^{1+2}" := (Pextraspecial.gtype p) : type_scope.
Notation "p ^{1+2}" := [set: gsort p^{1+2}] : group_scope.
Notation "p ^{1+2}" := [set: gsort p^{1+2}]%G : Group_scope.

Notation "p ^{1+2* n }" := (Pextraspecial.ngtype p n) : type_scope.
Notation "p ^{1+2* n }" := [set: gsort p^{1+2*n}] : group_scope.
Notation "p ^{1+2* n }" := [set: gsort p^{1+2*n}]%G : Group_scope.

Notation "''D^' n" := (Pextraspecial.ngtype 2 n) : type_scope.
Notation "''D^' n" := [set: gsort 'D^n] : group_scope.
Notation "''D^' n" := [set: gsort 'D^n]%G : Group_scope.

Notation "''D^' n * 'Q'" := (Pextraspecial.ngtypeQ n) : type_scope.
Notation "''D^' n * 'Q'" := [set: gsort 'D^n*Q] : group_scope.
Notation "''D^' n * 'Q'" := [set: gsort 'D^n*Q]%G : Group_scope.

Section ExponentPextraspecialTheory.

Variable p : nat.
Hypothesis p_pr : prime p.
Let p_gt1 := prime_gt1 p_pr.
Let p_gt0 := ltnW p_gt1.

Local Notation gtype := Pextraspecial.gtype.
Local Notation actp := (Pextraspecial.groupAction p).

Lemma card_pX1p2 : #|p^{1+2}| = (p ^ 3)%N.
Proof.
rewrite [@gtype _]unlock -(sdprod_card (sdprod_sdpair _)).
rewrite !card_injm ?injm_sdpair1 ?injm_sdpair2 // !cardsT card_prod card_ord.
by rewrite -mulnA Zp_cast.
Qed.

Lemma Grp_pX1p2 :
  p^{1+2} \isog Grp (x : y : (x ^+ p, y ^+ p, [~ x, y, x], [~ x, y, y])).
Proof.
rewrite [@gtype _]unlock ; apply: intro_isoGrp => [|rT H].
  apply/existsP; pose x := sdpair1 actp (0, 1)%R; pose y := sdpair2 actp 1%R.
  exists (x, y); rewrite /= !xpair_eqE; set z := [~ x, y]; set G := _ <*> _.
  have def_z: z = sdpair1 actp (1, 0)%R.
    rewrite [z]commgEl -sdpair_act ?inE //=.
    rewrite -morphV -?morphM ?inE //=; congr (sdpair1 _ (_, _)) => /=.
      by rewrite mulr1 mulKg.
    by rewrite mulVg.
  have def_xi i: x ^+ i = sdpair1 _ (0, i%:R)%R.
    rewrite -morphX ?inE //; congr (sdpair1 _ _).
    by apply/eqP; rewrite /eq_op /= !morphX ?inE ?expg1n //=.
  have def_yi i: y ^+ i = sdpair2 _ i%:R.
    by rewrite -morphX ?inE //.
  have def_zi i: z ^+ i = sdpair1 _ (i%:R, 0)%R.
    rewrite def_z -morphX ?inE //; congr (sdpair1 _ _).
    by apply/eqP; rewrite /eq_op /= !morphX ?inE ?expg1n ?andbT //=.
  rewrite def_xi def_yi char_Zp ?morph1 //.
  rewrite def_z -morphR ?inE // !commgEl -sdpair_act ?inE //= mulr0 addr0.
  rewrite mulVg -[_ * _]/(_ , _) /= !invg1 mulg1 !mul1g mulVg morph1 !andbT.
  have Gx: x \in G by rewrite -cycle_subG joing_subl.
  have Gy: y \in G by rewrite -cycle_subG joing_subr.
  rewrite eqEsubset subsetT -im_sdpair mulG_subG /= -/G; apply/andP; split.
    apply/subsetP=> u /morphimP[[i j] _ _ def_u].
    suffices ->: u = z ^+ i * x ^+ j by rewrite groupMl groupX ?groupR.
    rewrite def_zi def_xi !natr_Zp -morphM ?inE // def_u.
    by congr (sdpair1 _ (_, _)); rewrite ?mulg1 ?mul1g.
  apply/subsetP=> v /morphimP[k _ _ def_v].
  suffices ->: v = y ^+ k by rewrite groupX.
  by rewrite def_yi natr_Zp.
case/existsP=> [[x y] /=]; set z := [~ x, y].
case/eqP=> defH xp yp /eqP/commgP czx /eqP/commgP czy.
have zp: z ^+ p = 1 by rewrite -commXg // xp comm1g.
pose f1 (ij : 'Z_p * 'Z_p) := let: (i, j) := ij in z ^+ i * x ^+ j.
have f1M: {in setT &, {morph f1 : u v / u * v}}.
  case=> /= [i1 j1] [i2 j2] _ _ /=; rewrite {3 6}Zp_cast // !expg_mod //.
  rewrite !expgD !mulgA; congr (_ * _); rewrite -!mulgA; congr (_ * _).
  by apply: commuteX2.
pose f2 (k : 'Z_p) := y ^+ k.
have f2M: {in setT &, {morph f2 : u v / u * v}}.
  by move=> k1 k2 _ _; rewrite /f2 /= {3}Zp_cast // expg_mod // expgD.
have actf: {in setT & setT, morph_act actp 'J (Morphism f1M) (Morphism f2M)}.
  case=> /= i j k _ _; rewrite modnDmr {4}Zp_cast // expg_mod // expgD.
  rewrite /f2 conjMg {1}/conjg (commuteX2 i k czy) mulKg -mulgA.
  congr (_ * _); rewrite (commuteX2 _ _ czx) mulnC expgM.
  by rewrite -commXg // -commgX ?mulKVg // commXg // /commute commuteX.
apply/homgP; exists (xsdprod_morphism actf).
apply/eqP; rewrite eqEsubset -{2}defH -genM_join gen_subG /= im_xsdprodm.
have Hx: x \in H by rewrite -cycle_subG -defH joing_subl.
have Hy: y \in H by rewrite -cycle_subG -defH joing_subr.
rewrite mulG_subG -andbA; apply/and3P; split.
- apply/subsetP=> _ /morphimP[[i j] _ _ -> /=].
  by rewrite groupMl groupX ?groupR.
- by apply/subsetP=> _ /morphimP[k _ _ ->]; rewrite groupX.
rewrite mulgSS ?cycle_subG //= morphimEdom; apply/imsetP.
  by exists (0, 1)%R; rewrite ?inE //= mul1g.
by exists 1%R; rewrite ?inE.
Qed.

Lemma pX1p2_pgroup : p.-group p^{1+2}.
Proof. by rewrite /pgroup card_pX1p2 pnat_exp pnat_id. Qed.

(* This is part of the existence half of Aschbacher ex. (8.7)(1) *)
Lemma pX1p2_extraspecial : extraspecial p^{1+2}.
Proof.
apply: (p3group_extraspecial pX1p2_pgroup); last first.
  by rewrite card_pX1p2 pfactorK.
case/existsP: (isoGrp_hom Grp_pX1p2) card_pX1p2 => [[x y]] /=.
case/eqP=> <- xp yp _ _ oXY.
apply: contraL (dvdn_cardMg <[x]> <[y]>) => cXY_XY.
rewrite -cent_joinEl ?(sub_abelian_cent2 cXY_XY) ?joing_subl ?joing_subr //.
rewrite oXY -!orderE pfactor_dvdn ?muln_gt0 ?order_gt0 // -leqNgt.
rewrite -(pfactorK 2 p_pr) dvdn_leq_log ?expn_gt0 ?p_gt0 //.
by rewrite dvdn_mul ?order_dvdn ?xp ?yp.
Qed.

(* This is part of the existence half of Aschbacher ex. (8.7)(1) *)
Lemma exponent_pX1p2 : odd p -> exponent p^{1+2} %| p.
Proof.
move=> p_odd; have pG := pX1p2_pgroup.
have ->: p^{1+2} = 'Ohm_1(p^{1+2}).
  apply/eqP; rewrite eqEsubset Ohm_sub andbT (OhmE 1 pG).
  case/existsP: (isoGrp_hom Grp_pX1p2) => [[x y]] /=.
  case/eqP=> <- xp yp _ _; rewrite joing_idl joing_idr genS //.
  by rewrite subsetI subset_gen subUset !sub1set !inE xp yp!eqxx.
rewrite exponent_Ohm1_class2 ?card_pX1p2 ?odd_exp // nil_class2.
by have [[_ ->] _ ] := pX1p2_extraspecial.
Qed.

(* This is the uniqueness half of Aschbacher ex. (8.7)(1) *)
Lemma isog_pX1p2 (gT : finGroupType) (G : {group gT}) :
  extraspecial G -> exponent G %| p -> #|G| = (p ^ 3)%N -> G \isog p^{1+2}.
Proof.
move=> esG expGp oG; apply/(isoGrpP _ Grp_pX1p2).
rewrite card_pX1p2; split=> //.
have pG: p.-group G by rewrite /pgroup oG pnat_exp pnat_id.
have oZ := card_center_extraspecial pG esG.
have [x Gx notZx]: exists2 x, x \in G & x \notin 'Z(G).
  apply/subsetPn; rewrite proper_subn // properEcard center_sub oZ oG.
  by rewrite (ltn_exp2l 1 3).
have ox: #[x] = p.
  by apply: nt_prime_order; rewrite ?(exponentP expGp) ?(group1_contra notZx).
have [y Gy not_cxy]: exists2 y, y \in G & y \notin 'C[x].
  by apply/subsetPn; rewrite sub_cent1; rewrite inE Gx in notZx.
apply/existsP; exists (x, y) => /=; set z := [~ x, y].
have [[defPhiG defG'] _] := esG.
have Zz: z \in 'Z(G) by rewrite -defG' mem_commg.
have [Gz cGz] := setIP Zz; rewrite !xpair_eqE !(exponentP expGp) //.
have [_ nZG] := andP (center_normal G).
rewrite /commg /conjg !(centP cGz) // !mulKg mulVg !eqxx !andbT.
have sXY_G: <[x]> <*> <[y]> \subset G by rewrite join_subG !cycle_subG Gx.
have defZ: <[z]> = 'Z(G).
  apply/eqP; rewrite eqEcard cycle_subG Zz oZ /= -orderE.
  rewrite (nt_prime_order p_pr) ?(exponentP expGp) //.
  by rewrite (sameP commgP cent1P) cent1C.
have sZ_XY: 'Z(G) \subset <[x]> <*> <[y]>.
  by rewrite -defZ cycle_subG groupR // mem_gen // inE cycle_id ?orbT.
rewrite eqEcard sXY_G /= oG -(Lagrange sZ_XY) oZ leq_pmul2l //.
rewrite -card_quotient ?(subset_trans sXY_G) //.
rewrite quotientY ?quotient_cycle ?cycle_subG ?(subsetP nZG) //.
have abelGz: p.-abelem (G / 'Z(G)) by rewrite -defPhiG Phi_quotient_abelem.
have [cGzGz expGz] := abelemP p_pr abelGz.
rewrite cent_joinEr ?(sub_abelian_cent2 cGzGz) ?cycle_subG ?mem_quotient //.
have oZx: #|<[coset 'Z(G) x]>| = p.
  rewrite -orderE (nt_prime_order p_pr) ?expGz ?mem_quotient //.
  by apply: contra notZx; move/eqP=> Zx; rewrite coset_idr ?(subsetP nZG).
rewrite TI_cardMg ?oZx -?orderE ?(nt_prime_order p_pr) ?expGz ?mem_quotient //.
  apply: contra not_cxy; move/eqP=> Zy.
  rewrite -cent_cycle (subsetP _ y (coset_idr _ Zy)) ?(subsetP nZG) //.
  by rewrite subIset ?centS ?orbT ?cycle_subG.
rewrite prime_TIg ?oZx // cycle_subG; apply: contra not_cxy.
case/cycleP=> i; rewrite -morphX ?(subsetP nZG) // => /rcoset_kercosetP.
rewrite groupX ?(subsetP nZG) // cent1C => /(_ isT isT); apply: subsetP.
rewrite mul_subG ?sub1set ?groupX ?cent1id //= -cent_cycle subIset // orbC.
by rewrite centS ?cycle_subG.
Qed.

End ExponentPextraspecialTheory.

Section GeneralExponentPextraspecialTheory.

Variable p : nat.

Lemma pX1p2id : p^{1+2*1} \isog p^{1+2}.
Proof. exact: ncprod1. Qed.

Lemma pX1p2S n : xcprod_spec p^{1+2} p^{1+2*n} p^{1+2*n.+1}%type.
Proof. exact: ncprodS. Qed.

Lemma card_pX1p2n n : prime p -> #|p^{1+2*n}| = (p ^ n.*2.+1)%N.
Proof.
move=> p_pr; have pG := pX1p2_pgroup p_pr.
have oG := card_pX1p2 p_pr; have esG := pX1p2_extraspecial p_pr.
have oZ := card_center_extraspecial pG esG.
elim: n => [|n IHn]; first by rewrite (card_isog (ncprod0 _)) oZ.
case: pX1p2S => gz isoZ; rewrite -im_cpair cardMg_divn setI_im_cpair.
rewrite -injm_center ?{1}card_injm ?injm_cpairg1 ?injm_cpair1g ?center_sub //.
by rewrite oG oZ IHn -expnD mulKn ?prime_gt0.
Qed.

Lemma pX1p2n_pgroup n : prime p -> p.-group p^{1+2*n}.
Proof. by move=> p_pr; rewrite /pgroup card_pX1p2n // pnat_exp pnat_id. Qed.

(* This is part of the existence half of Aschbacher (23.13) *)
Lemma exponent_pX1p2n n : prime p -> odd p -> exponent p^{1+2*n} = p.
Proof.
move=> p_pr odd_p; apply: prime_nt_dvdP => //.
  rewrite -dvdn1 -trivg_exponent -cardG_gt1 card_pX1p2n //.
  by rewrite (ltn_exp2l 0) // prime_gt1.
elim: n => [|n IHn].
  by rewrite (dvdn_trans (exponent_dvdn _)) ?card_pX1p2n.
case: pX1p2S => gz isoZ; rewrite -im_cpair /=.
apply/exponentP=> xy; case/imset2P=> x y C1x C2y ->{xy}.
rewrite expgMn; last by red; rewrite -(centsP (im_cpair_cent isoZ)).
rewrite (exponentP _ y C2y) ?exponent_injm ?injm_cpair1g // mulg1.
by rewrite (exponentP _ x C1x) ?exponent_injm ?injm_cpairg1 // exponent_pX1p2.
Qed.

(* This is part of the existence half of Aschbacher (23.13) and (23.14) *)
Lemma pX1p2n_extraspecial n : prime p -> n > 0 -> extraspecial p^{1+2*n}.
Proof.
move=> p_pr; elim: n => [//|n IHn _].
have esG := pX1p2_extraspecial p_pr.
have [n0 | n_gt0] := posnP n.
  by apply: isog_extraspecial esG; rewrite isog_sym n0 pX1p2id.
case: pX1p2S (pX1p2n_pgroup n.+1 p_pr) => gz isoZ pGn.
apply: (cprod_extraspecial pGn (im_cpair_cprod isoZ) (setI_im_cpair isoZ)).
  by apply: injm_extraspecial esG; rewrite ?injm_cpairg1.
by apply: injm_extraspecial (IHn n_gt0); rewrite ?injm_cpair1g.
Qed.

(* This is Aschbacher (23.12) *)
Lemma Ohm1_extraspecial_odd (gT : finGroupType) (G : {group gT}) :
    p.-group G -> extraspecial G -> odd #|G| ->
 let Y := 'Ohm_1(G) in
  [/\ exponent Y = p, #|G : Y| %| p
    & Y != G ->
      exists E : {group gT},
        [/\ #|G : Y| = p, #|E| = p \/ extraspecial E,
            exists2 X : {group gT}, #|X| = p & X \x E = Y
          & exists M : {group gT},
             [/\ M \isog 'Mod_(p ^ 3), M \* E = G & M :&: E = 'Z(M)]]].
Proof.
move=> pG esG oddG Y; have [spG _] := esG.
have [defPhiG defG'] := spG; set Z := 'Z(G) in defPhiG defG'.
have{spG} expG: exponent G %| p ^ 2 by exact: exponent_special.
have p_pr := extraspecial_prime pG esG.
have p_gt1 := prime_gt1 p_pr; have p_gt0 := ltnW p_gt1.
have oZ: #|Z| = p := card_center_extraspecial pG esG.
have nsZG: Z <| G := center_normal G; have [sZG nZG] := andP nsZG.
have nsYG: Y <| G := Ohm_normal 1 G; have [sYG nYG] := andP nsYG.
have ntZ: Z != 1 by rewrite -cardG_gt1 oZ.
have sZY: Z \subset Y.
  by apply: contraR ntZ => ?; rewrite -(setIidPl sZG) TI_Ohm1 ?prime_TIg ?oZ.
have ntY: Y != 1 by apply: contra ntZ; rewrite -!subG1; exact: subset_trans.
have p_odd: odd p by rewrite -oZ (oddSg sZG).
have expY: exponent Y %| p by rewrite exponent_Ohm1_class2 // nil_class2 defG'.
rewrite (prime_nt_dvdP p_pr _ expY) -?dvdn1 -?trivg_exponent //.
have [-> | neYG] := eqVneq Y G; first by rewrite indexgg dvd1n eqxx; split.
have sG1Z: 'Mho^1(G) \subset Z by rewrite -defPhiG (Phi_joing pG) joing_subr.
have Z_Gp: {in G, forall x, x ^+ p \in Z}.
  by move=> x Gx; rewrite /= (subsetP sG1Z) ?(Mho_p_elt 1) ?(mem_p_elt pG).
have{expG} oY': {in G :\: Y, forall u, #[u] = (p ^ 2)%N}.
  move=> u /setDP[Gu notYu]; apply/eqP.
  have [k ou] := p_natP (mem_p_elt pG Gu).
  rewrite eqn_dvd order_dvdn (exponentP expG) // eqxx ou dvdn_Pexp2l // ltnNge.
  apply: contra notYu => k_le_1; rewrite [Y](OhmE _ pG) mem_gen // !inE Gu /=.
  by rewrite -order_dvdn ou dvdn_exp2l.
have isoMod3 (M : {group gT}):
    M \subset G -> ~~ abelian M -> ~~ (M \subset Y) -> #|M| = (p ^ 3)%N ->
  M \isog 'Mod_(p ^ 3).
- move=> sMG not_cMM /subsetPn[u Mu notYu oM].
  have pM := pgroupS sMG pG; have sUM: <[u]> \subset M by rewrite cycle_subG.
  have Y'u: u \in G :\: Y by rewrite inE notYu (subsetP sMG).
  have iUM: #|M : <[u]>| = p by rewrite -divgS // oM expnS -(oY' u) ?mulnK.
  have cM := maximal_cycle_extremal pM not_cMM (cycle_cyclic u) sUM iUM.
  rewrite (sameP eqP (prime_oddPn p_pr)) p_odd orbF in cM.
  rewrite /extremal_class oM pdiv_pfactor // pfactorK //= in cM.
  by do 3!case: ifP => // _ in cM.
have iYG: #|G : Y| = p.
  have [V maxV sYV]: {V : {group gT} | maximal V G & Y \subset V}.
    by apply: maxgroup_exists; rewrite properEneq neYG.
  have [sVG [u Gu notVu]] := properP (maxgroupp maxV).
  without loss [v Vv notYv]: / exists2 v, v \in V & v \notin Y.
    have [->| ] := eqVneq Y V; first by rewrite (p_maximal_index pG).
    by rewrite eqEsubset sYV => not_sVY; apply; exact/subsetPn.
  pose U := <[u]> <*> <[v]>; have Gv := subsetP sVG v Vv.
  have sUG: U \subset G by rewrite join_subG !cycle_subG Gu.
  have Uu: u \in U by rewrite -cycle_subG joing_subl.
  have Uv: v \in U by rewrite -cycle_subG joing_subr.
  have not_sUY: ~~ (U \subset Y) by apply/subsetPn; exists v.
  have sU1U: 'Ohm_1(U) \subset U := Ohm_sub 1 _.
  have sU1Y: 'Ohm_1(U) \subset Y := OhmS 1 sUG.
  suffices defUV: U :&: V = 'Ohm_1(U).
    by rewrite (subsetP sU1Y) // -defUV inE Uv in notYv.
  suffices iU1U: #|U : 'Ohm_1(U)| = p.
    have: maximal 'Ohm_1(U) U by rewrite p_index_maximal ?Ohm_sub ?iU1U.
    case/maxgroupP=> _; apply; rewrite /= -/U.
      by apply/properP; split; last exists u; rewrite ?subsetIl ?inE ?Uu.
    by rewrite subsetI Ohm_sub (subset_trans sU1Y).
  apply/prime_nt_dvdP=> //.
    by apply: contra not_sUY; rewrite /U; move/eqP; move/(index1g sU1U)=> <-.
  have ov: #[v] = (p ^ 2)%N by rewrite oY' // inE notYv.
  have sZv: Z \subset <[v]>.
    suffices defZ: <[v ^+ p]> == Z by rewrite -(eqP defZ) cycleX.
    by rewrite eqEcard cycle_subG Z_Gp //= oZ -orderE (orderXexp 1 ov).
  have nvG: G \subset 'N(<[v]>) by rewrite sub_der1_norm ?cycle_subG // defG'.
  have [cUU | not_cUU] := orP (orbN (abelian U)).
    rewrite -divgS ?Ohm_sub // -(mul_card_Ohm_Mho_abelian 1 cUU) /= -/U.
    by rewrite mulKn ?cardG_gt0 //= -oZ cardSg ?(subset_trans (MhoS 1 sUG)).
  have oU: #|U| = (p ^ 3)%N.
    have nvu := subsetP nvG u Gu; have nvU := subset_trans sUG nvG.
    rewrite -(Lagrange (joing_subr _ _)) -orderE ov mulnC; congr (_ * _)%N.
    rewrite -card_quotient //= quotientYidr ?cycle_subG //=.
    rewrite quotient_cycle // -orderE; apply: nt_prime_order => //.
      by rewrite -morphX //= coset_id // (subsetP sZv) // Z_Gp.
    have svV: <[v]> \subset V by rewrite cycle_subG.
    by apply: contra notVu; move/eqP=> v_u; rewrite (subsetP svV) // coset_idr.
  have isoU := isoMod3 _ sUG not_cUU not_sUY oU; rewrite /= -/U in isoU.
  have [//|[x y] genU modU] := generators_modular_group p_pr _ isoU.
  case/modular_group_structure: genU => // _ _ _ _.
  case: eqP (p_odd) => [[-> //] | _ _]; case/(_ 1%N)=> // _ oU1.
  by rewrite -divgS // oU oU1 mulnK // muln_gt0 p_gt0.
have iC1U (U : {group gT}) x:
  U \subset G -> x \in G :\: 'C(U) -> #|U : 'C_U[x]| = p.
- move=> sUG /setDP[Gx not_cUx]; apply/prime_nt_dvdP=> //.
    apply: contra not_cUx; rewrite -sub_cent1 => /eqP sUCx.
    by rewrite -(index1g _ sUCx) ?subsetIl ?subsetIr.
  rewrite -(@dvdn_pmul2l (#|U| * #|'C_G[x]|)) ?muln_gt0 ?cardG_gt0 //.
  have maxCx: maximal 'C_G[x] G.
    rewrite cent1_extraspecial_maximal //; apply: contra not_cUx.
    by rewrite inE Gx; exact: subsetP (centS sUG) _.
  rewrite {1}mul_cardG setIA (setIidPl sUG) -(p_maximal_index pG maxCx) -!mulnA.
  rewrite !Lagrange ?subsetIl // mulnC dvdn_pmul2l //.
  have [sCxG nCxG] := andP (p_maximal_normal pG maxCx).
  by rewrite -norm_joinEl ?cardSg ?join_subG ?(subset_trans sUG).
have oCG (U : {group gT}):
  Z \subset U -> U \subset G -> #|'C_G(U)| = (p * #|G : U|)%N.
- elim: {U}_.+1 {-2}U (ltnSn #|U|) => // m IHm U leUm sZU sUG.
  have [<- | neZU] := eqVneq Z U.
    by rewrite -oZ Lagrange // (setIidPl _) // centsC subsetIr.
  have{neZU} [x Gx not_cUx]: exists2 x, x \in G & x \notin 'C(U).
    by apply/subsetPn; rewrite eqEsubset sZU subsetI sUG centsC in neZU.
  pose W := 'C_U[x]; have iWU: #|U : W| = p by rewrite iC1U // inE not_cUx.
  have maxW: maximal W U by rewrite p_index_maximal ?subsetIl ?iWU.
  have ltWU: W \proper U by exact: maxgroupp maxW.
  have [sWU [u Uu notWu]] := properP ltWU.
  have defU: W * <[u]> = U.
    have nsWU: W <| U := p_maximal_normal (pgroupS sUG pG) maxW.
    by rewrite (mulg_normal_maximal nsWU) ?cycle_subG.
  have sWG := subset_trans sWU sUG.
  have sZW: Z \subset W.
    by rewrite subsetI sZU -cent_set1 subIset ?centS ?orbT ?sub1set.
  have iCW_CU: #|'C_G(W) : 'C_G(U)| = p.
    rewrite -defU centM cent_cycle setIA /= -/W.
    rewrite iC1U ?subsetIl ?setIS ?centS // inE andbC (subsetP sUG) //=.
    rewrite -sub_cent1; apply/subsetPn; exists x.
      by rewrite inE Gx -sub_cent1 subsetIr.
    by rewrite -defU centM cent_cycle inE -sub_cent1 subsetIr in not_cUx.
  apply/eqP; rewrite -(eqn_pmul2r p_gt0) -{1}iCW_CU Lagrange ?setIS ?centS //.
  rewrite IHm ?(leq_trans (proper_card ltWU)) //= -/W.
  by rewrite -(Lagrange_index sUG sWU) iWU mulnA.
have oCY: #|'C_G(Y)| = (p ^ 2)%N by rewrite oCG // iYG.
have [x cYx notZx]: exists2 x, x \in 'C_G(Y) & x \notin Z.
  apply/subsetPn; rewrite proper_subn // properEcard setIS ?centS //=.
  by rewrite oZ oCY (ltn_exp2l 1 2).
have{cYx} [Gx cYx] := setIP cYx; have nZx := subsetP nZG x Gx.
have defCx: 'C_G[x] = Y.
  apply/eqP; rewrite eq_sym eqEcard subsetI sYG sub_cent1 cYx /=.
  rewrite -(leq_pmul2r p_gt0) -{2}iYG -(iC1U G x) ?Lagrange ?subsetIl //.
  by rewrite !inE Gx ?andbT in notZx *.
have Yx: x \in Y by rewrite -defCx inE Gx cent1id.
have ox: #[x] = p.
  by apply: nt_prime_order; rewrite ?(exponentP expY) // (group1_contra notZx).
have defCy: 'C_G(Y) = Z * <[x]>.
  apply/eqP; rewrite eq_sym eqEcard mulG_subG setIS ?centS //=.
  rewrite cycle_subG inE Gx cYx oCY TI_cardMg ?oZ -?orderE ?ox //=.
  by rewrite setIC prime_TIg -?orderE ?ox ?cycle_subG.
have abelYt: p.-abelem (Y / Z).
  by rewrite (abelemS (quotientS _ sYG)) //= -/Z -defPhiG Phi_quotient_abelem.
have Yxt: coset Z x \in Y / Z by rewrite mem_quotient.
have{Yxt} [Et [sEtYt oEt defYt]] := p_abelem_split1 abelYt Yxt.
have nsZY: Z <| Y := normalS sZY sYG nsZG.
have [E defEt sZE sEY] := inv_quotientS nsZY sEtYt.
have{defYt} [_ defYt _ tiXEt] := dprodP defYt.
have defY: <[x]> \x E = Y.
  have nZX: <[x]> \subset 'N(Z) by rewrite cycle_subG.
  have TIxE: <[x]> :&: E = 1.
    rewrite prime_TIg -?orderE ?ox // -(quotientSGK _ sZE) ?quotient_cycle //.
    rewrite (sameP setIidPl eqP) eq_sym -defEt tiXEt -quotient_cycle //.
    by rewrite -subG1 quotient_sub1 // cycle_subG.
  rewrite dprodE //; last 1 first.
    by rewrite cent_cycle (subset_trans sEY) //= -/Y -defCx subsetIr.
  rewrite -[Y](quotientGK nsZY) -defYt cosetpreM -quotient_cycle //.
  rewrite quotientK // -(normC nZX) defEt quotientGK ?(normalS _ sEY) //.
  by rewrite -mulgA (mulSGid sZE).
have sEG := subset_trans sEY sYG; have nZE := subset_trans sEG nZG.
have defZE: 'Z(E) = Z.
  apply/eqP; rewrite eqEsubset andbC subsetI sZE subIset ?centS ?orbT //.
  rewrite -quotient_sub1 ?subIset ?nZE //= -tiXEt defEt subsetI andbC.
  rewrite quotientS ?center_sub //= -quotient_cycle //.
  rewrite -(quotientMidl _ <[x]>) /= -defCy quotientS // /Y.
  by case/dprodP: defY => _ <- _ _; rewrite centM setIA cent_cycle defCx setSI.
have pE := pgroupS sEG pG.
rewrite iYG; split=> // _; exists E.
split=> //; first 2 [by exists [group of <[x]>]].
  have:= sZE; rewrite subEproper; case/predU1P=> [<- | ltZE]; [by left | right].
  split; rewrite /special defZE ?oZ // (Phi_joing pE).
  have defE': E^`(1) = Z.
    have sE'Z: E^`(1) \subset Z by rewrite -defG' dergS.
    apply/eqP; rewrite eqEcard sE'Z -(prime_nt_dvdP _ _ (cardSg sE'Z)) ?oZ //=.
    rewrite -trivg_card1 (sameP eqP commG1P).
    by rewrite /proper sZE /= -/Z -defZE subsetI subxx in ltZE.
  split=> //; rewrite -defE'; apply/joing_idPl.
  by rewrite /= defE' -defPhiG (Phi_joing pG) joingC sub_gen ?subsetU ?MhoS.
have iEG: #|G : E| = (p ^ 2)%N.
  apply/eqP; rewrite -(@eqn_pmul2l #|E|) // Lagrange // -(Lagrange sYG) iYG.
  by rewrite -(dprod_card defY) -mulnA mulnCA -orderE ox.
pose M := 'C_G(E); exists [group of M] => /=.
have sMG: M \subset G := subsetIl _ _; have pM: p.-group M := pgroupS sMG pG.
have sZM: Z \subset M by rewrite setIS ?centS.
have oM: #|M| = (p ^ 3)%N by rewrite oCG ?iEG.
have defME: M * E = G.
  apply/eqP; rewrite eqEcard mulG_subG sMG sEG /= -(leq_pmul2r p_gt0).
  rewrite -{2}oZ -defZE /('Z(E)) -{2}(setIidPr sEG) setIAC -mul_cardG /= -/M.
  by rewrite -(Lagrange sEG) mulnAC -mulnA mulnC iEG oM.
have defZM: 'Z(M) = Z.
  apply/eqP; rewrite eqEsubset andbC subsetI sZM subIset ?centS ?orbT //=.
  by rewrite /Z /('Z(G)) -{2}defME centM setIA setIAC.
rewrite cprodE 1?centsC ?subsetIr //.
rewrite defME setIAC (setIidPr sEG) defZM isoMod3 //.
  rewrite abelianE (sameP setIidPl eqP) eqEcard subsetIl /= -/('Z(M)) -/M.
  by rewrite defZM oZ oM (leq_exp2l 3 1).
by apply: contra neYG => sMY; rewrite eqEsubset sYG -defME mulG_subG sMY.
Qed.

(* This is the uniqueness half of Aschbacher (23.13); the proof incorporates *)
(* in part the proof that symplectic spaces are hyperbolic (19.16).          *)
Lemma isog_pX1p2n n (gT : finGroupType) (G : {group gT}) :
    prime p -> extraspecial G -> #|G| = (p ^ n.*2.+1)%N -> exponent G %| p ->
  G \isog p^{1+2*n}.
Proof.
move=> p_pr esG oG expG; have p_gt1 := prime_gt1 p_pr.
have not_le_p3_p: ~~ (p ^ 3 <= p) by rewrite (leq_exp2l 3 1).
have pG: p.-group G by rewrite /pgroup oG pnat_exp pnat_id.
have oZ := card_center_extraspecial pG esG.
have{pG esG} [Es p3Es defG] := extraspecial_structure pG esG.
set Z := 'Z(G) in oZ defG p3Es.
elim: Es {+}G => [|E Es IHs] S in n oG expG p3Es defG *.
  rewrite big_nil cprod1g in defG; rewrite -defG.
  have ->: n = 0%N.
    apply: double_inj; apply/eqP.
    by rewrite -eqSS -(eqn_exp2l _ _ p_gt1) -oG -defG oZ.
  by rewrite isog_cyclic_card prime_cyclic ?oZ ?card_pX1p2n //=.
rewrite big_cons -cprodA in defG; rewrite /= -andbA in p3Es.
have [[_ T _ defT] defET cTE] := cprodP defG; rewrite defT in defET cTE defG.
case/and3P: p3Es; move/eqP=> oE; move/eqP=> defZE; move/IHs=> {IHs}IHs.
have not_cEE: ~~ abelian E.
  by apply: contra not_le_p3_p => cEE; rewrite -oE -oZ -defZE (center_idP _).
have sES: E \subset S by rewrite -defET mulG_subl.
have sTS: T \subset S by rewrite -defET mulG_subr.
have expE: exponent E %| p by exact: dvdn_trans (exponentS sES) expG.
have expT: exponent T %| p by exact: dvdn_trans (exponentS sTS) expG.
have{expE not_cEE} isoE: E \isog p^{1+2}.
  apply: isog_pX1p2 => //.
  by apply: card_p3group_extraspecial p_pr oE _; rewrite defZE.
have sZT: 'Z(E) \subset T.
  by case/cprodP: defT => [[U _ -> _] <- _]; rewrite defZE mulG_subr.
case def_n: n => [|n'].
  case/negP: not_le_p3_p; rewrite def_n in oG; rewrite -oE -[p]oG.
  exact: subset_leq_card.
have zI_ET: E :&: T = 'Z(E).
  by apply/eqP; rewrite eqEsubset subsetI sZT subsetIl setIS // centsC.
have{n def_n oG} oT: #|T| = (p ^ n'.*2.+1)%N.
  apply/eqP; rewrite -(eqn_pmul2l (cardG_gt0 E)) mul_cardG zI_ET defET.
  by rewrite defZE oE oG oZ -expnSr -expnD def_n.
have{IHs oT expT defT Es} isoT: T \isog p^{1+2*n'} by rewrite IHs.
case: pX1p2S => gz isoZ; rewrite (isog_cprod_by _ defG) //.
exact: Aut_extraspecial_full (pX1p2_pgroup p_pr) (pX1p2_extraspecial p_pr).
Qed.

End GeneralExponentPextraspecialTheory.

Lemma isog_2X1p2 : 2^{1+2} \isog 'D_8.
Proof.
have pr2: prime 2 by []; have oG := card_pX1p2 pr2; rewrite -[8]oG.
case/existsP: (isoGrp_hom (Grp_pX1p2 pr2)) => [[x y]] /=.
rewrite -/2^{1+2}; case/eqP=> defG x2 y2 _ _.
have not_oG_2: ~~ (#|2^{1+2}| %| 2) by rewrite oG.
have ox: #[x] = 2.
  apply: nt_prime_order => //; apply: contra not_oG_2 => x1.
  by rewrite -defG (eqP x1) cycle1 joing1G order_dvdn y2.
have oy: #[y] = 2.
  apply: nt_prime_order => //; apply: contra not_oG_2 => y1.
  by rewrite -defG (eqP y1) cycle1 joingG1 order_dvdn x2.
rewrite -defG joing_idl joing_idr involutions_gen_dihedral //.
apply: contra not_oG_2 => eq_xy; rewrite -defG (eqP eq_xy) (joing_idPl _) //.
by rewrite -orderE oy.
Qed.

Lemma Q8_extraspecial : extraspecial 'Q_8.
Proof.
have gt32: 3 > 2 by []; have isoQ: 'Q_8 \isog 'Q_(2 ^ 3) by exact: isog_refl.
have [[x y] genQ _] := generators_quaternion gt32 isoQ.
have [_ [defQ' defPhiQ _ _]] := quaternion_structure gt32 genQ isoQ.
case=> defZ oZ _ _ _ _ _; split; last by rewrite oZ.
by split; rewrite ?defPhiQ defZ.
Qed.

Lemma DnQ_P n : xcprod_spec 'D^n 'Q_8 ('D^n*Q)%type.
Proof.
have pQ: 2.-group 'Q_(2 ^ 3) by rewrite /pgroup card_quaternion.
have{pQ} oZQ := card_center_extraspecial pQ Q8_extraspecial.
suffices oZDn: #|'Z('D^n)| = 2.
  by apply: xcprodP; rewrite isog_cyclic_card ?prime_cyclic ?oZQ ?oZDn.
have [-> | n_gt0] := posnP n; first by rewrite center_ncprod0 card_pX1p2n.
have pr2: prime 2 by []; have pDn := pX1p2n_pgroup n pr2.
exact: card_center_extraspecial (pX1p2n_extraspecial pr2 n_gt0).
Qed.

Lemma card_DnQ n : #|'D^n*Q| = (2 ^ n.+1.*2.+1)%N.
Proof.
have oQ: #|'Q_(2 ^ 3)| = 8 by rewrite card_quaternion.
have pQ: 2.-group 'Q_8 by rewrite /pgroup oQ.
case: DnQ_P => gz isoZ.
rewrite -im_cpair cardMg_divn setI_im_cpair cpair_center_id.
rewrite -injm_center 3?{1}card_injm ?injm_cpairg1 ?injm_cpair1g ?center_sub //.
rewrite oQ card_pX1p2n // (card_center_extraspecial pQ Q8_extraspecial).
by rewrite -muln_divA // mulnC -(expnD 2 2).
Qed.

Lemma DnQ_pgroup n : 2.-group 'D^n*Q.
Proof. by rewrite /pgroup card_DnQ pnat_exp. Qed.

(* Final part of the existence half of Aschbacher (23.14). *)
Lemma DnQ_extraspecial n : extraspecial 'D^n*Q.
Proof.
case: DnQ_P (DnQ_pgroup n) => gz isoZ pDnQ.
have [injDn injQ] := (injm_cpairg1 isoZ, injm_cpair1g isoZ).
have [n0 | n_gt0] := posnP n.
  rewrite -im_cpair mulSGid; first exact: injm_extraspecial Q8_extraspecial.
  apply/setIidPl; rewrite setI_im_cpair -injm_center //=.
  by congr (_ @* _); rewrite n0 center_ncprod0.
apply: (cprod_extraspecial pDnQ (im_cpair_cprod isoZ) (setI_im_cpair _)).
  exact: injm_extraspecial (pX1p2n_extraspecial _ _).
exact: injm_extraspecial Q8_extraspecial.
Qed.

(* A special case of the uniqueness half of Achsbacher (23.14). *)
Lemma card_isog8_extraspecial (gT : finGroupType) (G : {group gT}) :
  #|G| = 8 -> extraspecial G -> (G \isog 'D_8) || (G \isog 'Q_8).
Proof.
move=> oG esG; have pG: 2.-group G by rewrite /pgroup oG.
apply/norP=> [[notG_D8 notG_Q8]].
have not_extG: extremal_class G = NotExtremal.
  by rewrite /extremal_class oG andFb (negPf notG_D8) (negPf notG_Q8).
have [x Gx ox] := exponent_witness (pgroup_nil pG).
pose X := <[x]>; have cycX: cyclic X := cycle_cyclic x.
have sXG: X \subset G by rewrite cycle_subG.
have iXG: #|G : X| = 2.
  by rewrite -divgS // oG -orderE -ox exponent_2extraspecial.
have not_cGG := extraspecial_nonabelian esG.
have:= maximal_cycle_extremal pG not_cGG cycX sXG iXG.
by rewrite /extremal2 not_extG.
Qed.

(* The uniqueness half of Achsbacher (23.14). The proof incorporates in part  *)
(* the proof that symplectic spces are hyperbolic (Aschbacher (19.16)), and   *)
(* the determination of quadratic spaces over 'F_2 (21.2); however we use     *)
(* the second part of exercise (8.4) to avoid resorting to Witt's lemma and   *)
(* Galois theory as in (20.9) and (21.1).                                     *)
Lemma isog_2extraspecial (gT : finGroupType) (G : {group gT}) n :
  #|G| = (2 ^ n.*2.+1)%N -> extraspecial G -> G \isog 'D^n \/ G \isog 'D^n.-1*Q.
Proof.
elim: n G => [|n IHn] G oG esG.
  case/negP: (extraspecial_nonabelian esG).
  by rewrite cyclic_abelian ?prime_cyclic ?oG.
have pG: 2.-group G by rewrite /pgroup oG pnat_exp.
have oZ:= card_center_extraspecial pG esG.
have: 'Z(G) \subset 'Ohm_1(G).
  apply/subsetP=> z Zz; rewrite (OhmE _ pG) mem_gen //.
  by rewrite !inE -order_dvdn -oZ order_dvdG ?(subsetP (center_sub G)).
rewrite subEproper; case/predU1P=> [defG1 | ltZG1].
  have [n' n'_gt2 isoG]: exists2 n', n' > 2 & G \isog 'Q_(2 ^ n').
    apply/quaternion_classP; apply/eqP.
    have not_cycG: ~~ cyclic G.
      by apply: contra (extraspecial_nonabelian esG); exact: cyclic_abelian.
    move: oZ; rewrite defG1; move/prime_Ohm1P; rewrite (negPf not_cycG) /=.
    by apply=> //; apply: contra not_cycG; move/eqP->; exact: cyclic1.
  have [n0 n'3]: n = 0%N /\ n' = 3.
    have [[x y] genG _] := generators_quaternion n'_gt2 isoG.
    have n'3: n' = 3.
      have [_ [_ _ oG' _] _ _ _] := quaternion_structure n'_gt2 genG isoG.
      apply/eqP; rewrite -(subnKC (ltnW n'_gt2)) subn2 !eqSS -(@eqn_exp2l 2) //.
      by rewrite -oG' -oZ; case: esG => [[_ ->]].
    by move/eqP: oG; have [-> _ _ _] := genG; rewrite n'3 eqn_exp2l //; case n.
  right; rewrite (isog_trans isoG) // n'3 n0 /=.
  case: DnQ_P => z isoZ; rewrite -im_cpair mulSGid ?sub_isog ?injm_cpair1g //.
  apply/setIidPl; rewrite setI_im_cpair -injm_center ?injm_cpairg1 //.
  by rewrite center_ncprod0.
case/andP: ltZG1 => _; rewrite (OhmE _ pG) gen_subG.
case/subsetPn=> x; case/LdivP=> Gx x2 notZx.
have ox: #[x] = 2 by exact: nt_prime_order (group1_contra notZx).
have Z'x: x \in G :\: 'Z(G) by rewrite inE notZx.
have [E [R [[oE oR] [defG ziER]]]] := split1_extraspecial pG esG Z'x.
case=> defZE defZR [esE Ex] esR.
have isoE: E \isog 2^{1+2}.
  apply: isog_trans (isog_symr isog_2X1p2).
  case/orP: (card_isog8_extraspecial oE esE) => // isoE; case/negP: notZx.
  have gt32: 3 > 2 by [].
  have [[y z] genE _] := generators_quaternion gt32 isoE.
  have [_ _ [defZx _ eq_y2 _ _] _ _] := quaternion_structure gt32 genE isoE.
  by rewrite (eq_y2 x) // -cycle_subG -defZx defZE.
rewrite oG doubleS 2!expnS divnMl ?mulKn // in oR.
case: ifP esR => [_ defR | _ esR].
  have ->: n = 0%N by move/eqP: oR; rewrite defR oZ (eqn_exp2l 1) //; case n.
  left; apply: isog_trans (isog_symr (ncprod1 _)).
  by rewrite -defG defR -defZE cprod_center_id.
have AutZin2_1p2: Aut_in (Aut 2^{1+2}) 'Z(2^{1+2}) \isog Aut 'Z(2^{1+2}).
  exact: Aut_extraspecial_full (pX1p2_pgroup _) (pX1p2_extraspecial _).
have [isoR | isoR] := IHn R oR esR.
  by left; case: pX1p2S => gz isoZ; rewrite (isog_cprod_by _ defG).
have n_gt0: n > 0.
  have pR: 2.-group R by rewrite /pgroup oR pnat_exp.
  have:= min_card_extraspecial pR esR.
  by rewrite oR leq_exp2l // ltnS (leq_double 1).
case: DnQ_P isoR => gR isoZR /=; rewrite isog_sym; case/isogP=> fR injfR im_fR.
have [injDn injQ] := (injm_cpairg1 isoZR, injm_cpair1g isoZR).
pose Dn1 := cpairg1 isoZR @* 'D^n.-1; pose Q := cpair1g isoZR @* 'Q_8.
have defR: fR @* Dn1 \* fR @* Q = R.
  rewrite cprodE ?morphim_cents ?im_cpair_cent //.
  by rewrite -morphimMl ?subsetT ?im_cpair.
rewrite -defR cprodA in defG.
have [[Dn _ defDn _] _ _] := cprodP defG; rewrite defDn in defG.
have isoDn: Dn \isog 'D^n.
  rewrite -(prednK n_gt0); case: pX1p2S => gz isoZ.
  rewrite (isog_cprod_by _ defDn) //; last 1 first.
    by rewrite isog_sym (isog_trans _ (sub_isog _ _)) ?subsetT // sub_isog.
  rewrite /= -morphimIim im_fR setIA ziER; apply/setIidPl.
  rewrite defZE -defZR -{1}im_fR -injm_center // morphimS //.
  by rewrite -cpairg1_center morphimS // center_sub.
right; case: DnQ_P => gz isoZ; rewrite (isog_cprod_by _ defG) //; first 1 last.
- exact: Aut_extraspecial_full (pX1p2n_pgroup _ _) (pX1p2n_extraspecial _ _).
- by rewrite isog_sym (isog_trans _ (sub_isog _ _)) ?subsetT // sub_isog.
rewrite /= -morphimIim; case/cprodP: defDn => _ defDn cDn1E.
rewrite setICA setIA -defDn -group_modr ?morphimS ?subsetT //.
rewrite /= im_fR (setIC R) ziER -center_prod // defZE -defZR.
rewrite mulSGid /=; last first.
  by rewrite -{1}im_fR -injm_center // -cpairg1_center !morphimS ?center_sub.
rewrite -injm_center ?subsetT // -injmI // setI_im_cpair.
by rewrite -injm_center // cpairg1_center injm_center // im_fR mulGid.
Qed.

(* The first concluding remark of Aschbacher (23.14). *)
Lemma rank_Dn n : 'r_2('D^n) = n.+1.
Proof.
elim: n => [|n IHn]; first by rewrite p_rank_abelem ?prime_abelem ?card_pX1p2n.
have oDDn: #|'D^n.+1| = (2 ^ n.+1.*2.+1)%N by exact: card_pX1p2n.
have esDDn: extraspecial 'D^n.+1 by exact: pX1p2n_extraspecial.
do [case: pX1p2S => gz isoZ; set DDn := [set: _]] in oDDn esDDn *.
have pDDn: 2.-group DDn by rewrite /pgroup oDDn pnat_exp.
apply/eqP; rewrite eqn_leq; apply/andP; split.
  have [E EprE]:= p_rank_witness 2 [group of DDn].
  have [sEDDn abelE <-] := pnElemP EprE; have [pE cEE _]:= and3P abelE.
  rewrite -(@leq_exp2l 2) // -p_part part_pnat_id // -leq_sqr -expnM -mulnn.
  rewrite muln2 doubleS expnS -oDDn -(@leq_pmul2r #|'C_DDn(E)|) ?cardG_gt0 //.
  rewrite {1}(card_subcent_extraspecial pDDn) // mulnCA -mulnA Lagrange //=.
  rewrite mulnAC mulnA leq_pmul2r ?cardG_gt0 // setTI.
  have ->: (2 * #|'C(E)| = #|'Z(DDn)| * #|'C(E)|)%N.
    by rewrite (card_center_extraspecial pDDn).
  by rewrite leq_mul ?subset_leq_card ?subsetIl.
have [inj1 injn] := (injm_cpairg1 isoZ, injm_cpair1g isoZ).
pose D := cpairg1 isoZ @* 2^{1+2}; pose Dn := cpair1g isoZ @* 'D^n.
have [E EprE] := p_rank_witness 2 [group of Dn].
rewrite injm_p_rank //= IHn in EprE; have [sEDn abelE dimE]:= pnElemP EprE.
have [x [Dx ox] notDnx]: exists x, [/\ x \in D, #[x] = 2 & x \notin Dn].
  have isoD: D \isog 'D_(2 ^ 3).
    by rewrite isog_sym -(isog_transl _ isog_2X1p2) sub_isog.
  have [//| [x y] genD [oy _]] := generators_2dihedral _ isoD.
  have [_ _ _ X'y] := genD; case/setDP: X'y; rewrite /= -/D => Dy notXy.
  exists y; split=> //; apply: contra notXy => Dny.
  case/dihedral2_structure: genD => // _ _ _ _ [defZD _ _ _ _].
  by rewrite (subsetP (cycleX x 2)) // -defZD -setI_im_cpair inE Dy.
have def_xE: <[x]> \x E = <[x]> <*> E.
  rewrite dprodEY ?prime_TIg -?orderE ?ox //.
    by rewrite (centSS sEDn _ (im_cpair_cent _)) ?cycle_subG.
  by rewrite cycle_subG (contra (subsetP sEDn x)).
apply/p_rank_geP; exists (<[x]> <*> E)%G.
rewrite 2!inE subsetT (dprod_abelem _ def_xE) abelE -(dprod_card def_xE).
by rewrite prime_abelem -?orderE ?ox //= lognM ?cardG_gt0 ?dimE.
Qed.

(* The second concluding remark of Aschbacher (23.14). *)
Lemma rank_DnQ n : 'r_2('D^n*Q) = n.+1.
Proof.
have pDnQ: 2.-group 'D^n*Q := DnQ_pgroup n.
have esDnQ: extraspecial 'D^n*Q := DnQ_extraspecial n.
do [case: DnQ_P => gz isoZ; set DnQ := setT] in pDnQ esDnQ *.
suffices [E]: exists2 E, E \in 'E*_2(DnQ) & logn 2 #|E| = n.+1.
  by rewrite (pmaxElem_extraspecial pDnQ esDnQ); case/pnElemP=> _ _ <-.
have oZ: #|'Z(DnQ)| = 2 by exact: card_center_extraspecial.
pose Dn := cpairg1 isoZ @* 'D^n; pose Q := cpair1g isoZ @* 'Q_8.
have [injDn injQ] := (injm_cpairg1 isoZ, injm_cpair1g isoZ).
have [E EprE]:= p_rank_witness 2 [group of Dn].
have [sEDn abelE dimE] := pnElemP EprE; have [pE cEE eE]:= and3P abelE.
rewrite injm_p_rank // rank_Dn in dimE; exists E => //.
have sZE: 'Z(DnQ) \subset E.
  have maxE := subsetP (p_rankElem_max _ _) E EprE.
  have abelZ: 2.-abelem 'Z(DnQ) by rewrite prime_abelem ?oZ.
  rewrite -(Ohm1_id abelZ) (OhmE _ (abelem_pgroup abelZ)) gen_subG.
  rewrite -(pmaxElem_LdivP _ maxE) // setSI //=.
  by rewrite -cpairg1_center injm_center // setIS ?centS.
have scE: 'C_Dn(E) = E.
  apply/eqP; rewrite eq_sym eqEcard subsetI sEDn -abelianE cEE /=.
  have [n0 | n_gt0] := posnP n.
    rewrite subset_leq_card // subIset // (subset_trans _ sZE) //.
    by rewrite -cpairg1_center morphimS // n0 center_ncprod0.
  have pDn: 2.-group Dn by rewrite morphim_pgroup ?pX1p2n_pgroup.
  have esDn: extraspecial Dn.
    exact: injm_extraspecial (pX1p2n_extraspecial _ _).
  rewrite dvdn_leq ?cardG_gt0 // (card_subcent_extraspecial pDn) //=.
  rewrite -injm_center // cpairg1_center (setIidPl sZE) oZ.
  rewrite -(dvdn_pmul2l (cardG_gt0 E)) mulnn mulnCA Lagrange //.
  rewrite card_injm ?card_pX1p2n // -expnS pfactor_dvdn ?expn_gt0 ?cardG_gt0 //.
  by rewrite lognX dimE mul2n.
apply/pmaxElemP; split=> [|F E2F sEF]; first by rewrite inE subsetT abelE.
have{E2F} [_ abelF] := pElemP E2F; have [pF cFF eF] := and3P abelF.
apply/eqP; rewrite eqEsubset sEF andbT; apply/subsetP=> x Fx.
have DnQx: x \in Dn * Q by rewrite im_cpair inE.
have{DnQx} [y z Dn_y Qz def_x]:= imset2P DnQx.
have{Dn_y} Ey: y \in E.
  have cEz: z \in 'C(E).
    by rewrite (subsetP (centS sEDn)) // (subsetP (im_cpair_cent _)).
  rewrite -scE inE Dn_y -(groupMr _ cEz) -def_x (subsetP (centS sEF)) //.
  by rewrite (subsetP cFF).
rewrite def_x groupMl // (subsetP sZE) // -cpair1g_center injm_center //= -/Q.
have: z \in 'Ohm_1(Q).
  rewrite (OhmE 1 (pgroupS (subsetT Q) pDnQ)) mem_gen // !inE Qz /=.
  rewrite -[z](mulKg y) -def_x (exponentP eF) ?groupM //.
  by rewrite groupV (subsetP sEF).
have isoQ: Q \isog 'Q_(2 ^ 3) by rewrite isog_sym sub_isog.
have [//|[u v] genQ _] := generators_quaternion _ isoQ.
by case/quaternion_structure: genQ => // _ _ [-> _ _ [-> _] _] _ _.
Qed.

(* The final concluding remark of Aschbacher (23.14). *)
Lemma not_isog_Dn_DnQ n : ~~ ('D^n \isog 'D^n.-1*Q).
Proof.
case: n => [|n] /=; first by rewrite isogEcard card_pX1p2n // card_DnQ andbF.
apply: contraL (leqnn n.+1) => isoDn1DnQ.
by rewrite -ltnNge -rank_Dn (isog_p_rank isoDn1DnQ) rank_DnQ.
Qed.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType ReflParam.indProp.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Print sig.

Inductive sigs (A : Set) (P : A -> Prop) : Prop :=
 existss : forall x : A, P x -> sigs A P.

Run TemplateProgram (genParamIndPropAll [] "Top.exists.sigs").


Require Import Algebra.Functor Algebra.Applicative Algebra.SetoidCat Algebra.SetoidCat.PairUtils Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Algebra.SetoidUtils Algebra.Monad Tactics Utils Monoid.
Require Import SetoidClass.

Existing Instance ConstS.

Section Settable.

  Context
    {A B}
    {AS : Setoid A}
    {BS : Setoid B}
    {t}
    {tS : Setoid t}.

  Class Settable :=
    {
      set : tS ~> BS ~~> AS ~~> AS;
    }.

End Settable.

Section PreLens.

  Context
    {A B}
    {AS : Setoid A}
    {BS : Setoid B}
    {t}
    {tS : Setoid t}
    {sett : @Settable A B AS BS t tS}.

  Class PreLens :=
    {
      view : tS ~> AS ~~> BS;
      set_view: forall l a, set @ l @ (view @ l @ a) @ a == a
    }.

End PreLens.

Section Preview.

  Context
    {A B}
    {AS : Setoid A}
    {BS : Setoid B}
    {t}
    {tS : Setoid t}
    {sett : @Settable A B AS BS t tS}.

  Class Preview  :=
    {
      preview : tS ~> AS ~~> maybeS BS;
      preview_set_Some : forall l a b b2, preview @ l @ a == Some b2 ->
                                          preview @ l @ (set @ l @ b @ a) == Some b;
      preview_set_None : forall l a b, preview @ l @ a == None ->
                                          preview @ l @ (set @ l @ b @ a) == None;
      set_preview_Some: forall l a b, preview @ l @ a == Some b ->
                                      set @ l @ b @ a == a;
      set_preview_None: forall l a b, preview @ l @ a == None ->
                                      set @ l @ b @ a == a
    }.

  Definition _pset_set (ps : tS ~> BS ~~> AS ~~> AS) (l: t) (b: maybe B) (a: A) : A :=
    caseMaybeS
      @ (cycle23S @ ps @ l @ a)
      @ a
      @ b.

  Instance _pset_set_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv ==> equiv) _pset_set.
  Proof.
    solve_properS _pset_set.
  Qed.

  Definition pset_set := injF4 _pset_set _.

  Instance Preview_Maybe_Settable (prv : Preview) : @Settable A (maybe B) _ _ t tS.
  Proof.
    split.
    exact (pset_set @ set).
  Defined.

  Instance Preview_PreLens (prv : Preview) : @PreLens A (maybe B) _ _ t tS _.
  Proof.
    exists (preview) .
    intros. simpl. unfold _pset_set. simpl. unfold caseMaybe. simpl. destruct (maybe_case (preview @ l @ a)).
    - rewrite H. reflexivity.
    - destruct H. rewrite H. apply set_preview_Some. rewrite H. reflexivity.
  Defined.

End Preview.

Section Lens.

  Context
    {A B}
    {AS : Setoid A}
    {BS : Setoid B}
    {t}
    {tS : Setoid t}
    {sett}
    {pl : @PreLens A B AS BS t tS sett}.

  Class Lens :=
    {
      set_set : forall (l : t) (a : A) (b1 b2 : B), set @ l @ b2 @ (set @ l @ b1 @ a) == set @ l @ b2 @ a;
      view_set : forall (l : t) (a : A) (b : B), view @ l @ (set @ l @ b @ a) == b
    }.

  Definition Lens_preview : tS ~> AS ~~> maybeS BS := comp2S @ view @ SomeS.
  Instance Lens_Preview (ls : Lens) : @Preview A B AS BS t tS sett.
  Proof.
    exists (Lens_preview).
    intros. simpl in *. rewrite view_set. reflexivity.
    intros. simpl in *. auto.
    intros. simpl in *. rewrite <- H. rewrite set_view. reflexivity.
    intros. simpl in *. tauto.
  Defined.

End Lens.

Section ComposePreLens.
  Context
    {A B C}
    {AS : Setoid A}
    {BS : Setoid B}
    {CS : Setoid C}
    {t}
    {tS : Setoid t}
    {sett}
    {pl : @PreLens A B AS BS t tS sett}
    {t2}
    {t2S : Setoid t2}
    {sett2}
    {pl2 : @PreLens B C BS CS t2 t2S sett2}.

  Inductive ComposeL := ComposeLIso : t -> t2 -> ComposeL.

  Definition ComposeL_equiv l l' :=
    match l, l' with
      | ComposeLIso l1 l2, ComposeLIso l1' l2' => l1 == l1' /\ l2 == l2'
    end.

  Instance ComposeL_equiv_Equivalence : Equivalence ComposeL_equiv.
  Proof.
    split.
    autounfold. intros. destruct x.  simpl.  split; [reflexivity | reflexivity].
    autounfold. intros. destruct x, y. destruct H. split; [symmetry ; auto | symmetry ; auto].
    autounfold. intros. destruct x, y, z. destruct H, H0. split; [transitivity t3; [auto | auto] | transitivity t4; [auto | auto]].
  Qed.

  Instance ComposeLS : Setoid ComposeL :=
    {
      equiv := ComposeL_equiv
    }
  .

  Definition _ComposeL_view l : AS ~> CS :=
    match l with
      | ComposeLIso l1 l2 => view @ l2 ∘ view @ l1
    end.

  Instance _ComposeL_view_Proper : Proper (equiv ==> equiv) _ComposeL_view.
  Proof.
    autounfold. intros. destruct x,y. destruct H. simpl. arrequiv. rewritesr.
  Qed.

  Definition ComposeL_view : ComposeLS ~> AS ~~> CS := injF _ComposeL_view _.

  Definition _ComposeL_set l (c : C) (a : A) : A :=
    match l with
      | ComposeLIso l1 l2 => set @ l1 @ (set @ l2 @ c @ (view @ l1 @ a)) @ a
    end.

  Instance _ComposeL_set_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) _ComposeL_set.
  Proof.
    autounfold. intros. destruct x, y. destruct H. simpl. rewritesr.
  Qed.

  Definition ComposeL_set := injF3 _ComposeL_set _.

  Instance ComposeL_Settable : @Settable A C AS CS ComposeL ComposeLS.
  Proof.
    split.
    exact ComposeL_set.
  Defined.

  Instance ComposeL_PreLens : @PreLens A C AS CS ComposeL ComposeLS _.
  Proof.
    exists ComposeL_view .
    intros. destruct l. simpl. rewrite set_view. rewrite set_view. reflexivity.
  Defined.

End ComposePreLens.

Section ComposePreview.
  Context
    {A B C}
    {AS : Setoid A}
    {BS : Setoid B}
    {CS : Setoid C}
    {t}
    {tS : Setoid t}
    {sett}
    {prv : @Preview A B AS BS t tS sett}
    {t2}
    {t2S : Setoid t2}
    {sett2}
    {prv2 : @Preview B C BS CS t2 t2S sett2}.

  Inductive ComposeP := ComposePIso : t -> t2 -> ComposeP.

  Definition ComposeP_equiv l l' :=
    match l, l' with
      | ComposePIso l1 l2, ComposePIso l1' l2' => l1 == l1' /\ l2 == l2'
    end.

  Instance ComposeP_equiv_Equivalence : Equivalence ComposeP_equiv.
  Proof.
    split.
    autounfold. intros. destruct x.  simpl.  split; [reflexivity | reflexivity].
    autounfold. intros. destruct x, y. destruct H. split; [symmetry ; auto | symmetry ; auto].
    autounfold. intros. destruct x, y, z. destruct H, H0. split; [transitivity t3; [auto | auto] | transitivity t4; [auto | auto]].
  Qed.

  Instance ComposePS : Setoid ComposeP :=
    {
      equiv := ComposeP_equiv
    }
  .

  Definition _ComposeP_preview (l :ComposeP ) (a : A) : maybe C :=
    match l with
      | ComposePIso l1 l2 =>
        caseMaybeS
          @ (preview @ l2)
          @ None
          @ (preview @ l1 @ a)
    end.

  Instance _ComposeP_preview_Proper : Proper (equiv ==> equiv ==> equiv) _ComposeP_preview.
  Proof.
    autounfold. intros. destruct x,y. destruct H. unfold _ComposeP_preview.   rewritesr.
  Qed.

  Definition ComposeP_preview := injF2 _ComposeP_preview _.

  Definition _ComposeP_Preview_set (l : ComposeP) (c : C) (a : A) : A :=
    match l with
      | ComposePIso l1 l2 =>
        caseMaybeS
          @ (flipS @ (set @ l1) @ a ∘ set @ l2 @ c)
          @ a
          @ (preview @ l1 @ a)
    end.

  Instance _ComposeP_Preview_set_Proper : Proper (equiv ==> equiv ==> equiv ==> equiv) _ComposeP_Preview_set.
  Proof.
    autounfold. intros. destruct x,y. destruct H. unfold _ComposeP_Preview_set. rewritesr.
  Qed.

  Definition ComposeP_Preview_set : (ComposePS) ~> CS ~~> AS ~~> AS := injF3 _ComposeP_Preview_set _.

  Instance ComposeP_Settable : @Settable A C AS CS (ComposeP) (ComposePS).
  Proof.
    split.
    exact ComposeP_Preview_set.
  Defined.

  Instance ComposeP_Preview : @Preview A C AS CS (ComposeP) (ComposePS) _.
  Proof.
    exists ComposeP_preview.
    - intros. destruct l. unfold ComposeP_preview, _ComposeP_preview in *. normalize. unfold injF2 in H. repeat rewrite eval_injF in H. destruct (maybe_case (preview @ t0 @ a)).
      + rewrite H0 in H. simpl in H. tauto.
      + destruct H0. rewrite H0 in *. simpl set.  unfold ComposeP_Preview_set, _ComposeP_Preview_set. normalize. rewrite H0. simpl ((caseMaybeS @ (flipS @ (set @ t0) @ a ∘ set @ t1 @ b) @ a @ Some x)). rewrite @preview_set_Some with (b2:=x); [| rewrite H0; reflexivity]. Opaque equiv. simpl in *. destruct (maybe_case (preview @ t1 @ x)).
        *   rewrite H1 in H. inversion H.
        * destruct H1. apply @preview_set_Some with (b2:=x0). rewrite H1. reflexivity.
    - intros. destruct l. simpl in *. destruct (maybe_case (preview @ t0 @ a)).
      + rewrite H0 in *. simpl in *. rewrite H0. reflexivity.
      + destruct H0. rewrite H0 in *. simpl in *. rewrite @preview_set_Some with (b2:=x); [| rewrite H0; reflexivity]. simpl. apply preview_set_None. auto.
    - intros. destruct l. simpl in *. destruct (maybe_case (preview @ t0 @ a)).
      + rewrite H0 in *. simpl in *. reflexivity.
      + destruct H0. rewrite H0 in *. simpl in *. rewrite set_preview_Some. reflexivity. rewrite H0. rewrite set_preview_Some. reflexivity. auto.
    - intros. destruct l. simpl in *. destruct (maybe_case (preview @ t0 @ a)).
      + rewrite H0 in *. simpl in *. reflexivity.
      + destruct H0. rewrite H0 in *. simpl in *. rewrite set_preview_Some. reflexivity. rewrite H0. rewrite set_preview_None. reflexivity. auto.
  Defined.

End ComposePreview.

Section ComposeLens.
  Context
    {A B C}
    {AS : Setoid A}
    {BS : Setoid B}
    {CS : Setoid C}
    {t}
    {tS : Setoid t}
    {sett pl }
    {ls : @Lens A B AS BS t tS sett pl}
    {t2}
    {t2S : Setoid t2}
    {sett2 pl2}
    {ls2 : @Lens B C BS CS t2 t2S sett2 pl2}.

  Existing Instance ComposeL_Settable.
  Existing Instance ComposeL_PreLens.
  Instance ComposeL_Lens : @Lens A C AS CS (@ComposeL t t2) (@ComposeLS t tS t2 t2S) _ _.
  Proof.
    split.
    intros. destruct l. simpl. rewrite set_set. rewrite view_set. rewrite set_set. reflexivity.
    intros. destruct l. simpl. rewrite view_set. rewrite view_set. reflexivity.
  Qed.

End ComposeLens.

Notation "a >>> b" := (ComposeLIso a b) (at level 45, left associativity).
Notation "a >>>? b" := (ComposePIso a b) (at level 45, left associativity).

Existing Instance ComposePS.
Existing Instance ComposeP_Preview.
Existing Instance ComposeP_Settable.
Existing Instance maybe_Monad.

Lemma preview_comp :
  forall {A} {B} {C} {AS : Setoid A} {BS : Setoid B} {CS : Setoid C} {t tS sett}
         {prv : @Preview A B AS BS t tS sett}
         {t2 t2S sett2}
         {prv2 : @Preview B C BS CS t2 t2S sett2} (l : t) (l2 : t2),
    preview @ (l >>>? l2) == preview @ l >=> (preview @ l2 : BS ~> maybeS CS).
Proof.
  intros. simpl. arrequiv.
Qed.


Require Import ListAux.
Require Import TreeAux.
Lemma splayhp1consistent_t0 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (u_0 = i_0))/\(not (tree_member  it_0 u_0))/\(tree_member  it_2 u_0)) -> (tree_member  it_1 u_0)).
Proof. solve_t. Qed.

Lemma splayhp1consistent_t1 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (tree_member  it_2 u_0))) -> (not (u_0 = i_0))).
Proof. solve_t. Qed.

Lemma splayhp1consistent_t2 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (tree_member  it_2 u_0))) -> (not (tree_member  it_0 u_0))).
Proof. solve_t. Qed.

Lemma splayhp1consistent_t3 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (tree_member  it_2 u_0))) -> (not (tree_member  it_1 u_0))).
Proof. solve_t. Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.

Require Import misc.

Section Bool_fun.

Definition var_env := BDDvar -> bool.

Definition bool_fun := var_env -> bool.

Definition bool_fun_eq (bf1 bf2 : bool_fun) :=
  forall vb : var_env, bf1 vb = bf2 vb.

Definition bool_fun_zero (vb : var_env) := false.

Definition bool_fun_one (vb : var_env) := true.

Definition bool_fun_neg (bf : bool_fun) : bool_fun :=
  fun vb : var_env => negb (bf vb).

Definition bool_fun_or (bf1 bf2 : bool_fun) : bool_fun :=
  fun vb : var_env => bf1 vb || bf2 vb.

Definition bool_fun_and (bf1 bf2 : bool_fun) : bool_fun :=
  fun vb : var_env => bf1 vb && bf2 vb.

Definition bool_fun_impl (bf1 bf2 : bool_fun) : bool_fun :=
  fun vb : var_env => implb (bf1 vb) (bf2 vb).

Definition bool_fun_iff (bf1 bf2 : bool_fun) : bool_fun :=
  fun vb : var_env => eqb (bf1 vb) (bf2 vb).

Definition bool_fun_if (x : BDDvar) (bf1 bf2 : bool_fun) : bool_fun :=
  fun vb : var_env => ifb (vb x) (bf1 vb) (bf2 vb).

Definition bool_fun_var (x : BDDvar) : bool_fun := fun vb : var_env => vb x.

Definition augment (vb : var_env) (x : BDDvar) (b : bool) : var_env :=
  fun y : BDDvar => if Neqb x y then b else vb y.

Definition bool_fun_restrict (bf : bool_fun) (x : BDDvar)
  (b : bool) : bool_fun := fun vb : var_env => bf (augment vb x b).

Definition bool_fun_independent (bf : bool_fun) (x : BDDvar) :=
  forall b : bool, bool_fun_eq (bool_fun_restrict bf x b) bf.

Definition bool_fun_forall (x : BDDvar) (bf : bool_fun) :=
  bool_fun_and (bool_fun_restrict bf x true) (bool_fun_restrict bf x false).

Definition bool_fun_ex (x : BDDvar) (bf : bool_fun) :=
  bool_fun_or (bool_fun_restrict bf x true) (bool_fun_restrict bf x false).

Definition bool_fun_ext (bf : bool_fun) :=
  forall vb vb' : var_env,
  (forall x : BDDvar, vb x = vb' x) -> bf vb = bf vb'.

Inductive bool_expr : Set :=
  | Zero : bool_expr
  | One : bool_expr
  | Var : BDDvar -> bool_expr
  | Neg : bool_expr -> bool_expr
  | Or : bool_expr -> bool_expr -> bool_expr
  | ANd : bool_expr -> bool_expr -> bool_expr
  | Impl : bool_expr -> bool_expr -> bool_expr
  | Iff : bool_expr -> bool_expr -> bool_expr.

Fixpoint bool_fun_of_bool_expr (be : bool_expr) : bool_fun :=
  match be with
  | Zero => bool_fun_zero
  | One => bool_fun_one
  | Var x => bool_fun_var x
  | Neg be' => bool_fun_neg (bool_fun_of_bool_expr be')
  | Or be1 be2 =>
      bool_fun_or (bool_fun_of_bool_expr be1) (bool_fun_of_bool_expr be2)
  | ANd be1 be2 =>
      bool_fun_and (bool_fun_of_bool_expr be1) (bool_fun_of_bool_expr be2)
  | Impl be1 be2 =>
      bool_fun_impl (bool_fun_of_bool_expr be1) (bool_fun_of_bool_expr be2)
  | Iff be1 be2 =>
      bool_fun_iff (bool_fun_of_bool_expr be1) (bool_fun_of_bool_expr be2)
  end.

Lemma bool_fun_eq_refl : forall bf : bool_fun, bool_fun_eq bf bf.
Proof.
  unfold bool_fun_eq in |- *.  intros.  reflexivity.
Qed.

Lemma bool_fun_eq_sym :
 forall bf1 bf2 : bool_fun, bool_fun_eq bf1 bf2 -> bool_fun_eq bf2 bf1.
Proof.
  unfold bool_fun_eq in |- *.  intros.  rewrite (H vb).  reflexivity.
Qed.

Lemma bool_fun_eq_trans :
 forall bf1 bf2 bf3 : bool_fun,
 bool_fun_eq bf1 bf2 -> bool_fun_eq bf2 bf3 -> bool_fun_eq bf1 bf3.
Proof.
  unfold bool_fun_eq in |- *.  intros.  rewrite (H vb).  rewrite <- (H0 vb).  reflexivity.
Qed.

Lemma bool_fun_neg_preserves_eq :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq bf1 bf2 -> bool_fun_eq (bool_fun_neg bf1) (bool_fun_neg bf2).
Proof.
  intros.  unfold bool_fun_eq, bool_fun_neg in |- *.  intros.  rewrite (H vb).  reflexivity.
Qed.

Lemma bool_fun_or_preserves_eq :
 forall bf1 bf1' bf2 bf2' : bool_fun,
 bool_fun_eq bf1 bf1' ->
 bool_fun_eq bf2 bf2' ->
 bool_fun_eq (bool_fun_or bf1 bf2) (bool_fun_or bf1' bf2').
Proof.
  intros.  unfold bool_fun_eq, bool_fun_or in |- *.  intros.  rewrite (H vb).  rewrite (H0 vb).  reflexivity.
Qed.

Lemma bool_fun_if_preserves_eq :
 forall (x : BDDvar) (bf1 bf2 bf1' bf2' : bool_fun),
 bool_fun_eq bf1 bf1' ->
 bool_fun_eq bf2 bf2' ->
 bool_fun_eq (bool_fun_if x bf1 bf2) (bool_fun_if x bf1' bf2').
Proof.
  unfold bool_fun_eq, bool_fun_if in |- *.  intros.  rewrite (H vb).  rewrite (H0 vb).
  reflexivity.
Qed.

Lemma bool_fun_and_preserves_eq :
 forall bf1 bf1' bf2 bf2' : bool_fun,
 bool_fun_eq bf1 bf1' ->
 bool_fun_eq bf2 bf2' ->
 bool_fun_eq (bool_fun_and bf1 bf2) (bool_fun_and bf1' bf2').
Proof.
  unfold bool_fun_eq, bool_fun_and in |- *.  intros.  rewrite (H vb).  rewrite (H0 vb).
  reflexivity.
Qed.

Lemma bool_fun_impl_preserves_eq :
 forall bf1 bf1' bf2 bf2' : bool_fun,
 bool_fun_eq bf1 bf1' ->
 bool_fun_eq bf2 bf2' ->
 bool_fun_eq (bool_fun_impl bf1 bf2) (bool_fun_impl bf1' bf2').
Proof.
  unfold bool_fun_eq, bool_fun_impl in |- *.  intros.  rewrite (H vb).  rewrite (H0 vb).
  reflexivity.
Qed.

Lemma bool_fun_iff_preserves_eq :
 forall bf1 bf1' bf2 bf2' : bool_fun,
 bool_fun_eq bf1 bf1' ->
 bool_fun_eq bf2 bf2' ->
 bool_fun_eq (bool_fun_iff bf1 bf2) (bool_fun_iff bf1' bf2').
Proof.
  unfold bool_fun_eq, bool_fun_iff in |- *.  intros.  rewrite (H vb).  rewrite (H0 vb).
  reflexivity.
Qed.

Lemma bool_fun_forall_preserves_eq :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq bf1 bf2 ->
 bool_fun_eq (bool_fun_forall x bf1) (bool_fun_forall x bf2).
Proof.
  unfold bool_fun_eq, bool_fun_forall, bool_fun_and in |- *.  intros.
  unfold bool_fun_restrict in |- *.  rewrite (H (augment vb x true)).
  rewrite (H (augment vb x false)).  reflexivity.
Qed.

Lemma bool_fun_ex_preserves_eq :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq bf1 bf2 -> bool_fun_eq (bool_fun_ex x bf1) (bool_fun_ex x bf2).
Proof.
  unfold bool_fun_eq, bool_fun_ex, bool_fun_or in |- *.  intros.
  unfold bool_fun_restrict in |- *.  rewrite (H (augment vb x true)).
  rewrite (H (augment vb x false)).  reflexivity.
Qed.

Lemma bool_fun_neg_zero :
 bool_fun_eq (bool_fun_neg bool_fun_zero) bool_fun_one.
Proof.
  unfold bool_fun_eq in |- *.  reflexivity.
Qed.

Lemma bool_fun_neg_one :
 bool_fun_eq (bool_fun_neg bool_fun_one) bool_fun_zero.
Proof.
  unfold bool_fun_eq in |- *.  reflexivity.
Qed.

Lemma bool_fun_and_lemma :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq (bool_fun_and bf1 bf2)
   (bool_fun_neg (bool_fun_or (bool_fun_neg bf1) (bool_fun_neg bf2))).
Proof.
  unfold bool_fun_eq, bool_fun_neg, bool_fun_or, bool_fun_and in |- *.  intros.
  elim (bf1 vb); elim (bf2 vb); reflexivity.
Qed.

Lemma bool_fun_impl_lemma :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq (bool_fun_impl bf1 bf2) (bool_fun_or (bool_fun_neg bf1) bf2).
Proof.
  unfold bool_fun_eq, bool_fun_impl, bool_fun_or, bool_fun_neg in |- *.  intros.
  elim (bf1 vb); elim (bf2 vb); reflexivity.
Qed.

Lemma bool_fun_iff_lemma :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq (bool_fun_iff bf1 bf2)
   (bool_fun_impl (bool_fun_or bf1 bf2) (bool_fun_and bf1 bf2)).
Proof.
  unfold bool_fun_eq, bool_fun_iff, bool_fun_impl, bool_fun_or, bool_fun_and
   in |- *.
  intros.  elim (bf1 vb); elim (bf2 vb); reflexivity.
Qed.

Lemma bool_fun_ex_lemma :
 forall (bf : bool_fun) (x : BDDvar),
 bool_fun_eq (bool_fun_ex x bf)
   (bool_fun_neg (bool_fun_forall x (bool_fun_neg bf))).
Proof.
  unfold bool_fun_ex in |- *.  intros.  unfold bool_fun_forall in |- *.
  unfold bool_fun_or, bool_fun_and, bool_fun_neg, bool_fun_restrict in |- *.
  unfold bool_fun_eq in |- *.  intro.
  elim (bf (augment vb x true)); elim (bf (augment vb x false)); reflexivity.
Qed.

Lemma bool_fun_var_lemma :
 forall x : BDDvar,
 bool_fun_eq (bool_fun_var x) (bool_fun_if x bool_fun_one bool_fun_zero).
Proof.
  unfold bool_fun_var, bool_fun_one, bool_fun_zero, bool_fun_if, bool_fun_eq
   in |- *.
  intros.  elim (vb x); reflexivity.
Qed.

Lemma bool_fun_eq_neg_eq :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq (bool_fun_neg bf1) (bool_fun_neg bf2) -> bool_fun_eq bf1 bf2.
Proof.
  unfold bool_fun_eq, bool_fun_neg in |- *.  intros.  cut (negb (bf1 vb) = negb (bf2 vb)).
  elim (bf1 vb).  elim (bf2 vb).  reflexivity.  simpl in |- *.  intro; discriminate.
  elim (bf2 vb).  intro; discriminate.  reflexivity.  apply H.
Qed.

Lemma bool_fun_neg_orthogonal :
 forall (x : BDDvar) (bf1 bf2 : bool_fun),
 bool_fun_eq (bool_fun_neg (bool_fun_if x bf1 bf2))
   (bool_fun_if x (bool_fun_neg bf1) (bool_fun_neg bf2)).
Proof.
  unfold bool_fun_eq, bool_fun_if, bool_fun_neg in |- *.  intros.  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_or_zero :
 forall bf : bool_fun, bool_fun_eq (bool_fun_or bf bool_fun_zero) bf.
Proof.
  unfold bool_fun_eq, bool_fun_or, bool_fun_zero in |- *.  intros.
  elim (bf vb); reflexivity.
Qed.

Lemma bool_fun_or_one :
 forall bf : bool_fun, bool_fun_eq (bool_fun_or bf bool_fun_one) bool_fun_one.
Proof.
  unfold bool_fun_eq, bool_fun_or, bool_fun_one in |- *.  intros.
  elim (bf vb); reflexivity.
Qed.

Lemma bool_fun_or_comm :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq (bool_fun_or bf1 bf2) (bool_fun_or bf2 bf1).
Proof.
  unfold bool_fun_eq, bool_fun_or in |- *.  intros.
  elim (bf1 vb); elim (bf2 vb); reflexivity.
Qed.

Lemma bool_fun_and_comm :
 forall bf1 bf2 : bool_fun,
 bool_fun_eq (bool_fun_and bf1 bf2) (bool_fun_and bf2 bf1).
Proof.
  unfold bool_fun_eq, bool_fun_and in |- *.  intros.
  elim (bf1 vb); elim (bf2 vb); reflexivity.
Qed.

Lemma bool_fun_and_idempotent :
 forall bf : bool_fun, bool_fun_eq (bool_fun_and bf bf) bf.
Proof.
  unfold bool_fun_eq, bool_fun_and in |- *.  intros.  elim (bf vb); reflexivity.
Qed.

Lemma bool_fun_or_orthogonal :
 forall (x : BDDvar) (bf1 bf2 bf1' bf2' : bool_fun),
 bool_fun_eq (bool_fun_or (bool_fun_if x bf1 bf2) (bool_fun_if x bf1' bf2'))
   (bool_fun_if x (bool_fun_or bf1 bf1') (bool_fun_or bf2 bf2')).
Proof.
  unfold bool_fun_eq, bool_fun_or, bool_fun_if in |- *.  intros.  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_or_orthogonal_right :
 forall (x : BDDvar) (bf bf1' bf2' : bool_fun),
 bool_fun_eq (bool_fun_or bf (bool_fun_if x bf1' bf2'))
   (bool_fun_if x (bool_fun_or bf bf1') (bool_fun_or bf bf2')).
Proof.
  unfold bool_fun_eq, bool_fun_or, bool_fun_if in |- *.  intros.  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_or_orthogonal_left :
 forall (x : BDDvar) (bf1 bf2 bf' : bool_fun),
 bool_fun_eq (bool_fun_or (bool_fun_if x bf1 bf2) bf')
   (bool_fun_if x (bool_fun_or bf1 bf') (bool_fun_or bf2 bf')).
Proof.
  unfold bool_fun_eq, bool_fun_or, bool_fun_if in |- *.  intros.  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_and_orthogonal :
 forall (x : BDDvar) (bf1 bf2 bf1' bf2' : bool_fun),
 bool_fun_eq (bool_fun_and (bool_fun_if x bf1 bf2) (bool_fun_if x bf1' bf2'))
   (bool_fun_if x (bool_fun_and bf1 bf1') (bool_fun_and bf2 bf2')).
Proof.
  unfold bool_fun_eq, bool_fun_and, bool_fun_if in |- *.  intros.  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_forall_independent :
 forall (x : BDDvar) (bf : bool_fun),
 bool_fun_independent bf x -> bool_fun_eq (bool_fun_forall x bf) bf.
Proof.
  unfold bool_fun_forall in |- *.  unfold bool_fun_independent in |- *.  intros.
  apply bool_fun_eq_trans with (bf2 := bool_fun_and bf bf).
  apply bool_fun_and_preserves_eq.  apply H.  apply H.
  apply bool_fun_and_idempotent.
Qed.

Lemma bool_fun_forall_zero :
 forall x : BDDvar,
 bool_fun_eq (bool_fun_forall x bool_fun_zero) bool_fun_zero.
Proof.
  intro.  unfold bool_fun_eq, bool_fun_forall, bool_fun_zero, bool_fun_restrict
   in |- *.
  intro.  reflexivity.
Qed.

Lemma bool_fun_forall_one :
 forall x : BDDvar, bool_fun_eq (bool_fun_forall x bool_fun_one) bool_fun_one.
Proof.
  intro.  unfold bool_fun_eq, bool_fun_forall, bool_fun_one, bool_fun_restrict
   in |- *.
  intro.  reflexivity.
Qed.

Lemma bool_fun_restrict_zero :
 forall (x : BDDvar) (b : bool),
 bool_fun_eq (bool_fun_restrict bool_fun_zero x b) bool_fun_zero.
Proof.
  intros.  unfold bool_fun_eq, bool_fun_restrict, bool_fun_zero, bool_fun_one in |- *.
  intros.  unfold augment in |- *.  reflexivity.
Qed.

Lemma bool_fun_restrict_one :
 forall (x : BDDvar) (b : bool),
 bool_fun_eq (bool_fun_restrict bool_fun_one x b) bool_fun_one.
Proof.
  intros.  unfold bool_fun_eq, bool_fun_restrict, bool_fun_zero, bool_fun_one in |- *.
  intros.  unfold augment in |- *.  reflexivity.
Qed.

Lemma bool_fun_restrict_preserves_eq :
 forall (bf1 bf2 : bool_fun) (x : BDDvar) (b : bool),
 bool_fun_eq bf1 bf2 ->
 bool_fun_eq (bool_fun_restrict bf1 x b) (bool_fun_restrict bf2 x b).
Proof.
  unfold bool_fun_eq, bool_fun_restrict in |- *.  intros.  rewrite (H (augment vb x b)).
  reflexivity.
Qed.

Lemma bool_fun_independent_zero :
 forall x : BDDvar, bool_fun_independent bool_fun_zero x.
Proof.
  unfold bool_fun_independent, bool_fun_zero in |- *.  unfold bool_fun_restrict, bool_fun_eq in |- *.
  reflexivity.
Qed.

Lemma bool_fun_independent_one :
 forall x : BDDvar, bool_fun_independent bool_fun_one x.
Proof.
  unfold bool_fun_independent, bool_fun_one in |- *.  unfold bool_fun_restrict, bool_fun_eq in |- *.
  reflexivity.
Qed.

Lemma bool_fun_eq_independent :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq bf1 bf2 ->
 bool_fun_independent bf1 x -> bool_fun_independent bf2 x.
Proof.
  unfold bool_fun_independent in |- *.  intros.
  apply bool_fun_eq_trans with (bf2 := bool_fun_restrict bf1 x b).
  apply bool_fun_restrict_preserves_eq.  apply bool_fun_eq_sym.  assumption.
  apply bool_fun_eq_trans with (bf2 := bf1).  apply H0.  assumption.
Qed.

Lemma bool_fun_if_restrict_true :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq (bool_fun_restrict (bool_fun_if x bf1 bf2) x true)
   (bool_fun_restrict bf1 x true).
Proof.
  intros.  unfold bool_fun_eq, bool_fun_if in |- *.  unfold bool_fun_restrict in |- *.
  unfold augment at 1 in |- *.  rewrite (Neqb_correct x).  simpl in |- *.  reflexivity.
Qed.

Lemma bool_fun_if_restrict_false :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq (bool_fun_restrict (bool_fun_if x bf1 bf2) x false)
   (bool_fun_restrict bf2 x false).
Proof.
  intros.  unfold bool_fun_eq, bool_fun_if in |- *.  unfold bool_fun_restrict in |- *.
  unfold augment at 1 in |- *.  rewrite (Neqb_correct x).  simpl in |- *.  reflexivity.
Qed.

Lemma bool_fun_if_restrict :
 forall (bf1 bf2 : bool_fun) (x y : BDDvar) (b : bool),
 Neqb x y = false ->
 bool_fun_eq (bool_fun_restrict (bool_fun_if x bf1 bf2) y b)
   (bool_fun_if x (bool_fun_restrict bf1 y b) (bool_fun_restrict bf2 y b)).
Proof.
  intros.  unfold bool_fun_restrict in |- *.  unfold bool_fun_eq in |- *.  intros.
  unfold augment in |- *.  unfold bool_fun_if in |- *.  rewrite (Neqb_comm x y) in H.
  rewrite H.  reflexivity.
Qed.

Lemma bool_fun_if_restrict_true_independent :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_independent bf1 x ->
 bool_fun_eq (bool_fun_restrict (bool_fun_if x bf1 bf2) x true) bf1.
Proof.
  unfold bool_fun_independent in |- *.  intros.
  apply bool_fun_eq_trans with (bf2 := bool_fun_restrict bf1 x true).
  apply bool_fun_if_restrict_true.  apply H.
Qed.

Lemma bool_fun_if_restrict_false_independent :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_independent bf2 x ->
 bool_fun_eq (bool_fun_restrict (bool_fun_if x bf1 bf2) x false) bf2.
Proof.
  unfold bool_fun_independent in |- *.  intros.
  apply bool_fun_eq_trans with (bf2 := bool_fun_restrict bf2 x false).
  apply bool_fun_if_restrict_false.  apply H.
Qed.

Lemma bool_fun_forall_orthogonal :
 forall (x u : BDDvar) (bf1 bf2 : bool_fun),
 Neqb x u = false ->
 bool_fun_eq (bool_fun_forall u (bool_fun_if x bf1 bf2))
   (bool_fun_if x (bool_fun_forall u bf1) (bool_fun_forall u bf2)).
Proof.
  intros.  unfold bool_fun_forall at 1 in |- *.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_and
                (bool_fun_if x (bool_fun_restrict bf1 u true)
                   (bool_fun_restrict bf2 u true))
                (bool_fun_if x (bool_fun_restrict bf1 u false)
                   (bool_fun_restrict bf2 u false))).
  apply bool_fun_and_preserves_eq.  apply bool_fun_if_restrict.  assumption.
  apply bool_fun_if_restrict.  assumption.  unfold bool_fun_forall in |- *.
  apply bool_fun_and_orthogonal.
Qed.

Lemma bool_fun_independent_if :
 forall (x y : BDDvar) (bf1 bf2 : bool_fun),
 bool_fun_independent bf1 x ->
 bool_fun_independent bf2 x ->
 Neqb x y = false -> bool_fun_independent (bool_fun_if y bf1 bf2) x.
Proof.
  intros.  unfold bool_fun_independent in |- *.  intro.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if y (bool_fun_restrict bf1 x b)
                (bool_fun_restrict bf2 x b)).
  apply bool_fun_if_restrict.  rewrite (Neqb_comm x y) in H1; assumption.
  apply bool_fun_if_preserves_eq.  apply H.  apply H0.
Qed.

Lemma bool_fun_forall_if_egal :
 forall (x : BDDvar) (bf1 bf2 : bool_fun),
 bool_fun_independent bf1 x ->
 bool_fun_independent bf2 x ->
 bool_fun_eq (bool_fun_forall x (bool_fun_if x bf1 bf2))
   (bool_fun_and bf1 bf2).
Proof.
  intros.  unfold bool_fun_forall in |- *.  apply bool_fun_and_preserves_eq.
  apply bool_fun_if_restrict_true_independent.  assumption.
  apply bool_fun_if_restrict_false_independent.  assumption.
Qed.

Lemma bool_fun_if_eq_1 :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq bf1 bf2 -> bool_fun_eq (bool_fun_if x bf1 bf2) bf1.
Proof.
  unfold bool_fun_eq, bool_fun_if in |- *.  intros.  rewrite (H vb).  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_if_eq_2 :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_eq bf1 bf2 -> bool_fun_eq (bool_fun_if x bf1 bf2) bf2.
Proof.
  unfold bool_fun_eq, bool_fun_if in |- *.  intros.  rewrite (H vb).  elim (vb x).
  reflexivity.  reflexivity.
Qed.

Lemma bool_fun_ext_zero : bool_fun_ext bool_fun_zero.
Proof.
  unfold bool_fun_ext, bool_fun_zero in |- *.  reflexivity.
Qed.

Lemma bool_fun_ext_one : bool_fun_ext bool_fun_one.
Proof.
  unfold bool_fun_ext, bool_fun_one in |- *.  reflexivity.
Qed.

Lemma bool_fun_ext_if :
 forall (bf1 bf2 : bool_fun) (x : BDDvar),
 bool_fun_ext bf1 -> bool_fun_ext bf2 -> bool_fun_ext (bool_fun_if x bf1 bf2).
Proof.
  unfold bool_fun_ext, bool_fun_if in |- *.  intros.  rewrite (H vb vb' H1).
  rewrite (H0 vb vb' H1).  rewrite (H1 x).  reflexivity.
Qed.

End Bool_fun.


(* Copyright (C) 2005-2008 Sebastien Briais *)
(* http://lamp.epfl.ch/~sbriais/ *)

(* This library is free software; you can redistribute it and/or modify *)
(* it under the terms of the GNU Lesser General Public License as *)
(* published by the Free Software Foundation; either version 2.1 of the *)
(* License, or (at your option) any later version. *)

(* This library is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
(* Lesser General Public License for more details. *)

(* You should have received a copy of the GNU Lesser General Public *)
(* License along with this library; if not, write to the Free Software *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA *)
(* 02110-1301 USA *)

Require Import Wf_nat.
Require Import missing.
Require Export List Permutation.

(** we define some notions on lists such as being a permutation of *)

(** insertion x l l' iff l' is l where x has been inserted somewhere *)
Inductive insertion (A:Set) : A -> list A -> list A -> Prop :=
  head_insertion : forall (x:A)(l:list A),(insertion A x l (x::l))
|tail_insertion : forall (x y:A)(l l':list A),(insertion A x l l')->(insertion A x (y::l) (y::l')).

Lemma insertion_snoc : forall (A:Set)(x:A)(xs:list A),(insertion _ x xs (app xs (cons x nil))).
  induction xs.
  simpl.
  apply head_insertion.
  simpl.
  apply tail_insertion.
  auto.
Qed.

(** if (insertion x l l') then x is in l' *)
Lemma insertion_in : forall (A:Set)(x:A)(l l':list A),(insertion A x l l')->(In x l').
  intros.
  induction H;simpl;tauto.
Qed.

(** if (insertion x l l') then l is included in l' *)
Lemma insertion_inclusion : forall (A:Set)(x:A)(l l':list A),(insertion A x l l')->forall (y:A),(In y l)->(In y l').
  induction l;simpl;try tauto;intros.
  inversion H;simpl;try tauto.
  case H0;try tauto.
  right;auto.
Qed.

(** if x is in l, then there is l' such that (insertion x l' l) *)
Lemma in_insertion : forall (A:Set)(x:A)(l:list A),(In x l)->exists l':list A,(insertion A x l' l).
  induction l;simpl;try tauto;intros.
  case H;intro.
  rewrite H0;exists l;apply head_insertion.
  elim (IHl H0);intro l';intro.
  exists (a::l');apply tail_insertion;trivial.
Qed.

(** if (insertion x l l') and y is in l' then y=x or y is in l *)
Lemma in_insertion_inv : forall (A:Set)(x y:A)(l l':list A),(insertion A y l l')->(In x l')->(x=y)\/(In x l).
  intros.
  induction H;simpl in H0.
  case H0;intro H1;try (symmetry in H1);tauto.
  case H0;simpl;intro;tauto.
Qed.

(** a list is a set iff all the elements are pairwise distinct *)
Inductive is_set (A:Set) : list A->Prop :=
  nil_is_set : (is_set A nil)
|cons_is_set : forall (x:A)(l:list A),(is_set A l)->~(In x l)->(is_set A (x::l)).

(** if (insertion x l l') and l' is a set then l is a set *)
Lemma is_set_insertion : forall (A:Set)(l l':list A)(x:A),(insertion A x l l')->(is_set A l')->(is_set A l).
  induction 1;intros.
  inversion H;trivial.
  inversion H0.
  apply cons_is_set.
  apply IHinsertion;trivial.
  intro;apply H4;apply (insertion_inclusion A x l l');trivial.
Qed.

(** if (insertion x l l') and l' is a set then x is not in l *)
Lemma is_set_insertion_in : forall (A:Set)(l l':list A)(x:A),(insertion A x l l')->(is_set A l')->~(In x l).
  induction l;simpl;try tauto;intros.
  inversion H;rewrite <- H3 in H0;inversion H0.
  simpl in H7;trivial.
  intro.
  case H10;intro.
  apply H9;rewrite H11;eapply insertion_in;apply H5.
  elim (IHl l'0 x H5 H8 H11).
Qed.

(** if l is a set, x not in l and (insertion x l l') then l' is a set *)
Lemma insertion_is_set : forall (A:Set)(l:list A),(is_set _ l)->forall (x:A),~(In x l)->forall (l':list A),(insertion _ x l l')->(is_set _ l').
  induction 1.
  intros.
  inversion H0.
  apply cons_is_set.
  apply nil_is_set.
  auto.
  intros.
  inversion H2.
  subst x1.
  subst l0.
  subst l'.
  apply cons_is_set.
  eapply IHis_set.
  apply H0.
  apply head_insertion.
  auto.
  subst x1;subst y;subst l0.
  apply cons_is_set.
  eapply IHis_set with x0;auto.
  red;intro.
  apply H1.
  simpl.
  right;auto.
  red;intro.
  case (in_insertion_inv _ _ _ _ _ H7 H3);intro.
  apply H1.
  simpl.
  left;auto.
  apply H0.
  auto.
Qed.

(** l' is a permutation of l *)
Inductive is_permutation (A:Set) : list A->list A->Prop :=
  nil_is_permutation : (is_permutation A nil nil)
|cons_is_permutation : forall (l l':list A),(is_permutation A l l')->forall (x:A)(l'':(list A)),(insertion A x l' l'')->(is_permutation A (x::l) l'').

(** if l and l' have the same content and are pairwise distinct then l' is a permutation of l *)
Lemma is_set_eq_impl_permutation : forall (A:Set)(l l':list A),(forall (x:A),(In x l)<->(In x l'))->(is_set A l)->(is_set A l')->(is_permutation A l l').
  induction l;intros;simpl in H.
  destruct l'.
  apply nil_is_permutation.
  elim (H a);intros.
  elim H3;simpl;tauto.
  inversion H0.
  symmetry in H2;rewrite H2 in H;elim (H a);intros.
  rewrite H2 in H6;rewrite H2.
  assert (In x l');auto.
  elim (in_insertion A x l' H8).
  intro l'';intro.
  apply cons_is_permutation with l'';trivial.
  apply IHl;trivial.
  split;intro.
  elim (H x0);intros.
  elim (in_insertion_inv A x0 x l'' l');auto.
  intro;rewrite H13 in H10;rewrite H2 in H5;tauto.
  elim (H x0);intros.
  case H12;try tauto.
  apply (insertion_inclusion A x l'' l');trivial.
  intro;rewrite <- H13 in H10.
  elim (is_set_insertion_in A l'' l' x);trivial.
  eapply is_set_insertion;eauto.
Qed.

(** is_permutation is reflexive *)
Lemma is_permutation_refl : forall (A:Set)(l:list A),(is_permutation A l l).
  induction l.
  apply nil_is_permutation.
  eapply cons_is_permutation;[apply IHl | apply head_insertion].
Qed.

(** if l' is l where x has been inserted then l' is a permutation of x::l *)
Lemma insertion_is_permutation : forall (A:Set)(l l':list A)(x:A),(insertion A x l l')->(is_permutation A (x::l) l').
  induction 1.
  apply cons_is_permutation with l;[apply is_permutation_refl | apply head_insertion].
  apply cons_is_permutation with (y::l);[apply is_permutation_refl | apply tail_insertion;trivial].
Qed.

(** if l1 is l0 where x has been inserted and l2 is l1 where y has been inserted then there is l3 such that l3 is l0 where y has been inserted and l2 is l3 where x has been inserted *)
Lemma insertion_trans : forall (A:Set)(l0 l1:list A)(x:A),(insertion A x l0 l1)->forall (l2:list A)(y:A),(insertion A y l1 l2)->exists l3:list A,(insertion A y l0 l3)/\(insertion A x l3 l2).
  induction 1;intros.
  inversion H.
  exists (y::l);split;[apply head_insertion | apply tail_insertion;apply head_insertion].
  exists l';split;[trivial | apply head_insertion].
  inversion H0.
  exists (y0::y::l);split;[apply head_insertion | apply tail_insertion;apply tail_insertion;trivial].
  elim (IHinsertion l'0 y0 H5);intro l3;intro.
  elim H6;intros.
  exists (y::l3);split;[apply tail_insertion | apply tail_insertion];trivial.
Qed.

(** if l1 is a permutation of l0 and then l1 where x has been inserted is a permutation of l0 where x has been inserted *)
Lemma permutation_insertion : forall (A:Set)(l0 l1:list A),(is_permutation A l0 l1)->forall (x:A)(l2 l3:list A),(insertion A x l0 l2)->(insertion A x l1 l3)->(is_permutation A l2 l3).
  induction 1;intros.
  inversion H;inversion H0;apply is_permutation_refl.
  inversion H1.
  apply cons_is_permutation with l'';trivial.
  apply cons_is_permutation with l';trivial.
  elim (insertion_trans A l' l'' x H0 l3 x0 H2).
  intro l4;intro.
  elim H8;intros.
  apply cons_is_permutation with l4;trivial.
  eapply IHis_permutation;eauto.
Qed.

(** is_permutation is symmetric *)
Lemma is_permutation_sym : forall (A:Set)(l l':list A),(is_permutation A l l')->(is_permutation A l' l).
  induction 1;[apply nil_is_permutation | eapply permutation_insertion;eauto;apply head_insertion].
Qed.

Lemma permutation_in : forall (A:Set)(l l':list A),(is_permutation A l l')->forall (x:A),(In x l)<->(In x l').
  induction l;simpl;intros.
  inversion H;simpl;tauto.
  inversion H;simpl.
  split;intro.
  case H5;intro.
  eapply insertion_in;rewrite H6 in H4;apply H4.
  elim (IHl l'0 H2 x);intros.
  eapply insertion_inclusion;eauto.
  case (in_insertion_inv A x a l'0 l' H4 H5);intro.
  rewrite H6;tauto.
  elim (IHl l'0 H2 x);intros.
  right;auto.
Qed.

Lemma permutation_insertion_aux : forall (A:Set)(l l' l'':list A)(x:A),(insertion A x l l')->(insertion A x l l'')->(is_permutation A l' l'').
  intros.
  eapply permutation_insertion;eauto.
  apply is_permutation_refl.
Qed.

Lemma length_recursion : forall (A:Set),forall (P:list A->Prop),(forall (x:list A),(forall (y:list A),(length y)<(length x)->(P y))->(P x))->(forall (a:list A),(P a)).
  intros.
  apply (well_founded_ind (well_founded_ltof (list A) (fun l:list A => length l)));unfold ltof;auto.
Qed.

Lemma insertion_length : forall (A:Set)(l l':list A)(x:A),(insertion A x l l')->(length l')=(S (length l)).
  induction 1;simpl;trivial.
  rewrite IHinsertion;trivial.
Qed.

Lemma permutation_length : forall (A:Set)(l l':list A),(is_permutation A l l')->(length l)=(length l').
  induction 1;simpl;trivial.
  generalize (insertion_length A l' l'' x H0);intro;congruence.
Qed.

Lemma insertion_permutation_eq : forall (A:Set)(l l':list A)(x:A),(insertion A x l' l)->forall (l'':list A),(insertion A x l'' l)->(is_permutation A l' l'').
  induction l;intros;inversion H.
  inversion H0.
  apply is_permutation_refl.
  rewrite <- H4;destruct l.
  inversion H8.
  generalize (head_insertion A a0 l);intro.
  assert (In x (a0::l)).
  eapply insertion_in;apply H8.
  case (in_insertion_inv A x a0 l (a0::l) H10 H11);intro.
  rewrite H12;rewrite <- H12 in H10;rewrite <- H12 in H8;rewrite <- H12 in IHl.
  assert (is_permutation A l l1).
  eapply IHl;eauto.
  eapply cons_is_permutation;eauto;apply head_insertion.
  elim (in_insertion A x l H12);intro l2;intro.
  generalize (tail_insertion A x a0 l2 l H13);intro.
  assert (is_permutation A (a0::l2) l1).
  eapply IHl;eauto.
  apply is_permutation_sym;auto.
  eapply cons_is_permutation;eauto.
  rewrite H1 in H3.
  inversion H0.
  rewrite <- H9;apply insertion_is_permutation;trivial.
  assert (is_permutation A l0 l1).
  eapply IHl;eauto.
  eapply cons_is_permutation;eauto;apply head_insertion.
Qed.

Lemma permutation_insertion_comm : forall (A:Set)(l1 l2:list A)(x:A),(insertion A x l1 l2)->forall (l4:list A),(is_permutation A l2 l4)->(exists l3:list A,(is_permutation A l1 l3) /\ (insertion A x l3 l4)).
  intros A l1 l2.
  generalize l1;clear l1.
  induction l2;intros.
  inversion H.
  inversion H.
  subst a.
  subst x0.
  subst l.
  subst l2.
  inversion H0.
  subst x0.
  subst l.
  subst l''.
  exists l'.
  tauto.
  subst x0.
  subst l'.
  subst a.
  subst l1.
  inversion H0.
  subst x0.
  subst l''.
  subst l0.
  elim (IHl2 l x H4 l' H3).
  intro l3;intros.
  elim H1;clear H1;intros.
  elim (insertion_trans A l3 l' x H2 l4 y H6).
  intro l5;intros.
  elim H5;clear H5;intros.
  exists l5.
  split;trivial.
  eapply cons_is_permutation.
  apply H1.
  trivial.
Qed.

Lemma permutation_insertion_permutation : forall (A:Set)(l l':list A),(is_permutation A l l')->forall (x:A)(l'':list A),(insertion A x l' l'')->forall (l''':list A),(is_permutation A l'' l''')->(is_permutation A (x::l) l''').
  induction 1;intros.
  inversion H.
  rewrite <- H3 in H0.
  trivial.
  elim (permutation_insertion_comm A l'' l''0 x0 H1 l''' H2).
  intro l1;intro.
  elim H3;clear H3;intros.
  eapply cons_is_permutation.
  eapply IHis_permutation.
  apply H0.
  apply H3.
  trivial.
Qed.

(** is_permutation is transitive *)
Lemma is_permutation_trans : forall (A:Set)(l l':list A),(is_permutation A l l')->forall (l'':list A),(is_permutation A l' l'')->(is_permutation A l l'').
  induction l.
  intros.
  inversion H.
  rewrite <- H2 in H0;trivial.
  intros.
  inversion H.
  induction H5;inversion H0.
  eapply cons_is_permutation;try (apply IHl with l1;eauto);trivial.
  eapply permutation_insertion_permutation.
  apply H3.
  apply tail_insertion.
  apply H5.
  eapply cons_is_permutation.
  apply H8.
  apply H10.
Qed.

Lemma is_permutation_reverse : forall (A:Set)(l:list A),(is_permutation A l (rev l)).
  induction l.
  simpl.
  apply nil_is_permutation.
  simpl.
  eapply cons_is_permutation.
  apply IHl.
  apply insertion_snoc.
Qed.

Lemma is_permutation_reverse_impl_is_permutation : forall (A:Set)(l l':list A),(is_permutation A (rev l) (rev l'))->(is_permutation A l l').
  intros.
  eapply is_permutation_trans.
  apply is_permutation_reverse.
  apply is_permutation_sym.
  eapply is_permutation_trans.
  apply is_permutation_reverse.
  apply is_permutation_sym.
  trivial.
Qed.

Lemma is_permutation_impl_is_permutation_reverse : forall (A:Set)(l l':list A),(is_permutation A l l')->(is_permutation A (rev l) (rev l')).
  intros.
  apply is_permutation_reverse_impl_is_permutation.
  rewrite rev_involutive.
  rewrite rev_involutive.
  trivial.
Qed.

Lemma is_permutation_cons_snoc : forall (A:Set)(x:A)(xs:list A),(is_permutation A (cons x xs) (app xs (cons x nil))).
  intros.
  eapply cons_is_permutation.
  apply is_permutation_refl.
  apply insertion_snoc.
Qed.

Lemma insertion_append : forall (A:Set)(x:A)(xs xss:list A),(insertion A x xs xss)->forall (yss:list A),(insertion A x (app xs yss) (app xss yss)).
  induction 1.
  simpl.
  intros.
  apply head_insertion.
  intros.
  simpl.
  apply tail_insertion.
  apply IHinsertion.
Qed.

Lemma is_permutation_append : forall (A:Set)(xs ys:list A),(is_permutation A xs ys)->forall (xs' ys':list A),(is_permutation A xs' ys')->(is_permutation A (app xs xs') (app ys ys')).
  induction 1;intros.
  simpl.
  auto.
  simpl.
  eapply cons_is_permutation.
  apply IHis_permutation.
  apply H1.
  apply insertion_append.
  auto.
Qed.

Lemma insertion_map : forall (B:Set)(y:B)(ys yss:list B),(insertion _ y ys yss)->forall (A:Set)(f:A->B)(x:A),y=f x->forall (xs:list A),ys = map f xs->exists xss:list A,yss = map f xss /\ insertion _ x xs xss.
  induction 1;intros.
  exists (cons x0 xs).
  simpl.
  split.
  subst x;subst l;auto.
  apply head_insertion.
  destruct xs.
  discriminate H1.
  simpl in H1.
  injection H1;clear H1;intros.
  elim (IHinsertion _ _ _ H0 _ H1).
  intro xss;intros.
  elim H3;clear H3;intros.
  exists (cons a xss).
  simpl.
  split.
  subst y;subst l';auto.
  apply tail_insertion.
  auto.
Qed.

Lemma is_permutation_map : forall (B:Set)(ys1 ys2:list B),(is_permutation B ys1 ys2)->forall (A:Set)(f:A->B)(xs1:list A),(ys1 = map f xs1)->exists xs2:list A,(is_permutation A xs1 xs2)/\ys2 = map f xs2.
  induction 1.
  intros.
  destruct xs1;try (discriminate H).
  exists (nil (A:=A)).
  split.
  apply nil_is_permutation.
  reflexivity.
  intros.
  destruct xs1;try (discriminate H1).
  simpl in H1.
  injection H1;clear H1;intros.
  subst x.
  elim (IHis_permutation _ _ _ H1).
  intro xs2.
  intros.
  elim H2;clear H2;intros.
  subst l'.
  elim (insertion_map _ _ _ _ H0 _ f a (refl_equal (f a)) xs2 (refl_equal (map f xs2))).
  intros.
  elim H3;clear H3;intros.
  exists x.
  split;auto.
  eapply cons_is_permutation;eauto.
Qed.

(** if l' is a permutation of l and the elements of l are pairwise distinct, then so are those of l' *)
Lemma is_permutation_set : forall (A:Set)(l l':list A),(is_permutation _ l l')->(is_set _ l)->(is_set _ l').
  induction 1.
  auto.
  intros.
  inversion H1.
  subst x0;subst l0.
  eapply insertion_is_set.
  apply IHis_permutation.
  auto.
  elim (permutation_in _ _ _ H x).
  intros.
  red;intro.
  apply H5.
  apply H3.
  apply H6.
  auto.
Qed.

Lemma Permutation_impl_permutation : forall (A:Set)(l l':list A),(Permutation l l')->(is_permutation _ l l').
  induction 1.
  apply nil_is_permutation.
  eapply cons_is_permutation.
  apply IHPermutation.
  apply head_insertion.
  eapply cons_is_permutation.
  apply is_permutation_refl.
  apply tail_insertion.
  apply head_insertion.
  eapply is_permutation_trans;eauto.
Qed.

Lemma insertion_append_decompose : forall (A:Set)(x:A)(l l':list A),(insertion _ x l l')->exists l1:list A,exists l2:list A,l=(app l1 l2)/\l'=(app l1 (cons x l2)).
  induction 1.
  exists (nil (A:=A)).
  exists l.
  split;try reflexivity.
  elim IHinsertion.
  intro l1.
  intro.
  elim H0.
  intro l2;intros.
  elim H1;clear H1;intros.
  exists (cons y l1).
  exists l2.
  subst l;subst l'.
  split;try reflexivity.
Qed.

Lemma permutation_impl_Permutation : forall (A:Set)(l l':list A),(is_permutation _ l l')->(Permutation l l').
  induction 1.
  apply perm_nil.
  elim (insertion_append_decompose _ _ _ _ H0).
  intro l1;intros.
  elim H1.
  intro l2;intros.
  elim H2;clear H2;intros.
  subst l';subst l''.
  apply Permutation_cons_app.
  auto.
Qed.