Require Import primRec.
Require Import code.
Require Import Arith.
Require Import cPair.

Lemma codeForallIsPR : isPR 2 (fun a b : nat => cPair 3 (cPair a b)).
Proof.
apply compose2_2IsPR with (f := fun a b : nat => 3).
apply filter10IsPR with (g := fun _ : nat => 3).
apply const1_NIsPR.
apply cPairIsPR.
apply cPairIsPR.
Qed.

Lemma codeNotIsPR : isPR 1 codeNot.
Proof.
unfold codeNot in |- *.
apply compose1_2IsPR with (f := fun a : nat => 2) (f' := fun a : nat => a).
apply const1_NIsPR.
apply idIsPR.
apply cPairIsPR.
Qed.

Lemma codeImpIsPR : isPR 2 codeImp.
Proof.
unfold codeImp in |- *.
apply compose2_2IsPR with (f := fun a b : nat => 1).
apply filter10IsPR with (g := fun _ : nat => 1).
apply const1_NIsPR.
apply cPairIsPR.
apply cPairIsPR.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_ray1.
Require Export GeoCoq.Elements.OriginalProofs.lemma_differenceofparts.
Require Export GeoCoq.Elements.OriginalProofs.lemma_interior5.
Require Export GeoCoq.Elements.OriginalProofs.lemma_partnotequalwhole.
Require Export GeoCoq.Elements.OriginalProofs.lemma_3_6b.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_layoffunique :
   forall A B C D,
   Out A B C -> Out A B D -> Cong A C A D ->
   eq C D.
Proof.
intros.
assert (Cong A D A C) by (conclude lemma_congruencesymmetric).
assert ((BetS A C B \/ eq B C \/ BetS A B C)) by (conclude lemma_ray1).
assert ((BetS A D B \/ eq B D \/ BetS A B D)) by (conclude lemma_ray1).
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (Cong B C B C) by (conclude cn_congruencereflexive).
assert (Cong C B C B) by (conclude cn_congruencereflexive).
assert (Cong A C A C) by (conclude cn_congruencereflexive).
assert (eq C D).
by cases on (BetS A C B \/ eq B C \/ BetS A B C).
{
 assert (eq C D).
 by cases on (BetS A D B \/ eq B D \/ BetS A B D).
 {
  assert (Cong C B D B) by (conclude lemma_differenceofparts).
  assert (Cong B C B D) by (forward_using lemma_congruenceflip).
  assert (Cong C C C D) by (conclude lemma_interior5).
  assert (Cong C D C C) by (conclude lemma_congruencesymmetric).
  assert (~ neq C D).
   {
   intro.
   assert (neq C C) by (conclude axiom_nocollapse).
   assert (eq C C) by (conclude cn_equalityreflexive).
   contradict.
   }
  close.
  }
 {
  assert (BetS A C D) by (conclude cn_equalitysub).
  assert (~ neq C D).
   {
   intro.
   assert (~ Cong A C A D) by (conclude lemma_partnotequalwhole).
   contradict.
   }
  close.
  }
 {
  assert (BetS A C D) by (conclude lemma_3_6b).
  assert (~ neq C D).
   {
   intro.
   assert (~ Cong A C A D) by (conclude lemma_partnotequalwhole).
   contradict.
   }
  close.
  }
(** cases *)
 close.
 }
{
 assert (Cong A B A D) by (conclude cn_equalitysub).
 assert (Cong A D A B) by (conclude lemma_congruencesymmetric).
 assert (eq C D).
 by cases on (BetS A D B \/ eq B D \/ BetS A B D).
 {
  assert (~ neq C D).
   {
   intro.
   assert (~ Cong A D A B) by (conclude lemma_partnotequalwhole).
   contradict.
   }
  close.
  }
 {
  assert (eq C B) by (conclude lemma_equalitysymmetric).
  assert (eq D B) by (conclude lemma_equalitysymmetric).
  assert (eq C D) by (conclude cn_equalitytransitive).
  close.
  }
 {
  assert (BetS A C D) by (conclude cn_equalitysub).
  assert (~ neq C D).
   {
   intro.
   assert (~ Cong A C A D) by (conclude lemma_partnotequalwhole).
   contradict.
   }
  close.
  }
(** cases *)
 close.
 }
{
 assert (eq C D).
 by cases on (BetS A D B \/ eq B D \/ BetS A B D).
 {
  assert (BetS A D C) by (conclude lemma_3_6b).
  assert (Cong A D A C) by (conclude lemma_congruencesymmetric).
  assert (~ neq C D).
   {
   intro.
   assert (~ Cong A D A C) by (conclude lemma_partnotequalwhole).
   contradict.
   }
  close.
  }
 {
  assert (BetS A D C) by (conclude cn_equalitysub).
  assert (~ neq C D).
   {
   intro.
   assert (~ Cong A D A C) by (conclude lemma_partnotequalwhole).
   contradict.
   }
  close.
  }
 {
  assert (neq A B) by (forward_using lemma_betweennotequal).
  assert (Cong B C B D) by (conclude lemma_differenceofparts).
  assert (eq C D) by (conclude lemma_extensionunique).
  close.
  }
(** cases *)
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


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

Require Import Rbase.
Require Import Rbasic_fun.
Require Import Even.
Require Import Div2.
Require Import ArithRing.

Open Local Scope Z_scope.
Open Local Scope R_scope.

Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
Proof.
  intros; red in |- *; intro.
  cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
  intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
    elim (lt_irrefl _ H).
  set (R := fun n m:nat => (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
  cut
    ((forall n m:nat, R n m) ->
      forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
  intro; apply H1.
  apply nat_double_ind.
  unfold R in |- *; intros; inversion H2; reflexivity.
  unfold R in |- *; intros; simpl in H3; assumption.
  unfold R in |- *; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
    assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
  unfold R in |- *; intros; apply H1; assumption.
Qed.

Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
Proof.
  set (R := fun m n:nat => (n <= m)%nat -> (m - n <= m)%nat).
  cut
    ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
  intro; apply H.
  apply nat_double_ind.
  unfold R in |- *; intros; simpl in |- *; apply le_n.
  unfold R in |- *; intros; simpl in |- *; apply le_n.
  unfold R in |- *; intros; simpl in |- *; apply le_trans with n.
  apply H0; apply le_S_n; assumption.
  apply le_n_Sn.
  unfold R in |- *; intros; apply H; assumption.
Qed.

Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
Proof.
  intros n m; pattern n, m in |- *; apply nat_double_ind;
    [ intros; rewrite <- minus_n_O; assumption
      | intros; elim (lt_n_O _ H)
      | intros; simpl in |- *; apply H; apply lt_S_n; assumption ].
Qed.

Lemma even_odd_cor :
  forall n:nat,  exists p : nat, n = (2 * p)%nat \/ n = S (2 * p).
Proof.
  intro.
  assert (H := even_or_odd n).
  exists (div2 n).
  assert (H0 := even_odd_double n).
  elim H0; intros.
  elim H1; intros H3 _.
  elim H2; intros H4 _.
  replace (2 * div2 n)%nat with (double (div2 n)).
  elim H; intro.
  left.
  apply H3; assumption.
  right.
  apply H4; assumption.
  unfold double in |- *;ring.
Qed.

  (* 2m <= 2n => m<=n *)
Lemma le_double : forall m n:nat, (2 * m <= 2 * n)%nat -> (m <= n)%nat.
Proof.
  intros; apply INR_le.
  assert (H1 := le_INR _ _ H).
  do 2 rewrite mult_INR in H1.
  apply Rmult_le_reg_l with (INR 2).
  replace (INR 2) with 2; [ prove_sup0 | reflexivity ].
  assumption.
Qed.

(** Here, we have the euclidian division *)
(** This lemma is used in the proof of sin_eq_0 : (sin x)=0<->x=kPI *)
Lemma euclidian_division :
  forall x y:R,
    y <> 0 ->
    exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y).
Proof.
  intros.
  set
    (k0 :=
      match Rcase_abs y with
	| left _ => (1 - up (x / - y))%Z
	| right _ => (up (x / y) - 1)%Z
      end).
  exists k0.
  exists (x - IZR k0 * y).
  split.
  ring.
  unfold k0 in |- *; case (Rcase_abs y); intro.
  assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl in |- *;
    unfold Rminus in |- *.
  replace (- ((1 + - IZR (up (x / - y))) * y)) with
    ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
  split.
  apply Rmult_le_reg_l with (/ - y).
  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
  rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
  apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
  rewrite Rplus_0_r; unfold Rdiv in |- *; pattern (/ - y) at 4 in |- *;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  replace
    (IZR (up (x * / - y)) - x * - / y +
      (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1;
    [ idtac | ring ].
  elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
  rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
  rewrite <- Rinv_l_sym.
  rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
    rewrite <- Ropp_inv_permute; [ idtac | assumption ].
  rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
      apply Rplus_lt_reg_r with (IZR (up (x / - y)) - 1).
  replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
    [ idtac | ring ].
  replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
    with (- (x * / y)); [ idtac | ring ].
  rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
    unfold Rdiv in |- *; intros H1 _; exact H1.
  apply Ropp_neq_0_compat; assumption.
  assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl in |- *;
    cut (0 < y).
  intro; unfold Rminus in |- *;
    replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
      [ idtac | ring ].
  split.
  apply Rmult_le_reg_l with (/ y).
  apply Rinv_0_lt_compat; assumption.
  rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r;
    rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
      [ rewrite Rmult_1_r | assumption ];
      apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y);
	rewrite Rplus_0_r; unfold Rdiv in |- *;
	  replace
	    (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2;
	      exact H2.
  rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
  apply Rinv_0_lt_compat; assumption.
  rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
    rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
      [ rewrite Rmult_1_r | assumption ];
      apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y)));
	  [ idtac | ring ];
	  replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *;
	      intros H2 _; exact H2.
  case (total_order_T 0 y); intro.
  elim s; intro.
  assumption.
  elim H; symmetry  in |- *; exact b.
  assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
Qed.

Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
Proof.
  intros; induction  i as [| i Hreci].
  replace (S n + 0)%nat with (S n); [ apply le_n_Sn | ring ].
  replace (S n + S i)%nat with (S (S n + i)).
  apply le_S; assumption.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
Qed.


Require Import Bool.

 Set Implicit Arguments.

  Lemma bool_dec : forall b, {b = true}+{b = false}.
    destruct b; auto.
  Qed.

 Section TreeS.
  (** Representing Piecewise functions *)

   Variables  (A : Set) (Aeq : A -> A -> bool)
            (Haq : forall a b, Aeq a b =  true -> Aeq b a = true).

  Inductive Piecewise : Set :=
   | lp : A -> Piecewise
   | pf : Piecewise -> Piecewise -> Piecewise -> Piecewise.

  Inductive Cond : Set :=
   | Ret :  A -> Cond
   | Cif :  A -> Cond-> Cond -> Cond.

  (* trivial equality for Cond *)
  Fixpoint CondEq i j :=
    match i, j with
    | Ret a, Ret b => Aeq a b
    | Cif a l r, Cif b l1 r1 =>
       if Aeq a b then CondEq l l1 && CondEq r r1 else false
    | _ , _ => false
    end.

  Fixpoint  cif  (a b c : Cond)  : Cond :=
   match a  with
   | Ret x => Cif  x b c
   | Cif x bt be => Cif x (cif bt b c) (cif be b c)
   end.

  (* From Piecewise to Cond  *)
  Fixpoint pNrm' ( p : Piecewise)  :=
    match p with
   | lp a => Ret a
   | pf c l r => cif (pNrm' c) (pNrm' l) (pNrm' r)
   end.

  (* cif is associative *)
  Lemma ciflemm (a b c x y : Cond) :
    cif (cif a b c) x y = cif a (cif b x y) (cif c x y).
  Proof.
   induction a; simpl; auto.
   intros b c x y; rewrite (IHa1 b c x y);  rewrite (IHa2 b c x y); trivial.
  Qed.

 Section Normalization.

  (** We can flatten the tree to the right and check each interval, but this
      of course is subject ot the ordering of the intervals, hence thos does not really work *)

   Inductive ST : Set :=
    | sl   : A -> ST
    | sf : A -> A -> ST -> ST.

   Fixpoint STeq i j :=
     match i, j with
     | sl a, sl b => Aeq a b
     | sf c a x, sf c1 a1 y => if (Aeq c c1) then (Aeq a a1) && (STeq x y) else false
     | _ , _ => false
     end.

  Fixpoint flatn_aux a (b c : ST) : ST :=
    match b with
    | sl x => sf a x c
    | sf x l r => sf x l (flatn_aux a r c)
    end.

  Fixpoint flatn (i : Cond ) : ST  :=
    match i with
    | Ret a => sl a
    | Cif a l r => flatn_aux a (flatn l) (flatn r)
    end.

 End Normalization.

 End TreeS.

 (* Section TreeS.
  (* Set Implicit Arguments. *)

  Variables (A : Set) (Aeq : A -> A -> bool)
            (Haq : forall a b, Aeq a b =  true -> Aeq b a = true).

  Inductive Piecewise : Set :=
   | lp : A -> Piecewise
   | pf : Piecewise -> Piecewise -> Piecewise -> Piecewise.

  Inductive Cond :     Set :=
   | Ret :  A -> Cond
   | Cif :  A -> Cond-> Cond -> Cond.

  Fixpoint CondEq i j :=
    match i, j with
    | Ret a, Ret b => Aeq a b
    | Cif a l r, Cif b l1 r1 =>
       if Aeq a b then CondEq l l1 && CondEq r r1 else false
    | _ , _ => false
    end.

  Fixpoint  cif  (a b c : Cond)  : Cond :=
   match a  with
   | Ret x => Cif  x b c
   | Cif x bt be => Cif x (cif bt b c) (cif be b c)
   end.

  Fixpoint pNrm' ( p : Piecewise)  :=
    match p with
   | lp a => Ret a
   | pf c l r => cif (pNrm' c) (pNrm' l) (pNrm' r)
   end.

 Fixpoint intervals i :=
   match i with
   | Ret a => (a :: nil)
   | Cif _ l r => intervals l ++ intervals r
  end.

 (*Lemma intervals_cif : forall a b c (F : A -> A),
  map F (intervals (cif a b c)) =  match a with
                          | Ret _ => map F (intervals b) ++ map F (intervals c)
                            | Cif _ x y => map F (intervals (cif x b c)) ++
                                           map F (intervals (cif y b c))
                             end.
   destruct a; simpl. intros. apply map_app.
   intros. apply map_app.
 Qed. *)

 (*Lemma intervals_cif : forall a b c,
   intervals (cif a b c) =  match a with
                            | Ret _ => intervals b ++intervals c
                            | Cif _ x y => intervals (cif x b c) ++
                                           intervals (cif y b c)
                             end.
 Proof.
   induction a; simpl; trivial.
 Qed. *)

 Fixpoint break_points i :=
   match i with
   | Cif a l r => break_points l ++ (a :: break_points r)
   | _  => nil
   end.

 Lemma int_bps_len1 :
     forall l, (length (intervals l) = 1 + length (break_points l))%nat.
  Proof.
    induction l; simpl;  try auto with arith.
    rewrite (app_length (intervals l1) (intervals l2));
    rewrite (app_length (break_points l1) (a:: break_points l2)). simpl.
    replace (length (break_points l1) + S (length (break_points l2)))%nat with
    (S (length (break_points l1) +  (length (break_points l2))))%nat;
    try auto with arith;  omega.
  Qed.

(* Lemma int_bps_len :
     forall l, (length (break_points l) < length (intervals l))%nat.
  Proof.
    induction l; simpl; try auto with arith.
    rewrite (app_length (break_points l1) (a:: break_points l2));
    rewrite (app_length (intervals l1) (intervals l2)); simpl.
    replace (length (break_points l1) + S (length (break_points l2)))%nat with
    (S (length (break_points l1) +  (length (break_points l2))))%nat;
    try auto with arith; omega.
  Qed. *)

 Variable a0 : A.

  Fixpoint seq bps inv   :=
   match bps, inv with
   | nil,   x::xs => Ret x
   | y::ys, x::xs => Cif y  (Ret x) (seq ys xs)
   | _ , _        =>   Ret a0
   end.

  Definition norm l := seq  (break_points l) (intervals l).

  Lemma intv_seq : forall l1 l2, length l2 = (1 + length l1)%nat  ->
    intervals (seq l1 l2) = l2.
    induction l1; simpl. intros. destruct l2. simpl in H; discriminate H.
    destruct l2; simpl in *; trivial. discriminate H.
    intros. destruct l2; simpl in *. discriminate H.
    injection H. intros.  pattern l2 at 2.
    rewrite <- (IHl1 l2 H0); trivial.
  Qed.

   Lemma bps_seq : forall l1 l2, length l2 = (1 + length l1)%nat  ->
    break_points (seq l1 l2) = l1.
    induction l1; simpl. intros l2 H; destruct l2.
    simpl in H; discriminate H. trivial.
    destruct l2; simpl in *.  intro H; discriminate H.
     intros H;  injection H. intro H0;  pattern l1 at 2;
    rewrite <- (IHl1 l2 H0); trivial.
  Qed.

  Lemma nf_intv : forall l, (intervals l) = (intervals (norm l)).
  Proof.
    unfold norm;  intro l;
    rewrite (intv_seq (break_points l) (intervals l) (int_bps_len1 l));
    trivial.
  Qed.

  Lemma nf_bps : forall l, (break_points l) = (break_points (norm l)).
  Proof.
    unfold norm;  intro l;
    rewrite (bps_seq (break_points l) (intervals l) (int_bps_len1 l));
    trivial.
  Qed.

 (* nf is a "normal" form *)
 Lemma nf_nf_idem : forall l, norm (norm l) = norm l.
  unfold norm at 1. intro l;
   rewrite <- (nf_bps l); rewrite <- (nf_intv l);
   unfold norm; trivial.
 Qed.

 (* Equating lists of A *)
  Inductive EQL : list A -> list A -> Set :=
  | eq_nil  : EQL nil nil
  | eq_cons : forall l r ls rs, Aeq l r = true -> EQL ls rs ->
                    EQL (l :: ls)  (r :: rs).
  (*| eq_app  : forall l l1 r r1, EQL l l1 -> EQL r r1 ->
   EQL (l ++ r) (l1 ++ r1). *)

 Fixpoint ListEq  i j :=
  match i, j with
  | nil, nil => true
  | x :: xs, y :: ys => if Aeq x y then ListEq xs ys else false
  | _ , _ => false
  end.

 Lemma ListEq_len : forall l l1, ListEq l l1 = true -> length l = length l1.
 Proof.
  induction l; destruct l1; simpl; try (intro h; discriminate h); auto.
  destruct (bool_dec ( Aeq a a1)). rewrite e.
  intro h; rewrite (IHl  _ h); trivial.
  rewrite e; intro h; discriminate h.
 Qed.

 Lemma listEq_EQL : forall l l1, ListEq l l1 = true -> EQL l l1.
 Proof.
  induction l; destruct l1; simpl; try (intro h; discriminate h).
  exact (fun _ => eq_nil).
  destruct (bool_dec (Aeq a a1)). rewrite e.
  intro h; exact (eq_cons e (IHl _ h)).
  rewrite e; intro h; discriminate h.
 Qed.

 Lemma intv_not_nill : forall l, intervals l <> nil.
  induction l; simpl; auto. discriminate.
  intuition. case (IHl1 (proj1 (app_eq_nil (intervals l1)  (intervals l2) H))).
 Qed.

 (* Lemma ListEq_append : forall l l1 r r1, ListEq (l ++ r) (l1 ++ r1) = true ->
   ListEq l l1 = true /\ ListEq r r1 = true.
 Proof.
   induction l; destruct l1; simpl; auto. simpl. *)

   (* cnd to piecewise *)
  Fixpoint cnd2P (i : Cond ) :=
    match i with
   | Ret a => lp a
   | Cif c l r => pf (lp c) (cnd2P l) (cnd2P r)
   end.

   Lemma cnd2P_ok : forall i, pNrm' (cnd2P i) = i.
      induction i; simpl; auto.
      rewrite IHi1; rewrite IHi2; trivial.
   Qed.

 (* Definition pNRm p :=  cnd2P (flatten (pNrm' p)).
  Definition pNrm p :=  (flatten (pNrm' p)).
  Definition PEq i j := CndEq (pNrm i) (pNrm j). *)

  (* cif is associative *)
  Lemma ciflemm (a b c x y : Cond) :
    cif (cif a b c) x y = cif a (cif b x y) (cif c x y).
  Proof.
   induction a; simpl; auto.
   intros b c x y;
   rewrite (IHa1 b c x y);
   rewrite (IHa2 b c x y); trivial.
  Qed.

 Section Normalization.

   Inductive ST : Set :=
    | sl   : A -> ST
    | sf : A -> A -> ST -> ST.

   Fixpoint STeq i j :=
     match i, j with
     | sl a, sl b => Aeq a b
     | sf c a x, sf c1 a1 y => if (Aeq c c1) then (Aeq a a1) && (STeq x y) else false
     | _ , _ => false
     end.

  Fixpoint flatn_aux a (b c : ST) : ST :=
    match b with
    | sl x => sf a x c
    | sf x l r => sf x l (flatn_aux a r c)
    end.

  Fixpoint flatn (i : Cond ) : ST  :=
    match i with
    | Ret a => sl a
    | Cif a l r => flatn_aux a (flatn l) (flatn r)
    end.

 End Normalization.

 End TreeS. *)


(* This file contains the definition of the relation \succ from the
   paper (t \succ q holds if *all* erasures of t are identical with q)
   and the formalisation of its basic properties *)

Require Import general.
Require Import list_facts.
Require Import iterms.
Require Import lterms.

(* `Erasure t q' holds if *all* erasures of t are identical with q *)
Inductive Erasure : lterm -> iterm -> Prop :=
| erasure_itm : forall x, Erasure (itm x) x
| erasure_c1 : Erasure C1 C
| erasure_c2 : Erasure C2 C
| erasure_t1 : Erasure T1 T
| erasure_f1 : Erasure F1 F
| erasure_i1 : Erasure I1 I
| erasure_k1 : Erasure K1 K
| erasure_s1 : forall l, Erasure (S1 l) Si
| erasure_s2 : forall n, Erasure (S2 n) Si
| erasure_lapp : forall x y x' y', Erasure x x' -> Erasure y y' -> Erasure (x @l y) (x' @i y')
| erasure_ltup : forall x y l z, Erasure x z -> Erasure y z -> (forall u, In u l -> Erasure u z) ->
                                 Erasure (ltup x y l) z.

Ltac pose_erasure := pose erasure_itm; pose erasure_c1; pose erasure_c2; pose erasure_t1;
                     pose erasure_f1; pose erasure_k1; pose erasure_s1; pose erasure_lapp;
                     pose erasure_ltup.
Ltac erasure_tac n := pose_erasure; yauto n.

Ltac invert_erasure :=
  repeat match goal with
         | [ H : Erasure C1 _ |- _ ] => yinversion H
         | [ H : Erasure C2 _ |- _ ] => yinversion H
         | [ H : Erasure T1 _ |- _ ] => yinversion H
         | [ H : Erasure F1 _ |- _ ] => yinversion H
         | [ H : Erasure K1 _ |- _ ] => yinversion H
         | [ H : Erasure (S1 _) _ |- _ ] => yinversion H
         | [ H : Erasure (S2 _) _ |- _ ] => yinversion H
         | [ H : Erasure (_ @l _) _ |- _ ] => yinversion H
         | [ H : Erasure (ltup _ _ _) _ |- _ ] => yinversion H
         end.

Ltac invert_sterm_erasure n :=
  lazymatch n with
  | 0 => yisolve
  | S ?k =>
    try match goal with
        | [ H1 : Sterm (?t @l _), H2 : Erasure ?t _ |- _ ] =>
          assert (Sterm t) by iauto 1;
          yinversion H2; try iauto 1
        end;
    invert_sterm_erasure k
  end.

Lemma lem_erasure_leftmost : forall t q, Erasure t q -> q = erase t.
Proof.
  induction t; try yelles 1.
  intros q H; yinversion H; ycrush.
Qed.

Lemma lem_erasure_eqv : forall t t' q q', Erasure t q -> Erasure t' q' -> ErasedEqv t t' ->
                                          Eqv_clc0 q q'.
Proof.
  unfold ErasedEqv; intros; pose lem_erasure_leftmost; pose lem_eqv_clc_to_eqv_clc0; ycrush.
Qed.

Lemma lem_erasure_lterm_of_tuple :
  forall l y, is_nonempty l -> (forall x, In x l -> Erasure x y) -> Erasure (lterm_of_tuple l) y.
Proof.
  induction l.
  ycrush.
  intros; simpl in *.
  ydestruct l.
  ycrush.
  pose_erasure; ycrush.
Qed.

Lemma lem_erasure_lterm_of_tuple_inv :
  forall l y, Erasure (lterm_of_tuple l) y -> (forall x, In x l -> Erasure x y).
Proof.
  induction l.
  ycrush.
  ydestruct l; ycrush.
Qed.

Lemma lem_erasure_glue_iterms : forall x1 x2 q1 q2, Erasure x1 q1 -> Erasure x2 q2 ->
                                                    Erasure (glue_iterms x1 x2) (q1 @i q2).
Proof.
  destruct x1, x2; try solve [ pose_erasure; yelles 1 ].
  ycrush.
Qed.

Lemma lem_erasure_build_ys :
  forall ys zs y z, (forall x, In x ys -> Erasure x y) ->
                    (forall l, In l zs -> is_nonempty l) ->
                    (forall x l, In l zs -> In x l -> Erasure x z) ->
                    forall x, In x (build_ys ys zs) -> Erasure x (y @i z).
Proof.
  induction ys.
  ycrush.
  intros; simpl in *.
  ydestruct zs.
  ycrush.
  simpl in *.
  ydestruct H2.
  subst.
  assert (Erasure (lterm_of_tuple l) z).
  pose lem_erasure_lterm_of_tuple; pose_erasure; yelles 2.
  apply lem_erasure_glue_iterms; pose_erasure; ycrush.
  pose_erasure; ycrush.
Qed.

Lemma lem_s_result_erasure :
  forall ns x ys zs x' y' z', is_nonempty ys ->
    is_nonempty ns -> (forall n, In n ns -> n > 0) -> (lst_sum ns < length zs) ->
    Erasure x x' -> (forall y, In y ys -> Erasure y y') -> (forall z, In z zs -> Erasure z z') ->
    Erasure (build_s_result ns x ys zs) (x' @i z' @i (y' @i z')).
Proof.
  unfold build_s_result.
  intros.
  ydestruct ns.
  ycrush.
  pose (lem_split_result n ns zs).
  simp_hyps.
  assert (forall x y, In y (x0 :: x1 :: x2) -> In x y -> In x zs).
  pose (lem_split_preserves_elements (n :: ns) zs).
  rewrite H6 in *; eauto.
  assert (forall x, In x x0 -> In x zs) by ycrush.
  assert (forall x y, In x y -> In y (x1 :: x2) -> In x zs) by ycrush.
  rewrite H6 in *.
  assert (is_nonempty x0).
  pose (lem_split_nonempty (n :: ns) zs).
  rewrite H6 in *; ycrush.
  assert (forall (x : lterm) (l : list lterm), In l (x1 :: x2) -> In x l -> Erasure x z') by ycrush.
  assert (forall l : list lterm, In l (x1 :: x2) -> is_nonempty l).
  pose (lem_split_nonempty (n :: ns) zs).
  rewrite H6 in *; ycrush.
  assert (forall x : lterm, In x (build_ys ys (x1 :: x2)) -> Erasure x (y' @i z')).
  pose (lem_erasure_build_ys ys (x1 :: x2) y' z'); ycrush.
  assert (Erasure (lterm_of_tuple x0) z').
  pose (lem_erasure_lterm_of_tuple x0); ycrush.
  assert (is_nonempty (build_ys ys (x1 :: x2))).
  ydestruct ys; ycrush.
  assert (Erasure (lterm_of_tuple (build_ys ys (x1 :: x2))) (y' @i z')).
  pose (lem_erasure_lterm_of_tuple (build_ys ys (x1 :: x2)) (y' @i z')); ycrush.
  pose_erasure; ycrush.
Qed.

Lemma lem_s2_result_erasure :
  forall n x y zs x' y' z',
    n > 0 -> n < length zs ->
    Erasure x x' -> Erasure y y' -> (forall z, In z zs -> Erasure z z') ->
    Erasure
      (x @l lterm_of_tuple (firstn n zs) @l
         glue_iterms y (lterm_of_tuple (skipn n zs)))
      (x' @i z' @i (y' @i z')).
Proof.
  intros.
  assert (is_nonempty (firstn n zs)) by ycrush.
  assert (is_nonempty (skipn n zs)).
  pose (lem_skipn_nonempty n zs); ycrush.
  assert (Erasure (lterm_of_tuple (firstn n zs)) z').
  pose (lem_firstn_preserves_elements n zs).
  pose (lem_erasure_lterm_of_tuple (firstn n zs) z').
  ycrush.
  assert (Erasure (lterm_of_tuple (skipn n zs)) z').
  pose (lem_skipn_preserves_elements n zs).
  pose (lem_erasure_lterm_of_tuple (skipn n zs) z').
  ycrush.
  pose lem_erasure_glue_iterms; pose_erasure; ycrush.
Qed.

Lemma lem_erasure_equal : forall x q, Erasure x q -> All_pairs (tuple_of_lterm x) ErasedEqv.
Proof.
  unfold All_pairs, ErasedEqv.
  intros.
  ydestruct x.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  ycrush.
  yinversion H; yintuition; pose lem_erasure_leftmost; ycrush.
Qed.

Lemma lem_erasure_tuple : forall x q, Erasure x q ->
                                      (forall y : lterm, In y (tuple_of_lterm x) ->
                                                         Erasure y q).
Proof.
  destruct x; ycrush.
Qed.

Lemma lem_all_pairs_erasure : forall l q, (forall x, In x l -> Erasure x q) ->
                                          All_pairs l ErasedEqv.
Proof.
  induction l.
  ycrush.
  unfold All_pairs in *; simpl.
  unfold ErasedEqv in *.
  yintros.
  assert (Erasure x q) by ycrush.
  assert (Erasure y q) by ycrush.
  assert (q = erase x).
  pose lem_erasure_leftmost; ycrush.
  assert (q = erase y).
  pose lem_erasure_leftmost; ycrush.
  ycrush.
Qed.


Require Import List.
Require Import Setoid.
Require Import PeanoNat.
Require Import Coq.omega.Omega.
Require Import Matrix.
Require Import Coq.setoid_ring.Ring.
Require Import Coq.setoid_ring.Ring_theory.
Require Import SparseMatrix.
Require Import DenseMatrix.

Section A.
Variable E: MatrixElem.
Definition M:= (@DenseMatrix E).
(* Definition M':= (@SparseMatrix E). *)
(* Axiom transposeM: forall {n}, @Mt _  M n n -> @Mt _ M n n. *)
(* Axiom transposeM': forall {n}, @Mt _  M' n n -> @Mt _ M' n n. *)

Existing Instance M.

Axiom transpose : forall {n}, Mt n n -> Mt n n.
Axiom Mplus : forall {n}, Mt n n -> Mt n n -> Mt n n.
Infix "@+" := Mplus (at level 50, left associativity) : matrix_scope.
Axiom Mminus : forall {n}, Mt n n -> Mt n n -> Mt n n.
Infix "@-" := Mminus (at level 50, left associativity) : matrix_scope.
Axiom Vt: nat -> Type.
Axiom MVtimes : forall {n m}, Mt m n -> Vt n -> Vt m.
Axiom inversion : forall {n}, Mt n n -> Mt n n.
Infix "&*" := MVtimes (at level 40, left associativity) : matrix_scope.
Axiom Vplus : forall {n}, Vt n -> Vt n -> Vt n.
Infix "&+" := Vplus (at level 50, left associativity) : matrix_scope.
Axiom Vminus : forall {n}, Vt n -> Vt n -> Vt n.
Infix "&-" := Vminus (at level 50, left associativity) : matrix_scope.
Axiom Id : forall {n}, Mt n n.
Axiom sparsify: forall {n}, Mt n n -> Mt n n.
Axiom sparsify_correct: forall n: nat, forall M : Mt n n, M @= sparsify M.
Axiom densify: forall {n}, Mt n n -> Mt n n.
Axiom densify_correct: forall n: nat, forall M : Mt n n, M @= densify M.
Axiom dense_sparse_correct: forall n : nat, forall M1 M2 : Mt n n,
      M1 @* M2 = densify(M1 @* sparsify M2).
Axiom solveR: forall {n}, Mt n n -> Mt n n -> Mt n n.
Axiom solveR_correct: forall n: nat, forall M1 M2: Mt n n,
      M1 @* (inversion M2) = solveR M2 M1.
Axiom multi_assoc: forall n: nat, forall M1 M2 M3 : Mt n n,
      (M1 @* M2) @* M3 = M1 @* (M2 @* M3).
Record priori {n: nat} :=
  {
    x_pr : Vt n;
    p_pr : Mt n n;
  }.
Record posteriori {n: nat} :=
  {
    x_po : Vt n;
    p_po : Mt n n;
  }.

Definition similar {n: nat} {p1 p2 : @posteriori n} :=
  p1.(x_po) = p2.(x_po) /\ p1.(p_po) @= p2.(p_po).
Infix "$=" := similar (at level 70) : matrix_scope.

Definition update_posteriori_to_priori n (f: posteriori) (F B Q: Mt n n) (u: Vt n) :=
  let x' := F &* f.(x_po) &+ B &* u in
  let p' := F @* f.(p_po) @* (transpose F) @+ Q in
  {| x_pr := x'; p_pr := p' |}.
Definition update_priori_to_posteriori n (f: priori) (H R: Mt n n) (z: Vt n) :=
  let y' := z &- H &* f.(x_pr) in
  let S' := H @* f.(p_pr) @* transpose(H) @+ R in
  let K' := f.(p_pr) @* transpose(H) @* inversion(S') in
  let x' := f.(x_pr) &+ K' &* y' in
  let p' := (Id @- K' @* H) @* f.(p_pr) in
  {| x_po := x'; p_po := p' |}.

Theorem Optimizer1: {f': _ & forall n f H R z, f' n f H R z = update_priori_to_posteriori n f H R z}.
Proof.
  intros.
  econstructor.
  intros.
  destruct f.
  cbv delta [update_priori_to_posteriori].
  cbv beta.
  simpl p_pr. simpl x_pr.
  rewrite dense_sparse_correct.
  change ((let y' := z &- H &* x_pr0 in
   let S' := densify (H @* p_pr0 @* sparsify (transpose H)) @+ R in
   let K' := p_pr0 @* transpose H @* inversion S' in
   let x' := x_pr0 &+ K' &* y' in
   let p' := (Id @- K' @* H) @* p_pr0 in {| x_po := x'; p_po := p' |})) with ((let y' := z &- H &* x_pr0 in
   let K' := p_pr0 @* transpose H @* inversion ( densify (H @* p_pr0 @* sparsify (transpose H)) @+ R) in
   let x' := x_pr0 &+ K' &* y' in
   let p' := (Id @- K' @* H) @* p_pr0 in {| x_po := x'; p_po := p' |})).
  replace (p_pr0 @* transpose H @*
                 inversion (densify (H @* p_pr0 @* sparsify (transpose H)) @+ R))
          with (p_pr0 @* (transpose H @*
                                    inversion (densify (H @* p_pr0 @* sparsify (transpose H)) @+ R))) by (rewrite <- multi_assoc at 1; reflexivity).
  rewrite solveR_correct.
  replace (let y' := z &- H &* x_pr0 in
   let K' :=
     p_pr0 @*
     solveR (densify (H @* p_pr0 @* sparsify (transpose H)) @+ R) (transpose H) in
   let x' := x_pr0 &+ K' &* y' in
   let p' := (Id @- K' @* H) @* p_pr0 in {| x_po := x'; p_po := p' |})
          with (
   let K' :=
     p_pr0 @*
     solveR (densify (H @* p_pr0 @* sparsify (transpose H)) @+ R) (transpose H) in
   let x' := x_pr0 &+ K' &* (z &- H &* x_pr0) in
   let p' := (Id @- K' @* H) @* p_pr0 in {| x_po := x'; p_po := p' |}) by (auto).
  reflexivity.
Defined.

Variable n: nat.
Variable f: @ posteriori n.
Variable F B Q: Mt n n.
Variable u: Vt n.
Compute projT1 (Optimizer1 n f F B Q u).

Record YC_data {n: nat} :=
  { X: Mt n n;
    Y: Mt n n;
  }.

Definition update n (f: YC_data) (A: Mt n n) :=
  let X' := A @* f.(X) @+ f.(Y) in
  let Z' := X' @* X' in
  let Y' := f.(Y) @* (transpose Z') in
  {| X := X'; Y := Y'|}.

Print sigT.
Print ex.
Theorem Optimizer: forall n f A, {f': _ & f' = update n f A}.
Proof.
  intros.
  destruct f.
  econstructor.
  cbv delta [update].
  cbv beta.
  cbv beta delta [X].
  reflexivity.
Defined.

Variable f1: @YC_data n.
Variable A: Mt n n.
Compute projT1 (Optimizer n f1 A).
Print projT1.

Record YC_data {n: nat} := {
  X: Mt n n;
  Y: Mt n n;
}.

Axiom transpose : forall {n}, Mt n n -> Mt n n.
Axiom Mplus : forall {n}, Mt n n -> Mt n n -> Mt n n.
Infix "@+" := Mplus (at level 50, left associativity) : matrix_scope.

Definition update n (f: YC_data) (A: Mt n n) :=
  let X' := A @* f.(X) @+ f.(Y) in
  let Z' := X' @* X' in
  let Y' := f.(Y) @* (transpose Z') in
  {| X := X'; Y := Y'|}.

Print sigT.
Print ex.
Theorem Optimizer: forall n f A, {f': _ & f' = update n f A}.
Proof.
  intros.
  destruct f.
  econstructor.
  cbv delta [update].
  cbv beta.
  cbv beta delta [X].

Defined.

Variable n: nat.
Variable f: @YC_data n.
Compute projT1 (Optimizer n f).
Print projT1.

Search beq_nat.


Set Implicit Arguments.
Require Import Morphisms Setoid.
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU.calculus Require Import prelim terms semantics.
Import ArsInstances.
(* * Confluence *)
Section Confluence.

  Context {X: Const}.

  Reserved Notation "s ≫ t" (at level 60).

  Inductive par : exp X -> exp X -> Prop :=
  | parVar x: var x ≫ var x
  | parConst c: const c ≫ const c
  | parLam s s': s ≫ s' -> (lambda s) ≫ lambda s'
  | parBeta s s' t t' u: s ≫ s' -> t ≫ t' -> u = beta s' t' -> (lambda s) t ≫ u
  | parApp s s' t t': s ≫ s' -> t ≫ t' -> s t ≫ s' t'
  where "s ≫ t" := (par s t).

  Hint Constructors par : core.

  Lemma refl_par: forall s, s ≫ s.
  Proof. induction s; auto. Qed.

  Hint Immediate refl_par : core.

  #[export] Instance refl_par_inst: Reflexive par.
  Proof.
    intros ?; eapply refl_par.
  Qed.

  Lemma ren_compatible_par s s' delta:
    s ≫ s' -> ren delta s ≫ ren delta s'.
  Proof.
    induction 1 in delta |-*; cbn; auto; subst.
    econstructor; auto. now asimpl.
  Qed.

  Lemma subst_compatible_par s s' sigma sigma':
    s ≫ s' -> (forall x, sigma x ≫ sigma' x) -> (sigma • s) ≫ (sigma'• s').
  Proof.
    induction 1 in sigma, sigma' |-*; cbn; trivial.
    - intros; econstructor; eapply IHpar.
      intros []; cbn; eauto using ren_compatible_par.
    - intros; econstructor.
      eapply IHpar1 with (sigma' := up sigma'); auto.
      intros []; cbn; eauto using ren_compatible_par.
      eapply IHpar2; auto.
      subst; now asimpl.
    - auto.
  Qed.

  #[export] Instance par_lam_proper: Proper (star par ++> star par) lam.
  Proof.
    intros s s' H; induction H; eauto.
  Qed.

  #[export] Instance par_app_proper: Proper (star par ++> star par ++> star par) app.
  Proof.
    intros s s' H; induction H; intros t t' H'; induction H'; eauto.
  Qed.

  #[export] Instance sandwich_step: subrelation step par.
  Proof.
    intros ??; induction 1; eauto.
  Qed.

  #[export] Instance sandwich_steps: subrelation par (star step).
  Proof.
    intros ??; induction 1; trivial.
    - rewrite IHpar; auto.
    - rewrite IHpar1, IHpar2, stepBeta; auto.
    - rewrite IHpar1, IHpar2; auto.
  Qed.

  Fixpoint rho (e: exp X) :=
    match e with
    | var x => var x
    | const c => const c
    | lambda s => lambda (rho s)
    | app (lambda s) t => beta (rho s) (rho t)
    | app s t => (rho s) (rho t)
    end.

  Lemma tak_fun_rho: tak_fun par rho.
  Proof.
    intros s t H; induction H; cbn; trivial.
    - auto.
    - subst u; eapply subst_compatible_par; auto.
      intros []; cbn; auto.
    - destruct s; auto.
      inv H; inv IHpar1.
      econstructor; eauto.
  Qed.

  Lemma confluence_step: confluent (@step X).
  Proof.
    eapply TMT.
    eapply sandwich_step. eapply sandwich_steps.
    typeclasses eauto.
    eapply tak_fun_rho.
  Qed.

End Confluence.

Notation "s ≫ t" := (par s t) (at level 60).
#[export] Hint Resolve confluence_step tak_fun_rho : core.


From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype div.
From pcm Require Import axioms pred pcm heap.
From htt Require Import options model heapauto.

(* classical mutable Euclid's algorithm for computing GCD with subtractions *)

(* two memory cells holding intermediate values *)
Definition shape (p q : ptr) (x y : nat) :=
  [Pred h | exists h', h = p :-> x \+ (q :-> y \+ h')].

(* GCD loop invariant: at the end both cells contain the answer *)
(* (`unit` is needed because `Fix` always requires a single parameter) *)
Definition gcd_loopT (p q : ptr) : Type :=
  unit ->
  {x y : nat}, STsep (shape p q x y,
                     [vfun (_ : unit) h =>
                        h \In shape p q (gcdn x y) (gcdn x y)]).

Program Definition gcd_loop (p q : ptr) :=
  Fix (fun (go : gcd_loopT p q) _ =>
    Do (x <-- !p;
        y <-- !q;
        if (x : nat) != y then
          if x < y then q ::= y - x;;
                        go tt
                   else p ::= x - y;;
                        go tt
        else skip)).
Next Obligation.
(* pull out ghosts + precondition (the shape of the heap) *)
move=>p q go _ [x [y _]] /= _ [h' ->].
(* read the numbers, do a 3-way comparison, run one more step in each branch *)
do 2!step; case: ltngtP=>/= [H|H|->]; step; last first.
- (* x=y, the program is finished because GCD(y,y) = y *)
  by move=>_; rewrite gcdnn; vauto.
- (* y<x, do the recursive call, deconstruct the shape *)
  apply: [gE (x-y), y]=>//=; first by eauto.
  move=>{h'} _ _ [m ->] _; exists m.
  (* use the difference property of GCD *)
  suff {p q go m}: gcdn (x - y) y = gcdn x y by move=>->.
  (* mathcomp's GCD theory uses addition, so we do a bit of arithmetical reasoning *)
  by rewrite gcdnC -gcdnDr gcdnC subnK //; apply: ltnW.
(* x<y, symmetrical case to above *)
apply: [gE x, (y-x)]=>//=; first by eauto.
move=>{h'}_ _ [m ->] _; exists m.
suff {p q go m}: gcdn x (y - x) = gcdn x y by move=>->.
by rewrite -gcdnDr subnK //; apply: ltnW.
Qed.

(* note that there's no guarantee on termination, so we have only partial correctness *)
(* i.e. the algorithm will get stuck if u = 0 /\ v != 0 or vice versa *)
Program Definition gcd u v :
  STsep (PredT, [vfun r _ => r = gcdn u v]) :=
  (* we allocate in the reverse order because the symbolic heap behaves as a stack *)
  (* this way it'll match the specification perfectly, removing a bit of bureaucracy *)
  Do (q <-- alloc v;
      p <-- alloc u;
      gcd_loop p q tt;;
      x <-- !p;
      dealloc p;;
      dealloc q;;
      ret x).
Next Obligation.
(* simplify *)
move=>u v _ m /= _.
(* initialize the two cells, run the loop, deconstruct the shape *)
step=>q; step=>p; apply: [stepE u, v]=>//=; first by eauto.
move=>_ _ [h' ->].
(* run the rest of the program *)
by do 4!step; rewrite !unitL.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defoppositeside_1 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_2 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable axiom_betweennesssymmetry_10 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_collinear4_11 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearorder_12 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_betweennotequal_13 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_14 : (forall A B : Universe, (A <> B -> B <> A)).

Theorem lemma_oppositesidesymmetric_15 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import fintype bigop finset prime fingroup morphism.
Require Import gfunctor automorphism quotient action gproduct cyclic.

(******************************************************************************)
(* Standard group notions and constructions based on the prime decomposition  *)
(* of the order of the group or its elements:                                 *)
(*        pi.-group G <=> G is a pi-group, i.e., pi.-nat #|G|.                *)
(*    -> Recall that here and in the sequel pi can be a single prime p.       *)
(*  pi.-subgroup(H) G <=> H is a pi-subgroup of G.                            *)
(*                     := (H \subset G) && pi.-group H.                       *)
(*    -> This is provided mostly as a shorhand, with few associated lemmas.   *)
(*       However, we do establish some results on maximal pi-subgroups.       *)
(*          pi.-elt x <=> x is a pi-element.                                  *)
(*                     := pi.-nat #[x] or pi.-group <[x]>.                    *)
(*             x.`_pi == the pi-constituent of x: the (unique) pi-element     *)
(*                       y \in <[x]> such that x * y^-1 is a pi'-element.     *)
(*      pi.-Hall(G) H <=> H is a Hall pi-subgroup of G.                       *)
(*                    := [&& H \subset G, pi.-group H & pi^'.-nat #|G : H|].  *)
(*    -> This is also eqivalent to H \subset G /\ #|H| = #|G|`_pi.            *)
(*      p.-Sylow(G) P <=> P is a Sylow p-subgroup of G.                       *)
(*    -> This is the display and preferred input notation for p.-Hall(G) P.   *)
(*          'Syl_p(G) == the set of the p-Sylow subgroups of G.               *)
(*                    := [set P : {group _} | p.-Sylow(G) P].                 *)
(*          p_group P <=> P is a p-group for some prime p.                    *)
(*           Hall G H <=> H is a Hall pi-subgroup of G for some pi.           *)
(*                    := coprime #|H| #|G : H| && (H \subset G).              *)
(*          Sylow G P <=> P is a Sylow p-subgroup of G for some p.            *)
(*                    := p_group P && Hall G P.                               *)
(*           'O_pi(G) == the pi-core (largest normal pi-subgroup) of G.       *)
(*   pcore_mod pi G H == the pi-core of G mod H.                              *)
(*                    := G :&: (coset H @*^-1 'O_pi(G / H)).                  *)
(*   'O_{pi2, pi1}(G) == the pi1,pi2-core of G.                               *)
(*                    := the pi1-core of G mod 'O_pi2(G).                     *)
(*     -> We have 'O_{pi2, pi1}(G) / 'O_pi2(G) = 'O_pi1(G / 'O_pi2(G))        *)
(*        with 'O_pi2(G) <| 'O_{pi2, pi1}(G) <| G.                            *)
(* 'O_{pn, ..., p1}(G) == the p1, ..., pn-core of G.                          *)
(*                    := the p1-core of G mod 'O_{pn, ..., p2}(G).            *)
(* Note that notions are always defined on sets even though their name        *)
(* indicates "group" properties; the actual definition of the notion never    *)
(* tests for the group property, since this property will always be provided  *)
(* by a (canonical) group structure. Similarly, p-group properties assume     *)
(* without test that p is a prime.                                            *)
(******************************************************************************)

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

Import GroupScope.

Section PgroupDefs.

(* We defer the definition of the functors ('0_p(G), etc) because they need *)
(* to quantify over the finGroupType explicitly.                            *)

Variable gT : finGroupType.
Implicit Type (x : gT) (A B : {set gT}) (pi : nat_pred) (p n : nat).

Definition pgroup pi A := pi.-nat #|A|.

Definition psubgroup pi A B := (B \subset A) && pgroup pi B.

Definition p_group A := pgroup (pdiv #|A|) A.

Definition p_elt pi x := pi.-nat #[x].

Definition constt x pi := x ^+ (chinese #[x]`_pi #[x]`_pi^' 1 0).

Definition Hall A B := (B \subset A) && coprime #|B| #|A : B|.

Definition pHall pi A B := [&& B \subset A, pgroup pi B & pi^'.-nat #|A : B|].

Definition Syl p A := [set P : {group gT} | pHall p A P].

Definition Sylow A B := p_group B && Hall A B.

End PgroupDefs.

Arguments Scope pgroup [_ nat_scope group_scope].
Arguments Scope psubgroup [_ nat_scope group_scope group_scope].
Arguments Scope p_group [_ group_scope].
Arguments Scope p_elt [_ nat_scope].
Arguments Scope constt [_ group_scope nat_scope].
Arguments Scope Hall [_ group_scope group_scope].
Arguments Scope pHall [_ nat_scope group_scope group_scope].
Arguments Scope Syl [_ nat_scope group_scope].
Arguments Scope Sylow [_ group_scope group_scope].
Prenex Implicits p_group Hall Sylow.

Notation "pi .-group" := (pgroup pi)
  (at level 2, format "pi .-group") : group_scope.

Notation "pi .-subgroup ( A )" := (psubgroup pi A)
  (at level 8, format "pi .-subgroup ( A )") : group_scope.

Notation "pi .-elt" := (p_elt pi)
  (at level 2, format "pi .-elt") : group_scope.

Notation "x .`_ pi" := (constt x pi)
  (at level 3, format "x .`_ pi") : group_scope.

Notation "pi .-Hall ( G )" := (pHall pi G)
  (at level 8, format "pi .-Hall ( G )") : group_scope.

Notation "p .-Sylow ( G )" := (nat_pred_of_nat p).-Hall(G)
  (at level 8, format "p .-Sylow ( G )") : group_scope.

Notation "''Syl_' p ( G )" := (Syl p G)
  (at level 8, p at level 2, format "''Syl_' p ( G )") : group_scope.

Section PgroupProps.

Variable gT : finGroupType.
Implicit Types (pi rho : nat_pred) (p : nat).
Implicit Types (x y z : gT) (A B C D : {set gT}) (G H K P Q R : {group gT}).

Lemma trivgVpdiv G : G :=: 1 \/ (exists2 p, prime p & p %| #|G|).
Proof.
have [leG1|lt1G] := leqP #|G| 1; first by left; exact: card_le1_trivg.
by right; exists (pdiv #|G|); rewrite ?pdiv_dvd ?pdiv_prime.
Qed.

Lemma prime_subgroupVti G H : prime #|G| -> G \subset H \/ H :&: G = 1.
Proof.
move=> prG; have [|[p p_pr pG]] := trivgVpdiv (H :&: G); first by right.
left; rewrite (sameP setIidPr eqP) eqEcard subsetIr.
suffices <-: p = #|G| by rewrite dvdn_leq ?cardG_gt0.
by apply/eqP; rewrite -dvdn_prime2 // -(LagrangeI G H) setIC dvdn_mulr.
Qed.

Lemma pgroupE pi A : pi.-group A = pi.-nat #|A|. Proof. by []. Qed.

Lemma sub_pgroup pi rho A : {subset pi <= rho} -> pi.-group A -> rho.-group A.
Proof. by move=> pi_sub_rho; exact: sub_in_pnat (in1W pi_sub_rho). Qed.

Lemma eq_pgroup pi rho A : pi =i rho -> pi.-group A = rho.-group A.
Proof. exact: eq_pnat. Qed.

Lemma eq_p'group pi rho A : pi =i rho -> pi^'.-group A = rho^'.-group A.
Proof. by move/eq_negn; exact: eq_pnat. Qed.

Lemma pgroupNK pi A : pi^'^'.-group A = pi.-group A.
Proof. exact: pnatNK. Qed.

Lemma pi_pgroup p pi A : p.-group A -> p \in pi -> pi.-group A.
Proof. exact: pi_pnat. Qed.

Lemma pi_p'group p pi A : pi.-group A -> p \in pi^' -> p^'.-group A.
Proof. exact: pi_p'nat. Qed.

Lemma pi'_p'group p pi A : pi^'.-group A -> p \in pi -> p^'.-group A.
Proof. exact: pi'_p'nat. Qed.

Lemma p'groupEpi p G : p^'.-group G = (p \notin \pi(G)).
Proof. exact: p'natEpi (cardG_gt0 G). Qed.

Lemma pgroup_pi G : \pi(G).-group G.
Proof. by rewrite /=; exact: pnat_pi. Qed.

Lemma partG_eq1 pi G : (#|G|`_pi == 1%N) = pi^'.-group G.
Proof. exact: partn_eq1 (cardG_gt0 G). Qed.

Lemma pgroupP pi G :
  reflect (forall p, prime p -> p %| #|G| -> p \in pi) (pi.-group G).
Proof. exact: pnatP. Qed.
Implicit Arguments pgroupP [pi G].

Lemma pgroup1 pi : pi.-group [1 gT].
Proof. by rewrite /pgroup cards1. Qed.

Lemma pgroupS pi G H : H \subset G -> pi.-group G -> pi.-group H.
Proof. by move=> sHG; exact: pnat_dvd (cardSg sHG). Qed.

Lemma oddSg G H : H \subset G -> odd #|G| -> odd #|H|.
Proof. by rewrite !odd_2'nat; exact: pgroupS. Qed.

Lemma odd_pgroup_odd p G : odd p -> p.-group G -> odd #|G|.
Proof.
move=> p_odd pG; rewrite odd_2'nat (pi_pnat pG) // !inE.
by case: eqP p_odd => // ->.
Qed.

Lemma card_pgroup p G : p.-group G -> #|G| = (p ^ logn p #|G|)%N.
Proof. by move=> pG; rewrite -p_part part_pnat_id. Qed.

Lemma properG_ltn_log p G H :
  p.-group G -> H \proper G -> logn p #|H| < logn p #|G|.
Proof.
move=> pG; rewrite properEneq eqEcard andbC ltnNge => /andP[sHG].
rewrite sHG /= {1}(card_pgroup pG) {1}(card_pgroup (pgroupS sHG pG)).
by apply: contra; case: p {pG} => [|p] leHG; rewrite ?logn0 // leq_pexp2l.
Qed.

Lemma pgroupM pi G H : pi.-group (G * H) = pi.-group G && pi.-group H.
Proof.
have GH_gt0: 0 < #|G :&: H| := cardG_gt0 _.
rewrite /pgroup -(mulnK #|_| GH_gt0) -mul_cardG -(LagrangeI G H) -mulnA.
by rewrite mulKn // -(LagrangeI H G) setIC !pnat_mul andbCA; case: (pnat _).
Qed.

Lemma pgroupJ pi G x : pi.-group (G :^ x) = pi.-group G.
Proof. by rewrite /pgroup cardJg. Qed.

Lemma pgroup_p p P : p.-group P -> p_group P.
Proof.
case: (leqP #|P| 1); first by move=> /card_le1_trivg-> _; exact: pgroup1.
move/pdiv_prime=> pr_q pgP; have:= pgroupP pgP _ pr_q (pdiv_dvd _).
by rewrite /p_group => /eqnP->.
Qed.

Lemma p_groupP P : p_group P -> exists2 p, prime p & p.-group P.
Proof.
case: (ltnP 1 #|P|); first by move/pdiv_prime; exists (pdiv #|P|).
move/card_le1_trivg=> -> _; exists 2 => //; exact: pgroup1.
Qed.

Lemma pgroup_pdiv p G :
    p.-group G -> G :!=: 1 ->
  [/\ prime p, p %| #|G| & exists m, #|G| = p ^ m.+1]%N.
Proof.
move=> pG; rewrite trivg_card1; case/p_groupP: (pgroup_p pG) => q q_pr qG.
move/implyP: (pgroupP pG q q_pr); case/p_natP: qG => // [[|m] ->] //.
by rewrite dvdn_exp // => /eqnP <- _; split; rewrite ?dvdn_exp //; exists m.
Qed.

Lemma coprime_p'group p K R :
  coprime #|K| #|R| -> p.-group R -> R :!=: 1 -> p^'.-group K.
Proof.
move=> coKR pR ntR; have [p_pr _ [e oK]] := pgroup_pdiv pR ntR.
by rewrite oK coprime_sym coprime_pexpl // prime_coprime // -p'natE in coKR.
Qed.

Lemma card_Hall pi G H : pi.-Hall(G) H -> #|H| = #|G|`_pi.
Proof.
case/and3P=> sHG piH pi'H; rewrite -(Lagrange sHG).
by rewrite partnM ?Lagrange // part_pnat_id ?part_p'nat ?muln1.
Qed.

Lemma pHall_sub pi A B : pi.-Hall(A) B -> B \subset A.
Proof. by case/andP. Qed.

Lemma pHall_pgroup pi A B : pi.-Hall(A) B -> pi.-group B.
Proof. by case/and3P. Qed.

Lemma pHallP pi G H : reflect (H \subset G /\ #|H| = #|G|`_pi) (pi.-Hall(G) H).
Proof.
apply: (iffP idP) => [piH | [sHG oH]].
  split; [exact: pHall_sub piH | exact: card_Hall].
rewrite /pHall sHG -divgS // /pgroup oH.
by rewrite -{2}(@partnC pi #|G|) ?mulKn ?part_pnat.
Qed.

Lemma pHallE pi G H : pi.-Hall(G) H = (H \subset G) && (#|H| == #|G|`_pi).
Proof. by apply/pHallP/andP=> [] [->] /eqP. Qed.

Lemma coprime_mulpG_Hall pi G K R :
    K * R = G -> pi.-group K -> pi^'.-group R ->
  pi.-Hall(G) K /\ pi^'.-Hall(G) R.
Proof.
move=> defG piK pi'R; apply/andP.
rewrite /pHall piK -!divgS /= -defG ?mulG_subl ?mulg_subr //= pnatNK.
by rewrite coprime_cardMg ?(pnat_coprime piK) // mulKn ?mulnK //; exact/and3P.
Qed.

Lemma coprime_mulGp_Hall pi G K R :
    K * R = G -> pi^'.-group K -> pi.-group R ->
  pi^'.-Hall(G) K /\ pi.-Hall(G) R.
Proof.
move=> defG pi'K piR; apply/andP; rewrite andbC; apply/andP.
by apply: coprime_mulpG_Hall => //; rewrite -(comm_group_setP _) defG ?groupP.
Qed.

Lemma eq_in_pHall pi rho G H :
  {in \pi(G), pi =i rho} -> pi.-Hall(G) H = rho.-Hall(G) H.
Proof.
move=> eq_pi_rho; apply: andb_id2l => sHG.
congr (_ && _); apply: eq_in_pnat => p piHp.
  by apply: eq_pi_rho; exact: (piSg sHG).
by congr (~~ _); apply: eq_pi_rho; apply: (pi_of_dvd (dvdn_indexg G H)).
Qed.

Lemma eq_pHall pi rho G H : pi =i rho -> pi.-Hall(G) H = rho.-Hall(G) H.
Proof. by move=> eq_pi_rho; exact: eq_in_pHall (in1W eq_pi_rho). Qed.

Lemma eq_p'Hall pi rho G H : pi =i rho -> pi^'.-Hall(G) H = rho^'.-Hall(G) H.
Proof. by move=> eq_pi_rho; exact: eq_pHall (eq_negn _). Qed.

Lemma pHallNK pi G H : pi^'^'.-Hall(G) H = pi.-Hall(G) H.
Proof. exact: eq_pHall (negnK _). Qed.

Lemma subHall_Hall pi rho G H K :
  rho.-Hall(G) H -> {subset pi <= rho} -> pi.-Hall(H) K -> pi.-Hall(G) K.
Proof.
move=> hallH pi_sub_rho hallK.
rewrite pHallE (subset_trans (pHall_sub hallK) (pHall_sub hallH)) /=.
by rewrite (card_Hall hallK) (card_Hall hallH) partn_part.
Qed.

Lemma subHall_Sylow pi p G H P :
  pi.-Hall(G) H -> p \in pi -> p.-Sylow(H) P -> p.-Sylow(G) P.
Proof.
move=> hallH pi_p sylP; have [sHG piH _] := and3P hallH.
rewrite pHallE (subset_trans (pHall_sub sylP) sHG) /=.
by rewrite (card_Hall sylP) (card_Hall hallH) partn_part // => q; move/eqnP->.
Qed.

Lemma pHall_Hall pi A B : pi.-Hall(A) B -> Hall A B.
Proof. by case/and3P=> sBA piB pi'B; rewrite /Hall sBA (pnat_coprime piB). Qed.

Lemma Hall_pi G H : Hall G H -> \pi(H).-Hall(G) H.
Proof.
by case/andP=> sHG coHG /=; rewrite /pHall sHG /pgroup pnat_pi -?coprime_pi'.
Qed.

Lemma HallP G H : Hall G H -> exists pi, pi.-Hall(G) H.
Proof. by exists \pi(H); exact: Hall_pi. Qed.

Lemma sdprod_Hall G K H : K ><| H = G -> Hall G K = Hall G H.
Proof.
case/sdprod_context=> /andP[sKG _] sHG defG _ tiKH.
by rewrite /Hall sKG sHG -!divgS // -defG TI_cardMg // coprime_sym mulKn ?mulnK.
Qed.

Lemma coprime_sdprod_Hall_l G K H : K ><| H = G -> coprime #|K| #|H| = Hall G K.
Proof.
case/sdprod_context=> /andP[sKG _] _ defG _ tiKH.
by rewrite /Hall sKG -divgS // -defG TI_cardMg ?mulKn.
Qed.

Lemma coprime_sdprod_Hall_r G K H : K ><| H = G -> coprime #|K| #|H| = Hall G H.
Proof.
by move=> defG; rewrite (coprime_sdprod_Hall_l defG) (sdprod_Hall defG).
Qed.

Lemma compl_pHall pi K H G :
  pi.-Hall(G) K -> (H \in [complements to K in G]) = pi^'.-Hall(G) H.
Proof.
move=> hallK; apply/complP/idP=> [[tiKH mulKH] | hallH].
  have [_] := andP hallK; rewrite /pHall pnatNK -{3}(invGid G) -mulKH mulG_subr.
  by rewrite invMG !indexMg -indexgI andbC -indexgI setIC tiKH !indexg1.
have [[sKG piK _] [sHG pi'H _]] := (and3P hallK, and3P hallH).
have tiKH: K :&: H = 1 := coprime_TIg (pnat_coprime piK pi'H).
split=> //; apply/eqP; rewrite eqEcard mul_subG //= TI_cardMg //.
by rewrite (card_Hall hallK) (card_Hall hallH) partnC.
Qed.

Lemma compl_p'Hall pi K H G :
  pi^'.-Hall(G) K -> (H \in [complements to K in G]) = pi.-Hall(G) H.
Proof. by move/compl_pHall->; exact: eq_pHall (negnK pi). Qed.

Lemma sdprod_normal_p'HallP pi K H G :
  K <| G -> pi^'.-Hall(G) H -> reflect (K ><| H = G) (pi.-Hall(G) K).
Proof.
move=> nsKG hallH; rewrite -(compl_p'Hall K hallH).
exact: sdprod_normal_complP.
Qed.

Lemma sdprod_normal_pHallP pi K H G :
  K <| G -> pi.-Hall(G) H -> reflect (K ><| H = G) (pi^'.-Hall(G) K).
Proof.
by move=> nsKG hallH; apply: sdprod_normal_p'HallP; rewrite ?pHallNK.
Qed.

Lemma pHallJ2 pi G H x : pi.-Hall(G :^ x) (H :^ x) = pi.-Hall(G) H.
Proof. by rewrite !pHallE conjSg !cardJg. Qed.

Lemma pHallJnorm pi G H x : x \in 'N(G) -> pi.-Hall(G) (H :^ x) = pi.-Hall(G) H.
Proof. by move=> Nx; rewrite -{1}(normP Nx) pHallJ2. Qed.

Lemma pHallJ pi G H x : x \in G -> pi.-Hall(G) (H :^ x) = pi.-Hall(G) H.
Proof. by move=> Gx; rewrite -{1}(conjGid Gx) pHallJ2. Qed.

Lemma HallJ G H x : x \in G -> Hall G (H :^ x) = Hall G H.
Proof.
by move=> Gx; rewrite /Hall -!divgI -{1 3}(conjGid Gx) conjSg -conjIg !cardJg.
Qed.

Lemma psubgroupJ pi G H x :
  x \in G -> pi.-subgroup(G) (H :^ x) = pi.-subgroup(G) H.
Proof. by move=> Gx; rewrite /psubgroup pgroupJ -{1}(conjGid Gx) conjSg. Qed.

Lemma p_groupJ P x : p_group (P :^ x) = p_group P.
Proof. by rewrite /p_group cardJg pgroupJ. Qed.

Lemma SylowJ G P x : x \in G -> Sylow G (P :^ x) = Sylow G P.
Proof. by move=> Gx; rewrite /Sylow p_groupJ HallJ. Qed.

Lemma p_Sylow p G P : p.-Sylow(G) P -> Sylow G P.
Proof.
by move=> pP; rewrite /Sylow (pgroup_p (pHall_pgroup pP)) (pHall_Hall pP).
Qed.

Lemma pHall_subl pi G K H :
  H \subset K -> K \subset G -> pi.-Hall(G) H -> pi.-Hall(K) H.
Proof.
move=> sHK sKG; rewrite /pHall sHK; case/and3P=> _ ->.
by apply: pnat_dvd; exact: indexSg.
Qed.

Lemma Hall1 G : Hall G 1.
Proof. by rewrite /Hall sub1G cards1 coprime1n. Qed.

Lemma p_group1 : @p_group gT 1.
Proof. by rewrite (@pgroup_p 2) ?pgroup1. Qed.

Lemma Sylow1 G : Sylow G 1.
Proof. by rewrite /Sylow p_group1 Hall1. Qed.

Lemma SylowP G P : reflect (exists2 p, prime p & p.-Sylow(G) P) (Sylow G P).
Proof.
apply: (iffP idP) => [| [p _]]; last exact: p_Sylow.
case/andP=> /p_groupP[p p_pr] /p_natP[[P1 _ | n oP /Hall_pi]]; last first.
  by rewrite /= oP pi_of_exp // (eq_pHall _ _ (pi_of_prime _)) //; exists p.
have{p p_pr P1} ->: P :=: 1 by apply: card1_trivg; rewrite P1.
pose p := pdiv #|G|.+1; have p_pr: prime p by rewrite pdiv_prime ?ltnS.
exists p; rewrite // pHallE sub1G cards1 part_p'nat //.
apply/pgroupP=> q pr_q qG; apply/eqnP=> def_q.
have: p %| #|G| + 1 by rewrite addn1 pdiv_dvd.
by rewrite dvdn_addr -def_q // Euclid_dvd1.
Qed.

Lemma p_elt_exp pi x m : pi.-elt (x ^+ m) = (#[x]`_pi^' %| m).
Proof.
apply/idP/idP=> [pi_xm | /dvdnP[q ->{m}]]; last first.
  rewrite mulnC; apply: pnat_dvd (part_pnat pi #[x]).
  by rewrite order_dvdn -expgM mulnC mulnA partnC // -order_dvdn dvdn_mulr.
rewrite -(@Gauss_dvdr _ #[x ^+ m]); last first.
  by rewrite coprime_sym (pnat_coprime pi_xm) ?part_pnat.
apply: (@dvdn_trans #[x]); first by rewrite -{2}[#[x]](partnC pi) ?dvdn_mull.
by rewrite order_dvdn mulnC expgM expg_order.
Qed.

Lemma mem_p_elt pi x G : pi.-group G -> x \in G -> pi.-elt x.
Proof. by move=> piG Gx; apply: pgroupS piG; rewrite cycle_subG. Qed.

Lemma p_eltM_norm pi x y :
  x \in 'N(<[y]>) -> pi.-elt x -> pi.-elt y -> pi.-elt (x * y).
Proof.
move=> nyx pi_x pi_y; apply: (@mem_p_elt pi _ (<[x]> <*> <[y]>)%G).
  by rewrite /= norm_joinEl ?cycle_subG // pgroupM; exact/andP.
by rewrite groupM // mem_gen // inE cycle_id ?orbT.
Qed.

Lemma p_eltM pi x y : commute x y -> pi.-elt x -> pi.-elt y -> pi.-elt (x * y).
Proof.
move=> cxy; apply: p_eltM_norm; apply: (subsetP (cent_sub _)).
by rewrite cent_gen cent_set1; exact/cent1P.
Qed.

Lemma p_elt1 pi : pi.-elt (1 : gT).
Proof. by rewrite /p_elt order1. Qed.

Lemma p_eltV pi x : pi.-elt x^-1 = pi.-elt x.
Proof. by rewrite /p_elt orderV. Qed.

Lemma p_eltX pi x n : pi.-elt x -> pi.-elt (x ^+ n).
Proof. by rewrite -{1}[x]expg1 !p_elt_exp dvdn1 => /eqnP->. Qed.

Lemma p_eltJ pi x y : pi.-elt (x ^ y) = pi.-elt x.
Proof. by congr pnat; rewrite orderJ. Qed.

Lemma sub_p_elt pi1 pi2 x : {subset pi1 <= pi2} -> pi1.-elt x -> pi2.-elt x.
Proof. by move=> pi12; apply: sub_in_pnat => q _; exact: pi12. Qed.

Lemma eq_p_elt pi1 pi2 x : pi1 =i pi2 -> pi1.-elt x = pi2.-elt x.
Proof. by move=> pi12; exact: eq_pnat. Qed.

Lemma p_eltNK pi x : pi^'^'.-elt x = pi.-elt x.
Proof. exact: pnatNK. Qed.

Lemma eq_constt pi1 pi2 x : pi1 =i pi2 -> x.`_pi1 = x.`_pi2.
Proof.
move=> pi12; congr (x ^+ (chinese _ _ 1 0)); apply: eq_partn => // a.
by congr (~~ _); exact: pi12.
Qed.

Lemma consttNK pi x : x.`_pi^'^' = x.`_pi.
Proof. by rewrite /constt !partnNK. Qed.

Lemma cycle_constt pi x : x.`_pi \in <[x]>.
Proof. exact: mem_cycle. Qed.

Lemma consttV pi x : (x^-1).`_pi = (x.`_pi)^-1.
Proof. by rewrite /constt expgVn orderV. Qed.

Lemma constt1 pi : 1.`_pi = 1 :> gT.
Proof. exact: expg1n. Qed.

Lemma consttJ pi x y : (x ^ y).`_pi = x.`_pi ^ y.
Proof. by rewrite /constt orderJ conjXg. Qed.

Lemma p_elt_constt pi x : pi.-elt x.`_pi.
Proof. by rewrite p_elt_exp /chinese addn0 mul1n dvdn_mulr. Qed.

Lemma consttC pi x : x.`_pi * x.`_pi^' = x.
Proof.
apply/eqP; rewrite -{3}[x]expg1 -expgD eq_expg_mod_order.
rewrite partnNK -{5 6}(@partnC pi #[x]) // /chinese !addn0.
by rewrite chinese_remainder ?chinese_modl ?chinese_modr ?coprime_partC ?eqxx.
Qed.

Lemma p'_elt_constt pi x : pi^'.-elt (x * (x.`_pi)^-1).
Proof. by rewrite -{1}(consttC pi^' x) consttNK mulgK p_elt_constt. Qed.

Lemma order_constt pi (x : gT) : #[x.`_pi] = #[x]`_pi.
Proof.
rewrite -{2}(consttC pi x) orderM; [|exact: commuteX2|]; last first.
  by apply: (@pnat_coprime pi); exact: p_elt_constt.
by rewrite partnM // part_pnat_id ?part_p'nat ?muln1 //; exact: p_elt_constt.
Qed.

Lemma consttM pi x y : commute x y -> (x * y).`_pi = x.`_pi * y.`_pi.
Proof.
move=> cxy; pose m := #|<<[set x; y]>>|; have m_gt0: 0 < m := cardG_gt0 _.
pose k := chinese m`_pi m`_pi^' 1 0.
suffices kXpi z: z \in <<[set x; y]>> -> z.`_pi = z ^+ k.
  by rewrite !kXpi ?expgMn // ?groupM ?mem_gen // !inE eqxx ?orbT.
move=> xyz; have{xyz} zm: #[z] %| m by rewrite cardSg ?cycle_subG.
apply/eqP; rewrite eq_expg_mod_order -{3 4}[#[z]](partnC pi) //.
rewrite chinese_remainder ?chinese_modl ?chinese_modr ?coprime_partC //.
rewrite -!(modn_dvdm k (partn_dvd _ m_gt0 zm)).
rewrite chinese_modl ?chinese_modr ?coprime_partC //.
by rewrite !modn_dvdm ?partn_dvd ?eqxx.
Qed.

Lemma consttX pi x n : (x ^+ n).`_pi = x.`_pi ^+ n.
Proof.
elim: n => [|n IHn]; first exact: constt1.
rewrite !expgS consttM ?IHn //; exact: commuteX.
Qed.

Lemma constt1P pi x : reflect (x.`_pi = 1) (pi^'.-elt x).
Proof.
rewrite -{2}[x]expg1 p_elt_exp -order_constt consttNK order_dvdn expg1.
exact: eqP.
Qed.

Lemma constt_p_elt pi x : pi.-elt x -> x.`_pi = x.
Proof.
by rewrite -p_eltNK -{3}(consttC pi x) => /constt1P->; rewrite mulg1.
Qed.

Lemma sub_in_constt pi1 pi2 x :
  {in \pi(#[x]), {subset pi1 <= pi2}} -> x.`_pi2.`_pi1 = x.`_pi1.
Proof.
move=> pi12; rewrite -{2}(consttC pi2 x) consttM; last exact: commuteX2.
rewrite (constt1P _ x.`_pi2^' _) ?mulg1 //.
apply: sub_in_pnat (p_elt_constt _ x) => p; rewrite order_constt => pi_p.
apply: contra; apply: pi12.
by rewrite -[#[x]](partnC pi2^') // primes_mul // pi_p.
Qed.

Lemma prod_constt x : \prod_(0 <= p < #[x].+1) x.`_p = x.
Proof.
pose lp n := [pred p | p < n].
have: (lp #[x].+1).-elt x by apply/pnatP=> // p _; exact: dvdn_leq.
move/constt_p_elt=> def_x; symmetry; rewrite -{1}def_x {def_x}.
elim: _.+1 => [|p IHp].
  by rewrite big_nil; apply/constt1P; exact/pgroupP.
rewrite big_nat_recr /= -{}IHp -(consttC (lp p) x.`__); congr (_ * _).
  rewrite sub_in_constt // => q _; exact: leqW.
set y := _.`__; rewrite -(consttC p y) (constt1P p^' _ _) ?mulg1.
  by rewrite 2?sub_in_constt // => q _; move/eqnP->; rewrite !inE ?ltnn.
rewrite /p_elt pnatNK !order_constt -partnI.
apply: sub_in_pnat (part_pnat _ _) => q _.
by rewrite !inE ltnS -leqNgt -eqn_leq.
Qed.

Lemma max_pgroupJ pi M G x :
    x \in G -> [max M | pi.-subgroup(G) M] ->
  [max M :^ x of M | pi.-subgroup(G) M].
Proof.
move=> Gx /maxgroupP[piM maxM]; apply/maxgroupP.
split=> [|H piH]; first by rewrite psubgroupJ.
by rewrite -(conjsgKV x H) conjSg => /maxM/=-> //; rewrite psubgroupJ ?groupV.
Qed.

Lemma comm_sub_max_pgroup pi H M G :
    [max M | pi.-subgroup(G) M] -> pi.-group H -> H \subset G ->
  commute H M -> H \subset M.
Proof.
case/maxgroupP=> /andP[sMG piM] maxM piH sHG cHM.
rewrite -(maxM (H <*> M)%G) /= comm_joingE ?(mulG_subl, mulG_subr) //.
by rewrite /psubgroup pgroupM piM piH mul_subG.
Qed.

Lemma normal_sub_max_pgroup pi H M G :
  [max M | pi.-subgroup(G) M] -> pi.-group H -> H <| G -> H \subset M.
Proof.
move=> maxM piH /andP[sHG nHG].
apply: comm_sub_max_pgroup piH sHG _ => //; apply: commute_sym; apply: normC.
by apply: subset_trans nHG; case/andP: (maxgroupp maxM).
Qed.

Lemma norm_sub_max_pgroup pi H M G :
    [max M | pi.-subgroup(G) M] -> pi.-group H -> H \subset G ->
  H \subset 'N(M) -> H \subset M.
Proof. by move=> maxM piH sHG /normC; exact: comm_sub_max_pgroup piH sHG. Qed.

Lemma sub_pHall pi H G K :
  pi.-Hall(G) H -> pi.-group K -> H \subset K -> K \subset G -> K :=: H.
Proof.
move=> hallH piK sHK sKG; apply/eqP; rewrite eq_sym eqEcard sHK.
by rewrite (card_Hall hallH) -(part_pnat_id piK) dvdn_leq ?partn_dvd ?cardSg.
Qed.

Lemma Hall_max pi H G : pi.-Hall(G) H -> [max H | pi.-subgroup(G) H].
Proof.
move=> hallH; apply/maxgroupP; split=> [|K].
  by rewrite /psubgroup; case/and3P: hallH => ->.
case/andP=> sKG piK sHK; exact: (sub_pHall hallH).
Qed.

Lemma pHall_id pi H G : pi.-Hall(G) H -> pi.-group G -> H :=: G.
Proof.
by move=> hallH piG; rewrite (sub_pHall hallH piG) ?(pHall_sub hallH).
Qed.

Lemma psubgroup1 pi G : pi.-subgroup(G) 1.
Proof. by rewrite /psubgroup sub1G pgroup1. Qed.

Lemma Cauchy p G : prime p -> p %| #|G| -> {x | x \in G & #[x] = p}.
Proof.
move=> p_pr; elim: {G}_.+1 {-2}G (ltnSn #|G|) => // n IHn G.
rewrite ltnS => leGn pG; pose xpG := [pred x in G | #[x] == p].
have [x /andP[Gx /eqP] | no_x] := pickP xpG; first by exists x.
have{pG n leGn IHn} pZ: p %| #|'C_G(G)|.
  have:= pG; rewrite -(cardsID 'C(G)) dvdn_addl //.
  have /acts_sum_card_orbit <-: [acts G, on G :\: 'C(G) | 'J].
    by apply/actsP=> x Gx y; rewrite !inE -!mem_conjgV -centJ conjGid ?groupV.
  elim/big_ind: _ => //; first exact: dvdn_add.
  move=> _ /imsetP[x /setDP[Gx nCx] ->]; rewrite card_orbit astab1J.
  move: pG; rewrite -(Lagrange (subsetIl G 'C[x])) Euclid_dvdM // => /orP[] //.
  case/IHn=> [|y /setIP[Gy _ /eqP oyp]]; last by case/andP: (no_x y).
  apply: leq_trans leGn; apply: proper_card; rewrite properE subsetIl.
  by rewrite subsetI subxx /= -cent_set1 centsC sub1set.
have [Q maxQ _]: {Q | [max Q | p^'.-subgroup('C_G(G)) Q] & 1%G \subset Q}.
  apply: maxgroup_exists; exact: psubgroup1.
case/andP: (maxgroupp maxQ) => sQC; rewrite /pgroup p'natE // => /negP[].
apply: dvdn_trans pZ (cardSg _); apply/subsetP=> x /setIP[Gx Cx].
rewrite -sub1set -gen_subG (normal_sub_max_pgroup maxQ) //; last first.
  rewrite /normal subsetI !cycle_subG ?Gx ?cents_norm ?subIset ?andbT //=.
  by rewrite centsC cycle_subG Cx.
rewrite /pgroup p'natE //= -[#|_|]/#[x]; apply/dvdnP=> [[m oxm]].
have m_gt0: 0 < m by apply: dvdn_gt0 (order_gt0 x) _; rewrite oxm dvdn_mulr.
case/idP: (no_x (x ^+ m)); rewrite /= groupX //= orderXgcd //= oxm.
by rewrite gcdnC gcdnMr mulKn.
Qed.

(* These lemmas actually hold for maximal pi-groups, but below we'll *)
(* derive from the Cauchy lemma that a normal max pi-group is Hall.  *)

Lemma sub_normal_Hall pi G H K :
  pi.-Hall(G) H -> H <| G -> K \subset G -> (K \subset H) = pi.-group K.
Proof.
move=> hallH nsHG sKG; apply/idP/idP=> [sKH | piK].
  by rewrite (pgroupS sKH) ?(pHall_pgroup hallH).
apply: norm_sub_max_pgroup (Hall_max hallH) piK _ _ => //.
exact: subset_trans sKG (normal_norm nsHG).
Qed.

Lemma mem_normal_Hall pi H G x :
  pi.-Hall(G) H -> H <| G -> x \in G -> (x \in H) = pi.-elt x.
Proof. by rewrite -!cycle_subG; exact: sub_normal_Hall. Qed.

Lemma uniq_normal_Hall pi H G K :
  pi.-Hall(G) H -> H <| G -> [max K | pi.-subgroup(G) K] -> K :=: H.
Proof.
move=> hallH nHG /maxgroupP[/andP[sKG piK] /(_ H) -> //].
  exact: (maxgroupp (Hall_max hallH)).
by rewrite (sub_normal_Hall hallH).
Qed.

End PgroupProps.

Implicit Arguments pgroupP [gT pi G].
Implicit Arguments constt1P [gT pi x].
Prenex Implicits pgroupP constt1P.

Section NormalHall.

Variables (gT : finGroupType) (pi : nat_pred).
Implicit Types G H K : {group gT}.

Lemma normal_max_pgroup_Hall G H :
  [max H | pi.-subgroup(G) H] -> H <| G -> pi.-Hall(G) H.
Proof.
case/maxgroupP=> /andP[sHG piH] maxH nsHG; have [_ nHG] := andP nsHG.
rewrite /pHall sHG piH; apply/pnatP=> // p p_pr.
rewrite inE /= -pnatE // -card_quotient //.
case/Cauchy=> //= Hx; rewrite -sub1set -gen_subG -/<[Hx]> /order.
case/inv_quotientS=> //= K -> sHK sKG {Hx}.
rewrite card_quotient ?(subset_trans sKG) // => iKH; apply/negP=> pi_p.
rewrite -iKH -divgS // (maxH K) ?divnn ?cardG_gt0 // in p_pr.
by rewrite /psubgroup sKG /pgroup -(Lagrange sHK) mulnC pnat_mul iKH pi_p.
Qed.

Lemma setI_normal_Hall G H K :
  H <| G -> pi.-Hall(G) H -> K \subset G -> pi.-Hall(K) (H :&: K).
Proof.
move=> nsHG hallH sKG; apply: normal_max_pgroup_Hall; last first.
  by rewrite /= setIC (normalGI sKG nsHG).
apply/maxgroupP; split=> [|M /andP[sMK piM] sHK_M].
  by rewrite /psubgroup subsetIr (pgroupS (subsetIl _ _) (pHall_pgroup hallH)).
apply/eqP; rewrite eqEsubset sHK_M subsetI sMK !andbT.
by rewrite (sub_normal_Hall hallH) // (subset_trans sMK).
Qed.

End NormalHall.

Section Morphim.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Implicit Types (pi : nat_pred) (G H P : {group aT}).

Lemma morphim_pgroup pi G : pi.-group G -> pi.-group (f @* G).
Proof. by apply: pnat_dvd; exact: dvdn_morphim. Qed.

Lemma morphim_odd G : odd #|G| -> odd #|f @* G|.
Proof. by rewrite !odd_2'nat; exact: morphim_pgroup. Qed.

Lemma pmorphim_pgroup pi G :
   pi.-group ('ker f) -> G \subset D -> pi.-group (f @* G) = pi.-group G.
Proof.
move=> piker sGD; apply/idP/idP=> [pifG|]; last exact: morphim_pgroup.
apply: (@pgroupS _ _ (f @*^-1 (f @* G))); first by rewrite -sub_morphim_pre.
by rewrite /pgroup card_morphpre ?morphimS // pnat_mul; exact/andP.
Qed.

Lemma morphim_p_index pi G H :
  H \subset D -> pi.-nat #|G : H| -> pi.-nat #|f @* G : f @* H|.
Proof.
by move=> sHD; apply: pnat_dvd; rewrite index_morphim ?subIset // sHD orbT.
Qed.

Lemma morphim_pHall pi G H :
  H \subset D -> pi.-Hall(G) H -> pi.-Hall(f @* G) (f @* H).
Proof.
move=> sHD /and3P[sHG piH pi'GH].
by rewrite /pHall morphimS // morphim_pgroup // morphim_p_index.
Qed.

Lemma pmorphim_pHall pi G H :
    G \subset D -> H \subset D -> pi.-subgroup(H :&: G) ('ker f) ->
  pi.-Hall(f @* G) (f @* H) = pi.-Hall(G) H.
Proof.
move=> sGD sHD /andP[/subsetIP[sKH sKG] piK]; rewrite !pHallE morphimSGK //.
apply: andb_id2l => sHG; rewrite -(Lagrange sKH) -(Lagrange sKG) partnM //.
by rewrite (part_pnat_id piK) !card_morphim !(setIidPr _) // eqn_pmul2l.
Qed.

Lemma morphim_Hall G H : H \subset D -> Hall G H -> Hall (f @* G) (f @* H).
Proof.
by move=> sHD /HallP[pi piH]; apply: (@pHall_Hall _ pi); exact: morphim_pHall.
Qed.

Lemma morphim_pSylow p G P :
  P \subset D -> p.-Sylow(G) P -> p.-Sylow(f @* G) (f @* P).
Proof. exact: morphim_pHall. Qed.

Lemma morphim_p_group P : p_group P -> p_group (f @* P).
Proof. by move/morphim_pgroup; exact: pgroup_p. Qed.

Lemma morphim_Sylow G P : P \subset D -> Sylow G P -> Sylow (f @* G) (f @* P).
Proof.
by move=> sPD /andP[pP hallP]; rewrite /Sylow morphim_p_group // morphim_Hall.
Qed.

Lemma morph_p_elt pi x : x \in D -> pi.-elt x -> pi.-elt (f x).
Proof. by move=> Dx; apply: pnat_dvd; exact: morph_order. Qed.

Lemma morph_constt pi x : x \in D -> f x.`_pi = (f x).`_pi.
Proof.
move=> Dx; rewrite -{2}(consttC pi x) morphM ?groupX //.
rewrite consttM; last by rewrite !morphX //; exact: commuteX2.
have: pi.-elt (f x.`_pi) by rewrite morph_p_elt ?groupX ?p_elt_constt //.
have: pi^'.-elt (f x.`_pi^') by rewrite morph_p_elt ?groupX ?p_elt_constt //.
by move/constt1P->; move/constt_p_elt->; rewrite mulg1.
Qed.

End Morphim.

Section Pquotient.

Variables (pi : nat_pred) (gT : finGroupType) (p : nat) (G H K : {group gT}).
Hypothesis piK : pi.-group K.

Lemma quotient_pgroup : pi.-group (K / H). Proof. exact: morphim_pgroup. Qed.

Lemma quotient_pHall :
  K \subset 'N(H) -> pi.-Hall(G) K -> pi.-Hall(G / H) (K / H).
Proof. exact: morphim_pHall. Qed.

Lemma quotient_odd : odd #|K| -> odd #|K / H|. Proof. exact: morphim_odd. Qed.

Lemma pquotient_pgroup : G \subset 'N(K) -> pi.-group (G / K) = pi.-group G.
Proof. by move=> nKG; rewrite pmorphim_pgroup ?ker_coset. Qed.

Lemma pquotient_pHall :
  K <| G -> K <| H -> pi.-Hall(G / K) (H / K) = pi.-Hall(G) H.
Proof.
case/andP=> sKG nKG; case/andP=> sKH nKH.
by rewrite pmorphim_pHall // ker_coset /psubgroup subsetI sKH sKG.
Qed.

Lemma ltn_log_quotient :
  p.-group G -> H :!=: 1 -> H \subset G -> logn p #|G / H| < logn p #|G|.
Proof.
move=> pG ntH sHG; apply: contraLR (ltn_quotient ntH sHG); rewrite -!leqNgt.
rewrite {2}(card_pgroup pG) {2}(card_pgroup (morphim_pgroup _ pG)).
by case: (posnP p) => [-> //|]; exact: leq_pexp2l.
Qed.

End Pquotient.

(* Application of card_Aut_cyclic to internal faithful action on cyclic *)
(* p-subgroups.                                                         *)
Section InnerAutCyclicPgroup.

Variables (gT : finGroupType) (p : nat) (G C : {group gT}).
Hypothesis nCG : G \subset 'N(C).

Lemma logn_quotient_cent_cyclic_pgroup :
  p.-group C -> cyclic C -> logn p #|G / 'C_G(C)| <= (logn p #|C|).-1.
Proof.
move=> pC cycC; have [-> | ntC] := eqsVneq C 1.
  by rewrite cent1T setIT trivg_quotient cards1 logn1.
have [p_pr _ [e oC]] := pgroup_pdiv pC ntC.
rewrite -ker_conj_aut (card_isog (first_isog_loc _ _)) //.
apply: leq_trans (dvdn_leq_log _ _ (cardSg (Aut_conj_aut _ _))) _ => //.
rewrite card_Aut_cyclic // oC totient_pfactor //= logn_Gauss ?pfactorK //.
by rewrite prime_coprime // gtnNdvd // -(subnKC (prime_gt1 p_pr)).
Qed.

Lemma p'group_quotient_cent_prime :
  prime p -> #|C| %| p -> p^'.-group (G / 'C_G(C)).
Proof.
move=> p_pr pC; have pgC: p.-group C := pnat_dvd pC (pnat_id p_pr).
have [_ dv_p] := primeP p_pr; case/pred2P: {dv_p pC}(dv_p _ pC) => [|pC].
  by move/card1_trivg->; rewrite cent1T setIT trivg_quotient pgroup1.
have le_oGC := logn_quotient_cent_cyclic_pgroup pgC.
rewrite /pgroup -partn_eq1 ?cardG_gt0 // -dvdn1 p_part pfactor_dvdn // logn1.
by rewrite (leq_trans (le_oGC _)) ?prime_cyclic // pC ?(pfactorK 1).
Qed.

End InnerAutCyclicPgroup.

Section PcoreDef.

(* A functor needs to quantify over the finGroupType just beore the set. *)

Variables (pi : nat_pred) (gT : finGroupType) (A : {set gT}).

Definition pcore := \bigcap_(G | [max G | pi.-subgroup(A) G]) G.

Canonical pcore_group : {group gT} := Eval hnf in [group of pcore].

End PcoreDef.

Arguments Scope pcore [_ nat_scope group_scope].
Arguments Scope pcore_group [_ nat_scope Group_scope].
Notation "''O_' pi ( G )" := (pcore pi G)
  (at level 8, pi at level 2, format "''O_' pi ( G )") : group_scope.
Notation "''O_' pi ( G )" := (pcore_group pi G) : Group_scope.

Section PseriesDefs.

Variables (pis : seq nat_pred) (gT : finGroupType) (A : {set gT}).

Definition pcore_mod pi B := coset B @*^-1 'O_pi(A / B).
Canonical pcore_mod_group pi B : {group gT} :=
  Eval hnf in [group of pcore_mod pi B].

Definition pseries := foldr pcore_mod 1 (rev pis).

Lemma pseries_group_set : group_set pseries.
Proof. rewrite /pseries; case: rev => [|pi1 pi1']; exact: groupP. Qed.

Canonical pseries_group : {group gT} := group pseries_group_set.

End PseriesDefs.

Arguments Scope pseries [_ seq_scope group_scope].
Local Notation ConsPred p := (@Cons nat_pred p%N) (only parsing).
Notation "''O_{' p1 , .. , pn } ( A )" :=
  (pseries (ConsPred p1 .. (ConsPred pn [::]) ..) A)
  (at level 8, format "''O_{' p1 , .. , pn } ( A )") : group_scope.
Notation "''O_{' p1 , .. , pn } ( A )" :=
  (pseries_group (ConsPred p1 .. (ConsPred pn [::]) ..) A) : Group_scope.

Section PCoreProps.

Variables (pi : nat_pred) (gT : finGroupType).
Implicit Types (A : {set gT}) (G H M K : {group gT}).

Lemma pcore_psubgroup G : pi.-subgroup(G) 'O_pi(G).
Proof.
have [M maxM _]: {M | [max M | pi.-subgroup(G) M] & 1%G \subset M}.
  by apply: maxgroup_exists; rewrite /psubgroup sub1G pgroup1.
have sOM: 'O_pi(G) \subset M by exact: bigcap_inf.
have /andP[piM sMG] := maxgroupp maxM.
by rewrite /psubgroup (pgroupS sOM) // (subset_trans sOM).
Qed.

Lemma pcore_pgroup G : pi.-group 'O_pi(G).
Proof. by case/andP: (pcore_psubgroup G). Qed.

Lemma pcore_sub G : 'O_pi(G) \subset G.
Proof. by case/andP: (pcore_psubgroup G). Qed.

Lemma pcore_sub_Hall G H : pi.-Hall(G) H -> 'O_pi(G) \subset H.
Proof. by move/Hall_max=> maxH; exact: bigcap_inf. Qed.

Lemma pcore_max G H : pi.-group H -> H <| G -> H \subset 'O_pi(G).
Proof.
move=> piH nHG; apply/bigcapsP=> M maxM.
exact: normal_sub_max_pgroup piH nHG.
Qed.

Lemma pcore_pgroup_id G : pi.-group G -> 'O_pi(G) = G.
Proof. by move=> piG; apply/eqP; rewrite eqEsubset pcore_sub pcore_max. Qed.

Lemma pcore_normal G : 'O_pi(G) <| G.
Proof.
rewrite /(_ <| G) pcore_sub; apply/subsetP=> x Gx.
rewrite inE; apply/bigcapsP=> M maxM; rewrite sub_conjg.
by apply: bigcap_inf; apply: max_pgroupJ; rewrite ?groupV.
Qed.

Lemma normal_Hall_pcore H G : pi.-Hall(G) H -> H <| G -> 'O_pi(G) = H.
Proof.
move=> hallH nHG; apply/eqP.
rewrite eqEsubset (sub_normal_Hall hallH) ?pcore_sub ?pcore_pgroup //=.
by rewrite pcore_max //= (pHall_pgroup hallH).
Qed.

Lemma eq_Hall_pcore G H :
   pi.-Hall(G) 'O_pi(G) -> pi.-Hall(G) H -> H :=: 'O_pi(G).
Proof.
move=> hallGpi hallH.
exact: uniq_normal_Hall (pcore_normal G) (Hall_max hallH).
Qed.

Lemma sub_Hall_pcore G K :
  pi.-Hall(G) 'O_pi(G) -> K \subset G -> (K \subset 'O_pi(G)) = pi.-group K.
Proof. by move=> hallGpi; exact: sub_normal_Hall (pcore_normal G). Qed.

Lemma mem_Hall_pcore G x :
  pi.-Hall(G) 'O_pi(G) -> x \in G -> (x \in 'O_pi(G)) = pi.-elt x.
Proof. move=> hallGpi; exact: mem_normal_Hall (pcore_normal G). Qed.

Lemma sdprod_Hall_pcoreP H G :
  pi.-Hall(G) 'O_pi(G) -> reflect ('O_pi(G) ><| H = G) (pi^'.-Hall(G) H).
Proof.
move=> hallGpi; rewrite -(compl_pHall H hallGpi) complgC.
exact: sdprod_normal_complP (pcore_normal G).
Qed.

Lemma sdprod_pcore_HallP H G :
  pi^'.-Hall(G) H -> reflect ('O_pi(G) ><| H = G) (pi.-Hall(G) 'O_pi(G)).
Proof. exact: sdprod_normal_p'HallP (pcore_normal G). Qed.

Lemma pcoreJ G x : 'O_pi(G :^ x) = 'O_pi(G) :^ x.
Proof.
apply/eqP; rewrite eqEsubset -sub_conjgV.
rewrite !pcore_max ?pgroupJ ?pcore_pgroup ?normalJ ?pcore_normal //.
by rewrite -(normalJ _ _ x) conjsgKV pcore_normal.
Qed.

End PCoreProps.

Section MorphPcore.

Implicit Types (pi : nat_pred) (gT rT : finGroupType).

Lemma morphim_pcore pi : GFunctor.pcontinuous (pcore pi).
Proof.
move=> gT rT D G f; apply/bigcapsP=> M /normal_sub_max_pgroup; apply.
  by rewrite morphim_pgroup ?pcore_pgroup.
apply: morphim_normal; exact: pcore_normal.
Qed.

Lemma pcoreS pi gT (G H : {group gT}) :
  H \subset G -> H :&: 'O_pi(G) \subset 'O_pi(H).
Proof.
move=> sHG; rewrite -{2}(setIidPl sHG).
do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom; exact: morphim_pcore.
Qed.

Canonical pcore_igFun pi := [igFun by pcore_sub pi & morphim_pcore pi].
Canonical pcore_gFun pi := [gFun by morphim_pcore pi].
Canonical pcore_pgFun pi := [pgFun by morphim_pcore pi].

Lemma pcore_char pi gT (G : {group gT}) : 'O_pi(G) \char G.
Proof. exact: gFchar. Qed.

Section PcoreMod.

Variable F : GFunctor.pmap.

Lemma pcore_mod_sub pi gT (G : {group gT}) : pcore_mod G pi (F _ G) \subset G.
Proof.
have nFD := gFnorm F G; rewrite sub_morphpre_im ?pcore_sub //=.
  by rewrite ker_coset_prim subIset // gen_subG gFsub.
by apply: subset_trans (pcore_sub _ _) _; apply: morphimS.
Qed.

Lemma quotient_pcore_mod pi gT (G : {group gT}) (B : {set gT}) :
  pcore_mod G pi B / B = 'O_pi(G / B).
Proof.
apply: morphpreK; apply: subset_trans (pcore_sub _ _) _.
by rewrite /= /quotient -morphimIdom  morphimS ?subsetIl.
Qed.

Lemma morphim_pcore_mod pi gT rT (D G : {group gT}) (f : {morphism D >-> rT}) :
  f @* pcore_mod G pi (F _ G) \subset pcore_mod (f @* G) pi (F _ (f @* G)).
Proof.
have sDF: D :&: G \subset 'dom (coset (F _ G)).
  by rewrite setIC subIset ?gFnorm.
have sDFf: D :&: G \subset 'dom (coset (F _ (f @* G)) \o f).
  by rewrite -sub_morphim_pre ?subsetIl // morphimIdom gFnorm.
pose K := 'ker (restrm sDFf (coset (F _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (F _ G))) \subset K.
  rewrite /K !ker_restrm ker_comp /= subsetI subsetIl /= -setIA.
  rewrite -sub_morphim_pre ?subsetIl //.
  by rewrite morphimIdom !ker_coset (setIidPr _) ?pmorphimF ?gFsub.
have sOF := pcore_sub pi (G / F _ G); have sDD: D :&: G \subset D :&: G by [].
rewrite -sub_morphim_pre -?quotientE; last first.
  by apply: subset_trans (gFnorm F _); rewrite morphimS ?pcore_mod_sub.
suffices im_fact (H : {group gT}) : F _ G \subset H -> H \subset G ->
  factm sFK sDD @* (H / F _ G) = f @* H / F _ (f @* G).
- rewrite -2?im_fact ?pcore_mod_sub ?gFsub //;
    try by rewrite -{1}[F _ G]ker_coset morphpreS ?sub1G.
  by rewrite quotient_pcore_mod morphim_pcore.
move=> sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?ker_coset //.
rewrite -(morphim_restrm sDF) morphim_factm morphim_restrm.
by rewrite morphim_comp -quotientE -setIA morphimIdom (setIidPr _).
Qed.

Lemma pcore_mod_res pi gT rT (D : {group gT}) (f : {morphism D >-> rT}) :
  f @* pcore_mod D pi (F _ D) \subset pcore_mod (f @* D) pi (F _ (f @* D)).
Proof. exact: morphim_pcore_mod. Qed.

Lemma pcore_mod1 pi gT (G : {group gT}) : pcore_mod G pi 1 = 'O_pi(G).
Proof.
rewrite /pcore_mod; have inj1 := coset1_injm gT; rewrite -injmF ?norms1 //.
by rewrite -(morphim_invmE inj1) morphim_invm ?norms1.
Qed.

End PcoreMod.

Lemma pseries_rcons pi pis gT (A : {set gT}) :
  pseries (rcons pis pi) A = pcore_mod A pi (pseries pis A).
Proof. by rewrite /pseries rev_rcons. Qed.

Lemma pseries_subfun pis :
   GFunctor.closed (pseries pis) /\  GFunctor.pcontinuous (pseries pis).
Proof.
elim/last_ind: pis => [|pis pi [sFpi fFpi]].
  by split=> [gT G | gT rT D G f]; rewrite (sub1G, morphim1).
pose fF := [gFun by fFpi : GFunctor.continuous [igFun by sFpi & fFpi]].
pose F := [pgFun by fFpi : GFunctor.hereditary fF].
split=> [gT G | gT rT D G f]; rewrite !pseries_rcons ?(pcore_mod_sub F) //.
exact: (morphim_pcore_mod F).
Qed.

Lemma pseries_sub pis : GFunctor.closed (pseries pis).
Proof. by case: (pseries_subfun pis). Qed.

Lemma morphim_pseries pis : GFunctor.pcontinuous (pseries pis).
Proof. by case: (pseries_subfun pis). Qed.

Lemma pseriesS pis : GFunctor.hereditary (pseries pis).
Proof. exact: (morphim_pseries pis). Qed.

Canonical pseries_igFun pis := [igFun by pseries_sub pis & morphim_pseries pis].
Canonical pseries_gFun pis := [gFun by morphim_pseries pis].
Canonical pseries_pgFun pis := [pgFun by morphim_pseries pis].

Lemma pseries_char pis gT (G : {group gT}) : pseries pis G \char G.
Proof. exact: gFchar. Qed.

Lemma pseries_normal pis gT (G : {group gT}) : pseries pis G <| G.
Proof. exact: gFnormal. Qed.

Lemma pseriesJ pis gT (G : {group gT}) x :
  pseries pis (G :^ x) = pseries pis G :^ x.
Proof.
rewrite -{1}(setIid G) -morphim_conj -(injmF _ (injm_conj G x)) //=.
by rewrite morphim_conj (setIidPr (pseries_sub _ _)).
Qed.

Lemma pseries1 pi gT (G : {group gT}) : 'O_{pi}(G) = 'O_pi(G).
Proof. exact: pcore_mod1. Qed.

Lemma pseries_pop pi pis gT (G : {group gT}) :
  'O_pi(G) = 1 -> pseries (pi :: pis) G = pseries pis G.
Proof.
by move=> OG1; rewrite /pseries rev_cons -cats1 foldr_cat /= pcore_mod1 OG1.
Qed.

Lemma pseries_pop2 pi1 pi2 gT (G : {group gT}) :
  'O_pi1(G) = 1 -> 'O_{pi1, pi2}(G) = 'O_pi2(G).
Proof. by move/pseries_pop->; exact: pseries1. Qed.

Lemma pseries_sub_catl pi1s pi2s gT (G : {group gT}) :
  pseries pi1s G \subset pseries (pi1s ++ pi2s) G.
Proof.
elim/last_ind: pi2s => [|pi pis IHpi]; rewrite ?cats0 //  -rcons_cat.
by rewrite pseries_rcons; apply: subset_trans IHpi _; rewrite sub_cosetpre.
Qed.

Lemma quotient_pseries pis pi gT (G : {group gT}) :
  pseries (rcons pis pi) G / pseries pis G = 'O_pi(G / pseries pis G).
Proof. by rewrite pseries_rcons quotient_pcore_mod. Qed.

Lemma pseries_norm2 pi1s pi2s gT (G : {group gT}) :
  pseries pi2s G \subset 'N(pseries pi1s G).
Proof.
apply: subset_trans (normal_norm (pseries_normal pi1s G)); exact: pseries_sub.
Qed.

Lemma pseries_sub_catr pi1s pi2s gT (G : {group gT}) :
  pseries pi2s G \subset pseries (pi1s ++ pi2s) G.
Proof.
elim: pi1s => //= pi1 pi1s /subset_trans; apply.
elim/last_ind: {pi1s pi2s}(_ ++ _) => [|pis pi IHpi]; first exact: sub1G.
rewrite -rcons_cons (pseries_rcons _ (pi1 :: pis)).
rewrite -sub_morphim_pre ?pseries_norm2 //.
apply: pcore_max; last by rewrite morphim_normal ?pseries_normal.
have: pi.-group (pseries (rcons pis pi) G / pseries pis G).
  by rewrite quotient_pseries pcore_pgroup.
by apply: pnat_dvd; rewrite !card_quotient ?pseries_norm2 // indexgS.
Qed.

Lemma quotient_pseries2 pi1 pi2 gT (G : {group gT}) :
  'O_{pi1, pi2}(G) / 'O_pi1(G) = 'O_pi2(G / 'O_pi1(G)).
Proof. by rewrite -pseries1 -quotient_pseries. Qed.

Lemma quotient_pseries_cat pi1s pi2s gT (G : {group gT}) :
  pseries (pi1s ++ pi2s) G / pseries pi1s G
    = pseries pi2s (G / pseries pi1s G).
Proof.
elim/last_ind: pi2s => [|pi2s pi IHpi]; first by rewrite cats0 trivg_quotient.
have psN := pseries_normal _ G; set K := pseries _ G.
case: (third_isom (pseries_sub_catl pi1s pi2s G) (psN _)) => //= f inj_f im_f.
have nH2H: pseries pi2s (G / K) <| pseries (pi1s ++ rcons pi2s pi) G / K.
  rewrite -IHpi morphim_normal // -cats1 catA.
  by apply/andP; rewrite pseries_sub_catl pseries_norm2.
apply: (quotient_inj nH2H).
  by apply/andP; rewrite /= -cats1 pseries_sub_catl pseries_norm2.
rewrite /= quotient_pseries /= -IHpi -rcons_cat.
rewrite -[G / _ / _](morphim_invm inj_f) //= {2}im_f //.
rewrite -(@injmF [igFun of pcore pi]) /= ?injm_invm ?im_f // -quotient_pseries.
by rewrite -im_f ?morphim_invm ?morphimS ?normal_sub.
Qed.

Lemma pseries_catl_id pi1s pi2s gT (G : {group gT}) :
  pseries pi1s (pseries (pi1s ++ pi2s) G) = pseries pi1s G.
Proof.
elim/last_ind: pi1s => [//|pi1s pi IHpi] in pi2s *.
apply: (@quotient_inj _ (pseries_group pi1s G)).
- rewrite /= -(IHpi (pi :: pi2s)) cat_rcons /(_ <| _) pseries_norm2.
  by rewrite -cats1 pseries_sub_catl.
- by rewrite /= /(_ <| _) pseries_norm2 -cats1 pseries_sub_catl.
rewrite /= cat_rcons -(IHpi (pi :: pi2s)) {1}quotient_pseries IHpi.
apply/eqP; rewrite quotient_pseries eqEsubset !pcore_max ?pcore_pgroup //=.
  rewrite -quotient_pseries morphim_normal // /(_ <| _) pseries_norm2.
  by rewrite -cat_rcons pseries_sub_catl.
by rewrite (char_normal_trans (pcore_char _ _)) ?quotient_normal ?gFnormal.
Qed.

Lemma pseries_char_catl pi1s pi2s gT (G : {group gT}) :
  pseries pi1s G \char pseries (pi1s ++ pi2s) G.
Proof. by rewrite -(pseries_catl_id pi1s pi2s G) pseries_char. Qed.

Lemma pseries_catr_id pi1s pi2s gT (G : {group gT}) :
  pseries pi2s (pseries (pi1s ++ pi2s) G) = pseries pi2s G.
Proof.
elim/last_ind: pi2s => [//|pi2s pi IHpi] in G *.
have Epis: pseries pi2s (pseries (pi1s ++ rcons pi2s pi) G) = pseries pi2s G.
  by rewrite -cats1 catA -2!IHpi pseries_catl_id.
apply: (@quotient_inj _ (pseries_group pi2s G)).
- by rewrite /= -Epis /(_ <| _) pseries_norm2 -cats1 pseries_sub_catl.
- by rewrite /= /(_ <| _) pseries_norm2 -cats1 pseries_sub_catl.
rewrite /= -Epis {1}quotient_pseries Epis quotient_pseries.
apply/eqP; rewrite eqEsubset !pcore_max ?pcore_pgroup //=.
  rewrite -quotient_pseries morphim_normal // /(_ <| _) pseries_norm2.
  by rewrite pseries_sub_catr.
apply: char_normal_trans (pcore_char pi _) (morphim_normal _ _).
exact: pseries_normal.
Qed.

Lemma pseries_char_catr pi1s pi2s gT (G : {group gT}) :
  pseries pi2s G \char pseries (pi1s ++ pi2s) G.
Proof. by rewrite -(pseries_catr_id pi1s pi2s G) pseries_char. Qed.

Lemma pcore_modp pi gT (G H : {group gT}) :
  H <| G -> pi.-group H -> pcore_mod G pi H = 'O_pi(G).
Proof.
move=> nsHG piH; apply/eqP; rewrite eqEsubset andbC.
have nHG := normal_norm nsHG; have sOG := subset_trans (pcore_sub pi _).
rewrite -sub_morphim_pre ?(sOG, morphim_pcore) // pcore_max //.
  rewrite -(pquotient_pgroup piH) ?subsetIl //.
  by rewrite quotient_pcore_mod pcore_pgroup.
by rewrite -{2}(quotientGK nsHG) morphpre_normal ?pcore_normal ?sOG ?morphimS.
Qed.

Lemma pquotient_pcore pi gT (G H : {group gT}) :
  H <| G -> pi.-group H -> 'O_pi(G / H) = 'O_pi(G) / H.
Proof. by move=> nsHG piH; rewrite -quotient_pcore_mod pcore_modp. Qed.

Lemma trivg_pcore_quotient pi gT (G : {group gT}) : 'O_pi(G / 'O_pi(G)) = 1.
Proof.
by rewrite pquotient_pcore ?pcore_normal ?pcore_pgroup // trivg_quotient.
Qed.

Lemma pseries_rcons_id pis pi gT (G : {group gT}) :
  pseries (rcons (rcons pis pi) pi) G = pseries (rcons pis pi) G.
Proof.
apply/eqP; rewrite -!cats1 eqEsubset pseries_sub_catl andbT -catA.
rewrite -(quotientSGK _ (pseries_sub_catl _ _ _)) ?pseries_norm2 //.
rewrite !quotient_pseries_cat -quotient_sub1 ?pseries_norm2 //.
by rewrite quotient_pseries_cat /= !pseries1 trivg_pcore_quotient.
Qed.

End MorphPcore.

Section EqPcore.

Variables gT : finGroupType.
Implicit Types (pi rho : nat_pred) (G H : {group gT}).

Lemma sub_in_pcore pi rho G :
  {in \pi(G), {subset pi <= rho}} -> 'O_pi(G) \subset 'O_rho(G).
Proof.
move=> pi_sub_rho; rewrite pcore_max ?pcore_normal //.
apply: sub_in_pnat (pcore_pgroup _ _) => p.
move/(piSg (pcore_sub _ _)); exact: pi_sub_rho.
Qed.

Lemma sub_pcore pi rho G : {subset pi <= rho} -> 'O_pi(G) \subset 'O_rho(G).
Proof. by move=> pi_sub_rho; exact: sub_in_pcore (in1W pi_sub_rho). Qed.

Lemma eq_in_pcore pi rho G : {in \pi(G), pi =i rho} -> 'O_pi(G) = 'O_rho(G).
Proof.
move=> eq_pi_rho; apply/eqP; rewrite eqEsubset.
by rewrite !sub_in_pcore // => p /eq_pi_rho->.
Qed.

Lemma eq_pcore pi rho G : pi =i rho -> 'O_pi(G) = 'O_rho(G).
Proof. by move=> eq_pi_rho; exact: eq_in_pcore (in1W eq_pi_rho). Qed.

Lemma pcoreNK pi G : 'O_pi^'^'(G) = 'O_pi(G).
Proof. by apply: eq_pcore; exact: negnK. Qed.

Lemma eq_p'core pi rho G : pi =i rho -> 'O_pi^'(G) = 'O_rho^'(G).
Proof. by move/eq_negn; exact: eq_pcore. Qed.

Lemma sdprod_Hall_p'coreP pi H G :
  pi^'.-Hall(G) 'O_pi^'(G) -> reflect ('O_pi^'(G) ><| H = G) (pi.-Hall(G) H).
Proof. by rewrite -(pHallNK pi G H); exact: sdprod_Hall_pcoreP. Qed.

Lemma sdprod_p'core_HallP pi H G :
  pi.-Hall(G) H -> reflect ('O_pi^'(G) ><| H = G) (pi^'.-Hall(G) 'O_pi^'(G)).
Proof. by rewrite -(pHallNK pi G H); exact: sdprod_pcore_HallP. Qed.

Lemma pcoreI pi rho G : 'O_[predI pi & rho](G) = 'O_pi('O_rho(G)).
Proof.
apply/eqP; rewrite eqEsubset !pcore_max //.
- rewrite /pgroup pnatI [pnat _ _]pcore_pgroup.
  exact: pgroupS (pcore_sub _ _) (pcore_pgroup _ _).
- exact: char_normal_trans (pcore_char _ _) (pcore_normal _ _).
- by apply: sub_in_pnat (pcore_pgroup _ _) => p _ /andP[].
apply/andP; split; first by apply: sub_pcore => p /andP[].
by rewrite (subset_trans (pcore_sub _ _)) ?gFnorm.
Qed.

Lemma bigcap_p'core pi G :
  G :&: \bigcap_(p < #|G|.+1 | (p : nat) \in pi) 'O_p^'(G) = 'O_pi^'(G).
Proof.
apply/eqP; rewrite eqEsubset subsetI pcore_sub pcore_max /=.
- by apply/bigcapsP=> p pi_p; apply: sub_pcore => r; apply: contraNneq => ->.
- apply/pgroupP=> q q_pr qGpi'; apply: contraL (eqxx q) => /= pi_q.
  apply: (pgroupP (pcore_pgroup q^' G)) => //.
  have qG: q %| #|G| by rewrite (dvdn_trans qGpi') // cardSg ?subsetIl.
  have ltqG: q < #|G|.+1 by rewrite ltnS dvdn_leq.
  rewrite (dvdn_trans qGpi') ?cardSg ?subIset //= orbC.
  by rewrite (bigcap_inf (Ordinal ltqG)).
rewrite /normal subsetIl normsI ?normG // norms_bigcap //.
by apply/bigcapsP => p _; exact: gFnorm.
Qed.

Lemma coprime_pcoreC (rT : finGroupType) pi G (R : {group rT}) :
  coprime #|'O_pi(G)| #|'O_pi^'(R)|.
Proof. exact: pnat_coprime (pcore_pgroup _ _) (pcore_pgroup _ _). Qed.

Lemma TI_pcoreC pi G H : 'O_pi(G) :&: 'O_pi^'(H) = 1.
Proof. by rewrite coprime_TIg ?coprime_pcoreC. Qed.

Lemma pcore_setI_normal pi G H : H <| G -> 'O_pi(G) :&: H = 'O_pi(H).
Proof.
move=> nsHG; apply/eqP; rewrite eqEsubset subsetI pcore_sub.
rewrite !pcore_max ?(pgroupS (subsetIl _ H)) ?pcore_pgroup //=.
  exact: char_normal_trans (pcore_char pi H) nsHG.
by rewrite setIC (normalGI (normal_sub nsHG)) ?pcore_normal.
Qed.

End EqPcore.

Implicit Arguments sdprod_Hall_pcoreP [gT pi G H].
Implicit Arguments sdprod_Hall_p'coreP [gT pi G H].

Section Injm.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Hypothesis injf : 'injm f.
Implicit Types (A : {set aT}) (G H : {group aT}).

Lemma injm_pgroup pi A : A \subset D -> pi.-group (f @* A) = pi.-group A.
Proof. by move=> sAD; rewrite /pgroup card_injm. Qed.

Lemma injm_pelt pi x : x \in D -> pi.-elt (f x) = pi.-elt x.
Proof. by move=> Dx; rewrite /p_elt order_injm. Qed.

Lemma injm_pHall pi G H :
  G \subset D -> H \subset D -> pi.-Hall(f @* G) (f @* H) = pi.-Hall(G) H.
Proof. by move=> sGD sGH; rewrite !pHallE injmSK ?card_injm. Qed.

Lemma injm_pcore pi G : G \subset D -> f @* 'O_pi(G) = 'O_pi(f @* G).
Proof. exact: injmF. Qed.

Lemma injm_pseries pis G :
  G \subset D -> f @* pseries pis G = pseries pis (f @* G).
Proof. exact: injmF. Qed.

End Injm.

Section Isog.

Variables (aT rT : finGroupType) (G : {group aT}) (H : {group rT}).

Lemma isog_pgroup pi : G \isog H -> pi.-group G = pi.-group H.
Proof. by move=> isoGH; rewrite /pgroup (card_isog isoGH). Qed.

Lemma isog_pcore pi : G \isog H -> 'O_pi(G) \isog 'O_pi(H).
Proof. exact: gFisog. Qed.

Lemma isog_pseries pis : G \isog H -> pseries pis G \isog pseries pis H.
Proof. exact: gFisog. Qed.

End Isog.


Section ml.
Theorem AnddiscP: forall (A:Prop)(B:Set -> Prop),
(exists x:Set, (A /\ (B x))) -> A /\ (exists x:Set, B x).
Proof.
(* intros P F.
intro h0.
split.
destruct h0 as [ n h1 ].
elim h1; intros p fn; assumption.
destruct h0 as [ n h1 ].
apply ex_intro with n.
elim h1; intros p fn; assumption. *)
intros a b h.
elim h.
intros x abx.
elim abx; intros a1 bx.
split.
assumption.
exists x.
assumption.
Qed.
End ml.

Check AnddiscP.


Require Export Category Functor.
Require Import Common.

Set Implicit Arguments.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section ComputableCat.
  Context `{Funext}.

  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Coercion Index2Cat : I >-> PreCategory.

  Context `{forall C D : I, IsHSet (Functor C D)}.

  Definition ComputableCat : PreCategory
    := @Build_PreCategory I
                          (fun C D : I => Functor C D)
                          (fun x : I => IdentityFunctor x)
                          (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))
                          (fun _ _ _ _ _ _ _ => ComposeFunctorsAssociativity _ _ _)
                          (fun _ _ _ => LeftIdentityFunctor _)
                          (fun _ _ _ => RightIdentityFunctor _)
                          _.
End ComputableCat.