(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
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.


Require Import XR_Rlt.
Require Import XR_Rmin.
Require Import XR_Rmin_Rgt_l.
Require Import XR_Rmin_Rgt_r.

Local Open Scope R_scope.

Lemma Rmin_Rgt : forall r1 r2 r, r < Rmin r1 r2 <-> r < r1 /\ r < r2.
Proof.
  intros x y z.
  split.
  {
    intro h.
    apply Rmin_Rgt_l.
    exact h.
  }
  {
    intro h.
    apply Rmin_Rgt_r.
    exact h.
  }
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require real.Real.
Require real.Square.

(* Why3 assumption *)
Definition dot (x1:R) (x2:R) (y1:R) (y2:R): R :=
  ((x1 * y1)%R + (x2 * y2)%R)%R.

(* Why3 assumption *)
Definition norm2 (x1:R) (x2:R): R :=
  ((Reals.RIneq.Rsqr x1) + (Reals.RIneq.Rsqr x2))%R.

Axiom norm2_pos : forall (x1:R) (x2:R), (0%R <= (norm2 x1 x2))%R.

Axiom Lagrange : forall (a1:R) (a2:R) (b1:R) (b2:R), (((norm2 a1
  a2) * (norm2 b1 b2))%R = ((Reals.RIneq.Rsqr (dot a1 a2 b1
  b2)) + (Reals.RIneq.Rsqr ((a1 * b2)%R - (a2 * b1)%R)%R))%R).

Axiom CauchySchwarz_aux : forall (x1:R) (x2:R) (y1:R) (y2:R),
  ((Reals.RIneq.Rsqr (dot x1 x2 y1 y2)) <= ((norm2 x1 x2) * (norm2 y1
  y2))%R)%R.

(* Why3 assumption *)
Definition norm (x1:R) (x2:R): R := (Reals.R_sqrt.sqrt (norm2 x1 x2)).

Axiom norm_pos : forall (x1:R) (x2:R), (0%R <= (norm x1 x2))%R.

Axiom sqr_le_sqrt : forall (x:R) (y:R), ((Reals.RIneq.Rsqr x) <= y)%R ->
  (x <= (Reals.R_sqrt.sqrt y))%R.

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 3; admit.

(* Why3 goal *)
Theorem CauchySchwarz : forall (x1:R) (x2:R) (y1:R) (y2:R), ((dot x1 x2 y1
  y2) <= ((norm x1 x2) * (norm y1 y2))%R)%R.
(* Why3 intros x1 x2 y1 y2. *)
intros x1 x2 y1 y2.
unfold norm.
rewrite <- R_sqrt.sqrt_mult.
apply sqr_le_sqrt.
ae.
ae.
ae.
Admitted.


Section club.

Variables Scottish RedSocks WearKilt Married GoOutSunday : Prop.

Hypothesis rule1 : ~ Scottish -> RedSocks.
Hypothesis rule2 : WearKilt \/ ~ RedSocks.
Hypothesis rule3 : Married -> ~ GoOutSunday.
Hypothesis rule4 : GoOutSunday <-> Scottish.
Hypothesis rule5 : WearKilt -> Scottish /\ Married.
Hypothesis rule6 : Scottish -> WearKilt.

Lemma NoMember : False.

tauto.

Qed.

End club.

Check NoMember.


Require Import Reals.
Require Import Flocq.Core.Core.
Require Import Gappa_tactic.
Open Scope R_scope.

Notation format :=
  (generic_format radix2 (FLT_exp (-1074) 53)).
Notation rnd :=
  (round radix2 (FLT_exp (-1074) 53) rndZR).

Goal
  forall a b : R,
  format a -> format b ->
  52 / 16 <= a <= 53 / 16 ->
  22 / 16 <= b <= 30 / 16 ->
  format (a - b).
Proof.
  intros a b Ha Hb Ia Ib.
  gappa.
Qed.


(* Definition of Salsa according to Bernstein's paper
"The Salsa20 family of stream ciphers", http://cr.yp.to/snuffle/salsafamily-20071225.pdf*)

Require Import compcert.lib.Coqlib.
Require Import Coq.Strings.String.
Require Import msl.Extensionality.
Require Import List. Import ListNotations.

Require Import compcert.lib.Integers.
Require Import sha.functional_prog.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetNaclBase. (*for bind, combinelist*)

Definition Step1 (x:list int): option (list int):=
match x with [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y3 := Int.xor x3 (Int.rol (Int.add x15 x11) (Int.repr 7)) in
 let y4 := Int.xor x4 (Int.rol (Int.add x0 x12) (Int.repr 7)) in
 let y9 := Int.xor x9 (Int.rol (Int.add x5 x1) (Int.repr 7)) in
 let y14 := Int.xor x14 (Int.rol (Int.add x10 x6) (Int.repr 7)) in
 Some [x0; x1; x2; y3;
       y4; x5; x6; x7;
       x8; y9; x10; x11;
       x12; x13; y14; x15]
| _ => None
 end.
Definition test1_in := map x2i
  ([ "61707865"; "04030201"; "08070605"; "0c0b0a09";
     "100f0e0d"; "3320646e"; "01040103"; "06020905";
     "00000007"; "00000000"; "79622d32"; "14131211";
     "18171615"; "1c1b1a19"; "201f1e1d"; "6b206574"])%string.
Definition test1_out1 := map x2i ([
"61707865"; "04030201"; "08070605"; "95b0c8b6";
"d3c83331"; "3320646e"; "01040103"; "06020905";
"00000007"; "91b3379b"; "79622d32"; "14131211";
"18171615"; "1c1b1a19"; "130804a0"; "6b206574"])%string.

Goal Step1 test1_in = Some(test1_out1). reflexivity. Qed.

Definition Step2 (x:list int): option (list int):=
match x with [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y2 := Int.xor x2 (Int.rol (Int.add x10 x14) (Int.repr 9)) in
 let y7 := Int.xor x7 (Int.rol (Int.add x15 x3) (Int.repr 9)) in
 let y8 := Int.xor x8 (Int.rol (Int.add x0 x4) (Int.repr 9)) in
 let y13 := Int.xor x13 (Int.rol (Int.add x5 x9) (Int.repr 9)) in
 Some [x0; x1; y2; x3;
       x4; x5; x6; y7;
       y8; x9; x10; x11;
       x12; y13; x14; x15]
| _ => None
 end.

Definition test1_out2 := map x2i ([
"61707865"; "04030201"; "dc64a31d"; "95b0c8b6";
"d3c83331"; "3320646e"; "01040103"; "a45e5d04";
"71572c6d"; "91b3379b"; "79622d32"; "14131211";
"18171615"; "bb230990"; "130804a0"; "6b206574"])%string.
Goal Step2 test1_out1 = Some(test1_out2). reflexivity. Qed.

Definition Step3 (x:list int): option (list int):=
match x with [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y1 := Int.xor x1 (Int.rol (Int.add x9 x13) (Int.repr 13)) in
 let y6 := Int.xor x6 (Int.rol (Int.add x14 x2) (Int.repr 13)) in
 let y11 := Int.xor x11 (Int.rol (Int.add x3 x7) (Int.repr 13)) in
 let y12 := Int.xor x12 (Int.rol (Int.add x4 x8) (Int.repr 13)) in
 Some [x0; y1; x2; x3;
       x4; x5; y6; x7;
       x8; x9; x10; y11;
       y12; x13; x14; x15]
| _ => None
 end.

Definition test1_out3 := map x2i ([
"61707865"; "cc266b9b"; "dc64a31d"; "95b0c8b6";
"d3c83331"; "3320646e"; "95f3bcee"; "a45e5d04";
"71572c6d"; "91b3379b"; "79622d32"; "f0a45550";
"f3e4deb6"; "bb230990"; "130804a0"; "6b206574"])%string.
Goal Step3 test1_out2 = Some(test1_out3). reflexivity. Qed.

Definition Step4 (x:list int): option (list int):=
match x with [x0; x1; x2; x3;  x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y0 := Int.xor x0 (Int.rol (Int.add x8 x12) (Int.repr 18)) in
 let y5 := Int.xor x5 (Int.rol (Int.add x13 x1) (Int.repr 18)) in
 let y10 := Int.xor x10 (Int.rol (Int.add x2 x6) (Int.repr 18)) in
 let y15 := Int.xor x15 (Int.rol (Int.add x7 x11) (Int.repr 18)) in
 Some [y0; x1; x2; x3;
       x4; y5; x6; x7;
       x8; x9; y10; x11;
       x12; x13; x14; y15]
| _ => None
 end.

Definition test1_out4 := map x2i ([
"4dfdec95"; "cc266b9b"; "dc64a31d"; "95b0c8b6";
"d3c83331"; "e78e794b"; "95f3bcee"; "a45e5d04";
"71572c6d"; "91b3379b"; "f94fe453"; "f0a45550";
"f3e4deb6"; "bb230990"; "130804a0"; "a272317e"])%string.
Goal Step4 test1_out3 = Some(test1_out4). reflexivity. Qed.

Definition transp (x:list int): option (list int):=
match x with [x0; x1; x2; x3;  x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=> Some [x0; x4; x8; x12;
         x1; x5; x9; x13;
         x2; x6; x10; x14;
         x3; x7; x11; x15]
| _ => None
 end.
Definition test1_out := map x2i ([
"4dfdec95"; "d3c83331"; "71572c6d"; "f3e4deb6";
"cc266b9b"; "e78e794b"; "91b3379b"; "bb230990";
"dc64a31d"; "95f3bcee"; "f94fe453"; "130804a0";
"95b0c8b6"; "a45e5d04"; "f0a45550"; "a272317e"])%string.
Goal transp test1_out4 = Some(test1_out). reflexivity. Qed.

Definition snuffleStep x :=
  bind (Step1 x) (fun y => bind (Step2 y) (fun z => bind (Step3 z) Step4)).

Definition snuffleRound x := bind (snuffleStep x) transp.

Goal snuffleRound test1_in = Some test1_out. reflexivity. Qed.

Definition test1_round2 := map x2i ([
"ba2409b1"; "1b7cce6a"; "29115dcf"; "5037e027";
"37b75378"; "348d94c8"; "3ea582b3"; "c3a9a148";
"825bfcb9"; "226ae9eb"; "63dd7748"; "7129a215";
"4effd1ec"; "5f25dc72"; "a6c3d164"; "152a26d8"])%string.
Goal snuffleRound test1_out = Some(test1_round2). reflexivity. Qed.

Fixpoint Snuffle n x :=
  match n with O => Some x | S m => bind (Snuffle m x) snuffleRound end.

Goal Snuffle 1 = snuffleRound. extensionality. reflexivity. Qed.
Goal Snuffle 2 test1_in = Some(test1_round2). reflexivity. Qed.

Definition test1_round20 := map x2i ([
"58318d3e"; "0292df4f"; "a28d8215"; "a1aca723";
"697a34c7"; "f2f00ba8"; "63e9b0a1"; "27250e3a";
"b1c7f1f3"; "62066edc"; "66d3ccf1"; "b0365cf3";
"091ad09e"; "64f0c40f"; "d60d95ea"; "00be78c9"])%string.
Goal Snuffle 20 test1_in = Some(test1_round20). reflexivity. Qed.

Lemma snuffleRound_length r l:
  snuffleRound r = Some l -> length l = 16%nat /\ length r = 16%nat.
Proof. intros.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H; inv H.
split; trivial.
Qed.

Lemma snuffleRound_Zlength r l (R: snuffleRound r = Some l):
      Zlength l = 16 /\ Zlength r = 16.
Proof.
  do 2 rewrite Zlength_correct.
  destruct (snuffleRound_length _ _ R) as [A B].
  rewrite A, B; split; reflexivity.
Qed.

Lemma Snuffle_length r: forall i l, Snuffle i r = Some l -> length r = 16%nat -> length l = 16%nat.
Proof. induction i; simpl; intros. inv H; trivial.
remember (Snuffle i r) as s. symmetry in Heqs; destruct s; inv H.
apply snuffleRound_length in H2. apply H2.
Qed.

Lemma Snuffle_Zlength r i l (SN:Snuffle i r = Some l)
      (R:Zlength r = 16): Zlength l= 16.
Proof.
  rewrite Zlength_correct.
  rewrite (Snuffle_length _ _ _ SN); trivial.
  apply sublist.Zlength_length in R; trivial.
Qed.
Opaque Snuffle.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cocartesian.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Structure.Initial.
Require Import Category.Structure.Terminal.
Require Import Category.Instance.Sets.

Generalizable All Variables.

(* The category of propositions. *)

Program Definition Props : Category := {|
  obj     := Prop;
  hom     := Basics.impl;
  (* By proof irrelevance, two statement P → Q of the same type are taken to
     always be the same implication. *)
  homset  := fun P Q => {| equiv := fun f g => True |};
  id      := fun _ x => x;
  compose := fun _ _ _ g f x => g (f x)
|}.

#[export]
Program Instance Props_Terminal : @Terminal Props := {
  terminal_obj := True;
  one := fun _ _ => I
}.

#[export]
Program Instance Props_Initial : @Initial Props := {
  terminal_obj := False;
  one := fun _ _ => False_rect _ _
}.

#[export]
Program Instance Props_Cartesian : @Cartesian Props := {
  product_obj := and;
  fork := fun _ _ _ f g x => conj (f x) (g x);
  exl  := fun _ _ p => proj1 p;
  exr  := fun _ _ p => proj2 p
}.

#[export]
Program Instance Props_Cocartesian : @Cocartesian Props := {
  product_obj := or;
  fork := fun _ _ _ f g x =>
            match x with
            | or_introl v => f v
            | or_intror v => g v
            end;
  exl  := fun _ _ p => or_introl p;
  exr  := fun _ _ p => or_intror p
}.

#[export]
Program Instance Props_Closed : @Closed Props _ := {
  exponent_obj := Basics.impl;
  exp_iso := fun _ _ _ =>
    {| to   := {| morphism := fun f a b => f (conj a b) |}
     ; from := {| morphism := fun f p => f (proj1 p) (proj2 p) |} |}
}.


Require Export Modal_syntax.
Require Import Coq.Arith.EqNat.

Fixpoint at_pv (l : list propvar) (i : nat) : propvar :=
  match l with
  | nil => (pv 1)
  | cons q l' => match i with
                 | S 0 => q
                 | 0 => (pv 1)
                 | _ => at_pv l' (i-1)
                 end
  end.

Lemma at_pv_app_cons : forall (l1 l2 : list propvar) (p : propvar),
  at_pv (app l1 (cons p l2)) (length l1 + 1) = p.
Proof.
  intros; induction l1.
  simpl; reflexivity.
  simpl in *.

  rewrite <- plus_n_Sm. simpl.
  rewrite plus_n_Sm. assumption.
Qed.

Lemma at_pv_app_l : forall (l1 l2 : list propvar) (i : nat),
  i <= (length l1) -> at_pv (app l1 l2) i = at_pv l1 i.
Proof.
  induction l1.
    simpl in *.
    induction l2; simpl in *; try reflexivity.
      intros i H.
      destruct i; try reflexivity.
      contradiction (PeanoNat.Nat.nle_succ_0 _ H).

      simpl app.
      intros l2 i H.
      case_eq i.
        intros Hi.
        simpl.
        reflexivity.

      simpl.
      intros n Hi.
      rewrite IHl1.
        reflexivity.

        simpl in H. rewrite PeanoNat.Nat.sub_0_r.
        rewrite Hi in H. apply le_S_n. assumption.
Qed.

Lemma at_pv_app_r : forall (l1 l2 : list propvar) (i : nat),
  i <> 0 ->  at_pv (app l1 l2) (length l1 + i) = at_pv l2 i.
Proof.
  intros l1 l2 i H.
  induction l1.
    simpl; reflexivity.

    simpl.
    case_eq (length l1 + i).
      intros H_eq. rewrite H_eq in IHl1. destruct l1.
        simpl in H_eq. subst. contradiction.
        discriminate.
      intros n H2.  simpl in *. rewrite <- H2; exact IHl1.
Qed.


Require Import Iron.Language.SimplePCF.Ty.
Require Export Iron.Language.SimplePCF.Exp.

(* Substitution of expressions in expressions preserves typing.
   Inductively, we must reason about performing substitutions at any
   depth, hence we must prove a property about (subst' d x2 x1) instead
   of the weaker (subst x2 x1) which assumes the substitution is taking
   place at top level. *)
Theorem subst_exp_exp_ix
 :  forall ix te x1 x2 t1 t2
 ,  get  ix te = Some t2
 -> TYPE te           x1 t1
 -> TYPE (delete ix te) x2 t2
 -> TYPE (delete ix te) (substX ix x2 x1) t1.
Proof.
 intros. gen ix te x2 t1.
 induction x1; rip; simpl; inverts H0; eauto.

 Case "XVar".
  fbreak_nat_compare; burn.
  SCase "n > ix".
   eapply TyVar.
   destruct n; burn.
    norm. nnat. down. apply get_delete_below. omega.

 Case "XLam".
  apply TyLam.
  rewrite delete_rewind.
  apply IHx1; burn using type_tyenv_weaken.

 Case "XFix".
  apply TyFix.
  rewrite delete_rewind.
  apply IHx1; burn using type_tyenv_weaken.
Qed.

Theorem subst_exp_exp
 :  forall te x1 x2 t1 t2
 ,  TYPE (te :> t2) x1 t1
 -> TYPE te         x2 t2
 -> TYPE te (substX 0 x2 x1) t1.
Proof.
  intros te x1 x2 t1 t2 Ht1 Ht2.
  lets H: subst_exp_exp_ix 0 (te :> t2).
  burn.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.QArith.QArith_base.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Crypto.Util.SideConditions.ReductionPackages.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Local Open Scope Z_scope.

Create HintDb dec2bool discriminated.

Lemma dec_Z_lt_to_bool a b
  : (if dec (a < b) then true else false) = Z.ltb a b.
Proof.
  destruct (Z.ltb a b) eqn:?; break_match; Z.ltb_to_lt; try reflexivity; lia.
Qed.
Hint Rewrite dec_Z_lt_to_bool : dec2bool.
Lemma dec_Z_le_to_bool a b
  : (if dec (a <= b) then true else false) = Z.leb a b.
Proof.
  destruct (Z.leb a b) eqn:?; break_match; Z.ltb_to_lt; try reflexivity; lia.
Qed.
Hint Rewrite dec_Z_le_to_bool : dec2bool.
Lemma dec_Z_eq_to_bool a b
  : (if dec (a = b) then true else false) = Z.eqb a b.
Proof.
  destruct (Z.eqb a b) eqn:?; break_match; Z.ltb_to_lt; try reflexivity; lia.
Qed.
Hint Rewrite dec_Z_eq_to_bool : dec2bool.
Lemma dec_nat_eq_to_bool a b
  : (if dec (a = b) then true else false) = Nat.eqb a b.
Proof.
  destruct (Nat.eqb a b) eqn:H; break_match; try reflexivity.
  { apply beq_nat_true in H; congruence. }
  { rewrite Nat.eqb_refl in H; congruence. }
Qed.
Hint Rewrite dec_nat_eq_to_bool : dec2bool.
Lemma dec_bool_eq_to_bool_if a b
  : (if dec (a = b :> bool) then true else false) = if b then a else negb a.
Proof.
  destruct a, b; reflexivity.
Qed.
Hint Rewrite dec_bool_eq_to_bool_if : dec2bool.
Lemma dec_not_negb {P} {H : Decidable P}
  : (if dec (not P) then true else false)
    = negb (if dec P then true else false).
Proof.
  do 2 edestruct dec; try reflexivity; tauto.
Qed.
Hint Rewrite @dec_not_negb : dec2bool.
Lemma dec_Q_le_to_bool a b
  : (if dec (a <= b)%Q then true else false) = Qle_bool a b.
Proof.
  destruct (Qle_bool a b) eqn:?; cbv [Qle Qle_bool] in *;
    break_match; Z.ltb_to_lt; try reflexivity; lia.
Qed.
Hint Rewrite dec_Q_le_to_bool : dec2bool.
Lemma dec_True_to_bool
  : (if dec True then true else false) = true.
Proof. reflexivity. Qed.
Hint Rewrite dec_True_to_bool : dec2bool.
Lemma dec_False_to_bool
  : (if dec False then true else false) = false.
Proof. reflexivity. Qed.
Hint Rewrite dec_False_to_bool : dec2bool.
Lemma dec_ifb_to_bool {b : bool} {A B} {HA : Decidable A} {HB : Decidable B}
  : (if dec (if b then A else B) then true else false)
    = if b then (if dec A then true else false) else (if dec B then true else false).
Proof. destruct b; reflexivity. Qed.
Hint Rewrite @dec_ifb_to_bool : dec2bool.
Lemma dec_and_to_bool {A B} {HA : Decidable A} {HB : Decidable B}
  : (if dec (A /\ B) then true else false)
    = andb (if dec A then true else false) (if dec B then true else false).
Proof. do 3 edestruct dec; try reflexivity; tauto. Qed.
Hint Rewrite @dec_and_to_bool : dec2bool.
Lemma dec_or_to_bool {A B} {HA : Decidable A} {HB : Decidable B}
  : (if dec (A \/ B) then true else false)
    = orb (if dec A then true else false) (if dec B then true else false).
Proof. do 3 edestruct dec; try reflexivity; tauto. Qed.
Hint Rewrite @dec_or_to_bool : dec2bool.
Lemma dec_fieldwise_to_bool {A B R n} {H : forall x y, Decidable (R x y)} x y
  : (if dec (@Tuple.fieldwise A B n R x y) then true else false)
    = @Tuple.fieldwiseb A B n (fun x y => if dec (R x y) then true else false) x y.
Proof.
  destruct (dec _) as [H'|H'].
  { symmetry; rewrite Tuple.fieldwiseb_fieldwise; [ eassumption | ].
    intros; edestruct dec; split; auto; discriminate. }
  { destruct (Tuple.fieldwiseb _ _ _) eqn:H''; [ | reflexivity ].
    rewrite Tuple.fieldwiseb_fieldwise in H''.
    { exfalso; apply H', H''. }
    { intros; edestruct dec; split; auto; discriminate. } }
Qed.
Hint Rewrite @dec_fieldwise_to_bool : dec2bool.
Lemma dec_tuple_eq_to_bool T {H : DecidableRel (@eq T)} n (x y : Tuple.tuple T n)
  : (if dec (x = y) then true else false) = Tuple.fieldwiseb (fun x y => if dec (x = y) then true else false) x y.
Proof.
  destruct (dec _) as [H'|H'], (Tuple.fieldwiseb _ _ _) eqn:H''; try reflexivity;
    rewrite <- Tuple.fieldwise_eq_iff in H';
    first [ exfalso; rewrite Tuple.fieldwiseb_fieldwise in H''
          | rewrite <- H''; clear H''; symmetry; rewrite Tuple.fieldwiseb_fieldwise ];
    try eassumption; eauto; intros; destruct dec; split; auto; congruence.
Qed.
Hint Rewrite dec_tuple_eq_to_bool : dec2bool.

Require Import Crypto.Util.ListUtil.Forall.
Lemma dec_Forall_to_bool {A P} {H : forall x, Decidable (P x)} ls
  : (if dec (@Forall A P ls) then true else false)
    = Forallb (fun x => if dec (P x) then true else false) ls.
Proof.
  destruct (dec _) as [H'|H'], (Forallb _ _) eqn:H'';
    try reflexivity; [ symmetry; rewrite <- H''; clear H'' | exfalso; apply H' ];
      [ rewrite Forall_Forallb_iff; [ eassumption | ]
      | rewrite <- Forall_Forallb_iff; [ eassumption | ] ];
      intros; cbv beta; destruct (dec _); intuition; try congruence.
Qed.
Hint Rewrite @dec_Forall_to_bool : dec2bool.

Ltac dec2bool_split_hyp H :=
  lazymatch type of H with
  | _ /\ _ => destruct H as [H _]; dec2bool_split_hyp H
  | andb _ _ = true => apply Bool.andb_true_iff in H; destruct H as [H _]; dec2bool_split_hyp H
  | ?e = true => is_evar e; apply Bool.andb_true_iff in H; destruct H as [_ H]
  end.

Ltac premake_parameter_package _ :=
  let H := fresh in
  eexists; intro H;
  unshelve econstructor;
  repeat match goal with
         | [ |- context[cbv_minus_then_vm_decide_package ?x ?y] ]
           => change (cbv_minus_then_vm_decide_package x y) with (vm_decide_package y)
         | [ |- context[vm_compute_reflexivity_package ?x] ]
           => change (vm_compute_reflexivity_package ?x) with (vm_decide_package x)
         end;
  autounfold with dec2bool;
  repeat autorewrite with dec2bool.
Ltac push_dec_to_hyps precheck :=
  let rec check R :=
      lazymatch R with
      | Z.ltb _ _ => idtac
      | Z.leb _ _ => idtac
      | Z.eqb _ _ => idtac
      | Qle_bool _ _ => idtac
      | Nat.eqb _ _ => idtac
      | negb ?b => check b
      | true => idtac
      | false => idtac
      | match ?b with true => ?a | false => ?c end
        => check a; check b; check c
      | andb ?a ?b => check a; check b
      | orb ?a ?b => check a; check b
      | (fun (a : ?A) => ?R)
        => let dummy := constr:(fun (a : A) =>
                                  let R' := R in
                                  ltac:(let R'' := (eval cbv beta delta [R'] in R') in
                                        check R'';
                                        exact I)) in
           idtac
      | ?R => precheck R
      end in
  repeat lazymatch goal with
         | [ |- vm_decide_package (Tuple.fieldwiseb _ _ _ = true) ]
           => cbv [vm_decide_package];
              rewrite Tuple.fieldwiseb_fieldwise, <- Tuple.fieldwiseb_fieldwise
                by (intros; autorewrite with dec2bool; apply reflexivity)
         | [ |- vm_decide_package (Forallb _ _ = true) ]
           => cbv [vm_decide_package];
              rewrite Forall_Forallb_iff, <- Forall_Forallb_iff
                by (intros; autorewrite with dec2bool; apply reflexivity)
         | [ H : ?e = true |- vm_decide_package (?R = true) ]
           => check R; dec2bool_split_hyp H; cbv [vm_decide_package]; exact H
         | [ H : ?e = true |- Tuple.fieldwiseb ?R ?t1 ?t2 = true ]
           => check (fun a b => R a b); dec2bool_split_hyp H; cbv [vm_decide_package]; exact H
         | [ H : ?e = true |- Forallb ?R ?ls = true ]
           => check (fun a => R a); dec2bool_split_hyp H; cbv [vm_decide_package]; exact H
         end.
Ltac make_parameter_package_for_vm_decide precheck :=
  premake_parameter_package ();
  unshelve (push_dec_to_hyps precheck);
  exact true.


(* Order of imports: import proofmode after utils after robinson *)

From FOL Require Import FullSyntax Arithmetics.

From FOL.Incompleteness Require Import fol_utils qdec.
From FOL.Proofmode Require Import Theories ProofMode.

Require Import Lia.
Require Import String.

Open Scope string_scope.
(* ** Sigma1 completeness *)

Section Sigma1.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Context {p : peirce}.

  (* #  #*)
  Inductive Σ1 : form -> Prop :=
  | Sigma_exists : forall α, Σ1 α -> Σ1 (∃ α)
  | Sigma_Delta : forall α, Qdec α -> Σ1 α.
  Inductive Π1 : form -> Prop :=
  | Pi_forall : forall α, Π1 α -> Π1 (∀ α)
  | Pi_Delta : forall α, Qdec α -> Π1 α.

  Lemma Σ1_subst φ ρ : Σ1 φ -> Σ1 φ[ρ].
  Proof.
    induction 1 as [α H IH | α H] in ρ |-*.
    - cbn. constructor. apply IH.
    - constructor. apply Qdec_subst, H.
  Qed.

  Lemma Π1_subst φ ρ : Π1 φ -> Π1 φ[ρ].
  Proof.
    induction 1 as [α H IH | α H] in ρ |-*.
    - cbn. constructor. apply IH.
    - constructor. apply Qdec_subst, H.
  Qed.

  Lemma exist_times_Σ1 n φ :
    Σ1 φ -> Σ1 (exist_times n φ).
  Proof.
    intros H. induction n.
    - easy.
    - now constructor.
  Qed.

  Lemma exists_compression_2 φ n : Qdec φ -> bounded (S (S n)) φ -> exists ψ, Qdec ψ /\ bounded (S n) ψ /\ Qeq ⊢ (∃∃φ) ↔ (∃ψ).
  Proof.
    intros HQ Hb.
    exists (∃ ($0 ⧀= $1) ∧ ∃ ($0 ⧀=' $2) ∧ φ[up (up (S >> var))]).
    repeat split.
    { apply (@Qdec_bounded_exists $0), (@Qdec_bounded_exists_comm $1).
      apply Qdec_subst, HQ. }
    { repeat solve_bounds.
      eapply subst_bounded_max; last eassumption.
      intros n' H'.
      destruct n' as [|[|n']]; cbn; unfold "↑"; cbn; constructor; lia. }
    fstart. fsplit.
    - fintros "[x [y H]]". fexists (x ⊕ y).
      fexists x. fsplit.
      { fexists y. fapply ax_refl. }
      fexists y. fsplit.
      { fexists x. fapply ax_refl. }
      asimpl. ctx.
    - fintros "[z [x [Hx [y [Hy H]]]]]".
      fexists x. fexists y.
      asimpl. ctx.
  Qed.

  Lemma exists_compression φ k n : bounded (n + k) φ -> Qdec φ ->
    exists ψ, Qdec ψ /\ bounded (S k) ψ /\ Qeq ⊢ exist_times n φ ↔ ∃ ψ.
  Proof.
    intros Hb HQ. revert Hb. induction n as [|n IH] in k |-*.
    2: destruct n. all: cbn.
    all: intros Hb.
    - exists φ[↑]. repeat split.
      { now apply Qdec_subst. }
      { eapply subst_bounded_max; last apply Hb. intros n H. constructor. lia. }
      fsplit.
      + fintros. fexists zero. ctx.
      + fintros. fdestruct 0. ctx.
    - exists φ. repeat split.
      + assumption.
      + cbn. replace (k - 0) with k by lia. assumption.
      + fsplit; fintros; ctx.
    - destruct (IH (S k)) as (ψ & HQ' & Hb' & H).
      { now replace (S n + S k) with (S (S n) + k) by lia. }
      edestruct (@exists_compression_2 ψ) as (ψ' & HΔψ & Hbψ' & Hψ).
      1-2: eassumption.
      exists ψ'. repeat split; try easy. cbn in H.
      fsplit; fstart.
      + fintros "[x H]".
        fapply Hψ. fexists x.
        apply subst_Weak  with (xi := x..) in H.
        cbn in H. fapply H. ctx.
      + fintros "H". fapply Hψ in "H".
        fdestruct "H" as "[x H]". fexists x.
        apply subst_Weak  with (xi := x..) in H.
        fapply H. ctx.
  Qed.

  Lemma Σ1_exist_times φ : Σ1 φ -> exists n ψ, Qdec ψ /\ φ = exist_times n ψ.
  Proof.
    induction 1 as [φ H (n & ψ & HΔ & Hψ)|φ H].
    - exists (S n), ψ. now rewrite Hψ.
    - now exists 0, φ.
  Qed.

  Lemma bounded_exist_times φ n k : bounded (n + k) φ <-> bounded k (exist_times n φ).
  Proof.
    induction n in k |-*; split.
    - easy.
    - easy.
    - cbn. intros H. constructor. apply IHn. replace (n + S k) with (S n + k) by lia. apply H.
    - cbn. invert_bounds. replace (S (n + k)) with (n + (S k)) by lia. now apply IHn.
  Qed.
End Sigma1.

Section Sigma1.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  (* Note that we get the equivalence proof intuitionistically, even though the Sigma 1 proof might be classical *)
  Context {p : peirce}.

  (* #  #*)
  Lemma Σ1_compression φ n : bounded n φ -> Σ1 φ -> exists ψ, Qdec ψ /\ bounded (S n) ψ /\ Qeq ⊢I φ ↔ ∃ψ.
  Proof.
    intros Hb (k & ψ & HΔ & ->)%Σ1_exist_times.
    destruct (@exists_compression intu ψ n k) as (ψ' & HΔ' & Hb' & H').
    all: firstorder using bounded_exist_times.
  Qed.
End Sigma1.

Section Sigma1completeness.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Existing Instance intu.

  Lemma Σ1_completeness_intu φ : Σ1 φ -> bounded 0 φ -> interp_nat ⊨= φ -> Qeq ⊢ φ.
  Proof.
    enough (forall ρ, Σ1 φ -> bounded 0 φ[ρ] -> interp_nat ⊨= φ[ρ] -> Qeq ⊢ φ[ρ]).
    { intros HΣ Hb Hsat. rewrite <-subst_var. apply H.
      - easy.
      - now rewrite subst_var.
      - intros ρ'. rewrite subst_var. apply Hsat. }
    intros ρ. induction 1 as [φ H IH|φ H] in ρ |-*.
    - cbn. invert_bounds.
      intros Hnat. destruct (Hnat (fun _ => 0)) as [d Hd].
      fexists (num d). rewrite subst_comp. apply IH.
      + rewrite <-subst_comp. eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
      + intros ρ'. rewrite <-subst_comp.
        rewrite sat_single_nat in Hd.
        eapply sat_closed; last apply Hd.
        eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
    - intros Hb Hnat.
      assert (Qdec φ[ρ]) as H'.
      { apply Qdec_subst, H. }
      destruct (H' intu (fun _ => zero)) as [H1|H1].
      { intros _. solve_bounds. }
      + rewrite bounded_0_subst in H1; assumption.
      + eapply soundness in H1. cbn in H1. unfold valid_ctx in H1.
        specialize (H1 _ interp_nat (fun _ => 0) (nat_is_Q_model _)).
        cbn in H1. destruct H1. rewrite bounded_0_subst; auto.
  Qed.

End Sigma1completeness.

Section conservativity.

  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Lemma Σ1_conservativity ϕ :
    Σ1 ϕ -> bounded 0 ϕ -> Qeq ⊢C ϕ -> Qeq ⊢I ϕ.
  Proof.
    intros S1 Hcl Htc.
    destruct (Σ1_compression Hcl S1) as [α (dec_α & b1_α & Hα)].
    assert (bounded 0 (∃ α)) as b0_α by (now solve_bounds).
    eapply IE with (∃ α).
    1: eapply CE2; apply Hα.
    apply Σ1_completeness_intu; auto.
    1: do 2 constructor; auto.
    assert (Qeq ⊢C ∃ α) as H.
    { eapply IE with ϕ; auto.
      apply prv_intu_peirce.
      eapply CE1. apply Hα. }
    apply Fr_cl_to_min, soundness in H.
    refine (let H' := H nat (extend_interp interp_nat _) (fun _ => 0) _ in _).
    cbn in H'; apply H'. clear H H'.
    intros [n Hn].
    destruct (dec_α intu (fun _ => num n)) as [H|H].
    - intro. apply num_bound.
    - exists n. apply soundness in H.
      eapply sat_single_nat.
      erewrite bounded_subst.
      + apply H, nat_is_Q_model.
      + eauto.
      + intros []; [reflexivity|lia].
    - eapply prv_intu_peirce in H.
      apply Fr_cl_to_min, soundness in H.
      refine (let H' := H nat (extend_interp interp_nat _) (fun _ => 0) _ in _).
      cbn in H'. apply H'; clear H H'.
      rewrite <-subst_Fr. apply sat_comp.
      eapply bound_ext with (N:=1).
      3 : apply Hn.
      { now apply bounded_Fr. }
      intros []; [intros _;cbn|lia].
      apply nat_eval_num.
      Unshelve. all: apply nat_sat_Fr_Q.
  Qed.

  Context `{pei : peirce}.

  Lemma Σ1_soundness ϕ :
    Σ1 ϕ -> bounded 0 ϕ -> Qeq ⊢ ϕ -> interp_nat ⊨= ϕ.
  Proof.
    intros HΣ Hb Hϕ. intros ρ.
    destruct pei eqn:H; eapply soundness.
    - apply Σ1_conservativity.
      * congruence.
      * assumption.
      * assumption.
    - apply nat_is_Q_model.
    - apply Hϕ.
    - apply nat_is_Q_model.
  Qed.

End conservativity.

Section Sigma1completeness.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Context `{pei : peirce}.

  (* #  #*)
  Theorem Σ1_completeness φ : Σ1 φ -> bounded 0 φ -> interp_nat ⊨= φ -> Qeq ⊢ φ.
  Proof.
    destruct pei; last apply Σ1_completeness_intu.
    enough (forall ρ, Σ1 φ -> bounded 0 φ[ρ] -> interp_nat ⊨= φ[ρ] -> Qeq ⊢C φ[ρ]).
    { intros HΣ Hb Hsat. rewrite <-subst_var. apply H.
      - easy.
      - now rewrite subst_var.
      - intros ρ'. rewrite subst_var. apply Hsat. }
    intros ρ. induction 1 as [φ H IH|φ H] in ρ |-*.
    - cbn. invert_bounds.
      intros Hnat. destruct (Hnat (fun _ => 0)) as [d Hd].
      remember intu as Hintu. (* for proof mode *)
      fexists (num d). rewrite subst_comp. apply IH.
      + rewrite <-subst_comp. eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
      + intros ρ'. rewrite <-subst_comp.
        rewrite sat_single_nat in Hd.
        eapply sat_closed; last apply Hd.
        eapply subst_bounded_max; last apply H4.
        intros [|n] Hn; last lia. apply num_bound.
    - intros Hb Hnat.
      assert (@Qdec φ[ρ]) as H'.
      { apply Qdec_subst, H. }
      destruct (H' class (fun _ => zero)) as [H1|H1].
      { intros _. solve_bounds. }
      all: rewrite bounded_0_subst in H1; try eassumption.
      contradict Hnat.
      apply Σ1_soundness with (p := fun _ => 0) in H1.
      + cbn in H1. contradict H1. apply H1.
      + constructor. apply Qdec_impl.
        * assumption.
        * apply Qdec_bot.
      + now solve_bounds.
  Qed.

  (* #  #*)
  Theorem Σ1_witness φ : Σ1 φ -> bounded 1 φ -> Qeq ⊢ ∃φ -> exists x, Qeq ⊢ φ[(num x)..].
  Proof.
    intros Hb HΣ Hφ. eapply Σ1_soundness with (p := fun _ => 0) in Hφ as [x Hx].
    exists x. eapply Σ1_completeness.
    - now apply Σ1_subst.
    - eapply subst_bounded_max; last eassumption.
      intros [|n] H; last lia. apply num_bound.
    - intros ρ. rewrite sat_single_nat in Hx.
      eapply sat_closed; last eassumption.
      eapply subst_bounded_max; last eassumption.
      intros [|n] H; lia + apply num_bound.
    - now constructor.
    - now constructor.
  Qed.

End Sigma1completeness.


Require Import Format.
Require Import Doc.

Require Import ZArith Int.
Require Import Coq.Lists.List.
Require Import String.

Fixpoint get_min_height (lst : list t) (w: nat) (res: option nat) :=
  match lst with
  | nil => res
  | hd :: tl => if total_width hd <=? w
                then match res with
                     | Some n => get_min_height tl w (Some (min n hd.(height)))
                     | None => get_min_height tl w (Some hd.(height))
                     end
                else get_min_height tl w res
  end.

Definition pick_best_list (lst : list t) (w: nat) :=
  match lst with
  | nil => nil
  | _   =>  match get_min_height lst w None with
            | None   => nil
            | Some n => filter
                          (fun f => andb (total_width f <=? w) (f.(height) =? n))
                          lst
            end
  end.

Definition pretty_list (docToVar: nat -> Doc -> list t) (width: nat) (doc: Doc) :=
  pick_best_list (docToVar width doc) width.


Unset Implicit Arguments.
Definition CN:= Set.

Parameters  Swede Scandinavian Man Human Report Nobel_Prize Woman Animal Object Delegate Survey: CN.

(** Quantifier some and letting a be some**)
Definition some:= fun A:CN=> fun P:A->Prop=> exists  x, P(x).
Let a:= some.
(**the as regarding an object of type A**)
Parameter the: forall A:CN, A.

(**Declaring subtyping relations**)
Axiom ro: Report->Object. Coercion ro: Report>-> Object.
Axiom no1: Nobel_Prize -> Object. Coercion no1: Nobel_Prize>-> Object.
Axiom mh : Man->Human. Coercion mh : Man >-> Human.
Axiom wh : Woman->Human. Coercion wh : Woman >-> Human.
Axiom ha: Human-> Animal. Coercion ha: Human>-> Animal.
Axiom ao: Animal->Object. Coercion ao: Animal>-> Object.
Axiom sh: Scandinavian->Human. Coercion sh: Scandinavian>->Human.
Axiom ss: Swede->Scandinavian. Coercion ss: Swede>-> Scandinavian.
Axiom dh:Delegate->Human. Coercion dh: Delegate>->Human.
Axiom so: Survey->Object. Coercion so:Survey>->Object.
(**adjectives, single predicate type**)
Parameter Irish scandinavian: Human -> Prop.
(** the two won entries**)
Parameter Won:Object->Human->Prop.
Parameter Won2:((Object->Prop)->Prop)->Human->Prop.

(**adjectival modification as sigmas, here dependent records**)
Record Irishdelegate : CN := mkIrishdelegate { c :> Delegate; C : Irish c }.
Record Scandinaviandelegate : CN := mkScandinaviandelegate { e :> Delegate; E : scandinavian e }.
Check mkIrishdelegate.

(**Adverb**)
Set Implicit Arguments.
Parameter On_time: forall A:CN, (A->Prop)->(A->Prop).
Parameter finish: Object->Human->Prop.
Unset Implicit Arguments.

(** A yes case: some IDs finish the survey on time-> some Ds finish the survey on time**)
Theorem IRISH: (some Irishdelegate(On_time(finish(the Survey)))->(some Delegate)(On_time (finish(the Survey)))).
cbv. intro. elim H. intros. exists x. apply H0.  Qed.
  (** Another YES example, note that FraCaS gives an extra premise: Every Swede is Scandinavian. This is not needed, the subtyping takes care of it**)
  Theorem SWEDE1: (a Swede)(Won2 (a Nobel_Prize))->(a  Scandinavian (Won2(a Nobel_Prize))).
    cbv. intros. elim H. intros. exists x. assumption. Qed.
  (**Introducing Variables for types swede and nobel_prize. you can do this for evey type if we wanted**)
 Variables s1 s2: Swede.
 Variables n1 n2: Nobel_Prize.

 (**The SWEDE case with no type lifting**)
  Theorem SWEDE2: exists x:Swede, exists y:Nobel_Prize, Won(y)(x)->exists x:Scandinavian, exists y:Nobel_Prize, Won(y)(x).
    (**eauto fails**)
    exists s1. exists n1. intro. exists s1. exists n1. assumption. Qed.
Definition no:= fun A:CN=>  fun P: A->Prop=>  not (exists x: A,  P x).
(** A NO example: no delegate finished the report on time->some scandinavian delegate finished the report on time.**)
Theorem SCANDEL: (no Delegate)(On_time (finish(the Report)))->not((some Scandinaviandelegate)(On_time (finish(the Report)))).
  cbv. intro. intro. elim H0. intro. intro.  apply H. exists x. assumption. Qed.

Theorem IRISHDEL: (some Delegate)(On_time (finish(the Survey)))->(some Irishdelegate)(On_time (finish(the Survey))). cbv. intros. elim H. intros. (**exists x.**) Abort all. (**This cannot be proven, neither its negation. You can try the negation yourselves if you do not trust me!**)

                       (**Veridical Adverbs**)
Set  Implicit Arguments.
Parameter ADV: forall (A : CN) (v : A -> Prop),sigT  (fun p : A -> Prop =>
 forall x : A, p x -> v x).
Definition on_time:= fun A:CN=> fun v:A->Prop=> projT1 (ADV(v)).

Theorem IRISH2: (some Delegate)(on_time(finish(the Survey)))->(some Delegate)((finish(the Survey))).
  cbv. destruct ADV. intro. elim  H. intros. exists x0. apply f.  assumption. Qed.

                  (**Sentence adverb veridicality**)
Parameter ADVS: forall ( v : Prop), sigT  (fun p : Prop => p  ->  v).
Definition fortunately:= fun v:Prop=>projT1 (ADVS v).

Parameter walk: Human -> Prop.
Parameter John: Man.

Theorem ADVSVER: fortunately (walk John)-> walk John. cbv. destruct ADVS. assumption. Qed.

(**some non-compositionality (playing no role in the proofs though**)
Parameter in_Europe: forall A:CN, (A->Prop)->(A->Prop).
Parameter right_to_live_in_Europe: CN.
Axiom roo: right_to_live_in_Europe-> Object. Coercion roo:right_to_live_in_Europe >-> Object.
Parameter can: forall A:CN, (A->Prop)->(A->Prop).
Parameter travel: Object->Prop.
Parameter freely: forall A:CN, (A->Prop)->(A->Prop).
Parameter within_Europe: forall A:CN, (A->Prop)->(A->Prop).
Unset Implicit Arguments.
Let each:= all.
Parameter European: CN.
Axiom eh:  European -> Human. Coercion eh: European >-> Human.
Parameter have: Object->Human->Prop.
Let person:= Human.
	Theorem EUROPEAN: ((each European)(have
(the right_to_live_in_Europe))/\forall x:person, ((have
				(the right_to_live_in_Europe)x)->can (within_Europe(freely
				(travel)))x))->(each European)(can (within_Europe(freely
				(travel)))). cbv. intros. elim H. intros. elim H. intros. apply H3. apply H2. Qed.


(*|
###########################################################################################
How to extract the witness from ``exists`` in Coq in function notation/without destructing?
###########################################################################################

:Link: https://proofassistants.stackexchange.com/q/1331
|*)

(*|
Question
********

Assuming I have some definition with a ``forall`` and an ``exists``
like so:
|*)

Definition fooable A B P := forall a : A, exists b : B, P a b.

(*|
Then on an intuitive level, I can for each ``(a : A)`` find a ``(b :
B)`` such that ``(P a b)`` holds, so it stands to reason that I can
build a function that generates the ``b`` from the ``a``. As Coq is
constructive, there has to be a witness for the ``b`` if I have
evidence for ``fooable``, so I am trying to define this function:
|*)

Definition fooify A B P (H : fooable A B P) : A -> B.

(*|
Using ``fun a => H a`` to get rid of the ``forall`` is easy enough,
but how can I extract the witness from the ``exists`` here? I've also
tried writing it as a proof and ``destruct``\ ing the ``exists``, but
as the goal is a ``Type``, not a ``Prop``, ``destruct`` errors.
|*)

(*|
Answer (Andrej Bauer)
*********************

In mathematics there are *two* kinds of existence:

1. The **concrete** or **informative existence** happens when we show
   that something exists by constructing a specific instance, which is
   then available.
2. The **abstract** or **non-informative existence** happens when we
   know that something exists by indirect means, or because the
   constucted witness has been hidden away from us by some mechanism.

An example that students come accross is this:

    **Theorem:** *There is a non-computable function*
    :math:`f:\mathbb{N} \rightarrow \mathbb{N}`.

*Abstract existence proof:* there are uncountably many function
:math:`\mathbb{N} \rightarrow \mathbb{N}` but only countably many
Turing machines, therefore some functions must be non-computable.
:math:`\square`

*Concrete existence proof:* we claim that the function
:math:`h:\mathbb{N} \rightarrow \mathbb{N}` defined by

.. math::

    h(n) = \begin{cases}
      1, \mbox{ if $n$-th Turing machine halts on input $n$}
      \\
      0, \mbox{ otherwise}.
    \end{cases}

is not computable. (Insert here the standard proof that :math:`h` is
not-computable.) :math:`\square`

I hope this conveys the idea clearly enough. First-order logic only
expresses the abstract existence. Martin-Löf type theory only
expresses the concrete existence.

Coq can express *both* kinds of existence. The abstract one is
``exists`` and the concrete one is ``sig``. So if you want to actually
extract witnesses, then you should be using ``sig``, not ``exists``.

In Coq ``sig (fun (x : A) => P x)`` is written in the more readable
notation ``{x : A | P x}``. Here is the extraction function you asked
for:
|*)

Definition extract {A B : Type} (P : A -> B -> Prop) :
  (forall a, { b : B | P a b }) -> { f : A -> B | forall a, P a (f a) } :=
  fun g => exist (fun f => forall a, P a (f a))
                 (fun a => proj1_sig (g a))
                 (fun a => proj2_sig (g a)).

(*|
It is possible to do violence to Coq and extract functions from the
wrong existence by postulating various choice principles (as in
`Coq.Logic.ChoiceFacts
<https://coq.inria.fr/library/Coq.Logic.ChoiceFacts.html>`__), but
it's just better to use the correct form of existence.

P.S. The difference between informative and non-informative facts
extends to all of logic and is not specific to existence. We may
distinguish between *informative* facts, where knowing a fact also
gives us the ability to inspect the *reason* for knowing it, and the
*non-informative* facts, where we simply know a fact, but have no
access to any reason as to why the fact holds. In Coq the
non-informative facts are in ``Prop``, whereas the informative ones
are in ``Type``.
|*)

(*|
Answer (kyo dralliam)
*********************

Extracting a function from a ``forall``/``exists`` statement is a
choice principle not derivable in Coq (at least not without axioms).
More precisely, this extraction could be derived out of
``FunctionalChoice_on`` (to get the existence of a function out of the
``forall``/``exists``) and ``ConstructiveIndefiniteDescription_on``
(to actually extract a function witnessing the existential) from the
module `Coq.Logic.ChoiceFacts
<https://coq.inria.fr/library/Coq.Logic.ChoiceFacts.html>`__ in the
"standard" library. That file also discuss in length the subtle
relationship between many different types of choice axioms.

----

**A:** Alternatively, you could replace the propositional existential
(``ex``) with one in ``Type`` (``sig``), from which you can extract a
function without any axiom.
|*)

(*|
Answer (Molossus Spondee)
*************************

As previously mentioned extracting a value from an existential is a
choice principle.

You can however extract a ``Prop`` or type squashed to ``Prop``.

The usual impredicative encoding of squashing is
|*)

Definition squash (A : Type) : Prop := forall B : Prop, (A -> B) -> B.

(*| But this can be a little awkward |*)

Reset Initial. (* .none *)
Variant squash (A : Type) : Prop :=
  | squash_intro : A -> squash A.

(*|
Is also awkward.

Writing the function
|*)

Definition proj_ex1 {A} {P : A -> _} : (exists x : A, P x) -> squash A.

(*|
Is then pretty simple.

Coq is pretty bare bones in terms of standard library and as far as I
know doesn't offer a version of ``squash`` or ergonomic tools for
working with it. (Edit: use ``inhabited``.) ``squash`` is
straightforwardly a monad and an applicative functor.

I generally find it easier to rework things to be in ``Set`` or
``Type`` instead of working around ``Prop`` though myself.

----

**A:** Coq does have a ``squash``. It is
|*)

Print inhabited. (* .unfold .messages *)

(*| and should be imported by default. |*)