Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e266m3_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(*  This file demonstrates loop verifications using two advanced techniques:
   1. Converting for-loop into while-loop
   2. Peeling off the first iteration of a loop.

  The function verified is this one, which computes integer square roots:

     int f (int b) {
       int i, a;
       for (i=b+1; i*i>b; i--) {
         a=i;
       }
       return a;
     }

Notice that the variable [a] is uninitialized until the middle of the first iteration,
  _and_  it should be mentioned in the loop invariant.  How should this be handled?
 Let's see . . .
*)

Require Import VST.floyd.proofauto.
Require Import VST.progs.peel.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition f_spec : ident * funspec :=
 DECLARE _f
  WITH b: Z
  PRE [ tint ]
          PROP  (0 <= b; (b+1)*(b+1) < Int.max_signed)
          PARAMS (Vint (Int.repr b))
          SEP   ()
  POST [ tint ]
        EX a:Z,
        PROP ((a-1)*(a-1)<=b /\ a*a>b)
        RETURN (Vint (Int.repr a))
           SEP ().

Definition Gprog : funspecs :=
        ltac:(with_library prog [f_spec ]).

Lemma body_f: semax_body Vprog Gprog f_f f_spec.
Proof.
start_function.
(* First: some preliminary arithmetic assertions. *)
assert (0 <= b <= b*b). {
   split; auto.
   destruct (zeq b 0). subst. lia.
   rewrite <- Z.mul_1_l at 1.
   apply Zmult_le_compat_r;  rep_lia.
}
assert (b*b <= (b+1)*(b+1) < Int.max_signed). {
  split; auto.
  apply Z.square_le_mono_nonneg; lia.
}
clear H H0.
(* Next:  We have a for-loop here.  For ease of reasoning, let's convert it
   to a while loop, which is easy with this tactic: *)
apply semax_convert_for_while'; [reflexivity .. | ].
forward.  (*  i = b+1; *)
rewrite add_repr.
(* Now comes the interesting part.  What should the loop invariant be?
  AFTER the first iteration, this invariant will work:
      (EX i:Z, PROP (0 <= i <= b+1; b < (i+1)*(i+1))
             LOCAL(temp _i (Vint (Int.repr i)); temp _b (Vint (Int.repr b)); temp _a (Vint (Int.repr (i+1))))
             SEP())
  But this does not hold before the first iteration.

  A more general invariant would be either of these,
   but they don't quite work in Verifiable C.

   EX i:Z, EX a: val,
             PROP (0 <= i <= Int.max_signed; b < (i+1)*(i+1) <= Int.max_signed;
                       (i=b+1)%Z \/ (a=Vint (Int.repr (i+1))))
             LOCAL(temp _i (Vint (Int.repr i)); temp _b (Vint (Int.repr b)); temp _a a)
             SEP().
   The problem with this one is that the initial value of variable _a is Vundef,
   and the declaration (LOCAL (temp _a ...)) requires that _a have a defined value.

   (PROP ()
             LOCAL(temp _i (Vint (Int.repr (b+1))); temp _b (Vint (Int.repr b)))
             SEP()) ||
   (EX i:Z, PROP (0 <= i <= Int.max_signed; b < (i+1)*(i+1) <= Int.max_signed)
             LOCAL(temp _i (Vint (Int.repr i)); temp _b (Vint (Int.repr b)); temp _a (Vint (Int.repr (i+1))))
             SEP()).
   The problem with this one is that forward_while requires that the loop
   invariant be in (existentially quantified) canonical form, but this is the disjunction
   of two (existentially quantified) canonical forms, which is not canonical.

   The underlying program logic (semax_while rule, etc.) is expressive enough
    to handle assertions and invariants not in canonical form, but the Floyd
    tactical machinery in forward_while requires canonical form.

    So, there's no loop invariant that works in VST.

    The solution is to peel off the first iteration; that is, prove the loop
        while (i*i>b) {a=i; i--}
    as if it were,
        if (i*i>b) then {a=i; i--; while (i*i>b) {a=i; i--}}

    We do that as follows.  First, apply a postcondition to the entire loop,
    using forward_seq:
*)
forward_seq (EX a:Z,  PROP ((a-1)*(a-1)<=b /\ a*a>b)
                     LOCAL(temp _a (Vint (Int.repr a)))
                     SEP ()).
(*  Then, peel off the first iteration: *)
eapply semax_while_peel.
(* Now the rest is straightforward. *)
-
 forward_if.
 forward.
 forward.
 apply ENTAIL_refl.
 rewrite Z.mul_add_distr_r, Z.mul_add_distr_l in *; lia.
-
 forward_while (EX i:Z, PROP (0 <= i <= b+1; b < (i+1)*(i+1))
             LOCAL(temp _i (Vint (Int.repr i)); temp _b (Vint (Int.repr b)); temp _a (Vint (Int.repr (i+1))))
             SEP()).
 *
  Exists b; entailer!!.
  f_equal; f_equal; lia.
 *
   entailer!!.
   split.
   pose proof (Z.square_nonneg i). rep_lia.
   assert (i*i <= (b+1)*(b+1)) by (apply Z.square_le_mono_nonneg; lia).
   lia.
 *
   forward.
   forward.
   Exists (i-1).
   entailer!.
   rewrite Z.sub_add. split; auto. split; try lia.
   destruct (zeq i 0); try lia. subst.
   rewrite Int.signed_repr in HRE by rep_lia. lia.
   split; auto.
   assert (i*i <= (b+1)*(b+1)) by (apply Z.square_le_mono_nonneg; lia).
   pose proof (Z.square_nonneg i).
   rewrite Int.signed_repr in HRE by rep_lia.
   lia.
 *
   forward.
   Exists (i+1).
   entailer!!.
   rewrite Z.add_simpl_r.
   assert (i*i <= (b+1)*(b+1)) by (apply Z.square_le_mono_nonneg; lia).
   pose proof (Z.square_nonneg i).
   rewrite Int.signed_repr in HRE by rep_lia.
   rewrite Z.mul_add_distr_r, Z.mul_add_distr_l in *.
   lia.
-
abbreviate_semax.
Intros a.
forward.
Exists a.
entailer!!.
Qed.


Require Export Base.Isomorphism.

Structure Functor (C D: Category) := {
  fobj: C -> D;
  fmap {a b: C}: (a ~> b) -> fobj a ~> fobj b;
  fmap_id {a: C}: fmap (@id _ a) = @id _ (fobj a);
  fmap_comp {a b c: C} (f: b ~> c) (g: a ~> b): fmap (f ∘ g) = fmap f ∘ fmap g;
}.

Arguments fobj {C D}.
Arguments fmap {C D} _ {a b}.
Arguments fmap_id {C D _ a}.
Arguments fmap_comp {C D _ a b c}.

Coercion fobj: Functor >-> Funclass.

Theorem fun_eq {C D: Category} (F G: Functor C D): F = G <-> (forall x: C, F x = G x) /\ (forall (x y: C) (f: x ~> y) (ex: F x = G x) (ey: F y = G y), eq_iso ey ∘ fmap F f = fmap G f ∘ eq_iso ex).
Proof.
  split.
  + intros H.
    subst G.
    split.
    intros x.
    reflexivity.
    intros x y f ex ey.
    rewrite !eq_iso_refl.
    simpl.
    rewrite comp_id_r.
    apply comp_id_l.
  + destruct F as [Fobj Fmap Fmap_id Fmap_comp], G as [Gobj Gmap Gmap_id Gmap_comp]; simpl.
    intros [Hobj Hmap].
    assert (Fobj = Gobj).
    now extensionality x.
    subst Gobj; clear Hobj.
    assert (Fmap = Gmap).
    extensionality x.
    extensionality y.
    extensionality f.
    specialize (Hmap x y f eq_refl eq_refl).
    simpl in Hmap.
    rewrite comp_id_l, comp_id_r in Hmap.
    exact Hmap.
    subst Gmap; clear Hmap.
    f_equal.
    all: apply proof_irrelevance.
Qed.

Ltac fun_eq x y f :=
  match goal with
  | [ |- ?F = ?G] =>
    apply (fun_eq F G); simpl;
    split; [
      intro;
      try reflexivity
    | let ex := fresh in
      let ey := fresh in
      intros x y f ex ey;
      try (
        rewrite (eq_iso_refl ex);
        clear ex;
        etransitivity; [ | symmetry; apply comp_id_r ]
      );
      try (
        rewrite (eq_iso_refl ey);
        clear ey;
        etransitivity; [ apply comp_id_l | ]
      );
      simpl
    ]
  end.

Section Cat.

Definition fun_id (C: Category): Functor C C := {|
  fobj x := x;
  fmap a b f := f;
  fmap_id a := eq_refl;
  fmap_comp _ _ _ f g := eq_refl;
|}.

Definition fun_comp {C D E: Category} (F: Functor D E) (G: Functor C D): Functor C E := {|
  fobj x := F (G x);
  fmap a b f := fmap F (fmap G f);
  fmap_id a := eq_trans (f_equal _ (fmap_id)) fmap_id;
  fmap_comp _ _ _ f g := eq_trans (f_equal _ (fmap_comp f g)) (fmap_comp (fmap G f) (fmap G g));
|}.

Lemma fun_comp_assoc (A B C D: Category) (F: Functor C D) (G: Functor B C) (H: Functor A B): fun_comp F (fun_comp G H) = fun_comp (fun_comp F G) H.
Proof. now fun_eq x y f. Qed.

Lemma fun_comp_id_l (A B: Category) (F: Functor A B): fun_comp (fun_id B) F = F.
Proof. now fun_eq x y f. Qed.

Lemma fun_comp_id_r (A B: Category) (F: Functor A B): fun_comp F (fun_id A) = F.
Proof. now fun_eq x y f. Qed.

Definition Cat_mixin: Category.mixin_of Category :=
Category.Mixin Category Functor fun_id (@fun_comp) fun_comp_assoc fun_comp_id_l fun_comp_id_r.

Global Canonical Cat: Category :=
Category.Pack Category Cat_mixin.

End Cat.

Section fmap_iso.
Context {C D: Category} {x y: C} (F: C ~> D) (i: x <~> y).

Definition imap_mixin: Isomorphism.mixin_of (fmap F i) :=
Isomorphism.Mixin _ _ _ (fmap F i) (fmap F i⁻¹)
(eq_trans (eq_sym (fmap_comp _ _)) (eq_trans (f_equal _ (inv_l _)) fmap_id))
(eq_trans (eq_sym (fmap_comp _ _)) (eq_trans (f_equal _ (inv_r _)) fmap_id)).

Global Canonical imap: F x <~> F y :=
Isomorphism.Pack (fmap F i) imap_mixin.

End fmap_iso.

Lemma is_iso_fmap {C D: Category} {x y: C} (F: C ~> D) (f: x ~> y): is_iso f -> is_iso (fmap F f).
Proof.
  intros [g [Hl Hr]].
  exists (fmap F g); split.
  all: rewrite <- fmap_comp, <- fmap_id.
  all: now f_equal.
Qed.

Lemma fmap_is_eq {C D: Category} {x y: C} (F: C ~> D) (f: x ~> y): is_eq f -> is_eq (fmap F f).
Proof.
intros [e H].
subst f y.
simpl.
rewrite fmap_id.
apply is_eq_id.
Qed.

Theorem fmap_inv {C D: Category} {x y: C} (F: C ~> D) (i: x <~> y): fmap F (i⁻¹) = (imap F i)⁻¹.
Proof. reflexivity. Qed.

Theorem imap_inv {C D: Category} {x y: C} (F: C ~> D) (i: x <~> y): imap F (i⁻¹) = (imap F i)⁻¹.
Proof. now apply iso_eq. Qed.

Definition cof {S T: Category} (F: S ~> T): co S ~> co T := {|
  fobj (x: co S) := F x: co T;
  fmap x y f := fmap F f;
  fmap_id := @fmap_id _ _ F;
  fmap_comp _ _ _ f g := @fmap_comp _ _ F _ _ _ g f;
|}.

Definition cof' {S T: Category} (F: co S ~> co T): S ~> T := {|
  fobj (x: S) := F x: T;
  fmap x y f := fmap F f;
  fmap_id := @fmap_id _ _ F;
  fmap_comp _ _ _ f g := @fmap_comp _ _ F _ _ _ g f;
|}.

Lemma cof_inv_l {S T: Category} (F: S ~> T): cof' (cof F) = F.
Proof. now fun_eq x y f. Qed.

Lemma cof_inv_r {S T: Category} (F: co S ~> co T): cof (cof' F) = F.
Proof.
  fun_eq x y f.
  rewrite !eq_iso_refl.
  unfold inv; simpl.
  rewrite comp_id_r.
  apply comp_id_l.
Qed.

Instance co_iso: Proper (isomorphic Cat ==> isomorphic Cat) co.
Proof.
  intros C D [[F [G]]].
  constructor.
  exists (cof F), (cof G).
  1: clear inv_r.
  2: clear inv_l.
  1: apply fun_eq in inv_l.
  2: apply fun_eq in inv_r.
  1: destruct inv_l as [Ho Hf].
  2: destruct inv_r as [Ho Hf].
  all: fun_eq y x f.
  1, 3: apply Ho.
  all: clear Ho.
  all: change (x ~> y) in f.
  all: unfold comp; simpl.
  all: change (Category.comp (Category.obj ?C) _ ?f ?g) with (@comp C _ _ _ f g).
  all: specialize (Hf x y f H0 H).
  all: simpl in Hf.
  all: rewrite !co_eq_iso.
  all: apply (iso_epic (eq_iso H0)).
  all: rewrite <- !comp_assoc.
  all: rewrite inv_l, comp_id_r.
  all: apply (iso_monic (eq_iso H)).
  all: rewrite comp_assoc.
  all: rewrite inv_r, comp_id_l.
  all: exact Hf.
Qed.

Program Definition Co': Cat ~> Cat := {|
  fobj := co;
  fmap := @cof;
|}.

Lemma Co'_invol: Co' ∘ Co' = id Cat.
Proof.
  fun_eq C D F.
  apply co_invol.
  revert H H0.
  destruct C as [X [xs xid xcomp xassoc xid_l xid_r]].
  destruct D as [Y [ys yid ycomp yassoc yid_l yid_r]].
  destruct F as [f F Fid Fcomp].
  unfold cof, co, co_mixin; simpl.
  unfold comp; simpl.
  unfold fun_comp; simpl.
  assert ((fun (a b c d: X)
    (f : xs c d) (g : xs b c) (h : xs a b) =>
    eq_sym (eq_sym (xassoc a b c d f g h))) = xassoc).
  apply proof_irrelevance.
  rewrite H; clear H.
  assert ((fun (a b c d: Y)
    (f : ys c d) (g : ys b c) (h : ys a b) =>
    eq_sym (eq_sym (yassoc a b c d f g h))) = yassoc).
  apply proof_irrelevance.
  rewrite H; clear H.
  intros H H0.
  rewrite !eq_iso_refl; clear H H0.
  simpl.
  reflexivity.
Qed.

Canonical Co: Cat <~> Cat :=
  Isomorphism.Pack Co' (Isomorphism.Mixin _ _ _ Co' Co' Co'_invol Co'_invol).

Definition full {S T: Category} (F: Functor S T) :=
  forall (x y: S) (f: F x ~> F y), exists f': x ~> y, fmap F f' = f.

Definition faithful {S T: Category} (F: Functor S T) :=
  forall (x y: S) (f g: x ~> y), fmap F f = fmap F g -> f = g.

Definition fully_faithful {S T: Category} (F: Functor S T) :=
  forall (x y: S) (f: F x ~> F y), exists! f': x ~> y, fmap F f' = f.

Lemma full_and_faithful {S T: Category} (F: Functor S T): fully_faithful F <-> full F /\ faithful F.
Proof.
  split.
  1: intros H.
  2: intros [fu fa].
  split.
  + intros x y f.
    specialize (H x y f).
    destruct H as [f' [Hf _]].
    now exists f'.
  + intros x y f g fg.
    specialize (H x y (fmap F g)).
    destruct H as [h [_ H]].
    transitivity h.
    symmetry.
    all: now apply H.
  + intros x y f.
    specialize (fu x y f).
    destruct fu as [f' H].
    exists f'; split.
    exact H.
    subst f.
    intros g H.
    symmetry.
    apply fa, H.
Qed.

Lemma fully_faithful_maps_iso {S T: Category} {x y: S} (F: Functor S T) (f: x ~> y): fully_faithful F -> is_iso f <-> is_iso (fmap F f).
Proof.
  intros Hf.
  apply full_and_faithful in Hf.
  destruct Hf as [fu fa].
  split.
  apply is_iso_fmap.
  intros [g' H].
  specialize (fu y x g').
  destruct fu as [g Hg].
  subst g'.
  rewrite <- !fmap_comp in H.
  rewrite <- !fmap_id in H.
  destruct H as [Hl Hr].
  apply fa in Hl.
  apply fa in Hr.
  now exists g.
Qed.

Lemma fully_faithful_iso {S T: Category} (F: Functor S T) (x y: S): fully_faithful F -> x ≃ y <-> F x ≃ F y.
Proof.
  intros Hf.
  apply full_and_faithful in Hf.
  destruct Hf as [H0 H1].
  split.
  all: intros [i].
  constructor.
  apply imap, i.
  destruct (H0 x y i) as [f Hf].
  destruct (H0 y x i⁻¹) as [g Hg].
  constructor.
  exists f, g.
  all: apply H1.
  all: rewrite fmap_id, fmap_comp.
  all: rewrite Hf, Hg.
  apply inv_l.
  apply inv_r.
Qed.

Lemma full_id (C: Category): full (id C).
Proof.
  intros x y f.
  now exists f.
Qed.

Lemma faithful_id (C: Category): faithful (id C).
Proof. easy. Qed.

Lemma fully_faithful_id (C: Category): fully_faithful (id C).
Proof.
  apply full_and_faithful.
  split.
  apply full_id.
  apply faithful_id.
Qed.

Lemma full_comp {A B C: Category} (F: B ~> C) (G: A ~> B): full F -> full G -> full (F ∘ G).
Proof.
  intros HF HG x y f.
  simpl in f |- *.
  specialize (HF (G x) (G y) f).
  destruct HF as [f' H].
  subst f.
  specialize (HG x y f').
  destruct HG as [f H].
  subst f'.
  now exists f.
Qed.

Lemma faithful_comp {A B C: Category} (F: B ~> C) (G: A ~> B): faithful F -> faithful G -> faithful (F ∘ G).
Proof.
  intros HF HG x y f g H.
  apply HG, HF, H.
Qed.

Lemma fully_faithful_comp {A B C: Category} (F: B ~> C) (G: A ~> B): fully_faithful F -> fully_faithful G -> fully_faithful (F ∘ G).
Proof.
  intros HF HG.
  apply full_and_faithful in HF.
  apply full_and_faithful in HG.
  apply full_and_faithful.
  split.
  now apply full_comp.
  now apply faithful_comp.
Qed.

Lemma full_cof {S T: Category} (F: S ~> T): full F -> full (cof F).
Proof.
  intros H x y f.
  apply H.
Qed.

Lemma faithful_cof {S T: Category} (F: S ~> T): faithful F -> faithful (cof F).
Proof.
  intros H x y f g.
  apply H.
Qed.

Lemma fully_faithful_cof {S T: Category} (F: S ~> T): fully_faithful F -> fully_faithful (cof F).
Proof.
  intros H.
  apply full_and_faithful in H.
  apply full_and_faithful.
  split.
  now apply full_cof.
  now apply faithful_cof.
Qed.

Lemma full_cof' {S T: Category} (F: co S ~> co T): full F -> full (cof' F).
Proof.
  intros H x y f.
  apply H.
Qed.

Lemma faithful_cof' {S T: Category} (F: co S ~> co T): faithful F -> faithful (cof' F).
Proof.
  intros H x y f g.
  apply H.
Qed.

Lemma fully_faithful_cof' {S T: Category} (F: co S ~> co T): fully_faithful F -> fully_faithful (cof' F).
Proof.
  intros H.
  apply full_and_faithful in H.
  apply full_and_faithful.
  split.
  now apply full_cof'.
  now apply faithful_cof'.
Qed.

Definition esurj {S T: Category} (F: Functor S T) :=
  forall y: T, exists x: S, F x ≃ y.

Lemma esurj_id (C: Category): esurj (id C).
Proof.
  intros x.
  now exists x.
Qed.

Lemma esurj_comp {A B C: Category} (F: B ~> C) (G: A ~> B): esurj F -> esurj G -> esurj (F ∘ G).
Proof.
  intros HF HG z.
  specialize (HF z).
  destruct HF as [y HF].
  specialize (HG y).
  destruct HG as [x HG].
  exists x.
  simpl.
  rewrite <- HF; clear HF.
  destruct HG as [i].
  constructor.
  exact (imap F i).
Qed.

Lemma esurj_cof {S T: Category} (F: S ~> T): esurj F <-> esurj (cof F).
Proof.
  split.
  all: intros H y.
  all: specialize (H y).
  all: destruct H as [x H].
  all: exists x.
  all: simpl in H |- *.
  1: rewrite iso_co.
  2: rewrite <- iso_co.
  all: exact H.
Qed.

Lemma esurj_cof' {S T: Category} (F: co S ~> co T): esurj F <-> esurj (cof' F).
Proof.
  split.
  all: intros H y.
  all: specialize (H y).
  all: destruct H as [x H].
  all: exists x.
  all: simpl in H |- *.
  1: rewrite <- iso_co.
  2: rewrite iso_co.
  all: exact H.
Qed.

Lemma fiso_surj {S T: Category} (F: S <~> T): forall y, exists x, to F x = y.
Proof.
  intros y.
  exists (to F⁻¹ y).
  change ((F ∘ F⁻¹) y = (id T) y).
  f_equal.
  apply inv_r.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(** Reformulation of the Wf module using subsets where possible, providing
   the support for [Program]'s treatment of well-founded definitions. *)

Require Import Coq.Init.Wf.
Require Import Coq.Program.Utils.
Require Import ProofIrrelevance.
Require Import FunctionalExtensionality.

Local Open Scope program_scope.

Section Well_founded.
  Variable A : Type.
  Variable R : A -> A -> Prop.
  Hypothesis Rwf : well_founded R.

  Variable P : A -> Type.

  Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.

  Fixpoint Fix_F_sub (x : A) (r : Acc R x) : P x :=
    F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y)
      (Acc_inv r (proj2_sig y))).

  Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).

  (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *)
  (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *)

  Hypothesis F_ext :
    forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
      (forall y:{y : A | R y x}, f y = g y) -> F_sub x f = F_sub x g.

  Lemma Fix_F_eq :
    forall (x:A) (r:Acc R x),
      F_sub x (fun y:{y:A | R y x} => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r.
  Proof.
    destruct r using Acc_inv_dep; auto.
  Qed.

  Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s.
  Proof.
    intro x; induction (Rwf x); intros.
    rewrite (proof_irrelevance (Acc R x) r s) ; auto.
  Qed.

  Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun y:{ y:A | R y x} => Fix_sub (proj1_sig y)).
  Proof.
    intro x; unfold Fix_sub.
    rewrite <- (Fix_F_eq ).
    apply F_ext; intros.
    apply Fix_F_inv.
  Qed.

  Lemma fix_sub_eq :
    forall x : A,
      Fix_sub x =
      let f_sub := F_sub in
        f_sub x (fun y: {y : A | R y x} => Fix_sub (`y)).
  Proof.
    exact Fix_eq.
  Qed.

End Well_founded.

Require Coq.extraction.Extraction.
Extraction Inline Fix_F_sub Fix_sub.

Set Implicit Arguments.

(** Reasoning about well-founded fixpoints on measures. *)

Section Measure_well_founded.

  (* Measure relations are well-founded if the underlying relation is well-founded. *)

  Variables T M: Type.
  Variable R: M -> M -> Prop.
  Hypothesis wf: well_founded R.
  Variable m: T -> M.

  Definition MR (x y: T): Prop := R (m x) (m y).

  Lemma measure_wf: well_founded MR.
  Proof with auto.
    unfold well_founded.
    cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0).
      intros.
      apply (H (m a))...
    apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)).
    intros.
    apply Acc_intro.
    intros.
    unfold MR in H1.
    rewrite H0 in H1.
    apply (H (m y))...
  Defined.

End Measure_well_founded.

Hint Resolve measure_wf.

Section Fix_rects.

  Variable A: Type.
  Variable P: A -> Type.
  Variable R : A -> A -> Prop.
  Variable Rwf : well_founded R.
  Variable f: forall (x : A), (forall y: { y: A | R y x }, P (proj1_sig y)) -> P x.

  Lemma F_unfold x r:
    Fix_F_sub A R P f x r =
    f (fun y => Fix_F_sub A R P f (proj1_sig y) (Acc_inv r (proj2_sig y))).
  Proof. intros. case r; auto. Qed.

  (* Fix_F_sub_rect lets one prove a property of
  functions defined using Fix_F_sub by showing
  that property to be invariant over single application of the
  function body (f in our case). *)

  Lemma Fix_F_sub_rect
    (Q: forall x, P x -> Type)
    (inv: forall x: A,
     (forall (y: A) (H: R y x) (a: Acc R y),
        Q y (Fix_F_sub A R P f y a)) ->
        forall (a: Acc R x),
          Q x (f (fun y: {y: A | R y x} =>
            Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y)))))
    : forall x a, Q _ (Fix_F_sub A R P f x a).
  Proof with auto.
    set (R' := fun (x: A) => forall a, Q _ (Fix_F_sub A R P f x a)).
    cut (forall x, R' x)...
    apply (well_founded_induction_type Rwf).
    subst R'.
    simpl.
    intros.
    rewrite F_unfold...
  Qed.

  (* Let's call f's second parameter its "lowers" function, since it
  provides it access to results for inputs with a lower measure.

  In preparation of lemma similar to Fix_F_sub_rect, but
  for Fix_sub, we first
  need an extra hypothesis stating that the function body has the
  same result for different "lowers" functions (g and h below) as long
  as those produce the same results for lower inputs, regardless
  of the lt proofs. *)

  Hypothesis equiv_lowers:
    forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)),
    (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist (*FIXME shouldn't be needed *) (fun y => R y x0) x p')) ->
      f g = f h.

  (* From equiv_lowers, it follows that
   [Fix_F_sub A R P f x] applications do not not
  depend on the Acc proofs. *)

  Lemma eq_Fix_F_sub x (a a': Acc R x):
    Fix_F_sub A R P f x a =
    Fix_F_sub A R P f x a'.
  Proof.
    revert a'.
    pattern x, (Fix_F_sub A R P f x a).
    apply Fix_F_sub_rect.
    intros.
    rewrite F_unfold.
    apply equiv_lowers.
    intros.
    apply H.
    assumption.
  Qed.

  (* Finally, Fix_F_rect lets one prove a property of
  functions defined using Fix_F_sub by showing that
  property to be invariant over single application of the function
  body (f). *)

  Lemma Fix_sub_rect
    (Q: forall x, P x -> Type)
    (inv: forall
      (x: A)
      (H: forall (y: A), R y x -> Q y (Fix_sub A R Rwf P f y))
      (a: Acc R x),
        Q x (f (fun y: {y: A | R y x} => Fix_sub A R Rwf P f (proj1_sig y))))
    : forall x, Q _ (Fix_sub A R Rwf P f x).
  Proof with auto.
    unfold Fix_sub.
    intros.
    apply Fix_F_sub_rect.
    intros.
    assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))...
    set (inv x0 X0 a). clearbody q.
    rewrite <- (equiv_lowers (fun y: {y: A | R y x0} =>
      Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y)))
    (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))...
    intros.
    apply eq_Fix_F_sub.
  Qed.

End Fix_rects.

(** Tactic to fold a definition based on [Fix_measure_sub]. *)

Ltac fold_sub f :=
  match goal with
    | [ |- ?T ] =>
      match T with
        context C [ @Fix_sub _ _ _ _ _ ?arg ] =>
        let app := context C [ f arg ] in
          change app
      end
  end.

(** This module provides the fixpoint equation provided one assumes
   functional extensionality. *)

Module WfExtensionality.

  (** The two following lemmas allow to unfold a well-founded fixpoint definition without
     restriction using the functional extensionality axiom. *)

  (** For a function defined with Program using a well-founded order. *)

  Program Lemma fix_sub_eq_ext :
    forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R)
      (P : A -> Type)
      (F_sub : forall x : A, (forall y:{y : A | R y x}, P (` y)) -> P x),
      forall x : A,
        Fix_sub A R Rwf P F_sub x =
          F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)).
  Proof.
    intros ; apply Fix_eq ; auto.
    intros.
    assert(f = g).
    extensionality y ; apply H.
    rewrite H0 ; auto.
  Qed.

  (** Tactic to unfold once a definition based on [Fix_sub]. *)

  Ltac unfold_sub f fargs :=
    set (call:=fargs) ; unfold f in call ; unfold call ; clear call ;
      rewrite fix_sub_eq_ext ; repeat fold_sub f ; simpl proj1_sig.

End WfExtensionality.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import fintype tuple tuple bigop prime finset fingroup.
From mathcomp Require Import morphism perm automorphism quotient action cyclic.
From mathcomp Require Import pgroup gseries sylow primitive_action.

(******************************************************************************)
(*  Definitions of the symmetric and alternate groups, and some properties.   *)
(*     'Sym_T == The symmetric group over type T (which must have a finType   *)
(*               structure).                                                  *)
(*            := [set: {perm T}]                                              *)
(*     'Alt_T == The alternating group over type T.                           *)
(******************************************************************************)

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

Import GroupScope.

Definition bool_groupMixin := FinGroup.Mixin addbA addFb addbb.
Canonical bool_baseGroup := Eval hnf in BaseFinGroupType bool bool_groupMixin.
Canonical boolGroup := Eval hnf in FinGroupType addbb.

Section SymAltDef.

Variable T : finType.
Implicit Types (s : {perm T}) (x y z : T).

(** Definitions of the alternate groups and some Properties **)
Definition Sym of phant T : {set {perm T}} := setT.

Canonical Sym_group phT := Eval hnf in [group of Sym phT].

Local Notation "'Sym_T" := (Sym (Phant T)) (at level 0).

Canonical sign_morph := @Morphism _ _ 'Sym_T _ (in2W (@odd_permM _)).

Definition Alt of phant T := 'ker (@odd_perm T).

Canonical Alt_group phT := Eval hnf in [group of Alt phT].

Local Notation "'Alt_T" := (Alt (Phant T)) (at level 0).

Lemma Alt_even p : (p \in 'Alt_T) = ~~ p.
Proof. by rewrite !inE /=; case: odd_perm. Qed.

Lemma Alt_subset : 'Alt_T \subset 'Sym_T.
Proof. exact: subsetT. Qed.

Lemma Alt_normal : 'Alt_T <| 'Sym_T.
Proof. exact: ker_normal. Qed.

Lemma Alt_norm : 'Sym_T \subset 'N('Alt_T).
Proof. by case/andP: Alt_normal. Qed.

Let n := #|T|.

Lemma Alt_index : 1 < n -> #|'Sym_T : 'Alt_T| = 2.
Proof.
move=> lt1n; rewrite -card_quotient ?Alt_norm //=.
have : ('Sym_T / 'Alt_T) \isog (@odd_perm T @* 'Sym_T) by apply: first_isog.
case/isogP=> g /injmP/card_in_imset <-.
rewrite /morphim setIid=> ->; rewrite -card_bool; apply: eq_card => b.
apply/imsetP; case: b => /=; last first.
  by exists (1 : {perm T}); [rewrite setIid inE | rewrite odd_perm1].
case: (pickP T) lt1n => [x1 _ | d0]; last by rewrite /n eq_card0.
rewrite /n (cardD1 x1) ltnS lt0n => /existsP[x2 /=].
by rewrite eq_sym andbT -odd_tperm; exists (tperm x1 x2); rewrite ?inE.
Qed.

Lemma card_Sym : #|'Sym_T| = n`!.
Proof.
rewrite -[n]cardsE -card_perm; apply: eq_card => p.
by apply/idP/subsetP=> [? ?|]; rewrite !inE.
Qed.

Lemma card_Alt : 1 < n -> (2 * #|'Alt_T|)%N = n`!.
Proof.
by move/Alt_index <-; rewrite mulnC (Lagrange Alt_subset) card_Sym.
Qed.

Lemma Sym_trans : [transitive^n 'Sym_T, on setT | 'P].
Proof.
apply/imsetP; pose t1 := [tuple of enum T].
have dt1: t1 \in n.-dtuple(setT) by rewrite inE enum_uniq; apply/subsetP.
exists t1 => //; apply/setP=> t; apply/idP/imsetP=> [|[a _ ->{t}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> x; rewrite !inE.
case/dtuple_onP=> injt _; have injf := inj_comp injt enum_rank_inj.
exists (perm injf); first by rewrite inE.
apply: eq_from_tnth => i; rewrite tnth_map /= [aperm _ _]permE; congr tnth.
by rewrite (tnth_nth (enum_default i)) enum_valK.
Qed.

Lemma Alt_trans : [transitive^n.-2 'Alt_T, on setT | 'P].
Proof.
case n_m2: n Sym_trans => [|[|m]] /= tr_m2; try exact: ntransitive0.
have tr_m := ntransitive_weak (leqW (leqnSn m)) tr_m2.
case/imsetP: tr_m2; case/tupleP=> x; case/tupleP=> y t.
rewrite !dtuple_on_add 2![x \in _]inE inE negb_or /= -!andbA.
case/and4P=> nxy ntx nty dt _; apply/imsetP; exists t => //; apply/setP=> u.
apply/idP/imsetP=> [|[a _ ->{u}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> z; rewrite !inE.
case/(atransP2 tr_m dt)=> /= a _ ->{u}.
case odd_a: (odd_perm a); last by exists a => //; rewrite !inE /= odd_a.
exists (tperm x y * a); first by rewrite !inE /= odd_permM odd_tperm nxy odd_a.
apply/val_inj/eq_in_map => z tz; rewrite actM /= /aperm; congr (a _).
by case: tpermP ntx nty => // <-; rewrite tz.
Qed.

Lemma aperm_faithful (A : {group {perm T}}) : [faithful A, on setT | 'P].
Proof.
by apply/faithfulP=> /= p _ np1; apply/eqP/perm_act1P=> y; rewrite np1 ?inE.
Qed.

End SymAltDef.

Notation "''Sym_' T" := (Sym (Phant T))
  (at level 8, T at level 2, format "''Sym_' T") : group_scope.
Notation "''Sym_' T" := (Sym_group (Phant T)) : Group_scope.

Notation "''Alt_' T" := (Alt (Phant T))
  (at level 8, T at level 2, format "''Alt_' T") : group_scope.
Notation "''Alt_' T" := (Alt_group (Phant T)) : Group_scope.

Lemma trivial_Alt_2 (T : finType) : #|T| <= 2 -> 'Alt_T = 1.
Proof.
rewrite leq_eqVlt => /predU1P[] oT.
  by apply: card_le1_trivg; rewrite -leq_double -mul2n card_Alt oT.
suffices Sym1: 'Sym_T = 1 by apply/trivgP; rewrite -Sym1 subsetT.
by apply: card1_trivg; rewrite card_Sym; case: #|T| oT; do 2?case.
Qed.

Lemma simple_Alt_3 (T : finType) : #|T| = 3 -> simple 'Alt_T.
Proof.
move=> T3; have{T3} oA: #|'Alt_T| = 3.
  by apply: double_inj; rewrite -mul2n card_Alt T3.
apply/simpleP; split=> [|K]; [by rewrite trivg_card1 oA | case/andP=> sKH _].
have:= cardSg sKH; rewrite oA dvdn_divisors // !inE orbC /= -oA.
case/pred2P=> eqK; [right | left]; apply/eqP.
  by rewrite eqEcard sKH eqK leqnn.
by rewrite eq_sym eqEcard sub1G eqK cards1.
Qed.

Lemma not_simple_Alt_4 (T : finType) : #|T| = 4 -> ~~ simple 'Alt_T.
Proof.
move=> oT; set A := 'Alt_T.
have oA: #|A| = 12 by apply: double_inj; rewrite -mul2n card_Alt oT.
suffices [p]: exists p, [/\ prime p, 1 < #|A|`_p < #|A| & #|'Syl_p(A)| == 1%N].
  case=> p_pr pA_int; rewrite /A; case/normal_sylowP=> P; case/pHallP.
  rewrite /= -/A => sPA pP nPA; apply/simpleP=> [] [_]; rewrite -pP in pA_int.
  by case/(_ P)=> // defP; rewrite defP oA ?cards1 in pA_int.
have: #|'Syl_3(A)| \in filter [pred d | d %% 3 == 1%N] (divisors 12).
  by rewrite mem_filter -dvdn_divisors //= -oA card_Syl_dvd ?card_Syl_mod.
rewrite /= oA mem_seq2 orbC.
case/predU1P=> [oQ3|]; [exists 2 | exists 3]; split; rewrite ?p_part //.
pose A3 := [set x : {perm T} | #[x] == 3]; suffices oA3: #|A :&: A3| = 8.
  have sQ2 P: P \in 'Syl_2(A) -> P :=: A :\: A3.
    rewrite inE pHallE oA p_part -natTrecE /= => /andP[sPA /eqP oP].
    apply/eqP; rewrite eqEcard -(leq_add2l 8) -{1}oA3 cardsID oA oP.
    rewrite andbT subsetD sPA; apply/exists_inP=> -[x] /= Px.
    by rewrite inE => /eqP ox; have:= order_dvdG Px; rewrite oP ox.
  have [/= P sylP] := Sylow_exists 2 [group of A].
  rewrite -(([set P] =P 'Syl_2(A)) _) ?cards1 // eqEsubset sub1set inE sylP.
  by apply/subsetP=> Q sylQ; rewrite inE -val_eqE /= !sQ2 // inE.
rewrite -[8]/(4 * 2)%N -{}oQ3 -sum1_card -sum_nat_const.
rewrite (partition_big (fun x => <[x]>%G) [in 'Syl_3(A)]) => [|x]; last first.
  by case/setIP=> Ax; rewrite /= !inE pHallE p_part cycle_subG Ax oA.
apply: eq_bigr => Q; rewrite inE pHallE oA p_part -?natTrecE //=.
case/andP=> sQA /eqP oQ; have:= oQ.
rewrite (cardsD1 1) group1 -sum1_card => [[/= <-]]; apply: eq_bigl => x.
rewrite setIC -val_eqE /= 2!inE in_setD1 -andbA -{4}[x]expg1 -order_dvdn dvdn1.
apply/and3P/andP=> [[/eqP-> _ /eqP <-] | [ntx Qx]]; first by rewrite cycle_id.
have:= order_dvdG Qx; rewrite oQ dvdn_divisors // mem_seq2 (negPf ntx) /=.
by rewrite eqEcard cycle_subG Qx (subsetP sQA) // oQ /order => /eqP->.
Qed.

Lemma simple_Alt5_base (T : finType) : #|T| = 5 -> simple 'Alt_T.
Proof.
move=> oT.
have F1: #|'Alt_T| = 60 by apply: double_inj; rewrite -mul2n card_Alt oT.
have FF (H : {group {perm T}}): H <| 'Alt_T -> H :<>: 1 -> 20 %| #|H|.
- move=> Hh1 Hh3.
  have [x _]: exists x, x \in T by apply/existsP/eqP; rewrite oT.
  have F2 := Alt_trans T; rewrite oT /= in F2.
  have F3: [transitive 'Alt_T, on setT | 'P] by apply: ntransitive1 F2.
  have F4: [primitive 'Alt_T, on setT | 'P] by apply: ntransitive_primitive F2.
  case: (prim_trans_norm F4 Hh1) => F5.
    by case: Hh3; apply/trivgP; apply: subset_trans F5 (aperm_faithful _).
  have F6: 5 %| #|H| by rewrite -oT -cardsT (atrans_dvd F5).
  have F7: 4 %| #|H|.
    have F7: #|[set~ x]| = 4 by rewrite cardsC1 oT.
    case: (pickP [in [set~ x]]) => [y Hy | ?]; last by rewrite eq_card0 in F7.
    pose K := 'C_H[x | 'P]%G.
    have F8 : K \subset H by apply: subsetIl.
    pose Gx := 'C_('Alt_T)[x | 'P]%G.
    have F9: [transitive^2 Gx, on [set~ x] | 'P].
      by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
    have F10: [transitive Gx, on [set~ x] | 'P].
      exact: ntransitive1 F9.
    have F11: [primitive Gx, on [set~ x] | 'P].
      exact: ntransitive_primitive F9.
    have F12: K \subset Gx by apply: setSI; apply: normal_sub.
    have F13: K <| Gx by rewrite /(K <| _) F12 normsIG // normal_norm.
    case: (prim_trans_norm F11 F13) => Ksub; last first.
      by apply: dvdn_trans (cardSg F8); rewrite -F7; apply: atrans_dvd Ksub.
    have F14: [faithful Gx, on [set~ x] | 'P].
      apply/subsetP=> g; do 2![case/setIP] => Altg cgx cgx'.
      apply: (subsetP (aperm_faithful 'Alt_T)).
      rewrite inE Altg /=; apply/astabP=> z _.
      case: (z =P x) => [->|]; first exact: (astab1P cgx).
      by move/eqP=> nxz; rewrite (astabP cgx') ?inE //.
    have Hreg g (z : T): g \in H -> g z = z -> g = 1.
      have F15 h: h \in H -> h x = x -> h = 1.
        move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
        by rewrite (trivGP (subset_trans Ksub F14)) => /set1P.
      move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
      case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
      apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
      by case/normalP: Hh1 => _ nH1; rewrite -(nH1 _ Hg1) memJ_conjg.
    clear K F8 F12 F13 Ksub F14.
    case: (Cauchy _ F6) => // h Hh /eqP Horder.
    have diff_hnx_x n: 0 < n -> n < 5 -> x != (h ^+ n) x.
      move=> Hn1 Hn2; rewrite eq_sym; apply/negP => HH.
      have: #[h ^+ n] = 5.
        rewrite orderXgcd // (eqP Horder).
        by move: Hn1 Hn2 {HH}; do 5 (case: n => [|n] //).
      have Hhd2: h ^+ n \in H by rewrite groupX.
      by rewrite (Hreg _ _ Hhd2 (eqP HH)) order1.
    pose S1 := [tuple x; h x; (h ^+ 3) x].
    have DnS1: S1 \in 3.-dtuple(setT).
      rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
      rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
      by rewrite (inj_eq perm_inj) diff_hnx_x.
    pose S2 := [tuple x; h x; (h ^+ 2) x].
    have DnS2:  S2 \in 3.-dtuple(setT).
      rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
      rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
      by rewrite (inj_eq perm_inj) diff_hnx_x.
    case: (atransP2 F2 DnS1 DnS2) => g Hg [/=].
    rewrite /aperm => Hgx Hghx Hgh3x.
    have h_g_com: h * g = g * h.
      suff HH: (g * h * g^-1) * h^-1 = 1 by rewrite -[h * g]mul1g -HH !gnorm.
      apply: (Hreg _ x); last first.
        by rewrite !permM -Hgx Hghx -!permM mulKVg mulgV perm1.
      rewrite groupM // ?groupV // (conjgCV g) mulgK -mem_conjg.
      by case/normalP: Hh1 => _ ->.
    have: (g * (h ^+ 2) * g ^-1) x = (h ^+ 3) x.
      rewrite !permM -Hgx.
      have ->: h (h x) = (h ^+ 2) x by rewrite /= permM.
      by rewrite {1}Hgh3x -!permM /= mulgV mulg1 -expgSr.
    rewrite commuteX // mulgK {1}[expgn]lock expgS permM -lock.
    by move/perm_inj=> eqxhx; case/eqP: (diff_hnx_x 1%N isT isT); rewrite expg1.
  by rewrite (@Gauss_dvd 4 5) // F7.
apply/simpleP; split => [|H Hnorm]; first by rewrite trivg_card1 F1.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
  by left; apply: card1_trivg; rewrite Hcard1.
right; case Hcard60: (#|H| == 60%N); move/eqP: Hcard60 => Hcard60.
  by apply/eqP; rewrite eqEcard Hcard60 F1 andbT; case/andP: Hnorm.
have {Hcard1 Hcard60} Hcard20: #|H| = 20.
  have Hdiv: 20 %| #|H| by apply: FF => // HH; case Hcard1; rewrite HH cards1.
  case H20: (#|H| == 20); first exact/eqP.
  case: Hcard60; case/andP: Hnorm; move/cardSg; rewrite F1 => Hdiv1 _.
  by case/dvdnP: Hdiv H20 Hdiv1 => n ->; move: n; do 4!case=> //.
have prime_5: prime 5 by [].
have nSyl5: #|'Syl_5(H)| = 1%N.
  move: (card_Syl_dvd 5 H) (card_Syl_mod H prime_5).
  rewrite Hcard20; case: (card _) => // n Hdiv.
  move: (dvdn_leq  (isT: (0 < 20)%N) Hdiv).
  by move: (n) Hdiv; do 20 (case=> //).
case: (Sylow_exists 5 H) => S; case/pHallP=> sSH oS.
have{} oS: #|S| = 5 by rewrite oS p_part Hcard20.
suff: 20 %| #|S| by rewrite oS.
apply: FF => [|S1]; last by rewrite S1 cards1 in oS.
apply: char_normal_trans Hnorm; apply: lone_subgroup_char => // Q sQH isoQS.
rewrite subEproper; apply/norP=> [[nQS _]]; move: nSyl5.
rewrite (cardsD1 S) (cardsD1 Q) 4!{1}inE nQS !pHallE sQH sSH Hcard20 p_part.
by rewrite (card_isog isoQS) oS.
Qed.

Section Restrict.

Variables (T : finType) (x : T).
Notation T' := {y | y != x}.

Lemma rfd_funP (p : {perm T}) (u : T') :
  let p1 := if p x == x then p else 1 in p1 (val u) != x.
Proof.
case: (p x =P x) => /= [pxx | _]; last by rewrite perm1 (valP u).
by rewrite -[x in _ != x]pxx (inj_eq perm_inj); apply: (valP u).
Qed.

Definition rfd_fun p := [fun u => Sub ((_ : {perm T}) _) (rfd_funP p u) : T'].

Lemma rfdP p : injective (rfd_fun p).
Proof.
apply: can_inj (rfd_fun p^-1) _ => u; apply: val_inj => /=.
rewrite -(can_eq (permK p)) permKV eq_sym.
by case: eqP => _; rewrite !(perm1, permK).
Qed.

Definition rfd p := perm (@rfdP p).

Hypothesis card_T : 2 < #|T|.

Lemma rfd_morph : {in 'C_('Sym_T)[x | 'P] &, {morph rfd : y z / y * z}}.
Proof.
move=> p q; rewrite !setIA !setIid; move/astab1P=> p_x; move/astab1P=> q_x.
apply/permP=> u; apply: val_inj.
by rewrite permE /= !permM !permE /= [p x]p_x [q x]q_x eqxx permM /=.
Qed.

Canonical rfd_morphism := Morphism rfd_morph.

Definition rgd_fun (p : {perm T'}) :=
  [fun x1 => if insub x1 is Some u then sval (p u) else x].

Lemma rgdP p : injective (rgd_fun p).
Proof.
apply: can_inj (rgd_fun p^-1) _ => y /=.
case: (insubP _ y) => [u _ val_u|]; first by rewrite valK permK.
by rewrite negbK; move/eqP->; rewrite insubF //= eqxx.
Qed.

Definition rgd p := perm (@rgdP p).

Lemma rfd_odd (p : {perm T}) : p x = x -> rfd p = p :> bool.
Proof.
have rfd1: rfd 1 = 1.
  by apply/permP => u; apply: val_inj; rewrite permE /= if_same !perm1.
have [n] := ubnP #|[set x | p x != x]|; elim: n p => // n IHn p le_p_n px_x.
have [p_id | [x1 Hx1]] := set_0Vmem [set x | p x != x].
  suffices ->: p = 1 by rewrite rfd1 !odd_perm1.
  by apply/permP => z; apply: contraFeq (in_set0 z); rewrite perm1 -p_id inE.
have nx1x: x1 != x by apply: contraTneq Hx1 => ->; rewrite inE px_x eqxx.
have npxx1: p x != x1 by apply: contraNneq nx1x => <-; rewrite px_x.
have npx1x: p x1 != x by rewrite -px_x (inj_eq perm_inj).
pose p1 := p * tperm x1 (p x1).
have fix_p1 y: p y = y -> p1 y = y.
  by move=> pyy; rewrite permM; have [<-|/perm_inj<-|] := tpermP; rewrite ?pyy.
have p1x_x: p1 x = x by apply: fix_p1.
have{le_p_n} lt_p1_n: #|[set x | p1 x != x]| < n.
  move: le_p_n; rewrite ltnS (cardsD1 x1) Hx1; apply/leq_trans/subset_leq_card.
  rewrite subsetD1 inE permM tpermR eqxx andbT.
  by apply/subsetP=> y /[!inE]; apply: contraNneq=> /fix_p1->.
transitivity (p1 (+) true); last first.
  by rewrite odd_permM odd_tperm -Hx1 inE eq_sym addbK.
have ->: p = p1 * tperm x1 (p x1) by rewrite -tpermV mulgK.
rewrite morphM; last 2 first; first by rewrite 2!inE; apply/astab1P.
  by rewrite 2!inE; apply/astab1P; rewrite -[RHS]p1x_x permM px_x.
rewrite odd_permM IHn //=; congr (_ (+) _).
pose x2 : T' := Sub x1 nx1x; pose px2 : T' := Sub (p x1) npx1x.
suffices ->: rfd (tperm x1 (p x1)) = tperm x2 px2.
  by rewrite odd_tperm eq_sym; rewrite inE in Hx1.
apply/permP => z; apply/val_eqP; rewrite permE /= tpermD // eqxx.
by rewrite !permE /= -!val_eqE /= !(fun_if sval) /=.
Qed.

Lemma rfd_iso : 'C_('Alt_T)[x | 'P] \isog 'Alt_T'.
Proof.
have rgd_x p: rgd p x = x by rewrite permE /= insubF //= eqxx.
have rfd_rgd p: rfd (rgd p) = p.
  apply/permP => [[z Hz]]; apply/val_eqP; rewrite !permE.
  by rewrite /= [rgd _ _]permE /= insubF eqxx // permE /= insubT.
have sSd: 'C_('Alt_T)[x | 'P] \subset 'dom rfd.
  by apply/subsetP=> p /[!inE]/= /andP[].
apply/isogP; exists [morphism of restrm sSd rfd] => /=; last first.
  rewrite morphim_restrm setIid; apply/setP=> z; apply/morphimP/idP=> [[p _]|].
    case/setIP; rewrite Alt_even => Hp; move/astab1P=> Hp1 ->.
    by rewrite Alt_even rfd_odd.
  have dz': rgd z x == x by rewrite rgd_x.
  move=> kz; exists (rgd z); last by rewrite /= rfd_rgd.
    by rewrite 2!inE (sameP astab1P eqP).
  rewrite 4!inE /= (sameP astab1P eqP) dz' -rfd_odd; last exact/eqP.
  by rewrite rfd_rgd mker // ?set11.
apply/injmP=> x1 y1 /=.
case/setIP=> Hax1; move/astab1P; rewrite /= /aperm => Hx1.
case/setIP=> Hay1; move/astab1P; rewrite /= /aperm => Hy1 Hr.
apply/permP => z.
case (z =P x) => [->|]; [by rewrite Hx1 | move/eqP => nzx].
move: (congr1 (fun q : {perm T'} => q (Sub z nzx)) Hr).
by rewrite !permE => [[]]; rewrite Hx1 Hy1 !eqxx.
Qed.

End Restrict.

Lemma simple_Alt5 (T : finType) : #|T| >= 5 -> simple 'Alt_T.
Proof.
suff F1 n: #|T| = n + 5 -> simple 'Alt_T by move/subnK/esym/F1.
elim: n T => [| n Hrec T Hde]; first exact: simple_Alt5_base.
have oT: 5 < #|T| by rewrite Hde addnC.
apply/simpleP; split=> [|H Hnorm]; last have [Hh1 nH] := andP Hnorm.
  rewrite trivg_card1 -[#|_|]half_double -mul2n card_Alt Hde addnC //.
  by rewrite addSn factS mulnC -(prednK (fact_gt0 _)).
case E1: (pred0b T); first by rewrite /pred0b in E1; rewrite (eqP E1) in oT.
case/pred0Pn: E1 => x _; have Hx := in_setT x.
have F2: [transitive^4 'Alt_T, on setT | 'P].
  by apply: ntransitive_weak (Alt_trans T); rewrite -(subnKC oT).
have F3 := ntransitive1 (isT: 0 < 4) F2.
have F4 := ntransitive_primitive (isT: 1 < 4) F2.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
  by left; apply: card1_trivg; rewrite Hcard1.
right; case: (prim_trans_norm F4 Hnorm) => F5.
  by rewrite (trivGP (subset_trans F5 (aperm_faithful _))) cards1 in Hcard1.
case E1: (pred0b (predD1 T x)).
  rewrite /pred0b in E1; move: oT.
  by rewrite (cardD1 x) (eqP E1); case: (T x).
case/pred0Pn: E1 => y Hdy; case/andP: (Hdy) => diff_x_y Hy.
pose K := 'C_H[x | 'P]%G.
have F8: K \subset H by apply: subsetIl.
pose Gx := 'C_('Alt_T)[x | 'P].
have F9: [transitive^3 Gx, on [set~ x] | 'P].
  by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
have F10: [transitive Gx, on [set~ x] | 'P].
  by apply: ntransitive1 F9.
have F11: [primitive Gx, on [set~ x] | 'P].
  by apply: ntransitive_primitive F9.
have F12: K \subset Gx by rewrite setSI // normal_sub.
have F13: K <| Gx by apply/andP; rewrite normsIG.
have:= prim_trans_norm F11; case/(_ K) => //= => Ksub; last first.
  have F14: Gx * H = 'Alt_T by apply/(subgroup_transitiveP _ _ F3).
  have: simple Gx.
    by rewrite (isog_simple (rfd_iso x)) Hrec //= card_sig cardC1 Hde.
  case/simpleP=> _ simGx; case/simGx: F13 => /= HH2.
    case Ez: (pred0b (predD1 (predD1 T x) y)).
      move: oT; rewrite /pred0b in Ez.
      by rewrite (cardD1 x) (cardD1 y) (eqP Ez) inE /= inE /= diff_x_y.
    case/pred0Pn: Ez => z; case/andP => diff_y_z Hdz.
    have [diff_x_z Hz] := andP Hdz.
    have: z \in [set~ x] by rewrite !inE.
    rewrite -(atransP Ksub y) ?inE //; case/imsetP => g.
    rewrite /= HH2 inE; move/eqP=> -> HH4.
    by case/negP: diff_y_z; rewrite HH4 act1.
  by rewrite /= -F14 -[Gx]HH2 (mulSGid F8).
have F14: [faithful Gx, on [set~ x] | 'P].
  apply: subset_trans (aperm_faithful 'Sym_T); rewrite subsetI subsetT.
  apply/subsetP=> g; do 2![case/setIP]=> _ cgx cgx'; apply/astabP=> z _ /=.
  case: (z =P x) => [->|]; first exact: (astab1P cgx).
  by move/eqP=> zx; rewrite [_ g](astabP cgx') ?inE.
have Hreg g z: g \in H -> g z = z -> g = 1.
  have F15 h: h \in H -> h x = x -> h = 1.
    move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
    by rewrite [K](trivGP (subset_trans Ksub F14)) => /set1P.
  move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
  case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
  apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
  by rewrite memJ_norm ?(subsetP nH).
clear K F8 F12 F13 Ksub F14.
have Hcard: 5 < #|H|.
  apply: (leq_trans oT); apply: dvdn_leq; first exact: cardG_gt0.
  by rewrite -cardsT (atrans_dvd F5).
case Eh: (pred0b [predD1 H & 1]).
  by move: Hcard; rewrite /pred0b in Eh; rewrite (cardD1 1) group1 (eqP Eh).
case/pred0Pn: Eh => h; case/andP => diff_1_h /= Hh.
case Eg: (pred0b (predD1 (predD1 [predD1 H & 1] h) h^-1)).
  move: Hcard; rewrite ltnNge; case/negP.
  rewrite (cardD1 1) group1 (cardD1 h) (cardD1 h^-1) (eqnP Eg).
  by do 2!case: (_ \in _).
case/pred0Pn: Eg => g; case/andP => diff_h1_g; case/andP => diff_h_g.
case/andP => diff_1_g /= Hg.
case diff_hx_x: (h x == x).
by case/negP: diff_1_h; apply/eqP; apply: (Hreg _ _ Hh (eqP diff_hx_x)).
case diff_gx_x: (g x == x).
  case/negP: diff_1_g; apply/eqP; apply: (Hreg _ _ Hg (eqP diff_gx_x)).
case diff_gx_hx: (g x == h x).
  case/negP: diff_h_g; apply/eqP; symmetry; apply: (mulIg g^-1); rewrite gsimp.
  apply: (Hreg _ x); first by rewrite groupM // groupV.
  by rewrite permM -(eqP diff_gx_hx) -permM mulgV perm1.
case diff_hgx_x: ((h * g) x == x).
  case/negP: diff_h1_g; apply/eqP; apply: (mulgI h); rewrite !gsimp.
  by apply: (Hreg _ x); [apply: groupM | apply/eqP].
case diff_hgx_hx: ((h * g) x == h x).
  case/negP: diff_1_g; apply/eqP.
  by apply: (Hreg _ (h x)) => //; apply/eqP; rewrite -permM.
case diff_hgx_gx: ((h * g) x == g x).
  by case/idP: diff_hx_x; rewrite -(can_eq (permK g)) -permM.
case Ez: (pred0b
            (predD1 (predD1 (predD1 (predD1 T x) (h x)) (g x)) ((h * g) x))).
- move: oT; rewrite /pred0b in Ez.
  rewrite (cardD1 x) (cardD1 (h x)) (cardD1 (g x)) (cardD1 ((h * g) x)).
  by rewrite (eqP Ez) addnC; do 3!case: (_ x \in _).
case/pred0Pn: Ez => z.
case/and5P=> diff_hgx_z diff_gx_z diff_hx_z diff_x_z /= Hz.
pose S1 := [tuple x; h x; g x; z].
have DnS1: S1 \in 4.-dtuple(setT).
  rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT.
  rewrite -!(eq_sym z) diff_gx_z diff_x_z diff_hx_z.
  by rewrite !(eq_sym x) diff_hx_x diff_gx_x eq_sym diff_gx_hx.
pose S2 := [tuple x; h x; g x; (h * g) x].
have DnS2: S2 \in 4.-dtuple(setT).
  rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT !(eq_sym x).
  rewrite diff_hx_x diff_gx_x diff_hgx_x.
  by rewrite !(eq_sym (h x)) diff_gx_hx diff_hgx_hx eq_sym diff_hgx_gx.
case: (atransP2 F2 DnS1 DnS2) => k Hk [/=].
rewrite /aperm => Hkx Hkhx Hkgx Hkhgx.
have h_k_com: h * k = k * h.
  suff HH: (k * h * k^-1) * h^-1 = 1 by rewrite -[h * k]mul1g -HH !gnorm.
  apply: (Hreg _ x); last first.
    by rewrite !permM -Hkx Hkhx -!permM mulKVg mulgV perm1.
  by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have g_k_com: g * k = k * g.
  suff HH: (k * g * k^-1) * g^-1 = 1 by rewrite -[g * k]mul1g -HH !gnorm.
  apply: (Hreg _ x); last first.
    by rewrite !permM -Hkx Hkgx -!permM mulKVg mulgV perm1.
  by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have HH: (k * (h * g) * k ^-1) x = z.
   by rewrite 2!permM -Hkx Hkhgx -permM mulgV perm1.
case/negP: diff_hgx_z.
rewrite -HH !mulgA -h_k_com -!mulgA [k * _]mulgA.
by rewrite -g_k_com -!mulgA mulgV mulg1.
Qed.


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

Set Implicit Arguments.

Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
Unset Universe Minimization ToSet.

Reserved Notation "x =m= y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x =m= y" (at level 70, no associativity).

(** * First-order quantifiers *)

(** [ex P], or simply [exists x, P x], or also [exists x:A, P x],
    expresses the existence of an [x] of some type [A] in [Set] which
    satisfies the predicate [P].  This is existential quantification.

    [ex2 P Q], or simply [exists2 x, P x & Q x], or also
    [exists2 x:A, P x & Q x], expresses the existence of an [x] of
    type [A] which satisfies both predicates [P] and [Q].

    Universal quantification is primitively written [forall x:A, Q]. By
    symmetry with existential quantification, the construction [all P]
    is provided too.
*)

Inductive mex (A:Type) (P:A -> Prop) : Prop :=
  mex_intro : forall x:A, P x -> mex (A:=A) P.

(** * Equality *)

(** [eq x y], or simply [x=y] expresses the equality of [x] and
    [y]. Both [x] and [y] must belong to the same type [A].
    The definition is inductive and states the reflexivity of the equality.
    The others properties (symmetry, transitivity, replacement of
    equals by equals) are proved below. The type of [x] and [y] can be
    made explicit using the notation [x = y :> A]. This is Leibniz equality
    as it expresses that [x] and [y] are equal iff every property on
    [A] which is true of [x] is also true of [y] *)

Inductive meq (A:Type) (x:A) : A -> Prop :=
     meq_refl : x =m= x :>A
where "x =m= y :> A" := (@meq A x y) : type_scope.

Notation "x =m= y" := (x =m= y :>_) : type_scope.

Arguments meq {A} x _.
Arguments meq_refl {A x} , [A] x.

Arguments meq_ind [A] x P _ y _ : rename.
Arguments meq_rec [A] x P _ y _ : rename.
Arguments meq_rect [A] x P _ y _ : rename.

(* Section Logic_lemmas. *)

Section equality.
  Variables A : Type.
  Variables x y z : A.

  Theorem meq_sym : x =m= y -> y =m= x.
  Proof.
    destruct 1; reflexivity.
  Defined.

  Theorem meq_trans : x =m= y -> y =m= z -> x =m= z.
  Proof.
    destruct 2; trivial.
  Defined.

  Variable B : Type.
  Variable f : A -> B.
  Theorem mf_equal : x =m= y -> f x =m= f y.
  Proof.
    destruct 1; reflexivity.
  Defined.
End equality.

  Definition meq_ind_r :
    forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y =m= x -> P y.
    intros A x P H y H0. elim meq_sym with (1 := H0); assumption.
  Defined.

  Definition meq_rec_r :
    forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y =m= x -> P y.
    intros A x P H y H0; elim meq_sym with (1 := H0); assumption.
  Defined.

  Definition meq_rect_r :
    forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y =m= x -> P y.
    intros A x P H y H0; elim meq_sym with (1 := H0); assumption.
  Defined.
(* End Logic_lemmas. *)

(* Module EqNotations. *)
(*   Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H) *)
(*     (at level 10, H' at level 10, *)
(*      format "'[' 'rew'  H  in  '/' H' ']'"). *)
(*   Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H) *)
(*     (at level 10, H' at level 10, *)
(*      format "'[' 'rew'  [ P ]  '/    ' H  in  '/' H' ']'"). *)
(*   Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H) *)
(*     (at level 10, H' at level 10, *)
(*      format "'[' 'rew'  <-  H  in  '/' H' ']'"). *)
(*   Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H) *)
(*     (at level 10, H' at level 10, *)
(*      format "'[' 'rew'  <-  [ P ]  '/    ' H  in  '/' H' ']'"). *)
(*   Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H) *)
(*     (at level 10, H' at level 10, only parsing). *)
(*   Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H) *)
(*     (at level 10, H' at level 10, only parsing). *)

(* End EqNotations. *)

(* Import EqNotations. *)

(* Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. *)
(* Proof. *)
(* intros. *)
(* destruct H. *)
(* reflexivity. *)
(* Defined. *)

(* Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a. *)
(* Proof. *)
(* intros. *)
(* destruct H. *)
(* reflexivity. *)
(* Defined. *)

(* Theorem f_equal2 : *)
(*   forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1) *)
(*     (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2. *)
(* Proof. *)
(*   destruct 1; destruct 1; reflexivity. *)
(* Qed. *)

(* Theorem f_equal3 : *)
(*   forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) *)
(*     (x2 y2:A2) (x3 y3:A3), *)
(*     x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3. *)
(* Proof. *)
(*   destruct 1; destruct 1; destruct 1; reflexivity. *)
(* Qed. *)

(* Theorem f_equal4 : *)
(*   forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B) *)
(*     (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4), *)
(*     x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4. *)
(* Proof. *)
(*   destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. *)
(* Qed. *)

(* Theorem f_equal5 : *)
(*   forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B) *)
(*     (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5), *)
(*     x1 = y1 -> *)
(*     x2 = y2 -> *)
(*     x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5. *)
(* Proof. *)
(*   destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. *)
(* Qed. *)

(* Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b), *)
(*   f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e. *)
(* Proof. *)
(*   destruct e. reflexivity. *)
(* Defined. *)

(* (** The goupoid structure of equality *) *)

(* Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. *)
(* Proof. *)
(*   destruct e. reflexivity. *)
(* Defined. *)

(* Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e. *)
(* Proof. *)
(*   destruct e. reflexivity. *)
(* Defined. *)

(* Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e. *)
(* Proof. *)
(*   destruct e; reflexivity. *)
(* Defined. *)

(* Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl. *)
(* Proof. *)
(*   destruct e; reflexivity. *)
(* Defined. *)

(* Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl. *)
(* Proof. *)
(*   destruct e; reflexivity. *)
(* Defined. *)

(* Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t), *)
(*   eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''. *)
(* Proof. *)
(*   destruct e''; reflexivity. *)
(* Defined. *)

(* (** Extra properties of equality *) *)

(* Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a). *)
(* Proof. *)
(*   intros. *)
(*   unfold f_equal. *)
(*   rewrite <- (eq_trans_sym_inv_l (Hf a)). *)
(*   destruct (Hf a) at 1 2. *)
(*   destruct (Hf a). *)
(*   reflexivity. *)
(* Defined. *)

(* Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a). *)
(* Proof. *)
(*   intros. *)
(*   unfold f_equal. *)
(*   rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))). *)
(*   set (Hfsymf := fun a => eq_sym (Hf a)). *)
(*   change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))). *)
(*   pattern (Hfsymf (f (f a))). *)
(*   destruct (eq_id_comm_l f Hfsymf (f a)). *)
(*   destruct (eq_id_comm_l f Hfsymf a). *)
(*   unfold Hfsymf. *)
(*   destruct (Hf a). simpl. *)
(*   rewrite eq_trans_refl_l. *)
(*   reflexivity. *)
(* Defined. *)

(* Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

(* Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). *)
(* Proof. *)
(* destruct e'. *)
(* reflexivity. *)
(* Defined. *)

(* Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e). *)
(* Proof. *)
(* destruct e. *)
(* reflexivity. *)
(* Defined. *)

(* Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). *)
(* Proof. *)
(* destruct e, e'. *)
(* reflexivity. *)
(* Defined. *)

(* Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), *)
(*     rew (eq_trans e e') in k = rew e' in rew e in k. *)
(* Proof. *)
(*   destruct e, e'; reflexivity. *)
(* Qed. *)

(* Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), *)
(*     rew [fun _ => P] e in k = k. *)
(* Proof. *)
(*   destruct e; reflexivity. *)
(* Qed. *)


(* ======================== *)
(* ===== CH00_knuth.v ===== *)
(* ======================== *)
Require Import Jordan2.

Module Type KnuthAxioms.

Parameter point : Set.

Parameter ccw : point -> point -> point -> Prop.

Parameter align : point  -> point -> point -> Prop.

Axiom ccw_axiom_1 : forall (p q r : point),
  ccw p q r -> ccw q r p.

Axiom ccw_axiom_2 : forall (p q r : point),
  ccw p q r -> ~ ccw p r q.

Axiom ccw_axiom_3 : forall (p q r : point),
  ~ align p q r -> (ccw p q r) \/ (ccw p r q).

Axiom ccw_axiom_4 : forall (p q r t : point),
  (ccw t q r) -> (ccw p t r) -> (ccw p q t) -> (ccw p q r).

Axiom ccw_axiom_5 : forall (p q r s t : point),
  (ccw t s p) -> (ccw t s q) -> (ccw t s r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).

Axiom ccw_axiom_5_bis : forall (p q r s t : point),
  (ccw s t p) -> (ccw s t q) -> (ccw s t r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).

End KnuthAxioms.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Module ModelOfKnuth <: KnuthAxioms.

Open Scope R_scope.

Definition point := point.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Definition det (p q r : point) : R :=
  (fst p * snd q) - (fst q * snd p) - (fst p * snd r) + (fst r * snd p) +
  (fst q * snd r) - (fst r * snd q).

Lemma eq_det : forall (p q r : point),
  det p q r = det q r p.
Proof.
intros p q r.
unfold det; ring.
Qed.

Lemma neq_det : forall (p q r : point),
  det p q r = - det p r q.
Proof.
intros p q r.
unfold det; ring.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Definition ccw (p q r : point) : Prop :=
  (det p q r > 0).

Lemma ccw_dec : forall (p q r : point),
  {ccw p q r} + {~ ccw p q r}.
Proof.
intros p q r.
unfold ccw; apply Rgt_dec.
Qed.

(* ======= ####### ======= *)

Definition align (p q r : point) : Prop :=
  (det p q r = 0).

Lemma align_dec : forall (p q r : point),
  {align p q r} + {~align p q r}.
Proof.
intros p q r.
unfold align.
generalize (total_order_T (det p q r) 0).
generalize (Rlt_dichotomy_converse (det p q r) 0).
tauto.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma Rle_neq_lt : forall (r1 r2 : R),
  r1 <= r2 -> r1 <> r2 -> r1 < r2.
Proof.
intros r1 r2 H1 H2.
elim (Rdichotomy r1 r2).
trivial.
generalize (Rle_not_lt r2 r1).
tauto.
assumption.
Qed.

Lemma R_gt_0_plus : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 + r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply Rgt_trans with r1.
 pattern r1 at 2; rewrite <- (Rplus_0_r r1).
 apply Rplus_gt_compat_l; assumption.
assumption.
Qed.

Lemma R_gt_0_mult : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof.
apply Rmult_gt_0_compat.
Qed.

Lemma R_gt_0_div : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 * / r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply R_gt_0_mult.
 assumption.
 unfold Rgt in *; auto with real.
Qed.

Lemma R_mult_div : forall (r1 r2 r3 : R),
  r1 = r2 * r3 -> r2 > 0 -> r1 * / r2 = r3.
Proof.
intros r1 r2 r3 H1 H2.
subst r1; auto with real.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma axiom_orientation_1 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ccw B C A.
Proof.
intros A B C.
unfold ccw; rewrite eq_det; trivial.
Qed.

Lemma axiom_orientation_2 :
  forall (A:point)(B:point)(C:point),
  align A B C -> align B C A.
Proof.
intros A B C.
unfold align; rewrite eq_det; trivial.
Qed.

Lemma axiom_orientation_3 :
  forall (A:point)(B:point)(C:point),
  align A B C -> align A C B.
Proof.
intros A B C.
unfold align; rewrite neq_det.
generalize (Rplus_opp_r (det A C B)).
generalize (Rplus_0_l (det A C B)).
intros H1 H2 H3.
rewrite H3 in H2; clear H3.
rewrite Rplus_comm in H1.
rewrite H1 in H2; clear H1.
assumption.
Qed.

Hint Resolve axiom_orientation_1 axiom_orientation_2 axiom_orientation_3 : myorientation.

(* ======================= *)

Lemma axiom_orientation_4 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ~ ccw A C B.
Proof.
intros A B C.
unfold ccw; rewrite neq_det.
generalize (Ropp_gt_lt_contravar (- det A C B) 0).
rewrite Ropp_involutive; rewrite Ropp_0.
intro H1; generalize (Rlt_le (det A C B) 0).
intro H2; generalize (Rle_not_lt 0 (det A C B)).
intro H3; tauto.
Qed.

Lemma axiom_orientation_5 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ~ align A B C.
Proof.
intros A B C.
unfold ccw, align in *.
apply Rgt_not_eq; assumption.
Qed.

Lemma axiom_orientation_6 :
  forall (A:point)(B:point)(C:point),
  align A B C -> ~ ccw A B C.
Proof.
intros A B C.
unfold ccw, align in *.
intro H1; rewrite H1.
unfold not; intro H2.
apply Rgt_not_eq in H2; tauto.
Qed.

Hint Resolve axiom_orientation_4 axiom_orientation_5 axiom_orientation_6 : myorientation.

(* ======================= *)

Lemma axiom_orientation_7 :
  forall (A:point)(B:point)(C:point),
  ~ ccw A B C -> ccw A C B \/ align A B C.
Proof.
intros A B C H.
elim (ccw_dec A C B).
 intro H1; left; assumption.
 intro H1; right.
 unfold ccw, align in *.
 rewrite neq_det in H1.
 apply Rle_antisym.
  apply Rnot_gt_le; assumption.
  apply Rnot_gt_le; auto with real.
Qed.

Lemma axiom_orientation_8 :
  forall (A:point)(B:point)(C:point),
  ~ align A B C -> ccw A B C \/ ccw A C B.
Proof.
intros A B C H.
elim (ccw_dec A B C).
 intro H0; left; assumption.
 intro H0; right.
 apply axiom_orientation_7 in H0.
 elim H0; [trivial|contradiction].
Qed.

Hint Resolve axiom_orientation_7 axiom_orientation_8 : myorientation.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma ccw_axiom_1 : forall (p q r : point),
  ccw p q r -> ccw q r p.
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_2 : forall (p q r : point),
  ccw p q r -> ~ ccw p r q.
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_3 : forall (p q r : point),
  ~ align p q r -> (ccw p q r) \/ (ccw p r q).
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_4 : forall (p q r t : point),
  (ccw t q r) -> (ccw p t r) -> (ccw p q t) -> (ccw p q r).
Proof.
intros p q r t H1 H2 H3.
unfold ccw in *.
assert (det t q r + det p t r + det p q t = det p q r).
unfold det; ring.
rewrite <- H.
apply R_gt_0_plus; [apply R_gt_0_plus; assumption | assumption].
Qed.

Lemma ccw_axiom_5 : forall (p q r s t : point),
  (ccw t s p) -> (ccw t s q) -> (ccw t s r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).
Proof.
intros p q r s t H1 H2 H3 H4 H5.
unfold ccw in *.
replace (det t p r) with ((det t p q * det t s r + det t q r * det t s p) * / (det t s q)).
apply R_gt_0_div.
 apply R_gt_0_plus.
  apply R_gt_0_mult; assumption.
  apply R_gt_0_mult; assumption.
 assumption.
apply R_mult_div.
 unfold det; ring.
 assumption.
Qed.

Lemma ccw_axiom_5_bis : forall (p q r s t : point),
  (ccw s t p) -> (ccw s t q) -> (ccw s t r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).
Proof.
intros p q r s t H1 H2 H3 H4 H5.
unfold ccw in *.
replace (det t p r) with ((det t p q * det s t r + det t q r * det s t p) * / (det s t q)).
apply R_gt_0_div.
 apply R_gt_0_plus.
  apply R_gt_0_mult; assumption.
  apply R_gt_0_mult; assumption.
 assumption.
apply R_mult_div.
 unfold det; ring.
 assumption.
Qed.

End ModelOfKnuth.


Require Export Iron.Language.SystemF2Data.Type.Exp.
Require Export Iron.Language.SystemF2Data.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Data.Type.Operator.SubstTT.

(* Type Enviroments *)
Definition tyenv := list ty.
Hint Unfold tyenv.

(* Lift type indices in type environments. *)
Definition liftTE d te    := map (liftTT 1 d) te.
Hint Unfold liftTE.

(* Substitution of types in type environments. *)
Definition substTE d t te := map (substTT d t) te.
Hint Unfold substTE.

(********************************************************************)
Lemma length_liftTE
 :  forall d te
 ,  length te = length (liftTE d te).
Proof.
 induction te; burn.
Qed.

(********************************************************************)
Lemma liftTE_liftTE
 :  forall n n' te
 ,  liftTE n              (liftTE (n + n') te)
 =  liftTE (1 + (n + n')) (liftTE n te).
Proof.
 intros. induction te; rip.
 - unfold liftTE.
   snorm.
   rewrite liftTT_liftTT_11.
   snorm.
   f_equal.
   unfold liftTE in IHte. auto.
Qed.

Lemma substTE_liftTE
 :  forall d te t2
 ,  substTE d t2 (liftTE d te) = te.
Proof.
 intros.
 unfold substTE. unfold liftTE.
 lists.
 induction te; simpl; burn.
Qed.

Lemma liftTE_substTE
 :  forall n n' t2 te
 ,  liftTE n (substTE (n + n') t2 te)
 =  substTE (1 + n + n') (liftTT 1 n t2) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold substTE. unfold liftTE.
   simpl. rewrite liftTT_substTT.
   unfold liftTE  in IHte.
   unfold substTE in IHte. rewrite IHte. auto.
Qed.

Lemma liftTE_closedT_id
 :  forall n se
 ,  Forall closedT se
 -> liftTE n se = se.
Proof.
 intros.
 unfold liftTE.
 induction se; rip.
Qed.
Hint Resolve liftTE_closedT_id.

Lemma substTE_closedT_id
 :  forall n t2 se
 ,  Forall closedT se
 -> substTE n t2 se = se.
Proof.
 intros.
 unfold substTE.
 induction se; rip.
Qed.
Hint Resolve substTE_closedT_id.


Require Import List.
Require Import utils.ListUtils.

Lemma concat_map_incl:
  forall (T1 T2: Type) (a: T1) (l: list T1) (f: T1-> (list T2)),
    (In a l) -> incl (f a) (concat (map f l)).
Proof.
  intros.
  induction l.
  - inversion H.
  - destruct H.
    + simpl.
      rewrite H.
      apply incl_appl.
      apply incl_refl.
    + simpl.
      apply IHl in H.
      apply incl_appr.
      exact H.
Qed.

Lemma concat_in:
  forall (T: Type) (el: T) (l0 : list T) (l1 : list (list T)),
    In el l0 -> In l0 l1 -> In el (concat l1).
Proof.
  intros.
  induction l1.
  - inversion H0.
  - simpl.
    simpl in H0.
    apply in_or_app.
    destruct H0.
    + left. rewrite H0. assumption.
    + right. apply IHl1. assumption.
Qed.

Lemma concat_map_option_incl:
  forall (T1 T2: Type) (a: T1) (l: list T1) (f: T1 -> option (list T2)) (lt: list T2),
    (In a l) -> (f a) = Some lt ->
    incl lt (concat (optionList2List (map f l))).
Proof.
  intros.
  induction l.
  - inversion H.
  - destruct H.
    + simpl. rewrite H. rewrite H0.
      simpl. apply incl_appl. apply incl_refl.
    + simpl. rewrite concat_app. apply incl_appr.
      apply IHl. assumption.
Qed.

Lemma concat_incl :
  forall (A: Type) (a: list A) (b: list A) (c: list (list A)),
    incl a b -> In b c -> incl a (concat c).
Proof.
  intros.
  induction c.
  - inversion H0.
  - simpl. simpl in H0.
    destruct H0.
    * apply incl_appl. rewrite H0. assumption.
    * apply incl_appr. apply IHc. apply H0.
Qed.

Lemma concat_exists :
  forall (T : Type) (a : T) (l : list (list T)),
    In a (concat l) -> (exists (la : list T), In la l /\ In a la).
Proof.
  intros.
  apply in_flat_map.
  rewrite flat_map_concat_map.
  rewrite map_id.
  assumption.
Qed.

Lemma concat_map_exists :
  forall (T1 T2: Type) (b : T2) (l : list T1) (f : T1 -> list T2),
    In b (concat (map f l)) -> (exists (a : T1), In a l /\ In b (f a)).
Proof.
  intros.
  apply in_flat_map.
  rewrite flat_map_concat_map.
  assumption.
Qed.

Lemma concat_map_option_exists :
  forall (T1 T2: Type) (b : T2)
    (l : list T1) (f : T1 -> option (list T2)),
    In b (concat (optionList2List (map f l))) ->
    (exists (a : T1), In a l /\
                 (match (f a) with
                  | None => False
                  | Some lst => In b lst
                  end)
    ).
Proof.
  intros.
  apply concat_exists in H.
  destruct H as [l2 [H H0]].
  induction l.
  - inversion H.
  - simpl in H. apply in_app_or in H. destruct H.
    + destruct (f a) eqn: fa.
      * exists a. split.
        -- left. reflexivity.
        -- rewrite fa. destruct H as [H|[]]. rewrite H. exact H0.
      * inversion H.
    + apply IHl in H. destruct H as [x [H H']].
      exists x. split.
      * right. apply H.
      * apply H'.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                                mesure.v                                  *)
(****************************************************************************)

Section mesure.

Require Export white_card.
Require Export grey_card.

Notation Card := (card _ _) (only parsing).

Inductive mesure (m : marking) : nat -> Prop :=
    mesur :
      forall w g : nat,
      card_color grey m g -> card_color white m w -> mesure m (g + w).

Lemma init_mesure : forall s : state, init_state s -> mesure (mk s) 0.

intros s init_state; replace 0 with (0 + 0); auto with arith.
constructor; eauto.
Qed.

Hint Resolve init_mesure.

Lemma init_ex_mesure :
 forall s : state, init_state s -> exists nb : nat, mesure (mk s) nb.

intros s init_state; exists 0; eauto.
Qed.

Lemma add_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> add_edge s t -> mesure (mk t) nb.

intros s t nb mes_s add; elim add; clear add.
intros n m accsn accsm cts ctt add mark; unfold marking_add in mark;
 elim mark; clear mark.
intro cas1; elim cas1; clear cas1.
intros mksn eqmk; rewrite eqmk; assumption.
intro cas; elim cas; clear cas.
intro cas2; elim cas2; clear cas2.
intros mksn eqmk; elim eqmk; clear eqmk.
intros mksm eqmk; rewrite eqmk; assumption.
intro cas3; elim cas3; clear cas3.
intros mksn mk2; elim mk2; clear mk2.
intros mksm updcol; inversion mes_s; elim (eq_nat_dec w 0).
intro weqO; absurd (card_color white (mk s) 0).
intro cards; inversion cards; absurd (mk s m = white); auto.
rewrite <- weqO; assumption.
intro wdifO; replace (g + w) with (S g + pred w).
elim updcol; clear updcol.
intros mkeq mktm; apply (mesur (mk t)); unfold card_color in |- *.
apply card_S with (M1 := mk s) (a0 := m); auto.
rewrite mksm; discriminate.
apply card_rem with (M1 := mk s) (a0 := m); auto.
rewrite mktm; discriminate.
rewrite (plus_S_pred g w); auto.
Qed.

Hint Resolve add_mesure.

Lemma add_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 add_edge s t -> exists nb : nat, mesure (mk t) nb.

intros s t H addedge; elim H; clear H.
intros nb H_mes; exists nb; eauto.
Qed.

Hint Resolve add_ex_mesure.

Lemma remove_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> remove_edge s t -> mesure (mk t) nb.

intros s t nb mes_s removeedge; elim removeedge; clear removeedge.
intros n m accsn accsm cts ctt remove mkeq; rewrite mkeq; assumption.
Qed.

Hint Resolve remove_mesure.

Lemma remove_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 remove_edge s t -> exists nb : nat, mesure (mk t) nb.

intros s t H removeedge; elim H; clear H.
intros nb H_mes; exists nb; eauto.
Qed.

Hint Resolve remove_ex_mesure.

Lemma alloc_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> alloc s t -> mesure (mk t) nb.

intros s t nb mes_s alloc; inversion mes_s; apply (mesur (mk t)); eauto.
Qed.

Hint Resolve alloc_mesure.

Lemma alloc_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 alloc s t -> exists nb : nat, mesure (mk t) nb.

intros s t H alloc; elim H; clear H.
intros nb H_mes; exists nb; eauto.
Qed.

Hint Resolve alloc_ex_mesure.

Lemma gccall_mesure :
 forall (s t : state) (nb : nat),
 gc_call s t ->
 mesure (mk s) 0 \/ (mesure (mk s) nb -> nb <> 0 /\ mesure (mk t) (pred nb)).

intros s t nb gccall; elim gccall; clear gccall.
intros ctls ctlt heap H_mark init; left; replace 0 with (0 + 0); auto.
apply (mesur (mk s)); constructor; intro n; elim (H_mark n); intro mksn;
 rewrite mksn; discriminate.
intros ctls ctlt heap greynode; elim greynode; clear greynode.
intros g mksg mktg H_col1 H_col2; right; intro mes_s; split.
intro nbeq0; rewrite nbeq0 in mes_s; inversion mes_s.
cut (g0 = 0).
intro g0eq0; rewrite g0eq0 in H0; inversion H0; absurd (mk s g = grey); auto.
rewrite (plus_comm g0 w) in H; apply (plus_O_O w g0); auto.
inversion mes_s; clear mes_s.
cut
 (exists M : node -> bool * color,
    (forall n : node, M n = (hp s g n, mk s n))).
intro H2; elim H2; clear H2.
intros M H_M.
cut
 (exists nb : nat,
    card _ _
      (fun p : bool * color =>
       match p with
       | (b, c) => b = true /\ c = white
       end) M nb /\ nb <= w).
intro H2; elim H2; clear H2.
intros nbsons H_nbsons; elim H_nbsons; clear H_nbsons.
intros H_cardsons le_nbsons_w.
cut (card_sons g white (mk s) (hp s) nbsons).
intro card_sons.
rewrite (pred_plus_minus nbsons g0 w); auto.
apply (mesur (mk t)).
apply
 card_grey_marknode with (n0 := g) (m1 := mk s) (h1 := hp s) (h2 := hp t);
 auto.
rewrite mktg; discriminate.
constructor; auto.
rewrite heap; auto.
apply
 card_white_marknode
  with (m1 := mk s) (h1 := hp s) (h2 := hp t) (nb := nbsons) (n0 := g);
 auto.
constructor; auto.
rewrite heap; auto.
intro g0eq0; rewrite g0eq0 in H; inversion H; absurd (mk s g = grey); auto.
apply CS with (M := M); auto.
unfold card_color in H0.
apply
 include_card_bis
  with (P := fun c : color => c = white) (M := mk s) (nb := w);
 auto.
exists (hp s rt g, mk s g).
intro H2; elim H2; clear H2.
intros hrtg mksg2; absurd (mk s g = white); auto.
rewrite mksg; discriminate.
unfold prop_dec2 in |- *.
intro c; case c; intros b c0; elim (sumbool_of_bool b).
elim (eq_dec_color c0 white).
intros c0_w b_t; left; auto.
intros c0_notw b_t; right; intro H2; elim H2; clear H2.
intros bt c0w; absurd (c0 = white); auto.
intro b_f; right; intro H2; elim H2; clear H2.
intros b_t c0_w; apply (eq_true_false_abs b); auto.
intros n; generalize (refl_equal (M n)); pattern (M n) at -1 in |- *;
 case (M n); intros b c M_n.
intro H2; elim H2; clear H2.
intros b_t c_w; replace (mk s n) with c; auto.
replace c with (snd (M n)).
rewrite (H_M n); auto.
rewrite M_n; auto.
exists (fun n : node => (hp s g n, mk s n)); auto.
intros ctls ctlt heap H_mark m mksm upd_col; right; intro mes_s; split.
intro nbeqO; absurd (mesure (mk s) nb); auto.
rewrite nbeqO; intro mes_s_O; inversion mes_s_O; clear mes_s_O.
generalize (refl_equal w); pattern w at -1 in |- *; case w.
intro weqO; rewrite weqO in H1; inversion H1; absurd (mk s m = white); auto.
intros n weqSn; absurd (w = S n); auto.
cut (w = 0).
intro weqO; rewrite weqO; auto with arith.
apply (plus_O_O g w); assumption.
elim upd_col; clear upd_col.
intros mark mktm.
inversion mes_s; clear mes_s; elim (eq_nat_dec w 0).
intro wO; absurd (card_color white (mk s) 0).
intro cards; inversion cards; absurd (mk s m = white); auto.
rewrite <- wO; assumption.
intro wO; replace (pred (g + w)) with (g + pred w).
apply (mesur (mk t)).
unfold card_color in |- *; apply card_inv with (M1 := mk s); auto.
intros n mksn; elim (eq_dec_node n m).
intro neqm; rewrite neqm; rewrite mktm; discriminate.
intro ndifm; rewrite <- (mark n ndifm); assumption.
intros n mksn; absurd (mk s n = grey); auto.
unfold card_color in |- *; apply card_rem with (M1 := mk s) (a0 := m); auto.
rewrite mktm; discriminate.
symmetry  in |- *; apply (plus_pred g w); assumption.
Qed.

Lemma gccall_ex_mesure :
 forall s t : state,
 rt_grey_or_black s ->
 (exists b : nat, card_color black (mk s) b) ->
 (exists nb : nat, mesure (mk s) nb) ->
 gc_call s t -> exists nb : nat, mesure (mk t) nb.

intros s t H_rt H_black H gccall; elim H; clear H.
intros nb H_mes; elim gccall; clear gccall.
intros ctls ctlt heap H_col H_init; elim H_black; clear H_black.
intros b H_card; exists (1 + pred b).
constructor; eauto.
intros ctls ctlt heap H_grey; exists (pred nb);
 cut
  (mesure (mk s) 0 \/
   (mesure (mk s) nb -> nb <> 0 /\ mesure (mk t) (pred nb))).
intro H; elim H; clear H.
elim H_grey; clear H_grey.
intros g mksg mktg mark1 mark2 Hmes; absurd (mesure (mk s) 0); auto.
intro Hmes_O; inversion Hmes_O.
cut (g0 = 0).
intro g0eq0; rewrite g0eq0 in H0; inversion H0; absurd (mk s g = grey); auto.
rewrite (plus_comm g0 w) in H; apply (plus_O_O w g0); assumption.
intro H; elim H; auto.
apply (gccall_mesure s t nb); auto.
apply (call_exist_grey s t); auto.
intros ctls ctlt heap H_col m mksm upd_col; exists (pred nb);
 cut
  (mesure (mk s) 0 \/
   (mesure (mk s) nb -> nb <> 0 /\ mesure (mk t) (pred nb))).
intro H; elim H; clear H.
intro Hmes_O; absurd (mesure (mk s) 0); auto.
intro Hmes; inversion Hmes.
cut (w = 0).
intro weq0; rewrite weq0 in H1; inversion H1; absurd (mk s m = white); auto.
apply (plus_O_O g w); assumption.
intro H; elim H; auto.
apply (gccall_mesure s t nb); auto.
apply init_no_greys_but_white with (s := s) (t := t) (m := m); auto.
Qed.

Hint Resolve gccall_ex_mesure.

Lemma marknode_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> mark_node s t -> mesure (mk t) (pred nb).

intros s t nb mes_s marknode.
inversion mes_s; clear mes_s.
elim marknode; clear marknode.
intros ctls ctlt heap greynode; clear ctls ctlt.
elim greynode; clear greynode.
intros g0 mksg0 mktg0 H_col mkseqmkt.
cut
 (exists M : node -> bool * color,
    (forall n : node, M n = (hp s g0 n, mk s n))).
intro H2; elim H2; clear H2.
intros M H_M.
cut
 (exists nb : nat,
    card _ _
      (fun p : bool * color =>
       match p with
       | (b, c) => b = true /\ c = white
       end) M nb /\ nb <= w).
intro H2; elim H2; clear H2.
intros nbsons H_nbsons; elim H_nbsons; clear H_nbsons.
intros H_cardsons le_nbsons_w.
cut (card_sons g0 white (mk s) (hp s) nbsons).
intro card_sons.
rewrite (pred_plus_minus nbsons g w); auto.
apply (mesur (mk t)).
apply
 card_grey_marknode with (n0 := g0) (m1 := mk s) (h1 := hp s) (h2 := hp t);
 auto.
rewrite mktg0; discriminate.
constructor; auto.
rewrite heap; auto.
apply
 card_white_marknode
  with (m1 := mk s) (h1 := hp s) (h2 := hp t) (nb := nbsons) (n0 := g0);
 auto.
constructor; auto.
rewrite heap; auto.
intro geq0; rewrite geq0 in H; inversion H; absurd (mk s g0 = grey); auto.
apply CS with (M := M); auto.
unfold card_color in H0.
apply
 include_card_bis
  with (P := fun c : color => c = white) (M := mk s) (nb := w);
 auto.
exists (hp s rt g0, mk s g0).
intro H2; elim H2; clear H2.
intros hrtg0 mksg02; absurd (mk s g0 = white); auto.
rewrite mksg0; discriminate.
unfold prop_dec2 in |- *.
intro c; case c; intros b c0; elim (sumbool_of_bool b).
elim (eq_dec_color c0 white).
intros c0_w b_t; left; auto.
intros c0_notw b_t; right; intro H2; elim H2; clear H2.
intros bt c0w; absurd (c0 = white); auto.
intro b_f; right; intro H2; elim H2; clear H2.
intros b_t c0_w; apply (eq_true_false_abs b); auto.
intros n; generalize (refl_equal (M n)); pattern (M n) at -1 in |- *;
 case (M n); intros b c M_n.
intro H2; elim H2; clear H2.
intros b_t c_w; replace (mk s n) with c; auto.
replace c with (snd (M n)).
rewrite (H_M n); auto.
rewrite M_n; auto.
exists (fun n : node => (hp s g0 n, mk s n)); auto.
Qed.

Hint Resolve marknode_mesure.

Lemma marknode_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 mark_node s t -> exists nb : nat, mesure (mk t) nb.

intros s t H marknode; elim H; clear H.
intros nb H_mes; exists (pred nb); eauto.
Qed.

Hint Resolve marknode_ex_mesure.

Lemma gcstop_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> gc_stop s t -> mesure (mk t) nb.

intros s t nb mes_s gcstop; elim gcstop; clear gcstop.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Hint Resolve gcstop_mesure.

Lemma gcstop_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 gc_stop s t -> exists nb : nat, mesure (mk t) nb.

intros s t H gcstop; elim H; clear H.
intros nb H_mes; exists nb; eauto.
Qed.

Hint Resolve gcstop_ex_mesure.

Lemma gcfree_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> gc_free s t -> mesure (mk t) (pred nb).

intros s t nb H_mes gcfree; elim gcfree; clear gcfree.
intros ctls ctlt H_col heap m mksm upd_col; inversion H_mes;
 elim (eq_nat_dec w 0).
intro weqO; absurd (card_color white (mk s) 0).
intro cards; inversion cards; absurd (mk s m = white); auto.
rewrite <- weqO; assumption.
intro wdifO; replace (pred (g + w)) with (g + pred w).
apply (mesur (mk t)); unfold card_color in |- *.
apply card_inv with (M1 := mk s); auto.
intros n mksn; apply (gcfree_notgreys_notgreyt s t); auto.
apply (free_no_grey_but_white s t) with (m := m); auto.
intros n mksn; apply (gcfree_greys_greyt s t); auto.
apply (free_no_grey_but_white s t) with (m := m); auto.
elim upd_col; clear upd_col.
intros mark mktm.
apply card_rem with (M1 := mk s) (a0 := m); auto.
rewrite mktm; discriminate.
symmetry  in |- *; apply (plus_pred g w); assumption.
Qed.

Hint Resolve gcfree_mesure.

Lemma gcfree_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 gc_free s t -> exists nb : nat, mesure (mk t) nb.

intros s t H gcfree; elim H; clear H.
intros nb H_mes; exists (pred nb); eauto.
Qed.

Hint Resolve gcfree_ex_mesure.

Lemma gcfree1_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> gc_free1 s t -> mesure (mk t) (pred nb).

intros s t nb mes_s gcfree1; inversion mes_s; elim (eq_nat_dec w 0).
intro weqO.
absurd (card_color white (mk s) 0).
elim gcfree1; clear gcfree1.
intros ctls ctlt heap n mksn upd_col; intro cards; inversion cards;
 absurd (mk s n = white); auto.
rewrite <- weqO; assumption.
intro wdifO; replace (pred (g + w)) with (g + pred w).
apply (mesur (mk t)); eauto.
rewrite (plus_pred g w); auto.
Qed.

Hint Resolve gcfree1_mesure.

Lemma gcfree1_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 gc_free1 s t -> exists nb : nat, mesure (mk t) nb.

intros s t H gcfree1; elim H; clear H.
intros nb H_mes; exists (pred nb); eauto.
Qed.

Hint Resolve gcfree1_ex_mesure.

Lemma gcend_mesure :
 forall (s t : state) (nb : nat),
 mesure (mk s) nb -> gc_end s t -> mesure (mk t) nb.

intros s t nb mes_s gcend; elim gcend; clear gcend.
intros ctls ctlt heap mark; rewrite mark; assumption.
Qed.

Hint Resolve gcend_mesure.

Lemma gcend_ex_mesure :
 forall s t : state,
 (exists nb : nat, mesure (mk s) nb) ->
 gc_end s t -> exists nb : nat, mesure (mk t) nb.

intros s t H gcend; elim H; clear H.
intros nb H_mes; exists nb; eauto.
Qed.

Hint Resolve gcend_ex_mesure.

End mesure.

Hint Resolve add_mesure.
Hint Resolve remove_mesure.
Hint Resolve gccall_mesure.
Hint Resolve alloc_mesure.
Hint Resolve marknode_mesure.
Hint Resolve gcstop_mesure.
Hint Resolve gcfree_mesure.
Hint Resolve gcfree1_mesure.
Hint Resolve gcend_mesure.
Hint Immediate add_ex_mesure.
Hint Immediate remove_ex_mesure.
Hint Immediate gccall_ex_mesure.
Hint Immediate alloc_ex_mesure.
Hint Immediate marknode_ex_mesure.
Hint Immediate gcstop_ex_mesure.
Hint Immediate gcfree_ex_mesure.
Hint Immediate gcfree1_ex_mesure.
Hint Immediate gcend_ex_mesure.
Hint Immediate init_ex_mesure.


Theorem Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
  intros.
  destruct H.
  contradiction.
  assumption.
Qed.