(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype finfun bigop prime binomial ssralg.
From mathcomp Require Import finset fingroup finalg perm zmodp matrix path.
From mathcomp Require Import fingraph.
Require Import ssr_ext subgraph_partition tanner f2 Rbigop.

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

(** * Cover/partition properties of Tanner graphs *)

(** OUTLINE:
- Section tanner_rel_no_hypo.
- Section acyclic_tanner_rel.
- Section tanner_partition.
*)

Import GRing.
Local Open Scope ring_scope.

Lemma trivIsetS_f (A B : finType) (f : A -> B) (AA : {set {set A}}) (BB : {set {set B}}) :
  (forall a, a \in AA -> exists b, b \in BB /\ a = [set a' | f a' \in b]) ->
  trivIset BB -> trivIset AA.
Proof.
move=> /= Hsub.
move/trivIsetP => Hdisj.
apply/trivIsetP => /= x y Hx Hy.
rewrite -setI_eq0.
case: (Hsub _ Hx) => x' [] x'Q ->.
case: (Hsub _ Hy) => y' [] y'Q -> xy.
have {xy} : x' != y' by apply: contra xy => /eqP ?; subst y'.
move/(Hdisj _ _ x'Q y'Q).
rewrite -setI_eq0 => /eqP abs.
apply/eqP/setP => /= m0.
rewrite in_set0.
move/setP : abs => /(_ (f m0)).
rewrite in_set0 => /negbT.
rewrite inE negb_and !inE.
case/orP; move/negbTE => -> //; by rewrite andbF.
Qed.

Section tanner_rel_no_hypo.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).

Lemma Vgraph_decompose n1 m0 n0 : n0 \in 'V m0 ->
  n1 \in 'V(m0, n0) -> n1 != n0 -> n1 \notin 'V m0 -> exists n1',
  n1' \in 'V m0 :\ n0 /\ exists m1, m1 \in 'F n1' :\ m0 /\
    n1 \in 'V(m1, n1').
Proof.
move=> m0n0 Hn1 n1n0 n1Vm0.
rewrite !inE (negbTE n1n0) /= in Hn1.
case/andP : Hn1 => _.
case/connectP => /= q Hq Hq'.
case/shortenP : Hq Hq' => /= p Hp Huniq pq Hp'.
destruct p as [|[?|n1'] p]; [by [] | by rewrite exceptE /= tanner_relE in Hp | ].
rewrite /= in Hp'.
rewrite /= {1}exceptE /= -andbA in Hp.
case/and3P : Hp => m0n1' n1'n0 Hp.
have n1n1' : n1 != n1'.
  apply/eqP => ?; subst n1'.
  by move: n1Vm0; rewrite VnextE sym_tanner_rel m0n1'.
destruct p as [|[m1|?] t]; [ | | by rewrite exceptE /= tanner_relE in Hp ].
  exfalso; move/negP : n1n1'; apply.
  by case: Hp' => ->.
move: Hp; rewrite /= {1}exceptE; case/andP => /and3P[/= m1n1' _ _] Hp.
exists n1'.
rewrite !inE /=.
split.
  rewrite VnextE sym_tanner_rel m0n1' andbT.
  by apply: contra n1'n0 => /eqP ->.
exists m1; split.
  rewrite in_setD1 FnextE VnextE m1n1' andbT.
  apply/eqP => ?; subst m1.
  by rewrite !inE /= eqxx /= in Huniq.
rewrite !inE /= (negbTE n1n1') /= m1n1' /=.
apply/connectP; exists t => //.
apply: (sub_path_except _ _ Hp) => //.
case/andP : Huniq => _.
rewrite -(cat1s (inr _)) -(cat1s (inl m1)).
by rewrite uniq_catCA cat_uniq => /and3P[_ _ /= /andP[]].
Qed.

End tanner_rel_no_hypo.

Section acyclic_tanner_rel.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma notin_Vgraph n1 m0 n0 m1 : n0 \in 'V m0 ->
  n1 \in 'V m0 :\ n0 -> m1 \in 'F n1 :\ m0 ->
  n0 \notin 'V(m1, n1).
Proof.
move=> n0m0 Hn1 Hm1.
rewrite in_setD1 in Hn1; case/andP : Hn1 => n1n0 n1m0.
rewrite in_setD1 in Hm1; case/andP : Hm1 => m1m0 m1n1.
suff : inr n0 \notin subgraph (tanner_rel H) (inl m1) (inr n1).
  move=> Htmp.
  by rewrite /Vgraph inE negb_or in_set1 eq_sym n1n0 /= inE.
apply: (@notin_subgraph _ (tanner_rel H) _ _ _ _ (inl m0)) => //.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE.
by rewrite /= -VnextE.
by rewrite /= -VnextE -FnextE.
Qed.

Lemma Vgraph_inclusion n1 m0 n0 m1 n2 : n0 \in 'V m0 ->
  n1 \in 'V m0 :\ n0 -> m1 \in 'F n1 :\ m0 ->
  n2 \in 'V(m1, n1) -> n2 \in 'V(m0, n0).
Proof.
move=> n0m0 Hn1 Hm1 Hn2.
rewrite !inE.
case/boolP : (n2 == n0) => //= n2n0.
rewrite -VnextE n0m0 /=.
rewrite !inE /= in Hn2.
case/orP : Hn2 => Hn2.
  move/eqP in Hn2; subst n2.
  apply connect1 => /=.
  move: (Hn1); rewrite in_setD1 exceptE /= -VnextE => /andP[_ -> /=].
  by apply: contra n2n0 => /eqP [] ->.
case/andP : Hn2 => m1n1 Hn2.
case/connectP : Hn2 => p.
case/shortenP => p' Hp' Hun p'p Hlast.
apply/connectP.
exists [:: inr n1, inl m1 & p'] => //.
rewrite /=.
rewrite !inE /= in Hn1.
case/andP : Hn1 => n1n0 Hn1.
rewrite {1 2}exceptE /= -VnextE Hn1 /= m1n1 /=.
apply/andP; split.
  by apply: contra n1n0 => /eqP [] ->.
apply/andP; split.
  rewrite andbT.
  by apply: contra n1n0 => /eqP [] ->.
apply (@sub_path_except _ _ (inr n1)) => //.
apply/negP => n0p'.
case/splitPr : n0p' => p1 p2 in Hp' Hun p'p Hlast.
suff : path.ucycle (tanner_rel H) [:: inr n0, inl m0, inr n1, inl m1 & p1].
  exact: Hacyclic.
apply: uniq_path_ucycle_extend_2 => //.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE.
by rewrite /= -VnextE.
apply/eqP; case => ?; subst m1; by rewrite in_setD1 eqxx in Hm1.
rewrite -(cat1s (inr n0)) catA cat_path in Hp'; by case/andP : Hp'.
rewrite -(cat1s (inl m1)) catA cat_uniq in Hun; by case/andP : Hun.
Qed.

End acyclic_tanner_rel.

Section tanner_partition.

Variables (m n : nat).
Variable H : 'M['F_2]_(m, n).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).

Definition Fgraph_part_fnode (n0 : 'I_n) : {set {set 'I_m}} :=
  (fun m => 'F(m, n0)) @: ('F n0).

Hypothesis Hconnect : forall a b, connect (tanner_rel H) a b.

Lemma cover_Fgraph_part_fnode (n0 : 'I_n) : cover (Fgraph_part_fnode n0) = setT.
Proof.
apply/setP => /= m1; rewrite in_set.
apply/bigcupP => /=.
have : inl m1 \in cover ([set inr n0] |: subgraph_succ (tanner_rel H) (inr n0)).
move: (cover_subgraph_succ (tanner_rel H) (inr n0)) => /setP/(_ (inl m1)) ->.
  by rewrite inE Hconnect.
case/bigcupP => /= E HE m1_in_E.
rewrite in_setU1 in HE.
move/orP: HE => [HE | ].
  by rewrite (eqP HE) in_set1 in m1_in_E.
case/imsetP => /= p Hp HE.
rewrite HE in_set in m1_in_E.
rewrite in_set in Hp.
case: p HE Hp m1_in_E => p HE /= Hp m1_in_E; last by rewrite tanner_relE in m1_in_E.
exists [set m0 | inl m0 \in E].
  apply/imsetP => /=.
  exists p.
    by rewrite FnextE VnextE.
  apply/setP => /= m0.
  by rewrite HE !inE.
by rewrite HE !in_set.
Qed.

Definition Vgraph_part_vnode (n0 : 'I_n) : {set {set 'I_n}} :=
  (fun m => 'V(m, n0) :\ n0) @: ('F n0).

Lemma notin_Vgraph_part_vnode (n0 : 'I_n) : n0 \notin cover (Vgraph_part_vnode n0).
Proof.
apply/bigcupP => /=; case=> E /imsetP [] /= m0 Hm0 ->; by rewrite 2!inE eqxx.
Qed.

Lemma cover_Vgraph_part_vnode (n0 : 'I_n) : cover (Vgraph_part_vnode n0) = setT :\ n0.
Proof.
apply/setP => /= n1.
rewrite !inE andbT.
case/boolP : (n1 == n0) => [ /eqP -> | n1n0] /=.
  exact/negbTE/notin_Vgraph_part_vnode.
apply/bigcupP => /=.
have : inr n1 \in cover ([set inr n0] |: subgraph_succ (tanner_rel H) (inr n0)).
  by rewrite (cover_subgraph_succ (tanner_rel H) (inr n0)) inE Hconnect.
case/bigcupP => /= p.
rewrite !inE.
case/orP => [ /eqP -> | ].
  rewrite inE.
  case/eqP => abs; by rewrite abs eqxx in n1n0.
case/imsetP => /=; case=> p1; last by rewrite inE tanner_relE.
move=> Hp1 pp1 n1p.
exists ('V(p1, n0) :\ n0).
  apply/imsetP => /=.
  exists p1 => //.
  rewrite inE /= -VnextE in Hp1.
  by rewrite FnextE.
rewrite !inE n1n0 /= predU1r //.
by rewrite pp1 inE in n1p.
Qed.

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma trivIset_Fgraph_part_fnode (n0 : 'I_n) : trivIset (Fgraph_part_fnode n0).
Proof.
have K : trivIset (subgraph_succ (tanner_rel H) (inr n0)).
  exact: trivIsetS _ (subsetUr _ _)
    (trivIset_subgraph_succ (simple_tanner_rel H) (sym_tanner_rel H) Hacyclic (inr n0)).
apply: trivIsetS_f K => /= z.
case/imsetP => /= i Hi Hz.
exists [set x | x in subgraph (tanner_rel H) (inl i) (inr n0)].
split.
  apply/imsetP.
  exists (inl i).
    by rewrite inE /= -VnextE -FnextE.
  apply/setP => /= j.
  move Hlhs : (j \in _) => [|]; first by case/imsetP : Hlhs => /= k kz ->.
  apply/esym/negbTE.
  move/negbT : Hlhs; apply contra => Hlhs.
  apply/imsetP.
  by exists j.
apply/setP => /= j.
rewrite inE.
move Hlhs : (j \in z) => [|].
  apply/esym/imsetP.
  exists (inl j) => //.
  by rewrite Hz /Fgraph inE in Hlhs.
apply/esym/negbTE.
move/negbT : Hlhs; apply contra.
case/imsetP => /= p Hp ?; subst p.
by rewrite Hz inE.
Qed.

Lemma trivIset_Vgraph_part_vnode n0 : trivIset (Vgraph_part_vnode n0).
Proof.
have : trivIset (subgraph_succ (tanner_rel H) (inr n0)).
  exact: trivIsetS _ (subsetUr _ _) (trivIset_subgraph_succ
    (simple_tanner_rel H) (sym_tanner_rel H) Hacyclic (inr n0)).
apply: trivIsetS_f => /= z.
case/imsetP => /= i Hi Hz.
exists [set x | x in (subgraph (tanner_rel H) (inl i) (inr n0))].
split.
  apply/imsetP.
  exists (inl i).
    by rewrite inE /= -VnextE -FnextE.
  apply/setP => /= j.
  move Hlhs : (j \in _) => [|]; first by case/imsetP : Hlhs => /= k kz ->.
  apply/esym/negbTE.
  move/negbT : Hlhs; apply contra => Hlhs.
  apply/imsetP.
  by exists j.
apply/setP => /= j.
move Hlhs : (j \in z) => [|].
  rewrite inE.
  apply/esym/imsetP => /=.
  exists (inr j) => //.
  rewrite Hz !inE in Hlhs.
  case/andP : Hlhs => jn0.
  case/orP => jn0'.
    by rewrite (negbTE jn0) in jn0'.
  by rewrite inE.
apply/esym/negbTE.
move/negbT : Hlhs; apply contra.
rewrite inE.
case/imsetP => /= p Hp ?; subst p.
rewrite Hz !inE.
apply/andP; split.
  apply/negP => /eqP ?; subst j.
  move: Hp; apply/negP.
  apply (root_notin_subgraph (simple_tanner_rel _)).
  by rewrite inE /= -VnextE -FnextE.
rewrite inE in Hp.
by rewrite Hp orbT.
Qed.

(* NB: Lemma Vgraph_inclusion n1 m0 n0 m1 n2 : n0 \in `V m0 ->
  n1 \in `V m0 :\ n0 -> m1 \in `F n1 :\ m0 ->
  n2 \in `V(m1, n1) -> n2 \in `V(m0, n0).
=> do not need the n2 \in `V(m0, n0) hypo
*)

Lemma disjoint_Vgraph2 m0 n0 n1 n2 m1 (m0n0 : n0 \in 'V m0) :
  n1 \in 'V m0 :\ n0 ->
  n2 \in 'V(m0, n1) :\ n1 ->
  m1 \in 'F n1 :\ m0 ->
  n2 \in 'V(m1, n1) ->
  n2 \notin 'V m0 ->
  n2 \in 'V(m0, n0) -> Logic.False.
Proof.
move=> Hn1 Hn2 Hm1 H1 H2 H3.
move: (trivIset_Vgraph_part_vnode n1).
move/trivIsetP.
move/(_ ('V(m0, n1) :\ n1) ('V(m1,n1) :\ n1)).
rewrite /Vgraph_part_vnode.
have K1 : 'V(m0, n1) :\ n1 \in [set 'V(m2, n1) :\ n1 | m2 in 'F n1].
  apply/imsetP.
  exists m0 => //.
  by move: Hn1; rewrite in_setD1 -FnextE => /andP[].
move/(_ K1).
have K2 : 'V(m1, n1) :\ n1 \in [set 'V(m2, n1) :\ n1 | m2 in 'F n1].
  apply/imsetP.
  exists m1 => //.
  rewrite inE in Hm1.
  by case/andP : Hm1.
move/(_ K2).
have K3 : 'V(m0, n1) :\ n1 != 'V(m1, n1) :\ n1.
  have K4 : n0 \in 'V(m0, n1) :\ n1.
    rewrite !inE.
    rewrite !inE in Hn1.
    case/andP : Hn1 => n1n0 m0n1.
    rewrite eq_sym n1n0 /= -VnextE (negbTE n1n0) /= m0n1 /=.
    apply/connect1.
    rewrite exceptE /= -VnextE m0n0 /=.
    by apply: contra n1n0 => /eqP[->].
  have K5 : n0 \notin 'V(m1, n1) :\ n1.
    rewrite !inE negb_and negbK negb_or /=.
    rewrite !inE in Hn1.
    case/andP : Hn1 => n1n0 m0n1.
    rewrite eq_sym (negbTE n1n0) /= negb_and.
    rewrite !inE in Hm1.
    apply/orP; right.
    apply/negP.
    case/connectP => p.
    case/shortenP => p' Hp' Hun pp' Hlast.
    suff : ucycle (tanner_rel H) (inl m0 :: inr n1 :: inl m1 :: p').
      exact: Hacyclic.
    apply: uniq_path_ucycle_extend_1 => //.
    exact: simple_tanner_rel.
    by rewrite /= -VnextE; case/andP : Hm1.
    by rewrite /= -VnextE -FnextE; case/andP : Hm1.
    rewrite cat_path Hp' /= andbT exceptE /= andbT -Hlast -VnextE m0n0 /=.
    apply/eqP; case => ?; subst n1.
    by rewrite in_setD1 eqxx in K4.
    rewrite -(cat1s (inl m1)) catA cat_uniq Hun /= andbT orbF inE negb_or.
    apply/andP; split.
      apply/eqP; case => ?; subst m1; by rewrite eqxx in Hm1.
    apply/negP => m0p.
    case/splitPr : m0p => p1 p2 in Hp' Hun pp' Hlast.
    suff : ucycle (tanner_rel H) (inl m0 :: inr n1 :: inl m1 :: p1) by apply Hacyclic.
    apply: uniq_path_ucycle_extend_1.
    exact: simple_tanner_rel.
    by rewrite /= -VnextE.
    rewrite /= -VnextE -FnextE; by case/andP : Hm1.
    rewrite -(cat1s (inl m0)) catA cat_path in Hp'; by case/andP : Hp'.
    rewrite -(cat1s (inl m1)) -(cat1s (inl m0)) 2!catA cat_uniq in Hun.
    by case/andP : Hun.
  apply/eqP.
  move/setP/(_ n0).
  by rewrite K4 (negbTE K5).
move/(_ K3)/disjoint_setI0/setP/(_ n2).
rewrite inE Hn2 /= in_set0 in_setD1 H1.
rewrite in_setD1 in Hn2.
case/andP : Hn2.
by move=> -> _.
Qed.

Lemma Fgraph_injective n0 m0 m1 :
  n0 \in 'V m0 -> n0 \in 'V m1 -> 'F(m0, n0) = 'F(m1, n0) -> m0 = m1.
Proof.
move=> Hm0 Hm1 m0m1.
apply/eqP/negPn/negP => abs.
have : exists cy, (2 < size cy)%nat /\ ucycleb (tanner_rel H) cy.
  have : connect (except (tanner_rel H) (inr n0)) (inl m0) (inl m1).
    have : m0 \in 'F(m1, n0).
      by rewrite -m0m1 /Fgraph 2!inE connect0 andbT -VnextE.
    rewrite 2!inE /subgraph.
    case/andP => n0m1.
    rewrite connect_sym //; exact/symmetric_except/sym_tanner_rel.
  case/connectP => /= s H1 H2.
  case/shortenP : (H1) H2 => /= s' H1' H2' H3' H2.
  have [/= s1 [s2 s1s2]] : exists s1 s2, s' = s1 ++ inl m1 :: s2.
    have m1s : inl m1 \in s'.
      rewrite H2.
      destruct s' as [|h t].
        rewrite /= in H2.
        case: H2 => ?; subst m1; by rewrite eqxx in abs.
      by rewrite /= mem_last.
    case/(nthP (inl m0)) : m1s => i Hi im1.
    exists (take i s'), (drop i.+1 s').
    by rewrite -im1 -drop_nth // cat_take_drop.
  exists (inr n0 :: inl m0 :: s1 ++ [:: inl m1]).
  split.
    by rewrite /= size_cat /= addn1.
  apply/andP; split; last first.
    rewrite -/(uniq (inl m0 :: s')) s1s2 -cat1s catA -(cat1s (inl m1)) catA cat_uniq in H2'.
    case/andP : H2' => H2' H2''.
    rewrite cons_uniq H2' andbC /= inE /= mem_cat /= negb_or.
    apply/andP; split => //.
    apply/negP => abs'.
    have {abs'}abs' : inr n0 \in s' by rewrite s1s2 mem_cat abs'.
    case/(nthP (inl m0)) : abs' => i Hi abs'.
    move/pathP : H1'.
    move/( _ (inl m0) _ Hi).
    by rewrite exceptE /= abs' eqxx andbA andbC.
  rewrite /cycle /=.
  rewrite -VnextE Hm0 /= rcons_path.
  apply/andP; split.
    rewrite s1s2 -cat1s catA cat_path in H1'.
    case/andP : H1' => H1' _; move: H1'.
    exact: except_path.
  by rewrite last_cat /= -VnextE.
case=> cy [] H1; exact: Hacyclic.
Qed.

Lemma Fgraph_disjoint n0 m0 m1 m2 :
  m2 \in 'F(m0, n0) -> m2 \in 'F(m1, n0) -> m0 = m1.
Proof.
move=> m3m1 m3m2.
case/boolP : (m0 == m1) => [/eqP //| m1m2].
suff : Logic.False by done.
move: (trivIset_Fgraph_part_fnode n0).
move/trivIsetP.
move/(_ 'F(m0, n0) 'F(m1, n0)).
have m1n1 : n0 \in 'V m0.
  apply: contraLR m3m1.
  move/Fgraph_nonempty/eqP => ->.
  by rewrite in_set0.
have m2n1 : n0 \in 'V m1.
  apply: contraLR m3m2.
  move/Fgraph_nonempty/eqP => ->.
  by rewrite in_set0.
have H1 : 'F(m0, n0) \in Fgraph_part_fnode n0.
  apply/imsetP; exists m0 => //; by rewrite FnextE.
have H2 : 'F(m1, n0) \in Fgraph_part_fnode n0.
  apply/imsetP; exists m1 => //; by rewrite FnextE.
move/(_ H1 H2) => {H1 H2}.
have Htmp : 'F(m0, n0) != 'F(m1, n0).
  apply: contra m1m2 => /eqP Htmp; apply/eqP; move: Htmp.
  exact: Fgraph_injective.
move/(_ Htmp) => {Htmp}.
rewrite -setI_eq0.
move/set0Pn.
apply.
exists m2.
by rewrite inE m3m1 m3m2.
Qed.

Lemma Vgraph_injective n0 m0 m1 :
  n0 \in 'V m0 -> n0 \in 'V m1 -> 'V(m0, n0) :\ n0 != set0 ->
  'V(m1, n0) :\ n0 != set0 -> 'V(m0, n0) :\ n0 = 'V(m1, n0) :\ n0 -> m0 = m1.
Proof.
move=> Hm0 Hm1 m0m1 H10 H20.
apply/eqP/negPn/negP => abs.
have : exists cy, (2 < size cy)%nat /\ ucycleb (tanner_rel H) cy.
  have : connect (except (tanner_rel H) (inr n0)) (inl m0) (inl m1).
    have : exists n1, n1 \in 'V(m1, n0) :\ n0 by apply/set0Pn.
    case=> n1 Hn1; move: (Hn1).
    rewrite !inE.
    case/andP => n1n0.
    case/orP => [/eqP ? | ]; first by subst n1; rewrite eqxx in n1n0.
    rewrite /subgraph => /andP [] n0m1 Htmp.
    have Htmp2 : connect (except (tanner_rel H) (inr n0)) (inl m0) (inr n1).
      move: Hn1.
      rewrite -H20 !inE.
      case/andP => _.
      case/orP => [/eqP ? | ]; first by subst n1; rewrite eqxx in n1n0.
      by case/andP.
    apply (connect_trans Htmp2).
    rewrite connect_sym //; exact/symmetric_except/sym_tanner_rel.
  case/connectP => /= s H1 H2.
  case/shortenP : (H1) H2 => /= s' H1' H2' H3' H2.
  have [/= s1 [s2 s1s2]] : exists s1 s2, s' = s1 ++ inl m1 :: s2.
    have m1s : inl m1 \in s'.
      rewrite H2.
      destruct s' as [|h t].
        rewrite /= in H2.
        case: H2 => ?; subst m1; by rewrite eqxx in abs.
      by rewrite /= mem_last.
    case/(nthP (inl m0)) : m1s => i Hi im1.
    exists (take i s'), (drop i.+1 s').
    by rewrite -im1 -drop_nth // cat_take_drop.
  exists (inr n0 :: inl m0 :: s1 ++ [:: inl m1]).
  split.
    by rewrite /= size_cat /= addn1.
  apply/andP; split; last first.
    rewrite -/(uniq (inl m0 :: s')) s1s2 -cat1s catA -(cat1s (inl m1)) catA cat_uniq in H2'.
    case/andP : H2' => H2' H2''.
    rewrite cons_uniq H2' andbC /= inE /= mem_cat /= negb_or.
    apply/andP; split => //.
    apply/negP => abs'.
    have {abs'}abs' : inr n0 \in s' by rewrite s1s2 mem_cat abs'.
    case/(nthP (inl m0)) : abs' => i Hi abs'.
    move/pathP : H1'.
    move/( _ (inl m0) _ Hi).
    by rewrite exceptE /= abs' eqxx !andbF.
  rewrite /cycle /=.
  rewrite -VnextE Hm0 /= rcons_path.
  apply/andP; split.
    rewrite s1s2 -cat1s catA cat_path in H1'.
    case/andP : H1' => H1' _; move: H1'.
    exact: except_path.
  by rewrite last_cat /= -VnextE.
case=> cy [] H1; exact: Hacyclic.
Qed.

Local Open Scope R_scope.

Lemma rprod_Fgraph_part_fnode g n0:
  \rprod_(m0 < m) g m0 = \rprod_(m0 in 'F n0) \rprod_(m1 in 'F(m0, n0)) g m1.
Proof.
transitivity (\rprod_(m0 in [set: 'I_m]) g m0).
  apply eq_bigl => /= ?; by rewrite in_set.
rewrite -(cover_Fgraph_part_fnode n0).
rewrite big_trivIset /=; last exact: trivIset_Fgraph_part_fnode.
rewrite big_imset // => //.
move=> m1 m2 Hm1 Hm2 /=.
apply Fgraph_injective => //; by rewrite -FnextE.
Qed.

Lemma disjoint_Vgraph (m0 m1 : 'I_m) (n1 n0 : 'I_n) : n1 != n0 -> m0 != m1 ->
  n1 \in 'V(m0, n0) -> n1 \notin 'V(m1, n0).
Proof.
move=> n1n0 m0m1 Hn1; apply/negP => Hm1.
have Hm0' : n0 \in 'V m0.
  apply: contraLR Hn1.
  move/Vgraph_set1 => ->; by rewrite in_set1.
have Hm1' : n0 \in 'V m1.
  apply: contraLR Hm1.
  move/Vgraph_set1 => ->; by rewrite in_set1.
have Hdiff : 'V(m0, n0) :\ n0 != 'V(m1, n0) :\ n0.
  move: m0m1; apply contra.
  move/eqP => abs; apply/eqP; move: abs.
  apply Vgraph_injective => //.
  apply/set0Pn; exists n1; by rewrite in_setD1 n1n0 Hn1.
  apply/set0Pn; exists n1; by rewrite in_setD1 n1n0 Hm1.
move: (trivIset_Vgraph_part_vnode n0).
move/trivIsetP.
move/(_ ('V(m0, n0) :\ n0) ('V(m1, n0) :\ n0)) => /= abs.
have : 'V(m0, n0) :\ n0 \in Vgraph_part_vnode n0.
  case: imsetP => // abs'.
  suff: Logic.False by done.
  apply abs'; exists m0 => //; by rewrite FnextE.
move/abs => {abs}abs.
have : 'V(m1, n0) :\ n0 \in Vgraph_part_vnode n0.
   case: imsetP => // abs'; exfalso.
   apply abs'; exists m1 => //; by rewrite FnextE.
move/abs => {abs}abs.
move: (abs Hdiff) => {abs}abs'.
move/disjoint_setI0 : abs' => abs'.
move: abs'; apply/eqP.
apply/set0Pn.
exists n1.
by rewrite in_setI in_setD1 n1n0 /= Hn1 /= in_setD1 n1n0 Hm1.
Qed.

Definition Fgraph_part_Fgraph m0 n0 : {set {set 'I_m}} :=
  (fun n1 => \bigcup_(m1 in 'F n1 :\ m0) 'F(m1, n1)) @: (('V m0) :\ n0).

Lemma cover_Fgraph_part_Fgraph m0 n0 : n0 \in 'V m0 ->
  cover (Fgraph_part_Fgraph m0 n0) = 'F(m0, n0) :\ m0.
Proof.
move=> Htmp.
have {Htmp}Htmp : tanner_rel H (inl m0) (inr n0) by rewrite VnextE sym_tanner_rel in Htmp.
move: (cover_subgraph_succ2_D1 (sym_tanner_rel H) Hacyclic (simple_tanner_rel H) Htmp) => Hcover.
apply/setP => /= m1.
rewrite 2!inE.
move Hlhs : ( _ \in _ ) => [|].
  apply/esym.
  have Hm1 : inl m1 \in cover (subgraph_succ2_D1 Htmp).
    rewrite /Fgraph_part_Fgraph in Hlhs.
    case/bigcupP : Hlhs => /= i i1 i2.
    case/imsetP : i1 => /= n1 Hn1 i1.
    apply/bigcupP => /=.
    exists (inr n1 |: \bigcup_(m' in successors (tanner_rel H) (inr n1) :\ inl m0) (subgraph (tanner_rel H) m' (inr n1))).
      apply/imsetP => /=.
      exists (inr n1) => //.
      rewrite !inE /= -VnextE.
      rewrite !inE /= in Hn1.
      case/andP: Hn1 => Hn1 ->; rewrite andbT.
      by apply: contra Hn1 => /eqP Hn1; case: Hn1 => ->.
    rewrite !inE /=.
    apply/bigcupP => /=.
    rewrite i1 in i2.
    case/bigcupP : i2 => /= m2 Hm2 Hm1.
    exists (inl m2).
      rewrite !inE /=.
      rewrite !inE /= in Hm1.
      case/andP : Hm1 => -> _; rewrite andbT.
      apply/eqP => abs; case : abs => ?; subst m2.
      by rewrite !inE /= eqxx in Hm2.
    rewrite !inE /= in Hm1.
    by rewrite /subgraph !inE.
  rewrite Hcover 2!inE in Hm1.
  apply/andP; split.
    case/andP : Hm1 => Hm1 _.
    by apply: contra Hm1 => /eqP ->.
  case/andP : Hm1 => _ Hm1.
  by rewrite inE.
apply/esym/negbTE.
rewrite negb_and negbK.
case/boolP : (m1 == m0) => // m1m0 /=.
move/negbT : Hlhs; apply contra => Hlhs.
apply/bigcupP => /=.
rewrite inE in Hlhs.
rewrite /Fgraph_part_Fgraph.
rewrite !inE /= in Hlhs.
case/andP : Hlhs => Hlhs Hlhs'.
case/connectP : Hlhs' => /= p.
case/shortenP => p' Hp' Hun p'p Hlast.
case: p' Hp' Hun p'p Hlast => [|p1 p2] Hp' Hun p'p Hlast.
  rewrite /= in Hlast.
  case: Hlast => ?; subst m1.
  by rewrite eqxx in m1m0.
case: p1 Hp' Hun p'p Hlast => [|n1 Hp' Hun p'p Hlast].
  by rewrite exceptE /= tanner_relE.
exists (\bigcup_(m2 in 'F n1 :\ m0) 'F(m2, n1)).
  apply/imsetP.
  exists n1 => //.
  rewrite !inE.
  rewrite /= in Hp'.
  case/andP : Hp'.
  rewrite {1}exceptE /= -VnextE => /andP[H1 H2] _.
  rewrite H1 andbT.
  by apply: contra H2 => /eqP ->.
apply/bigcupP => /=.
case: p2 Hp' Hun p'p Hlast => [ // | [p2|p2] p'] Hp' Hun p'p Hlast; last first.
  by rewrite exceptE /= tanner_relE /= andbF in Hp'.
rewrite /= in Hp'.
case/andP : Hp' => H1 /andP [] H2 H3.
exists p2.
  rewrite !inE.
  apply/andP; split.
    apply/eqP => ?; subst p2.
    rewrite -(cat1s (inl m0)) -(cat1s (inr n1)) -[in X in _ ++ X](cat1s (inl m0)) in Hun.
    by rewrite catA uniq_catCA /= inE eqxx /= in Hun.
  by move/except_rel : H2; rewrite /= -VnextE -FnextE.
rewrite !inE.
rewrite (except_rel H2) /=.
apply/connectP; exists p' => //.
apply: sub_path_except H3 => //.
apply/negP => n1p'.
move: Hun.
rewrite -(cat1s (inl m0)) -(cat1s (inr n1)) -(cat1s (inl p2)) catA uniq_catCA.
by rewrite catA uniq_catC -!catA catA cat_uniq uniq_catC /= n1p'.
Qed.

Lemma trivIset_Fgraph_part_Fgraph m0 n0 : n0 \in 'V m0 ->
  trivIset (Fgraph_part_Fgraph m0 n0).
Proof.
move=> m0n0.
rewrite VnextE sym_tanner_rel in m0n0.
move: (@trivIset_subgraph_succ2_D1 _ _ (sym_tanner_rel H)
  Hacyclic (simple_tanner_rel H) (inl m0) (inr n0) m0n0) => K.
apply: (@trivIsetS_f _ _ inl) K => /= z.
rewrite /Fgraph_part_Fgraph.
case/imsetP => n1 Hn1 Hz.
rewrite /subgraph_succ2_D1.
exists (inr n1 |: \bigcup_(m1 in successors (tanner_rel H) (inr n1) :\ inl m0)
  (subgraph (tanner_rel H) m1 (inr n1))).
split.
  apply/imsetP => /=.
  exists (inr n1).
    rewrite !inE /= in Hn1.
    rewrite !inE /= -VnextE.
    case/andP : Hn1 => Hn1 ->.
    rewrite andbT.
    by apply: contra Hn1 => /eqP [] ->.
  by f_equal.
rewrite Hz.
apply/setP => /= m1.
apply/bigcupP.
case: ifP.
  rewrite 3!inE /=.
  case/bigcupP => /=.
  case=> [m2 Hm2 Hm1 | n2].
    exists m2 => //.
      rewrite in_setD1 FnextE.
      rewrite !inE /= -VnextE in Hm2.
      case/andP : Hm2 => Hm2 ->.
      rewrite andbT.
      by apply: contra Hm2 => /eqP ->.
    by rewrite inE.
  by rewrite !inE {2}tanner_relE.
rewrite !inE /=.
move/negbT/negP => abs' abs; apply abs' => {abs'}.
case: abs => m2 Hm Hm1.
apply/bigcupP => /=.
exists (inl m2).
  rewrite !inE /= -VnextE.
  rewrite in_setD1 FnextE in Hm.
  case/andP : Hm => Hm ->.
  rewrite andbT.
  by apply: contra Hm => /eqP [] ->.
by rewrite inE in Hm1.
Qed.

Lemma another_Fgraph_injective (m0 : 'I_m) (n0 n1 n2 : 'I_n)
  (Hn1 : n1 \in 'V m0 :\ n0) (Hn2 : n2 \in 'V m0 :\ n0) :
  'F n1 :\ m0 != set0 -> (* 'F n2 :\ m0 != set0 *)
  \bigcup_(m1 in 'F n1 :\ m0) 'F(m1, n1) = \bigcup_(m1 in 'F n2 :\ m0) 'F(m1, n2) ->
  n1 = n2.
Proof.
move=> Hset0.
move=> abs.
apply/eqP/negPn/negP => n1n2.
have {Hset0}Hset0 : \bigcup_(m1 in 'F n1 :\ m0) 'F(m1, n1) != set0.
  apply: contra Hset0; exact: bigcup_succ_set0.
case/set0Pn : Hset0 => /= m1 Habs.
move: (Habs).
case/bigcupP => /= m2 Hm2 Hm1.
rewrite !inE /= in Hm1.
case/andP : Hm1 => m2n1.
case/connectP => /= p.
case/shortenP => p' Hp' unp pp' lastp.
rewrite abs in Habs.
move: Habs.
case/bigcupP => /= m3 Hm3 Hm1'.
rewrite !inE /= in Hm1'.
case/andP : Hm1' => m3n2.
case/connectP => /= p0.
case/shortenP => p0' Hp0' unp0 p0p0' lastp0.
destruct p' as [|p'1 p'2].
  rewrite /= in lastp.
  case: lastp => ?; subst m2.
  suff : ucycle (tanner_rel H) (inr n1 :: inl m0 :: inr n2 :: inl m3 :: p0').
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_2.
  exact: sym_tanner_rel.
  exact: simple_tanner_rel.
  by [].
  by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
  by [].
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  apply/eqP; case => ?; subst m3; by rewrite in_setD1 eqxx in Hm3.
  rewrite cat_path Hp0' /= andbT exceptE /= -lastp0 /= sym_tanner_rel m2n1 /=.
  by apply: contra n1n2 => /eqP [] ->.
  by [].
destruct p0' as [|p0'1 p0'2].
  rewrite /= in lastp0.
  case: lastp0 => ?; subst m3.
  suff : ucycle (tanner_rel H) (inr n2 :: inl m0 :: inr n1 :: inl m2 :: p'1 :: p'2).
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_3.
  exact: sym_tanner_rel.
  exact: simple_tanner_rel.
  by [].
  by move: Hp' => /= /andP[] /except_rel.
  by move: Hp' => /= /andP[] /except_rel.
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
  apply/eqP; case => ?; subst m2; by rewrite in_setD1 eqxx in Hm2.
  move/path_except_notin : Hp'; rewrite inE negb_or => /andP []; by rewrite eq_sym.
  by apply: contra n1n2 => /eqP [] ->.
  rewrite cat_path.
  apply/andP; split.
    rewrite /= in Hp'.
    case/andP : (Hp') => Hp'1 Hp'2.
    apply: sub_path_except Hp'2.
      apply/eqP => ?; subst p'1.
      by move/andP : Hp'; rewrite exceptE /= {1}tanner_relE; case.
    apply/negP => m2p'2.
    move: unp.
    rewrite -(cat1s (inl m2)) -(cat1s p'1) uniq_catCA uniq_catC cat_uniq.
    case/andP => /andP []; by rewrite m2p'2.
  rewrite /= in lastp.
  rewrite /= andbT exceptE /= andbT -lastp /= sym_tanner_rel m3n2 /=.
  apply/eqP; case => ?; subst m2.
  move: unp.
  by rewrite cons_uniq lastI mem_rcons inE -lastp /= eqxx.
  rewrite [p'1 :: _]lock /= -lock in unp; by case/andP : unp.
suff : ucycle (tanner_rel H)
  ((inl m1 :: rev (belast p0'1 p0'2)) ++ (inl m3 :: inr n2 :: inl m0 :: inr n1 :: inl m2 :: belast p'1 p'2)).
  apply Hacyclic; by rewrite size_cat addnC.
apply: uniq_path_ucycle_cat_extend; try assumption.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
apply/eqP; case => ?; subst m3; by rewrite in_setD1 eqxx in Hm3.
apply/eqP; case => ?; subst m2; by rewrite in_setD1 eqxx in Hm2.
by rewrite lastp [_ ++ _]/= cats1 -lastI.
by rewrite lastp0 cats1 -lastI.
move: unp.
rewrite (cons_uniq (inl m2)) => /andP [] H1 H2.
rewrite cons_uniq.
apply/andP; split.
  apply: contra H1; by move/mem_belast.
rewrite lastI rcons_uniq in H2; by case/andP : H2.
move: unp0.
rewrite (cons_uniq (inl m3)) => /andP [] H1 H2.
rewrite cons_uniq.
apply/andP; split.
  apply: contra H1; by move/mem_belast.
rewrite lastI rcons_uniq in H2; by case/andP : H2.
Qed.

Lemma Vgraph_id n0 m0 n1 n1' m1 m1' n2 :
  n0 \in 'V m0 ->
  n1 \in 'V m0 :\ n0 -> n1' \in 'V m0 :\ n0 ->
  m1 \in 'F n1 :\ m0 -> m1' \in 'F n1' :\ m0 ->
  n2 \in 'V(m1, n1) ->
  n2 \in 'V(m1', n1') -> n1 = n1'.
Proof.
move=> Hn0 Hn1 Hn1' Hm1 Hm1'.
rewrite !inE.
case/orP => [/eqP ? |]; [subst n2|].
  case/orP => [/eqP ?|]; [by subst n1'|].
  case/andP => n1'm1'.
  case/connectP => /= p.
  case/shortenP => p' Hp' unp pp' lastp.
  exfalso.
  suff : path.ucycle (tanner_rel H) [:: inl m0, inr n1', inl m1' & p'].
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
  rewrite cat_path /= andbT Hp' /= exceptE /= -lastp andbT.
  apply/andP; split.
    by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  apply/eqP; case => ?; subst n1'.
  move/path_except_notin : Hp'.
  destruct p' => //.
  rewrite /= in lastp.
  by rewrite lastI -lastp mem_rcons inE eqxx.
  rewrite -(cat1s (inl m1')) catA cat_uniq unp /= andbT orbF inE negb_or.
  apply/andP; split.
    rewrite !inE in Hm1'.
    case/andP : Hm1' => Hm1' _.
    by apply: contra Hm1' => /eqP [] ->.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' unp pp' lastp.
  suff : ucycle (tanner_rel H) [:: inl m0, inr n1', inl m1' & p1].
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
  rewrite -(cat1s (inl m0)) catA cat_path in Hp'; by case/andP : Hp'.
  rewrite -(cat1s (inl m0)) -(cat1s (inl m1')) 2!catA cat_uniq in unp; by case/andP : unp.
case/andP => n1m1 /connectP /= [] p.
case/shortenP => p' Hp' unp pp' lastp.
case/orP => [/eqP ?|]; [subst n1'|].
  exfalso.
  suff : path.ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p'].
    exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  rewrite cat_path Hp' /= andbT -lastp exceptE /= andbT -VnextE.
  rewrite !inE in Hn1'.
  case/andP : Hn1' => n2n0 -> /=.
  apply/eqP; case => ?; subst n2.
  move/path_except_notin : Hp'.
  destruct p' => //.
  rewrite /= in lastp.
  by rewrite lastI mem_rcons -lastp inE eqxx.
  rewrite -(cat1s (inl m1)) catA cat_uniq unp /= andbT orbF inE negb_or.
  apply/andP; split.
    apply/eqP; case => ?; subst m1.
    by rewrite in_setD1 eqxx in Hm1.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' unp pp' lastp.
  suff : ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p1] by exact: Hacyclic.
  apply: uniq_path_ucycle_extend_1 => //.
  exact: simple_tanner_rel.
  by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
  rewrite -(cat1s (inl m0)) catA cat_path in Hp'; by case/andP : Hp'.
  rewrite -(cat1s (inl m0)) -(cat1s (inl m1)) 2!catA cat_uniq in unp; by case/andP : unp.
move: (Hm1'); rewrite !inE /= -VnextE -FnextE => /andP [] _ -> /=.
case/connectP => /= q.
case/shortenP => q' Hq' unq qq' lastq.
apply/eqP/negPn/negP => n1n1'.
case: p' Hp' unp pp' lastp => [// | p'1 p'2] Hp' unp pp' lastp.
elim/last_ind : q' Hq' unq qq' lastq => [// | q'1 q'2 _] Hq' unq qq' lastq.
rewrite last_rcons in lastq; subst q'2.
suff : ucycle (tanner_rel H) ((inr n2 :: rev q'1) ++ [:: inl m1', inr n1', inl m0, inr n1, inl m1 & belast p'1 p'2]).
  by apply Hacyclic; rewrite size_cat addnC.
apply: uniq_path_ucycle_cat_extend => //.
exact: sym_tanner_rel.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE -FnextE; move: Hm1'; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
apply/eqP;case => ?; subst m1'; by rewrite in_setD1 eqxx in Hm1'.
apply/eqP;case => ?; subst m1; by rewrite in_setD1 eqxx in Hm1.
by rewrite lastp cats1 -lastI.
by rewrite cats1.
move: unp.
rewrite (lastI p'1) /= mem_rcons inE negb_or => /andP [] /andP [] H1 ->.
by rewrite rcons_uniq => /andP [].
move: unq.
rewrite /= mem_rcons inE negb_or => /andP [] /andP [] -> ->.
by rewrite rcons_uniq => /andP [] _ ->.
Qed.

Definition Vgraph_part_Vgraph m0 n0 : {set {set 'I_n}} :=
  (fun n1 => n1 |: (\bigcup_(m1 in 'F n1 :\ m0) ('V(m1, n1) :\ n1))) @: (('V m0) :\ n0).

Lemma cover_Vgraph_part_Vgraph m0 n0 : n0 \in 'V m0 ->
  cover (Vgraph_part_Vgraph m0 n0) = 'V(m0, n0) :\ n0.
Proof.
move=> Htmp.
have {Htmp}Htmp : tanner_rel H (inl m0) (inr n0) by rewrite VnextE sym_tanner_rel in Htmp.
move: (cover_subgraph_succ2_D1 (sym_tanner_rel H) Hacyclic (simple_tanner_rel H) Htmp) => Hcover.
apply/setP => /= n1.
rewrite 2!inE.
move Hlhs : ( _ \in _ ) => [|].
  apply/esym.
  have Hn1 : inr n1 \in cover (subgraph_succ2_D1 Htmp).
    rewrite /Vgraph_part_Vgraph in Hlhs.
    case/bigcupP : Hlhs => /= i i1 i2.
    case/imsetP : i1 => /= n1' Hn1' i1.
    apply/bigcupP => /=.
    exists (inr n1' |: \bigcup_(m' in successors (tanner_rel H) (inr n1') :\ inl m0) (subgraph (tanner_rel H) m' (inr n1'))).
      apply/imsetP => /=.
      exists (inr n1') => //.
      rewrite !inE /= -VnextE.
      rewrite !inE /= in Hn1'.
      case/andP: Hn1' => Hn1' ->; rewrite andbT.
      by apply: contra Hn1' => /eqP Hn1'; case: Hn1' => ->.
    rewrite !inE /=.
    rewrite i1 !inE in i2.
    case/orP : i2.
      move/eqP => ->; by rewrite eqxx.
    case/bigcupP => /= m1 Hm1.
    rewrite in_setD1.
    case/andP => n1n1' Hn1.
    apply/orP; right.
    apply/bigcupP => /=.
    exists (inl m1).
      move: Hm1.
      rewrite in_setD1 /= in_setD1 inE /= -VnextE -FnextE.
      case/andP => Hm1 ->; rewrite andbT.
      by apply: contra Hm1 => /eqP [] ->.
    by rewrite inE in_set1 (negbTE n1n1') /= inE in Hn1.
  move: Hn1.
  rewrite Hcover in_setD1.
  case/andP => n1m0 Hn1.
  apply/andP; split.
    apply/eqP => ?; subst n1.
    move: Hn1.
    apply/negP/(root_notin_subgraph (simple_tanner_rel _)).
    by rewrite inE sym_tanner_rel.
  by rewrite 3!inE Hn1 orbT.
apply/esym/negbTE.
move/negbT : Hlhs; apply contra.
case/andP.
rewrite 2!inE.
move=> n1n0.
rewrite in_set1 (negbTE n1n0) orFb.
rewrite inE.
case/andP => _ Hn1.
apply/bigcupP => /=.
case/connectP : Hn1 => /= p.
case/shortenP.
case=> //.
case=> [|n2 p' Hp' Hun p'p Hlast]; first by rewrite exceptE tanner_relE.
exists (n2 |: \bigcup_(m1 in 'F n2 :\ m0) ('V(m1, n2) :\ n2)).
  apply/imsetP => /=.
  exists n2 => //.
  rewrite !inE /=.
  move: Hp'.
  rewrite /= exceptE /= -VnextE -andbA => /and3P[] -> tmp _.
  rewrite andbT.
  by apply: contra tmp => /eqP ->.
rewrite !inE.
case: (boolP (n1 == n2)) => //= n1n2.
apply/bigcupP.
case: p' Hp' Hun p'p Hlast => //.
  move=> _ _ _ [] ?; subst n2; by rewrite eqxx in n1n2.
case; last by rewrite exceptE /= tanner_relE /= andbF.
move=> m1 p' Hp' Hun p'p Hlast.
rewrite /= in Hp'.
case/andP : Hp' => H1 /andP [] H2 H3.
rewrite exceptE /= andbT -VnextE -FnextE in H2.
exists m1.
  rewrite !inE.
  case/andP : H2 => -> _.
  rewrite -(cat1s (inl m0)) -(cat1s (inr n2)) -(cat1s (inl m1)) in Hun.
  rewrite uniq_catCA uniq_catC /= in Hun.
  case/andP : Hun.
  rewrite inE negb_or.
  case/andP => Hun _ _.
  rewrite andbT.
  by apply: contra Hun => /eqP ->.
rewrite !inE (negbTE n1n2) /= -VnextE -FnextE.
case/andP : H2 => -> H2 /=.
apply/connectP; exists p' => //.
apply: sub_path_except H3 => //.
apply/negP => n2p'.
move: Hun.
rewrite -(cat1s (inl m0)) -(cat1s (inr n2)) -(cat1s (inl m1)) catA uniq_catCA.
by rewrite catA uniq_catC -!catA catA cat_uniq uniq_catC /= n2p'.
Qed.

Lemma trivIset_Vgraph_part_Vgraph m0 n0 : n0 \in 'V m0 ->
  trivIset (Vgraph_part_Vgraph m0 n0).
Proof.
move=> m0n0.
have {m0n0}m0n0 : tanner_rel H (inl m0) (inr n0) by rewrite VnextE sym_tanner_rel in m0n0.
move: (@trivIset_subgraph_succ2_D1 _ _ (sym_tanner_rel H)
  Hacyclic (simple_tanner_rel _) (inl m0) (inr n0) m0n0) => K.
apply: (@trivIsetS_f _ _ inr) K => /= z.
rewrite /Vgraph_part_Vgraph.
case/imsetP => /= n1 Hn1 Hz.
rewrite /subgraph_succ2_D1.
exists (inr n1 |: \bigcup_(m1 in successors (tanner_rel H) (inr n1) :\ inl m0)
  (@subgraph _ (tanner_rel H) m1 (inr n1))).
split.
  apply/imsetP => /=.
  exists (inr n1) => //.
  rewrite !inE /= in Hn1.
  rewrite !inE /= -VnextE.
  case/andP : Hn1 => Hn1 ->.
  rewrite andbT.
  by apply: contra Hn1 => /eqP [] ->.
rewrite Hz.
apply/setP => /= m1.
rewrite !inE.
case: (boolP (m1 == n1)) => [|m1n1] /=.
  move/eqP => ->; by rewrite eqxx.
rewrite (_ : inr m1 == _ = false) /=; last first.
  apply/negbTE.
  by apply: contra m1n1 => /eqP [] ->.
apply/bigcupP.
case: ifP.
  case/bigcupP => /=.
  case => [m2 | n2]; last by rewrite !inE {2}tanner_relE.
  rewrite 3!inE /=.
  case/andP => m2m0 m2n1 X.
  rewrite -VnextE -FnextE in m2n1.
  exists m2.
    rewrite !inE /= m2n1 andbT.
    by apply: contra m2m0 => /eqP ->.
  by rewrite in_setD1 m1n1 /= inE in_set1 (negbTE m1n1) orFb inE.
move/bigcupP => abs abs'; apply abs => {abs}.
case: abs' => m2 Hm2 Hm1 /=.
exists (inl m2).
  rewrite !inE /= -VnextE -FnextE.
  rewrite !inE /= in Hm2.
  case/andP : Hm2 => m2m0 ->.
  rewrite andbT.
  by apply: contra m2m0 => /eqP [] ->.
rewrite !inE (negbTE m1n1) /= in Hm1.
by rewrite !inE.
Qed.

Lemma Vgraph_injective3 (m0 : 'I_m) (n0 n1 n2 : 'I_n)
  (Hn1 : n1 \in 'V m0 :\ n0) (Hn2 : n2 \in 'V m0 :\ n0) :
  n1 |: (\bigcup_(m1 in 'F n1 :\ m0) ('V(m1, n1) :\ n1)) = n2 |: (\bigcup_(m1 in 'F n2 :\ m0) ('V(m1, n2) :\ n2)) ->
  n1 = n2.
Proof.
move=> abs.
apply/eqP/negPn/negP => abs'.
have [m1] : exists m1, (m1 \in 'F n1 :\ m0) && (n2 \in 'V(m1, n1) :\ n1).
  move/setP : abs.
  move/(_ n2) => abs.
  have {abs} : n2 \in n1 |: \bigcup_(m1 in 'F n1 :\ m0) ('V(m1, n1) :\ n1).
    by rewrite abs inE in_set1 eqxx.
  rewrite inE in_set1 eq_sym (negbTE abs') orFb.
  case/bigcupP => m1 Hm1 n2m1 .
  exists m1; by rewrite Hm1.
case/andP => m1n1.
rewrite in_setD1 eq_sym abs' /=.
rewrite inE.
rewrite in_set1 eq_sym (negbTE abs') /= 2!inE.
case/andP => _.
case/connectP => p.
case/shortenP => p' Hp unp pp' lastp.
suff : ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p'] by exact: Hacyclic.
apply: uniq_path_ucycle_extend_1.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE -FnextE; move: m1n1; rewrite in_setD1 => /andP[].
rewrite cat_path Hp /= andbT exceptE /= andbT -lastp.
apply/andP; split.
  by rewrite /= -VnextE; move: Hn2; rewrite in_setD1 => /andP[].
apply/eqP; case=> ?; subst n2; by rewrite eqxx in abs'.
rewrite -(cat1s (inl m1)) catA cat_uniq unp /= andbT orbF inE negb_or.
apply/andP; split.
  apply/eqP; case => ?; subst m1; by rewrite in_setD1 eqxx in m1n1.
apply/negP => m0p'.
case/splitPr : m0p' => p'1 p'2 in Hp unp pp' lastp.
suff : ucycle (tanner_rel H) [:: inl m0, inr n1, inl m1 & p'1].
  exact: Hacyclic.
apply: uniq_path_ucycle_extend_1; try assumption.
exact: simple_tanner_rel.
by rewrite /= -VnextE; move: Hn1; rewrite in_setD1 => /andP[].
by rewrite /= -VnextE -FnextE; move: m1n1; rewrite in_setD1 => /andP[].
rewrite -(cat1s (inl m0)) catA cat_path in Hp; by case/andP : Hp.
rewrite -(cat1s (inl m1)) -(cat1s (inl m0)) 2!catA cat_uniq in unp; by case/andP : unp.
Qed.

End tanner_partition.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj17eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 (mult lv2 lv1))) (plus lv0 (mult lv1 (Succ lv2)))).
Admitted.
QuickChick conj17eqsynthconj3.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (mult (Succ lv0) lv1) (mult lv3 lv1))).
Admitted.
QuickChick conj23synthconj5.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C I H1 H2 : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (col_ B C H2 /\ (col_ B C I /\ (col_ H2 B I /\ (col_ I B H1 /\ col_ B H1 A)))))))))))) -> col_ H2 B H1)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import CoqPropInLogicNotation.
Import SeparationLogicNotation.

Class SepconAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_comm_impp: forall x y, |-- x * y --> y * x;
  sepcon_assoc1: forall x y z, |-- x * (y * z) --> (x * y) * z;
  sepcon_mono: forall x1 x2 y1 y2, |-- x1 --> x2 -> |-- y1 --> y2 -> |-- (x1 * y1) --> (x2 * y2);
}.

Class SepconOrAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  orp_sepcon_impp: forall (x y z: expr),
    |-- (x || y) * z --> x * z || y * z
}.

Class SepconCoqPropAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {iffpL: IffLanguage L}
        {coq_prop_L: CoqPropLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  prop_andp_sepcon1: forall P Q R,
    |-- (!! P && Q) * R <--> !! P && (Q * R)
}.

Class SepconFalseAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {falsepL: FalseLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  falsep_sepcon_impp: forall (x: expr),
    |-- FF * x --> FF
}.

Class EmpAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
    sepcon_emp1: forall x, |-- x * emp --> x;
    sepcon_emp2: forall x, |-- x --> x * emp
}.

Class WandAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (Gamma: Provable L) := {
  wand_sepcon_adjoint: forall x y z, |-- x * y --> z <-> |-- x --> (y -* z)
}.

Class ExtSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {trueL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_ext: forall x, |-- x --> x * TT
}.

Class NonsplitEmpSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  emp_sepcon_truep_elim: forall x, |-- (x * TT) && emp --> x
}.

Class DupEmpSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  emp_dup: forall x, |-- x && emp --> x * x
}.

(* Only for documentation *)
Class MallocFreeSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  MallocFreeSeparationLogic_NonsplitEmpSeparationLogic :>
    NonsplitEmpSeparationLogic L Gamma;
  MallocFreeSeparationLogic_DupEmpSeparationLogic :>
    DupEmpSeparationLogic L Gamma
}.

Class GarbageCollectSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_elim1: forall x y, |-- x * y --> x
}.

Class SepconDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_comm: forall x y, x * y |-- y * x;
  derivable1_sepcon_assoc1: forall x y z, x * (y * z) |-- (x * y) * z;
  derivable1_sepcon_mono: forall x1 x2 y1 y2, x1 |-- x2 -> y1 |-- y2
               -> (x1 * y1) |-- (x2 * y2);
}.

Class SepconOrDeduction
        (L: Language)
        {orpL: OrLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  orp_sepcon_left: forall x y z,
     (x || y) * z |-- x * z || y * z
}.

Class SepconFalseDeduction
        (L: Language)
        {falsepL: FalseLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  falsep_sepcon_left: forall x,
     FF * x |-- FF
}.

Class EmpDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
    sepcon_emp_left: forall x,  x * emp |-- x;
    sepcon_emp_right: forall x, x |-- x * emp
}.

Class WandDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_wand_sepcon_adjoint: forall x y z, x * y  |-- z <-> x |-- (y -* z)
}.

Class ExtSeparationLogicDeduction
        (L: Language)
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_ext: forall x, x |-- x * TT
}.

Class NonsplitEmpSeparationLogicDeduction
        (L: Language)
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_emp_sepcon_truep_elim: forall x, (x * TT) && emp |-- x
}.

Class DupEmpSeparationLogicDeduction
        (L: Language)
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_emp_dup: forall x, x && emp |-- x * x
}.

Class GarbageCollectSeparationLogicDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_elim1: forall x y, x * y |-- x
}.

Section SepconRules.

Context {L: Language}
        {sepconL: SepconLanguage L}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}
        {sepconD: SepconDeduction L GammaD1}.

Lemma derivable1_sepcon_Comm: D1.Commutativity L GammaD1 sepcon.
Proof.
  constructor.
  intros.
  apply derivable1_sepcon_comm.
Qed.

Lemma derivable1_sepcon_Mono: D1.Monotonicity L GammaD1 sepcon.
Proof.
  constructor.
  intros.
  apply derivable1_sepcon_mono; auto.
Qed.

Lemma derivable1_sepcon_Assoc: D1.Associativity L GammaD1 sepcon.
Proof.
  apply @D1.Build_Associativity1; auto.
  + apply derivable1_sepcon_Comm.
  + apply derivable1_sepcon_Mono.
  + intros.
    apply derivable1_sepcon_assoc1.
Qed.

Lemma derivable1_sepcon_assoc2: forall x y z, (x * y) * z |-- x * (y * z).
Proof.
  intros.
  apply (@D1.prodp_assoc2 _ _ _ derivable1_sepcon_Assoc).
Qed.

Lemma orp_sepcon_right
      {orpL: OrLanguage L}
      {orpD: OrDeduction L GammaD1}:
  forall (x y z: expr), x * z || y * z |-- (x || y) * z.
Proof.
  intros.
  apply derivable1_orp_elim; apply derivable1_sepcon_mono.
  - apply derivable1_orp_intros1.
  - reflexivity.
  - apply derivable1_orp_intros2.
  - reflexivity.
Qed.

Lemma falsep_sepcon_right
      {falsepL: FalseLanguage L}
      {falsepD: FalseDeduction L GammaD1}:
  forall (x: expr), FF |-- FF * x.
Proof.
  intros.
  apply derivable1_falsep_elim.
Qed.

Section emp.

Context {empL: EmpLanguage L}
        {empD: EmpDeduction L GammaD1}.

Lemma derivable1_sepcon_LU: D1.LeftUnit L GammaD1 emp sepcon.
Proof.
  constructor; intros.
  + rewrite derivable1_sepcon_comm.
    apply sepcon_emp_left.
  + rewrite <- derivable1_sepcon_comm.
    apply sepcon_emp_right.
Qed.

Lemma derivable1_sepcon_RU: D1.RightUnit L GammaD1 emp sepcon.
Proof.
  constructor; intros.
  intros.
  + apply sepcon_emp_left.
  + apply sepcon_emp_right.
Qed.

End emp.

Context {GammaE: LogicEquiv L}
        {GammED1: EquivDerivable1 L GammaD1 GammaE}
        {bE: BasicLogicEquiv L GammaE}.

Lemma sepcon_comm_logic_equiv:
  forall (x y: expr), x * y --||-- y * x.
Proof.
  intros.
  apply (@D1.prodp_comm _ _ _ _ _ derivable1_sepcon_Comm).
Qed.

Lemma sepcon_assoc_logic_equiv:
  forall x y z, x * (y * z) --||-- (x * y) * z.
Proof.
  intros.
  apply (@D1.prodp_assoc _ _ _ _ _ derivable1_sepcon_Assoc).
Qed.

Section emp.

Context {empL: EmpLanguage L}
        {empD: EmpDeduction L GammaD1}.

Lemma sepcon_emp_logic_equiv: forall x, x * emp --||-- x.
Proof. apply (@D1.right_unit _ _ _ _ _ _ derivable1_sepcon_RU). Qed.

Lemma emp_sepcon_logic_equiv: forall x, emp * x --||-- x.
Proof. apply (@D1.left_unit _ _ _ _ _ _ derivable1_sepcon_LU). Qed.

End emp.

Context {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {orpD: OrDeduction L GammaD1}
        {falsepD: FalseDeduction L GammaD1}
        {sepcon_orp_D: SepconOrDeduction L GammaD1}
        {sepcon_falsep_D: SepconFalseDeduction L GammaD1}.

Lemma derivable1_sepcon_orp_RDistr: D1.RightDistr L GammaD1 sepcon orp.
Proof.
  constructor; intros.
  + apply orp_sepcon_left.
  + apply orp_sepcon_right.
Qed.

Lemma derivable1_sepcon_orp_LDistr: D1.LeftDistr L GammaD1 sepcon orp.
Proof.
  apply @D1.RightDistr2LeftDistr; auto.
  + apply derivable1_sepcon_Comm.
  + apply derivable1_orp_Mono.
  + apply derivable1_sepcon_orp_RDistr.
Qed.

Lemma sepcon_orp_distr_r: forall (x y z: expr),
  (x || y) * z --||-- x * z || y * z.
Proof.
  intros.
  apply (@D1.prodp_sump_distr_r _ _ _ _ _ _ derivable1_sepcon_orp_RDistr).
Qed.

Lemma sepcon_orp_distr_l: forall (x y z: expr),
  x * (y || z) --||-- x * y || x * z.
Proof.
  intros.
  apply (@D1.prodp_sump_distr_l _ _ _ _ _ _ derivable1_sepcon_orp_LDistr).
Qed.

Lemma falsep_sepcon_logic_equiv: forall (x: expr),
  FF * x --||-- FF.
Proof.
  intros.
  apply logic_equiv_derivable1; split.
  + apply falsep_sepcon_left.
  + apply falsep_sepcon_right.
Qed.

Lemma sepcon_falsep_logic_equiv: forall (x: expr),
  x * FF --||-- FF.
Proof.
  intros.
  rewrite sepcon_comm_logic_equiv.
  apply falsep_sepcon_logic_equiv.
Qed.

End SepconRules.

(*
(** Proof rules for cancel. **)

Lemma cancel_ready: forall x y, |-- x * emp --> y -> |-- x --> y.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- sepcon_emp2 in H.
  auto.
Qed.

Lemma cancel_one_succeed: forall u x y z,
  |-- x * y --> z -> |-- (u * x) * y --> u * z.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite sepcon_assoc2.
  apply sepcon_mono; auto.
  apply provable_impp_refl.
Qed.

Lemma cancel_one_giveup: forall x y z w v,
  |-- x * (y * z) --> w * v-> |-- (y * x) * z --> w * v.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp y x.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite H1.
  apply sepcon_assoc2.
Qed.

Lemma cancel_rev: forall x y z w,  |-- (y * x) * z --> w -> |-- x * (y * z) --> w.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp x y.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite <- H1.
  apply sepcon_assoc1.
Qed.

Lemma cancel_finish: forall x, |-- x * emp --> x.
Proof.
  apply sepcon_emp1.
Qed.

End SepconRules.
*)
Section WandRules.

Context {L: Language}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}
        {wandD: WandDeduction L GammaD1}.

Lemma derivable1_wand_sepcon_Adj: D1.Adjointness L GammaD1 sepcon wand.
Proof.
  constructor.
  intros.
  apply derivable1_wand_sepcon_adjoint.
Qed.

Lemma derivable1_wand_sepcon_modus_ponens1: forall (x y: expr),
  (x -* y) * x |-- y.
Proof.
  intros.
  apply (@D1.adjoint_modus_ponens _ _ _ _ _ derivable1_wand_sepcon_Adj).
Qed.

Context {sepconD: SepconDeduction L GammaD1}.

Lemma derivable1_wand_sepcon_modus_ponens2: forall (x y: expr),
  x * (x -* y) |-- y.
Proof.
  intros.
  rewrite (derivable1_sepcon_comm x (x -* y)).
  apply derivable1_wand_sepcon_modus_ponens1.
Qed.

Lemma derivable1_wand_mono: forall x1 x2 y1 y2,
  x2 |-- x1 -> y1 |-- y2 -> x1 -* y1 |-- x2 -* y2.
Proof.
  intros.
  apply (@D1.funcp_mono _ _ _ _ _ derivable1_wand_sepcon_Adj derivable1_sepcon_Mono); auto.
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {GammaE: LogicEquiv L}
        {GammED1: EquivDerivable1 L GammaD1 GammaE}
        {bE: BasicLogicEquiv L GammaE}
        {andpD: AndDeduction L GammaD1}
        {orpD: OrDeduction L GammaD1}
        {sepcon_orp_D: SepconOrDeduction L GammaD1}.

Lemma wand_andp_logic_equiv: forall x y z: expr,
  x -* y && z --||-- (x -* y) && (x -* z).
Proof.
  intros.
  apply (@D1.funcp_andp_distr_r _ _ _ _ _ _ _ derivable1_wand_sepcon_Adj); auto.
Qed.

Lemma orp_wand_logic_equiv: forall x y z: expr,
  (x || y) -* z --||-- (x -* z) && (y -* z).
Proof.
  intros.
  apply (@D1.orp_funcp _ _ _ _ _ _ _ _ _ _ derivable1_wand_sepcon_Adj _ _ derivable1_sepcon_Comm); auto.
Qed.

Lemma derivable1_sepcon_elim2: forall {gcsD: GarbageCollectSeparationLogicDeduction L GammaD1} (x y: expr),
  x * y |-- y.
Proof.
  intros.
  rewrite (derivable1_sepcon_comm x y).
  apply derivable1_sepcon_elim1.
Qed.

Lemma derivable1_emp_sepcon_elim1
      {truepL: TrueLanguage L}
      {empL: EmpLanguage L}
      {truepD: TrueDeduction L GammaD1}
      {empD: EmpDeduction L GammaD1}
      {nssD: NonsplitEmpSeparationLogicDeduction L GammaD1}:
  forall x y, x * y && emp |-- x.
Proof.
  intros.
  rewrite <- (derivable1_emp_sepcon_truep_elim x) at 2.
  apply andp_proper_derivable1; [| reflexivity].
  apply derivable1_sepcon_mono; [reflexivity |].
  apply derivable1_truep_intros.
Qed.

Lemma derivable1_emp_sepcon_elim2
      {truepL: TrueLanguage L}
      {empL: EmpLanguage L}
      {truepD: TrueDeduction L GammaD1}
      {empD: EmpDeduction L GammaD1}
      {nssD: NonsplitEmpSeparationLogicDeduction L GammaD1}:
  forall x y, x * y && emp |-- y.
Proof.
  intros.
  rewrite derivable1_sepcon_comm.
  apply derivable1_emp_sepcon_elim1.
Qed.

End WandRules.

Section Axiomatization2Deduction.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {GammaP: Provable L}
        {GammaD1: Derivable1 L}
        {GammaD1P: Derivable1Provable L GammaP GammaD1}
        {minAX: MinimumAxiomatization L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}.

Lemma Axiomatization2Deduction_sepconD: SepconDeduction L GammaD1.
Proof.
  constructor; intros.
  + apply derivable1_provable.
    apply sepcon_comm_impp.
  + apply derivable1_provable.
    apply sepcon_assoc1.
  + rewrite derivable1_provable in H, H0 |- *.
    apply sepcon_mono; auto.
Qed.

Lemma Axiomatization2Deduction_wandD
      {wandL: WandLanguage L}
      {wandAX: WandAxiomatization L GammaP}:
  WandDeduction L GammaD1.
Proof.
  constructor; intros.
  rewrite !derivable1_provable.
  apply wand_sepcon_adjoint.
Qed.

Lemma Axiomatization2Deduction_empD
      {empL: EmpLanguage L}
      {empAX: EmpAxiomatization L GammaP}:
  EmpDeduction L GammaD1.
Proof.
  constructor; intros.
  + rewrite derivable1_provable.
    apply sepcon_emp1.
  + rewrite derivable1_provable.
    apply sepcon_emp2.
Qed.

End Axiomatization2Deduction.

Section SepconRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}.

Lemma sepcon_Comm: P.Commutativity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply sepcon_comm_impp.
Qed.

Lemma sepcon_Mono: P.Monotonicity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply sepcon_mono; auto.
Qed.

Lemma sepcon_Assoc: P.Associativity L Gamma sepcon.
Proof.
  apply @P.Build_Associativity1; auto.
  + apply sepcon_Comm.
  + apply sepcon_Mono.
  + intros.
    apply sepcon_assoc1.
Qed.

Lemma sepcon_assoc2: forall x y z, |-- (x * y) * z --> x * (y * z).
Proof.
  intros.
  apply (@P.prodp_assoc2 _ _ _ _ sepcon_Assoc).
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}.

Lemma sepcon_comm:
  forall (x y: expr), |-- x * y <--> y * x.
Proof.
  intros.
  apply (@P.prodp_comm _ _ _ _ _ _ _ sepcon_Comm).
Qed.

Lemma sepcon_assoc:
  forall x y z, |-- x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  apply (@P.prodp_assoc _ _ _ _ _ _ _ sepcon_Assoc).
Qed.

Lemma impp_orp_sepcon:
  forall (x y z: expr), |-- x * z || y * z --> (x || y) * z.
Proof.
  intros.
  apply solve_orp_impp; apply sepcon_mono.
  - apply orp_intros1.
  - apply provable_impp_refl.
  - apply orp_intros2.
  - apply provable_impp_refl.
Qed.

Lemma impp_falsep_sepcon:
  forall (x: expr),|-- FF --> FF * x.
Proof.
  intros.
  apply falsep_elim.
Qed.

Context {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {sepcon_false_AX: SepconFalseAxiomatization L Gamma}.

Lemma sepcon_orp_RDistr: P.RightDistr L Gamma sepcon orp.
Proof.
  constructor; intros.
  + apply orp_sepcon_impp.
  + apply impp_orp_sepcon.
Qed.

Lemma sepcon_orp_LDistr: P.LeftDistr L Gamma sepcon orp.
Proof.
  apply @P.RightDistr2LeftDistr; auto.
  + apply sepcon_Comm.
  + apply orp_Mono.
  + apply sepcon_orp_RDistr.
Qed.

Lemma sepcon_orp_distr_r_iffp: forall (x y z: expr),
  |-- (x || y) * z <--> x * z || y * z.
Proof.
  intros.
  apply (@P.prodp_sump_distr_r _ _ _ _ _ _ _ _ sepcon_orp_RDistr).
Qed.

Lemma sepcon_orp_distr_l_iffp: forall (x y z: expr),
  |-- x * (y || z) <--> x * y || x * z.
Proof.
  intros.
  apply (@P.prodp_sump_distr_l _ _ _ _ _ _ _ _ sepcon_orp_LDistr).
Qed.

Lemma falsep_sepcon: forall (x: expr),
  |-- FF * x <--> FF.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply falsep_sepcon_impp.
  + apply impp_falsep_sepcon.
Qed.

Lemma sepcon_falsep: forall (x: expr),
  |-- x * FF <--> FF.
Proof.
  intros.
  rewrite sepcon_comm.
  apply falsep_sepcon.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L Gamma}.

Lemma sepcon_emp: forall x, |-- x * emp <--> x.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply sepcon_emp1.
  + apply sepcon_emp2.
Qed.

Lemma sepcon_LU: P.LeftUnit L Gamma emp sepcon.
Proof.
  apply P.Build_LeftUnit; intros.
  + rewrite sepcon_comm_impp.
    apply sepcon_emp1.
  + rewrite <- sepcon_comm_impp.
    apply sepcon_emp2.
Qed.

Lemma sepcon_RU: P.RightUnit L Gamma emp sepcon.
Proof.
  apply P.Build_RightUnit.
  intros.
  + apply sepcon_emp1.
  + apply sepcon_emp2.
Qed.

(** Proof rules for cancel. **)

Lemma cancel_ready: forall x y, |-- x * emp --> y -> |-- x --> y.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- sepcon_emp2 in H.
  auto.
Qed.

Lemma cancel_one_succeed: forall u x y z,
  |-- x * y --> z -> |-- (u * x) * y --> u * z.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite sepcon_assoc2.
  apply sepcon_mono; auto.
  apply provable_impp_refl.
Qed.

Lemma cancel_one_giveup: forall x y z w v,
  |-- x * (y * z) --> w * v-> |-- (y * x) * z --> w * v.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp y x.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite H1.
  apply sepcon_assoc2.
Qed.

Lemma cancel_rev: forall x y z w,  |-- (y * x) * z --> w -> |-- x * (y * z) --> w.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp x y.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite <- H1.
  apply sepcon_assoc1.
Qed.

Lemma cancel_finish: forall x, |-- x * emp --> x.
Proof.
  apply sepcon_emp1.
Qed.

End SepconRules.

Section WandRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {wandAX: WandAxiomatization L Gamma}.

Lemma wand_sepcon_Adj: P.Adjointness L Gamma sepcon wand.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
Qed.

Lemma provable_wand_sepcon_modus_ponens1: forall (x y: expr),
  |-- (x -* y) * x --> y.
Proof.
  intros.
  apply (@P.adjoint_modus_ponens _ _ _ _ _ _ wand_sepcon_Adj).
Qed.

Context {sepconAX: SepconAxiomatization L Gamma}.

Lemma provable_wand_sepcon_modus_ponens2: forall (x y: expr),
  |-- x * (x -* y) --> y.
Proof.
  intros.
  rewrite (sepcon_comm_impp x (x -* y)).
  apply provable_wand_sepcon_modus_ponens1.
Qed.

Lemma wand_mono: forall x1 x2 y1 y2,
  |-- x2 --> x1 -> |-- y1 --> y2 -> |-- (x1 -* y1) --> (x2 -* y2).
Proof.
  intros.
  apply (@P.funcp_mono _ _ _ _ _ _ wand_sepcon_Adj sepcon_Mono); auto.
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}
        {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {sepcon_false_AX: SepconFalseAxiomatization L Gamma}.

Lemma wand_andp: forall x y z: expr,
  |-- x -* y && z <--> (x -* y) && (x -* z).
Proof.
  intros.
  apply (@P.funcp_andp_distr_r _ _ _ _ _ _ wand_sepcon_Adj); auto.
Qed.

Lemma orp_wand: forall x y z: expr,
  |-- (x || y) -* z <--> (x -* z) && (y -* z).
Proof.
  intros.
  apply (@P.orp_funcp _ _ _ _ _ _ _ _ wand_sepcon_Adj _ _ _ _ sepcon_Comm); auto.
Qed.

Lemma sepcon_elim2: forall {gcsGamma: GarbageCollectSeparationLogic L Gamma} (x y: expr),
  |-- x * y --> y.
Proof.
  intros.
  rewrite (sepcon_comm_impp x y).
  apply sepcon_elim1.
Qed.

Lemma emp_sepcon_elim1: forall {empL: EmpLanguage L} {empAX: EmpAxiomatization L Gamma} {nssGamma: NonsplitEmpSeparationLogic L Gamma} x y,
  |-- x * y && emp --> x.
Proof.
  intros.
  rewrite <- (emp_sepcon_truep_elim x) at 2.
  apply andp_proper_impp; [| apply provable_impp_refl].
  apply sepcon_mono; [apply provable_impp_refl |].
  apply solve_impp_elim_left, provable_truep.
Qed.

Lemma emp_sepcon_elim2: forall {empL: EmpLanguage L} {empAX: EmpAxiomatization L Gamma} {nssGamma: NonsplitEmpSeparationLogic L Gamma} x y,
  |-- x * y && emp --> y.
Proof.
  intros.
  rewrite sepcon_comm.
  apply emp_sepcon_elim1.
Qed.

End WandRules.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus Zero (plus Zero lv0)) (plus (plus lv1 lv2) lv3)).
Admitted.
QuickChick conj3synthconj1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A B /\ (wd_ A Aprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O A Cprime /\ col_ A C B)))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime M Aprimeprime Cprimeprime : Universe, ((wd_ Aprime Bprime /\ (wd_ Cprime Bprime /\ (wd_ B Aprimeprime /\ (wd_ B Cprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprimeprime Cprimeprime /\ (wd_ C Cprimeprime /\ (wd_ Aprimeprime C /\ (wd_ A Aprimeprime /\ (wd_ A Cprimeprime /\ (wd_ Aprime Cprime /\ (col_ C Cprimeprime B /\ (col_ Aprimeprime B A /\ (col_ Aprimeprime Cprimeprime B /\ (col_ Cprime M Cprimeprime /\ (col_ Aprime M Aprimeprime /\ col_ M B Bprime)))))))))))))))))) -> col_ C B Aprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus (plus lv0 lv1) lv2)) (plus (mult lv2 (Succ lv1)) lv3)).
Admitted.
QuickChick conj19synthconj2.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import fintype prime bigop finset fingroup morphism.
From mathcomp Require Import automorphism quotient action cyclic gproduct.
From mathcomp Require Import gfunctor commutator pgroup center nilpotent.

(******************************************************************************)
(*   The Sylow theorem and its consequences, including the Frattini argument, *)
(* the nilpotence of p-groups, and the Baer-Suzuki theorem.                   *)
(*   This file also defines:                                                  *)
(*      Zgroup G == G is a Z-group, i.e., has only cyclic Sylow p-subgroups.  *)
(******************************************************************************)

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

Import GroupScope.

(* The mod p lemma for the action of p-groups. *)
Section ModP.

Variable (aT : finGroupType) (sT : finType) (D : {group aT}).
Variable to : action D sT.

Lemma pgroup_fix_mod (p : nat) (G : {group aT}) (S : {set sT}) :
  p.-group G -> [acts G, on S | to] -> #|S| = #|'Fix_(S | to)(G)| %[mod p].
Proof.
move=> pG nSG; have sGD: G \subset D := acts_dom nSG.
apply/eqP; rewrite -(cardsID 'Fix_to(G)) eqn_mod_dvd (leq_addr, addKn) //.
have: [acts G, on S :\: 'Fix_to(G) | to]; last move/acts_sum_card_orbit <-.
  rewrite actsD // -(setIidPr sGD); apply: subset_trans (acts_subnorm_fix _ _).
  by rewrite setIS ?normG.
apply: dvdn_sum => _ /imsetP[x /setDP[_ nfx] ->].
have [k oGx]: {k | #|orbit to G x| = (p ^ k)%N}.
  by apply: p_natP; apply: pnat_dvd pG; rewrite card_orbit_in ?dvdn_indexg.
case: k oGx => [/card_orbit1 fix_x | k ->]; last by rewrite expnS dvdn_mulr.
by case/afixP: nfx => a Ga; apply/set1P; rewrite -fix_x mem_orbit.
Qed.

End ModP.

Section ModularGroupAction.

Variables (aT rT : finGroupType) (D : {group aT}) (R : {group rT}).
Variables (to : groupAction D R) (p : nat).
Implicit Types (G H : {group aT}) (M : {group rT}).

Lemma nontrivial_gacent_pgroup G M :
    p.-group G -> p.-group M -> {acts G, on group M | to} ->
  M :!=: 1 -> 'C_(M | to)(G) :!=: 1.
Proof.
move=> pG pM [nMG sMR] ntM; have [p_pr p_dv_M _] := pgroup_pdiv pM ntM.
rewrite -cardG_gt1 (leq_trans (prime_gt1 p_pr)) 1?dvdn_leq ?cardG_gt0 //= /dvdn.
by rewrite gacentE ?(acts_dom nMG) // setIA (setIidPl sMR) -pgroup_fix_mod.
Qed.

Lemma pcore_sub_astab_irr G M :
    p.-group M -> M \subset R -> acts_irreducibly G M to ->
  'O_p(G) \subset 'C_G(M | to).
Proof.
move=> pM sMR /mingroupP[/andP[ntM nMG] minM].
have /andP[sGpG nGpG]: 'O_p(G) <| G := gFnormal _ G.
have sGD := acts_dom nMG; have sGpD: 'O_p(G) \subset D := gFsub_trans _ sGD.
rewrite subsetI sGpG -gacentC //=; apply/setIidPl; apply: minM (subsetIl _ _).
rewrite nontrivial_gacent_pgroup ?pcore_pgroup //=; last first.
  by split; rewrite ?gFsub_trans.
by apply: subset_trans (acts_subnorm_subgacent sGpD nMG); rewrite subsetI subxx.
Qed.

Lemma pcore_faithful_irr_act G M :
    p.-group M -> M \subset R -> acts_irreducibly G M to ->
    [faithful G, on M | to] ->
  'O_p(G) = 1.
Proof.
move=> pM sMR irrG ffulG; apply/trivgP; apply: subset_trans ffulG.
exact: pcore_sub_astab_irr.
Qed.

End ModularGroupAction.

Section Sylow.

Variables (p : nat) (gT : finGroupType) (G : {group gT}).
Implicit Types P Q H K : {group gT}.

Theorem Sylow's_theorem :
  [/\ forall P, [max P | p.-subgroup(G) P] = p.-Sylow(G) P,
      [transitive G, on 'Syl_p(G) | 'JG],
      forall P, p.-Sylow(G) P -> #|'Syl_p(G)| = #|G : 'N_G(P)|
   &  prime p -> #|'Syl_p(G)| %% p = 1%N].
Proof.
pose maxp A P := [max P | p.-subgroup(A) P]; pose S := [set P | maxp G P].
pose oG := orbit 'JG%act G.
have actS: [acts G, on S | 'JG].
  apply/subsetP=> x Gx; rewrite 3!inE; apply/subsetP=> P; rewrite 3!inE.
  exact: max_pgroupJ.
have S_pG P: P \in S -> P \subset G /\ p.-group P.
  by rewrite inE => /maxgroupp/andP[].
have SmaxN P Q: Q \in S -> Q \subset 'N(P) -> maxp 'N_G(P) Q.
  rewrite inE => /maxgroupP[/andP[sQG pQ] maxQ] nPQ.
  apply/maxgroupP; rewrite /psubgroup subsetI sQG nPQ.
  by split=> // R; rewrite subsetI -andbA andbCA => /andP[_]; apply: maxQ.
have nrmG P: P \subset G -> P <| 'N_G(P).
  by move=> sPG; rewrite /normal subsetIr subsetI sPG normG.
have sylS P: P \in S -> p.-Sylow('N_G(P)) P.
  move=> S_P; have [sPG pP] := S_pG P S_P.
  by rewrite normal_max_pgroup_Hall ?nrmG //; apply: SmaxN; rewrite ?normG.
have{SmaxN} defCS P: P \in S -> 'Fix_(S |'JG)(P) = [set P].
  move=> S_P; apply/setP=> Q; rewrite {1}in_setI {1}afixJG.
  apply/andP/set1P=> [[S_Q nQP]|->{Q}]; last by rewrite normG.
  apply/esym/val_inj; case: (S_pG Q) => //= sQG _.
  by apply: uniq_normal_Hall (SmaxN Q _ _ _) => //=; rewrite ?sylS ?nrmG.
have{defCS} oG_mod: {in S &, forall P Q, #|oG P| = (Q \in oG P) %[mod p]}.
  move=> P Q S_P S_Q; have [sQG pQ] := S_pG _ S_Q.
  have soP_S: oG P \subset S by rewrite acts_sub_orbit.
  have /pgroup_fix_mod-> //: [acts Q, on oG P | 'JG].
    apply/actsP=> x /(subsetP sQG) Gx R; apply: orbit_transl.
    exact: mem_orbit.
  rewrite -{1}(setIidPl soP_S) -setIA defCS // (cardsD1 Q) setDE.
  by rewrite -setIA setICr setI0 cards0 addn0 inE set11 andbT.
have [P S_P]: exists P, P \in S.
  have: p.-subgroup(G) 1 by rewrite /psubgroup sub1G pgroup1.
  by case/(@maxgroup_exists _ (p.-subgroup(G))) => P; exists P; rewrite inE.
have trS: [transitive G, on S | 'JG].
  apply/imsetP; exists P => //; apply/eqP.
  rewrite eqEsubset andbC acts_sub_orbit // S_P; apply/subsetP=> Q S_Q.
  have /[1!inE] /maxgroupP[/andP[_ pP]] := S_P.
  have [-> max1 | ntP _] := eqVneq P 1%G.
    move/andP/max1: (S_pG _ S_Q) => Q1.
    by rewrite (group_inj (Q1 (sub1G Q))) orbit_refl.
  have:= oG_mod _ _ S_P S_P; rewrite (oG_mod _ Q) // orbit_refl.
  have p_gt1: p > 1 by apply: prime_gt1; case/pgroup_pdiv: pP.
  by case: (Q \in oG P) => //; rewrite mod0n modn_small.
have oS1: prime p -> #|S| %% p = 1%N.
  move/prime_gt1 => p_gt1.
  by rewrite -(atransP trS P S_P) (oG_mod P P) // orbit_refl modn_small.
have oSiN Q: Q \in S -> #|S| = #|G : 'N_G(Q)|.
  by move=> S_Q; rewrite -(atransP trS Q S_Q) card_orbit astab1JG.
have sylP: p.-Sylow(G) P.
  rewrite pHallE; case: (S_pG P) => // -> /= pP.
  case p_pr: (prime p); last first.
    rewrite p_part lognE p_pr /= -trivg_card1; apply/idPn=> ntP.
    by case/pgroup_pdiv: pP p_pr => // ->.
  rewrite -(LagrangeI G 'N(P)) /= mulnC partnM ?cardG_gt0 // part_p'nat.
    by rewrite mul1n (card_Hall (sylS P S_P)).
  by rewrite p'natE // -indexgI -oSiN // /dvdn oS1.
have eqS Q: maxp G Q = p.-Sylow(G) Q.
  apply/idP/idP=> [S_Q|]; last exact: Hall_max.
  have{} S_Q: Q \in S by rewrite inE.
  rewrite pHallE -(card_Hall sylP); case: (S_pG Q) => // -> _ /=.
  by case: (atransP2 trS S_P S_Q) => x _ ->; rewrite cardJg.
have ->: 'Syl_p(G) = S by apply/setP=> Q; rewrite 2!inE.
by split=> // Q sylQ; rewrite -oSiN ?inE ?eqS.
Qed.

Lemma max_pgroup_Sylow P : [max P | p.-subgroup(G) P] = p.-Sylow(G) P.
Proof. by case Sylow's_theorem. Qed.

Lemma Sylow_superset Q :
  Q \subset G -> p.-group Q -> {P : {group gT} | p.-Sylow(G) P & Q \subset P}.
Proof.
move=> sQG pQ.
have [|P] := @maxgroup_exists _ (p.-subgroup(G)) Q; first exact/andP.
by rewrite max_pgroup_Sylow; exists P.
Qed.

Lemma Sylow_exists : {P : {group gT} | p.-Sylow(G) P}.
Proof. by case: (Sylow_superset (sub1G G) (pgroup1 _ p)) => P; exists P. Qed.

Lemma Syl_trans : [transitive G, on 'Syl_p(G) | 'JG].
Proof. by case Sylow's_theorem. Qed.

Lemma Sylow_trans P Q :
  p.-Sylow(G) P -> p.-Sylow(G) Q -> exists2 x, x \in G & Q :=: P :^ x.
Proof.
move=> sylP sylQ; have /[!inE] := (atransP2 Syl_trans) P Q.
by case=> // x Gx ->; exists x.
Qed.

Lemma Sylow_subJ P Q :
    p.-Sylow(G) P -> Q \subset G -> p.-group Q ->
  exists2 x, x \in G & Q \subset P :^ x.
Proof.
move=> sylP sQG pQ; have [Px sylPx] := Sylow_superset sQG pQ.
by have [x Gx ->] := Sylow_trans sylP sylPx; exists x.
Qed.

Lemma Sylow_Jsub P Q :
    p.-Sylow(G) P -> Q \subset G -> p.-group Q ->
  exists2 x, x \in G & Q :^ x \subset P.
Proof.
move=> sylP sQG pQ; have [x Gx] := Sylow_subJ sylP sQG pQ.
by exists x^-1; rewrite (groupV, sub_conjgV).
Qed.

Lemma card_Syl P : p.-Sylow(G) P -> #|'Syl_p(G)| = #|G : 'N_G(P)|.
Proof. by case: Sylow's_theorem P. Qed.

Lemma card_Syl_dvd : #|'Syl_p(G)| %| #|G|.
Proof. by case Sylow_exists => P /card_Syl->; apply: dvdn_indexg. Qed.

Lemma card_Syl_mod : prime p -> #|'Syl_p(G)| %% p = 1%N.
Proof. by case Sylow's_theorem. Qed.

Lemma Frattini_arg H P : G <| H -> p.-Sylow(G) P -> G * 'N_H(P) = H.
Proof.
case/andP=> sGH nGH sylP; rewrite -normC ?subIset ?nGH ?orbT // -astab1JG.
move/subgroup_transitiveP: Syl_trans => ->; rewrite ?inE //.
apply/imsetP; exists P; rewrite ?inE //.
apply/eqP; rewrite eqEsubset -{1}((atransP Syl_trans) P) ?inE // imsetS //=.
by apply/subsetP=> _ /imsetP[x Hx ->]; rewrite inE -(normsP nGH x Hx) pHallJ2.
Qed.

End Sylow.

Section MoreSylow.

Variables (gT : finGroupType) (p : nat).
Implicit Types G H P : {group gT}.

Lemma Sylow_setI_normal G H P :
  G <| H -> p.-Sylow(H) P -> p.-Sylow(G) (G :&: P).
Proof.
case/normalP=> sGH nGH sylP; have [Q sylQ] := Sylow_exists p G.
have /maxgroupP[/andP[sQG pQ] maxQ] := Hall_max sylQ.
have [R sylR sQR] := Sylow_superset (subset_trans sQG sGH) pQ.
have [[x Hx ->] pR] := (Sylow_trans sylR sylP, pHall_pgroup sylR).
rewrite -(nGH x Hx) -conjIg pHallJ2.
have /maxQ-> //: Q \subset G :&: R by rewrite subsetI sQG.
by rewrite /psubgroup subsetIl (pgroupS _ pR) ?subsetIr.
Qed.

Lemma normal_sylowP G :
  reflect (exists2 P : {group gT}, p.-Sylow(G) P & P <| G)
          (#|'Syl_p(G)| == 1%N).
Proof.
apply: (iffP idP) => [syl1 | [P sylP nPG]]; last first.
  by rewrite (card_Syl sylP) (setIidPl _) (indexgg, normal_norm).
have [P sylP] := Sylow_exists p G; exists P => //.
rewrite /normal (pHall_sub sylP); apply/setIidPl; apply/eqP.
rewrite eqEcard subsetIl -(LagrangeI G 'N(P)) -indexgI /=.
by rewrite -(card_Syl sylP) (eqP syl1) muln1.
Qed.

Lemma trivg_center_pgroup P : p.-group P -> 'Z(P) = 1 -> P :=: 1.
Proof.
move=> pP Z1; apply/eqP/idPn=> ntP.
have{ntP} [p_pr p_dv_P _] := pgroup_pdiv pP ntP.
suff: p %| #|'Z(P)| by rewrite Z1 cards1 gtnNdvd ?prime_gt1.
by rewrite /center /dvdn -afixJ -pgroup_fix_mod // astabsJ normG.
Qed.

Lemma p2group_abelian P : p.-group P -> logn p #|P| <= 2 -> abelian P.
Proof.
move=> pP lePp2; pose Z := 'Z(P); have sZP: Z \subset P := center_sub P.
have [/(trivg_center_pgroup pP) ->|] := eqVneq Z 1; first exact: abelian1.
case/(pgroup_pdiv (pgroupS sZP pP)) => p_pr _ [k oZ].
apply: cyclic_center_factor_abelian.
have [->|] := eqVneq (P / Z) 1; first exact: cyclic1.
have pPq := quotient_pgroup 'Z(P) pP; case/(pgroup_pdiv pPq) => _ _ [j oPq].
rewrite prime_cyclic // oPq; case: j oPq lePp2 => //= j.
rewrite card_quotient ?gFnorm //.
by rewrite -(Lagrange sZP) lognM // => ->; rewrite oZ !pfactorK ?addnS.
Qed.

Lemma card_p2group_abelian P : prime p -> #|P| = (p ^ 2)%N -> abelian P.
Proof.
move=> primep oP; have pP: p.-group P by rewrite /pgroup oP pnatX pnat_id.
by rewrite (p2group_abelian pP) // oP pfactorK.
Qed.

Lemma Sylow_transversal_gen (T : {set {group gT}}) G :
    (forall P, P \in T -> P \subset G) ->
    (forall p, p \in \pi(G) -> exists2 P, P \in T & p.-Sylow(G) P) ->
  << \bigcup_(P in T) P >> = G.
Proof.
move=> G_T T_G; apply/eqP; rewrite eqEcard gen_subG.
apply/andP; split; first exact/bigcupsP.
apply: dvdn_leq (cardG_gt0 _) _; apply/dvdn_partP=> // q /T_G[P T_P sylP].
by rewrite -(card_Hall sylP); apply: cardSg; rewrite sub_gen // bigcup_sup.
Qed.

Lemma Sylow_gen G : <<\bigcup_(P : {group gT} | Sylow G P) P>> = G.
Proof.
set T := [set P : {group gT} | Sylow G P].
rewrite -{2}(@Sylow_transversal_gen T G) => [|P | q _].
- by congr <<_>>; apply: eq_bigl => P; rewrite inE.
- by rewrite inE => /and3P[].
by case: (Sylow_exists q G) => P sylP; exists P; rewrite // inE (p_Sylow sylP).
Qed.

End MoreSylow.

Section SomeHall.

Variable gT : finGroupType.
Implicit Types (p : nat) (pi : nat_pred) (G H K P R : {group gT}).

Lemma Hall_pJsub p pi G H P :
    pi.-Hall(G) H -> p \in pi -> P \subset G -> p.-group P ->
  exists2 x, x \in G & P :^ x \subset H.
Proof.
move=> hallH pi_p sPG pP.
have [S sylS] := Sylow_exists p H; have sylS_G := subHall_Sylow hallH pi_p sylS.
have [x Gx sPxS] := Sylow_Jsub sylS_G sPG pP; exists x => //.
exact: subset_trans sPxS (pHall_sub sylS).
Qed.

Lemma Hall_psubJ p pi G H P :
    pi.-Hall(G) H -> p \in pi -> P \subset G -> p.-group P ->
  exists2 x, x \in G & P \subset H :^ x.
Proof.
move=> hallH pi_p sPG pP; have [x Gx sPxH] := Hall_pJsub hallH pi_p sPG pP.
by exists x^-1; rewrite ?groupV -?sub_conjg.
Qed.

Lemma Hall_setI_normal pi G K H :
  K <| G -> pi.-Hall(G) H -> pi.-Hall(K) (H :&: K).
Proof.
move=> nsKG hallH; have [sHG piH _] := and3P hallH.
have [sHK_H sHK_K] := (subsetIl H K, subsetIr H K).
rewrite pHallE sHK_K /= -(part_pnat_id (pgroupS sHK_H piH)); apply/eqP.
rewrite (widen_partn _ (subset_leq_card sHK_K)); apply: eq_bigr => p pi_p.
have [P sylP] := Sylow_exists p H.
have sylPK := Sylow_setI_normal nsKG (subHall_Sylow hallH pi_p sylP).
rewrite -!p_part -(card_Hall sylPK); symmetry; apply: card_Hall.
by rewrite (pHall_subl _ sHK_K) //= setIC setSI ?(pHall_sub sylP).
Qed.

Lemma coprime_mulG_setI_norm H G K R :
    K * R = G -> G \subset 'N(H) -> coprime #|K| #|R| ->
  (K :&: H) * (R :&: H) = G :&: H.
Proof.
move=> defG nHG coKR; apply/eqP; rewrite eqEcard mulG_subG /= -defG.
rewrite !setSI ?mulG_subl ?mulG_subr //=.
rewrite coprime_cardMg ?(coKR, coprimeSg (subsetIl _ _), coprime_sym) //=.
pose pi := \pi(K); have piK: pi.-group K by apply: pgroup_pi.
have pi'R: pi^'.-group R by rewrite /pgroup -coprime_pi' /=.
have [hallK hallR] := coprime_mulpG_Hall defG piK pi'R.
have nsHG: H :&: G <| G by rewrite /normal subsetIr normsI ?normG.
rewrite -!(setIC H) defG -(partnC pi (cardG_gt0 _)).
rewrite -(card_Hall (Hall_setI_normal nsHG hallR)) /= setICA.
rewrite -(card_Hall (Hall_setI_normal nsHG hallK)) /= setICA.
by rewrite -defG (setIidPl (mulG_subl _ _)) (setIidPl (mulG_subr _ _)).
Qed.

End SomeHall.

Section Nilpotent.

Variable gT : finGroupType.
Implicit Types (G H K P L : {group gT}) (p q : nat).

Lemma pgroup_nil p P : p.-group P -> nilpotent P.
Proof.
move: {2}_.+1 (ltnSn #|P|) => n.
elim: n gT P => // n IHn pT P; rewrite ltnS=> lePn pP.
have [Z1 | ntZ] := eqVneq 'Z(P) 1.
  by rewrite (trivg_center_pgroup pP Z1) nilpotent1.
rewrite -quotient_center_nil IHn ?morphim_pgroup // (leq_trans _ lePn) //.
rewrite card_quotient ?normal_norm ?center_normal // -divgS ?subsetIl //.
by rewrite ltn_Pdiv // ltnNge -trivg_card_le1.
Qed.

Lemma pgroup_sol p P : p.-group P -> solvable P.
Proof. by move/pgroup_nil; apply: nilpotent_sol. Qed.

Lemma small_nil_class G : nil_class G <= 5 -> nilpotent G.
Proof.
move=> leK5; case: (ltnP 5 #|G|) => [lt5G | leG5 {leK5}].
  by rewrite nilpotent_class (leq_ltn_trans leK5).
apply: pgroup_nil (pdiv #|G|) _ _; apply/andP; split=> //.
by case: #|G| leG5 => //; do 5!case=> //.
Qed.

Lemma nil_class2 G : (nil_class G <= 2) = (G^`(1) \subset 'Z(G)).
Proof.
rewrite subsetI der_sub; apply/idP/commG1P=> [clG2 | L3G1].
  by apply/(lcn_nil_classP 2); rewrite ?small_nil_class ?(leq_trans clG2).
by apply/(lcn_nil_classP 2) => //; apply/lcnP; exists 2.
Qed.

Lemma nil_class3 G : (nil_class G <= 3) = ('L_3(G) \subset 'Z(G)).
Proof.
rewrite subsetI lcn_sub; apply/idP/commG1P=> [clG3 | L4G1].
  by apply/(lcn_nil_classP 3); rewrite ?small_nil_class ?(leq_trans clG3).
by apply/(lcn_nil_classP 3) => //; apply/lcnP; exists 3.
Qed.

Lemma nilpotent_maxp_normal pi G H :
  nilpotent G -> [max H | pi.-subgroup(G) H] -> H <| G.
Proof.
move=> nilG /maxgroupP[/andP[sHG piH] maxH].
have nHN: H <| 'N_G(H) by rewrite normal_subnorm.
have{maxH} hallH: pi.-Hall('N_G(H)) H.
  apply: normal_max_pgroup_Hall => //; apply/maxgroupP.
  rewrite /psubgroup normal_sub // piH; split=> // K.
  by rewrite subsetI -andbA andbCA => /andP[_ /maxH].
rewrite /normal sHG; apply/setIidPl/esym.
apply: nilpotent_sub_norm; rewrite ?subsetIl ?setIS //= char_norms //.
by congr (_ \char _): (pcore_char pi 'N_G(H)); apply: normal_Hall_pcore.
Qed.

Lemma nilpotent_Hall_pcore pi G H :
  nilpotent G -> pi.-Hall(G) H -> H :=: 'O_pi(G).
Proof.
move=> nilG hallH; have maxH := Hall_max hallH; apply/eqP.
rewrite eqEsubset pcore_max ?(pHall_pgroup hallH) //.
  by rewrite (normal_sub_max_pgroup maxH) ?pcore_pgroup ?pcore_normal.
exact: nilpotent_maxp_normal maxH.
Qed.

Lemma nilpotent_pcore_Hall pi G : nilpotent G -> pi.-Hall(G) 'O_pi(G).
Proof.
move=> nilG; case: (@maxgroup_exists _ (psubgroup pi G) 1) => [|H maxH _].
  by rewrite /psubgroup sub1G pgroup1.
have hallH := normal_max_pgroup_Hall maxH (nilpotent_maxp_normal nilG maxH).
by rewrite -(nilpotent_Hall_pcore nilG hallH).
Qed.

Lemma nilpotent_pcoreC pi G : nilpotent G -> 'O_pi(G) \x 'O_pi^'(G) = G.
Proof.
move=> nilG; have trO: 'O_pi(G) :&: 'O_pi^'(G) = 1.
  by apply: coprime_TIg; apply: (@pnat_coprime pi); apply: pcore_pgroup.
rewrite dprodE //.
  apply/eqP; rewrite eqEcard mul_subG ?pcore_sub // (TI_cardMg trO).
  by rewrite !(card_Hall (nilpotent_pcore_Hall _ _)) // partnC ?leqnn.
rewrite (sameP commG1P trivgP) -trO subsetI commg_subl commg_subr.
by rewrite !gFsub_trans ?gFnorm.
Qed.

Lemma sub_nilpotent_cent2 H K G :
    nilpotent G -> K \subset G -> H \subset G -> coprime #|K| #|H| ->
  H \subset 'C(K).
Proof.
move=> nilG sKG sHG; rewrite coprime_pi' // => p'H.
have sub_Gp := sub_Hall_pcore (nilpotent_pcore_Hall _ nilG).
have [_ _ cGpp' _] := dprodP (nilpotent_pcoreC \pi(K) nilG).
by apply: centSS cGpp'; rewrite sub_Gp ?pgroup_pi.
Qed.

Lemma pi_center_nilpotent G : nilpotent G -> \pi('Z(G)) = \pi(G).
Proof.
move=> nilG; apply/eq_piP => /= p.
apply/idP/idP=> [|pG]; first exact: (piSg (center_sub _)).
move: (pG); rewrite !mem_primes !cardG_gt0; case/andP=> p_pr _.
pose Z := 'O_p(G) :&: 'Z(G); have ntZ: Z != 1.
  rewrite meet_center_nil ?pcore_normal // trivg_card_le1 -ltnNge.
  rewrite (card_Hall (nilpotent_pcore_Hall p nilG)) p_part.
  by rewrite (ltn_exp2l 0 _ (prime_gt1 p_pr)) logn_gt0.
have pZ: p.-group Z := pgroupS (subsetIl _ _) (pcore_pgroup _ _).
have{ntZ pZ} [_ pZ _] := pgroup_pdiv pZ ntZ.
by rewrite p_pr (dvdn_trans pZ) // cardSg ?subsetIr.
Qed.

Lemma Sylow_subnorm p G P : p.-Sylow('N_G(P)) P = p.-Sylow(G) P.
Proof.
apply/idP/idP=> sylP; last first.
  apply: pHall_subl (subsetIl _ _) (sylP).
  by rewrite subsetI normG (pHall_sub sylP).
have [/subsetIP[sPG sPN] pP _] := and3P sylP.
have [Q sylQ sPQ] := Sylow_superset sPG pP; have [sQG pQ _] := and3P sylQ.
rewrite -(nilpotent_sub_norm (pgroup_nil pQ) sPQ) {sylQ}//.
rewrite subEproper eq_sym eqEcard subsetI sPQ sPN dvdn_leq //.
rewrite -(part_pnat_id (pgroupS (subsetIl _ _) pQ)) (card_Hall sylP).
by rewrite partn_dvd // cardSg ?setSI.
Qed.

End Nilpotent.

Lemma nil_class_pgroup (gT : finGroupType) (p : nat) (P : {group gT}) :
  p.-group P -> nil_class P <= maxn 1 (logn p #|P|).-1.
Proof.
move=> pP; move def_c: (nil_class P) => c.
elim: c => // c IHc in gT P def_c pP *; set e := logn p _.
have nilP := pgroup_nil pP; have sZP := center_sub P.
have [e_le2 | e_gt2] := leqP e 2.
  by rewrite -def_c leq_max nil_class1 (p2group_abelian pP).
have pPq: p.-group (P / 'Z(P)) by apply: quotient_pgroup.
rewrite -(subnKC e_gt2) ltnS (leq_trans (IHc _ _ _ pPq)) //.
  by rewrite nil_class_quotient_center ?def_c.
rewrite geq_max /= -add1n -leq_subLR -subn1 -subnDA -subSS leq_sub2r //.
rewrite ltn_log_quotient //= -(setIidPr sZP) meet_center_nil //.
by rewrite -nil_class0 def_c.
Qed.

Definition Zgroup (gT : finGroupType) (A : {set gT}) :=
  [forall (V : {group gT} | Sylow A V), cyclic V].

Section Zgroups.

Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}).
Implicit Types G H K : {group gT}.

Lemma ZgroupS G H : H \subset G -> Zgroup G -> Zgroup H.
Proof.
move=> sHG /forallP zgG; apply/forall_inP=> V /SylowP[p p_pr /and3P[sVH]].
case/(Sylow_superset (subset_trans sVH sHG))=> P sylP sVP _.
by have:= zgG P; rewrite (p_Sylow sylP); apply: cyclicS.
Qed.

Lemma morphim_Zgroup G : Zgroup G -> Zgroup (f @* G).
Proof.
move=> zgG; wlog sGD: G zgG / G \subset D.
  by rewrite -morphimIdom; apply; rewrite (ZgroupS _ zgG, subsetIl) ?subsetIr.
apply/forall_inP=> fV /SylowP[p pr_p sylfV].
have [P sylP] := Sylow_exists p G.
have [|z _ ->] := @Sylow_trans p _ _ (f @* P)%G _ _ sylfV.
  by apply: morphim_pHall (sylP); apply: subset_trans (pHall_sub sylP) sGD.
by rewrite cyclicJ morphim_cyclic ?(forall_inP zgG) //; apply/SylowP; exists p.
Qed.

Lemma nil_Zgroup_cyclic G : Zgroup G -> nilpotent G -> cyclic G.
Proof.
have [n] := ubnP #|G|; elim: n G => // n IHn G /ltnSE-leGn ZgG nilG.
have [->|[p pr_p pG]] := trivgVpdiv G; first by rewrite -cycle1 cycle_cyclic.
have /dprodP[_ defG Cpp' _] := nilpotent_pcoreC p nilG.
have /cyclicP[x def_p]: cyclic 'O_p(G).
  have:= forallP ZgG 'O_p(G)%G.
  by rewrite (p_Sylow (nilpotent_pcore_Hall p nilG)).
have /cyclicP[x' def_p']: cyclic 'O_p^'(G).
  have sp'G := pcore_sub p^' G.
  apply: IHn (leq_trans _ leGn) (ZgroupS sp'G _) (nilpotentS sp'G _) => //.
  rewrite proper_card // properEneq sp'G andbT; case: eqP => //= def_p'.
  by have:= pcore_pgroup p^' G; rewrite def_p' /pgroup p'natE ?pG.
apply/cyclicP; exists (x * x'); rewrite -{}defG def_p def_p' cycleM //.
  by red; rewrite -(centsP Cpp') // (def_p, def_p') cycle_id.
by rewrite /order -def_p -def_p' (@pnat_coprime p) //; apply: pcore_pgroup.
Qed.

End Zgroups.

Arguments Zgroup {gT} A%g.

Section NilPGroups.

Variables (p : nat) (gT : finGroupType).
Implicit Type G P N : {group gT}.

(* B & G 1.22 p.9 *)
Lemma normal_pgroup r P N :
    p.-group P -> N <| P -> r <= logn p #|N| ->
  exists Q : {group gT}, [/\ Q \subset N, Q <| P & #|Q| = (p ^ r)%N].
Proof.
elim: r gT P N => [|r IHr] gTr P N pP nNP le_r.
  by exists (1%G : {group gTr}); rewrite sub1G normal1 cards1.
have [NZ_1 | ntNZ] := eqVneq (N :&: 'Z(P)) 1.
  by rewrite (TI_center_nil (pgroup_nil pP)) // cards1 logn1 in le_r.
have: p.-group (N :&: 'Z(P)) by apply: pgroupS pP; rewrite /= setICA subsetIl.
case/pgroup_pdiv=> // p_pr /Cauchy[// | z].
rewrite -cycle_subG !subsetI => /and3P[szN szP cPz] ozp _.
have{cPz} nzP: P \subset 'N(<[z]>) by rewrite cents_norm // centsC.
have: N / <[z]> <| P / <[z]> by rewrite morphim_normal.
case/IHr=> [||Qb [sQNb nQPb]]; first exact: morphim_pgroup.
  rewrite card_quotient ?(subset_trans (normal_sub nNP)) // -ltnS.
  apply: (leq_trans le_r); rewrite -(Lagrange szN) [#|_|]ozp.
  by rewrite lognM // ?prime_gt0 // logn_prime ?eqxx.
case/(inv_quotientN _): nQPb sQNb => [|Q -> szQ nQP]; first exact/andP.
have nzQ := subset_trans (normal_sub nQP) nzP.
rewrite quotientSGK // card_quotient // => sQN izQ.
by exists Q; split=> //; rewrite expnS -izQ -ozp Lagrange.
Qed.

Theorem Baer_Suzuki x G :
    x \in G -> (forall y, y \in G -> p.-group <<[set x; x ^ y]>>) ->
  x \in 'O_p(G).
Proof.
have [n] := ubnP #|G|; elim: n G x => // n IHn G x /ltnSE-leGn Gx pE.
set E := x ^: G; have{} pE: {in E &, forall x1 x2, p.-group <<[set x1; x2]>>}.
  move=> _ _ /imsetP[y1 Gy1 ->] /imsetP[y2 Gy2 ->].
  rewrite -(mulgKV y1 y2) conjgM -2!conjg_set1 -conjUg genJ pgroupJ.
  by rewrite pE // groupMl ?groupV.
have sEG: <<E>> \subset G by rewrite gen_subG class_subG.
have nEG: G \subset 'N(E) by apply: class_norm.
have Ex: x \in E by apply: class_refl.
have [P Px sylP]: exists2 P : {group gT}, x \in P & p.-Sylow(<<E>>) P.
  have sxxE: <<[set x; x]>> \subset <<E>> by rewrite genS // setUid sub1set.
  have{sxxE} [P sylP sxxP] := Sylow_superset sxxE (pE _ _ Ex Ex).
  by exists P => //; rewrite (subsetP sxxP) ?mem_gen ?setU11.
case sEP: (E \subset P).
  apply: subsetP Ex; rewrite -gen_subG; apply: pcore_max.
    by apply: pgroupS (pHall_pgroup sylP); rewrite gen_subG.
  by rewrite /normal gen_subG class_subG // norms_gen.
pose P_yD D := [pred y in E :\: P | p.-group <<y |: D>>].
pose P_D := [pred D : {set gT} | D \subset P :&: E & [exists y, P_yD D y]].
have{Ex Px}: P_D [set x].
  rewrite /= sub1set inE Px Ex; apply/existsP=> /=.
  by case/subsetPn: sEP => y Ey Py; exists y; rewrite inE Ey Py pE.
case/(@maxset_exists _ P_D)=> D /maxsetP[]; rewrite {P_yD P_D}/=.
rewrite subsetI sub1set -andbA => /and3P[sDP sDE /existsP[y0]].
set B := _ |: D; rewrite inE -andbA => /and3P[Py0 Ey0 pB] maxD Dx.
have sDgE: D \subset <<E>> by apply: sub_gen.
have sDG: D \subset G by apply: subset_trans sEG.
have sBE: B \subset E by rewrite subUset sub1set Ey0.
have sBG: <<B>> \subset G by apply: subset_trans (genS _) sEG.
have sDB: D \subset B by rewrite subsetUr.
have defD: D :=: P :&: <<B>> :&: E.
  apply/eqP; rewrite eqEsubset ?subsetI sDP sDE sub_gen //=.
  apply/setUidPl; apply: maxD; last apply: subsetUl.
  rewrite subUset subsetI sDP sDE setIAC subsetIl.
  apply/existsP; exists y0; rewrite inE Py0 Ey0 /= setUA -/B.
  by rewrite -[<<_>>]joing_idl joingE setKI genGid.
have nDD: D \subset 'N(D).
  apply/subsetP=> z Dz; rewrite inE defD.
  apply/subsetP=> _ /imsetP[y /setIP[PBy Ey] ->].
  rewrite inE groupJ // ?inE ?(subsetP sDP) ?mem_gen ?setU1r //= memJ_norm //.
  exact: (subsetP (subset_trans sDG nEG)).
case nDG: (G \subset 'N(D)).
  apply: subsetP Dx; rewrite -gen_subG pcore_max ?(pgroupS (genS _) pB) //.
  by rewrite /normal gen_subG sDG norms_gen.
have{n leGn IHn nDG} pN: p.-group <<'N_E(D)>>.
  apply: pgroupS (pcore_pgroup p 'N_G(D)); rewrite gen_subG /=.
  apply/subsetP=> x1 /setIP[Ex1 Nx1]; apply: IHn => [||y Ny].
  - apply: leq_trans leGn; rewrite proper_card // /proper subsetIl.
    by rewrite subsetI nDG andbF.
  - by rewrite inE Nx1 (subsetP sEG) ?mem_gen.
  have Ex1y: x1 ^ y \in E.
    by rewrite -mem_conjgV (normsP nEG) // groupV; case/setIP: Ny.
  by apply: pgroupS (genS _) (pE _ _ Ex1 Ex1y); apply/subsetP => u /[!inE].
have [y1 Ny1 Py1]: exists2 y1, y1 \in 'N_E(D) & y1 \notin P.
  case sNN: ('N_<<B>>('N_<<B>>(D)) \subset 'N_<<B>>(D)).
    exists y0 => //; have By0: y0 \in <<B>> by rewrite mem_gen ?setU11.
    rewrite inE Ey0 -By0 -in_setI.
    by rewrite -['N__(D)](nilpotent_sub_norm (pgroup_nil pB)) ?subsetIl.
  case/subsetPn: sNN => z /setIP[Bz NNz]; rewrite inE Bz inE.
  case/subsetPn=> y; rewrite mem_conjg => Dzy Dy.
  have:= Dzy; rewrite {1}defD; do 2![case/setIP]=> _ Bzy Ezy.
  have Ey: y \in E by rewrite -(normsP nEG _ (subsetP sBG z Bz)) mem_conjg.
  have /setIP[By Ny]: y \in 'N_<<B>>(D).
    by rewrite -(normP NNz) mem_conjg inE Bzy ?(subsetP nDD).
  exists y; first by rewrite inE Ey.
  by rewrite defD 2!inE Ey By !andbT in Dy.
have [y2 Ny2 Dy2]: exists2 y2, y2 \in 'N_(P :&: E)(D) & y2 \notin D.
  case sNN: ('N_P('N_P(D)) \subset 'N_P(D)).
    have [z /= Ez sEzP] := Sylow_Jsub sylP (genS sBE) pB.
    have Gz: z \in G by apply: subsetP Ez.
    have /subsetPn[y Bzy Dy]: ~~ (B :^ z \subset D).
      apply/negP; move/subset_leq_card; rewrite cardJg cardsU1.
      by rewrite {1}defD 2!inE (negPf Py0) ltnn.
    exists y => //; apply: subsetP Bzy.
    rewrite -setIA setICA subsetI sub_conjg (normsP nEG) ?groupV // sBE.
    have nilP := pgroup_nil (pHall_pgroup sylP).
    by rewrite -['N__(_)](nilpotent_sub_norm nilP) ?subsetIl // -gen_subG genJ.
  case/subsetPn: sNN => z /setIP[Pz NNz]; rewrite 2!inE Pz.
  case/subsetPn=> y Dzy Dy; exists y => //; apply: subsetP Dzy.
  rewrite -setIA setICA subsetI sub_conjg (normsP nEG) ?groupV //.
    by rewrite sDE -(normP NNz); rewrite conjSg subsetI sDP.
  by apply: subsetP Pz; apply: (subset_trans (pHall_sub sylP)).
suff{Dy2} Dy2D: y2 |: D = D by rewrite -Dy2D setU11 in Dy2.
apply: maxD; last by rewrite subsetUr.
case/setIP: Ny2 => PEy2 Ny2; case/setIP: Ny1 => Ey1 Ny1.
rewrite subUset sub1set PEy2 subsetI sDP sDE.
apply/existsP; exists y1; rewrite inE Ey1 Py1; apply: pgroupS pN.
rewrite genS // !subUset !sub1set !in_setI Ey1 Ny1.
by case/setIP: PEy2 => _ ->; rewrite Ny2 subsetI sDE.
Qed.

End NilPGroups.


Require Import Sail.Base.
Open Scope Z.

Definition write_ram {rv e a} wk (addr : mword a) size (v : mword (8 * size)) (meta : unit) : monad rv bool e := write_mem wk a addr size v.

Definition read_ram {rv e a} rk (addr : mword a) size (read_tag : bool) `{ArithFact (size >=? 0)} : monad rv (mword (8 * size) * unit) e :=
  read_mem rk a addr size >>= fun data =>
  returnm (data, tt).