(** This files implements a type [natmap A] of finite maps whose keys range
over Coq's data type of unary natural numbers [nat]. The implementation equips
a list with a proof of canonicity. *)
From stdpp Require Import fin_maps mapset.
From stdpp Require Import options.

Notation natmap_raw A := (list (option A)).
Definition natmap_wf {A} (l : natmap_raw A) :=
  match last l with None => True | Some x => is_Some x end.
Global Instance natmap_wf_pi {A} (l : natmap_raw A) : ProofIrrel (natmap_wf l).
Proof. unfold natmap_wf. case_match; apply _. Qed.

Lemma natmap_wf_inv {A} (o : option A) (l : natmap_raw A) :
  natmap_wf (o :: l) → natmap_wf l.
Proof. by destruct l. Qed.
Lemma natmap_wf_lookup {A} (l : natmap_raw A) :
  natmap_wf l → l ≠ [] → ∃ i x, mjoin (l !! i) = Some x.
Proof.
  intros Hwf Hl. induction l as [|[x|] l IH]; simpl; [done| |].
  { exists 0. simpl. eauto. }
  destruct IH as (i&x&?); eauto using natmap_wf_inv; [|by exists (S i), x].
  intros ->. by destruct Hwf.
Qed.

Record natmap (A : Type) : Type := NatMap {
  natmap_car : natmap_raw A;
  natmap_prf : natmap_wf natmap_car
}.
Global Arguments NatMap {_} _ _ : assert.
Global Arguments natmap_car {_} _ : assert.
Global Arguments natmap_prf {_} _ : assert.
Lemma natmap_eq {A} (m1 m2 : natmap A) :
  m1 = m2 ↔ natmap_car m1 = natmap_car m2.
Proof.
  split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?].
  simplify_eq/=; f_equal; apply proof_irrel.
Qed.
Global Instance natmap_eq_dec `{EqDecision A} : EqDecision (natmap A) := λ m1 m2,
  match decide (natmap_car m1 = natmap_car m2) with
  | left H => left (proj2 (natmap_eq m1 m2) H)
  | right H => right (H ∘ proj1 (natmap_eq m1 m2))
  end.

Global Instance natmap_empty {A} : Empty (natmap A) := NatMap [] I.
Global Instance natmap_lookup {A} : Lookup nat A (natmap A) := λ i m,
  let (l,_) := m in mjoin (l !! i).

Fixpoint natmap_singleton_raw {A} (i : nat) (x : A) : natmap_raw A :=
  match i with 0 => [Some x]| S i => None :: natmap_singleton_raw i x end.
Lemma natmap_singleton_wf {A} (i : nat) (x : A) :
  natmap_wf (natmap_singleton_raw i x).
Proof. unfold natmap_wf. induction i as [|[]]; simplify_eq/=; eauto. Qed.
Lemma natmap_lookup_singleton_raw {A} (i : nat) (x : A) :
  mjoin (natmap_singleton_raw i x !! i) = Some x.
Proof. induction i; simpl; auto. Qed.
Lemma natmap_lookup_singleton_raw_ne {A} (i j : nat) (x : A) :
  i ≠ j → mjoin (natmap_singleton_raw i x !! j) = None.
Proof. revert j; induction i; intros [|?]; simpl; auto with congruence. Qed.
Hint Rewrite @natmap_lookup_singleton_raw : natmap.

Definition natmap_cons_canon {A} (o : option A) (l : natmap_raw A) :=
  match o, l with None, [] => [] | _, _ => o :: l end.
Lemma natmap_cons_canon_wf {A} (o : option A) (l : natmap_raw A) :
  natmap_wf l → natmap_wf (natmap_cons_canon o l).
Proof. unfold natmap_wf, last. destruct o, l; simpl; eauto. Qed.
Lemma natmap_cons_canon_O {A} (o : option A) (l : natmap_raw A) :
  mjoin (natmap_cons_canon o l !! 0) = o.
Proof. by destruct o, l. Qed.
Lemma natmap_cons_canon_S {A} (o : option A) (l : natmap_raw A) i :
  natmap_cons_canon o l !! S i = l !! i.
Proof. by destruct o, l. Qed.
Hint Rewrite @natmap_cons_canon_O @natmap_cons_canon_S : natmap.

Definition natmap_alter_raw {A} (f : option A → option A) :
    nat → natmap_raw A → natmap_raw A :=
  fix go i l {struct l} :=
  match l with
  | [] =>
     match f None with
     | Some x => natmap_singleton_raw i x | None => []
     end
  | o :: l =>
     match i with
     | 0 => natmap_cons_canon (f o) l | S i => natmap_cons_canon o (go i l)
     end
  end.
Lemma natmap_alter_wf {A} (f : option A → option A) i l :
  natmap_wf l → natmap_wf (natmap_alter_raw f i l).
Proof.
  revert i. induction l; [intro | intros [|?]]; simpl; repeat case_match;
    eauto using natmap_singleton_wf, natmap_cons_canon_wf, natmap_wf_inv.
Qed.
Global Instance natmap_alter {A} : PartialAlter nat A (natmap A) := λ f i m,
  let (l,Hl) := m in NatMap _ (natmap_alter_wf f i l Hl).
Lemma natmap_lookup_alter_raw {A} (f : option A → option A) i l :
  mjoin (natmap_alter_raw f i l !! i) = f (mjoin (l !! i)).
Proof.
  revert i. induction l; intros [|?]; simpl; repeat case_match; simpl;
    autorewrite with natmap; auto.
Qed.
Lemma natmap_lookup_alter_raw_ne {A} (f : option A → option A) i j l :
  i ≠ j → mjoin (natmap_alter_raw f i l !! j) = mjoin (l !! j).
Proof.
  revert i j. induction l; intros [|?] [|?] ?; simpl;
    repeat case_match; simpl; autorewrite with natmap; auto with congruence.
  rewrite natmap_lookup_singleton_raw_ne; congruence.
Qed.

Definition natmap_omap_raw {A B} (f : A → option B) :
    natmap_raw A → natmap_raw B :=
  fix go l :=
  match l with [] => [] | o :: l => natmap_cons_canon (o ≫= f) (go l) end.
Lemma natmap_omap_raw_wf {A B} (f : A → option B) l :
  natmap_wf l → natmap_wf (natmap_omap_raw f l).
Proof. induction l; simpl; eauto using natmap_cons_canon_wf, natmap_wf_inv. Qed.
Lemma natmap_lookup_omap_raw {A B} (f : A → option B) l i :
  mjoin (natmap_omap_raw f l !! i) = mjoin (l !! i) ≫= f.
Proof.
  revert i. induction l; intros [|?]; simpl; autorewrite with natmap; auto.
Qed.
Hint Rewrite @natmap_lookup_omap_raw : natmap.
Global Instance natmap_omap: OMap natmap := λ A B f m,
  let (l,Hl) := m in NatMap _ (natmap_omap_raw_wf f _ Hl).

Definition natmap_merge_raw {A B C} (f : option A → option B → option C) :
    natmap_raw A → natmap_raw B → natmap_raw C :=
  fix go l1 l2 :=
  match l1, l2 with
  | [], l2 => natmap_omap_raw (f None ∘ Some) l2
  | l1, [] => natmap_omap_raw (flip f None ∘ Some) l1
  | o1 :: l1, o2 :: l2 => natmap_cons_canon (diag_None f o1 o2) (go l1 l2)
  end.
Lemma natmap_merge_wf {A B C} (f : option A → option B → option C) l1 l2 :
  natmap_wf l1 → natmap_wf l2 → natmap_wf (natmap_merge_raw f l1 l2).
Proof.
  revert l2. induction l1; intros [|??]; simpl;
    eauto using natmap_omap_raw_wf, natmap_cons_canon_wf, natmap_wf_inv.
Qed.
Lemma natmap_lookup_merge_raw {A B C} (f : option A → option B → option C) l1 l2 i :
  mjoin (natmap_merge_raw f l1 l2 !! i) = diag_None f (mjoin (l1 !! i)) (mjoin (l2 !! i)).
Proof.
  intros. revert i l2. induction l1; intros [|?] [|??]; simpl;
    autorewrite with natmap; auto;
    match goal with |- context [?o ≫= _] => by destruct o end.
Qed.
Global Instance natmap_merge: Merge natmap := λ A B C f m1 m2,
  let (l1, Hl1) := m1 in let (l2, Hl2) := m2 in
  NatMap (natmap_merge_raw f l1 l2) (natmap_merge_wf _ _ _ Hl1 Hl2).

Fixpoint natmap_to_list_raw {A} (i : nat) (l : natmap_raw A) : list (nat * A) :=
  match l with
  | [] => []
  | None :: l => natmap_to_list_raw (S i) l
  | Some x :: l => (i,x) :: natmap_to_list_raw (S i) l
  end.
Lemma natmap_elem_of_to_list_raw_aux {A} j (l : natmap_raw A) i x :
  (i,x) ∈ natmap_to_list_raw j l ↔ ∃ i', i = i' + j ∧ mjoin (l !! i') = Some x.
Proof.
  split.
  - revert j. induction l as [|[y|] l IH]; intros j; simpl.
    + by rewrite elem_of_nil.
    + rewrite elem_of_cons. intros [?|?]; simplify_eq.
      * by exists 0.
      * destruct (IH (S j)) as (i'&?&?); auto.
        exists (S i'); simpl; auto with lia.
    + intros. destruct (IH (S j)) as (i'&?&?); auto.
      exists (S i'); simpl; auto with lia.
  - intros (i'&?&Hi'). subst. revert i' j Hi'.
    induction l as [|[y|] l IH]; intros i j ?; simpl.
    + done.
    + destruct i as [|i]; simplify_eq/=; [left|].
      right. rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
    + destruct i as [|i]; simplify_eq/=.
      rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
Qed.
Lemma natmap_elem_of_to_list_raw {A} (l : natmap_raw A) i x :
  (i,x) ∈ natmap_to_list_raw 0 l ↔ mjoin (l !! i) = Some x.
Proof.
  rewrite natmap_elem_of_to_list_raw_aux. setoid_rewrite Nat.add_0_r.
  naive_solver.
Qed.
Lemma natmap_to_list_raw_nodup {A} i (l : natmap_raw A) :
  NoDup (natmap_to_list_raw i l).
Proof.
  revert i. induction l as [|[?|] ? IH]; simpl; try constructor; auto.
  rewrite natmap_elem_of_to_list_raw_aux. intros (?&?&?). lia.
Qed.
Global Instance natmap_to_list {A} : FinMapToList nat A (natmap A) := λ m,
  let (l,_) := m in natmap_to_list_raw 0 l.

Definition natmap_map_raw {A B} (f : A → B) : natmap_raw A → natmap_raw B :=
  fmap (fmap (M:=option) f).
Lemma natmap_map_wf {A B} (f : A → B) l :
  natmap_wf l → natmap_wf (natmap_map_raw f l).
Proof.
  unfold natmap_map_raw, natmap_wf. rewrite fmap_last.
  destruct (last l); [|done]. by apply fmap_is_Some.
Qed.
Lemma natmap_lookup_map_raw {A B} (f : A → B) i l :
  mjoin (natmap_map_raw f l !! i) = f <$> mjoin (l !! i).
Proof.
  unfold natmap_map_raw. rewrite list_lookup_fmap. by destruct (l !! i).
Qed.
Global Instance natmap_map: FMap natmap := λ A B f m,
  let (l,Hl) := m in NatMap (natmap_map_raw f l) (natmap_map_wf _ _ Hl).

Global Instance: FinMap nat natmap.
Proof.
  split.
  - unfold lookup, natmap_lookup. intros A [l1 Hl1] [l2 Hl2] E.
    apply natmap_eq. revert l2 Hl1 Hl2 E. simpl.
    induction l1 as [|[x|] l1 IH]; intros [|[y|] l2] Hl1 Hl2 E; simpl in *.
    + done.
    + by specialize (E 0).
    + destruct (natmap_wf_lookup (None :: l2)) as (i&?&?); auto with congruence.
    + by specialize (E 0).
    + f_equal.
      * apply (E 0).
      * apply IH; eauto using natmap_wf_inv.
        intros i. apply (E (S i)).
    + by specialize (E 0).
    + destruct (natmap_wf_lookup (None :: l1)) as (i&?&?); auto with congruence.
    + by specialize (E 0).
    + f_equal. apply IH; eauto using natmap_wf_inv. intros i. apply (E (S i)).
  - done.
  - intros ?? [??] ?. apply natmap_lookup_alter_raw.
  - intros ?? [??] ??. apply natmap_lookup_alter_raw_ne.
  - intros ??? [??] ?. apply natmap_lookup_map_raw.
  - intros ? [??]. by apply natmap_to_list_raw_nodup.
  - intros ? [??] ??. by apply natmap_elem_of_to_list_raw.
  - intros ??? [??] ?. by apply natmap_lookup_omap_raw.
  - intros ???? [??] [??] ?. apply natmap_lookup_merge_raw.
Qed.

Fixpoint strip_Nones {A} (l : list (option A)) : list (option A) :=
  match l with None :: l => strip_Nones l | _ => l end.

Lemma list_to_natmap_wf {A} (l : list (option A)) :
  natmap_wf (reverse (strip_Nones (reverse l))).
Proof.
  unfold natmap_wf. rewrite last_reverse.
  induction (reverse l) as [|[]]; simpl; eauto.
Qed.
Definition list_to_natmap {A} (l : list (option A)) : natmap A :=
  NatMap (reverse (strip_Nones (reverse l))) (list_to_natmap_wf l).
Lemma list_to_natmap_spec {A} (l : list (option A)) i :
  list_to_natmap l !! i = mjoin (l !! i).
Proof.
  unfold lookup at 1, natmap_lookup, list_to_natmap; simpl.
  rewrite <-(reverse_involutive l) at 2. revert i.
  induction (reverse l) as [|[x|] l' IH]; intros i; simpl; auto.
  rewrite reverse_cons, IH. clear IH. revert i.
  induction (reverse l'); intros [|?]; simpl; auto.
Qed.

(** Finally, we can construct sets of [nat]s satisfying extensional equality. *)
Notation natset := (mapset natmap).
Global Instance natmap_dom {A} : Dom (natmap A) natset := mapset_dom.
Global Instance: FinMapDom nat natmap natset := mapset_dom_spec.

(* Fixpoint avoids this definition from being unfolded *)
Definition bools_to_natset (βs : list bool) : natset :=
  let f (β : bool) := if β then Some () else None in
  Mapset $ list_to_natmap $ f <$> βs.
Definition natset_to_bools (sz : nat) (X : natset) : list bool :=
  let f (mu : option ()) := match mu with Some _ => true | None => false end in
  resize sz false $ f <$> natmap_car (mapset_car X).

Lemma bools_to_natset_unfold βs :
  let f (β : bool) := if β then Some () else None in
  bools_to_natset βs = Mapset $ list_to_natmap $ f <$> βs.
Proof. by destruct βs. Qed.
Lemma elem_of_bools_to_natset βs i : i ∈ bools_to_natset βs ↔ βs !! i = Some true.
Proof.
  rewrite bools_to_natset_unfold; unfold elem_of, mapset_elem_of; simpl.
  rewrite list_to_natmap_spec, list_lookup_fmap.
  destruct (βs !! i) as [[]|]; compute; intuition congruence.
Qed.
Lemma bools_to_natset_union βs1 βs2 :
  length βs1 = length βs2 →
  bools_to_natset (βs1 ||* βs2) = bools_to_natset βs1 ∪ bools_to_natset βs2.
Proof.
  rewrite <-Forall2_same_length; intros Hβs.
  apply set_eq. intros i. rewrite elem_of_union, !elem_of_bools_to_natset.
  revert i. induction Hβs as [|[] []]; intros [|?]; naive_solver.
Qed.
Lemma natset_to_bools_length (X : natset) sz : length (natset_to_bools sz X) = sz.
Proof. apply resize_length. Qed.
Lemma lookup_natset_to_bools_ge sz X i : sz ≤ i → natset_to_bools sz X !! i = None.
Proof. by apply lookup_resize_old. Qed.
Lemma lookup_natset_to_bools sz X i β :
  i < sz → natset_to_bools sz X !! i = Some β ↔ (i ∈ X ↔ β = true).
Proof.
  unfold natset_to_bools, elem_of, mapset_elem_of, lookup at 2, natmap_lookup; simpl.
  intros. destruct (mapset_car X) as [l ?]; simpl.
  destruct (l !! i) as [mu|] eqn:Hmu; simpl.
  { rewrite lookup_resize, list_lookup_fmap, Hmu
      by (rewrite ?fmap_length; eauto using lookup_lt_Some).
    destruct mu as [[]|], β; simpl; intuition congruence. }
  rewrite lookup_resize_new by (rewrite ?fmap_length;
    eauto using lookup_ge_None_1); destruct β; intuition congruence.
Qed.
Lemma lookup_natset_to_bools_true sz X i :
  i < sz → natset_to_bools sz X !! i = Some true ↔ i ∈ X.
Proof. intros. rewrite lookup_natset_to_bools by done. intuition. Qed.
Lemma lookup_natset_to_bools_false sz X i :
  i < sz → natset_to_bools sz X !! i = Some false ↔ i ∉ X.
Proof. intros. rewrite lookup_natset_to_bools by done. naive_solver. Qed.
Lemma natset_to_bools_union sz X1 X2 :
  natset_to_bools sz (X1 ∪ X2) = natset_to_bools sz X1 ||* natset_to_bools sz X2.
Proof.
  apply list_eq; intros i; rewrite lookup_zip_with.
  destruct (decide (i < sz)); [|by rewrite !lookup_natset_to_bools_ge by lia].
  apply option_eq; intros β.
  rewrite lookup_natset_to_bools, elem_of_union by done; intros.
  destruct (decide (i ∈ X1)), (decide (i ∈ X2)); repeat first
    [ rewrite (λ X H, proj2 (lookup_natset_to_bools_true sz X i H)) by done
    | rewrite (λ X H, proj2 (lookup_natset_to_bools_false sz X i H)) by done];
    destruct β; naive_solver.
Qed.
Lemma natset_to_bools_to_natset βs sz :
  natset_to_bools sz (bools_to_natset βs) = resize sz false βs.
Proof.
  apply list_eq; intros i. destruct (decide (i < sz));
    [|by rewrite lookup_natset_to_bools_ge, lookup_resize_old by lia].
  apply option_eq; intros β.
  rewrite lookup_natset_to_bools, elem_of_bools_to_natset by done.
  destruct (decide (i < length βs)).
  { rewrite lookup_resize by done.
    destruct (lookup_lt_is_Some_2 βs i) as [[]]; destruct β; naive_solver. }
  rewrite lookup_resize_new, lookup_ge_None_2 by lia. destruct β; naive_solver.
Qed.

(** A [natmap A] forms a stack with elements of type [A] and possible holes *)
Definition natmap_push {A} (o : option A) (m : natmap A) : natmap A :=
  let (l,Hl) := m in NatMap _ (natmap_cons_canon_wf o l Hl).

Definition natmap_pop_raw {A} (l : natmap_raw A) : natmap_raw A := tail l.
Lemma natmap_pop_wf {A} (l : natmap_raw A) :
  natmap_wf l → natmap_wf (natmap_pop_raw l).
Proof. destruct l; simpl; eauto using natmap_wf_inv. Qed.
Definition natmap_pop {A} (m : natmap A) : natmap A :=
  let (l,Hl) := m in NatMap _ (natmap_pop_wf _ Hl).

Lemma lookup_natmap_push_O {A} o (m : natmap A) : natmap_push o m !! 0 = o.
Proof. by destruct o, m as [[|??]]. Qed.
Lemma lookup_natmap_push_S {A} o (m : natmap A) i :
  natmap_push o m !! S i = m !! i.
Proof. by destruct o, m as [[|??]]. Qed.
Lemma lookup_natmap_pop {A} (m : natmap A) i : natmap_pop m !! i = m !! S i.
Proof. by destruct m as [[|??]]. Qed.
Lemma natmap_push_pop {A} (m : natmap A) :
  natmap_push (m !! 0) (natmap_pop m) = m.
Proof.
  apply map_eq. intros i. destruct i.
  - by rewrite lookup_natmap_push_O.
  - by rewrite lookup_natmap_push_S, lookup_natmap_pop.
Qed.
Lemma natmap_pop_push {A} o (m : natmap A) : natmap_pop (natmap_push o m) = m.
Proof. apply natmap_eq. by destruct o, m as [[|??]]. Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import fintype bigops prime binomial finset ssralg.
Require Import groups morphisms normal automorphism commutators zmodp.
Require Import gprod gfunc cyclic center pgroups nilpotent sylow abelian.
Require Import gseries maximal matrix mxrepresentation BGsection1 BGsection2.

(******************************************************************************)
(* This file contains the useful material in B & G, appendices A and B, i.e., *)
(* the proof of the p-stability properties and the ZL-Theorem (the Puig       *)
(* replacement for the Glaubermann ZJ-theorem). The relevant definitions are  *)
(* given in BGsection1.                                                       *)
(******************************************************************************)

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

Open Local Scope ring_scope.
Import GroupScope GRing.Theory.

Section AppendixA.

Implicit Type gT : finGroupType.
Implicit Type p : nat.

Import MatrixGenField.

(* This is B & G, Theorem A.4(c) (in Appendix A, not section 16!). We follow  *)
(* both B & G and Gorenstein in using the general form of the p-stable        *)
(* property. We could simplify the property because the conditions under      *)
(* which we prove p-stability are inherited by sections (morphic image in our *)
(* framework), and restrict to the case where P is normal in G. (Clearly the  *)
(* 'O_p^'(G) * P <| G premise plays no part in the proof.)                    *)
Lemma odd_p_stable : forall gT p (G : {group gT}), odd #|G| -> p.-stable G.
Proof.
move=> gT p; move: gT.
pose p_xp gT (E : {group gT}) x := p.-elt x && (x \in 'C([~: E, [set x]])).
suffices: forall gT (E : {group gT}) x y, let G := <<[set x; y]>> in
  [&& odd #|G|, p.-group E & G \subset 'N(E)] ->
  p_xp gT E x && p_xp gT E y -> p.-group (G / 'C(E)).
- move=> IH gT G oddG P A pP; case/andP; rewrite mulG_subG; case/andP=> _ sPG _.
  case/andP=> sANG pA cRA; apply/subsetP=> Cx; case/morphimP=> x Nx Ax ->{Cx}.
  have NGx := subsetP sANG x Ax.
  apply: Baer_Suzuki => [|Cy]; first exact: mem_quotient.
  case/morphimP=> y Ny NGy ->{Cy}; rewrite -morphJ // -!morphim_set1 ?groupJ //.
  rewrite -morphimU -morphim_gen ?subUset ?sub1set ?Nx ?groupJ //= -quotientE.
  set G1 := <<_>>; rewrite /pgroup -(isog_card (second_isog _)); last first.
    by rewrite mulgen_subG !sub1set Nx groupJ.
  case/setIP: NGx => Gx {Nx}Nx; case/setIP: NGy => Gy {Ny}Ny.
  have sG1G: G1 \subset G by rewrite mulgen_subG !sub1set groupJ ?andbT.
  have nPG1: G1 \subset 'N(P) by rewrite mulgen_subG !sub1set groupJ ?andbT.
  rewrite -setIA setICA (setIidPr sG1G).
  rewrite (isog_card (second_isog _)) ?norms_cent //.
  apply: IH => //; first by rewrite pP nPG1 (oddSg sG1G).
  rewrite /p_xp -{2}(normP Ny) -conjg_set1 -conjsRg centJ memJ_conjg.
  rewrite p_eltJ andbb (mem_p_elt pA) // -sub1set centsC (sameP commG1P trivgP).
  by rewrite -cRA !commgSS ?sub1set.
move=> gT E; move: {2}_.+1 (ltnSn #|E|) => n; elim: n => // n IHn in gT E *.
rewrite ltnS => leEn x y G; case/and3P=> oddG pE nEG.
case/and3P; case/andP => p_x cRx p_y cRy.
have [Gx Gy]: x \in G /\ y \in G.
  by apply/andP; rewrite -!sub1set -subUset subset_gen.
apply/idPn=> p'Gc; case/pgroupP: (p'Gc) => q q_pr qGc; apply/idPn => p'q.
have [Q sylQ] := Sylow_exists q [group of G].
have [sQG qQ]: Q \subset G /\ q.-group Q by case/and3P: sylQ.
have{qQ p'q} p'Q: p^'.-group Q by apply: sub_in_pnat qQ => q' _; move/eqnP->.
have{q q_pr sylQ qGc} ncEQ: ~~ (Q \subset 'C(E)).
  apply: contraL qGc => cEQ; rewrite -p'natE // -partn_eq1 //.
  have nCQ: Q \subset 'N('C(E)) by exact: subset_trans (normG _).
  have sylQc: q.-Sylow(G / 'C(E)) (Q / 'C(E)) by rewrite morphim_pSylow.
  by rewrite -(card_Hall sylQc) -trivg_card1 (sameP eqP trivgP) quotient_sub1.
have solE: solvable E := pgroup_sol pE.
have ntE: E :!=: 1 by apply: contra ncEQ; move/eqP->; rewrite cents1.
have{Q ncEQ p'Q sQG} minE_EG: minnormal E (E <*> G).
  apply/mingroupP; split=> [|D]; rewrite mulgen_subG ?ntE ?normG //.
  case/and3P=> ntD nDE nDG sDE; have nDGi := subsetP nDG.
  apply/eqP; rewrite eqEcard sDE leqNgt; apply: contra ncEQ => ltDE.
  have nDQ: Q \subset 'N(D) by rewrite (subset_trans sQG).
  have cDQ: Q \subset 'C(D).
    rewrite -quotient_sub1 ?norms_cent // ?[_ / _]card1_trivg //.
    apply: pnat_1 (morphim_pgroup _ p'Q); apply: pgroupS (quotientS _ sQG) _.
    apply: (IHn _ D (leq_trans ltDE leEn)); first by rewrite oddG (pgroupS sDE).
    rewrite /p_xp p_x p_y /=; apply/andP.
    by split; [move: cRx | move: cRy]; apply: subsetP; rewrite centS ?commSg.
  apply: (stable_factor_cent cDQ) solE; rewrite ?(pnat_coprime pE) //.
  apply/and3P; split; rewrite // -quotient_cents2 // centsC.
  rewrite -quotient_sub1 ?norms_cent ?quotient_norms ?(subset_trans sQG) //=.
  rewrite [(_ / _) / _]card1_trivg //=.
  apply: pnat_1 (morphim_pgroup _ (morphim_pgroup _ p'Q)).
  apply: pgroupS (quotientS _ (quotientS _ sQG)) _.
  have defGq: G / D = <<[set coset D x; coset D y]>>.
    by rewrite quotient_gen -1?gen_subG ?quotientU ?quotient_set1 ?nDGi.
  rewrite /= defGq IHn ?(leq_trans _ leEn) ?ltn_quotient // -?defGq.
    by rewrite quotient_odd // quotient_pgroup // quotient_norms.
  rewrite /p_xp -!sub1set !morph_p_elt -?quotient_set1 ?nDGi //=.
  by rewrite -!quotientR ?quotient_cents ?sub1set ?nDGi.
have abelE: p.-abelem E.
  by rewrite -is_abelem_pgroup //; case: (minnormal_solvable minE_EG _ solE).
have cEE: abelian E by case/and3P: abelE.
have{minE_EG} minE: minnormal E G.
  case/mingroupP: minE_EG => _ minE; apply/mingroupP; rewrite ntE.
  split=> // D ntD sDE; apply: minE => //; rewrite mulgen_subG cents_norm //.
  by rewrite centsC (subset_trans sDE).
have nCG: G \subset 'N('C_G(E)) by rewrite normsI ?normG ?norms_cent.
suffices{p'Gc} pG'c: p.-group (G / 'C_G(E))^`(1).
  have [Pc sylPc sGc'Pc]:= Sylow_superset (der_subS _ _) pG'c.
  have nsPc: Pc <| G / 'C_G(E) by rewrite sub_der1_normal ?(pHall_sub sylPc).
  case/negP: p'Gc; rewrite /pgroup -(isog_card (second_isog _)) ?norms_cent //.
  rewrite setIC; apply: pgroupS (pHall_pgroup sylPc) => /=.
  rewrite sub_quotient_pre // mulgen_subG !sub1set !(subsetP nCG, inE) //=.
  by rewrite !(mem_normal_Hall sylPc) ?mem_quotient ?morph_p_elt ?(subsetP nCG).
have defC := rker_abelem abelE ntE nEG; rewrite /= -/G in defC.
set rG := abelem_repr _ _ _ in defC.
case ncxy: (rG x *m rG y == rG y *m rG x).
  have Cxy: [~ x, y] \in 'C_G(E).
    rewrite -defC inE groupR //= !repr_mxM ?groupM ?groupV // mul1mx -/rG.
    by rewrite (eqP ncxy) -!repr_mxM ?groupM ?groupV // mulKg mulVg repr_mx1.
  rewrite [_^`(1)](commG1P _) ?pgroup1 //= quotient_gen -gen_subG //= -/G.
  rewrite !gen_subG centsC gen_subG quotient_cents2r ?gen_subG //= -/G.
  rewrite /commg_set imset2Ul !imset2_set1l !imsetU !imset_set1.
  by rewrite !subUset andbC !sub1set !commgg group1 /= -invg_comm groupV Cxy.
pose Ax : 'M(E) := rG x - 1; pose Ay : 'M(E) := rG y - 1.
have Ax2: Ax *m Ax = 0.
  apply/row_matrixP=> i; apply/eqP; rewrite row_mul mulmx_subr mulmx1.
  rewrite row0 subr_eq0 -(inj_eq (@rVabelem_inj _ _ _ abelE ntE)).
  rewrite rVabelemJ // conjgE -(centP cRx) ?mulKg //.
  rewrite linear_sub /= addrC row1 rowE rVabelemD rVabelemN rVabelemJ //=.
  by rewrite mem_commg ?set11 ?mem_rVabelem.
have Ay2: Ay *m Ay = 0.
  apply/row_matrixP=> i; apply/eqP; rewrite row_mul mulmx_subr mulmx1.
  rewrite row0 subr_eq0 -(inj_eq (@rVabelem_inj _ _ _ abelE ntE)).
  rewrite rVabelemJ // conjgE -(centP cRy) ?mulKg //.
  rewrite linear_sub /= addrC row1 rowE rVabelemD rVabelemN rVabelemJ //=.
  by rewrite mem_commg ?set11 ?mem_rVabelem.
pose A := Ax *m Ay + Ay *m Ax.
have cAG: centgmx rG A.
  rewrite /centgmx gen_subG subUset !sub1set !inE Gx Gy /=; apply/andP.
  rewrite -[rG x](subrK 1%R) -[rG y](subrK 1%R) -/Ax -/Ay.
  rewrite 2!(mulmx_addl _ 1 A) 2!(mulmx_addr A _ 1) !mulmx1 !mul1mx.
  rewrite !(inj_eq (@addIr _ A)) ![_ *m A]mulmx_addr ![A *m _]mulmx_addl.
  by rewrite -!mulmxA Ax2 Ay2 !mulmx0 !mulmxA Ax2 Ay2 !mul0mx !addr0 !add0r.
have irrG: mx_irreducible rG by exact/abelem_mx_irrP.
pose rAG := gen_repr irrG cAG; pose inFA := in_gen irrG cAG.
pose valFA := @val_gen _ _ _ _ _ _ irrG cAG.
set dA := gen_dim A in rAG inFA valFA.
rewrite -(rker_abelem abelE ntE nEG) -/rG -(rker_gen irrG cAG) -/rAG.
have dA_gt0: dA > 0 by rewrite (gen_dim_gt0 irrG cAG).
have irrAG: mx_irreducible rAG by exact: gen_mx_irr.
have: dA <= 2.
  case Ax0: (Ax == 0).
    by rewrite subr_eq0 in Ax0; case/eqP: ncxy; rewrite (eqP Ax0) mulmx1 mul1mx.
  case/rowV0Pn: Ax0 => v; case/subsetmxP => u def_v nzv.
  pose U := col_mx v (v *m Ay); pose UA := <<inFA _ U>>%MS.
  pose rvalFA := @rowval_gen _ _ _ _ _ _ irrG cAG.
  have Umod: submodmx rAG UA.
    rewrite /submodmx gen_subG subUset !sub1set !inE Gx Gy /= andbC.
    apply/andP; split; rewrite (eqmxMr _ (genmxE _)) -in_genJ // genmxE.
      rewrite subsetmx_in_gen // -[rG y](subrK 1%R) -/Ay mulmx_addr mulmx1.
      rewrite subsetmx_add // mul_col_mx -mulmxA Ay2 mulmx0.
      by rewrite -!sumsmxE sumsmx0 sumsmxSr.
    rewrite -[rG x](subrK 1%R) -/Ax mulmx_addr mulmx1 in_genD mul_col_mx.
    pose A' := A; rewrite -mulmxA -[Ay *m Ax](addKr (Ax *m Ay)) -/A mulmx_addr.
    rewrite -mulmxN mulmxA {1 2}def_v -(mulmxA u) Ax2 mulmx0 mul0mx add0r.
    rewrite -(mul0mx _ A') -mul_col_mx -[A'](mxval_groot irrG cAG).
    rewrite -[_ 0 v](in_genK irrG cAG) -val_genZ val_genK.
    rewrite subsetmx_add ?subsetmx_scale ?subsetmx_in_gen //.
    by rewrite -!sumsmxE sums0mx sumsmxSl.
  have nzU: UA != 0.
    rewrite -mxrank_eq0 genmxE mxrank_eq0; apply/eqP.
    move/(canRL ((in_genK _ _) _)); rewrite val_gen0; apply/eqP.
    by rewrite -subsetmx0 -sumsmxE sumsmx_sub subsetmx0 negb_and nzv.
  case/mx_irrP: irrAG => _; move/(_ UA Umod nzU); move/eqnP <-.
  by rewrite genmxE rank_leq_row.
rewrite leq_eqVlt ltnS leq_eqVlt ltnNge dA_gt0 orbF orbC; case/pred2P=> def_dA.
  rewrite [_^`(1)](commG1P _) ?pgroup1 // quotient_cents2r // gen_subG.
  apply/subsetP=> zt; case/imset2P=> z t Gz Gt ->{zt}.
  rewrite !inE groupR //= mul1mx; have Gtz := groupM Gt Gz.
  rewrite -(inj_eq (can_inj (mulKmx (repr_mx_unit rAG Gtz)))) mulmx1.
  rewrite [eq_op]lock -repr_mxM ?groupR ?groupM // -commgC !repr_mxM // -lock.
  apply/eqP; move: (rAG z) (rAG t); rewrite /= -/dA def_dA => Az At.
  by rewrite [Az]mx11_scalar scalar_mxC.
move: (kquo_repr _) (kquo_mx_faithful rAG) => /=; set K := rker _.
rewrite def_dA => r2G; move/der1_odd_GL2_charf; move/implyP.
rewrite quotient_odd //= -/G; apply: etrans; apply: eq_pgroup => p'.
have [p_pr _ _] := pgroup_pdiv pE ntE.
by rewrite (fieldM_char (genRM _ _)) (charf_eq (char_Fp _)).
Qed.

Section A5.

Variables (gT : finGroupType) (p : nat) (G P X : {group gT}).

Hypotheses (oddG : odd #|G|) (solG : solvable G) (pP : p.-group P).
Hypotheses (nsPG : P <| G) (sXG : X \subset G).
Hypotheses (genX : generated_by (p_norm_abelian p P) X).

Let C := 'C_G(P).
Let defN : 'N_G(P) = G. Proof. by rewrite (setIidPl _) ?normal_norm. Qed.
Let nsCG : C <| G. Proof. by rewrite -defN subcent_normal. Qed.
Let nCG := normal_norm nsCG.
Let nCX := subset_trans sXG nCG.

(* This is B & G, Theorem A.5.1; it does not depend on the solG assumption. *)
Lemma odd_abelian_gen_stable : X / C \subset 'O_p(G / C).
Proof.
case/existsP: genX => gX; move/eqP=> defX.
rewrite -defN sub_quotient_pre // -defX gen_subG; apply/bigcupsP=> A gX_A.
have [_ pA nAP cAA] := and4P gX_A.
have{gX_A} sAX: A \subset X by rewrite -defX sub_gen ?bigcup_sup.
rewrite -sub_quotient_pre ?(subset_trans sAX nCX) //=.
rewrite odd_p_stable ?normalM ?pcore_normal //.
  by rewrite /psubgroup pA defN (subset_trans sAX sXG).
by apply/commG1P; rewrite (subset_trans _ cAA) // commg_subr.
Qed.

(* This is B & G, Theorem A.5.2. *)
Lemma odd_abelian_gen_constrained :
  'O_p^'(G) = 1 -> 'C_('O_p(G))(P) \subset P -> X \subset 'O_p(G).
Proof.
set Q := 'O_p(G) => p'G1 sCQ_P.
have sPQ: P \subset Q by rewrite pcore_max.
have defQ: 'O_{p^', p}(G) = Q by rewrite pseries_pop2.
have pQ: p.-group Q by exact: pcore_pgroup.
have sCQ: 'C_G(Q) \subset Q.
  by rewrite -{2}defQ solvable_p_constrained //= defQ /pHall pQ indexgg subxx.
have pC: p.-group C.
  apply/pgroupP=> q q_pr; case/Cauchy=> // u Cu q_u; apply/idPn=> p'q.
  suff cQu: u \in 'C_G(Q).
    case/negP: p'q; have{q_u}: q %| #[u] by rewrite q_u.
    by apply: pnatP q q_pr => //; apply: mem_p_elt pQ _; exact: (subsetP sCQ).
  have [Gu cPu] := setIP Cu; rewrite inE Gu /= -cycle_subG.
  rewrite coprime_nil_faithful_cent_stab ?(pgroup_nil pQ) //= -/C -/Q.
  - by rewrite cycle_subG; apply: subsetP Gu; rewrite normal_norm ?pcore_normal.
  - by rewrite (pnat_coprime pQ) // [#|_|]q_u pnatE.
  have sPcQu: P \subset 'C_Q(<[u]>) by rewrite subsetI sPQ centsC cycle_subG.
  by apply: subset_trans (subset_trans sCQ_P sPcQu); rewrite setIS // centS.
rewrite -(quotientSGK nCX) ?pcore_max // -pquotient_pcore //.
exact: odd_abelian_gen_stable.
Qed.

End A5.

End AppendixA.

Section AppendixB.

Local Notation "X --> Y" := (generated_by (norm_abelian X) Y)
  (at level 70, no associativity) : group_scope.

Variable gT : finGroupType.
Implicit Types G H A : {group gT}.
Implicit Types D E : {set gT}.
Implicit Type p : nat.

Lemma Puig_char : forall G, 'L(G) \char G.
Proof. by move=> G; exact: bgFunc_char. Qed.

Lemma center_Puig_char : forall G, 'Z('L(G)) \char G.
Proof. by move=> G; apply: char_trans (center_char _) (Puig_char _). Qed.

Lemma Puig_succS : forall G D E, D \subset E -> 'L_[G](E) \subset 'L_[G](D).
Proof.
move=> G D E sDE; apply: Puig_max (Puig_succ_sub _ _).
exact: norm_abgenS sDE (Puig_gen _ _).
Qed.

Lemma Puig_sub_even : forall m n G,
  m <= n -> 'L_{m.*2}(G) \subset 'L_{n.*2}(G).
Proof.
move=> m n G; move/subnKC <-; move: {n}(n - m)%N => n.
by elim: m => [|m IHm] /=; rewrite ?sub1G ?Puig_succS.
Qed.

Lemma Puig_sub_odd : forall m n G,
  m <= n -> 'L_{n.*2.+1}(G) \subset 'L_{m.*2.+1}(G).
Proof. by move=> m n G le_mn; rewrite Puig_succS ?Puig_sub_even. Qed.

Lemma Puig_sub_even_odd : forall m n G, 'L_{m.*2}(G) \subset 'L_{n.*2.+1}(G).
Proof.
move=> m n G; elim: n m => [|n IHn] m; first by rewrite Puig1 Puig_at_sub.
by case: m => [|m]; rewrite ?sub1G ?Puig_succS ?IHn.
Qed.

Lemma Puig_limit : forall G,
  exists m, forall k, m <= k ->
    'L_{k.*2}(G) = 'L_*(G) /\ 'L_{k.*2.+1}(G) = 'L(G).
Proof.
move=> G; pose L2G m := 'L_{m.*2}(G); pose n := #|G|.
have []: #|L2G n| <= n /\ n <= n by rewrite subset_leq_card ?Puig_at_sub.
elim: {1 2 3}n => [|m IHm leLm1]; first by rewrite leqNgt cardG_gt0.
move/ltnW; case: (eqVneq (L2G m.+1) (L2G m)) => [eqLm le_mn|]; last first.
  rewrite eq_sym eqEcard Puig_sub_even ?leqnSn // -ltnNge => lt_m1_m.
  exact: IHm (leq_trans lt_m1_m leLm1).
have{eqLm} eqLm: forall k, m <= k -> 'L_{k.*2}(G) = L2G m.
  move=> k; rewrite leq_eqVlt; case/predU1P=> [-> // |].
  elim: k => // k IHk; rewrite leq_eqVlt; case/predU1P=> [<- //| ltmk].
  by rewrite -eqLm !PuigS IHk.
by exists m => k le_mk; rewrite Puig_def PuigS /Puig_inf /= !eqLm //.
Qed.

Lemma Puig_inf_def : forall G, 'L_*(G) = 'L_[G]('L(G)).
Proof.
move=> G; have [k defL] := Puig_limit G.
by case: (defL k) => // _ <-; case: (defL k.+1) => [|<- //]; exact: leqnSn.
Qed.

Lemma abelian_norm_Puig : forall n G A,
   n > 0 -> abelian A -> A <| G -> A \subset 'L_{n}(G).
Proof.
case=> // n G A _ cAA; case/andP=> sAG nAG.
rewrite PuigS sub_gen // bigcup_sup // inE sAG /norm_abelian cAA andbT.
exact: subset_trans (Puig_at_sub n G) nAG.
Qed.

Lemma Puig_inf_sub_Puig : forall G, 'L_*(G) \subset 'L(G).
Proof. move=> G; exact: Puig_sub_even_odd. Qed.

Lemma sub_cent_Puig_at : forall n p G,
  n > 0 -> p.-group G -> 'C_G('L_{n}(G)) \subset 'L_{n}(G).
Proof.
move=> n p G n_gt0 pG.
have: exists M : {group gT}, (M <| G) && abelian M.
  by exists 1%G; rewrite normal1 abelian1.
case/ex_maxgroup => M; move/(max_SCN pG) => SCN_M.
have cMM := SCN_abelian SCN_M; case/SCN_P: SCN_M => nsMG defCM.
have sML: M \subset 'L_{n}(G) by exact: abelian_norm_Puig.
by apply: subset_trans (sML); rewrite -defCM setIS // centS.
Qed.

Lemma sub_cent_Puig_inf : forall p G,
  p.-group G -> 'C_G('L_*(G)) \subset 'L_*(G).
Proof. by move=> p G; apply: sub_cent_Puig_at; rewrite double_gt0. Qed.

Lemma sub_cent_Puig : forall p G, p.-group G -> 'C_G('L(G)) \subset 'L(G).
Proof. by move=> p G; exact: sub_cent_Puig_at. Qed.

Lemma sub_center_cent_Puig_at : forall n G, 'Z(G) \subset 'C_G('L_{n}(G)).
Proof. by move=> n G; rewrite setIS ?centS ?Puig_at_sub. Qed.

Lemma trivg_center_Puig_pgroup : forall p G,
  p.-group G -> 'Z('L(G)) = 1 -> G :=: 1.
Proof.
move=> p G pG LG1; apply: (trivg_center_pgroup pG); apply/trivgP.
rewrite -(trivg_center_pgroup (pgroupS (Puig_sub _) pG) LG1).
by apply: subset_trans (sub_cent_Puig pG); exact: sub_center_cent_Puig_at.
Qed.

Lemma sub_Puig_eq : forall G H, H \subset G -> 'L(G) \subset H -> 'L(H) = 'L(G).
Proof.
move=> G H sHG sLG_H.
have [kG defLG] := Puig_limit G; have [kH defLH] := Puig_limit H.
move: {2}(maxn _ _) (leqnn (maxn kH kG)) => k; rewrite leq_maxl; case/andP.
case/defLH=> _ <-; case/defLG=> _ {defLH defLG}defL.
have sLH_G := subset_trans (Puig_succ_sub _ _) sHG.
have gPuig := norm_abgenS _ (Puig_gen _ _).
apply/eqP; rewrite eqEsubset; apply/andP; split.
  rewrite -{}defL; elim: k => [|k IHk /=]; first by rewrite !Puig1.
  rewrite doubleS !(PuigS _.+1) Puig_max ?gPuig // Puig_max ?gPuig //.
  exact: subset_trans (Puig_sub_even_odd _.+1 _ _) sLG_H.
elim: k {defL} => [|k IHk /=]; first by rewrite Puig1.
rewrite doubleS Puig_max // -!PuigS Puig_def gPuig //.
by rewrite Puig_inf_def Puig_max ?gPuig ?sLH_G.
Qed.

Lemma norm_abgen_pgroup : forall p X G,
  p.-group G -> X --> G -> generated_by (p_norm_abelian p X) G.
Proof.
move=> p X G pG; case/existsP=> gG; move/eqP=> defG.
have:= subxx G; rewrite -{1 3}defG gen_subG /=; move/bigcupsP=> sGG.
apply/existsP; exists gG; apply/eqP; congr <<_>>; apply: eq_bigl => A.
rewrite andbCA andbC; case gGA: ((A \in _) && _) => //.
exact: pgroupS (sGG A gGA) pG.
Qed.

Variables (p : nat) (G S : {group gT}).
Hypotheses (oddG : odd #|G|) (solG : solvable G) (sylS : p.-Sylow(G) S).
Hypothesis p'G1 : 'O_p^'(G) = 1.

Let T := 'O_p(G).
Let nsTG : T <| G := pcore_normal _ _.
Let pT : p.-group T := pcore_pgroup _ _.
Let pS : p.-group S := pHall_pgroup sylS.
Let sSG := pHall_sub sylS.

Lemma pcore_Sylow_Puig_sub : 'L_*(S) \subset 'L_*(T) /\ 'L(T) \subset 'L(S).
Proof.
have [kS defLS] := Puig_limit S; have [kT defLT] := Puig_limit [group of T].
move: {2}(maxn _ _) (leqnn (maxn kS kT)) => k; rewrite leq_maxl; case/andP.
case/defLS=> <- <-; case/defLT=> <- <- {defLS defLT}/=.
have sL_ := subset_trans (Puig_succ_sub _ _).
elim: k => [|k [_ sL1]]; first by rewrite !Puig1 pcore_sub_Hall.
have{sL1} gL: 'L_{k.*2.+1}(T) --> 'L_{k.*2.+2}(S).
  exact: norm_abgenS sL1 (Puig_gen _ _).
have sCT_L: 'C_T('L_{k.*2.+1}(T)) \subset 'L_{k.*2.+1}(T).
  exact: sub_cent_Puig_at pT.
have{sCT_L} sLT: 'L_{k.*2.+2}(S) \subset T.
  apply: odd_abelian_gen_constrained sCT_L => //.
  - exact: pgroupS (Puig_at_sub _ _) pT.
  - by apply: char_normal_trans nsTG; exact: bgFunc_char.
  - exact: sL_ sSG.
  by rewrite norm_abgen_pgroup // (pgroupS _ pS) ?Puig_at_sub.
have sL2: 'L_{k.*2.+2}(S) \subset 'L_{k.*2.+2}(T) by exact: Puig_max.
split; [exact sL2 | rewrite doubleS; apply: subset_trans (Puig_succS _ sL2) _].
by rewrite Puig_max -?PuigS ?Puig_gen // sL_ // pcore_sub_Hall.
Qed.

Let Y := 'Z('L(T)).
Let L := 'L(S).

Theorem Puig_center_normal : 'Z(L) <| G.
Proof.
have [sLiST sLTS] := pcore_Sylow_Puig_sub.
have sLiLT: 'L_*(T) \subset 'L(T) by exact: Puig_sub_even_odd.
have sZY: 'Z(L) \subset Y.
  rewrite subsetI andbC subIset ?centS ?orbT //=.
  suff: 'C_S('L_*(S)) \subset 'L(T).
    by apply: subset_trans; rewrite setISS ?Puig_sub ?centS ?Puig_sub_even_odd.
  apply: subset_trans (subset_trans sLiST sLiLT).
  by apply: sub_cent_Puig_at pS; rewrite double_gt0.
have chY: Y \char G := char_trans (center_Puig_char _) (pcore_char _ _).
have nsCY_G: 'C_G(Y) <| G by rewrite char_normal 1?subcent_char ?char_refl.
have [C defC sCY_C nsCG] := inv_quotientN nsCY_G (pcore_normal p _).
have sLG: L \subset G by rewrite (subset_trans _ (pHall_sub sylS)) ?Puig_sub.
have nsL_nCS: L <| 'N_G(C :&: S).
  have sYLiS: Y \subset 'L_*(S).
    rewrite abelian_norm_Puig ?double_gt0 ?center_abelian //.
    apply: normalS (pHall_sub sylS) (char_normal chY).
    by rewrite subIset // (subset_trans sLTS) ?Puig_sub.
  have gYL: Y --> L := norm_abgenS sYLiS (Puig_gen _ _).
  have sLCS: L \subset C :&: S.
    rewrite subsetI Puig_sub andbT.
    rewrite -(quotientSGK _ sCY_C) ?(subset_trans sLG) ?normal_norm // -defC.
    rewrite odd_abelian_gen_stable ?char_normal ?norm_abgen_pgroup //.
      by rewrite (pgroupS _ pT) ?subIset // Puig_sub.
    by rewrite (pgroupS _ pS) ?Puig_sub.
  rewrite -[L](sub_Puig_eq _ sLCS) ?subsetIr //.
  by rewrite (char_normal_trans (Puig_char _)) ?normalSG // subIset // sSG orbT.
have sylCS: p.-Sylow(C) (C :&: S) := pSylow_normalI nsCG sylS.
have{defC} defC: 'C_G(Y) * (C :&: S) = C.
  apply/eqP; rewrite eqEsubset mulG_subG sCY_C subsetIl /=.
  have nCY_C: C \subset 'N('C_G(Y)).
    exact: subset_trans (normal_sub nsCG) (normal_norm nsCY_G).
  rewrite -quotientSK // -defC /= -pseries1.
  rewrite -(pseries_catr_id [:: p : nat_pred]) (pseries_rcons_id [::]) /=.
  rewrite pseries1 /= pseries1 defC pcore_sub_Hall // morphim_pHall //.
  by rewrite subIset ?nCY_C.
have defG: 'C_G(Y) * 'N_G(C :&: S) = G.
  have sCS_N: C :&: S \subset 'N_G(C :&: S).
    by rewrite subsetI normG subIset // sSG orbT.
  by rewrite -(mulSGid sCS_N) mulgA defC (Frattini_arg _ sylCS).
have nsZ_N: 'Z(L) <| 'N_G(C :&: S) := char_normal_trans (center_char _) nsL_nCS.
rewrite /normal subIset ?sLG //= -{1}defG mulG_subG /=.
rewrite cents_norm ?normal_norm // centsC.
by rewrite (subset_trans sZY) // centsC subsetIr.
Qed.

End AppendixB.

Section Puig_factorization.

Variables (gT : finGroupType) (p : nat) (G S : {group gT}).
Hypotheses (oddG : odd #|G|) (solG : solvable G) (sylS : p.-Sylow(G) S).

Theorem Puig_factorization : 'O_p^'(G) * 'N_G('Z('L(S))) = G.
Proof.
set D := 'O_p^'(G); set Z := 'Z(_); have [sSG pS _] := and3P sylS.
have sSN: S \subset 'N(D) by rewrite (subset_trans sSG) ?bgFunc_norm.
have p'D: p^'.-group D := pcore_pgroup _ _.
have tiSD: S :&: D = 1 := coprime_TIg (pnat_coprime pS p'D).
have def_Zq: Z / D = 'Z('L(S / D)).
  rewrite !quotientE -(setIid S) -(morphim_restrm sSN); set f := restrm _ _.
  have injf: 'injm f by rewrite ker_restrm ker_coset tiSD.
  rewrite -!(bgFunc_ascont _ injf) ?Puig_sub //= morphim_restrm.
  by rewrite (setIidPr _) // subIset ?Puig_sub.
have{def_Zq} nZq: Z / D <| G / D.
  have sylSq: p.-Sylow(G / D) (S / D) by exact: morphim_pHall.
  rewrite def_Zq (Puig_center_normal _ _ sylSq) ?quotient_odd ?quotient_sol //.
  exact: trivg_pcore_quotient.
have sZS: Z \subset S by rewrite subIset ?Puig_sub.
have sZN: Z \subset 'N_G(Z) by rewrite subsetI normG (subset_trans sZS).
have nDZ: Z \subset 'N(D) by rewrite (subset_trans sZS).
rewrite -(mulSGid sZN) mulgA -(norm_mulgenEr nDZ) (@Frattini_arg p) //= -/D -/Z.
  rewrite -cosetpre_normal quotientK ?quotientGK ?pcore_normal // in nZq.
  by rewrite norm_mulgenEr.
rewrite /pHall -divgS mulgen_subr ?(pgroupS sZS) /= ?norm_mulgenEr //= -/Z.
by rewrite TI_cardMg ?mulnK //; apply/trivgP; rewrite /= setIC -tiSD setSI.
Qed.

End Puig_factorization.


From Coq Require Import
     String List Arith ZArith
     FMapAVL OrderedTypeEx
     extraction.ExtrOcamlIntConv.
Import ListNotations.

From ExtLib.Structures Require Import
     Monad MonadFix.

From SimpleIO Require SimpleIO.

From advent Require Import lib sol.day16_common.

Module ZMap := FMapAVL.Make Z_as_OT.

Definition assignments : Type := ZMap.t (list op).

Definition initial_assignments : assignments :=
  snd (Z.iter 16
              (fun '(i, t) => ((i + 1)%Z, ZMap.add i all_ops t))
              (0%Z, ZMap.empty _)).

Definition show_list {A : Type}
           (show : A -> string) (xs : list A) : string :=
  "[" ++ (fix aux xs : string :=
    match xs with
    | [] => "]"
    | [x] => show x ++ "]"
    | x :: xs => show x ++ "," ++ aux xs
    end%string) xs.

Section show.
Import SimpleIO.

Definition show_z (z : Z) : string :=
  from_ostring (ostring_of_int (int_of_z z)).

Definition show_assignments (p : assignments) : string :=
  show_list
    (fun '(i, os) => show_z i ++ ":" ++ show_list show_op os)%string
    (ZMap.elements p).

Definition show_code : list (Z * op) -> string :=
  show_list (fun '(i, o) =>
                      show_z i ++ ":" ++ show_op o)%string.

End show.

Section enum.
Import SimpleIO.

Inductive stream' (A : Type) :=
| snil
| scons : A -> (unit -> stream' A) -> stream' A
.

Definition stream (A : Type) := unit -> stream' A.

Fixpoint enum_aux (os : list (Z * op)) (p : list (Z * list op)) :
  stream (list (Z * op)) -> stream (list (Z * op)) :=
  fun s (_ : unit) =>
    match p with
    | [] => scons _ (rev' os) s
    | (i, os') :: p =>
      fold_left
        (fun s o =>
           if existsb (fun '(_, o') => eqb_op o o') os then
             s
           else
             enum_aux ((i, o) :: os) p s)
        os' s tt
    end.

Definition enum p := enum_aux [] (ZMap.elements p) (fun _ => snil _).

Definition opcode_to_op (p : list (Z * op)) : Z -> op :=
  let m := fold_left
             (fun m '(i, o) => ZMap.add i o m) p (ZMap.empty _) in
  fun i =>
    match ZMap.find i m with
    | None => dummy
    | Some o => o
    end.

Variant instr : Type :=
  Instr (opcode : Z) (a b c : Z).

Definition interp_instr (oto : Z -> op) : regs -> instr -> regs :=
  fun rs '(Instr o a b c) =>
    interp (oto o, a, b, c) rs.

End enum.

Section main.

Import MonadNotation.
Local Open Scope monad_scope.

Definition sample_ (regs instr : Type) : Type :=
  regs * instr * regs.

Definition sample : Type := sample_ regs instr.

Context {m : Type -> Type} `{Monad m} `{MonadFix m} `{MonadError m}
        `{MonadDebug m}
        `{FoldRead sample m} `{FoldRead instr m} `{MonadO Z m}.

Definition test_sample : assignments -> sample -> assignments :=
  fun p '(rs, Instr oc a b c, rs') =>
    match ZMap.find oc p with
    | None => p (* Should not happen. *)
    | Some os =>
      let os :=
          filter
            (fun o =>
               let is := (o, a, b, c) in
               wf is && eqb_reg (interp is rs) rs')%bool
            os in
      ZMap.add oc os p
    end.

Definition deduce_assignments : m assignments :=
  fold_read test_sample initial_assignments.

Import SimpleIO.

Definition check_unique {A : Type}
           (show : A -> string) (s : stream A) : m A :=
  match s tt with
  | snil _ => error "No solution"
  | scons _ x s =>
    debug (print_endline (show x));;
    match s tt with
    | snil _ => ret x
    | scons _ x' s =>
      debug (print_endline (show x'));;
      error "Solution is not unique"
    end
  end.

Definition main : m unit :=
  p <- deduce_assignments;;
  debug (print_endline (show_assignments p));;
  code <- check_unique show_code (enum p);;
  let oto := opcode_to_op code in
  ' (Regs r0 _ _ _) <- fold_read (interp_instr oto) (Regs 0 0 0 0);;
  print r0.

End main.

Import SimpleIO.

Parameter parse_sample : forall {regs instr},
    (int -> int -> int -> int -> regs) ->
    (int -> int -> int -> int -> instr) ->
    IO (option (sample_ regs instr)).
Extract Constant parse_sample => "
  fun regs instr k ->
    k (try
      Scanf.scanf
        ""Before: [%d, %d, %d, %d] %d %d %d %d After: [%d, %d, %d, %d] ""
        (fun r0 r1 r2 r3 o a b c s0 s1 s2 s3 ->
          Some ((regs r0 r1 r2 r3, instr o a b c), regs s0 s1 s2 s3))
       with Scanf.Scan_failure _ | End_of_file -> None)".

Definition read_sample : IO (option sample) :=
  let z := z_of_int in
  let Regs' r0 r1 r2 r3 := Regs (z r0) (z r1) (z r2) (z r3) in
  let Instr' o a b c := Instr (z o) (z a) (z b) (z c) in
  parse_sample Regs' Instr'.

Local Instance MonadI_sample_IO : MonadI sample IO :=
  read_sample.

Parameter parse_instr : forall {instr},
    (int -> int -> int -> int -> instr) ->
    IO (option instr).
Extract Constant parse_instr => "
  fun instr k ->
    k (try Scanf.scanf ""%d %d %d %d ""
             (fun o a b c -> Some (instr o a b c))
       with End_of_file -> None)".

Definition read_instr : IO (option instr) :=
  let z := z_of_int in
  let Instr' o a b c := Instr (z o) (z a) (z b) (z c) in
  parse_instr Instr'.

Local Instance MonadI_instr_IO : MonadI instr IO :=
  read_instr.

Definition exe : io_unit := IO.unsafe_run main.
Extraction "day16_2.ml" exe.


(**  Module defining the programming languages:
     - Values
     - Expressions
     - Statements **)
Add LoadPath "vst".
Require Import Arith.
Require Import List.
Require Import Subst.
Require Import msl.eq_dec.
Import Relations.
Import ListNotations.

Delimit Scope lang_scope with lang.

Inductive var   : Set := V : nat -> var.
Inductive loc  : Set := L : nat -> loc.
Inductive pname : Set := P : nat -> pname.

Inductive value : Set :=
  | int_v  : nat -> value
  | loc_v  : loc -> value
  | null   : value.

Inductive expr :=
  | value_e : value -> expr
  | var_e   : var -> expr
  | fun_e   : pname -> expr -> expr -> expr.

Fixpoint fv_expr e :=
  match e with
    | var_e v => [v]
    | fun_e f e1 e2 => fv_expr e1 ++ fv_expr e2
    | _ => []
  end.
(*
Procedure p(x0 ... xn)
- return value is stored in one of p_mod
*)
Record proc' {s} :=
    { p_args: list var;
      p_ret: var;
      p_mod: list var;
      p_body: s }.

Inductive stmt :=
| skip_s   : stmt
| pad_s    : var -> var -> stmt
| alloc_s  : var -> var -> expr -> stmt
| assign_s : var -> expr -> stmt
| proc_s   : pname -> list var -> var -> list var -> stmt (* p(x0...xn), modifies y0...yn *)
| seq_s    : stmt -> stmt -> stmt
| if_s     : expr -> stmt -> stmt -> stmt
| return_s : expr -> stmt.

Definition proc := @proc' stmt.

Inductive program :=
| entry_p    : stmt -> program
| procdecl_p : pname -> proc -> program -> program.

Definition mkProc := Build_proc' stmt.

(* Coercion int_v: nat >-> value. *)
Coercion value_e: value >-> expr.
(* Coercion var_e: var >-> expr. *)

(*** Equality ***)
Instance EqDec_var : EqDec var := _.
Proof.
  hnf. decide equality; try apply eq_dec.
Qed.

Instance EqDec_loc : EqDec loc := _.
Proof.
  hnf. decide equality; try apply eq_dec.
Qed.

Instance EqDec_pname : EqDec pname := _.
Proof.
  hnf. decide equality; try apply eq_dec.
Qed.

Instance EqDec_value : EqDec value := _.
Proof.
  hnf. decide equality; apply eq_dec.
Qed.

Instance EqDec_expr : EqDec expr := _.
Proof.
  hnf. decide equality; apply eq_dec.
Qed.

Instance EqDec_stmt : EqDec stmt := _.
Proof.
  hnf.
  decide equality;
  apply eq_dec.
Qed.

(*** Substitutions ***)
Definition subst_var (s:subst_t var var) (v:var) := s v.
Definition subst_loc (s:subst_t loc loc) (l:loc) := s l.
Instance Subst_var_var : Subst var var var := subst_var.
Instance Subst_loc_loc : Subst loc loc loc := subst_loc.

Definition subst_var_one (v : var) (v' : var) : subst_t var var  :=
  fun i => if eq_dec i v then v' else i.

Definition subst_loc_one (l : loc) (l' : loc) : subst_t loc loc  :=
  fun i => if eq_dec i l then l' else i.

Fixpoint subst_expr_var (s:subst_t var var) (e:expr) :=
  match e with
    | var_e v => var_e (s v)
    | fun_e p e1 e2 => fun_e p (subst_expr_var s e1) (subst_expr_var s e2)
    | _ => e
  end.
Instance Subst_var_var_expr : Subst expr var var := fun s v => subst_expr_var s v.

Fixpoint subst_expr (s:subst_t var expr) (e:expr) :=
  match e with
    | var_e v => s v
    | fun_e p e1 e2 => fun_e p (subst_expr s e1) (subst_expr s e2)
    | _ => e
  end.
Instance Subst_var_expr : Subst expr var expr := fun s v => subst_expr s v.

Fixpoint subst_stmt (s:subst_t var var) (st:stmt) :=
  match st with
    | proc_s p xs r os => proc_s p (subst s xs) (subst s r) (subst s os)
    | assign_s x e => assign_s (subst s x) (subst s e)
    | _ => st
  end.

Instance Subst_stmt : Subst stmt var var := subst_stmt.

Definition state := var -> value.
Definition heap  := nat -> option value.
Definition world := (state * heap)%type.
Definition stk (w : world) : state := fst w.
Definition hp (w : world) : heap := snd w.

Parameter eval_fun : pname -> expr -> expr -> value.

Fixpoint eval s e :=
  match e with
    | value_e v => v
    | var_e v   => stk s v
    | fun_e f e1 e2 =>
      let v1 := eval s e1 in
      let v2 := eval s e2 in
      eval_fun f v1 v2
  end.

Definition subst_one (x : var) (e : expr) :=
  fun i => if eq_dec i x then e else (var_e i).

Inductive modvars : stmt -> var -> Prop :=
| mod_alloc1 : forall l v e, modvars (alloc_s l v e) l
| mod_alloc2 : forall l v e, modvars (alloc_s l v e) v
| mod_assign: forall x e, modvars (assign_s x e) x
| mod_proc1: forall f xs r os x,
               In x os ->
               modvars (proc_s f xs r os) x
| mod_proc2: forall f xs r os,
               modvars (proc_s f xs r os) r
| mod_seq1: forall x s1 s2, modvars s1 x -> modvars (seq_s s1 s2) x
| mod_seq2: forall x s1 s2, modvars s2 x -> modvars (seq_s s1 s2) x.


Require Import Coq.Lists.List.

Require Export SystemFR.RedTactics.
Require Export SystemFR.ErasedEquivalentMatch.

Opaque reducible_values.
Opaque makeFresh.

Lemma equivalent_split_match:
  forall ρ Γ1 Γ2 n t t' e1 e2 e x y v l,
    [ support ρ; Γ2 ⊨ n : T_nat ] ->
    valid_interpretation ρ ->
    (forall z, z ∈ support Γ1 -> z ∈ fv e1 -> False) ->
    (forall z, z ∈ support Γ1 -> z ∈ fv e2 -> False) ->
    (forall z, z ∈ support Γ1 -> z ∈ fv e -> False) ->
    (forall z, z ∈ support Γ1 -> z ∈ fv n -> False) ->
    ~(x ∈ fv_context Γ1) ->
    ~(x ∈ fv_context Γ2) ->
    ~(x ∈ fv t) ->
    ~(x ∈ fv t') ->
    ~(y ∈ fv e) ->
    ~(y ∈ fv e1) ->
    ~(y ∈ fv e2) ->
    ~(y ∈ fv n) ->
    ~(y ∈ fv t) ->
    ~(y ∈ fv t') ->
    ~(y ∈ fv_context Γ1) ->
    ~(y ∈ fv_context Γ2) ->
    ~(v ∈ fv e) ->
    ~(v ∈ fv e1) ->
    ~(v ∈ fv e2) ->
    ~(v ∈ fv n) ->
    ~(v ∈ fv t) ->
    ~(v ∈ fv t') ->
    ~(v ∈ fv_context Γ1) ->
    ~(v ∈ fv_context Γ2) ->
    NoDup (x :: y :: v :: nil) ->
    subset (fv n ++ fv e1 ++ fv e2) (support Γ2) ->
    subset (fv e) (support Γ2) ->
    (forall l,
          satisfies (reducible_values ρ)
                    (Γ1 ++ (x, T_equiv e1 e) :: (y, T_equiv n zero) :: Γ2)
                    l ->
          [ substitute t l ≡ substitute t' l ]) ->
    (forall l,
          satisfies (reducible_values ρ)
                    (Γ1 ++
                            (x, T_equiv (open 0 e2 (fvar v term_var)) e)
                            :: (y, T_equiv n (succ (fvar v term_var))) :: (v, T_nat) :: Γ2) l ->
          [ substitute t l ≡ substitute t' l ]) ->
    satisfies (reducible_values ρ) (Γ1 ++ (x, T_equiv (tmatch n e1 e2) e) :: Γ2) l ->
    wf n 0 ->
    wf e1 0 ->
    wf e2 1 ->
    [ substitute t l ≡ substitute t' l ].
Proof.
  unfold open_reducible,reduces_to;
    repeat step || list_utils || satisfies_cut || t_instantiate_sat3 ||
           t_termlist || step_inversion satisfies ||
           simp_red.

  t_invert_nat_value; steps.

  - unshelve epose proof (H28 (l1 ++ (x, uu) :: (y, uu) :: lterms) _);
      repeat step || apply satisfies_insert || step_inversion NoDup ||
             list_utils || t_substitutions || simp_red;
      t_closer;
      eauto using equivalent_match_zero2;
      eauto using satisfies_drop;
      try solve [ equivalent_star ].

  - unshelve epose proof (H29 (l1 ++ (x, uu) :: (y, uu) :: (v, v1) :: lterms) _);
      clear H28; clear H29;
      repeat step || apply satisfies_insert || step_inversion NoDup ||
             list_utils || t_substitutions || simp_red || fv_open;
      t_closer;
      eauto with twf;
      eauto using equivalent_match_succ2 with values erased wf;
      eauto using satisfies_drop;
      try solve [ equivalent_star ].
Qed.


Set Implicit Arguments.

Section Proc.
  Variable Op : Type -> Type.

  Inductive proc : Type -> Type :=
  | Call : forall T (op : Op T), proc T
  | Ret : forall T (v : T), proc T
  | Bind : forall T (T1 : Type) (p1 : proc T1) (p2 : T1 -> proc T), proc T
  | Until : forall T (c : T -> bool) (p : option T -> proc T) (v : option T), proc T
  | Atomic : forall T (p : proc T), proc T
  | Spawn : forall T (p: proc T), proc unit
  .

  Inductive maybe_proc :=
  | Proc : forall T, proc T -> maybe_proc
  | NoProc.
End Proc.

Arguments Call {Op T}.
Arguments Ret {Op T}.
Arguments Bind {Op T T1}.
Arguments Until {Op T}.
Arguments Atomic {Op T}.
Arguments Spawn {Op T}.

Arguments Proc {Op T}.
Arguments NoProc {Op}.

Notation "x <- p1 ; p2" := (Bind p1 (fun x => p2))
  (at level 60, right associativity).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  The trivial subset of the language.

 This is an attempt to see if I can work with these proofs.
 It is teaching me a few things but most of it is just rubbish.

 Lessons:

 So far it has shown me that I have to make gettype a relation again,
 as we induct on the structure of its derivation.

 Also it is checking for unused quantifiers.

 And it is teaching me how to do a proof by derivation of a relation.

 And it is teaching me how to set up a simultaneous instruction.

 And it is showing me how to do a proof by inspection and the form of values.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import CpdtTactics.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafetyProof.
Require Export TypeSafety.

Fixpoint EmptySubsetTau (tau : Tau) :=
  match tau with
    | _ => False
  end.

Fixpoint EmptySubsetSt (s : St) :=
  match s with
    | _ => False
  end.

Fixpoint EmptySubsetE (e : E) :=
  match e with
    | _ => False
  end.

(* Just test that I can easily automate away all cases. *)
Theorem Type_Safety_Empty_Bad_Induction:
 forall (s : St) (tau : Tau),
   EmptySubsetSt s ->
   EmptySubsetTau tau ->
   styp [] [] [] tau s ->
   ret s ->
   exists (h' : H) (s' : St),
     Sstar [] s h' s' ->
     NotStuck h' s'.
Proof.
  intros s tau.
  induction s;  crush.
Qed.

Theorem Type_Safety_Empty_Mutual_Induction:
 forall (s : St) (tau : Tau),
   EmptySubsetSt s ->
   EmptySubsetTau tau ->
   styp [] [] [] tau s ->
   ret s ->
   exists (h' : H) (s' : St),
     Sstar [] s h' s' ->
     NotStuck h' s'.
Proof.
  intros s tau.
  induction s;  crush.
Qed.

Lemma A_1_Context_Weakening_1:
  forall (d d' : Delta) (tau : Tau) (k : Kappa),
    EmptySubsetTau tau ->
    K d tau k ->
    K (d ++ d') tau k.
Proof.
  intros d d' tau k NoSuchType.
  intros Kderivation.
  induction Kderivation;
  try inversion NoSuchType.
  induction tau;
  try inversion NoSuchType.
Qed.

(* TODO need ltac that just finds the EmptySubsetTau and gives it a
  known name ?*)
Lemma A_1_Context_Weakening_2:
  forall (u : Upsilon) (d : Delta) (tau : Tau)
         (x : EVar) (p : P),
    EmptySubsetTau tau ->
    WFU u ->
    getU u x p = Some tau ->
    K d tau A.
Proof.
  intros u d tau x p NoSuchType WFUderivation.
  induction WFUderivation.
  induction tau; try inversion NoSuchType.
  induction tau; try inversion NoSuchType.
Qed.

(* Observation, not getting all that much here but a check on the
  quantifiers. *)

Lemma A_2_Term_Weakening_1 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (x : EVar) (p p' : P) (tau tau' : Tau),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    WFC d (u ++ u') (g ++ g') ->
    gettype u x p tau p' = Some tau' ->
    gettype (u ++ u') x p tau p' = Some tau'.
Proof.
  intros d u u' g g' x p p' tau tau'.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros WFCd.
  intros gettypederivation.
  functional induction (gettype u x p tau p'); try inversion NoSuchTypeTau.
Qed.

Lemma A_2_Term_Weakening_2 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (e : E) (tau : Tau),
(*    EmptySubsetTau tau ->
    EmptySubsetE   e ->
*)
    WFC d (u ++ u') (g ++ g') ->
    ltyp d u g e tau ->
    ltyp d (u ++ u') (g++g') e tau.
Proof.
(*
  intros *.
  intros NoSuchType NoSuchExpression.
  intros H.
  intros ltypederivation.
  induction ltypederivation;
    try (try inversion NoSuchType; try inversion NoSuchExpression).
*)
  (* Simultaneous induction on the assumed typing derivation.
    By which I think he means ltyp. *)
  (* So this is on ltyp, rtyp and stype. *)
  intros d u u' g g' e tau WFCder.
  (* No unification, good question why. I need to start on a simpler
   case. *)
(*  apply (typ_ind_mutual
           (fun (c1 : C) (tau : Tau) (s : St) (st : styp c1 tau s) =>
                 forall (u' : Upsilon) (g' : Gamma),
                   match c1 with
                     | d u g =>
                       ltyp d (u ++ u') (g ++ g') e tau
                   end)).
*)
  (* C failing to match so I either have to restructure the theorems or
   pattern match here. Going to try the pattern match. *)
Admitted.

Lemma A_2_Term_Weakening_3 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (e : E) (tau : Tau),
    EmptySubsetTau tau ->
    EmptySubsetE e ->
    WFC d (u ++ u') (g ++ g') ->
    rtyp d u g e tau ->
    rtyp d (u ++ u') (g++g') e tau.
Proof.
  intros *.
  intros NoSuchType NoSuchExpression.
  intros WFCderivation.
  intros rtypederivation.
  induction rtypederivation;
    try (try inversion NoSuchType; try inversion NoSuchExpression).
Qed.

Lemma A_2_Term_Weakening_4 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (s : St) (tau : Tau),
    EmptySubsetTau tau ->
    EmptySubsetSt s ->
    WFC d (u ++ u') (g ++ g') ->
    styp d u g               tau s ->
    styp d (u ++ u') (g++g') tau s.
Proof.
  intros *.
  intros NoSuchType NoSuchStatement.
  intros WFC.
  intros stypderivation.
  induction stypderivation;
      try (try inversion NoSuchType;
           try inversion NoSuchExpression;
           try inversion NoSuchStatement).
Qed.

(* Can't do any subsetting with heap weakening. *)

Lemma A_4_Useless_Substitutions_1:
  forall (d : Delta) (alpha : TVar) (tau tau' : Tau) (k : Kappa),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    getD d alpha = None ->
    K d tau' k ->
    subst_Tau tau' tau alpha = tau'.
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros H.
  intros Kderivation.
  induction Kderivation;
  try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau0;
  try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Qed.

Lemma A_4_Useless_Substitutions_2:
  forall (d : Delta) (alpha : TVar) (tau tau' : Tau) (g : Gamma),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    getD d alpha = None ->
    WFDG d g ->
    subst_Gamma g tau alpha = g.
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros H.
  intros Kderivation.
  induction Kderivation;
  try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau;
  try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Admitted.

Lemma A_4_Useless_Substitutions_3:
  forall (d : Delta) (alpha : TVar) (tau tau': Tau) (u : Upsilon) (p : P)
         (x : EVar),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    getD d alpha = None ->
    WFU u ->
    getU u x p = Some tau' ->
    subst_Tau tau' tau alpha = tau'.
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros H.
  intros WFUderivation.
  induction WFUderivation;
  try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Admitted.

Lemma A_5_Commuting_Substitutions:
  forall (alpha beta : TVar) (t0 t1 t2 : Tau),
    EmptySubsetTau t0 ->
    EmptySubsetTau t1 ->
    EmptySubsetTau t2 ->
    NotFreeInTau beta t2 = true ->
    (subst_Tau (subst_Tau t0 t1 beta) t2 alpha) =
    (subst_Tau (subst_Tau t0 t2 alpha)
              (subst_Tau t1 t2 alpha)
              beta).
Proof.
  intros *.
  intros NoSuchTypeT0 NoSuchTypeT1 NoSuchTypeT2.
  induction t0;
  try (try inversion NoSuchTypeT0;
       try inversion NoSuchTypeT1;
       try inversion NoSuchTypeT2).
Qed.

Lemma A_6_Substitution_1:
  forall (d : Delta) (alpha : TVar) (tau tau' : Tau) (k k': Kappa),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    AK d tau k ->
    K (d ++ [(alpha,k)]) tau' k' ->
    K d (subst_Tau tau' tau alpha) k'.
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau';
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Qed.

Lemma A_6_Substitution_2:
  forall (d : Delta) (alpha : TVar) (tau tau' : Tau) (k k': Kappa),
    EmptySubsetTau tau  ->
    EmptySubsetTau tau' ->
    AK d tau k ->
    K (d ++ [(alpha,k)]) tau' k' ->
    AK d (subst_Tau tau' tau alpha) k'.
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau';
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Qed.

Lemma A_6_Substitution_3:
  forall (d : Delta) (alpha : TVar) (tau tau' : Tau) (k : Kappa),
    EmptySubsetTau tau  ->
    EmptySubsetTau tau' ->
    AK d tau k ->
    ASGN (d ++ [(alpha, k)]) tau' ->
    ASGN d (subst_Tau tau' tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau';
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Qed.

Lemma A_6_Substitution_4:
  forall (d : Delta) (alpha : TVar) (tau : Tau) (g : Gamma) (k : Kappa),
    EmptySubsetTau tau  ->
    AK d tau k ->
    WFDG (d ++ [(alpha,k)]) g ->
    WFDG d (subst_Gamma g tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Qed.

Lemma A_6_Substitution_5:
  forall (d : Delta) (u : Upsilon ) (alpha : TVar) (tau : Tau)
         (g : Gamma) (k : Kappa),
    EmptySubsetTau tau  ->
    AK d tau k ->
    WFC (d ++ [(alpha,k)]) u g ->
    WFC d u (subst_Gamma g tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
  induction tau;
    try (try inversion NoSuchTypeTau; try inversion NoSuchTypeTau').
Qed.

Lemma A_6_Substitution_6:
  forall (d : Delta) (alpha : TVar) (tau : Tau) (s : St)
         (k : Kappa),
    EmptySubsetTau tau  ->
    EmptySubsetSt s  ->
    AK d tau k ->
    ret s ->
    ret (subst_St s tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchStatementS.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau; try inversion NoSuchStatementS).
  induction tau;
    try (try inversion NoSuchTypeTau; try inversion NoSuchStatementS).
Qed.

Lemma A_6_Substitution_7:
  forall (d: Delta) (u : Upsilon ) (alpha : TVar) (x : EVar)
         (t1 t2 tau : Tau) (p p': P) (k : Kappa),
    EmptySubsetTau t1 ->
    EmptySubsetTau t2 ->
    EmptySubsetTau tau ->
    AK d tau k ->
    WFU u ->
    gettype u x p t1 p' = Some t2 ->
    gettype u x p (subst_Tau t1 tau alpha) p' =
    Some (subst_Tau t2 tau alpha).
Proof.
  intros *.
  intros NoSuchTypeT1 NoSuchTypeT2 NoSuchTypeTau.
  intros AKderivation.
  induction AKderivation;
    try (try inversion NoSuchTypeTau;
         try inversion NoSuchTypeT1;
         try inversion NoSuchTypeT2).
  intros W.
  intros gettypederviation;
    try (try inversion NoSuchTypeTau;
         try inversion NoSuchTypeT1;
         try inversion NoSuchTypeT2).
Admitted.

Lemma A_6_Substitution_8_1:
  forall (d : Delta) (alpha : TVar) (u : Upsilon) (g : Gamma)
         (e : E) (tau tau' : Tau) (k : Kappa),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    EmptySubsetE e ->
    AK d tau k ->
    ltyp (d ++ [(alpha,k)]) u g  e tau' ->
    ltyp d u (subst_Gamma g tau alpha)
              (subst_E e tau alpha)
              (subst_Tau tau' tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau' NoSuchExpressionE.
  intros AKderivation.
  intros ltypederivation.
  induction AKderivation; induction ltypederivation;
    try (try inversion NoSuchTypeTau;
         try inversion NoSuchTypeTau';
         try inversion NoSuchExpressionE).
Qed.

Lemma A_6_Substitution_8_2:
  forall (d : Delta) (alpha : TVar) (u : Upsilon) (g : Gamma)
         (e : E) (tau tau' : Tau) (k : Kappa),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    EmptySubsetE e ->
    AK d tau k ->
    rtyp (d ++ [(alpha,k)]) u g  e tau' ->
    rtyp d u (subst_Gamma g tau alpha)
              (subst_E e tau alpha)
              (subst_Tau tau' tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau' NoSuchExpressionE.
  intros AKderivation.
  intros ltypederivation.
  induction AKderivation; induction ltypederivation;
    try (try inversion NoSuchTypeTau;
         try inversion NoSuchTypeTau';
         try inversion NoSuchExpressionE).
Qed.

Lemma A_6_Substitution_8_3:
  forall (d : Delta) (alpha : TVar) (u : Upsilon) (g : Gamma)
         (s : St) (tau tau' : Tau) (k : Kappa),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    EmptySubsetSt s ->
    AK d tau k ->
    styp (d ++ [(alpha,k)]) u g tau' s ->
    styp d u (subst_Gamma g tau alpha)
              (subst_Tau tau' tau alpha)
              (subst_St s tau alpha).
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau' NoSuchStatementS.
  intros AKderivation.
  intros stypederivation.
  induction AKderivation; induction stypederivation;
    try (try inversion NoSuchTypeTau;
         try inversion NoSuchTypeTau';
         try inversion NoSuchStatementS).
Qed.

Lemma A_7_Typing_Well_Formedness_1 :
  forall (d: Delta) (u : Upsilon) (x : EVar) (tau tau' : Tau) (p p' : P),
    EmptySubsetTau tau ->
    EmptySubsetTau tau' ->
    WFU u ->
    gettype u x p tau p' = Some tau' ->
    K d tau A ->
    K d tau' A.
Proof.
  intros *.
  intros NoSuchTypeTau NoSuchTypeTau'.
  functional induction (gettype u x p tau p');
    try (try inversion NoSuchTypeTau;
         try inversion NoSuchTypeTau').
Qed.

Lemma A_7_Typing_Well_Formedness_2 :
  forall (d: Delta) (g : Gamma) (u : Upsilon) (tau : Tau) (e : E),
    EmptySubsetTau tau ->
    EmptySubsetE   e ->
    ltyp d u g e tau ->
    (WFC d u g /\
     K d tau A).
Proof.
  (* Simultaneous induction does not seem to be used here. *)
  intros *.
  intros NoSuchType NoSuchExpression.
  intros ltypderivation.
  induction ltypderivation;
    try (try inversion NoSuchType; try inversion NoSuchExpression).
Qed.

Lemma A_7_Typing_Well_Formedness_3 :
  forall (d: Delta) (g : Gamma) (u : Upsilon) (tau : Tau) (e : E),
    EmptySubsetTau tau ->
    EmptySubsetE   e ->
    rtyp d u g e tau ->
    (WFC d u g /\
     K d tau A).
Proof.
  intros *.
  intros NoSuchType NoSuchExpression.
  intros rtypderivation.
  induction rtypderivation;
    try (try inversion NoSuchType; try inversion NoSuchExpression).
Qed.

Lemma A_7_Typing_Well_Formedness_4 :
  forall (d: Delta) (g : Gamma) (u : Upsilon) (tau : Tau) (s : St),
    EmptySubsetTau tau ->
    EmptySubsetSt  s ->
    styp d u g tau s ->
    WFC d u g.
Proof.
  intros *.
  intros NoSuchType NoSuchStatement.
  intros stypderivation.
  induction stypderivation;
    try (try inversion NoSuchType; try inversion NoSuchStatement).
Qed.

Lemma A_7_Typing_Well_Formedness_5 :
  forall (d: Delta) (g : Gamma) (u : Upsilon) (tau : Tau) (s : St),
    EmptySubsetTau tau ->
    EmptySubsetSt  s ->
    styp d u g tau s ->
    ret s ->
    K d tau A.
Proof.
  intros *.
  intros NoSuchType NoSuchStatement.
  intros stypderivation retderivation.
  induction stypderivation; induction retderivation;
    try (try inversion NoSuchType; try inversion NoSuchStatement).
Qed.

Lemma A_8_Return_Preservation:
  forall (s s' : St) (h h' : H),
  EmptySubsetSt  s ->
  EmptySubsetSt  s' ->
  ret s ->
  S h s h' s' ->
  ret s'.
Proof.
  intros *.
  intros NoSuchStatementS NoSuchStatementS'.
  intros r.
  intros S.
  (* TODO this does not match Dan's induction on the S derivation. *)
  induction s';
    try (try inversion NoSuchStatementS;
         try inversion NoSuchStatementS').
Qed.

Lemma A_9_Cannonical_Forms_1:
  forall (u : Upsilon) (g : Gamma) (v : E) (tau : Tau),
    EmptySubsetTau tau ->
    EmptySubsetE   v ->
    rtyp [] u g v tau ->
    Value v ->
    tau = cint ->
    exists z : Z, v = (i_e (i_i z)).
Proof.
  (* TODO is this inspection on rtyp and Value v? *)
  intros *.
  intros NoSuchType NoSuchExpression.
  intros R V T.
  destruct tau;
    try (try inversion NoSuchType;
         try inversion NoSuchExpression).
Qed.

(* The other six are going to be identical. *)

Lemma A_10_Path_Extension_1_A:
  forall (v v0 v1 : E) (p : P),
    EmptySubsetE   v ->
    EmptySubsetE   v0 ->
    EmptySubsetE   v1 ->
    Value v ->
    Value v0 ->
    Value v1 ->
    get v p (cpair v0 v1) ->
    get v (p ++ [i_pe (i_i 0)]) v0 /\
    get v (p ++ [i_pe (i_i 1)]) v1.
Proof.
  intros *.
  intros NoSuchExpressionv NoSuchExpressionv0 NoSuchExpressionv1.
  induction p.
  (* How do I induct on the length of a list ? *)
Admitted.

(* The induction is on htyp and refp simultaneously. *)
Lemma A_14_Term_Progress_1:
  forall (g : Gamma) (u : Upsilon) (h : H) (e : E) (tau : Tau),
    htyp u g h g ->
    refp h u ->
    (ltyp [] u g e tau ->
     (exists (x : EVar) (p : P), e = (p_e x p) \/
      exists (h' : H) (e' : E),  L h (e_s e) h' (e_s e'))).
Proof.
  intros g u h e tau.
  intros H.
  induction H.
  intros R.
  induction R.
  (* Not a good test on mutual induction. *)
Admitted.


(** * Hoare triple for machine state monad *)
Require Import x86proved.triple.core.
Import triple.core.tripleconfig.

Require Import Coq.Setoids.Setoid Coq.Program.Basics Coq.Classes.Morphisms.
Require Import x86proved.common_tactics.

Import Prenex Implicits.

Local Transparent ILFun_Ops ILPre_Ops.

Local Ltac fin_solve_morphism :=
  do !(idtac;
       match goal with
         | [ s : ProcState, H : forall _ : ProcState, _ |- _ ] => specialize (H s)
         | [ H : _ |- _ ] => (eapply H; eassumption)
         | [ H : _, H' : _ |- _ ] => (rewrite -> H in H'; clear H)
         | [ H : _, H' : _ |- _ ] => (rewrite <- H in H'; clear H)
         | [ H : _, H' : _ |- _ ] => (setoid_rewrite -> H in H'; clear H)
         | [ H : _, H' : _ |- _ ] => (setoid_rewrite <- H in H'; clear H)
         | [ H : _ |- _ ] => (rewrite -> H; clear H)
         | [ H : _ |- _ ] => (rewrite <- H; clear H)
         | [ H : _ |- _ ] => (setoid_rewrite -> H; clear H)
         | [ H : _ |- _ ] => (setoid_rewrite <- H; clear H)
         | [ H : _ |- _ ] => eapply H; eassumption
       end).

Local Ltac solve_morphism :=
  (rewrite /valued_TRIPLE/pointwise_relation => *; do ?move => ?);
  fin_solve_morphism.

(** Triples behave contravariantly in the precondition and covariantly
    in the postcondition wrt entailment *)
Global Add Parametric Morphism T v : (@valued_TRIPLE T v) with signature lentails --> eq ==> eq ==> lentails ==> impl as TRIPLE_mor2.
Proof. solve_morphism. Qed.

Global Add Parametric Morphism T v : (@valued_TRIPLE T v) with signature lequiv ==> eq ==> eq ==> lequiv ==> iff as TRIPLE_mor4.
Proof. move => *; split => ?; fin_solve_morphism. Qed.

(** For dealing with programs *)
Global Add Parametric Morphism T v P : (@valued_TRIPLE T v P) with signature (pointwise_relation ProcState eq) ==> eq ==> eq ==> impl as TRIPLE_morprogram.
Proof. solve_morphism. Qed.


(**********************************************************************)
(* 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                  Typed LambdaFactor Calculus                       *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus  from Project Coq                                  *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                           General.v                                *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega.
Require Import ArithRing.

(* some general-purpose tactics *)

Ltac eapply2 H := eapply H; eauto.

Ltac split_all := simpl; intros;
match goal with
| H : _ /\ _ |- _ => inversion_clear H; split_all
| H : if ?b then False else False |-_=> generalize H; clear H; case b; split_all
| |- if ?b then True else True => case b; auto
| H : false = true |-_=> inversion H
| H : exists _, _ |- _ => inversion H; clear H; split_all
| _ =>  try (split; split_all); try contradiction
end; try congruence; auto.

Ltac noway := simpl in *; intros; assert False by omega; contradiction.

Ltac exist x := exists x; split_all.

Ltac gen_case H W :=
  generalize H; clear H; case W; split_all.

Ltac gen2_case H0 H1 W :=
  generalize H0 H1; clear H0 H1; case W; split_all.

Ltac gen3_case H0 H1 H2 W :=
  generalize H0 H1 H2; clear H0 H1 H2; case W; split_all.

Ltac gen4_case H0 H1 H2 H3 W :=
  generalize H0 H1 H2 H3; clear H0 H1 H2 H3; case W; split_all.

Ltac gen_inv H W :=
  generalize H; clear H; inversion W; split_all.

Ltac gen2_inv H0 H1 W :=
  generalize H0 H1; clear H0 H1; inversion W; split_all.

Ltac gen3_inv H0 H1 H2 W :=
  generalize H0 H1 H2; clear H0 H1 H2; inversion W; split_all.

Ltac gen4_inv H0 H1 H2 H3 W :=
  generalize H0 H1 H2 H3; clear H0 H1 H2 H3; inversion W; split_all.

Ltac gen_case_inv H M := gen_case H M; inversion H; auto.

Ltac invsub := match goal with | H : _ = _ |- _ => inversion H; subst; clear H; invsub | _ => split_all end.

(* some arithmetic *)

Ltac dropS :=
match goal with
| |- S ?m <= S?n => cut(m<= n); [split_all; omega |]
| |- S ?m < S?n => cut(m< n); [split_all; omega |]
| |- S ?m >= S?n => cut(m>= n); [split_all; omega |]
| |- S ?m > S?n => cut(m> n); [split_all; omega |]
end.

Lemma times_distributive : forall m n p, (m+n) * p = m*p + n * p.
Proof. split_all. ring. Qed.

Lemma times_distributive2 :
forall m n p q, (m+n) * (p+q) = m*p + n * p + m*q + n*q.
Proof. split_all. ring. Qed.

Lemma times_positive: forall m n, m>0 -> n>0 -> m*n >0 .
Proof.
split_all. gen_case H m; gen_case H0 n; split_all; try noway.
case (n1 + n0 * S n1); split_all; omega.
Qed.

Lemma  times_monotonic:  forall m1 m2 n1 n2, 0< m1 -> 0 < m2 -> m1 < n1 -> m2 < n2 -> m1 * m2 < n1 * n2.
Proof.
split_all.
replace n1 with (n1 - m1 + m1) by omega.
replace n2 with (n2 - m2 + m2) by omega.
rewrite times_distributive2.
cut(0 < (n1 - m1) * (n2 - m2) + m1 * (n2 - m2) + (n1 - m1) * m2).
split_all; omega.
replace m1 with (1+ (pred m1)) by omega.
replace (n2 - m2) with (1+ (pred (n2 - m2))) by omega.
rewrite times_distributive2.
simpl.
case((pred m1 * 1 + (pred (n2 - m2) + 0) + pred m1 * pred (n2 - m2)));
case((n1 - S (pred m1)) * S (pred (n2 - m2)));
case((n1 - S (pred m1)) * m2); split_all; omega.
Qed.

Lemma  times_monotonic2:  forall m1 m2 n1 n2, 0< m1 -> 0 < m2 -> m1 <= n1 -> m2 < n2 -> m1 * m2 < n1 * n2.
Proof.
split_all.
replace n1 with (n1 - m1 + m1) by omega.
replace n2 with (n2 - m2 + m2) by omega.
rewrite times_distributive2.
assert(0 < (n1 - m1) * (n2 - m2) + m1 * (n2 - m2) + (n1 - m1) * m2).
replace m1 with (1+ (pred m1)) by omega.
replace (n2 - m2) with (1+ (pred (n2 - m2))) by omega.
rewrite times_distributive2.
simpl.
case((pred m1 * 1 + (pred (n2 - m2) + 0) + pred m1 * pred (n2 - m2)));
case((n1 - S (pred m1)) * S (pred (n2 - m2)));
case((n1 - S (pred m1)) * m2); split_all; omega.
gen_case H3 ((n1 - m1) * (n2 - m2) + m1 * (n2 - m2) + (n1 - m1) * m2); split_all; try noway.  omega.
Qed.

Fixpoint exp (m n:nat) {struct n}: nat :=
match n with
| O => 1
| S n => m * exp m n
end.

Notation "x ^ y" := (exp x y).

Lemma exp_positive: forall n m, m>0 -> exp m n >0 .
Proof.
induction n; split_all.
assert(m^n >0) by eapply2 IHn.
eapply2 times_positive.
Qed.

Lemma max_is_max : forall m n, max m n >= m /\ max m n >= n.
Proof.
double induction m n; split_all; try omega.
elim (H0 n); split_all; omega.
elim (H0 n); split_all; omega.
Qed.

Lemma max_succ: forall m n, S (max m n) = max (S m) (S n).
Proof. double induction m n; split_all.  Qed.

Lemma max_pred: forall m n, pred (max m n) = max (pred m) (pred n).
Proof. double induction m n; split_all. case n; split_all. Qed.

Lemma max_max : forall m n p, m >= max n p -> m>= n /\ m>= p.
Proof.
induction m; intros n p. case n; case p; split_all; subst; try noway; try omega.
intros.
assert(m >= pred (max n p)) by omega.
rewrite max_pred in H0.
elim (IHm (pred n) (pred p)); split_all; omega.
Qed.

Lemma max_max2 : forall m n k, k>= m -> k>= n -> k>= max m n.
Proof.
double induction m n; split_all.
assert(pred k >= max n1 n) .  eapply2 H0. omega. omega. omega.
Qed.

Lemma max_zero : forall m, max m 0 = m.
Proof. induction m; split_all. Qed.

Lemma max_plus: forall m n k, max m n +k = max (m+k) (n+k).
Proof.
double induction m n; split_all.
induction k; split_all.
assert(max k (S (n0+k)) >= S(n0+k)) by eapply2 max_is_max.
assert(S(n0+k) >= max k (S(n0+k))) . eapply2 max_max2.
omega.
omega.
case k; split_all.
assert(max (n+S n1) n1 >= n+ S n1) by  eapply2 max_is_max.
assert(n+ S n1 >= max (n+S n1) n1) . eapply2 max_max2.
omega.
omega.
Qed.

Lemma max_minus: forall m n k, max m n -k = max (m-k) (n-k).
Proof.
double induction m n; split_all.
case k; split_all.
rewrite max_zero. omega.
case k; split_all.
Qed.

Lemma max_monotonic : forall m1 m2 n1 n2, m1 >= n1 -> m2 >= n2 -> max m1 m2 >= max n1 n2.
Proof.
double induction m1 m2; split_all.
assert (n1 = 0) by omega; subst.
assert (n2 = 0) by omega; subst.
split_all.
assert (n1 = 0) by omega; subst. split_all.
assert (n2 = 0) by omega; subst.
assert(max n1 0 = n1) . case n1; split_all.
rewrite H2; auto.
assert(n0 >= pred n1) by omega.
cut(max n0 n >= pred (max n1 n2)).
intro.
omega.
rewrite max_pred.
eapply2 H0.
omega.
Qed.

Lemma max_succ_zero : forall k n, max k (S n) = 0 -> False .
Proof. split_all. assert(max k (S n) >= S n) by eapply2 max_is_max. noway. Qed.
Ltac max_out :=
match goal with
| H : max _ (S _) = 0  |- _ => assert False by (eapply2 max_succ_zero); noway
| H : max ?m ?n = 0 |- _ =>
assert (m = 0) by (assert (max m n >= m) by eapply2 max_is_max; omega);
assert (n = 0) by (assert (max m n >= n) by eapply2 max_is_max; omega);
clear H; try omega; try noway
| H : max ?m ?n <= 0 |- _ =>
assert (m = 0) by (assert (max m n >= m) by eapply2 max_is_max; omega);
assert (n = 0) by (assert (max m n >= n) by eapply2 max_is_max; omega);
clear H; try omega; try noway
end.

Lemma min_is_min : forall m n, min m n <= m /\ min m n <= n.
Proof.
double induction m n; split_all; try omega.
elim (H0 n); split_all; omega.
elim (H0 n); split_all; omega.
Qed.

Lemma min_succ: forall m n, S (min m n) = min (S m) (S n).
Proof. double induction m n; split_all.  Qed.

Lemma min_pred: forall m n, pred (min m n) = min (pred m) (pred n).
Proof. double induction m n; split_all. case n; split_all. Qed.

Lemma min_zero : forall m, min m 0 = 0.
Proof. induction m; split_all. Qed.

Lemma min_min : forall m n p, m <= min n p -> m<= n /\ m<= p.
Proof.
induction m; split_all; try omega.
gen_case H n; gen_case H p; try noway.
assert(m<= min n0 n1) by omega.
assert(m<= n0 /\ m<= n1) by eapply2 IHm; split_all; omega.
gen_case H p; try noway.
rewrite min_zero in *.
noway.
assert(m<= pred (min n (S n0))) by omega.
rewrite min_pred in H0.
simpl in *.
elim (IHm (pred n) n0); split_all.
omega.
Qed.

Lemma min_min2 : forall m n k, k<= m -> k<= n -> k<= min m n.
Proof.
double induction m n; split_all.
assert(pred k <= min n1 n) .  eapply2 H0. omega. omega. omega.
Qed.

Lemma min_plus: forall m n k, min m n +k = min (m+k) (n+k).
Proof.
double induction m n; split_all.
induction k; split_all.
assert(min k (S (n0+k)) <= k) by eapply2 min_is_min.
assert(k <= min k (S(n0+k))) . eapply2 min_min2.
omega.
omega.
case k; split_all.
assert(min (n+S n1) n1 <= n1) by  eapply2 min_is_min.
assert(n1 <= min (n+S n1) n1) . eapply2 min_min2.
omega.
omega.
Qed.

Lemma min_minus: forall m n k, min m n -k = min (m-k) (n-k).
Proof.
double induction m n; split_all.
case k; split_all.
rewrite min_zero. omega.
case k; split_all.
Qed.

Lemma min_monotonic : forall m1 m2 n1 n2, m1 <= n1 -> m2 <= n2 -> min m1 m2 <= min n1 n2.
Proof.
double induction m1 m2; split_all; try omega.
gen_case H1 n1; try noway.
gen_case H2 n2; try noway.
assert(min n0 n <= min n3 n4).
eapply2 H0; try omega.
omega.
Qed.

Lemma decidable_nats : forall (m n: nat), m=n \/ m<>n.
Proof.
 double induction m n.
left; split_all.
split_all; right; congruence.
split_all; right; congruence.
split_all.
elim(H0 n); split_all.
Qed.