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

Require Import Bool.
Require Import Arith.
Require Import Classical_Prop.
From IntMap Require Import Allmaps.
Require Import bases.
Require Import defs.

Unset Standard Proposition Elimination Names.

(* fonction définissant la sémantique : reconnaissance d'un terme par un automate *)

Fixpoint rec_term (d : preDTA) (a : ad) (t : term)
 (n : nat) {struct n} : bool :=
  match n with
  | O => false
  | S k =>
      match t with
      | app c l =>
          match MapGet _ d a with
          | None => false
          | Some lts =>
              match MapGet _ lts c with
              | None => false
              | Some pre => rec_list_terms d pre l k
              end
          end
      end
  end

 with rec_list_terms (d : preDTA) (pre : prec_list)
 (l : term_list) (n : nat) {struct n} : bool :=
  match n with
  | O => false
  | S k =>
      match pre with
      | prec_empty => match l with
                      | tnil => true
                      | _ => false
                      end
      | prec_cons st stp pre' =>
          match l with
          | tnil => false
          | tcons hd tl =>
              rec_list_terms d pre' l k
              || rec_term d st hd k && rec_list_terms d stp tl k
          end
      end
  end.

(* bornes sur l'entier décroissant (terminaison de la fonction reconnaissance *)

Lemma borne_0_0 :
 forall p : prec_list,
 prec_in_state (M0 prec_list) p -> taille_0 p <= taille_1 (M0 prec_list).
Proof.
	intros. elim (prec_in_state_M0_false p). assumption.
Qed.

Lemma borne_0_1 :
 forall (a : ad) (p' p : prec_list),
 prec_in_state (M1 prec_list a p') p ->
 taille_0 p <= taille_1 (M1 prec_list a p').
Proof.
	intros. cut (p = p'). intros. simpl in |- *. rewrite H0.
	exact (le_n_n (taille_0 p')).
	unfold prec_in_state in H.
	exact (in_M1_id prec_list p a p' H).
Qed.

Lemma borne_0_2 :
 forall (m0 m1 : Map prec_list) (p : prec_list),
 (prec_in_state m0 p -> taille_0 p <= taille_1 m0) ->
 (prec_in_state m1 p -> taille_0 p <= taille_1 m1) ->
 prec_in_state (M2 prec_list m0 m1) p ->
 taille_0 p <= taille_1 (M2 prec_list m0 m1).
Proof.
	intros. cut (prec_in_state m0 p \/ prec_in_state m1 p).
	intro. elim H2; intros. simpl in |- *. cut (taille_0 p <= taille_1 m0).
	intro. cut (taille_1 m0 <= max (taille_1 m0) (taille_1 m1)).
	intro. exact
  (le_trans (taille_0 p) (taille_1 m0) (max (taille_1 m0) (taille_1 m1)) H4
     H5).
	exact (le_max_l (taille_1 m0) (taille_1 m1)).
	exact (H H3).
	simpl in |- *. cut (taille_0 p <= taille_1 m1).
	cut (taille_1 m1 <= max (taille_1 m0) (taille_1 m1)). intros.
	exact
  (le_trans (taille_0 p) (taille_1 m1) (max (taille_1 m0) (taille_1 m1)) H5
     H4).
	exact (le_max_r (taille_1 m0) (taille_1 m1)).
	exact (H0 H3).
	unfold prec_in_state in |- *. unfold prec_in_state in H1.
	exact (in_M2_disj prec_list p m0 m1 H1).
Qed.

Lemma borne_0 :
 forall (s : state) (p : prec_list),
 prec_in_state s p -> taille_0 p <= taille_1 s.
Proof.
	simple induction s. intros. exact (borne_0_0 p H).
	intros. exact (borne_0_1 a a0 p H).
	intros. exact (borne_0_2 m m0 p (H p) (H0 p) H1).
Qed.

Lemma borne_1_0 :
 forall s : state,
 state_in_dta (M0 state) s -> taille_1 s <= DTA_taille (M0 state).
Proof.
	intros. elim (state_in_dta_M0_false s). assumption.
Qed.

Lemma borne_1_1 :
 forall (a : ad) (s' s : state),
 state_in_dta (M1 state a s') s -> taille_1 s <= DTA_taille (M1 state a s').
Proof.
	intros. cut (s = s'). intros. simpl in |- *. rewrite H0.
	exact (le_n_n (taille_1 s')).
	unfold state_in_dta in H.
	exact (in_M1_id state s a s' H).
Qed.

Lemma borne_1_2 :
 forall (m0 m1 : Map state) (s : state),
 (state_in_dta m0 s -> taille_1 s <= DTA_taille m0) ->
 (state_in_dta m1 s -> taille_1 s <= DTA_taille m1) ->
 state_in_dta (M2 state m0 m1) s -> taille_1 s <= DTA_taille (M2 state m0 m1).
Proof.
	intros. cut (state_in_dta m0 s \/ state_in_dta m1 s).
	intro. elim H2; intros. simpl in |- *. cut (taille_1 s <= DTA_taille m0).
	intro. cut (DTA_taille m0 <= max (DTA_taille m0) (DTA_taille m1)).
	intro. exact
  (le_trans (taille_1 s) (DTA_taille m0)
     (max (DTA_taille m0) (DTA_taille m1)) H4 H5).
	exact (le_max_l (DTA_taille m0) (DTA_taille m1)).
	exact (H H3).
	simpl in |- *. cut (taille_1 s <= DTA_taille m1).
	cut (DTA_taille m1 <= max (DTA_taille m0) (DTA_taille m1)). intros.
	exact
  (le_trans (taille_1 s) (DTA_taille m1)
     (max (DTA_taille m0) (DTA_taille m1)) H5 H4).
	exact (le_max_r (DTA_taille m0) (DTA_taille m1)).
	exact (H0 H3).
	unfold state_in_dta in |- *. unfold state_in_dta in H1.
	exact (in_M2_disj state s m0 m1 H1).
Qed.

Lemma borne_1 :
 forall (d : preDTA) (s : state),
 state_in_dta d s -> taille_1 s <= DTA_taille d.
Proof.
	simple induction d. intros. exact (borne_1_0 s H).
	intros. exact (borne_1_1 a a0 s H).
	intros. exact (borne_1_2 m m0 s (H s) (H0 s) H1).
Qed.

Lemma borne_2 :
 forall (d : preDTA) (p : prec_list),
 prec_in_dta d p -> taille_0 p <= DTA_taille d.
Proof.
	intros. unfold prec_in_dta in H. elim H. intros. elim H0.
	intros. elim H1. intros. elim H2. intros.
	cut (taille_0 p <= taille_1 x).
	cut (taille_1 x <= DTA_taille d). intros.
	exact (le_trans (taille_0 p) (taille_1 x) (DTA_taille d) H6 H5).
	apply (borne_1 d x). unfold state_in_dta in |- *. split with x0.
	assumption.
	apply (borne_0 x p). unfold prec_in_state in |- *. split with x1.
	assumption.
Qed.

(* définition de la quantité d'essence (Astuce de Boyer, définition de *)
(* la reconnaissance par fixpoint...) *)

Definition essence (t : term) (d : preDTA) : nat :=
  S (term_high t) * S (DTA_taille d).

(* "hauteur" d'une liste : term_high_0 *)

Definition essence_list (l : term_list) (d : preDTA)
  (pl : prec_list) : nat :=
  match l, pl with
  | tnil, _ => 1
  | _, prec_empty => 1
  | _, prec_cons a la ls =>
      taille_0 pl + S (term_high_0 l) * S (DTA_taille d)
  end.

(* lemmes concernant la gestion de la diminution de la quantité d'essence *)

Lemma conservation_0_0 : forall n n0 : nat, S n * S n0 = S (n0 + n * S n0).
Proof.
	simple induction n. simpl in |- *. trivial.
	intros. simpl in |- *. trivial.
Qed.

Lemma conservation_0 :
 forall (d : preDTA) (p : prec_list) (c : ad) (l : term_list),
 prec_in_dta d p -> S (essence_list l d p) <= essence (app c l) d.
Proof.
	intro. intro. intro. simple induction l. intros. unfold essence_list in |- *. unfold essence in |- *.
	case p. intros. cut (2 <= S (term_high (app c tnil))).
	cut (1 <= S (DTA_taille d)). intros.
	exact
  (le_mult_mult 2 (S (term_high (app c tnil))) 1 (S (DTA_taille d)) H1 H0).
	exact (le_n_S 0 (DTA_taille d) (le_O_n (DTA_taille d))).
	cut (1 <= term_high (app c tnil)). intro.
	exact (le_n_S 1 (term_high (app c tnil)) H0).
	simpl in |- *. exact (le_n_n 1).
	intros. cut (2 <= S (term_high (app c tnil))). cut (1 <= S (DTA_taille d)).
	intros. exact
  (le_mult_mult 2 (S (term_high (app c tnil))) 1 (S (DTA_taille d)) H1 H0).
	exact (le_n_S 0 (DTA_taille d) (le_O_n (DTA_taille d))).
	cut (1 <= term_high (app c tnil)). intro. exact (le_n_S 1 (term_high (app c tnil)) H0).
	simpl in |- *. exact (le_n_n 1).
	case p. intros. unfold essence in |- *. unfold essence_list in |- *.
	cut
  (S (term_high (app c (tcons t t0))) * S (DTA_taille d) =
   S (DTA_taille d + term_high (app c (tcons t t0)) * S (DTA_taille d))).
	intro. rewrite H1.
	cut
  (taille_0 (prec_cons a p0 p1) +
   S (term_high_0 (tcons t t0)) * S (DTA_taille d) <=
   DTA_taille d + term_high (app c (tcons t t0)) * S (DTA_taille d)).
	intro. exact (le_n_S _ _ H2).
	cut (taille_0 (prec_cons a p0 p1) <= DTA_taille d).
	cut
  (S (term_high_0 (tcons t t0)) * S (DTA_taille d) <=
   term_high (app c (tcons t t0)) * S (DTA_taille d)).
	intros. exact (plus_le_compat _ _ _ _ H3 H2).
	cut (S (term_high_0 (tcons t t0)) <= term_high (app c (tcons t t0))).
	intro. exact (le_mult_l _ _ _ H2).
	cut (S (term_high_0 (tcons t t0)) = term_high (app c (tcons t t0))). intro.
	exact (high_aux_0 c (tcons t t0)).
	exact (high_aux_1 c (tcons t t0)).
	exact (borne_2 d (prec_cons a p0 p1) H0).
	exact (conservation_0_0 (term_high (app c (tcons t t0))) (DTA_taille d)).
	intros. unfold essence_list in |- *. unfold essence in |- *.
	cut (2 <= S (term_high (app c (tcons t t0)))).
	cut (1 <= S (DTA_taille d)). intros.
	exact
  (le_mult_mult 2 (S (term_high (app c (tcons t t0)))) 1
     (S (DTA_taille d)) H2 H1).
	exact (le_n_S 0 (DTA_taille d) (le_O_n (DTA_taille d))).
	apply (le_n_S 1 (term_high (app c (tcons t t0)))).
	cut (1 <= S (term_high_0 (tcons t t0))).
	cut (S (term_high_0 (tcons t t0)) <= term_high (app c (tcons t t0))).
	intros. exact
  (le_trans 1 (S (term_high_0 (tcons t t0))) (term_high (app c (tcons t t0)))
     H2 H1).
	exact (high_aux_0 c (tcons t t0)). apply (le_n_S 0 (term_high_0 (tcons t t0))).
	exact (le_O_n _).
Qed.

Lemma conservation_1 :
 forall (d : preDTA) (l : term_list), 1 <= essence_list l d prec_empty.
Proof.
	intros. induction  l as [| t l Hrecl]. simpl in |- *. exact (le_n_n 1).
	simpl in |- *. exact (le_n_n 1).
Qed.

Lemma conservation_2 :
 forall (d : preDTA) (p : prec_list), 1 <= essence_list tnil d p.
Proof.
	intros. simpl in |- *. induction  p as [a p1 Hrecp1 p0 Hrecp0| ]; exact (le_n_n 1).
Qed.

Lemma conservation_3 :
 forall (d : preDTA) (hd : term) (tl : term_list) (a : ad)
   (la ls : prec_list),
 S (essence_list (tcons hd tl) d ls) <=
 essence_list (tcons hd tl) d (prec_cons a la ls).
Proof.
	unfold essence_list in |- *. intros. induction  ls as [a0 ls1 Hrecls1 ls0 Hrecls0| ].
	cut
  (S
     (taille_0 (prec_cons a0 ls1 ls0) +
      S (term_high_0 (tcons hd tl)) * S (DTA_taille d)) =
   S (taille_0 (prec_cons a0 ls1 ls0)) +
   S (term_high_0 (tcons hd tl)) * S (DTA_taille d)).
	intro. rewrite H.
	cut
  (S (taille_0 (prec_cons a0 ls1 ls0)) <=
   taille_0 (prec_cons a la (prec_cons a0 ls1 ls0))).
	intro.
	exact
  (plus_le_compat (S (taille_0 (prec_cons a0 ls1 ls0)))
     (taille_0 (prec_cons a la (prec_cons a0 ls1 ls0)))
     (S (term_high_0 (tcons hd tl)) * S (DTA_taille d))
     (S (term_high_0 (tcons hd tl)) * S (DTA_taille d)) H0
     (le_n_n (S (term_high_0 (tcons hd tl)) * S (DTA_taille d)))).
	exact (taille_aux_2 a la (prec_cons a0 ls1 ls0)).
	generalize (taille_0 (prec_cons a0 ls1 ls0)).
	generalize (S (term_high_0 (tcons hd tl)) * S (DTA_taille d)).
	simpl in |- *. trivial.
	cut (1 <= taille_0 (prec_cons a la prec_empty)).
	cut (1 <= S (term_high_0 (tcons hd tl)) * S (DTA_taille d)).
	intros. exact
  (plus_le_compat 1 (taille_0 (prec_cons a la prec_empty)) 1
     (S (term_high_0 (tcons hd tl)) * S (DTA_taille d)) H0 H).
	exact
  (le_mult_mult 1 (S (term_high_0 (tcons hd tl))) 1
     (S (DTA_taille d))
     (le_n_S 0 (term_high_0 (tcons hd tl))
        (le_O_n (term_high_0 (tcons hd tl))))
     (le_n_S 0 (DTA_taille d) (le_O_n (DTA_taille d)))).
	exact (taille_aux_1 a la prec_empty).
Qed.

Lemma conservation_4 :
 forall (d : preDTA) (hd : term) (tl : term_list) (a : ad)
   (la ls : prec_list),
 S (essence_list tl d la) <= essence_list (tcons hd tl) d (prec_cons a la ls).
Proof.
	unfold essence_list in |- *. intro. intro. intro. intros.
	cut (1 <= taille_0 (prec_cons a la ls)).
	cut (1 <= S (term_high_0 (tcons hd tl)) * S (DTA_taille d)).
	intros. induction  tl as [| t tl Hrectl].
	cut
  (2 <=
   taille_0 (prec_cons a la ls) +
   S (term_high_0 (tcons hd tnil)) * S (DTA_taille d)).
	intros. induction  la as [a0 la1 Hrecla1 la0 Hrecla0| ]. assumption.
	assumption.
	exact
  (plus_le_compat 1 (taille_0 (prec_cons a la ls)) 1
     (S (term_high_0 (tcons hd tnil)) * S (DTA_taille d)) H0 H).
	induction  la as [a0 la1 Hrecla1 la0 Hrecla0| ].
	cut
  (S
     (taille_0 (prec_cons a0 la1 la0) +
      S (term_high_0 (tcons t tl)) * S (DTA_taille d)) =
   S (taille_0 (prec_cons a0 la1 la0)) +
   S (term_high_0 (tcons t tl)) * S (DTA_taille d)).
	intro. rewrite H1. cut
  (S (taille_0 (prec_cons a0 la1 la0)) <=
   taille_0 (prec_cons a (prec_cons a0 la1 la0) ls)).
	intro.
	apply
  (plus_le_compat (S (taille_0 (prec_cons a0 la1 la0)))
     (taille_0 (prec_cons a (prec_cons a0 la1 la0) ls))
     (S (term_high_0 (tcons t tl)) * S (DTA_taille d))
     (S (term_high_0 (tcons hd (tcons t tl))) * S (DTA_taille d)) H2).
	cut
  (S (term_high_0 (tcons t tl)) <= S (term_high_0 (tcons hd (tcons t tl)))).
	intro.
	exact
  (le_mult_mult (S (term_high_0 (tcons t tl)))
     (S (term_high_0 (tcons hd (tcons t tl)))) (S (DTA_taille d))
     (S (DTA_taille d)) H3 (le_n_n (S (DTA_taille d)))).
	exact
  (le_n_S (term_high_0 (tcons t tl)) (term_high_0 (tcons hd (tcons t tl)))
     (high_aux_4 hd (tcons t tl))).
	exact (taille_aux_0 a (prec_cons a0 la1 la0) ls).
	generalize (taille_0 (prec_cons a0 la1 la0)).
	generalize (S (term_high_0 (tcons t tl)) * S (DTA_taille d)).
	simpl in |- *. trivial.
	exact
  (plus_le_compat 1 (taille_0 (prec_cons a prec_empty ls)) 1
     (S (term_high_0 (tcons hd (tcons t tl))) * S (DTA_taille d)) H0 H).
	exact
  (le_mult_mult 1 (S (term_high_0 (tcons hd tl))) 1
     (S (DTA_taille d))
     (le_n_S 0 (term_high_0 (tcons hd tl))
        (le_O_n (term_high_0 (tcons hd tl))))
     (le_n_S 0 (DTA_taille d) (le_O_n (DTA_taille d)))).
	exact (taille_aux_1 a la ls).
Qed.

Lemma conservation_5_0 :
 forall (a : ad) (la ls : prec_list), 1 <= taille_0 (prec_cons a la ls).
Proof.
	intros. simpl in |- *. apply (le_n_S 0 (taille_0 la + taille_0 ls)).
	exact (le_O_n (taille_0 la + taille_0 ls)).
Qed.

Lemma conservation_5 :
 forall (d : preDTA) (hd : term) (tl : term_list) (a : ad)
   (la ls : prec_list),
 S (essence hd d) <= essence_list (tcons hd tl) d (prec_cons a la ls).
Proof.
	intros. unfold essence in |- *. unfold essence_list in |- *.
	cut (term_high hd <= term_high_0 (tcons hd tl)).
	cut (1 <= taille_0 (prec_cons a la ls)).
	intros.
	cut
  (S (S (term_high hd) * S (DTA_taille d)) =
   1 + S (term_high hd) * S (DTA_taille d)).
	intros. rewrite H1.
	apply
  (plus_le_compat 1 (taille_0 (prec_cons a la ls))
     (S (term_high hd) * S (DTA_taille d))
     (S (term_high_0 (tcons hd tl)) * S (DTA_taille d)) H).
	apply
  (le_mult_mult (S (term_high hd)) (S (term_high_0 (tcons hd tl)))
     (S (DTA_taille d)) (S (DTA_taille d))
     (le_n_S (term_high hd) (term_high_0 (tcons hd tl)) H0)).
	exact (le_n_n (S (DTA_taille d))).
	unfold plus in |- *. trivial.
	exact (conservation_5_0 a la ls).
	exact (high_aux_3 hd tl).
Qed.

Definition dta_rec_term (d : DTA) (t : term) : bool :=
  match d with
  | dta p a => rec_term p a t (essence t p)
  end.

(* définitions inductives pour la reconnaissance d'un terme par un automate *)

Inductive reconnaissance : preDTA -> ad -> term -> Prop :=
    rec_dta :
      forall (d : preDTA) (a : ad) (t : term) (ladj : state),
      MapGet state d a = Some ladj ->
      state_reconnait d ladj t -> reconnaissance d a t
with state_reconnait : preDTA -> state -> term -> Prop :=
    rec_st :
      forall (d : preDTA) (s : state) (c : ad) (tl : term_list)
        (l : prec_list),
      MapGet prec_list s c = Some l ->
      liste_reconnait d l tl -> state_reconnait d s (app c tl)
with liste_reconnait : preDTA -> prec_list -> term_list -> Prop :=
  | rec_empty : forall d : preDTA, liste_reconnait d prec_empty tnil
  | rec_consi :
      forall (d : preDTA) (a : ad) (la ls : prec_list)
        (hd : term) (tl : term_list),
      reconnaissance d a hd ->
      liste_reconnait d la tl ->
      liste_reconnait d (prec_cons a la ls) (tcons hd tl)
  | rec_consn :
      forall (d : preDTA) (a : ad) (la ls : prec_list)
        (hd : term) (tl : term_list),
      liste_reconnait d ls (tcons hd tl) ->
      liste_reconnait d (prec_cons a la ls) (tcons hd tl).

Definition reconnait (d : DTA) (t : term) : Prop :=
  match d with
  | dta p a => reconnaissance p a t
  end.

(* principe d'induction commun *)

Scheme mreconnaissance_ind := Induction for reconnaissance
  Sort Prop
  with mstrec_ind := Induction for state_reconnait
  Sort Prop
  with mlrec_ind := Induction for liste_reconnait Sort Prop.

(* lemmes de base sur la sémantique précédente (pour simplifier d'autres démos) *)

Lemma sem_listes_0 :
 forall (d : preDTA) (p : prec_list) (hd : term) (tl : term_list),
 liste_reconnait d p (tcons hd tl) -> p <> prec_empty.
Proof.
	intros. intro. inversion H. rewrite H0 in H4. discriminate H4.
	rewrite H0 in H3. inversion H3.
Qed.

Lemma sem_listes_1 :
 forall (d : preDTA) (hd : term) (tl : term_list),
 ~ liste_reconnait d prec_empty (tcons hd tl).
Proof.
	intros. intro. cut (prec_empty = prec_empty). intro.
	exact (sem_listes_0 d prec_empty hd tl H H0). trivial.
Qed.

Lemma sem_listes_2 :
 forall (d : preDTA) (pl : prec_list),
 liste_reconnait d pl tnil -> pl = prec_empty.
Proof.
	intros. inversion H. trivial.
Qed.

(* lemmes d'équivalence sémantique entre la fonction calculatoire (Fixpoint) *)
(* et la définition par Inductive *)

Definition sem_equiv_prop_t (t : term) :=
  forall (d : preDTA) (a : ad) (n : nat),
  rec_term d a t n = true -> reconnaissance d a t.
Definition sem_equiv_prop_l (l : term_list) :=
  forall (d : preDTA) (p : prec_list) (n : nat),
  rec_list_terms d p l n = true -> liste_reconnait d p l.

Lemma semantic_equiv_0_0 :
 forall (d : preDTA) (p : prec_list) (n : nat),
 rec_list_terms d p tnil n = true -> p = prec_empty.
Proof.
	intros. induction  p as [a p1 Hrecp1 p0 Hrecp0| ]. induction  n as [| n Hrecn]. simpl in H. discriminate H.
	simpl in H. discriminate H.
	trivial.
Qed.

Lemma semantic_equiv_0_1 : sem_equiv_prop_l tnil.
Proof.
	unfold sem_equiv_prop_l in |- *. intros. cut (p = prec_empty). intros. rewrite H0.
	exact (rec_empty d).
	exact (semantic_equiv_0_0 d p n H).
Qed.

Lemma semantic_equiv_0_2 :
 forall (d : preDTA) (a a' : ad) (l : term_list) (n : nat)
   (s : state) (p : prec_list),
 rec_term d a (app a' l) (S n) = true ->
 MapGet state d a = Some s ->
 MapGet prec_list s a' = Some p -> rec_list_terms d p l n = true.
Proof.
	intro. intro. intro. intro. simple induction n. intros. simpl in H.
	rewrite H0 in H. rewrite H1 in H. discriminate H.
	intros. elim (classic (rec_list_terms d p l (S n0) = true)).
	intro. assumption.
	intro. cut (rec_list_terms d p l (S n0) = false). intro. simpl in H0.
	rewrite H1 in H0. rewrite H2 in H0. simpl in H0. simpl in H4.
	simpl in H4. (* Unfold rec_list_terms in H4. *) rewrite H4 in H0.
	discriminate H0.
	exact (not_true_is_false (rec_list_terms d p l (S n0)) H3).
Qed.

Lemma semantic_equiv_0_3 :
 forall (d : preDTA) (a a' : ad) (l : term_list) (n : nat),
 rec_term d a (app a' l) (S n) = true ->
 exists s : state, MapGet state d a = Some s.
Proof.
	intro. intro. intro. intro. simpl in |- *. intro.
	elim (MapGet state d a). Focus 2. intro H. discriminate H.
	intro. split with a0. trivial.
Qed.

Lemma semantic_equiv_0_4 :
 forall (d : preDTA) (a a' : ad) (l : term_list) (n : nat) (s : state),
 MapGet state d a = Some s ->
 rec_term d a (app a' l) (S n) = true ->
 exists p : prec_list, MapGet prec_list s a' = Some p.
Proof.
	intro. intro. intro. intro. intro. intro. intro. simpl in |- *.
	rewrite H. simpl in |- *. elim (MapGet prec_list s a'). Focus 2.
	intro H0. discriminate H0.
	intro. intro. split with a0. trivial.
Qed.

Lemma semantic_equiv_0_5 :
 forall (a : ad) (t : term_list),
 sem_equiv_prop_l t -> sem_equiv_prop_t (app a t).
Proof.
	unfold sem_equiv_prop_l in |- *. unfold sem_equiv_prop_t in |- *. intros.
	cut (exists s : state, MapGet state d a0 = Some s).
	intro. elim H1. intros.
	cut (exists p : prec_list, MapGet prec_list x a = Some p).
	intros. elim H3. intros. induction  n as [| n Hrecn]. simpl in H0. discriminate H0.
	exact
  (rec_dta d a0 (app a t) x H2
     (rec_st d x a t x0 H4
        (H d x0 n (semantic_equiv_0_2 d a0 a t n x x0 H0 H2 H4)))).
	induction  n as [| n Hrecn]. simpl in H0. discriminate.
	exact (semantic_equiv_0_4 d a0 a t n x H2 H0).
	induction  n as [| n Hrecn]. simpl in H0. discriminate H0.
	exact (semantic_equiv_0_3 d a0 a t n H0).
Qed.

Lemma semantic_equiv_0_6 :
 forall (n : nat) (t : term) (t0 : term_list),
 (forall (d : preDTA) (a : ad) (m : nat),
  rec_term d a t m = true -> reconnaissance d a t) ->
 (forall (d : preDTA) (p : prec_list) (m : nat),
  rec_list_terms d p t0 m = true -> liste_reconnait d p t0) ->
 forall (d : preDTA) (p : prec_list),
 rec_list_terms d p (tcons t t0) n = true -> liste_reconnait d p (tcons t t0).
Proof.
	simple induction n. intros. simpl in H1. inversion H1. intros.
	simpl in H2. elim (pl_sum p); intros. rewrite H3 in H2.
	inversion H2. elim H3. intros. elim H4. intros. elim H5.
	intros. rewrite H6 in H2. elim (bool_is_true_or_false (rec_list_terms d x1 (tcons t t0) n0)); intros;
  rewrite H7 in H2. rewrite H6. exact (rec_consn d x x0 x1 t t0 (H t t0 H0 H1 d x1 H7)). simpl in H2. fold rec_term in H2. elim (bool_is_true_or_false (rec_term d x t n0)); intros; rewrite H8 in H2. elim (bool_is_true_or_false (rec_list_terms d x0 t0 n0)). intros. rewrite H6. exact (rec_consi d x x0 x1 t t0 (H0 _ _ _ H8) (H1 _ _ _ H9)). intros. rewrite H9 in H2.
	inversion H2. inversion H2.
Qed.

Lemma semantic_equiv_0_7 :
 forall t : term,
 sem_equiv_prop_t t ->
 forall t0 : term_list, sem_equiv_prop_l t0 -> sem_equiv_prop_l (tcons t t0).
Proof.
	unfold sem_equiv_prop_t, sem_equiv_prop_l in |- *. intros.
	exact (semantic_equiv_0_6 n t t0 H H0 d p H1).
Qed.

Lemma semantic_equiv_0 :
 forall (d : preDTA) (a : ad) (t : term) (n : nat),
 rec_term d a t n = true -> reconnaissance d a t.
Proof.
	cut (forall t : term, sem_equiv_prop_t t). intros.
	unfold sem_equiv_prop_t in H; intros.
	exact (H t d a n H0).
	exact
  (term_term_list_ind sem_equiv_prop_t sem_equiv_prop_l semantic_equiv_0_5
     semantic_equiv_0_1 semantic_equiv_0_7).
Qed.

(* conservation de la reconnaissance d'un terme si on met plus d'essence ... *)

Definition invar_term (t : term) : Prop :=
  forall (n m : nat) (d : preDTA) (a : ad),
  rec_term d a t n = true -> n <= m -> rec_term d a t m = true.

Definition invar_list (tl : term_list) : Prop :=
  forall (n m : nat) (d : preDTA) (p : prec_list),
  rec_list_terms d p tl n = true -> n <= m -> rec_list_terms d p tl m = true.

Lemma invar_0 : invar_list tnil.
Proof.
	unfold invar_list in |- *. simple induction n. intro. intro. simple induction p.
	intros. simpl in H1. discriminate H1.
	intros. simpl in H. discriminate H.
	intro. intro. simple induction m. intros. elim (le_Sn_O n0 H1).
	intro. intro. simple induction p. intros. simpl in |- *. simpl in H3. assumption.
	simpl in |- *. intros. assumption.
Qed.

Lemma invar_1_0 :
 forall (d : preDTA) (a c : ad) (t : term_list) (n : nat)
   (s : state) (p : prec_list),
 MapGet state d a = Some s ->
 MapGet prec_list s c = Some p ->
 rec_list_terms d p t n = true -> rec_term d a (app c t) (S n) = true.
Proof.
	intro; intro; intro; simple induction n. intros. simpl in H1. discriminate H1.
	intros. simpl in |- *. rewrite H0. rewrite H1. simpl in H2. assumption.
Qed.

Lemma invar_1_1 :
 forall (d : preDTA) (a c : ad) (t : term_list) (n : nat),
 rec_term d a (app c t) (S n) = true ->
 exists p : prec_list, rec_list_terms d p t n = true.
Proof.
	intros. cut (exists s : state, MapGet state d a = Some s).
	intro. elim H0. intros.
	cut (exists p : prec_list, MapGet prec_list x c = Some p).
	intro. elim H2. intros. split with x0.
	exact (semantic_equiv_0_2 d a c t n x x0 H H1 H3).
	exact (semantic_equiv_0_4 d a c t n x H1 H).
	exact (semantic_equiv_0_3 d a c t n H).
Qed.

Lemma invar_1 :
 forall (a : ad) (t : term_list), invar_list t -> invar_term (app a t).
Proof.
	intro. intro. intro. unfold invar_list in H. unfold invar_term in |- *.
	simple induction n. intros. simpl in H0. discriminate H0.
	intro. intro. simple induction m; intros. elim (le_Sn_O n0 H2).
	cut (exists s : state, MapGet state d a0 = Some s).
	intro. elim H4. intros.
	cut (exists p : prec_list, MapGet prec_list x a = Some p).
	intro. elim H6. intros. apply (invar_1_0 d a0 a t n1 x x0 H5 H7).
	cut (rec_list_terms d x0 t n0 = true). intro.
	exact (H n0 n1 d x0 H8 (le_S_n n0 n1 H3)).
	exact (semantic_equiv_0_2 d a0 a t n0 x x0 H2 H5 H7).
	exact (semantic_equiv_0_4 d a0 a t n0 x H5 H2).
	exact (semantic_equiv_0_3 d a0 a t n0 H2).
Qed.

Lemma invar_2_0 :
 forall (d : preDTA) (p : prec_list) (n : nat),
 rec_list_terms d p tnil n = true -> p = prec_empty.
Proof.
	intro. simple induction p; simple induction n. intro. simpl in H1. discriminate H1.
	intros. simpl in H2. discriminate H2.
	intro. simpl in H. trivial.
	intros. trivial.
Qed.

Lemma invar_2_1 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list) (n : nat),
 rec_list_terms d (prec_cons a la ls) (tcons hd tl) (S n) = true ->
 rec_list_terms d ls (tcons hd tl) n = true \/
 rec_term d a hd n = true /\ rec_list_terms d la tl n = true.
Proof.
	intro. intro. intro. intro. intro. intro. intro. induction  n as [| n Hrecn]. intro. simpl in H.
	discriminate H.
	intros.
	cut
  (rec_list_terms d ls (tcons hd tl) (S n) = true \/
   rec_list_terms d ls (tcons hd tl) (S n) = false).
	cut (rec_term d a hd (S n) = true \/ rec_term d a hd (S n) = false).
	cut
  (rec_list_terms d la tl (S n) = true \/
   rec_list_terms d la tl (S n) = false).
	intros. elim H2. left. assumption.
	elim H1. elim H0. intros. right. split; assumption. simpl in H. intros.
	simpl in H. simpl in H3. simpl in H4. simpl in H5. rewrite H3 in H.
	rewrite H4 in H. rewrite H5 in H. simpl in H. discriminate H.
	intros. simpl in H. simpl in H2. simpl in H3. simpl in H4. rewrite H3 in H.
	rewrite H4 in H. simpl in H. discriminate H.
	exact (bool_is_true_or_false (rec_list_terms d la tl (S n))).
	exact (bool_is_true_or_false (rec_term d a hd (S n))).
	exact (bool_is_true_or_false (rec_list_terms d ls (tcons hd tl) (S n))).
Qed.

Lemma invar_2_2 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list) (n : nat),
 rec_list_terms d ls (tcons hd tl) n = true \/
 rec_term d a hd n = true /\ rec_list_terms d la tl n = true ->
 rec_list_terms d (prec_cons a la ls) (tcons hd tl) (S n) = true.
Proof.
	intros. elim H. intro. simpl in |- *. simpl in H0. rewrite H0. simpl in |- *. trivial.
	intro. elim H0. intro. intro. simpl in |- *. simpl in H1. (*Unfold rec_term in H1.*)
	rewrite H1. rewrite H2. simpl in |- *.
	exact (orb_b_true (rec_list_terms d ls (tcons hd tl) n)).
Qed.

Lemma invar_2 :
 forall t : term,
 invar_term t ->
 forall t0 : term_list, invar_list t0 -> invar_list (tcons t t0).
Proof.
	intros. unfold invar_list in H0. unfold invar_list in |- *.
	simple induction n; simple induction m; intro. intros. simpl in H1. discriminate H1.
	intros. simpl in H2. discriminate H2.
	intros. elim (le_Sn_O n0 H3).
	simple induction p. intros.
	cut
  (rec_list_terms d p1 (tcons t t0) n1 = true \/
   rec_term d a t n1 = true /\ rec_list_terms d p0 t0 n1 = true).
	intro. elim H7. intros. exact (invar_2_2 d a p0 p1 t t0 n1 H7).
	intros. exact (invar_2_2 d a p0 p1 t t0 n1 H7).
	cut
  (rec_list_terms d p1 (tcons t t0) n0 = true \/
   rec_term d a t n0 = true /\ rec_list_terms d p0 t0 n0 = true).
	intro. elim H7; intros. left. exact (H1 n1 d p1 H8 (le_S_n n0 n1 H6)).
	right. elim H8. intros. split. unfold invar_term in H.
	exact (H n0 n1 d a H9 (le_S_n n0 n1 H6)).
	exact (H0 n0 n1 d p0 H10 (le_S_n n0 n1 H6)).
	exact (invar_2_1 d a p0 p1 t t0 n0 H5).
	intros. simpl in H3. discriminate H3.
Qed.

Lemma invar : forall t : term, invar_term t.
Proof.
	exact (term_term_list_ind invar_term invar_list invar_1 invar_0 invar_2).
Qed.

Lemma invarl : forall tl : term_list, invar_list tl.
Proof.
	exact (term_list_term_ind invar_term invar_list invar_1 invar_0 invar_2).
Qed.

(* Second sens de l'équivalence sémantique *)

Definition dta_reconnait (d : preDTA) (a : ad) (t : term)
  (pr : reconnaissance d a t) := rec_term d a t (essence t d) = true.

Definition st_reconnait (d : preDTA) (s : state) (t : term)
  (pr : state_reconnait d s t) :=
  match t with
  | app c l =>
      exists p : prec_list,
        MapGet prec_list s c = Some p /\
        rec_list_terms d p l (essence_list l d p) = true
  end.

Definition pre_reconnait (d : preDTA) (p : prec_list)
  (t : term_list) (pr : liste_reconnait d p t) :=
  rec_list_terms d p t (essence_list t d p) = true.

Lemma semantic_equiv_1_0 :
 forall (d : preDTA) (a : ad) (t : term) (ladj : state)
   (e : MapGet state d a = Some ladj) (s : state_reconnait d ladj t),
 st_reconnait d ladj t s -> dta_reconnait d a t (rec_dta d a t ladj e s).
Proof.
	intros. unfold dta_reconnait in |- *. unfold st_reconnait in H. induction  t as (a0, t).
	simpl in H. elim H. intros; intros. elim H0. intros.
	cut (rec_term d a (app a0 t) (S (essence_list t d x)) = true).
	cut (S (essence_list t d x) <= essence (app a0 t) d).
	intros. exact
  (invar (app a0 t) (S (essence_list t d x)) (essence (app a0 t) d) d a H4 H3).
	apply (conservation_0 d x a0 t). unfold prec_in_dta in |- *. split with ladj. split with a.
	split with a0. split. assumption.
	assumption.
	simpl in |- *. rewrite e. rewrite H1. simpl in H2. assumption.
Qed.

Lemma semantic_equiv_1_1 :
 forall (d : preDTA) (s : state) (c : ad) (tl : term_list)
   (l : prec_list) (e : MapGet prec_list s c = Some l)
   (l0 : liste_reconnait d l tl),
 pre_reconnait d l tl l0 ->
 st_reconnait d s (app c tl) (rec_st d s c tl l e l0).
Proof.
	intros. unfold st_reconnait in |- *. unfold pre_reconnait in H. split with l. split; assumption.
Qed.

Lemma semantic_equiv_1_2 :
 forall d : preDTA, pre_reconnait d prec_empty tnil (rec_empty d).
Proof.
	intros. unfold pre_reconnait in |- *. simpl in |- *. trivial.
Qed.

Lemma semantic_equiv_1_3 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list) (r : reconnaissance d a hd),
 dta_reconnait d a hd r ->
 forall l : liste_reconnait d la tl,
 pre_reconnait d la tl l ->
 pre_reconnait d (prec_cons a la ls) (tcons hd tl)
   (rec_consi d a la ls hd tl r l).
Proof.
	intros. unfold dta_reconnait in H. unfold pre_reconnait in H0. unfold pre_reconnait in |- *.
	cut
  (rec_list_terms d (prec_cons a la ls) (tcons hd tl)
     (S (max (essence hd d) (essence_list tl d la))) = true).
	intro. cut
  (S (max (essence hd d) (essence_list tl d la)) <=
   essence_list (tcons hd tl) d (prec_cons a la ls)).
	intros. exact
  (invarl (tcons hd tl) (S (max (essence hd d) (essence_list tl d la)))
     (essence_list (tcons hd tl) d (prec_cons a la ls)) d
     (prec_cons a la ls) H1 H2).
	cut
  (max (essence hd d) (essence_list tl d la) = essence hd d \/
   max (essence hd d) (essence_list tl d la) = essence_list tl d la).
	intro. elim H2. intros. rewrite H3. exact (conservation_5 d hd tl a la ls).
	intro. rewrite H3. exact (conservation_4 d hd tl a la ls).
	case (max_dec (essence hd d) (essence_list tl d la)); [ left | right ]; auto.
	cut (rec_term d a hd (max (essence hd d) (essence_list tl d la)) = true).
	cut
  (rec_list_terms d la tl (max (essence hd d) (essence_list tl d la)) = true).
	generalize (max (essence hd d) (essence_list tl d la)). intros. simpl in |- *. rewrite H1.
	(* Unfold rec_term in H2. *) rewrite H2. simpl in |- *.
	exact (orb_b_true (rec_list_terms d ls (tcons hd tl) n)).
	cut (essence_list tl d la <= max (essence hd d) (essence_list tl d la)).
	intro. exact
  (invarl tl (essence_list tl d la)
     (max (essence hd d) (essence_list tl d la)) d la H0 H1).
	exact (le_max_r (essence hd d) (essence_list tl d la)).
	cut (essence hd d <= max (essence hd d) (essence_list tl d la)). intro.
	exact
  (invar hd (essence hd d) (max (essence hd d) (essence_list tl d la)) d a H
     H1).
	exact (le_max_l (essence hd d) (essence_list tl d la)).
Qed.

Lemma semantic_equiv_1_4_0 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (l : term_list) (n : nat),
 l <> tnil ->
 rec_list_terms d ls l n = true ->
 rec_list_terms d (prec_cons a la ls) l (S n) = true.
Proof.
	intro. intro. intro. intro. simple induction l. intros. simpl in H. cut (tnil = tnil). intro. elim (H H1).
	trivial.
	intro. intro. simple induction n. intros. simpl in H1. discriminate H1.
	intros. simpl in |- *. simpl in H2. rewrite H2. simpl in |- *. trivial.
Qed.

Lemma semantic_equiv_1_4 :
 forall (d : preDTA) (a : ad) (la ls : prec_list) (hd : term)
   (tl : term_list) (l : liste_reconnait d ls (tcons hd tl)),
 pre_reconnait d ls (tcons hd tl) l ->
 pre_reconnait d (prec_cons a la ls) (tcons hd tl)
   (rec_consn d a la ls hd tl l).
Proof.
	intro. intro. intro. intro. unfold pre_reconnait in |- *. intros. induction  ls as [a0 ls1 Hrecls1 ls0 Hrecls0| ].
	cut
  (S (essence_list (tcons hd tl) d (prec_cons a0 ls1 ls0)) <=
   essence_list (tcons hd tl) d (prec_cons a la (prec_cons a0 ls1 ls0))).
	intro. cut
  (rec_list_terms d (prec_cons a la (prec_cons a0 ls1 ls0))
     (tcons hd tl) (S (essence_list (tcons hd tl) d (prec_cons a0 ls1 ls0))) =
   true).
	intro.
	exact
  (invarl (tcons hd tl)
     (S (essence_list (tcons hd tl) d (prec_cons a0 ls1 ls0)))
     (essence_list (tcons hd tl) d (prec_cons a la (prec_cons a0 ls1 ls0))) d
     (prec_cons a la (prec_cons a0 ls1 ls0)) H1 H0).
	cut (tcons hd tl <> tnil). intro. (* Unfold liste_reconnait in l.*)
	exact
  (semantic_equiv_1_4_0 d a la (prec_cons a0 ls1 ls0)
     (tcons hd tl) (essence_list (tcons hd tl) d (prec_cons a0 ls1 ls0)) H1 H).
	intro. inversion H1.
	exact (conservation_3 d hd tl a la (prec_cons a0 ls1 ls0)).
	simpl in H. discriminate H.
Qed.

Lemma semantic_equiv_1 :
 forall (d : preDTA) (a : ad) (t : term),
 reconnaissance d a t -> rec_term d a t (essence t d) = true.
Proof.
	exact
  (mreconnaissance_ind dta_reconnait st_reconnait pre_reconnait
     semantic_equiv_1_0 semantic_equiv_1_1 semantic_equiv_1_2
     semantic_equiv_1_3 semantic_equiv_1_4).
Qed.


(** * Completeness *)

(** ** Henkin Constructions **)

From FOL Require Import FragmentSyntax Theories.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Coq Require Import Vector List.
Import ListAutomationNotations ListAutomationHints ListAutomationInstances ListAutomationFacts.

Section GenCons.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {HdF : eq_dec syms} {HdP : eq_dec preds}.

  Context {ff : falsity_flag}.
  Variable GBot : form.
  Hypothesis GBot_closed : closed GBot.

  Notation "⊥'" := GBot.
  Notation "A ⊢G phi" := (@prv Σ_funcs Σ_preds ff class A phi) (at level 30).
  Notation "T ⊢TG phi" := (@tprv Σ_funcs Σ_preds ff class T phi) (at level 30).

  Definition econsistent T T' := T' ⊢TG ⊥' -> T ⊢TG ⊥'.

  (* **** Union *)

  Section Union.
    Variable f : nat -> theory.
    Hypothesis econsistent_f : forall n, econsistent (f n) (f (S n)).
    Hypothesis f_le : forall m n, m <= n -> f m ⊑ f n.

    Definition union (f : nat -> theory) := fun t => exists n, f n t.

    Lemma union_f phi :
      union f ⊢TG phi -> exists n, f n ⊢TG phi.
    Proof.
      intros (A & HA1 & HA2). enough (exists n, A ⊏ f n) as [n H] by now exists n, A.
      clear HA2; induction A.
      - exists 0; eauto with contains_theory.
      - destruct IHA as [n Hn]; destruct (HA1 a) as [m Hm]; eauto with contains_theory.
        exists (max n m); intros ? []; subst.
        + eapply f_le; [apply PeanoNat.Nat.le_max_r | eauto with contains_theory].
        + eapply f_le; [apply PeanoNat.Nat.le_max_l | eauto with contains_theory].
    Qed.

    Lemma union_sub n :
      f n ⊑ union f.
    Proof.
      intros ? ?; exists n; eauto with contains_theory.
    Qed.

    Lemma union_econsistent :
      econsistent (f 0) (union f).
    Proof.
      intros [n H] % union_f. induction n; unfold econsistent in *; eauto.
    Qed.

    Lemma union_closed :
      (forall n, closed_T (f n)) -> closed_T (union f).
    Proof.
      intros f_closed phi [m H]. now eapply f_closed with (n := m) (phi := phi).
    Qed.
  End Union.

  (* **** Explosion *)

  Section Explosion.
    Variable T : theory.
    Hypothesis Hclosed : closed_T T.

    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.

    Definition exp_axiom phi := ⊥' → close All phi.

    Lemma exp_axiom_closed phi : closed (exp_axiom phi).
    Proof.
      unfold closed, exp_axiom. econstructor. 1:easy.
      apply close_closed.
    Qed.

    Lemma exp_axiom_lift phi A :
      exp_axiom phi el A -> exp_axiom phi el (map (subst_form ↑) A).
    Proof.
      intros H. apply in_map_iff. exists (exp_axiom phi). split. 2: assumption.
      unshelve erewrite <- subst_id. 1: intros x; exact ($x). eapply bounded_subst.
      1: apply exp_axiom_closed. lia. now cbv.
    Qed.

    Fixpoint exp n :=
      match n with
      | 0 => T
      | S n => exp n ⋄ exp_axiom (e n)
      end.
    Definition Exp := union exp.

    Lemma Exp_sub :
      T ⊑ Exp.
    Proof.
      apply union_sub with (n := 0) (f := exp).
    Qed.

    Lemma Exp_econsistent :
      econsistent T Exp.
    Proof.
      apply union_econsistent.
      - cbn. intros n (B & HB & Hprv) % prv_T_impl. use_theory B.
        eapply IE. 1: eapply Pc. apply Hprv.
      - induction 1; intros ?; firstorder.
    Qed.

    Lemma Exp_closed :
      closed_T Exp.
    Proof.
      apply union_closed. induction n; intuition.
      cbn. apply closed_T_extend. 1:easy. apply exp_axiom_closed.
    Qed.

    Definition exploding T := forall phi, (⊥' → close All phi) ∈ T.

    Lemma Exp_exploding :
      exploding Exp.
    Proof.
      intros phi. destruct (He phi) as [n Hn]. exists (S n). right; now subst.
    Qed.

    Lemma exploding_inherit T1 T2 :
      exploding T1 -> T1 ⊑ T2 -> exploding T2.
    Proof.
      firstorder.
    Qed.

  End Explosion.

  (* **** Proving with explosion axioms *)

  Notation "¬' phi" := (phi → GBot) (at level 20).
  Notation "∃' phi" := (¬' ∀ ¬' phi) (at level 56, right associativity).

  Lemma GExp A phi :
    (exp_axiom phi) el A -> A ⊢G ⊥' -> A ⊢G phi.
  Proof.
    intros Hel Hbot. apply close_extract. exact (IE (Ctx Hel) Hbot).
  Qed.

  Lemma GDN A phi :
    (exp_axiom phi) el A -> A ⊢G ¬' (¬' phi) -> A ⊢G phi.
  Proof.
    intros Hx H.
    eapply IE.
    2: eapply (Pc A phi GBot).
    eapply II.
    eapply IE. 1: eapply Ctx; now left.
    eapply II. apply GExp. 1: now do 2 right.
    eapply IE. 2: eapply Ctx; now left.
    eapply Weak. 1: apply H.
    intros a Ha; now do 2 right.
  Qed.

  Lemma GExE A phi psi :
    exp_axiom psi el A -> A ⊢G (∃' phi) -> (phi :: map (subst_form ↑) A) ⊢G psi[↑] -> A ⊢G psi.
  Proof.
    intros Hx Hex Hinst.
    apply GDN; [easy | apply II].
    eapply IE. 1: eapply Weak; [eapply Hex |eauto].
    eapply AllI. eapply II.
    cbn. rewrite (@subst_closed _ _ _ _ ⊥'). 2: easy.
    eapply IE. 1: apply Ctx; right; now left.
    eapply Weak. 1: apply Hinst.
    intros a [->|H2]; eauto.
  Qed.

  Lemma GExI A t phi :
    A ⊢G phi [t..] -> A ⊢G ∃' phi.
  Proof.
    intros Hc. apply II.
    erewrite <- (@subst_closed _ _ _ _ ⊥' (t..)). 2:easy.
    eapply IE. 2: eapply Weak. 2: apply Hc. 2: intros a Ha; eauto.
    change ((phi[t..] → ⊥'[t..])) with ((phi → ⊥')[t..]).
    eapply AllE. apply Ctx. left.
    now rewrite subst_closed.
  Qed.

  Lemma GXM A phi psi :
    exp_axiom psi el A -> (phi :: A) ⊢G psi -> (¬' phi :: A) ⊢G psi -> A ⊢G psi.
  Proof.
    intros Hx Ht Hf. apply GDN; try easy.
    apply II. eapply IE with (¬' phi); [apply II|].
    - eapply IE. 1: apply Ctx; right; now left. eapply Weak. 1: apply Hf. intros a [->|Ha]; eauto.
    - eapply II. eapply IE. 1: apply Ctx; right; now left. eapply Weak. 1: apply Ht. intros a [->|Ha]; eauto.
  Qed.

  Definition DPexp1 phi := exp_axiom (∃' (phi → (∀ phi)[↑])).
  Definition DPexp2 phi := exp_axiom (phi [($O) .: (S >> (S >> var))]).
  Definition DPexp3 phi := exp_axiom phi.

  Lemma GDP A phi :
    DPexp1 phi el A -> DPexp2 phi el A -> DPexp3 phi el A -> A ⊢G ∃' (phi → (∀ phi)[↑]).
  Proof.
    intros ? H1 H2. do 2 apply exp_axiom_lift in H1. do 1 apply exp_axiom_lift in H2.
    apply (@GXM _ (∃' (¬' phi))); [intuition| |].
    - eapply GExE; [intuition|apply Ctx;now left|]; cbn.
      erewrite !(subst_closed _ GBot_closed).
      apply (@GExI _ ($0)). cbn. apply II. apply AllI. asimpl. apply GExp.
      eapply incl_map. 2: exact H1. intros a Ha; eauto. cbn.
      asimpl. rewrite (subst_closed _ GBot_closed).
      eapply IE; apply Ctx. 2: now left. 1: right; now left.
    - apply (@GExI _ ($0)). cbn. apply II. apply AllI. cbn.
      asimpl. rewrite ! (subst_closed _ GBot_closed).
      eapply GDN. 1: now do 2 right.
      eapply II.
      eapply IE. 1: apply Ctx; right; right; now left.
      apply (@GExI _ ($0)). cbn. rewrite ! (subst_closed _ GBot_closed).
      asimpl. apply Ctx. now left.
  Qed.

  (* **** Henkin *)

  Section Henkin.
    Variable T : theory.
    Hypothesis Hclosed : closed_T T.
    Hypothesis Hexp : exploding T.

    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.
    Hypothesis Hbounded : forall n, bounded n (e n).

    Definition henkin_axiom phi := (phi → ((∀ phi)[↑])).

    Lemma henkin_axiom_bounded n phi :
      bounded n (∀ phi) -> bounded (S n) (¬' (henkin_axiom phi)).
    Proof.
      intros H%bounded_S_quant.
      unfold henkin_axiom. constructor. 2: eapply bounded_up; [apply GBot_closed|lia].
      econstructor. 2: cbn; econstructor. 1:easy.
      eapply subst_bounded_max. 2: apply H.
      intros i Hi. unfold up, funcomp, scons. cbn.
      destruct i; econstructor; lia.
    Qed.

    Fixpoint henkin n :=
      match n with
      | O => T
      | S n => henkin n ⋄ subst_form (($ n)..) (henkin_axiom (e n))
      end.

    Lemma henkin_bounded n :
      forall phi, phi ∈ (henkin n) -> bounded n phi.
    Proof.
      induction n as [|n IH]; cbn.
      - intros. now apply Hclosed.
      - intros phi [H1|H1]. 1: eapply bounded_up; intuition.
        subst. econstructor.
        + eapply subst_bounded_max. 2: apply Hbounded.
          intros i Hi. destruct i; econstructor; lia.
        + econstructor. rewrite subst_comp. eapply subst_bounded_max. 2:apply Hbounded.
          intros i Hi. destruct i; econstructor; lia.
    Qed.

    Lemma henkin_le m n :
      m <= n -> henkin m ⊑ henkin n.
    Proof.
      induction 1; firstorder.
    Qed.

    Definition Henkin := union henkin.

    Lemma Henkin_consistent :
      econsistent T Henkin.
    Proof.
      refine (union_econsistent _ henkin_le). intros n.
      cbn; intros (A & HA1 & HA2) % prv_T_impl.
      rewrite <- (@subst_id _ _ _ _ ⊥' var) in HA2.
      rewrite (@bounded_subst _ _ _ _ _ _ _ ($n..) GBot_closed) in HA2.
      apply <- (@nameless_equiv_all' _ _ ff class A (¬' (henkin_axiom (e n))) n) in HA2. 5:easy. 4:lia.
      - use_theory (exp_axiom GBot :: DPexp1 (e n) :: DPexp2 (e n) :: DPexp3 (e n) :: A).
        { intros ? [<- | [<- | [ <- | [<- |]]]]. 5: intuition.
          all: apply henkin_le with (m := 0); [lia | apply Hexp]. }
        eapply IE.
        2: apply (@GDP (exp_axiom GBot :: DPexp1 (e n) :: DPexp2 (e n) :: DPexp3 (e n) :: A) (e n)); eauto.
        apply II.
        eapply GExE. 1: eauto. 1: apply Ctx; eauto.
        cbn.
        rewrite ! (subst_closed _ GBot_closed).
        rewrite ! (subst_closed _ (close_closed _ _)).
        eapply IE. 2: eapply Weak; [apply HA2|]. 2: intros a Ha; now do 6 right.
        apply II. eapply IE. 1: apply Ctx; now left. apply Ctx. right. now left.
      - apply henkin_axiom_bounded. constructor. eapply bounded_up; [apply Hbounded | lia].
      - intros ? H' % HA1. eapply henkin_bounded. apply H'.
    Qed.

    Definition is_Henkin T := forall T' phi, T ⊑ T' -> (forall t, T' ⊢TG phi[t..]) -> T' ⊢TG ∀ phi.

    Lemma Henkin_is_Henkin :
      is_Henkin Henkin.
    Proof.
      intros T' phi HT' Hall. destruct (He phi) as [n Hn]. destruct (Hall ($n)) as (A & HA1 & HA2).
      use_theory (subst_form (($n)..) (henkin_axiom phi) :: A).
      - intros ? [<- |]; [| intuition]; subst. apply HT'. exists (S n). now right.
      - eapply IE; [|eapply Weak; [apply HA2|intros a Ha; eauto]]; apply II.
        cbn. asimpl.
        eapply IE. 1: apply Ctx; eauto. apply Ctx; eauto.
    Qed.

    Lemma is_Henkin_inherit T1 T2 :
      is_Henkin T1 -> T1 ⊑ T2 -> is_Henkin T2.
    Proof.
      intros H1 H2 TT phi HTT. apply H1. intros psi Hpsi. apply HTT. apply H2. easy.
    Qed.

    Lemma Henkin_T :
      T ⊑ Henkin.
    Proof.
      apply union_sub with (f := henkin) (n := 0).
    Qed.
  End Henkin.

  (* **** Omega *)

  Section Omega.
    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.

    Variable T : theory.
    Hypothesis Hexp : exploding T.
    Hypothesis Hhenkin : is_Henkin T.

    Definition maximal T := forall f, econsistent T (T ⋄ f) -> f ∈ T.

    Definition econsistent_join T phi := fun psi => T psi \/ (econsistent T (T ⋄ phi) /\ psi = phi).
    Infix "∘" := econsistent_join (at level 20).

    Lemma econsistent_join_sub T' phi :
      (T' ∘ phi) ⊑ (T' ⋄ phi).
    Proof.
      intros psi [Htt1|[Htt2 ->]].
      - now left.
      - now right.
    Qed.

    Lemma consistent_join_step T' phi psi :
      T' ∘ psi ⊢TG phi -> T' ⊢TG phi \/ econsistent T' (T' ⋄ psi).
    Proof.
      intros (A & HA1 & HA2).
      enough (A ⊏ T' \/ econsistent T' (T' ⋄ psi)) as [] by ((left; exists A; intuition) + now right).
      clear HA2; induction A.
      - firstorder.
      - destruct (HA1 a), IHA; intuition. all: eauto with contains_theory.
    Qed.

    Fixpoint omega n : theory :=
      match n with
      | 0 => T
      | S n => omega n ∘ e n
      end.

    Lemma omega_le n m :
      n <= m -> omega n ⊑ omega m.
    Proof.
      induction 1; firstorder.
    Qed.

    Definition Omega : theory := union omega.

    Lemma econsistent_Omega :
      econsistent T Omega.
    Proof.
      refine (union_econsistent _ omega_le). intros n H. destruct (consistent_join_step H).
      all: firstorder.
    Qed.

    Lemma econsistency_inheritance T1 T2 T1' T2' :
      econsistent T1 T1' -> T1 ⊑ T2 -> T2' ⊑ T1' -> econsistent T2 T2'.
    Proof.
      intros H1 HT HT' (A & AT2' & Hprv).
      assert (T1' ⊢TG ⊥') as HT1'.
      - use_theory A. 1: intros psi Hin; apply HT', AT2', Hin. easy.
      - destruct (H1 HT1') as (B & BT1' & HBprv).
        use_theory B. intros psi Hin; apply HT, BT1', Hin. easy.
    Qed.

    Lemma econsistency_trans T1 T2 T3 :
      econsistent T1 T2 -> econsistent T2 T3 -> econsistent T1 T3.
    Proof.
      intros H1 H2 H. apply H1. apply H2. easy.
    Qed.

    Lemma maximal_Omega :
      maximal Omega.
    Proof.
      intros phi H. destruct (He phi) as [n Hn].
      apply (union_sub (n := S n)); cbn; rewrite -> Hn. right; split; [| reflexivity].
      eapply econsistency_inheritance.
      + exact (econsistency_trans econsistent_Omega H).
      + apply omega_le with (n := 0). lia.
      + firstorder.
    Qed.

    Lemma econsistent_prv T' T'' phi :
      econsistent T' T'' -> T'' ⊢TG phi -> econsistent T' (T'' ⋄ phi).
    Proof.
      intros HT Hphi Hbot. now apply HT, (prv_T_remove Hphi).
    Qed.

    Lemma maximal_prv T' phi :
      maximal T' -> T' ⊢TG phi -> phi ∈ T'.
    Proof.
      intros Hin Hprv. now apply Hin, econsistent_prv.
    Qed.

    Lemma Omega_prv phi :
      Omega ⊢TG phi -> phi ∈ Omega.
    Proof.
      intros Hprv. now apply (maximal_prv maximal_Omega).
    Qed.

    Lemma Omega_T :
      T ⊑ Omega.
    Proof.
      change T with (omega 0). apply (union_sub (n := 0)).
    Qed.

    Lemma Omega_impl phi psi :
      phi → psi ∈ Omega <-> (phi ∈ Omega -> psi ∈ Omega).
    Proof.
      split.
      - intros Himp Hphi. apply Omega_prv.
        use_theory [phi → psi; phi].
        1: intros a [<-|[<-|[]]]; easy.
        eapply IE. 1: apply Ctx; eauto. apply Ctx; eauto.
      - intros H. apply maximal_Omega. intros (A & HA1 & HA2) % prv_T_impl.
        apply (prv_T_remove (phi := psi)).
        + apply elem_prv, H, Omega_prv.
          use_theory (exp_axiom phi :: exp_axiom psi :: A).
          * intros ? [<- | [ <- | H'']]; [apply Omega_T, Hexp | apply Omega_T, Hexp | now apply HA1].
          * eapply GDN; try eauto. apply II.
            eapply IE; [|eapply Weak; [apply HA2|intros a Ha; eauto]]; apply II.
            eapply IE; [eapply Ctx; now left|].
            apply II. apply GExp; eauto. eapply IE; [|apply Ctx; now left]. apply Ctx; eauto.
        + use_theory (psi :: A). 1:intros a [->|Hin]; [right|left]; intuition.
          eapply IE; [|eapply Weak; [apply HA2|intros a Ha; eauto]]; apply II.
          eapply IE; [apply Ctx; eauto|]. apply II. apply Ctx; eauto.
    Qed.

    Lemma Omega_all phi :
      ∀ phi ∈ Omega <-> (forall t, phi[t..] ∈ Omega).
    Proof.
      split; intros Hprv.
      - intros t. apply Omega_prv. use_theory [∀ phi]. 1: intros psi [<-|[]]; eauto.
        apply AllE. now apply Ctx.
      - apply Omega_prv, (Hhenkin Omega_T). eauto using elem_prv.
    Qed.
  End Omega.
End GenCons.

(* **** Conclusion *)

Section Composition.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {HdF : eq_dec syms} {HdP : eq_dec preds}.

  Structure ConstructionInputs : Type :=
    {
      variant : falsity_flag ;

      NBot : form ;
      NBot_closed : closed NBot ;

      In_T : theory ;
      In_T_closed : closed_T In_T ;

      enum : nat -> form ;
      enum_enum : forall phi, exists n, enum n = phi ;
      enum_bounded : forall n, bounded n (enum n)
    }.

  Structure ConstructionOutputs (In : ConstructionInputs) :=
    {
      Out_T : theory ;
      Out_T_econsistent : @econsistent _ _  (variant In) (NBot In) (@In_T In) Out_T ;
      Out_T_sub : @In_T In ⊑ Out_T ;

      Out_T_prv : forall phi, @tprv _ _ (variant In) class Out_T phi -> phi ∈ Out_T ;
      Out_T_all : forall phi, ∀ phi ∈ Out_T <-> (forall t, phi[t..] ∈ Out_T) ;
      Out_T_impl : forall phi psi, phi → psi ∈ Out_T <-> (phi ∈ Out_T -> psi ∈ Out_T)
    }.

  Lemma construct_construction (In : ConstructionInputs) :
    ConstructionOutputs In.
  Proof.
    destruct In as [ff NBot NBot_closed T T_closed e e_enum e_bounded].
    eexists (Omega NBot e (Henkin (Exp NBot T e) e)); cbn.
    + eapply econsistency_trans. { eapply econsistency_trans. eapply Exp_econsistent.
      eapply Henkin_consistent; intuition. 1: eapply Exp_closed; intuition. eapply Exp_exploding. intros n; easy. } eapply econsistent_Omega.
    + transitivity (Henkin (Exp NBot T e) e). 1: transitivity (Exp NBot T e).
      1: apply Exp_sub. 1: apply Henkin_T. apply Omega_T.
    + eapply Omega_prv. easy.
    + eapply Omega_all; try easy. eapply Henkin_is_Henkin. easy.
    + eapply Omega_impl; try easy. eapply exploding_inherit.
      - eapply Exp_exploding. easy.
      - eapply Henkin_T.
  Qed.
End Composition.


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 X A B C U V : Universe, ((wd_ A B /\ (wd_ C X /\ (wd_ B X /\ (col_ X A B /\ (col_ X C X /\ (col_ U A B /\ col_ V C X)))))) -> col_ U B X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import HoTT.
Require Import HoTT.Categories Category.Morphisms.
Require Import FunextAxiom.
(* Require Import finite_lemmas. *)

Section Type_to_Cat.

  Local Notation "x --> y" := (morphism _ x y) (at level 99, right associativity, y at level 200) : type_scope.
  Definition Type_to_Cat : 1-Type -> PreCategory.
  Proof.
    intro X.
    srapply (Build_PreCategory (fun x y : X => x = y)).
    - reflexivity.
    - cbn. intros x y z p q.
      exact (q @ p).
    - intros x1 x2 x3 x4 p q r. simpl. apply concat_p_pp.
    - cbn. intros x1 x2 p. apply concat_p1.
    - intros x y p. simpl. apply concat_1p.
  Defined.

  Global Instance isgroupoid_type_to_cat (X : 1-Type) (x1 x2 : (Type_to_Cat X)) (f : x1 --> x2) :
    IsIsomorphism f.
  Proof.
    srapply @Build_IsIsomorphism.
    - exact f^.
    - apply concat_pV.
    - apply concat_Vp.
  Defined.

  Definition arrow_to_functor {X Y : 1-Type} (F : X -> Y) :
    Functor (Type_to_Cat X) (Type_to_Cat Y).
  Proof.
    srapply (Build_Functor (Type_to_Cat X) (Type_to_Cat Y) F).
    - intros x1 x2. simpl.
      exact (ap F).
    - simpl. intros x1 x2 x3 p q.
      apply ap_pp.
    - simpl. reflexivity.
  Defined.

  Definition cat_of_arrow (X Y : 1-Type) :
    Functor (Type_to_Cat (BuildTruncType 1 (X -> Y)))
            (functor_category (Type_to_Cat X) (Type_to_Cat Y)).
  Proof.
    srapply @Build_Functor; simpl.
    - apply arrow_to_functor.
    - intros f g p.
      srapply @Build_NaturalTransformation; simpl.
      + apply (ap10 p).
      + intros x1 x2 q.
        destruct p, q. reflexivity.
    - intros f g h p q. simpl.
      unfold NaturalTransformation.Composition.Core.compose. simpl. destruct p, q. simpl.
      apply NaturalTransformation.path_natural_transformation. simpl. intro x. reflexivity.
    - intro f. simpl.
      apply NaturalTransformation.path_natural_transformation. simpl. intro x. reflexivity.
  Defined.
End Type_to_Cat.


Require Import sflib.

Require Import vellvm.
Require Import paco.

Require Import GenericValues.
Import Opsem.

(* TODO: obs_done should have the return value. *)
CoInductive observation : Type :=
| obs_done (retval: val)
| obs_inftau
| obs_event (evt:event) (obs:observation)
.

Definition trace_observation (tr:trace) (obs:observation) : observation :=
  fold_right obs_event obs tr.

Inductive behmatch
          (conf:Config)
          (behave: forall (st:State) (obs:observation), Prop):
  forall (st:State) (obs:observation), Prop :=
| beh_error
    s obs
    (ERROR: error_state conf s):
    behmatch conf behave s obs
| beh_done
    s retval
    (FINAL: s_isFinalState conf s = Some retval):
    behmatch conf behave s (obs_done retval)
| beh_inftau
    s s'
    (ST: sInsn conf s s' E0)
    (INF: behave s' obs_inftau):
    behmatch conf behave s obs_inftau
| beh_evt
    s s' tr obs
    (ST: sInsn conf s s' tr)
    (TR: tr <> E0)
    (INF: behave s' obs):
    behmatch conf behave s (trace_observation tr obs)
.
Hint Constructors behmatch.

Inductive behave_ conf behave s obs: Prop :=
| behave_intro
    s'
    (TAU: sop_star conf s s' E0)
    (MAT: behmatch conf behave s' obs)
.
Hint Constructors behave_.

Definition behave conf : _ -> _ -> Prop := paco2 (behave_ conf) bot2.

Lemma behave_mon conf: monotone2 (@behave_ conf).
Proof.
  ii; destruct IN; destruct MAT; eauto.
Qed.
Hint Resolve behave_mon: paco.

Definition behave_module module main args obs: Prop :=
  forall conf st (INIT: s_genInitState [module] main args Mem.empty = Some (conf, st)),
    behave conf st obs.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype prime.
Require Import bigop finset fingroup morphism automorphism quotient action.
Require Import cyclic gproduct 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 [sGpG nGpG]:= andP (pcore_normal p G).
have sGD := acts_dom nMG; have sGpD := subset_trans sGpG sGD.
rewrite subsetI sGpG -gacentC //=; apply/setIidPl; apply: minM (subsetIl _ _).
rewrite nontrivial_gacent_pgroup ?pcore_pgroup //=; last first.
  by split; rewrite ?(subset_trans sGpG).
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[_]; exact: 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_transr.
    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:= S_P; rewrite inE => /maxgroupP[/andP[_ pP]].
  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} 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:= (atransP2 Syl_trans) P Q; rewrite !inE.
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->; exact: 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.
case: (eqVneq Z 1); first by move/(trivg_center_pgroup pP)->; exact: abelian1.
case/(pgroup_pdiv (pgroupS sZP pP)) => p_pr _ [k oZ].
apply: cyclic_center_factor_abelian.
case: (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 ?gfunctor.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 pnat_exp 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 exact: 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; exact: 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[_]; exact: maxH.
rewrite /normal sHG; apply/setIidPl; symmetry.
apply: nilpotent_sub_norm; rewrite ?subsetIl ?setIS //=.
by rewrite char_norms // -{1}(normal_Hall_pcore hallH) // pcore_char.
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); exact: 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 !(subset_trans (pcore_sub _ _)) ?normal_norm ?pcore_normal.
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 exact: 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/forallP=> V.
apply/implyP=> /SylowP[p p_pr /and3P[sVH]].
case/(Sylow_superset (subset_trans sVH sHG))=> P sylP sVP _.
have:= zgG P; rewrite (p_Sylow sylP); exact: 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/forallP=> fV; apply/implyP => /SylowP[p pr_p sylfV].
have [P sylP] := Sylow_exists p G.
have [|z _ ->] := @Sylow_trans p _ _ (f @* P)%G _ _ sylfV.
  apply: morphim_pHall (sylP); exact: subset_trans (pHall_sub sylP) sGD.
rewrite cyclicJ morphim_cyclic // (implyP (forallP zgG P)) //.
by apply/SylowP; exists p.
Qed.

Lemma nil_Zgroup_cyclic G : Zgroup G -> nilpotent G -> cyclic G.
Proof.
elim: {G}_.+1 {-2}G (ltnSn #|G|) => // n IHn G; rewrite ltnS => 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.
rewrite /order -def_p -def_p' (@pnat_coprime p) //; exact: pcore_pgroup.
Qed.

End Zgroups.

Arguments Scope Zgroup [_ group_scope].
Prenex Implicits Zgroup.

Section NilPGroups.

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

Lemma cyclic_pgroup_quo_der1_cyclic P :
  p.-group P -> cyclic (P / P^`(1)) -> cyclic P.
Proof.
move=> pP; rewrite (isog_cyclic (quotient1_isog P)).
have [-> // | ntP' cPP'] := eqVneq P^`(1) 1.
suffices: 'L_2(P) == 1 by move/eqP <-.
apply: (implyP (forallP (pgroup_nil pP) _)).
rewrite subsetI lcn_sub -lcnSn /= -quotient_cents2 ?lcn_norm //.
apply: cyclic_factor_abelian (lcn_central 2 P) _.
by rewrite (isog_cyclic (third_isog _ _ _)) ?lcn_normal // lcn_subS.
Qed.

(* 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.
elim: {G}_.+1 {-2}G x (ltnSn #|G|) => // n IHn G x; rewrite ltnS.
set E := x ^: G => leGn Gx pE.
have{pE} 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 exact: class_norm.
have Ex: x \in E by exact: 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 exact: sub_gen.
have sDG: D \subset G by exact: subset_trans sEG.
have sBE: B \subset E by rewrite subUset sub1set Ey0.
have sBG: <<B>> \subset G by exact: 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 exact: 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.
  apply: pgroupS (genS _) (pE _ _ Ex1 Ex1y).
  by apply/subsetP=> u; rewrite !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 exact: 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.
  apply: subsetP Pz; exact: (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.