From Coq Require Import String Bool Datatypes Relations Program.Equality Classes.RelationClasses.
From SymEx Require Import Expr Maps.
Import BasicExpr BasicMaps.

Inductive trace (A : Type) : Type :=
| Tnil : trace A
| Tcons : trace A -> A -> trace A.

Arguments Tnil {A}.
Arguments Tcons {A} a l.

Declare Scope trace_scope.
Infix "::" := Tcons (at level 60, right associativity) : trace_scope.
Notation "[ ]" := Tnil (format "[ ]") : trace_scope.
Notation "[ x ]" := (Tcons Tnil x) : trace_scope.
Notation "[ x ; .. ; y ; z ]" := (Tcons (Tcons .. (Tcons Tnil x) .. y) z)
  (format "[ '[' x ; '/' .. ; '/' y ; '/' z ']' ]") : trace_scope.

Open Scope trace_scope.

Lemma cons_eq {A:Type} (x y:trace A) : forall a b, x::a = y::b -> x = y /\ a = b.
Proof. intros. induction x; inversion H; subst; split; reflexivity. Qed.

Fixpoint app {A:Type} (xs ys:trace A) : trace A :=
  match ys with
  | [] => xs
  | ys :: y => (app xs ys) :: y
  end.

Notation "x '++' y" := (app x y) : trace_scope.

Theorem app_nil_l {A:Type} (x:trace A) : [] ++ x = x.
Proof. induction x. reflexivity. simpl. rewrite IHx. reflexivity. Qed.

Theorem app_nil_r {A:Type} (x:trace A) : x ++ [] = x.
Proof. reflexivity. Qed.

Theorem app_comm_cons {A:Type} (a:A) (x y:trace A) : (x ++ y) :: a = x ++ (y :: a).
Proof. reflexivity. Qed.

Theorem app_assoc {A:Type} (x y z:trace A) : x ++ y ++ z = (x ++ y) ++ z.
Proof.
  induction z.
  - reflexivity.
  - simpl. rewrite IHz. reflexivity.
Qed.

Lemma cons_not_empty {A:Type} (a:A) (t:trace A) : t :: a <> [].
Proof.
  intros. induction t.
  - discriminate.
  - discriminate.
Qed.

Lemma not_empty_cons {A:Type} (t:trace A) : t <> [] -> exists a t', t = t'::a.
Proof.
  intros. destruct t.
  - exfalso. apply H. reflexivity.
  - exists a. exists t. reflexivity.
Qed.

Theorem app_eq_nil {A:Type} (x y:trace A) : x ++ y = [] -> x = [] /\ y = [].
Proof.
  induction y; induction x; intro; split;
    try (rewrite app_nil_r in H);
    try (rewrite app_nil_l in H);
    try reflexivity;
    try assumption;
    discriminate.
Qed.

Theorem cons_neq {A:Type} (x:trace A) (y:A) : x::y <> x.
Proof. induction x.
       - apply cons_not_empty.
       - intro. inversion H; subst. exact (IHx H1).
Qed.

Theorem cons_neq' {A:Type} (x:trace A) (y:A) : x <> x::y.
Proof. intro. symmetry in H. exact (cons_neq _ _  H). Qed.

Lemma peel_off' {A:Type} (t:trace A) (a:A) : exists x t', t::a = [x] ++ t'.
Proof.
  intros. induction t.
  - exists a. exists []. reflexivity.
  - destruct IHt as [x [t' IH]]. destruct t'; inversion IH; subst.
    + exists a0. exists [x]. reflexivity.
    + exists x. exists ((t' :: a0 ):: a1). reflexivity.
Qed.

Theorem peel_off {A:Type} (t:trace A) : t <> [] -> exists x t', t = [x] ++ t'.
Proof.
  intros. destruct (not_empty_cons _ H) as [x [t' H']].
  rewrite H'. apply peel_off'.
Qed.

(* generic equivalence stuff *)
Inductive permute_events {X: Type} (IF: relation X): relation (trace X) :=
  | pe_refl: forall t, permute_events IF t t
  | pe_sym: forall t t', permute_events IF t t' -> permute_events IF t' t
  | pe_trans: forall t1 t2 t3,
      permute_events IF t1 t2 -> permute_events IF t2 t3 -> permute_events IF t1 t3
  | pe_interference_free: forall t t' e1 e2,
      IF e1 e2 ->
      permute_events IF ((((t :: e1) :: e2)) ++ t') ((((t :: e2) :: e1)) ++ t')
.

Global Instance trace_eq_refl {X: Type} {r: relation X}: Reflexive (permute_events r).
Proof. intro. apply pe_refl. Qed.

Global Instance trace_eq_sym {X: Type} {r: relation X}: Symmetric (permute_events r).
Proof. intro. apply pe_sym. Qed.

Global Instance trace_eq_trans {X: Type} {r: relation X}: Transitive (permute_events r).
Proof. intro. apply pe_trans. Qed.

Lemma path_equiv_extend {X:Type}: forall r t t' (x: X),
    permute_events r t t' -> permute_events r (t :: x) (t' :: x).
Proof.
  intros. induction H.
  - reflexivity.
  - symmetry. assumption.
  - transitivity (t2::x); assumption.
  - rewrite 2 app_comm_cons. apply pe_interference_free. assumption.
Qed.

Module TraceSemantics.
  (** Symbolic *)
  Definition Var: Type := string.

  Inductive trace_step__S : Type :=
  | Asgn__S (x:Var) (e:Aexpr)
  | Cond (b:Bexpr).

  Definition trace__S := trace trace_step__S.

  Fixpoint acc_subst (s0:sub) (t:trace__S) : sub :=
    match t with
    | [] => s0
    | t :: Asgn__S x e => let s := acc_subst s0 t in
                      (x !-> Aapply s e ; s)
    | t :: _ => acc_subst s0 t
    end.

  Definition Aapply_t (t:trace__S) (e:Aexpr) : Aexpr :=
    Aapply (acc_subst id_sub t) e.

  Definition Bapply_t (t:trace__S) (e:Bexpr) : Bexpr :=
    Bapply (acc_subst id_sub t) e.

  Fixpoint pc (t:trace__S) : Bexpr :=
    match t with
    | [] => BTrue
    | t :: Cond b => BAnd (Bapply_t t b) (pc t)
    | t :: _ => pc t
    end.

  (** Concrete *)
  Definition trace__C := trace (Var * Aexpr).

  Fixpoint acc_val (V0:Valuation) (t:trace__C) : Valuation :=
    match t with
    | [] => V0
    | t :: (x, e) => let V := acc_val V0 t in
                   (x !-> Aeval V e ; V)
    end.

  Definition Aeval_t (V0:Valuation) (t:trace__C) (e:Aexpr) : nat :=
    Aeval (acc_val V0 t) e.

  Definition Beval_t (V0:Valuation) (t:trace__C) (e:Bexpr) : bool :=
    Beval (acc_val V0 t) e.

  Definition is_abstraction (V0:Valuation) (t:trace__C) (t':trace__S) : Prop :=
    Beval V0 (pc t') = true /\ Comp V0 (acc_subst id_sub t') = acc_val V0 t.

  Fixpoint Apply_t (s: sub) (t: trace__S) : trace__S :=
    match t with
    | [] => []
    | xs :: Asgn__S x e => Apply_t s xs :: Asgn__S x (Aapply s e)
    | xs :: Cond e => Apply_t s xs :: Cond (Bapply s e)
    end.

  (* Path Equivalence Conditions *)
  Definition sim_subst (r: relation trace_step__S) :=
    forall s x x' e e',
        r (Asgn__S x e) (Asgn__S x' e') ->
        (x' !-> Aapply (x !-> Aapply s e; s) e'; x !-> Aapply s e; s)
      = (x !-> Aapply (x' !-> Aapply s e'; s) e; x' !-> Aapply s e'; s).

  Definition subst_bapply (r: relation trace_step__S) :=
    forall x e b s, r (Asgn__S x e) (Cond b) ->
      Bapply (x !-> Aapply s e; s) b = Bapply s b.

  (* if r allows simultaneous substitution, then equiv_acc_subst *)
  Theorem equiv_acc_subst_generic (r: relation trace_step__S) (sim_subst: sim_subst r):
    forall s t t',
      permute_events r t t' -> acc_subst s t = acc_subst s t'.
  Proof.
    intros s t t' equiv. induction equiv;
      try auto.
    - rewrite IHequiv1. apply IHequiv2.
    - induction t'.
      + destruct e1, e2;
          try reflexivity.
        apply sim_subst. apply H.
      + destruct a; simpl;
          rewrite IHt'; auto.
  Qed.

  (* if r additionally respects subst_bapply we get equiv_pc*)
  Theorem equiv_pc_generic (r: relation trace_step__S) (sym: Symmetric r) (sim_subst: sim_subst r) (subst_bapply: subst_bapply r):
    forall V t t', permute_events r t t' -> Beval V (pc t) = true <-> Beval V (pc t') = true.
  Proof.
    intros.
    induction H.
    - reflexivity.
    - symmetry. apply IHpermute_events.
    - rewrite IHpermute_events1. apply IHpermute_events2.
    - induction t'.
      + destruct e1, e2.
        * reflexivity.
        * simpl. unfold Bapply_t. simpl.
          rewrite (subst_bapply _ _ _ _ H). reflexivity.
        * simpl. unfold Bapply_t. simpl. symmetry in H.
          rewrite (subst_bapply _ _ _ _ H). reflexivity.
        * simpl. unfold Bapply_t. simpl.
          rewrite 2 andb_assoc.
          rewrite (andb_comm (Beval V (Bapply (acc_subst id_sub t) b0))).
          reflexivity.
      + destruct a; simpl.
        * apply IHt'.
        * unfold Bapply_t.
          assert (IHequiv: permute_events r (((t :: e1) :: e2) ++ t') (((t :: e2) :: e1) ++ t'))
            by (apply pe_interference_free; assumption).
          rewrite (equiv_acc_subst_generic r sim_subst _ _ _ IHequiv).
          rewrite 2 andb_true_iff. rewrite IHt'. reflexivity.
  Qed.

  Definition sim_subst__C (r: relation (Var * Aexpr)) :=
    forall V x x' e e',
        r (x, e) (x', e') ->
        (x' !-> Aeval (x !-> Aeval V e ; V) e'; x !-> Aeval V e; V)
      = (x !-> Aeval (x' !-> Aeval V e'; V) e; x' !-> Aeval V e'; V).

  Theorem equiv_acc_val_generic (r: relation (Var * Aexpr)) (sim_subst: sim_subst__C r):
    forall V t t', permute_events r t t' -> acc_val V t = acc_val V t'.
  Proof.
    intros. induction H;
      try auto.
    - rewrite IHpermute_events1. apply IHpermute_events2.
    - induction t'.
      + destruct e1, e2; simpl.
        apply sim_subst. apply H.
      + destruct a; simpl. rewrite IHt'. reflexivity.
  Qed.

End TraceSemantics.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.reals.fast.CRFieldOps.
Require Export CoRN.model.ordfields.CRordfield.
Require Export CoRN.reals.CReals.
Require Import CoRN.reals.fast.CRcorrect.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.tactics.CornTac.

Opaque CR.

Local Open Scope uc_scope.

(**
** Example of a real number structure: $\langle$#⟨#[CR]$\rangle$#⟩#
*)

Lemma CRAbsSmall_ball : forall (x y:CR) (e:Q),
    AbsSmall (R:=CRasCOrdField) (inject_Q_CR e) ((x:CRasCOrdField)[-]y) <->
 ball e x y.
Proof.
 intros x y e.
 split.
 - intros [H1 H2].
  rewrite <- (doubleSpeed_Eq x).
  rewrite <- (doubleSpeed_Eq (doubleSpeed x)).
  rewrite <- (doubleSpeed_Eq y).
  rewrite <- (doubleSpeed_Eq (doubleSpeed y)).
  apply: regFunBall_e.
  intros d.
  assert (H1':=H1 d).
  assert (H2':=H2 d).
  clear H1 H2.
  simpl.
  set (x':=approximate x ((1#2)*((1#2)*d))%Qpos).
  set (y':=approximate y ((1#2)*((1#2)*d))%Qpos).
  change (-proj1_sig d <= x' - y' + - - e) in H1'.
  change (-proj1_sig d <= e + - (x' - y')) in H2'.
  rewrite -> Qle_minus_iff in *.
  apply: ball_weak. apply Qpos_nonneg.
  split; simpl; rewrite -> Qle_minus_iff.
  rewrite Qopp_involutive. do 2 rewrite Qopp_involutive in H1'.
  rewrite (Qplus_comm (proj1_sig d)).
  rewrite Qplus_assoc. exact H1'.
  rewrite <- Qplus_assoc, Qplus_comm. rewrite Qopp_involutive in H2'.
  exact H2'.
 - intros H.
 rewrite <- (doubleSpeed_Eq x) in H.
 rewrite <- (doubleSpeed_Eq y) in H.
 split; intros d; destruct (H ((1#2)*d)%Qpos ((1#2)*d)%Qpos) as [H1 H2]; clear H;
   set (x':=(approximate (doubleSpeed x) ((1 # 2) * d)%Qpos)) in *;
     set (y':=(approximate (doubleSpeed y) ((1 # 2) * d)%Qpos)) in *.
  autorewrite with QposElim in H1.
  change (- ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)<=x' - y') in H1.
  change (-proj1_sig d <= x' - y' + - - e).
  rewrite -> Qle_minus_iff.
  rewrite -> Qle_minus_iff in H1.
  replace RHS with (x' - y' + - - ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)) by ring.
  assumption.
 autorewrite with QposElim in H2.
 change (x' - y'<=((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)) in H2.
 change (-proj1_sig d <= e + - (x' - y')).
 rewrite -> Qle_minus_iff.
 rewrite -> Qle_minus_iff in H2.
 replace RHS with ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d + - (x' - y'))
   by ring.
 assumption.
Qed.

Lemma CRlt_Qlt : forall a b, (a < b)%Q -> ((' a%Q) < (' b))%CR.
Proof.
 intros a b H.
 destruct (Qpos_sub _ _ H) as [c Hc].
 exists c.
 intros d.
 change (-proj1_sig d <= b + - a + - proj1_sig c).
 rewrite -> Hc.
 rewrite -> Qle_minus_iff.
 ring_simplify.
 apply Qpos_nonneg.
Qed.

Definition CRlim (s:CauchySeq CRasCOrdField) : CR.
Proof.
 revert s.
 intros [f Hf].
 apply (ucFun (@Cjoin Q_as_MetricSpace)).
 exists (fun e:QposInf => match e with | QposInfinity => 0%CR
   | Qpos2QposInf e => let (n,_) := Hf (inject_Q_CR (proj1_sig e)) (CRlt_Qlt _ _ (Qpos_ispos e)) in f n end).
 abstract ( intros e1 e2; destruct (Hf (inject_Q_CR (proj1_sig e1)) (CRlt_Qlt _ _ (Qpos_ispos e1))) as [n1 Hn1];
   destruct (Hf (inject_Q_CR (proj1_sig e2)) (CRlt_Qlt _ _ (Qpos_ispos e2))) as [n2 Hn2];
     eapply ball_triangle;[apply ball_sym|];rewrite <- CRAbsSmall_ball; [apply Hn1;apply le_max_l|
       apply Hn2;apply le_max_r]) using Rlim_subproof0.
Defined.

Lemma CRisCReals : is_CReals CRasCOrdField CRlim.
Proof.
 split.
  intros [f Hf] e [d Hed].
  destruct (Hf _ (CRlt_Qlt _ _ (Qpos_ispos ((1#2)*d)%Qpos))) as [n Hn].
  exists n.
  intros m Hm.
  apply AbsSmall_leEq_trans with (inject_Q_CR (proj1_sig d));
    [rstepr (e[-][0]);assumption|].
  rewrite -> CRAbsSmall_ball.
  change (nat -> Complete Q_as_MetricSpace) in f.
  change (ball (proj1_sig d) (f m) (CRlim (Build_CauchySeq CRasCOrdField f Hf))).
  rewrite <- (MonadLaw5 (f m)).
  change (ball (proj1_sig d) (Cjoin (Cunit (f m))) (CRlim (Build_CauchySeq CRasCOrdField f Hf))).
  unfold CRlim.
  apply uc_prf.
  change (ball (proj1_sig d) (Cunit (f m)) (Build_RegularFunction (Rlim_subproof0 f Hf))).
  intros e1 e2.
  simpl.
  destruct (Hf (' proj1_sig e2)%CR (CRlt_Qlt _ _ (Qpos_ispos e2))) as [a Ha].
  change (ball (proj1_sig (e1+d+e2)%Qpos) (f m) (f a)).
  destruct (le_ge_dec a m).
   rewrite <- CRAbsSmall_ball.
   eapply AbsSmall_leEq_trans;[|apply Ha;assumption].
   intros x.
   autorewrite with QposElim.
   change (-proj1_sig x <= proj1_sig e1 + proj1_sig d + proj1_sig e2 - proj1_sig e2).
   rewrite -> Qle_minus_iff.
   ring_simplify.
   change (0<= proj1_sig (e1+d+x)%Qpos).
   apply Qpos_nonneg.
  apply ball_weak_le with (proj1_sig ((1#2)*d+(1#2)*d)%Qpos).
   rewrite -> Qle_minus_iff.
   simpl. ring_simplify.
   change (0<= proj1_sig (e1+e2)%Qpos).
   apply Qpos_nonneg.
  apply ball_triangle with (f n);[|apply ball_sym]; rewrite <- CRAbsSmall_ball; apply Hn.
   auto.
  apply le_trans with m; auto.
 (*Archimedean*)
 intros x.
 assert (X:=(CR_b_upperBound (1#1) x)).
 destruct (CR_b (1 # 1) x) as [[n d] qpos].
 destruct n as [|n|n]. inversion qpos. 2: inversion qpos.
 rewrite (anti_convert_pred_convert n) in X.
 exists (nat_of_P n)%nat.
 eapply leEq_transitive.
  apply X.
 clear X.
 intros z.
 simpl.
 unfold Cap_raw.
 simpl.
 apply Qle_trans with 0.
  rewrite -> Qle_minus_iff.
  ring_simplify.
  apply Qpos_nonneg.
 destruct (ZL4 n) as [a Ha].
 rewrite Ha.
 clear Ha.
 simpl.
 unfold Cap_raw.
 simpl.
 rewrite <- Qle_minus_iff.
 remember ((1 # 2) * ((1 # 2) * z))%Qpos as q.
 simpl in Heqq. rewrite <- Heqq. clear Heqq.
 revert q.
 induction a; intro q.
  simpl.
  ring_simplify.
  unfold Qle.
  simpl.
  apply Zle_1_POS.
 simpl.
 unfold Cap_raw.
 simpl.
 rewrite -> Qle_minus_iff.
 rewrite <- Qplus_assoc.
 setoid_replace (1 + - (Pos.succ (Pos.of_succ_nat a) # d))
   with (-((Pos.succ (Pos.of_succ_nat a) # d) - 1)) by ring.
 rewrite<- Qle_minus_iff.
 apply (Qle_trans _ (Pos.of_succ_nat a # d)).
 2: apply IHa.
 generalize (P_of_succ_nat a).
 intros p.
 rewrite -> Qle_minus_iff.
 autorewrite with QposElim.
 replace RHS with (((p#d) + 1) + - (Pos.succ p # d)) by ring.
 rewrite <- Qle_minus_iff.
 unfold Qle.
 simpl.
 repeat rewrite Pmult_1_r.
 rewrite Pplus_one_succ_r.
 repeat rewrite Zpos_mult_morphism.
 apply Zmult_lt_0_le_compat_r.
  auto with *.
 repeat rewrite Zpos_plus_distr.
 auto with *.
Qed.

Definition CRasCReals : CReals :=
Build_CReals _ _ CRisCReals.

Canonical Structure CRasCReals.


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

Require Import Equations.Prop.Equations.

From Coq Require Import String Ensembles Setoid.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.Classical_Prop.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Coq.Classes Require Import Morphisms_Prop.
From Coq.Unicode Require Import Utf8.
From Coq.micromega Require Import Lia.

From MatchingLogic Require Import Logic ProofMode.MLPM.
From MatchingLogic.Theories Require Import Definedness_Syntax Definedness_ProofSystem FOEquality_ProofSystem.
From MatchingLogic.Utils Require Import stdpp_ext.

Require Import MatchingLogic.wftactics.

From stdpp Require Import base fin_sets sets propset proof_irrel option list.

Import extralibrary.

Import MatchingLogic.Logic.Notations.
Import MatchingLogic.Theories.Definedness_Syntax.Notations.

Set Default Proof Mode "Classic".

Close Scope equations_scope. (* Because of [!] *)

Open Scope ml_scope.
Open Scope string_scope.
Open Scope list_scope.

Section ProofSystemTheorems.
  Context
    {Σ : Signature}
    {syntax : Syntax}.

  Lemma Prop₃_left: forall Γ φ φ',
      theory ⊆ Γ ->
      well_formed φ -> well_formed φ' ->
      Γ ⊢ (φ and (φ' =ml φ)) ---> (φ and φ').
  Proof.
    intros Γ φ φ' SubTheory Wf1 Wf2.
    toMLGoal. wf_auto2.
    mlIntro "H0". mlDestructAnd "H0" as "H1" "H2".
    mlRewriteBy "H2" at 1. assumption. wf_auto2.
    {
      unfold mu_in_evar_path. cbn. rewrite decide_eq_same. cbn.
      rewrite !Nat.max_0_r.
      case_match;[reflexivity|].
      rewrite maximal_mu_depth_to_0 in H.
      2: { inversion H. }
      eapply evar_is_fresh_in_richer'.
      2: apply set_evar_fresh_is_fresh.
      { clear. set_solver. }
    }
    mlSplitAnd; mlExact "H1".
  Defined.

  Lemma functional_pattern_defined :
    forall Γ φ, theory ⊆ Γ -> well_formed φ ->
       Γ ⊢ (ex , (φ =ml b0)) ---> ⌈ φ ⌉.
  Proof.
    intros Γ φ HΓ Wf.
    toMLGoal. wf_auto2.
    mlIntro "H0".
    mlApplyMetaRaw (forall_functional_subst ⌈ b0 ⌉ φ _ HΓ ltac:(wf_auto2)
                 ltac:(wf_auto2) ltac:(wf_auto2) ltac:(wf_auto2)).
    mlSplitAnd.
    * mlClear "H0". fromMLGoal. wf_auto2.
      remember (fresh_evar patt_bott) as x.
      pose proof (universal_generalization Γ ⌈patt_free_evar x⌉ x AnyReasoning (pile_any _))
        as H1'.
      cbn in H1'. case_match. 2: congruence. apply H1'. reflexivity.
      gapply defined_evar.
      { apply pile_any. }
      { exact HΓ. }
    * mlExact "H0".
  Defined.

  Lemma membership_equal_equal :
    forall Γ φ φ',
      theory ⊆ Γ -> mu_free φ' ->
      well_formed φ -> well_formed φ' ->
      Γ ⊢ (ex , (φ =ml b0))  ->
      Γ ⊢ (ex , (φ' =ml b0))  ->
      Γ ⊢ (φ ∈ml φ') =ml (φ =ml φ') .
  Proof.
    intros Γ φ φ' HΓ Mufree Wf1 Wf2 Func1 Func2.
    unfold patt_equal at 1.

    toMLGoal. wf_auto2.
    mlIntro.
    pose proof (bott_not_defined Γ) as H.
    use AnyReasoning in H.
    mlApplyMeta H.
    fromMLGoal. wf_auto2.

    apply ceil_monotonic; auto.
    { wf_auto2. }

    toMLGoal. wf_auto2.
    pose proof (not_not_intro Γ ((φ ∈ml φ' <---> φ =ml φ' ))
    ltac:(wf_auto2)) as H0.
    use AnyReasoning in H0.
    mlApplyMetaRaw H0.
    mlSplitAnd; mlIntro.
    * mlApplyMeta membership_imp_equal_meta; auto. mlExactn 0.
    * mlApplyMeta equal_imp_membership; auto. mlExactn 0.
      Unshelve.
      toMLGoal. wf_auto2.
      clear h. mlApplyMeta functional_pattern_defined; auto.
      mlExactMeta Func2.
  Defined.

  Lemma Prop₃_right : forall Γ φ φ',
      theory ⊆ Γ ->
      well_formed φ -> well_formed φ' -> mu_free φ' ->
      Γ ⊢ (ex , (φ =ml b0))  ->
      Γ ⊢ (ex , (φ' =ml b0))  ->
      Γ ⊢ (φ and φ') ---> (φ and (φ =ml φ')) .
  Proof.
    intros Γ φ φ' HΓ Wf1 Wf2 MF Func1 Func2.
    toMLGoal. wf_auto2.
    mlIntro "H0".
    mlAssert ("H1" : ⌈ φ and φ' ⌉).
    { wf_auto2. }
    (* Why can we only mlApplyMetaRaw here, and not after mlRevert? *)
    {
      pose proof (phi_impl_defined_phi Γ (φ and φ') (fresh_evar (φ and φ')) HΓ
                    ltac:(solve_fresh) ltac:(wf_auto2)) as H.
      use AnyReasoning in H.
      mlApplyMetaRaw H.
      mlExact "H0".
    }
    replace (⌈ φ and φ' ⌉) with (φ ∈ml φ') by auto.
    mlDestructAnd "H0" as "H2" "H3". mlSplitAnd.
    * mlExact "H2".
    * mlApplyMeta membership_imp_equal_meta; auto.
      mlExact "H1".
  Defined.

  Corollary delete : forall φ φ' Γ,
    well_formed φ -> well_formed φ'
  ->
    Γ ⊢ φ and φ' =ml φ' ---> φ
    .
  Proof.
    intros φ φ' Γ WF1 WF2.
    toMLGoal. wf_auto2.
    mlIntro "H0". mlDestructAnd "H0" as "H1" "H2". mlExact "H1".
  Defined.

  Lemma free_evar_subst_id :
    forall φ x, φ^[[evar: x ↦ patt_free_evar x]] = φ.
  Proof.
    induction φ; intros x'; simpl; auto.
    * case_match; subst; auto.
    * rewrite IHφ1. now rewrite IHφ2.
    * rewrite IHφ1. now rewrite IHφ2.
    * now rewrite IHφ.
    * now rewrite IHφ.
  Qed.

  Theorem elimination : forall φ φ' x Γ, x ∉ free_evars φ ->
    theory ⊆ Γ -> mu_free φ ->
    well_formed_closed_ex_aux φ 1 ->
    well_formed_closed_mu_aux φ 0 ->
    well_formed φ' ->
    Γ ⊢ φ^[evar: 0 ↦ patt_free_evar x] and φ' =ml patt_free_evar x --->
        φ^[evar: 0 ↦ φ'] and φ' =ml patt_free_evar x
    .
  Proof.
    intros φ φ' x Γ NotIn HΓ MF WFp1 WFp2 WF2.
    assert (well_formed (φ^[evar:0↦φ'])) as WFF.
    { wf_auto2. now apply mu_free_wfp. }
    assert (well_formed (φ^[evar:0↦patt_free_evar x])) as WFFF. {
      wf_auto2. now apply mu_free_wfp. }
    toMLGoal. wf_auto2.
    mlIntro "H0". mlDestructAnd "H0" as "H1" "H2".
    mlSplitAnd.
    2: { mlExact "H2". }
    epose proof (equality_elimination_basic Γ φ' (patt_free_evar x)
            {|pcEvar := x; pcPattern := φ^[evar: 0 ↦ patt_free_evar x]|}
            HΓ WF2 ltac:(wf_auto2) ltac:(wf_auto2) ltac:(wf_auto2)).
    cbn in H.
    assert (Hwfeaψ': well_formed_closed_ex_aux φ' 0 = true).
    {
      (* TODO this clear should not be necessary *)
      clear - WF2.
      wf_auto2.
    }
    pose proof (bound_to_free_variable_subst φ x 1 0 φ' ltac:(lia) ltac:(wf_auto2) WFp1 NotIn) as H0.
    unfold evar_open in H0. rewrite <- H0 in H. (* TODO: cast_proof? *)
    rewrite free_evar_subst_id in H.
    assert (Γ ⊢ φ^[evar:0↦φ'] <---> φ^[evar:0↦patt_free_evar x] --->
                φ^[evar:0↦patt_free_evar x] ---> φ^[evar:0↦φ'] ) as Hiff. {
      toMLGoal.
      { clear H. wf_auto2. }
      mlIntro "H1". unfold patt_iff. mlDestructAnd "H1" as "H2" "H3". mlExact "H3".
    }

    use AnyReasoning in H.
    epose proof (syllogism_meta _ _ _ H Hiff).
    (* TODO: mlApplyMetaRaw buggy?
             Tries to match the longest conclusion, not the shortest *)
    apply reorder_meta in H1.
    mlRevertLast. mlApplyMetaRaw H1. mlExact "H1".
    Unshelve. all: wf_auto2.
    cbn. rewrite mu_free_bevar_subst; wf_auto2.
  Defined.

  Theorem elimination_reverse : forall φ φ' x Γ, x ∉ free_evars φ ->
    theory ⊆ Γ -> mu_free φ ->
    well_formed_closed_ex_aux φ 1 ->
    well_formed_closed_mu_aux φ 0 ->
    well_formed φ' ->
    Γ ⊢ φ^[evar: 0 ↦ φ'] and φ' =ml patt_free_evar x --->
        φ^[evar: 0 ↦ patt_free_evar x] and φ' =ml patt_free_evar x
    .
  Proof.
    intros φ φ' x Γ NotIn HΓ MF WFp1 WFp2 WF2.
    assert (well_formed (φ^[evar:0↦φ'])) as WFF.
    { wf_auto2. now apply mu_free_wfp. }
    assert (well_formed (φ^[evar:0↦patt_free_evar x])) as WFFF. {
      wf_auto2. now apply mu_free_wfp. }
    toMLGoal. wf_auto2.
    mlIntro "H0".
    mlDestructAnd "H0" as "H1" "H2".
    mlSplitAnd.
    2: { mlAssumption. }
    epose proof (equality_elimination_basic Γ φ' (patt_free_evar x)
            {|pcEvar := x; pcPattern := φ^[evar: 0 ↦ patt_free_evar x]|}
            HΓ WF2 ltac:(wf_auto2) ltac:(wf_auto2) ltac:(wf_auto2)).
    cbn in H.
    pose proof (bound_to_free_variable_subst φ x 1 0 φ' ltac:(lia) ltac:(clear -WF2; wf_auto2) WFp1 NotIn) as H0.
    unfold evar_open in H0. rewrite <- H0 in H. (* TODO: cast_proof? *)
    rewrite free_evar_subst_id in H.
    assert (Γ ⊢ φ^[evar:0↦φ'] <---> φ^[evar:0↦patt_free_evar x] --->
                φ^[evar:0↦φ'] ---> φ^[evar:0↦patt_free_evar x] ) as Hiff. {
      toMLGoal.
      { clear H. wf_auto2. }
      mlIntro "H1". unfold patt_iff. mlDestructAnd "H1" as "H2" "H3". mlExact "H2".
    }
    use AnyReasoning in H.
    epose proof (syllogism_meta _ _ _ H Hiff).
    (* TODO: mlApplyMetaRaw buggy?
             Tries to match the longest conclusion, not the shortest *)
    apply reorder_meta in H1.
    mlRevertLast.
    mlApplyMetaRaw H1.
    mlExact "H1".
    Unshelve. all: wf_auto2.
    cbn. rewrite mu_free_bevar_subst; wf_auto2.
  Defined.

  (**
     Should be a consequence of the injectivity axiom:

      f(x₁,...,xₙ) = f(x₁',...,xₙ') → x₁ = x₁' ∧ ... ∧ xₙ = xₙ'

     The question is, why can we assume this axiom?
  *)
  (* TODO move this definition to a more general place. *)
  Definition application_chain (φ : Pattern) (φs : list Pattern) : Pattern :=
    fold_left (fun Acc φ => patt_app Acc φ) φs φ.

  Theorem application_equal : forall φs ψ φ's Γ,
    length φs = length φ's ->
    well_formed ψ -> (* Forall well_formed φs -> Forall well_formed φ's *)
    (forall i, i < length φs -> well_formed (nth i φs ⊥)) ->
    (forall i, i < length φ's -> well_formed (nth i φ's ⊥))
  ->
    Γ ⊢ application_chain ψ φs =ml application_chain ψ φ's --->
         fold_right (fun '(x, y) Acc => Acc and x =ml y) Top (zip φs φ's)
    .
  Proof.
    induction φs;
    intros ψ φ's Γ Len WF WFs1 WFs2.
    * apply eq_sym, length_zero_iff_nil in Len. subst. cbn.
      toMLGoal. wf_auto2.
      mlIntro "H0". mlClear "H0". (* TODO: mlExact for meta theorems *)
      fromMLGoal. wf_auto2.
      useBasicReasoning.
      apply (top_holds Γ).
    * destruct φ's. simpl in Len. congruence.
      simpl in Len. inversion Len. clear Len.
      cbn.
      admit.
  Abort.

End ProofSystemTheorems.

Section UnificationProcedure.
  Context {Σ : Signature} {ΣS : Syntax}.

  (* Fixpoint apps_r (C : Application_context) : bool :=
  match C with
   | box => true
   | ctx_app_l cc p => apps_r cc
   | ctx_app_r p cc => false
  end. *)

  (** Based on https://www.cs.bu.edu/fac/snyder/publications/UnifChapter.pdf *)
  Definition Unification_problem : Set := list (Pattern * Pattern) *
                                          list (evar * Pattern).

  Fixpoint get_apps (p : Pattern) : option (symbols * list Pattern) :=
  match p with
  | patt_app p1 p2 =>
    match get_apps p1 with
    | Some (s, ps) => Some (s, ps ++ [p2])
    | None => None
    end
  | patt_sym s => Some (s, [])
  | _ => None
  end.

  Definition u_remove := remove (prod_eqdec Pattern_eqdec Pattern_eqdec).

  Definition subst_ziplist (x : evar) (p : Pattern)
    : list (Pattern * Pattern) -> list (Pattern * Pattern) :=
    map (fun '(p1, p2) => ( p1^[[evar: x ↦ p]] , p2^[[evar: x ↦ p]] )).
  Definition subst_list (x : evar) (p : Pattern)
    : list (evar * Pattern) -> list (evar * Pattern) :=
    map (fun '(y, p2) => ( y , p2^[[evar: x ↦ p]] )).

  Reserved Notation "u ===> u'" (at level 80).
  Inductive unify_step : Unification_problem -> option Unification_problem -> Set :=
  (* trivial/delete *)
  | u_trivial t U S U' :
    (U ++ (t, t)::U', S) ===> Some (U ++ U', S)
  (* decomposition *)
  | u_decompose U U' S t1 t2 f ps ps' :
    get_apps t1 = Some (f, ps) -> get_apps t2 = Some (f, ps') ->
    length ps = length ps'
   ->
    (U ++ (t1, t2)::U', S) ===> Some (zip ps ps' ++ U ++ U', S)
  (* symbol_clash *)
  | u_clash U U' S t1 t2 f g ps ps' :
    get_apps t1 = Some (f, ps) -> get_apps t2 = Some (g, ps') ->
    f <> g
   ->
    (U ++ (t1, t2)::U', S) ===> None
  (* orient *)
  | u_orient U U' S t x:
    (U ++ (t, patt_free_evar x)::U', S) ===> Some (U ++ (patt_free_evar x, t)::U', S)
  (* occurs check *)
  | u_check U U' S x t:
    x ∈ free_evars t ->
    patt_free_evar x <> t
   ->
    (U ++ (t, patt_free_evar x)::U', S) ===> None
  (* elimination *)
  | u_elim U U' S x t:
    x ∉ free_evars t
   ->
    (U ++ (patt_free_evar x, t)::U', S) ===> Some (subst_ziplist x t (U ++ U'),
                                                   (x, t) :: subst_list x t S)
  where "u ===> u'" := (unify_step u u').

  Definition eq_pats := (fun '(p1, p2) => p1 =ml p2).
  Definition eq_vars := (fun '(x, p2) => patt_free_evar x =ml p2).

  Definition unification_to_pattern (u : Unification_problem) : Pattern :=
    match u with
    | (Us, Ss) =>
        foldr patt_and Top (map eq_pats Us)
        and
        foldr patt_and Top (map eq_vars Ss)
    end.
  Definition wf_unification (u : Unification_problem) :=
    wf (map fst u.1) && wf (map snd u.1) && wf (map snd u.2).

(*   Theorem foldr_equiv :
    forall l p l' p0, well_formed p -> well_formed (foldr patt_and p0 l) -> well_formed (foldr patt_and p0 l') ->
    forall Γ, Γ ⊢ foldr patt_and p0 (l ++ p::l') <---> foldr patt_and p0 (p::l ++ l').
  Proof.
    intros l. induction l; intros p l' p0 WFp WFl WFl' Γ.
    * simpl. useBasicReasoning. apply pf_iff_equiv_refl. wf_auto2.
    * simpl.
  Admitted. *)

  Theorem wf_unify_step :
    forall u u' : Unification_problem,
    u ===> Some u' ->
    wf_unification u ->
    wf_unification u'.
  Proof.
    intros u u' D. dependent induction D; intros WF.
    *
  Admitted.

  Theorem wf_unify_pattern :
    forall u, wf_unification u -> well_formed (unification_to_pattern u).
  Proof.
  Admitted.

  Theorem foldr_last_element :
    forall Γ xs x y,
    well_formed x -> well_formed y -> wf xs ->
    Γ ⊢i foldr patt_and (x and y) xs <--->
    ((foldr patt_and y xs) and x) using AnyReasoning.
  Proof.
    induction xs; intros x y Wf1 Wf2 Wf3; simpl.
    * gapply patt_and_comm; auto. apply pile_any.
    * apply wf_tail' in Wf3 as Wf4.
      specialize (IHxs x y Wf1 Wf2 Wf4).
      unshelve(toMLGoal).
      {
        assert (well_formed a) by now apply andb_true_iff in Wf3.
        apply well_formed_and; apply well_formed_imp;
        repeat apply well_formed_and; auto;
        apply well_formed_foldr_and; wf_auto2.
      }
      mlSplitAnd; mlIntro "H"; mlDestructAnd "H" as "H0" "H1".
      - mlRevertLast. mlRewrite IHxs at 1. mlIntro "H1". mlDestructAnd "H1".
        mlSplitAnd; [mlSplitAnd;mlAssumption|mlAssumption].
      - mlRewrite IHxs at 1. mlDestructAnd "H0".
        mlSplitAnd; [mlAssumption|mlSplitAnd;mlAssumption].
    Unshelve.
  Admitted.

  Theorem unification_soundness :
    forall u u' : Unification_problem,
    u ===> Some u' ->
    wf_unification u ->
    forall Γ, theory ⊆ Γ -> Γ ⊢ unification_to_pattern u ---> unification_to_pattern u' .
  Proof.
    intros u u' D WF.
    assert (wf_unification u') as H.
    { eapply wf_unify_step; eassumption. }
    inversion D; intros Γ HΓ.
    * subst.
      (* TODO: why does toMyGoal simplify??? *)
      (* Opaque unification_to_pattern. *)
      with_strategy opaque [unification_to_pattern] toMLGoal.
      { apply well_formed_imp; apply wf_unify_pattern; auto. }
      (* Transparent unification_to_pattern. *)
      cbn.
      rewrite map_app. simpl map.

      mlIntro "H". mlDestructAnd "H" as "H0" "H1". mlSplitAnd. 2: mlExact "H1".
      mlClear "H1".
      replace (fix app (l m : list Pattern) {struct l} : list Pattern :=
         match l with
         | [] => m
         | a :: l1 => a :: app l1 m
         end) with (@app Pattern) by reflexivity.
      mlRevertLast.
      rewrite map_app.
      do 2 rewrite foldr_app.
      simpl.
      apply wf_unify_pattern in WF. cbn in WF.
      rewrite map_app in WF. rewrite foldr_app in WF.
      simpl in WF.
      remember (foldr patt_and Top (map eq_pats U')) as L1.
      remember (map eq_pats U) as L2.
      epose proof (@foldr_last_element Γ L2 (t =ml t) L1 _ _ _).
      mlRewrite H0 at 1.
      mlIntro "H". mlDestructAnd "H" as "H0" "H1". mlExact "H0".
    * subst. admit.
    * subst; simpl.
      with_strategy opaque [unification_to_pattern] toMLGoal.
      { apply well_formed_imp. admit. admit. }
      do 2 rewrite map_app. simpl map.
      do 2 rewrite foldr_app. simpl.
      remember (foldr patt_and Top (map eq_pats U')) as L1.
      remember (map eq_pats U) as L2.
      epose proof (@foldr_last_element Γ L2 (t =ml patt_free_evar x) L1 _ _ _).
      mlRewrite H0 at 1.
      epose proof (@foldr_last_element Γ L2 (patt_free_evar x =ml t) L1 _ _ _).
      mlRewrite H1 at 1.
      mlIntro "H". mlDestructAnd "H" as "H0" "H1". mlDestructAnd "H0" as "H0_1" "H0_2".
      mlSplitAnd. mlSplitAnd. 1, 3: mlAssumption.
      mlClear "H0_1". mlClear "H1".
      mlApplyMetaRaw (@patt_equal_sym _ _ Γ t (patt_free_evar x) _ ltac:(wf_auto2) ltac:(wf_auto2)). mlExact "H0_2".
    * subst; simpl.
      with_strategy opaque [unification_to_pattern] toMLGoal.
      { apply well_formed_imp. admit. admit. }
      rewrite map_app. simpl map.
      rewrite foldr_app. simpl.
      mlIntro "H". mlDestructAnd "H" as "H0" "H1".
    Unshelve. all: admit.
  Abort.

(* (*   Axiom f : symbols.
  Compute (get_apps (patt_sym f $ ⊥ $ ⊤ $ ⊥)). *)
  Fixpoint unify_step1 (u : Unification_problem) : option Unification_problem :=
  match u with
  | []           => Some []
  | (t1, t2)::xs =>
    match unify_step1 xs with
    | None => None
    | Some xs' =>
      match decide (t1 = t2) with
      | left _ => Some xs' (* delete *)
      | right _ =>
        match get_apps t1, get_apps t2 with
        | Some (s, ps), Some (s', ps') =>
          match decide (s = s') with
          | left _ => Some (xs' ++ zip ps ps') (* decomposition *)
          | right _ => None (* symbol clash *)
          end
        | _, _ => Some xs'
        end
      end
    end
  end. *)

  Definition is_free_evar (p : Pattern) : bool :=
  match p with
  | patt_free_evar _ => true
  | _ => false
  end.

  Definition swap_if {A : Type} (P : A -> bool) (p : A * A): A * A :=
  match p with
  | (p1, p2) =>
    match P p1, P p2 with
    | true, _ => (p1, p2)
    | _, true => (p2, p1)
    | _, _    => (p1, p2)
    end
  end.

  (* (* orient *)
  Definition unify_step2 (u : Unification_problem) : Unification_problem :=
     map (swap_if is_free_evar) u.

  (* occurs_check *)
  Fixpoint unify_step3 (u : Unification_problem) : option Unification_problem :=
  match u with
  | [] => Some []
  | (p1, p2)::xs =>
    match unify_step3 xs with
    | Some xs' =>
      match p1 with
      | patt_free_evar x =>
        match decide (x ∈ free_evars p2) with
        | left _ => None
        | right _ => Some ((p1, p2)::xs')
        end
      | _ => Some ((p1, p2)::xs')
      end
    | None => None
    end
  end.

  (* 1x elimination *)
  Fixpoint unify_step3 (u : Unification_problem) : Unification_problem :=
  match u with
  | [] => []
  | (patt_free_evar x, p2)::xs =>
  | (p1, p2)::xs => unify_step3 xs
  end. *)

End UnificationProcedure.

Close Scope ml_scope.
Close Scope string_scope.
Close Scope list_scope.


Require Import ExtLib.Structures.Applicative.
Require Import Temporal.DiscreteLogic.
Require Import ChargeCore.Tactics.Tactics.

Set Implicit Arguments.
Set Strict Implicit.

Definition lift1 {T U : Type} {F : Type -> Type}
           {Ap : Applicative.Applicative F}
(f : T -> U) (x : F T) : F U :=
  Applicative.ap (Applicative.pure f) x.

Definition lift2 {T U V : Type} {F : Type -> Type}
           {Ap : Applicative.Applicative F}
(f : T -> U -> V) (x : F T) (y : F U) : F V :=
  Applicative.ap (lift1 (F:=F) f x) y.

(*
Class Arith (T : Type) : Type :=
{ plus  : T -> T -> T
; minus : T -> T -> T
; mult  : T -> T -> T
}.

Instance Arith_nat : Arith nat :=
{ plus := Nat.add
; minus := Nat.sub
; mult := Nat.mul
}.

Instance Arith_lift {T U} {A : Arith T} : Arith (U -> T) :=
{ plus := fun a b x => plus (a x) (b x)
; minus := fun a b x => minus (a x) (b x)
; mult := fun a b x => mult (a x) (b x)
}.
*)

Record State : Type :=
{ x : nat }.

Definition Sys : TraceProp State :=
       now (lift2 eq x (pure 1))
  //\\ always (starts (lift2 eq (pre x) (post x))).

(** TODO: Move **)
Definition beforeProp (P : StateProp State) (Q : ActionProp State) : Prop :=
  before State P -|- Q.
Definition beforeVal {T} (P : StateVal State T) (Q : ActionVal State T)
: Prop :=
  forall st st', P st = Q st st'.
Theorem beforeProp_lift2 {T U} (f : T -> U -> Prop) x y x' y'
: beforeVal x x' -> beforeVal y y' ->
  beforeProp (lift2 f x y) (lift2 f x' y').
Proof.
  unfold beforeVal, beforeProp.
  simpl. intros.
  unfold before.
  split.
  Transparent ILInsts.ILFun_Ops.
  { do 3 red. simpl. destruct t0.
    rewrite <- H. rewrite <- H0. auto. }
  { do 3 red. simpl. destruct t0.
    rewrite <- H. rewrite <- H0. auto. }
Qed.

Theorem beforeVal_pre {T} (get : State -> T) :
  beforeVal get (pre get).
Proof. red. reflexivity. Qed.

Theorem beforeVal_pure {T} (x : T) :
  beforeVal (pure x) (pure x).
Proof. red. reflexivity. Qed.

Require Import Coq.Classes.Morphisms.

Notation "[] e" := (always e) (at level 30).

Goal |-- Sys -->> [] (now (lift2 eq x (pure 1))).
Proof.
  unfold Sys.
  charge_intros.
  eapply hybrid_induction.
  { charge_assumption. }
  { charge_assumption. }
  { apply always_tauto.
    rewrite <- curry.
    rewrite now_starts_discretely_and.
    rewrite next_now.
    rewrite starts_impl.
    eapply starts_tauto.
    unfold before, after, pre, post. simpl.
    destruct 2; congruence. }
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype bigop.
Require Import finset prime fingroup morphism automorphism action quotient.
Require Import gfunctor cyclic pgroup center commutator gseries nilpotent.
Require Import sylow abelian maximal hall.
Require Import BGsection1 BGsection6.

(******************************************************************************)
(*   This file covers B & G, section 7, i.e., the proof of the Thompson       *)
(* Transitivity Theorem, as well as some generalisations used later in the    *)
(* proof.                                                                     *)
(*   This is the first section of the proof that applies to a (hypothetical)  *)
(* minimally simple odd group, so we also introduce at this point some        *)
(* infrastructure to carry over this assumption into the rest of the proof.   *)
(*   minSimpleOddGroupType == a finGroupType that ranges exactly over the     *)
(*                            elements of a minimal counter-example to the    *)
(*                            Odd Order Theorem.                              *)
(*                       G == the group of all the elements in a              *)
(*                            minSimpleOddGroupType (this is a local notation *)
(*                            that must be reestablished for each such Type). *)
(*                      'M == the set of all (proper) maximal subgroups of G  *)
(*                   'M(H) == the set of all elements of 'M that contain H    *)
(*                      'U == the set of all H such that 'M(H) contains a     *)
(*                            single (unique) maximal subgroup of G.          *)
(*               'SCN_n[p] == the set of all SCN subgroups of rank at least n *)
(*                            of all the Sylow p-subgroups of G.              *)
(*            |/|_H(A, pi) == the set of all pi-subgroups of H that are       *)
(*                            normalised by A.                                *)
(*             |/|*(A, pi) == the set of pi-subgroups of G, normalised by A,  *)
(*                            and maximal subject to this condition.          *)
(*    normed_constrained A == A is a nontrivial proper subgroup of G, such    *)
(*                            that for any proper subgroup X containing A,    *)
(*                            all Y in |/|_X(A, pi') lie in the pi'-core of X *)
(*                            (here pi is the set of prime divisors of #|A|). *)
(*                            This is Hypothesis 7.1 in B & G.                *)
(******************************************************************************)

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

Import GroupScope.

Reserved Notation "''M'" (at level 8, format "''M'").
Reserved Notation "''M' ( H )" (at level 8, format "''M' ( H )").
Reserved Notation "''U'" (at level 8).
Reserved Notation "''SCN_' n [ p ]"
  (at level 8, n at level 2, format "''SCN_' n [ p ]").
Reserved Notation "|/|_ X ( A ; pi )"
  (at level 8, X at level 2, format "|/|_ X ( A ;  pi )").
Reserved Notation "|/|* ( A ; pi )"
  (at level 8, format "|/|* ( A ;  pi )").

(* The generic setup for the whole Odd Order Theorem proof. *)
Section InitialReduction.

Implicit Type gT : finGroupType.

Record minSimpleOddGroupMixin gT : Prop := MinSimpleOddGroupMixin {
  _ : odd #|[set: gT]|;
  _ : simple [set: gT];
  _ : ~~ solvable [set: gT];
  _ : forall M : {group gT}, M \proper [set: gT] -> solvable M
}.

Structure minSimpleOddGroupType := MinSimpleOddGroupType {
  minSimpleOddGroupType_base :> finGroupType;
  _ : minSimpleOddGroupMixin minSimpleOddGroupType_base
}.

Hypothesis IH_FT : minSimpleOddGroupType -> False.

Lemma minSimpleOdd_ind gT (G : {group gT}) : odd #|G| -> solvable G.
Proof.
move: {2}_.+1 (ltnSn #|G|) => n.
elim: n => // n IHn in gT G *; rewrite ltnS => leGn oddG.
have oG: #|[subg G]| = #|G| by rewrite (card_isog (isog_subg G)).
apply/idPn=> nsolG; case: IH_FT; exists [finGroupType of subg_of G].
do [split; rewrite ?oG //=] => [||M].
- rewrite -(isog_simple (isog_subg _)); apply/simpleP; split=> [|H nsHG].
    by apply: contra nsolG; move/eqP->; rewrite abelian_sol ?abelian1.
  have [sHG _]:= andP nsHG; apply/pred2P; apply: contraR nsolG; case/norP=> ntH.
  rewrite eqEcard sHG -ltnNge (series_sol nsHG) => ltHG.
  by rewrite !IHn ?(oddSg sHG) ?quotient_odd ?(leq_trans _ leGn) ?ltn_quotient.
- by apply: contra nsolG => solG; rewrite -(im_sgval G) morphim_sol.
rewrite properEcard oG; case/andP=> sMG ltMG.
by apply: IHn (leq_trans ltMG leGn) (oddSg sMG _); rewrite oG.
Qed.

Lemma minSimpleOdd_prime gT (G : {group gT}) :
  odd #|G| -> simple G -> prime #|G|.
Proof. by move/minSimpleOdd_ind; apply: simple_sol_prime. Qed.

End InitialReduction.

Notation TheMinSimpleOddGroup gT :=
    [set: FinGroup.arg_sort (FinGroup.base (minSimpleOddGroupType_base gT))]
  (only parsing).

(* Elementary properties of the minimal counter example. *)
Section MinSimpleOdd.

Variable gT : minSimpleOddGroupType.
Notation G := (TheMinSimpleOddGroup gT).
Implicit Types H K D M P U V X : {group gT}.
Local Notation sT := {set gT}.
Implicit Type p : nat.

Lemma mFT_odd H : odd #|H|.
Proof. by apply: (oddSg (subsetT H)); case: gT => ? []. Qed.

Lemma mFT_simple : simple G.
Proof. by case: gT => ? []. Qed.

Lemma mFT_nonSolvable : ~~ solvable G.
Proof. by case: gT => ? []. Qed.

Lemma mFT_sol M : M \proper G -> solvable M.
Proof. by case: gT M => ? []. Qed.

Lemma mFT_nonAbelian : ~~ abelian G.
Proof. by apply: contra mFT_nonSolvable; apply: abelian_sol. Qed.

Lemma mFT_neq1 : G != 1.
Proof. by apply: contraNneq mFT_nonAbelian => ->; apply: abelian1. Qed.

Lemma mFT_gt1 : [1] \proper G. Proof. by rewrite proper1G mFT_neq1. Qed.

Lemma mFT_quo_odd M H : odd #|M / H|.
Proof. by rewrite quotient_odd ?mFT_odd. Qed.

Lemma mFT_sol_proper M : (M \proper G) = solvable M.
Proof.
apply/idP/idP; first exact: mFT_sol.
by rewrite properT; apply: contraL; move/eqP->; apply: mFT_nonSolvable.
Qed.

Lemma mFT_pgroup_proper p P : p.-group P -> P \proper G.
Proof. by move/pgroup_sol; rewrite mFT_sol_proper. Qed.

Lemma mFT_norm_proper H : H :!=: 1 -> H \proper G -> 'N(H) \proper G.
Proof.
move=> ntH; rewrite !properT; apply: contra; move/eqP=> nHG; apply/eqP.
move/eqP: ntH; case/simpleP: mFT_simple => _; case/(_ H) => //=.
by rewrite -nHG normalG.
Qed.

Lemma cent_mFT_trivial : 'C(G) = 1.
Proof.
apply/eqP; apply: contraR mFT_nonAbelian => ntC.
rewrite /abelian subTset /= eqEproper subsetT /=; apply/negP=> prC.
have:= mFT_norm_proper ntC prC.
by rewrite /proper subsetT norms_cent ?normG.
Qed.

Lemma mFT_cent_proper H : H :!=: 1 -> 'C(H) \proper G.
Proof.
case: (eqsVneq H G) => [-> | ].
  by rewrite cent_mFT_trivial properT eq_sym.
rewrite -properT => prH ntH; apply: sub_proper_trans (cent_sub H) _.
exact: mFT_norm_proper.
Qed.

Lemma mFT_cent1_proper x : x != 1 -> 'C[x] \proper G.
Proof. by rewrite -cycle_eq1 -cent_cycle; apply: mFT_cent_proper. Qed.

Lemma mFT_quo_sol M H : H :!=: 1 -> solvable (M / H).
Proof.
move=> ntH; case: (eqsVneq H G) => [-> |].
  rewrite [_ / _](trivgP _) ?abelian_sol ?abelian1 //.
  by rewrite quotient_sub1 ?normsG ?subsetT.
rewrite -properT => prH; rewrite -quotientInorm morphim_sol //.
by apply: solvableS (subsetIr _ _) (mFT_sol _); rewrite mFT_norm_proper.
Qed.

(* Maximal groups of the minimal FT counterexample, as defined at the start   *)
(* of B & G, section 7.                                                       *)
Definition minSimple_max_groups := [set M : {group gT} | maximal M G].
Local Notation "'M" := minSimple_max_groups : group_scope.

Definition minSimple_max_groups_of (H : sT) := [set M in 'M | H \subset M].
Local Notation "''M' ( H )" := (minSimple_max_groups_of H) : group_scope.

Definition minSimple_uniq_max_groups := [set U : {group gT} | #|'M(U)| == 1%N].
Local Notation "'U" := minSimple_uniq_max_groups : group_scope.

Definition minSimple_SCN_at n p := \bigcup_(P in 'Syl_p(G)) 'SCN_n(P).

Lemma mmax_exists H : H \proper G -> {M | M \in 'M(H)}.
Proof.
case/(@maxgroup_exists _ (fun M => M \proper G)) => M maxM sHM.
by exists M; rewrite !inE sHM andbT.
Qed.

Lemma any_mmax : {M : {group gT} | M \in 'M}.
Proof. by have [M] := mmax_exists mFT_gt1; case/setIdP; exists M. Qed.

Lemma mmax_proper M : M \in 'M -> M \proper G.
Proof. by rewrite inE; apply: maxgroupp. Qed.

Lemma mmax_sol M : M \in 'M -> solvable M.
Proof. by move/mmax_proper/mFT_sol. Qed.

Lemma mmax_max M H : M \in 'M -> H \proper G -> M \subset H -> H :=: M.
Proof. by rewrite inE; case/maxgroupP=> _; apply. Qed.

Lemma eq_mmax : {in 'M &, forall M H, M \subset H -> M :=: H}.
Proof. by move=> M H Mmax; move/mmax_proper=> prH; move/mmax_max->. Qed.

Lemma sub_mmax_proper M H : M \in 'M -> H \subset M -> H \proper G.
Proof. by move=> maxM sHM; apply: sub_proper_trans (mmax_proper maxM). Qed.

Lemma mmax_norm X M :
  M \in 'M -> X :!=: 1 -> X \proper G -> M \subset 'N(X) -> 'N(X) = M.
Proof. by move=> maxM ntX prX; apply: mmax_max (mFT_norm_proper _ _). Qed.

Lemma mmax_normal_subset A M :
  M \in 'M -> A <| M -> ~~ (A \subset [1]) -> 'N(A) = M.
Proof.
rewrite -gen_subG subG1 => maxM /andP[sAM nAM] ntGA.
rewrite (mmax_max maxM) // (sub_proper_trans (norm_gen _)) ?mFT_norm_proper //.
by rewrite (sub_mmax_proper maxM) // gen_subG.
Qed.

Lemma mmax_normal M H : M \in 'M -> H <| M -> H :!=: 1 -> 'N(H) = M.
Proof. by rewrite -subG1; apply: mmax_normal_subset. Qed.

Lemma mmax_sigma_Sylow p P M :
  M \in 'M -> p.-Sylow(M) P -> 'N(P) \subset M -> p.-Sylow(G) P.
Proof.
by move=> maxM sylP sNM; rewrite -Sylow_subnorm setTI (pHall_subl _ sNM) ?normG.
Qed.

Lemma mmax_neq1 M : M \in 'M -> M :!=: 1.
Proof.
move=> maxM; apply: contra mFT_nonAbelian; move/eqP=> M1.
case: (eqVneq G 1) => [-> | ]; first exact: abelian1.
case/trivgPn=> x; rewrite -cycle_subG -cycle_eq1 subEproper /=.
case/predU1P=> [<- | ]; first by rewrite cycle_abelian.
by move/(mmax_max maxM)=> ->; rewrite M1 ?sub1G ?eqxx.
Qed.

Lemma norm_mmax M : M \in 'M -> 'N(M) = M.
Proof.
move=> maxM; apply: mmax_max (normG M) => //.
exact: (mFT_norm_proper (mmax_neq1 maxM) (mmax_proper maxM)).
Qed.

Lemma mmaxJ M x : (M :^ x \in 'M)%G = (M \in 'M).
Proof. by rewrite !inE /= -{1}[G](@conjGid _ _ x) ?maximalJ ?inE. Qed.

Lemma mmax_ofS H K : H \subset K -> 'M(K) \subset 'M(H).
Proof.
move=> sHK; apply/subsetP=> M; rewrite !inE => /andP[->].
exact: subset_trans.
Qed.

Lemma mmax_ofJ K x M : ((M :^ x)%G \in 'M(K :^ x)) = (M \in 'M(K)).
Proof. by rewrite inE mmaxJ conjSg !inE. Qed.

Lemma uniq_mmaxP U : reflect (exists M, 'M(U) = [set M]) (U \in 'U).
Proof. by rewrite inE; apply: cards1P. Qed.
Implicit Arguments uniq_mmaxP [U].

Lemma mem_uniq_mmax U M : 'M(U) = [set M] -> M \in 'M /\ U \subset M.
Proof. by move/setP/(_ M); rewrite set11 => /setIdP. Qed.

Lemma eq_uniq_mmax U M H :
  'M(U) = [set M] -> H \in 'M -> U \subset H -> H :=: M.
Proof.
by move=> uU_M maxH sUH; apply/congr_group/set1P; rewrite -uU_M inE maxH.
Qed.

Lemma def_uniq_mmax U M :
  U \in 'U -> M \in 'M -> U \subset M -> 'M(U) = [set M].
Proof.
case/uniq_mmaxP=> D uU_D maxM sUM.
by rewrite (group_inj (eq_uniq_mmax uU_D maxM sUM)).
Qed.

Lemma uniq_mmax_subset1 U M :
  M \in 'M -> U \subset M -> (U \in 'U) = ('M(U) \subset [set M]).
Proof.
move=> maxM sUM; apply/idP/idP=> uU; first by rewrite -(def_uniq_mmax uU).
by apply/uniq_mmaxP; exists M; apply/eqP; rewrite eqEsubset uU sub1set inE maxM.
Qed.

Lemma sub_uniq_mmax U M H :
  'M(U) = [set M] -> U \subset H -> H \proper G -> H \subset M.
Proof.
move=> uU_M sUH; case/mmax_exists=> D; case/setIdP=> maxD sHD.
by rewrite -(eq_uniq_mmax uU_M maxD) ?(subset_trans sUH).
Qed.

Lemma mmax_sup_id M : M \in 'M -> 'M(M) = [set M].
Proof.
move=> maxM; apply/eqP; rewrite eqEsubset sub1set inE maxM subxx !andbT.
apply/subsetP=> H; case/setIdP=> maxH; rewrite inE -val_eqE /=.
by move/eq_mmax=> ->.
Qed.

Lemma mmax_uniq_id : {subset 'M <= 'U}.
Proof. by move=> M maxM; apply/uniq_mmaxP; exists M; apply: mmax_sup_id. Qed.

Lemma def_uniq_mmaxJ M K x : 'M(K) = [set M] -> 'M(K :^ x) = [set M :^ x]%G.
Proof.
move=> uK_M; apply/setP=> L; rewrite -(actKV 'JG x L) mmax_ofJ uK_M.
by rewrite !inE (inj_eq (act_inj 'JG x)).
Qed.

Lemma uniq_mmaxJ K x :((K :^ x)%G \in 'U) = (K \in 'U).
Proof.
apply/uniq_mmaxP/uniq_mmaxP=> [] [M uK_M].
  by exists (M :^ x^-1)%G; rewrite -(conjsgK x K); apply: def_uniq_mmaxJ.
by exists (M :^ x)%G; apply: def_uniq_mmaxJ.
Qed.

Lemma uniq_mmax_norm_sub (M U : {group gT}) :
  'M(U) = [set M] -> 'N(U) \subset M.
Proof.
move=> uU_M; have [maxM _] := mem_uniq_mmax uU_M.
apply/subsetP=> x nUx; rewrite -(norm_mmax maxM) inE.
have:= set11 M; rewrite -uU_M -(mmax_ofJ _ x) (normP nUx) uU_M.
by move/set1P/congr_group->.
Qed.

Lemma uniq_mmax_neq1 (U : {group gT}) : U \in 'U -> U :!=: 1.
Proof.
case/uniq_mmaxP=> M uU_M; have [maxM _] := mem_uniq_mmax uU_M.
apply: contraL (uniq_mmax_norm_sub uU_M); move/eqP->.
by rewrite norm1 subTset -properT mmax_proper.
Qed.

Lemma def_uniq_mmaxS M U V :
  U \subset V -> V \proper G -> 'M(U) = [set M] -> 'M(V) = [set M].
Proof.
move=> sUV prV uU_M; apply/eqP; rewrite eqEsubset sub1set -uU_M.
rewrite mmax_ofS //= inE (sub_uniq_mmax uU_M) //.
by case/mem_uniq_mmax: uU_M => ->.
Qed.

Lemma uniq_mmaxS U V : U \subset V -> V \proper G -> U \in 'U -> V \in 'U.
Proof.
move=> sUV prV /uniq_mmaxP[M uU_M]; apply/uniq_mmaxP; exists M.
exact: def_uniq_mmaxS uU_M.
Qed.

End MinSimpleOdd.

Implicit Arguments uniq_mmaxP [gT U].
Prenex Implicits uniq_mmaxP.

Notation "''M'" := (minSimple_max_groups _) : group_scope.
Notation "''M' ( H )" := (minSimple_max_groups_of H) : group_scope.
Notation "''U'" := (minSimple_uniq_max_groups _) : group_scope.
Notation "''SCN_' n [ p ]" := (minSimple_SCN_at _ n p) : group_scope.

Section Hypothesis7_1.

Variable gT : finGroupType.
Implicit Types X Y A P Q : {group gT}.
Local Notation G := [set: gT].

Definition normed_pgroups (X A : {set gT}) pi :=
  [set Y : {group gT} | pi.-subgroup(X) Y & A \subset 'N(Y)].
Local Notation "|/|_ X ( A ; pi )" := (normed_pgroups X A pi) : group_scope.

Definition max_normed_pgroups (A : {set gT}) pi :=
  [set Y : {group gT} | [max Y | pi.-group Y & A \subset 'N(Y)]].
Local Notation "|/|* ( A ; pi )" := (max_normed_pgroups A pi) : group_scope.

(* This is the statement for B & G, Hypothesis 7.1. *)
Inductive normed_constrained (A : {set gT}) :=
  NormedConstrained (pi := \pi(A)) of A != 1 & A \proper G
  & forall X Y : {group gT},
    A \subset X -> X \proper G -> Y \in |/|_X(A; pi^') -> Y \subset 'O_pi^'(X).

Variable pi : nat_pred.

Lemma max_normed_exists A X :
  pi.-group X -> A \subset 'N(X) -> {Y | Y \in |/|*(A; pi) & X \subset Y}.
Proof.
move=> piX nXA; pose piAn Y := pi.-group(Y) && (A \subset 'N(Y)).
have [|Y] := @maxgroup_exists _ piAn X; first by rewrite /piAn piX.
by exists Y; rewrite // inE.
Qed.

Lemma mem_max_normed A X : X \in |/|*(A; pi) -> pi.-group X /\ A \subset 'N(X).
Proof. by rewrite inE; move/maxgroupp; move/andP. Qed.

Lemma norm_acts_max_norm P : [acts 'N(P), on |/|*(P; pi) | 'JG].
Proof.
apply/subsetP=> z Nz; rewrite !inE; apply/subsetP=> Q; rewrite !inE.
case/maxgroupP=> qQ maxQ; apply/maxgroupP; rewrite pgroupJ norm_conj_norm //.
split=> // Y; rewrite sub_conjg /= => qY; move/maxQ=> <-; rewrite ?conjsgKV //.
by rewrite pgroupJ norm_conj_norm ?groupV.
Qed.

Lemma trivg_max_norm P : 1%G \in |/|*(P; pi) -> |/|*(P; pi) = [set 1%G].
Proof.
move=> max1; apply/eqP; rewrite eqEsubset sub1set max1 andbT.
apply/subsetP=> Q; rewrite !inE -val_eqE /= in max1 *.
by case/maxgroupP: max1 => _ max1; move/maxgroupp; move/max1->; rewrite ?sub1G.
Qed.

Lemma max_normed_uniq A P Q :
    |/|*(A; pi) = [set Q] -> A \subset P -> P \subset 'N(Q) ->
  |/|*(P; pi) = [set Q].
Proof.
move=> defAmax sAP nQP; have: Q \in |/|*(A; pi) by rewrite defAmax set11.
rewrite inE; case/maxgroupP; case/andP=> piQ _ maxQ.
apply/setP=> X; rewrite !inE -val_eqE /=; apply/maxgroupP/eqP=> [[]|->{X}].
  case/andP=> piX nXP maxX; have nXA := subset_trans sAP nXP.
  have [Y] := max_normed_exists piX nXA.
  by rewrite defAmax; move/set1P->; move/maxX=> -> //; rewrite piQ.
rewrite piQ; split=> // X; case/andP=> piX nXP sQX.
by rewrite (maxQ X) // piX (subset_trans sAP).
Qed.

End Hypothesis7_1.

Notation "|/|_ X ( A ; pi )" := (normed_pgroups X A pi) : group_scope.
Notation "|/|* ( A ; pi )" := (max_normed_pgroups A pi) : group_scope.

Section Seven.

Variable gT : minSimpleOddGroupType.
Local Notation G := (TheMinSimpleOddGroup gT).
Local Notation grT := {group gT}.
Implicit Types H P Q R K M A B : grT.
Implicit Type p q : nat.

Section NormedConstrained.

Variables (q : nat) (A : grT).
Let pi := Eval simpl in \pi(A).
Let K := 'O_pi^'('C(A)).
Let nsKC : K <| 'C(A) := pcore_normal _ _.

Lemma cent_core_acts_max_norm : [acts K, on |/|*(A; q) | 'JG].
Proof.
by rewrite (subset_trans _ (norm_acts_max_norm _ _)) ?cents_norm ?pcore_sub.
Qed.
Let actsKmax := actsP cent_core_acts_max_norm.

Hypotheses (cstrA : normed_constrained A) (pi'q : q \notin pi).

Let hyp71 H R :
  A \subset H -> H \proper G -> R \in |/|_H(A; pi^') -> R \subset 'O_pi^'(H).
Proof. by case: cstrA H R. Qed.

(* This is the observation between B & G, Hypothesis 7.1 and Lemma 7.1. *)
Remark normed_constrained_Hall : pi^'.-Hall('C(A)) K.
Proof.
have [_ ntA prA _] := cstrA; rewrite -[setT]/G in prA.
rewrite /pHall pcore_pgroup pcore_sub pnatNK /=.
rewrite -card_quotient ?gFnorm //= -/K.
apply/pgroupP=> p p_pr; case/Cauchy=> // Kx; case/morphimP=> x Nx Cx ->{Kx}.
rewrite /order -quotient_cycle //= -/K => def_p; apply/idPn=> pi'p.
have [P sylP] := Sylow_exists p <[x]>; have [sPx pP _]:= and3P sylP.
suffices: P \subset K.
  have nKP: P \subset 'N(K) by rewrite (subset_trans sPx) ?cycle_subG.
  rewrite -quotient_sub1 //= -/K (sameP trivgP eqP) trivg_card1.
  rewrite (card_Hall (morphim_pHall _ nKP sylP)) def_p part_pnat_id ?pnat_id //.
  by case: eqP p_pr => // ->.
suffices sP_pAC: P \subset 'O_pi^'(A <*> 'C(A)).
  rewrite (subset_trans sP_pAC) ?pcore_max ?pcore_pgroup //.
  rewrite /normal gFnorm_trans ?normsG ?joing_subr // andbT.
  rewrite -quotient_sub1; last first.
    by rewrite gFsub_trans // join_subG !(normG, norms_cent).
  rewrite /= -(setIidPr (pcore_sub _ _)) quotientGI ?joing_subr //=.
  rewrite {1}cent_joinEr // quotientMidr coprime_TIg // coprime_morph //.
  by rewrite coprime_pi' ?cardG_gt0 //= -/pi [pnat _ _]pcore_pgroup.
apply: hyp71; first exact: joing_subl.
  apply: sub_proper_trans (mFT_norm_proper ntA prA).
  by rewrite join_subG normG cent_sub.
have sPC: P \subset 'C(A) by rewrite (subset_trans sPx) ?cycle_subG.
rewrite inE /psubgroup cents_norm 1?centsC // andbT.
rewrite (subset_trans sPC) ?joing_subr //=.
by apply: sub_in_pnat pP => p' _; move/eqnP->.
Qed.
Let hallK := normed_constrained_Hall.

(* This is B & G, Lemma 7.1. *)
Lemma normed_constrained_meet_trans Q1 Q2 H :
    A \subset H -> H \proper G -> Q1 \in |/|*(A; q) -> Q2 \in |/|*(A; q) ->
    Q1 :&: H != 1 -> Q2 :&: H != 1 ->
  exists2 k, k \in K & Q2 :=: Q1 :^ k.
Proof.
move: {2}_.+1 (ltnSn (#|G| - #|Q1 :&: Q2|)) => m.
elim: m => // m IHm in H Q1 Q2 * => geQ12m sAH prHG maxQ1 maxQ2 ntHQ1 ntHQ2.
have:= maxQ1; rewrite inE => /maxgroupP[/andP[qQ1 nQ1A] maxQ1P].
have:= maxQ2; rewrite inE => /maxgroupP[/andP[qQ2 nQ2A] maxQ2P].
have prQ12: Q1 :&: Q2 \proper G.
  rewrite properT; apply: contraNneq (mFT_nonSolvable gT) => <-.
  by apply: pgroup_sol (pgroupS _ qQ1); rewrite subsetIl.
wlog defH: H prHG sAH ntHQ1 ntHQ2 / Q1 :&: Q2 != 1 -> H :=: 'N(Q1 :&: Q2).
  case: (eqVneq (Q1 :&: Q2) 1) => [-> | ntQ12] IH.
    by apply: (IH H) => //; case/eqP.
  apply: (IH 'N(Q1 :&: Q2)%G); rewrite ?normsI ?mFT_norm_proper //;
    apply: contra ntQ12; rewrite -!subG1; apply: subset_trans;
    by rewrite subsetI normG (subsetIl, subsetIr).
pose L := 'O_pi^'(H); have sLH: L \subset H := pcore_sub _ _.
have [nLA coLA solL]: [/\ A \subset 'N(L), coprime #|L| #|A| & solvable L].
  rewrite gFnorm_trans ?normsG // coprime_sym coprime_pi' ?cardG_gt0 //.
  by rewrite -pgroupE pcore_pgroup (solvableS sLH) ?mFT_sol.
have Qsyl Q: Q \in |/|*(A; q) -> Q :&: H != 1 ->
  exists R : {group _}, [/\ q.-Sylow(L) R, A \subset 'N(R) & Q :&: H \subset R].
- case/mem_max_normed=> qQ nQA ntQH.
  have qQH: q.-group (Q :&: H) by rewrite (pgroupS _ qQ) ?subsetIl.
  have nQHA: A \subset 'N(Q :&: H) by rewrite normsI // normsG.
  apply: coprime_Hall_subset => //; apply: (hyp71) => //.
  rewrite inE nQHA /psubgroup subsetIr andbT.
  by apply: sub_in_pnat qQH => p _; move/eqnP->.
have [R1 [sylR1 nR1A sQR1]] := Qsyl _ maxQ1 ntHQ1.
have [R2 [sylR2 nR2A sQR2]] := Qsyl _ maxQ2 ntHQ2.
have [h Ch defR2] := coprime_Hall_trans nLA coLA solL sylR2 nR2A sylR1 nR1A.
have{Ch} [Hh Kh]: h \in H /\ h \in K.
  case/setIP: Ch => Lh Ch; rewrite (subsetP sLH) //.
  rewrite (mem_normal_Hall hallK (pcore_normal _ _)) //.
  by rewrite (mem_p_elt _ Lh) ?pcore_pgroup.
have [Q3 maxQ3 sR2Q3] := max_normed_exists (pHall_pgroup sylR2) nR2A.
have maxQ1h: (Q1 :^ h)%G \in |/|*(A; q) by rewrite actsKmax.
case: (eqsVneq Q1 Q2) => [| neQ12]; first by exists 1; rewrite ?group1 ?conjsg1.
have ntHQ3: Q3 :&: H != 1.
  by apply: subG1_contra ntHQ2; rewrite subsetI subsetIr (subset_trans sQR2).
have ntHQ1h: (Q1 :^ h) :&: H != 1.
  by move: ntHQ1; rewrite !trivg_card1 -(cardJg _ h) conjIg (conjGid Hh).
suff [prI1 prI2]: Q1 :&: Q2 \proper Q1 :&: R1 /\ Q1 :&: Q2 \proper Q2 :&: R2.
  have: #|G| - #|(Q1 :^ h) :&: Q3| < m.
    rewrite ltnS in geQ12m; apply: leq_trans geQ12m.
    rewrite ltn_sub2l ?(proper_card prQ12) // -(cardJg _ h) proper_card //.
    by rewrite (proper_sub_trans _ (setIS _ sR2Q3)) // defR2 -conjIg properJ.
  have: #|G| - #|Q3 :&: Q2| < m.
    rewrite ltnS in geQ12m; apply: leq_trans geQ12m.
    rewrite ltn_sub2l ?proper_card // (proper_sub_trans prI2) //.
    by rewrite setIC setISS.
  case/(IHm H) => // k2 Kk2 defQ2; case/(IHm H) => // k3 Kk3 defQ3.
  by exists (h * k3 * k2); rewrite ?groupM ?conjsgM // -defQ3.
case: (eqVneq (Q1 :&: Q2) 1) => [-> | ntQ12].
  by rewrite !proper1G; split; [move: ntHQ1 | move: ntHQ2];
     apply: subG1_contra; rewrite subsetI subsetIl.
rewrite -(setIidPr (subset_trans (pHall_sub sylR1) sLH)) setIA.
rewrite -(setIidPr (subset_trans (pHall_sub sylR2) sLH)) setIA.
rewrite (setIidPl sQR1) (setIidPl sQR2) {}defH //.
have nilQ1 := pgroup_nil qQ1; have nilQ2 := pgroup_nil qQ2.
rewrite !nilpotent_proper_norm /proper ?subsetIl ?subsetIr ?subsetI ?subxx //=.
  by rewrite andbT; apply: contra neQ12 => sQ21; rewrite (maxQ2P Q1) ?qQ1.
by apply: contra neQ12 => sQ12; rewrite (maxQ1P Q2) ?qQ2.
Qed.

(* This is B & G, Theorem 7.2. *)
Theorem normed_constrained_rank3_trans :
  'r('Z(A)) >= 3 -> [transitive K, on |/|*(A; q) | 'JG].
Proof.
case/rank_geP=> B /nElemP[p]; rewrite !inE subsetI -2!andbA.
case/and4P=> sBA cAB abelB mB3; have [_ cBB _] := and3P abelB.
have q'B: forall Q, q.-group Q -> coprime #|Q| #|B|.
  move=> Q qQ; rewrite coprime_sym (coprimeSg sBA) ?coprime_pi' //.
  exact: pi_pnat qQ _.
have [Q1 maxQ1 _] := max_normed_exists (pgroup1 _ q) (norms1 A).
apply/imsetP; exists Q1 => //; apply/setP=> Q2.
apply/idP/imsetP=> [maxQ2|[k Kk] ->]; last by rewrite actsKmax.
have [qQ1 nQ1A]:= mem_max_normed maxQ1; have [qQ2 nQ2A]:= mem_max_normed maxQ2.
case: (eqVneq Q1 1%G) => [trQ1 | ntQ1].
  exists 1; rewrite ?group1 // act1; apply/eqP.
  by rewrite trivg_max_norm -trQ1 // inE in maxQ2.
case: (eqVneq Q2 1%G) => [trQ2 | ntQ2].
  by case/negP: ntQ1; rewrite trivg_max_norm -trQ2 // inE in maxQ1 *.
have: [exists (C : grT | 'C_Q1(C) != 1), cyclic (B / C) && (C <| B)].
  apply: contraR ntQ1 => trQ1; have: B \subset 'N(Q1) := subset_trans sBA nQ1A.
  rewrite -val_eqE -subG1 /=; move/coprime_abelian_gen_cent <-; rewrite ?q'B //.
  rewrite gen_subG; apply/bigcupsP=> C cocyC; rewrite subG1.
  by apply: contraR trQ1 => ntCC; apply/existsP; exists C; rewrite ntCC.
case/existsP=> C /and3P[ntCQ1 cycBC nsCB]; have [sCB nCB]:= andP nsCB.
have{mB3} ncycC: ~~ cyclic C.
  rewrite (abelem_cyclic (quotient_abelem _ abelB)) ?card_quotient // in cycBC.
  rewrite -divgS // logn_div ?cardSg // leq_subLR addn1 (eqP mB3) in cycBC.
  by rewrite (abelem_cyclic (abelemS sCB abelB)) -ltnNge.
have: [exists (z | 'C_Q2[z] != 1), z \in C^#].
  apply: contraR ntQ2 => trQ2; have:= subset_trans sCB (subset_trans sBA nQ2A).
  rewrite -[_ == _]subG1 /=.
  move/coprime_abelian_gen_cent1 <-; rewrite ?(abelianS sCB) //; last first.
    by rewrite (coprimegS sCB) ?q'B.
  rewrite gen_subG; apply/bigcupsP=> z Cz.
  by apply: contraR trQ2 => ntCz; apply/existsP; exists z; rewrite -subG1 ntCz.
case/existsP=> z; rewrite !inE => /and3P[ntzQ2 ntz Cz].
have prCz: 'C[z] \proper G by rewrite -cent_cycle mFT_cent_proper ?cycle_eq1.
have sACz: A \subset 'C[z] by rewrite sub_cent1 (subsetP cAB) ?(subsetP sCB).
have [|//|k Kk defQ2]:= normed_constrained_meet_trans sACz prCz maxQ1 maxQ2.
  by apply: subG1_contra ntCQ1; rewrite setIS //= -cent_cycle centS ?cycle_subG.
by exists k => //; apply: val_inj.
Qed.

(* This is B & G, Theorem 7.3. *)
Theorem normed_constrained_rank2_trans :
  q %| #|'C(A)| -> 'r('Z(A)) >= 2 -> [transitive K, on |/|*(A; q) | 'JG].
Proof.
move=> qC /rank_geP[B /nElemP[p /setIdP[/setIdP[/subsetIP[sBA cAB] abelB] oB]]].
have [_ cBB _] := and3P abelB.
have{abelB oB} ncycB: ~~ cyclic B by rewrite (abelem_cyclic abelB) (eqP oB).
have [R0 sylR0] := Sylow_exists q 'C(A); have [cAR0 qR0 _] := and3P sylR0.
have nR0A: A \subset 'N(R0) by rewrite cents_norm // centsC.
have{nR0A} [R maxR sR0R] := max_normed_exists qR0 nR0A.
apply/imsetP; exists R => //; apply/setP=> Q.
apply/idP/imsetP=> [maxQ|[k Kk] ->]; last by rewrite actsKmax.
have [qR nRA]:= mem_max_normed maxR; have [qQ nQA]:= mem_max_normed maxQ.
have [R1 | ntR] := eqVneq R 1%G.
  rewrite trivg_max_norm -R1 // in maxQ.
  by exists 1; rewrite ?group1 ?act1 ?(set1P maxQ).
have ntQ: Q != 1%G.
  by apply: contra ntR => Q1; rewrite trivg_max_norm -(eqP Q1) // inE in maxR *.
have ntRC: 'C_R(A) != 1.
  have sR0CR: R0 \subset 'C_R(A) by rewrite subsetI sR0R.
  suffices: R0 :!=: 1 by apply: subG1_contra.
  move: ntR; rewrite -!cardG_gt1 -(part_pnat_id qR) (card_Hall sylR0).
  by rewrite !p_part_gt1 !mem_primes !cardG_gt0 qC => /and3P[->].
have: [exists (z | 'C_Q[z] != 1), z \in B^#].
  apply: contraR ntQ => trQ; have:= subset_trans sBA nQA.
  rewrite -[_ == _]subG1=> /coprime_abelian_gen_cent1 <- //; last first.
    by rewrite coprime_sym (coprimeSg sBA) ?coprime_pi' /pgroup ?(pi_pnat qQ).
  rewrite gen_subG; apply/bigcupsP=> z Cz; rewrite subG1.
  by apply: contraR trQ => ntCz; apply/existsP; exists z; rewrite ntCz.
case/existsP=> z; rewrite 2!inE => /and3P[ntzQ ntz Bz].
have prCz: 'C[z] \proper G by rewrite -cent_cycle mFT_cent_proper ?cycle_eq1.
have sACz: A \subset 'C[z] by rewrite sub_cent1 (subsetP cAB).
have [|//|k Kk defQ2]:= normed_constrained_meet_trans sACz prCz maxR maxQ.
  apply: subG1_contra ntRC; rewrite setIS //=.
  by rewrite -cent_cycle centS // cycle_subG (subsetP sBA).
by exists k => //; apply: val_inj.
Qed.

(* This is B & G, Theorem 7.4. *)
Theorem normed_trans_superset P :
    A <|<| P -> pi.-group P -> [transitive K, on |/|*(A; q) | 'JG] ->
 [/\ 'C_K(P) = 'O_pi^'('C(P)),
     [transitive 'O_pi^'('C(P)), on |/|*(P; q) | 'JG],
     |/|*(P; q) \subset |/|*(A; q)
   & {in |/|*(P; q), forall Q, P :&: 'N(P)^`(1) \subset 'N(Q)^`(1)
                            /\ 'N(P) = 'C_K(P) * 'N_('N(P))(Q)}].
Proof.
move=> snAP piP trnK; set KP := 'O_pi^'('C(P)).
have defK B: A \subset B -> 'C_K(B) = 'O_pi^'('C(B)).
  move=> sAB; apply/eqP; rewrite eqEsubset {1}setIC pcoreS ?centS // subsetI.
  by rewrite gFsub (sub_Hall_pcore hallK) ?pcore_pgroup // gFsub_trans ?centS.
suffices: [transitive KP, on |/|*(P; q) | 'JG] /\ |/|*(P; q) \subset |/|*(A; q).
  have nsKPN: KP <| 'N(P) := gFnormal_trans _ (cent_normal _).
  case=> trKP smnPA; rewrite (defK _ (subnormal_sub snAP)); split=> // Q maxQ.
  have defNP: KP * 'N_('N(P))(Q) = 'N(P).
    rewrite -(astab1JG Q) -normC; last by rewrite subIset 1?normal_norm.
    apply/(subgroup_transitiveP maxQ); rewrite ?normal_sub //=.
    by rewrite (atrans_supgroup _ trKP) ?norm_acts_max_norm ?normal_sub.
  split=> //; move/pprod_focal_coprime: defNP => -> //.
  - by rewrite subIset // orbC commgSS ?subsetIr.
  - by rewrite subsetI normG; case/mem_max_normed: maxQ.
  by rewrite (p'nat_coprime (pcore_pgroup _ _)).
elim: {P}_.+1 {-2}P (ltnSn #|P|) => // m IHm P lePm in KP piP snAP *.
wlog{snAP} [B maxnB snAB]: / {B : grT | maxnormal B P P & A <|<| B}.
  case/subnormalEr: snAP => [|[D [snAD nDP prDP]]]; first by rewrite /KP => <-.
  have [B maxnB sDB]: {B : grT | maxnormal B P P & D \subset B}.
    by apply: maxgroup_exists; rewrite prDP normal_norm.
  apply; exists B => //; apply: subnormal_trans snAD (normal_subnormal _).
  by apply: normalS sDB _ nDP; case/andP: (maxgroupp maxnB); case/andP.
have [prBP nBP] := andP (maxgroupp maxnB); have sBP := proper_sub prBP.
have{lePm}: #|B| < m by apply: leq_trans (proper_card prBP) _.
case/IHm=> {IHm}// [|trnB smnBA]; first by rewrite (pgroupS sBP).
have{maxnB} abelPB: is_abelem (P / B).
  apply: charsimple_solvable (maxnormal_charsimple _ maxnB) _ => //.
  have [_ ntA _ _] := cstrA; have sAB := subnormal_sub snAB.
  by apply: mFT_quo_sol; apply: contraL sAB; move/eqP->; rewrite subG1.
have{abelPB} [p p_pr pPB]: exists2 p, prime p & p.-group (P / B).
  by case/is_abelemP: abelPB => p p_pr; case/andP; exists p.
have{prBP} pi_p: p \in pi.
  case/pgroup_pdiv: pPB => [|_ pPB _].
    by rewrite -subG1 quotient_sub1 // proper_subn.
  by apply: pgroupP p_pr pPB; apply: quotient_pgroup.
pose S := |/|*(B; q); have p'S: #|S| %% p != 0.
  have pi'S: pi^'.-nat #|S| := pnat_dvd (atrans_dvd trnB) (pcore_pgroup _ _).
  by rewrite -prime_coprime // (pnat_coprime _ pi'S) ?pnatE.
have{p'S} [Q S_Q nQP]: exists2 Q, Q \in S & P \subset 'N(Q).
  have sTSB: setT \subset G / B by rewrite -im_quotient quotientS ?subsetT.
  have modBE: {in P & S, forall x Q, ('JG %% B) Q (coset B x) = 'JG Q x}%act.
    move=> x Q Px; rewrite inE; move/maxgroupp; case/andP=> _ nQB.
    by rewrite /= modactE ?(subsetP nBP) ?afixJG ?setTI ?inE.
  have actsPB: [acts P / B, on S | 'JG %% B \ sTSB].
    apply/subsetP=> _ /morphimP[x Nx Px ->].
    rewrite !inE; apply/subsetP=> Q S_Q; rewrite inE /= modBE //.
    by rewrite (actsP (norm_acts_max_norm q B)).
  move: p'S; rewrite (pgroup_fix_mod pPB actsPB); set nQ := #|_|.
  case: (posnP nQ) => [->|]; first by rewrite mod0n.
  rewrite lt0n; case/existsP=> Q /setIP[Q_S fixQ]; exists Q => //.
  apply/normsP=> x Px; apply: congr_group; have Nx := subsetP nBP x Px.
  by have:= afixP fixQ (coset B x); rewrite /= modBE ?mem_morphim //= => ->.
have [qQ _]:= mem_max_normed S_Q.
have{qQ nQP} [Q0 maxQ0 sQQ0] := max_normed_exists qQ nQP.
have [_ nQ0P]:= mem_max_normed maxQ0.
have actsKmnP: [acts 'O_pi^'('C(P)), on |/|*(P; q) | 'JG].
  by rewrite (subset_trans _ (norm_acts_max_norm q P)) // cents_norm ?pcore_sub.
case nt_mnP: (1%G \in |/|*(P; q)) => [|{Q S_Q sQQ0}].
  rewrite atrans_acts_card actsKmnP trivg_max_norm // imset_set1 in maxQ0 *.
  have <-: Q = 1%G by apply/trivGP; rewrite -(congr_group (set1P maxQ0)).
  by rewrite cards1 sub1set (subsetP smnBA).
have sAB := subnormal_sub snAB; have sAP := subset_trans sAB sBP.
have smnP_S: |/|*(P; q) \subset S.
  apply/subsetP=> Q1 maxQ1; have [qQ1 nQ1P] := mem_max_normed maxQ1.
  have ntQ1: Q1 != 1%G by case: eqP nt_mnP maxQ1 => // -> ->.
  have prNQ1: 'N(Q1) \proper G := mFT_norm_proper ntQ1 (mFT_pgroup_proper qQ1).
  have nQ1A: A \subset 'N(Q1) := subset_trans sAP nQ1P.
  have [Q2 maxQ2 sQ12] := max_normed_exists qQ1 (subset_trans sBP nQ1P).
  have [qQ2 nQ2B] := mem_max_normed maxQ2; apply: etrans maxQ2; congr in_mem.
  apply: val_inj; suffices: q.-Sylow(Q2) Q1 by move/pHall_id=> /= ->.
  have qNQ2: q.-group 'N_Q2(Q1) by rewrite (pgroupS _ qQ2) ?subsetIl.
  pose KN := 'O_pi^'('N(Q1)); have sNQ2_KN: 'N_Q2(Q1) \subset KN.
    rewrite hyp71 // inE normsI ?norms_norm ?(subset_trans sAB nQ2B) //=.
    by rewrite /psubgroup subsetIr andbT; apply: pi_pnat qNQ2 _.
  rewrite -Sylow_subnorm (pHall_subl _ sNQ2_KN) ?subsetI ?sQ12 ?normG //= -/KN.
  suff: exists Q3 : grT, [/\ q.-Sylow(KN) Q3, P \subset 'N(Q3) & Q1 \subset Q3].
    move: maxQ1; rewrite inE; case/maxgroupP=> _ maxQ1 [Q3 [sylQ3 nQ3P sQ13]].
    by rewrite -(maxQ1 Q3) // (pHall_pgroup sylQ3).
  apply: coprime_Hall_subset; rewrite //= -/KN.
  - by rewrite gFnorm_trans ?norms_norm.
  - by rewrite coprime_sym (pnat_coprime piP (pcore_pgroup _ _)).
  - by rewrite (solvableS (pcore_sub _ _)) ?mFT_sol.
  by rewrite pcore_max ?normalG // /pgroup (pi_pnat qQ1).
split; last exact: subset_trans smnP_S smnBA.
apply/imsetP; exists Q0 => //; apply/setP=> Q2.
apply/idP/imsetP=> [maxQ2 | [k Pk ->]]; last by rewrite (actsP actsKmnP).
have [S_Q0 S_Q2]: Q0 \in S /\ Q2 \in S by rewrite !(subsetP smnP_S).
pose KB := 'O_pi^'('C(B)); pose KBP := KB <*> P.
have pi'KB: pi^'.-group KB by apply: pcore_pgroup.
have nKB_P: P \subset 'N(KB) by rewrite gFnorm_trans ?norms_cent.
have [k KBk defQ2]:= atransP2 trnB S_Q0 S_Q2.
have [qQ2 nQ2P] := mem_max_normed maxQ2.
have hallP: pi.-Hall('N_KBP(Q2)) P.
  have sPN: P \subset 'N_KBP(Q2) by rewrite subsetI joing_subr.
  rewrite pHallE eqn_leq -{1}(part_pnat_id piP) dvdn_leq ?partn_dvd ?cardSg //.
  have ->: #|P| = #|KBP|`_pi.
    rewrite /KBP joingC norm_joinEl // coprime_cardMg ?(pnat_coprime piP) //.
    by rewrite partnM // part_pnat_id // part_p'nat // muln1.
  by rewrite sPN dvdn_leq ?partn_dvd ?cardSg ?cardG_gt0 ?subsetIl.
have hallPk: pi.-Hall('N_KBP(Q2)) (P :^ k).
  rewrite pHallE -(card_Hall hallP) cardJg eqxx andbT subsetI /=.
  by rewrite defQ2 normJ conjSg conj_subG ?joing_subr // mem_gen // inE KBk.
have [gz]: exists2 gz, gz \in 'N_KBP(Q2) & P :=: (P :^ k) :^ gz.
  apply: Hall_trans (solvableS (subsetIr _ _) _) hallP hallPk.
  have ntQ2: Q2 != 1%G by case: eqP nt_mnP maxQ2 => // -> ->.
  exact: mFT_sol (mFT_norm_proper ntQ2 (mFT_pgroup_proper qQ2)).
rewrite [KBP]norm_joinEr //= setIC -group_modr //= setIC -/KB.
case/imset2P=> g z; case/setIP=> KBg nQ2g Pz ->{gz} defP.
exists (k * g); last first.
  by apply: val_inj; rewrite /= conjsgM -(normP nQ2g) defQ2.
rewrite /KP -defK // (subsetP (subsetIl _ 'C(B))) //= setIAC defK // -/KB.
rewrite -coprime_norm_cent 1?coprime_sym ?(pnat_coprime piP) //= -/KB.
rewrite inE groupM //; apply/normP.
by rewrite -{2}(conjsgK z P) (conjGid Pz) {2}defP /= !conjsgM conjsgK.
Qed.

End NormedConstrained.

(* This is B & G, Proposition 7.5(a). As this is only used in Proposition    *)
(* 10.10, under the assumption A \in E*_p(G), we avoid the in_pmaxElemE      *)
(* detour A = [set x in 'C_G(A) | x ^+ p == 1], and just use A \in E*_p(G).  *)
Proposition plength_1_normed_constrained p A :
    A :!=: 1 -> A \in 'E*_p(G) -> (forall M, M \proper G -> p.-length_1 M) ->
  normed_constrained A.
Proof.
move=> ntA EpA pl1subG.
case/pmaxElemP: (EpA); case/pElemP=> sAG; case/and3P=> pA cAA _ _.
have prA: A \proper G := sub_proper_trans cAA (mFT_cent_proper ntA).
split=> // X Y sAX prX; case/setIdP; case/andP=> sYX p'Y nYA.
have pl1X := pl1subG _ prX; have solX := mFT_sol prX.
have [p_pr _ [r oApr]] := pgroup_pdiv pA ntA.
have oddp: odd p by move: (mFT_odd A); rewrite oApr odd_exp.
have def_pi: \pi(A)^' =i p^'.
  by move=> q; rewrite inE /= oApr pi_of_exp // pi_of_prime.
have{p'Y} p'Y : p^'.-group Y by rewrite -(eq_pgroup _ def_pi).
rewrite (eq_pcore _ def_pi) (@plength1_norm_pmaxElem _ p X A) //.
by rewrite (subsetP (pmaxElemS p (subsetT _))) // setIC 2!inE sAX.
Qed.

(* This is B & G, Proposition 7.5(b). *)
Proposition SCN_normed_constrained p P A :
  p.-Sylow(G) P -> A \in 'SCN_2(P) -> normed_constrained A.
Proof.
move=> sylP; rewrite 2!inE -andbA => /and3P[nsAP /eqP defCA lt1mA].
have [sAP nAP]:= andP nsAP.
have pP := pHall_pgroup sylP; have pA := pgroupS sAP pP.
have abA: abelian A by rewrite /abelian -{1}defCA subsetIr.
have prP: P \proper G := mFT_pgroup_proper pP.
have ntA: A :!=: 1 by rewrite -rank_gt0 ltnW.
pose pi := \pi(A); simpl in pi.
have [p_pr pdvA [r oApr]] := pgroup_pdiv pA ntA.
have{r oApr} def_pi: pi =i (p : nat_pred).
  by move=> p'; rewrite !inE oApr primes_exp // primes_prime ?inE.
have def_pi' := eq_negn def_pi; have defK := eq_pcore _ def_pi'.
pose Z := 'Ohm_1('Z(P)); have sZ_ZP: Z \subset 'Z(P) by apply: Ohm_sub.
have sZP_A: 'Z(P) \subset A by rewrite -defCA setIS ?centS.
have sZA := subset_trans sZ_ZP sZP_A.
have nsA1: 'Ohm_1(A) <| P by apply: gFnormal_trans.
pose inZor1 B := B \subset Z \/ #|Z| = p /\ Z \subset B.
have [B [E2_B nsBP sBZ]]: exists B, [/\ B \in 'E_p^2(A), B <| P & inZor1 B].
  have pZP: p.-group 'Z(P) by apply: pgroupS (center_sub _) pP.
  have pZ: p.-group Z by apply: pgroupS sZ_ZP pZP.
  have abelZ: p.-abelem Z by rewrite Ohm1_abelem ?center_abelian.
  have nsZP: Z <| P := sub_center_normal sZ_ZP; have [sZP nZP] := andP nsZP.
  case: (eqVneq Z 1).
    rewrite -(setIidPr sZ_ZP); move/TI_Ohm1; rewrite setIid.
    by move/(trivg_center_pgroup pP)=> P1; rewrite -subG1 -P1 sAP in ntA.
  case/(pgroup_pdiv pZ)=> _ _ [[|k] /=]; rewrite -/Z => oZ; last first.
    have: 2 <= 'r_p(Z) by rewrite p_rank_abelem // oZ pfactorK.
    case/p_rank_geP=> B; rewrite /= -/Z => Ep2Z_B; exists B.
    rewrite (subsetP (pnElemS _ _ sZA)) //.
    case/setIdP: Ep2Z_B; case/setIdP=> sBZ _ _; split=> //; last by left.
    by rewrite sub_center_normal ?(subset_trans sBZ).
  pose BZ := ('Ohm_1(A) / Z) :&: 'Z(P / Z).
  have ntBz: BZ != 1.
    rewrite meet_center_nil ?quotient_nil ?(pgroup_nil pP) ?quotient_normal //.
    rewrite -subG1 quotient_sub1 ?(subset_trans (normal_sub nsA1) nZP) //= -/Z.
    apply: contraL lt1mA => sA1Z; rewrite -(pfactorK 1 p_pr) -oZ -rank_Ohm1.
    by rewrite -(rank_abelem abelZ) -leqNgt rankS.
  have lt1A1: 1 < logn p #|'Ohm_1(A)| by rewrite -p_rank_abelian -?rank_pgroup.
  have [B [sBA1 nsBP oB]] := normal_pgroup pP nsA1 lt1A1.
  exists B; split=> //; last do [right; split=> //].
    rewrite 2!inE (subset_trans sBA1) ?Ohm_sub // oB pfactorK //.
    by rewrite (abelemS sBA1) ?Ohm1_abelem.
  apply/idPn=> s'BZ; have: B :&: Z = 1 by rewrite setIC prime_TIg ?oZ.
  move/TI_Ohm1; apply/eqP; rewrite meet_center_nil ?(pgroup_nil pP) //.
  by rewrite -cardG_gt1 oB (ltn_exp2l 0 _ (prime_gt1 p_pr)).
split; rewrite ?(sub_proper_trans sAP) // => X Y sAX prX.
rewrite inE defK -andbA (eq_pgroup _ def_pi'); case/and3P=> sYX p'Y nYA.
move: E2_B; rewrite 2!inE -andbA; case/and3P=> sBA abelB dimB2.
have [pB cBB _] := and3P abelB.
have ntB: B :!=: 1 by case: (eqsVneq B 1) dimB2 => // ->; rewrite cards1 logn1.
have cBA b: b \in B -> A \subset 'C[b].
  by move=> Bb; rewrite -cent_set1 centsC sub1set (subsetP abA) ?(subsetP sBA).
have solCB (b : gT): b != 1 -> solvable 'C[b].
  by move=> ntb; rewrite mFT_sol ?mFT_cent1_proper.
wlog{sAX prX} [b B'b defX]: X Y p'Y nYA sYX / exists2 b, b \in B^# & 'C[b] = X.
  move=> IH; have nYB := subset_trans sBA nYA.
  rewrite -(coprime_abelian_gen_cent1 cBB _ nYB); last first.
  - by rewrite coprime_sym (pnat_coprime pB).
  - apply: contraL dimB2 => /cyclicP[x defB].
    have Bx: x \in B by rewrite defB cycle_id.
    rewrite defB -orderE (abelem_order_p abelB Bx) ?(pfactorK 1) //.
    by rewrite -cycle_eq1 -defB.
  rewrite gen_subG; apply/bigcupsP=> b B'b.
  have [ntb Bb]:= setD1P B'b; have sYbY: 'C_Y[b] \subset Y := subsetIl _ _.
  have{IH} sYbKb: 'C_Y[b] \subset 'O_p^'('C[b]).
    rewrite IH ?(pgroupS sYbY) ?subsetIr //; last by exists b.
    by rewrite normsI // ?normsG ?cBA.
  have{sYbKb} sYbKXb: 'C_Y[b] \subset 'O_p^'('C_X(<[b]>)).
    apply: subset_trans (pcoreS _ (subsetIr _ _)).
    by rewrite /= cent_gen cent_set1 subsetI setSI.
  rewrite (subset_trans sYbKXb) // p'core_cent_pgroup ?mFT_sol //.
  rewrite /psubgroup ?(pgroupS _ pB) cycle_subG //.
  by rewrite (subsetP sAX) ?(subsetP sBA).
wlog Zb: b X Y defX B'b p'Y nYA sYX / b \in Z.
  move=> IH; case Zb: (b \in Z); first exact: IH Zb.
  case/setD1P: B'b => ntb Bb; have solX := solCB b ntb; rewrite defX in solX.
  case: sBZ => [sBZ | [oZ sZB]]; first by rewrite (subsetP sBZ) in Zb.
  have defB: Z * <[b]> = B.
    apply/eqP; rewrite eqEcard mulG_subG sZB cycle_subG Bb.
    have obp := abelem_order_p abelB Bb ntb.
    rewrite (card_pgroup pB) /= (eqP dimB2) TI_cardMg -/#[_] ?oZ ?obp //.
    rewrite -obp in p_pr; case: (prime_subgroupVti [group of Z] p_pr) => //.
    by rewrite cycle_subG Zb.
  pose P1 := P :&: X; have sP1P: P1 \subset P := subsetIl _ _.
  have pP1 := pgroupS sP1P pP.
  have [P2 sylP2 sP12] := Sylow_superset (subsetIr _ _) pP1.
  have defP1: P1 = 'C_P(B).
    rewrite -defB centM /= -/Z setIA /cycle cent_gen cent_set1 defX.
    by rewrite [P :&: _](setIidPl _) // centsC (subset_trans sZ_ZP) ?subsetIr.
  have dimPP1: logn p #|P : P1| <= 1.
    by rewrite defP1 logn_quotient_cent_abelem ?normal_norm ?(eqP dimB2).
  have{dimPP1} nsP12: P1 <| P2.
    have pP2 := pHall_pgroup sylP2.
    have: logn p #|P2 : P1| <= 1.
      apply: leq_trans dimPP1; rewrite dvdn_leq_log //.
      rewrite -(dvdn_pmul2l (cardG_gt0 [group of P1])) !Lagrange ?subsetIl //.
      rewrite -(part_pnat_id pP2) (card_Hall sylP).
      by rewrite partn_dvd ?cardSg ?subsetT.
    rewrite -(pfactorK 1 p_pr) -pfactor_dvdn ?prime_gt0 // -p_part.
    rewrite part_pnat_id ?(pnat_dvd (dvdn_indexg _ _)) //=.
    case: (primeP p_pr) => _ dv_p; move/dv_p=> {dv_p}.
    case/pred2P=> oP21; first by rewrite -(index1g sP12 oP21) normal_refl.
    by rewrite (p_maximal_normal pP2) ?p_index_maximal ?oP21.
  have nsZP1_2: 'Z(P1) <| P2 by rewrite gFnormal_trans.
  have sZKp: Z \subset 'O_{p^', p}(X).
    suff: 'Z(P1) \subset 'O_{p^', p}(X).
      apply: subset_trans; rewrite subsetI {1}defP1 (subset_trans sZB).
        by rewrite (subset_trans sZ_ZP) ?subIset // orbC centS.
      by rewrite subsetI normal_sub.
    apply: odd_p_abelian_constrained sylP2 (center_abelian _) nsZP1_2 => //.
    exact: mFT_odd.
  have coYZ: coprime #|Y| #|Z|.
    by rewrite oZ coprime_sym (pnat_coprime _ p'Y) ?pnatE ?inE.
  have nYZ := subset_trans sZA nYA.
  have <-: [~: Y, Z] * 'C_Y(Z) = Y.
    exact: coprime_cent_prod (solvableS sYX solX).
  set K := 'O_p^'(X); have [nKY nKZ]: Y \subset 'N(K) /\ Z \subset 'N(K).
    by rewrite !gFnorm_trans ?(subset_trans sZA) ?normsG // -defX cBA.
  rewrite mul_subG //.
    have coYZK: coprime #|Y / K| #|'O_p(X / K)|.
      by rewrite coprime_sym coprime_morphr ?(pnat_coprime (pcore_pgroup _ _)).
    rewrite -quotient_sub1 ?comm_subG // -(coprime_TIg coYZK) subsetI.
    rewrite /= -quotient_pseries2 !quotientS ?commg_subl //.
    by rewrite (subset_trans (commgSS sYX sZKp)) ?commg_subr //= gFnorm.
  have: 'O_p^'('C_X(Z)) \subset K.
    rewrite p'core_cent_pgroup // /psubgroup /pgroup oZ pnat_id //.
    by rewrite -defX (subset_trans sZA) ?cBA.
  apply: subset_trans; apply: subset_trans (pcoreS _ (subsetIr _ _)).
  have: cyclic Z by rewrite prime_cyclic ?oZ.
  case/cyclicP=> z defZ; have Zz: z \in Z by rewrite defZ cycle_id.
  rewrite subsetI setSI //= (IH z) ?subsetIr ?(pgroupS (subsetIl _ _)) //.
  - by rewrite defZ /= cent_gen cent_set1.
  - rewrite !inE -cycle_eq1 -defZ trivg_card_le1 oZ -ltnNge prime_gt1 //=.
    by rewrite (subsetP sZB).
  by rewrite normsI // norms_cent // cents_norm // centsC (subset_trans sZA).
set K := 'O_p^'(X); have nsKX: K <| X by apply: pcore_normal.
case/setD1P: B'b => ntb Bb.
have [sAX solX]: A \subset X /\ solvable X by rewrite -defX cBA ?solCB.
have sPX: P \subset X.
  by rewrite -defX -cent_set1 centsC sub1set; case/setIP: (subsetP sZ_ZP b Zb).
have [nKA nKY nKP]: [/\ A \subset 'N(K), Y \subset 'N(K) & P \subset 'N(K)].
  by rewrite !(subset_trans _ (normal_norm nsKX)).
have sylPX: p.-Sylow(X) P by apply: pHall_subl (subsetT _) sylP.
have sAKb: A \subset 'O_{p^', p}(X).
  exact: (odd_p_abelian_constrained (mFT_odd _)) abA nsAP.
have coYZK: coprime #|Y / K| #|'O_p(X / K)|.
  by rewrite coprime_sym coprime_morphr ?(pnat_coprime (pcore_pgroup _ _)).
have cYAq: A / K \subset 'C_('O_p(X / K))(Y / K).
  rewrite subsetI -quotient_pseries2 quotientS //= (sameP commG1P trivgP).
  rewrite /= -quotientR // -(coprime_TIg coYZK) subsetI /= -quotient_pseries2.
  rewrite !quotientS ?commg_subr // (subset_trans (commgSS sAKb sYX)) //.
  by rewrite commg_subl /= gFnorm.
have cYKq: Y / K \subset 'C('O_p(X / K)).
  apply: coprime_nil_faithful_cent_stab => /=.
  - by rewrite gFnorm_trans ?normsG ?quotientS.
  - by rewrite coprime_sym.
  - exact: pgroup_nil (pcore_pgroup _ _).
  apply: subset_trans (cYAq); rewrite -defCA -['C_P(A) / K](morphim_restrm nKP).
  rewrite injm_cent ?ker_restrm ?ker_coset ?morphim_restrm -?quotientE //.
    rewrite setIid (setIidPr sAP) setISS ?centS //.
    by rewrite pcore_sub_Hall ?morphim_pHall.
  by rewrite coprime_TIg ?(pnat_coprime _ (pcore_pgroup _ _)).
rewrite -quotient_sub1 //= -/K -(coprime_TIg coYZK) subsetI subxx /=.
rewrite -Fitting_eq_pcore ?trivg_pcore_quotient // in cYKq *.
apply: subset_trans (cent_sub_Fitting (quotient_sol _ solX)).
by rewrite subsetI quotientS.
Qed.

(* This is B & G, Theorem 7.6 (the Thompson Transitivity Theorem). *)
Theorem Thompson_transitivity p q A :
    A \in 'SCN_3[p] -> q \in p^' ->
  [transitive 'O_p^'('C(A)), on |/|*(A; q) | 'JG].
Proof.
case/bigcupP=> P; rewrite 2!inE => sylP /andP[SCN_A mA3].
have [defZ def_pi']: 'Z(A) = A /\ \pi(A)^' =i p^'.
  rewrite inE -andbA in SCN_A; case/and3P: SCN_A => sAP _ /eqP defCA.
  case: (eqsVneq A 1) mA3 => /= [-> | ntA _].
    rewrite /rank big1_seq // => p1 _; rewrite /p_rank big1 // => E.
    by rewrite inE; case/andP; move/trivgP->; rewrite cards1 logn1.
  have [p_pr _ [k ->]] := pgroup_pdiv (pgroupS sAP (pHall_pgroup sylP)) ntA.
  split=> [|p1]; last by rewrite !inE primes_exp // primes_prime ?inE.
  by apply/eqP; rewrite eqEsubset subsetIl subsetI subxx -{1}defCA subsetIr.
rewrite -(eq_pcore _ def_pi') -def_pi' => pi'q.
apply: normed_constrained_rank3_trans; rewrite ?defZ //.
by apply: SCN_normed_constrained sylP _; rewrite inE SCN_A ltnW.
Qed.

End Seven.


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

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Parts2.
(** Title "Cantor Bernstein theorem" *)
Comments
  "We prove that if there is an injection from A to B, and an injection from B to A".
Comments "then there is a bijection between A and B.".
Section Cantor_Bernstein.
Variable E F : Setoid.
Variable f : MAP E F.
Variable g : MAP F E.
Hypothesis finj : injective f.
Hypothesis ginj : injective g.

Let h (X : part_set E) := compl (image g (compl (image f X))).

Let h_incr : forall A B : part_set E, included A B -> included (h A) (h B).
unfold h in |- *.
auto with algebra.
Qed.
Hint Resolve h_incr: algebra.

Let PX : part_set (part_set E).
apply (Build_Predicate (Pred_fun:=fun A : part_set E => included A (h A))).
red in |- *.
intros x y H' H'0; try assumption.
apply included_comp with x (h x); auto with algebra.
unfold h in |- *.
auto with algebra.
Defined.

Let X := union_part PX.

Let XhX : included X (h X).
unfold X in |- *.
apply union_part_upper_bound.
intros A H'; try assumption.
apply included_trans with (h A); auto with algebra.
Qed.

Let hXX : included (h X) X.
unfold X in |- *.
apply union_part_included.
simpl in |- *.
apply h_incr.
exact XhX.
Qed.

Let PXeq : Equal (h X) X.
apply included_antisym.
exact hXX.
exact XhX.
Qed.
Hint Resolve PXeq hXX XhX: algebra.

Let img : Equal (image g (compl (image f X))) (compl X).
apply Trans with (compl (h X)); auto with algebra.
unfold h in |- *; auto with algebra.
Qed.
Hint Resolve img: algebra.
Hypothesis
  partial_section :
    forall (E F : Setoid) (f : MAP E F),
    injective f -> exists g : MAP F E, Equal (comp_map_map g f) (Id E).
Hypothesis
  map_extend :
    forall (E F : Setoid) (f g : MAP E F) (A : part_set E),
    exists b : MAP E F,
      (forall x : E, in_part x A -> Equal (b x) (f x)) /\
      (forall x : E, ~ in_part x A -> Equal (b x) (g x)).

Theorem Cantor_Berstein : exists b : MAP E F, bijective b.
case (partial_section ginj).
intros g1 H'; try assumption.
case (map_extend f g1 X).
intros b H'1; try assumption.
exists b; try assumption.
elim H'1; intros H'2 H'3; try exact H'2; clear H'1.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
intros x y H'0; try assumption.
case (compl_not_compl X x); intros.
case (compl_not_compl X y); intros.
apply finj.
apply Trans with (b y); auto with algebra.
apply Trans with (b x); auto with algebra.
apply Sym; auto with algebra.
cut (in_part y (image g (compl (image f X)))).
intros H'1; try assumption.
generalize (image_in H'1).
intros H'4; try assumption.
elim H'4; intros x0 E0; try exact E0; clear H'4.
elim E0; intros H'4 H'5; try exact H'5; clear E0.
absurd (in_part x0 (compl (image f X))); auto with algebra.
apply not_in_comp_l with (Ap (Id F) x0); auto with algebra.
apply not_in_comp_l with (Ap (comp_map_map g1 g) x0); auto with algebra.
apply not_in_comp_l with (Ap g1 (Ap g x0)); auto with algebra.
apply not_in_comp_l with (Ap g1 y); auto with algebra.
apply not_in_comp_l with (Ap b y); auto with algebra.
apply not_in_comp_l with (Ap b x); auto with algebra.
apply not_in_comp_l with (Ap f x); auto with algebra.
apply Sym; auto with algebra.
apply in_part_comp_r with (compl X); auto with algebra.
case (compl_not_compl X y); intros.
cut (in_part x (image g (compl (image f X)))).
intros H'1; try assumption.
generalize (image_in H'1).
intros H'4; try assumption.
elim H'4; intros x0 E0; try exact E0; clear H'4.
elim E0; intros H'4 H'5; try exact H'5; clear E0.
absurd (in_part x0 (compl (image f X))); auto with algebra.
apply not_in_comp_l with (Ap (Id F) x0); auto with algebra.
apply not_in_comp_l with (Ap (comp_map_map g1 g) x0); auto with algebra.
apply not_in_comp_l with (Ap g1 (Ap g x0)); auto with algebra.
apply not_in_comp_l with (Ap g1 x); auto with algebra.
apply not_in_comp_l with (Ap b x); auto with algebra.
apply not_in_comp_l with (Ap b y); auto with algebra.
apply not_in_comp_l with (Ap f y); auto with algebra.
apply Sym; auto with algebra.
apply in_part_comp_r with (compl X); auto with algebra.
cut (in_part x (image g (compl (image f X)))).
cut (in_part y (image g (compl (image f X)))).
intros H'1 H'4; try assumption.
generalize (image_in H'1).
generalize (image_in H'4).
intros H'5 H'6; try assumption.
elim H'6; intros x0 E0; elim E0; intros H'7 H'8; try exact H'7; clear E0 H'6.
elim H'5; intros x1 E0; elim E0; intros H'6 H'9; try exact H'6; clear E0 H'5.
apply Trans with (Ap g x1); auto with algebra.
apply Trans with (Ap g x0); auto with algebra.
cut (Equal x1 x0).
auto with algebra.
cut (Equal (Ap (Id F) x1) (Ap (Id F) x0)).
auto with algebra.
cut (Equal (Ap (comp_map_map g1 g) x1) (Ap (comp_map_map g1 g) x0)).
intros H'5; try assumption.
apply Trans with (Ap (comp_map_map g1 g) x0); auto with algebra.
apply Trans with (Ap (comp_map_map g1 g) x1); auto with algebra.
simpl in |- *.
unfold comp_map_fun in |- *.
apply Trans with (Ap g1 x); auto with algebra.
apply Trans with (Ap g1 y); auto with algebra.
apply Trans with (Ap b x); auto with algebra.
apply Sym; auto with algebra.
apply Trans with (Ap b y); auto with algebra.
apply in_part_comp_r with (compl X); auto with algebra.
apply in_part_comp_r with (compl X); auto with algebra.
red in |- *.
intros y; try assumption.
case (compl_not_compl (image f X) y); intros.
generalize (image_in H).
intros H'0; try assumption.
elim H'0; intros x E0; elim E0; intros H'1 H'4; try exact H'1; clear E0 H'0.
exists x; try assumption.
apply Trans with (Ap f x); auto with algebra.
apply Sym; auto with algebra.
exists (g y); try assumption.
apply Trans with (Ap g1 (Ap g y)); auto with algebra.
apply Sym.
apply Trans with (Ap (Id F) y); auto with algebra.
apply Trans with (Ap (comp_map_map g1 g) y); auto with algebra.
apply Sym.
apply H'3.
cut (in_part (Ap g y) (compl X)).
auto with algebra.
apply in_part_comp_r with (image g (compl (image f X))); auto with algebra.
Qed.
End Cantor_Bernstein.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj5synthconj1 : forall  (lv0 : natural), (@eq natural (lv0) lv0).
Admitted.
QuickChick conj5synthconj1.