(** * Lifting saturation from categories to sigma/subcategories *)
Require Import Category.Core Category.Morphisms.
Require Import Category.Univalent.
Require Import Category.Sigma.Core Category.Sigma.OnObjects Category.Sigma.OnMorphisms.
Require Import HoTT.Types HoTT.Basics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Notation pr1_type := Overture.pr1 (only parsing).

Local Open Scope path_scope.
Local Open Scope morphism_scope.

Local Open Scope function_scope.

(** TODO: Following a comment from Mike Shulman
    (https://github.com/HoTT/HoTT/pull/670##issuecomment-68907833),
    much of this can probably be subsumed by a general theorem proving
    that univalence lifts along suitable pseudomonic functors
    (http://ncatlab.org/nlab/show/pseudomonic+functor). *)

(** ** Lift saturation to sigma on objects whenever the property is an hProp *)
Section onobjects.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  Global Instance iscategory_sig_obj `{forall a, IsHProp (Pobj a), A_cat : IsCategory A}
  : IsCategory (sig_obj A Pobj).
  Proof.
    intros s d.
    (* This makes typeclass search go faster. *)
    pose @isequiv_compose.
    refine (isequiv_homotopic
              ((issig_full_isomorphic (sig_obj A Pobj) _ _ o (issig_full_isomorphic A _ _)^-1)
                 o (@idtoiso A s.1 d.1)
                 o pr1_path)
              _).
    intro x; destruct x.
    reflexivity.
  Defined.

  (** The converse is not true; consider [Pobj := fun _ => Empty]. *)
End onobjects.

(** ** Lift saturation to sigma on objects whenever the property is automatically and uniquely true of isomorphisms *)
Section onmorphisms.
  Variable A : PreCategory.
  Variable Pmor : forall s d, morphism A s d -> Type.

  Local Notation mor s d := { m : _ | Pmor s d m }%type.
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  Local Notation A' := (@sig_mor' A Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity).

  (** To have any hope of relating [IsCategory A] with [IsCategory
      A'], we assume that [Pmor] is automatically and uniquely true on
      isomorphisms. *)
  Context `{forall s d m, IsIsomorphism m -> Contr (Pmor s d m)}.

  Definition iscategory_sig_mor_helper {s d}
  : @Isomorphic A' s d -> @Isomorphic A s d.
  Proof.
    refine ((issig_full_isomorphic A _ _) o _ o (issig_full_isomorphic A' _ _)^-1).
    exact (functor_sigma
             pr1_type
             (fun _ =>
                functor_sigma
                  pr1_type
                  (fun _ =>
                     functor_sigma
                       pr1_path
                       (fun _ => pr1_path)))).
  Defined.

  Local Instance isequiv_iscategory_sig_mor_helper s d
  : IsEquiv (@iscategory_sig_mor_helper s d).
  Proof.
    simple refine (isequiv_adjointify _ _ _ _).
    { intro e.
      exists (e : morphism _ _ _; center _).
      exists (e^-1%morphism; center _);
        simple refine (path_sigma _ _ _ _ _);
        first [ apply left_inverse
              | apply right_inverse
              | by apply path_ishprop ]. }
    { intro; by apply path_isomorphic. }
    { intros x; apply path_isomorphic.
      exact (path_sigma' _ 1 (contr _)). }
  Defined.

  Global Instance iscategory_sig_mor `{A_cat : IsCategory A}
  : IsCategory A'.
  Proof.
    intros s d.
    (* Use [equiv_compose] rather than "o" to speed up typeclass search. *)
    refine (isequiv_homotopic
              (equiv_compose iscategory_sig_mor_helper^-1 (@idtoiso _ _ _))
              _).
    intro x; apply path_isomorphic; cbn.
    destruct x; refine (path_sigma' _ 1 (contr _)).
  Defined.

  Definition iscategory_from_sig_mor `{A'_cat : IsCategory A'}
  : IsCategory A.
  Proof.
    intros s d.
    refine (isequiv_homotopic
              (iscategory_sig_mor_helper
                 o (@idtoiso A' _ _))
              _).
    intro x; apply path_isomorphic; cbn.
    destruct x; reflexivity.
  Defined.

  Global Instance isequiv_iscategory_sig_mor `{Funext}
  : IsEquiv (@iscategory_sig_mor).
  Proof.
    refine (isequiv_iff_hprop _ (@iscategory_from_sig_mor)).
  Defined.
End onmorphisms.

(** ** Lift saturation to sigma on both objects and morphisms *)
Section on_both.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  Local Notation obj := { x : _ | Pobj x }%type (only parsing).

  Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type.

  Local Notation mor s d := { m : _ | Pmor s d m }%type (only parsing).
  Context `(HPmor : forall s d, IsHSet (mor s d)).

  Variable Pidentity : forall x, @Pmor x x (@identity A _).
  Variable Pcompose : forall s d d' m1 m2,
                        @Pmor d d' m1
                        -> @Pmor s d m2
                        -> @Pmor s d' (m1 o m2).

  Local Notation identity x := (@identity A x.1; @Pidentity x).
  Local Notation compose m1 m2 := (m1.1 o m2.1; @Pcompose _ _ _ m1.1 m2.1 m1.2 m2.2)%morphism.

  Hypothesis P_associativity
  : forall x1 x2 x3 x4 (m1 : mor x1 x2) (m2 : mor x2 x3) (m3 : mor x3 x4),
      compose (compose m3 m2) m1 = compose m3 (compose m2 m1).

  Hypothesis P_left_identity
  : forall a b (f : mor a b),
      compose (identity b) f = f.

  Hypothesis P_right_identity
  : forall a b (f : mor a b),
      compose f (identity a) = f.

  Local Notation A' := (@sig' A Pobj Pmor HPmor Pidentity Pcompose P_associativity P_left_identity P_right_identity).

  (** We must assume some relation on the properties; we assume that
      the path space of the extra data on objects is classified by
      isomorphisms of the extra data on objects. *)
  Local Definition Pmor_iso_T s d m m' left right :=
    ({ e : Pmor s d m
     | { e' : Pmor d s m'
       | { _ : transport (Pmor _ _) ((left : m' o m = 1)%morphism) (Pcompose e' e) = Pidentity _
         | transport (Pmor _ _) ((right : m o m' = 1)%morphism) (Pcompose e e') = Pidentity _ } } }).

  Global Arguments Pmor_iso_T / .

  Local Definition Pmor_iso_T' x (xp xp' : Pobj x)
    := { e : Pmor (x; xp) (x; xp') 1
       | { e' : Pmor (x; xp') (x; xp) 1
         | { _ : Pcompose e' e = Pcompose (Pidentity _) (Pidentity _)
           | Pcompose e e' = Pcompose (Pidentity _) (Pidentity _) } } }.

  Global Arguments Pmor_iso_T' / .

  Local Definition Pidtoiso x (xp xp' : Pobj x) (H : xp = xp')
  : Pmor_iso_T' xp xp'.
  Proof.
    destruct H.
    exists (Pidentity _).
    exists (Pidentity _).
    split; reflexivity.
  Defined.

  Global Arguments Pidtoiso / .

  (** TODO: generalize this to a theorem [forall A P, IsHSet A -> IsHSet { x : A | P x } -> forall x, IsHSet (P x)], [inO_unsigma] of ##672 *)
  Local Instance ishset_pmor {s d m} : IsHSet (Pmor s d m).
  Proof.
    intros p q.
    apply hprop_allpath.
    let H := constr:(_ : forall x y : mor s d, IsHProp (x = y)) in
    pose proof (@path_ishprop _ (H (m; p) (m; q))) as H'.
    intros x y.
    specialize (H' (path_sigma' _ 1 x) (path_sigma' _ 1 y)).
    unfold path_sigma', path_sigma in H'.
    apply (ap (path_sigma_uncurried (Pmor s d) (m; p) (m; q)))^-1 in H'.
    assert (H'' : H'..1 = idpath) by apply path_ishprop.
    exact (transport (fun H'1 => transport _ H'1 _ = _) H'' H'..2).
  Defined.

  Local Definition Pmor_iso_adjust x xp xp'
  : (Pmor_iso_T (x; xp) (x; xp') 1 1 (left_identity _ _ _ _) (right_identity _ _ _ _))
      <~> Pmor_iso_T' xp xp'.
  Proof.
    refine (equiv_functor_sigma_id _); intro.
    refine (equiv_functor_sigma_id _); intro.
    refine (equiv_functor_sigma' (equiv_iff_hprop _ _) (fun _ => equiv_iff_hprop _ _));
      cbn; intro H';
      first [ apply moveL_transport_V in H'
                | apply moveR_transport_p ];
      refine (H' @ _);
      first [ refine (_ @ ((P_left_identity (identity (x; _)))^)..2)
                | refine ((((P_left_identity (identity (x; _)))^)..2)^ @ _) ];
      refine (ap (fun p => transport _ p _) (path_ishprop _ _)).
  Defined.

  Global Arguments Pmor_iso_adjust / .

  Local Definition iso_A'_code {s d}
  : (@Isomorphic A' s d)
    -> { e : @Isomorphic A s.1 d.1
       | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }.
  Proof.
    intro e.
    simple refine (_; _).
    { exists (e : morphism _ _ _).1.
      exists (e^-1%morphism).1.
      - exact (@left_inverse _ _ _ e e)..1.
      - exact (@right_inverse _ _ _ e e)..1. }
    { exists (e : morphism _ _ _).2.
      exists (e^-1%morphism).2; cbn.
      exists (((@left_inverse _ _ _ e e))..2).
      exact (@right_inverse _ _ _ e e)..2. }
  Defined.

  Local Definition iso_A'_decode_helper {s d}
        (e : { e : @Isomorphic A s.1 d.1
             | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse })
  : @IsIsomorphism A' _ _ (e.1:morphism A s.1 d.1; (e.2).1).
  Proof.
    eexists. Unshelve.
    3:exact (e.1^-1%morphism; e.2.2.1).
    { refine (path_sigma' _ left_inverse e.2.2.2.1). }
    { refine (path_sigma' _ right_inverse e.2.2.2.2). }
  Defined.

  Local Definition iso_A'_decode {s d}
  : { e : @Isomorphic A s.1 d.1
    | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }
    -> (@Isomorphic A' s d).
  Proof.
    intro e.
    eexists. Unshelve.
    2:exact (e.1 : morphism _ _ _; e.2.1).
    apply iso_A'_decode_helper.
  Defined.

  Local Definition equiv_iso_A'_eisretr_helper {s d}
        (x : {e : @Isomorphic A s.1 d.1
             | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }%type)
  : transport
      (fun e : @Isomorphic A s.1 d.1 =>
         Pmor_iso_T s d e e^-1 left_inverse right_inverse)
      (path_isomorphic (iso_A'_code (iso_A'_decode x)).1 x.1 1)
      (iso_A'_code (iso_A'_decode x)).2 = x.2.
  Proof.
    simple refine (path_sigma _ _ _ _ _); cycle 1.
    (* Speed up typeclass search: *)
    1:pose @istrunc_sigma; pose @istrunc_paths;
      simple refine (path_sigma _ _ _ _ (path_ishprop _ _)).
    all:repeat match goal with
                 | [ |- (transport ?P ?p ?z).1 = _ ] => rewrite (@ap_transport _ P _ _ _ p (fun _ x => x.1))
                 | [ |- (transport ?P ?p ?z).2.1 = _ ] => rewrite (@ap_transport _ P _ _ _ p (fun _ x => x.2.1))
                 | [ |- transport (fun _ => ?x) _ _ = _ ] => rewrite transport_const
                 | [ |- transport (fun x => ?f (@morphism_inverse _ _ _ (@morphism_isomorphic _ _ _ x) _)) _ _ = _ ]
                   => rewrite (@transport_compose _ _ _ _ f (fun x => (@morphism_inverse _ _ _ (@morphism_isomorphic _ _ _ x) (@isisomorphism_isomorphic _ _ _ x))))
                 | [ |- transport (?f o ?g) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f g)
                 | [ |- transport (fun x => ?f (?g x)) _ _ = _ ] => rewrite (@transport_compose _ _ _ _ f g)
                 | [ |- context[ap (@morphism_isomorphic ?a ?b ?c) (path_isomorphic ?i ?j ?x)] ]
                   => change (ap (@morphism_isomorphic a b c)) with ((path_isomorphic i j)^-1%function);
                     rewrite (@eissect _ _ (path_isomorphic i j) _ x)
                 | [ |- context[ap (fun e : Isomorphic _ _ => @morphism_inverse ?C ?s ?d _ _) (path_isomorphic ?i ?j ?x)] ]
                   => rewrite (@ap_morphism_inverse_path_isomorphic C s d i j x 1)
                 | [ |- transport ?P 1 ?x = ?y ] => change (x = y)
                 | [ |- (((iso_A'_code (iso_A'_decode ?x)).2).2).1 = ((?x.2).2).1 ] => reflexivity
                 | [ |- (((iso_A'_code (iso_A'_decode ?x)).2).1) = ((?x.2).1) ] => reflexivity
               end.
  Qed.

  Local Definition equiv_iso_A' {s d}
  : (@Isomorphic A' s d)
      <~> { e : @Isomorphic A s.1 d.1
          | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }.
  Proof.
    refine (equiv_adjointify iso_A'_code iso_A'_decode _ _).
    { intro.
      simple refine (path_sigma _ _ _ _ _).
      { apply path_isomorphic; reflexivity. }
      { apply equiv_iso_A'_eisretr_helper. }  }
    { intro.
      apply path_isomorphic.
      reflexivity. }
  Defined.

  Context `{Pisotoid : forall x xp xp', IsEquiv (@Pidtoiso x xp xp')}.

  Local Arguments Pmor_iso_T : simpl never.

  Global Instance iscategory_sig `{A_cat : IsCategory A}
  : IsCategory A'.
  Proof.
    intros s d.
    simple notypeclasses refine (isequiv_homotopic
              ((equiv_iso_A'^-1)
                 o (functor_sigma _ _)
                 o (path_sigma_uncurried _ _ _)^-1)
              _); [exact _ | | | exact _ | |].
    (* [try exact _] leaves the third remaining goal unchanged, but takes ~9s to do so. *)
    { exact (@idtoiso A _ _). }
    { destruct s as [s0 s1], d as [d0 d1]; cbn.
      intro p; destruct p; cbn.
      refine ((@Pmor_iso_adjust s0 s1 d1)^-1 o _).
      refine (@Pidtoiso _ _ _). }
    { (* Do this in small steps to make it fast. *)
      nrefine isequiv_compose. 1:apply isequiv_inverse.
      nrefine isequiv_compose. 2:apply isequiv_inverse.
      nrefine isequiv_functor_sigma. 1:apply A_cat.
      destruct s, d.
      simpl Overture.pr1.
      intro p; destruct p.
      eapply @isequiv_compose.
      - exact _.
      - eapply @isequiv_inverse. }
    { intro p; apply path_isomorphic; destruct p.
      reflexivity. }
  Defined.
End on_both.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition validate_table_commands_spec (map_addr: Z64) (level: Z64) (min_level: Z64) (max_level: Z64) (index: Z64) (adt: RData) : option Z :=
    match map_addr, level, min_level, max_level, index with
    | VZ64 map_addr, VZ64 level, VZ64 min_level, VZ64 max_level, VZ64 index =>
      rely is_int64 map_addr; rely is_int64 level;
      if (level >=? min_level) && (level <=? max_level) && (__addr_is_level_aligned map_addr level) then
        Some 0
      else
        Some 1
    end.

End Spec.


(** ** Weak Head Normalisation *)

Require Import core fintype.
Import ScopedNotations.
From Chapter9 Require Export preservation.

Definition E_ {m} (L: tm m -> Prop)  (s : tm m) : Prop :=
  exists v, star step s v /\ L v.

Fixpoint L {m} (A : ty): tm m -> Prop :=
  match A with
  | Base => fun s => exists v, star step s v /\ value v
  | Fun A1 A2 => fun e => match e with
                      | (lam B s) => forall k (xi: fin m -> fin k) v, L A1 v -> E_ (L A2) (subst_tm (scons v (xi >> var_tm)) s)
                      | _ => False
                      end
  end.

Lemma L_ren {m n} s A (xi: fin m -> fin n) :
  L A s -> L A (ren_tm xi s).
Proof.
  revert m n s xi. induction A; eauto; intros m n s xi.
  - intros (?&?&?).
    exists (x⟨xi⟩). split.
    + substify. eauto using mstep_inst.
    + destruct x; eauto.
  - intros.
    destruct s; try contradiction.
    intros k zeta v H''. cbn in H. specialize (H _ (xi >> zeta) _ H'').
    destruct H as (?&?&?).
    exists x. split; eauto. asimpl. eauto.
Qed.

Definition G {m k} (Gamma : ctx m) : (fin m -> tm k)  -> Prop :=
  fun σ => forall (x : fin m), L (Gamma x) (σ x) .

Definition has_ty_sem {m} (Gamma : ctx m) (s: tm m) (A: ty) : Prop :=
  forall k (sigma: fin m -> tm k), G Gamma sigma -> E_ (L A) (subst_tm sigma s).

Lemma val_inclusion {m} A (e: tm m) :
  L A e -> E_ (L A) e.
Proof. intros. unfold E_. exists e. split; eauto. Qed.

Lemma wn_fundamental_lam {m} Gamma (s: tm m) A:
  has_type Gamma s A -> has_ty_sem Gamma s A.
Proof.
  intros C. unfold has_ty_sem, E_. induction C; subst; intros.
  - eauto.
  - apply val_inclusion. asimpl.
    intros m. intros.
    assert (G (S1 .: Gamma) (v .: (sigma >> ren_tm xi))).     { unfold G. intros [|]; cbn; eauto.
      - cbn in *. specialize (H f). now apply L_ren. }
    asimpl.
    specialize (IHC _ _ H1).
    destruct (IHC) as (v'&?&?).
    exists v'; split; eauto.
    (* a.d. I had to unfold funcomp here to setoid rewrite with rinstInst' *)
    revert H2. unfold funcomp. setoid_rewrite rinstInst'_tm. eauto using mstep_inst.
  - destruct (IHC1 _ _  H) as (v1&?&?).
    destruct (IHC2  _ _ H) as (v2&?&?).
    destruct v1; try contradiction.
    cbn in H1.
    destruct (H1 _ id _ H3) as (v&?&?).
    exists v; split; eauto. asimpl.
    enough (star step (app  (lam t v1) v2) v).
    + eapply star_trans.
      eapply mstep_app; eauto. assumption.
    + eapply star_trans.
      * eright. econstructor; eauto. constructor.
        (* a.d. asimpl directly in hypothesis instead of * *)
      * now asimpl in H4.
Qed.


(*******************************************************************************

 The projection

 Given a strict functor `F : C ⟶ StrictCat`, then we have a projection going
 from `∫ F` to `C`.
 In addition, the Grothendieck construction is pseudofunctorial.

 Contents
 1. The projection
 2. Action on 1-cells
 3. Action on 2-cells
 4. Identitor
 5. Compositor

 *******************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Setcategories.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.categories.CategoryOfSetCategories.
Require Import UniMath.CategoryTheory.GrothendieckConstruction.TotalCategory.

Local Open Scope cat.

(**
 1. The projection
 *)
Definition pr1_total_category_of_set_functor_data
           {C : setcategory}
           (F : C ⟶ cat_of_setcategory)
  : functor_data
      (total_setcategory_of_set_functor F)
      C.
Proof.
  use make_functor_data.
  - exact (λ x, pr1 x).
  - exact (λ _ _ f, pr1 f).
Defined.

Definition pr1_total_category_of_set_is_functor
           {C : setcategory}
           (F : C ⟶ cat_of_setcategory)
  : is_functor (pr1_total_category_of_set_functor_data F).
Proof.
  split ; intro ; intros ; apply idpath.
Qed.

Definition pr1_total_category_of_set_functor
           {C : setcategory}
           (F : C ⟶ cat_of_setcategory)
  : total_setcategory_of_set_functor F ⟶ C.
Proof.
  use make_functor.
  - exact (pr1_total_category_of_set_functor_data F).
  - exact (pr1_total_category_of_set_is_functor F).
Defined.

(**
 2. Action on 1-cells
 *)
Section FunctorTotalCategoryFromSetFunctor.
  Context {C₁ C₂ : setcategory}
          (F : C₁ ⟶ C₂)
          {G₁ : C₁ ⟶ cat_of_setcategory}
          {G₂ : C₂ ⟶ cat_of_setcategory}
          (α : G₁ ⟹ F ∙ G₂).

  Definition functor_total_category_of_set_functor_eq
             {x y : total_precategory_of_set_functor G₁}
             (f : x --> y)
    : pr1 (# G₂ (# F (pr1 f))) (pr1 (pr1 α (pr1 x)) (pr2 x))
      =
      pr1 (α (pr1 y)) (pr1 (# G₁ (pr1 f)) (pr2 x)).
  Proof.
    exact (!(eqtohomot (maponpaths (λ z, pr11 z) (nat_trans_ax α _ _ (pr1 f))) (pr2 x))).
  Qed.

  Definition functor_total_category_of_set_functor_data
    : functor_data
        (total_setcategory_of_set_functor G₁)
        (total_setcategory_of_set_functor G₂).
  Proof.
    use make_functor_data.
    - exact (λ x, F (pr1 x) ,, pr1 (pr1 α (pr1 x)) (pr2 x)).
    - refine (λ x y f, #F (pr1 f) ,, _).
      exact (idtoiso (functor_total_category_of_set_functor_eq f)
             · # (pr1 (α (pr1 y))) (pr2 f)).
  Defined.

  Definition is_functor_functor_total_category_of_set_functor
    : is_functor functor_total_category_of_set_functor_data.
  Proof.
    split.
    - intro x.
      use eq_mor_category_of_set_functor ; cbn.
      + apply functor_id.
      + etrans.
        {
          apply maponpaths.
          refine (!_).
          exact (pr1_maponpaths_idtoiso
                   (α (pr1 x))
                   (eq_in_set_fiber (functor_id G₁ (pr1 x)) (pr2 x))).
        }
        etrans.
        {
          refine (!_).
          exact (pr1_idtoiso_concat
                   _
                   (maponpaths
                      (pr1 (α (pr1 x)))
                      (eq_in_set_fiber (functor_id G₁ (pr1 x)) (pr2 x)))).
        }
        refine (!_).
        etrans.
        {
          refine (!_).
          exact (pr1_idtoiso_concat
                   _
                   (eq_in_set_fiber
                      (functor_id G₂ (F (pr1 x))) (pr1 (pr1 α (pr1 x)) (pr2 x)))).
        }
        apply setcategory_eq_idtoiso.
    - intros x y z f g.
      use eq_mor_category_of_set_functor ; cbn.
      + apply functor_comp.
      + cbn.
        refine (!_).
        rewrite !assoc.
        etrans.
        {
          do 3 apply maponpaths_2.
          refine (!_).
          exact (pr1_idtoiso_concat
                   _
                   (eq_in_set_fiber
                      (functor_comp G₂ (# F (pr1 f)) (# F (pr1 g)))
                      (pr1 (pr1 α (pr1 x)) (pr2 x)))).
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          etrans.
          {
            apply functor_comp.
          }
          apply maponpaths_2.
          refine (!_).
          apply  (pr1_maponpaths_idtoiso
                    (# G₂ (# F (pr1 g)))
                    (functor_total_category_of_set_functor_eq f)).
        }
        rewrite !assoc.
        etrans.
        {
          do 3 apply maponpaths_2.
          refine (!_).
          exact (pr1_idtoiso_concat
                   (maponpaths
                      (λ q, pr1 (# G₂ q) (pr1 (pr1 α (pr1 x)) (pr2 x)))
                      (functor_comp F (pr1 f) (pr1 g))
                       @ eq_in_set_fiber
                           (functor_comp G₂ (# F (pr1 f)) (# F (pr1 g)))
                           (pr1 (pr1 α (pr1 x)) (pr2 x)))
                   (maponpaths
                      (pr1 (# G₂ (# F (pr1 g))))
                      (functor_total_category_of_set_functor_eq f))).
        }
        refine (!_).
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply functor_comp.
          }
          apply maponpaths.
          apply functor_comp.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            refine (!_).
            exact (pr1_maponpaths_idtoiso
                     (α (pr1 z))
                     (eq_in_set_fiber (functor_comp G₁ (pr1 f) (pr1 g)) (pr2 x))).
          }
          refine (!_).
          exact (pr1_idtoiso_concat
                   _
                   (maponpaths
                      (pr1 (α (pr1 z)))
                      (eq_in_set_fiber (functor_comp G₁ (pr1 f) (pr1 g)) (pr2 x)))).
        }
        etrans.
        {
          apply maponpaths.
          exact (from_eq_cat_of_setcategory
                   (nat_trans_ax α _ _ (pr1 g))
                   (pr2 f)).
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          refine (!_).
          apply pr1_idtoiso_concat.
        }
        cbn.
        apply setcategory_eq_idtoiso_comp.
  Qed.

  Definition functor_total_category_of_set_functor
    : total_setcategory_of_set_functor G₁ ⟶ total_setcategory_of_set_functor G₂.
  Proof.
    use make_functor.
    - exact functor_total_category_of_set_functor_data.
    - exact is_functor_functor_total_category_of_set_functor.
  Defined.

  Definition functor_total_category_of_set_functor_comm
    : pr1_total_category_of_set_functor G₁ ∙ F
      ⟹
      functor_total_category_of_set_functor ∙ pr1_total_category_of_set_functor G₂.
  Proof.
    use make_nat_trans.
    - exact (λ x, identity _).
    - abstract
        (intros x y f ; cbn ;
         exact (id_right _ @ !(id_left _))).
  Defined.

  Definition is_nat_z_iso_functor_total_category_of_set_functor_comm
    : is_nat_z_iso functor_total_category_of_set_functor_comm.
  Proof.
    intro ; cbn.
    apply identity_is_z_iso.
  Defined.
End FunctorTotalCategoryFromSetFunctor.

(**
 3. Action on 2-cells
 *)
Section NatTransTotalCategoryFromNatTrans.
  Context {C₁ C₂ : setcategory}
          {F₁ F₂ : C₁ ⟶ C₂}
          (α : F₁ ⟹ F₂)
          {G₁ : C₁ ⟶ cat_of_setcategory}
          {G₂ : C₂ ⟶ cat_of_setcategory}
          (β₁ : G₁ ⟹ F₁ ∙ G₂)
          (β₂ : G₁ ⟹ F₂ ∙ G₂)
          (p : ∏ (x : C₁), pr1 β₁ x ∙ # (pr1 G₂) (pr1 α x) = pr1 β₂ x).

  Definition nat_trans_total_category_of_set_functor_eq
             (x : total_precategory_of_set_functor G₁)
    : pr1 (# G₂ (α (pr1 x))) (pr1 (pr1 β₁ (pr1 x)) (pr2 x))
      =
      pr1 (pr1 β₂ (pr1 x)) (pr2 x).
  Proof.
    exact (eqtohomot (maponpaths (λ z, pr11 z) (p (pr1 x))) (pr2 x)).
  Qed.

  Definition nat_trans_total_category_of_set_functor_data
    : nat_trans_data
        (functor_total_category_of_set_functor F₁ β₁)
        (functor_total_category_of_set_functor F₂ β₂).
  Proof.
    refine (λ x, α (pr1 x) ,, _).
    exact (idtoiso (nat_trans_total_category_of_set_functor_eq x)).
  Defined.

  Definition nat_trans_total_category_of_set_functor_is_nat_trans
    : is_nat_trans
        _ _
        nat_trans_total_category_of_set_functor_data.
  Proof.
    intros x y f.
    use eq_mor_category_of_set_functor.
    - apply nat_trans_ax.
    - cbn.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        apply functor_comp.
      }
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply (pr1_maponpaths_idtoiso (# G₂ (α (pr1 y)))).
        }
        refine (!_).
        apply (pr1_idtoiso_concat
                 (eq_in_set_fiber
                    (functor_comp G₂ (# F₁ (pr1 f)) (α (pr1 y)))
                    (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            exact (pr1_idtoiso_concat
                     _
                     (eq_in_set_fiber
                        (functor_comp G₂ (α (pr1 x)) (# F₂ (pr1 f)))
                        (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))).
          }
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply (pr1_maponpaths_idtoiso (# G₂ (# F₂ (pr1 f)))).
          }
          refine (!_).
          apply (pr1_idtoiso_concat
                   (_
                    @ eq_in_set_fiber
                        (functor_comp G₂ (α (pr1 x)) (# F₂ (pr1 f)))
                        (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))).
        }
        refine (!_).
        apply (pr1_idtoiso_concat
                 ((_
                  @ eq_in_set_fiber
                      (functor_comp G₂ (α (pr1 x)) (# F₂ (pr1 f)))
                      (pr1 (pr1 β₁ (pr1 x)) (pr2 x)))
                  @ _)).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        exact (from_eq_cat_of_setcategory (p (pr1 y)) (pr2 f)).
      }
      rewrite !assoc'.
      etrans.
      {
        do 3 apply maponpaths.
        refine (!_).
        exact (pr1_idtoiso_concat
                 _
                 (nat_trans_total_category_of_set_functor_eq y)).
      }
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply pr1_idtoiso_concat.
      }
      etrans.
      {
        apply maponpaths.
        apply setcategory_refl_idtoiso.
      }
      etrans.
      {
        apply id_right.
      }
      apply maponpaths_2.
      apply setcategory_eq_idtoiso.
  Qed.

  Definition nat_trans_total_category_of_set_functor
    : functor_total_category_of_set_functor F₁ β₁
        ⟹
        functor_total_category_of_set_functor F₂ β₂.
  Proof.
    use make_nat_trans.
    - exact nat_trans_total_category_of_set_functor_data.
    - exact nat_trans_total_category_of_set_functor_is_nat_trans.
  Defined.
End NatTransTotalCategoryFromNatTrans.

(**
 4. Identitor
 *)
Definition functor_total_category_of_set_functor_on_id_data
           {C : setcategory}
           (F : C ⟶ cat_of_setcategory)
  : nat_trans_data
      (functor_identity _)
      (functor_total_category_of_set_functor
         (functor_identity C)
         (nat_trans_id F))
  := λ _, identity _.

Definition functor_total_category_of_set_functor_on_id_is_nat_trans
           {C : setcategory}
           (F : C ⟶ cat_of_setcategory)
  : is_nat_trans
      _ _
      (functor_total_category_of_set_functor_on_id_data F).
Proof.
  intros x y f.
  refine (id_right _ @ _ @ !(id_left _)).
  use eq_mor_category_of_set_functor.
  - apply idpath.
  - cbn.
    rewrite id_left.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply setcategory_refl_idtoiso.
    }
    apply id_left.
Qed.

Definition functor_total_category_of_set_functor_on_id
           {C : setcategory}
           (F : C ⟶ cat_of_setcategory)
  : functor_identity _
    ⟹
    functor_total_category_of_set_functor
      (functor_identity C)
      (nat_trans_id F).
Proof.
  use make_nat_trans.
  - exact (functor_total_category_of_set_functor_on_id_data F).
  - exact (functor_total_category_of_set_functor_on_id_is_nat_trans F).
Defined.

Definition is_nat_z_iso_functor_total_category_of_set_functor_on_id
          {C : setcategory}
          (F : C ⟶ cat_of_setcategory)
  : is_nat_z_iso (functor_total_category_of_set_functor_on_id_data F).
Proof.
  intro.
  apply identity_is_z_iso.
Defined.

(**
 5. Compositor
 *)
Definition functor_total_category_of_set_functor_on_comp_data
           {C₁ C₂ C₃ : setcategory}
           {F₁ : C₁ ⟶ C₂}
           {F₂ : C₂ ⟶ C₃}
           {G₁ : C₁ ⟶ cat_of_setcategory}
           {G₂ : C₂ ⟶ cat_of_setcategory}
           {G₃ : C₃ ⟶ cat_of_setcategory}
           (α : G₁ ⟹ F₁ ∙ G₂)
           (β : G₂ ⟹ F₂ ∙ G₃)
  : nat_trans_data
      (functor_total_category_of_set_functor F₁ α
       ∙ functor_total_category_of_set_functor F₂ β)
      (functor_total_category_of_set_functor
         (F₁ ∙ F₂)
         (nat_trans_comp _ _ _ α (pre_whisker F₁ β)))
  := λ _, identity _.

Definition functor_total_category_of_set_functor_on_comp_is_nat_trans
           {C₁ C₂ C₃ : setcategory}
           {F₁ : C₁ ⟶ C₂}
           {F₂ : C₂ ⟶ C₃}
           {G₁ : C₁ ⟶ cat_of_setcategory}
           {G₂ : C₂ ⟶ cat_of_setcategory}
           {G₃ : C₃ ⟶ cat_of_setcategory}
           (α : G₁ ⟹ F₁ ∙ G₂)
           (β : G₂ ⟹ F₂ ∙ G₃)
  : is_nat_trans
      _ _
      (functor_total_category_of_set_functor_on_comp_data α β).
Proof.
  intros x y f.
  refine (id_right _ @ _ @ !(id_left _)).
  use eq_mor_category_of_set_functor ; cbn.
  - apply idpath.
  - cbn.
    refine (_ @ !(id_left _)).
    etrans.
    {
      apply maponpaths.
      apply functor_comp.
    }
    rewrite !assoc.
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths.
      refine (!_).
      apply (pr1_maponpaths_idtoiso (β (F₁ (pr1 y)))).
    }
    etrans.
    {
      refine (!_).
      exact (pr1_idtoiso_concat
               _
               (maponpaths
                  (pr1 (β (F₁ (pr1 y))))
                  (functor_total_category_of_set_functor_eq F₁ α f))).
    }
    apply setcategory_eq_idtoiso.
Qed.

Definition functor_total_category_of_set_functor_on_comp
           {C₁ C₂ C₃ : setcategory}
           {F₁ : C₁ ⟶ C₂}
           {F₂ : C₂ ⟶ C₃}
           {G₁ : C₁ ⟶ cat_of_setcategory}
           {G₂ : C₂ ⟶ cat_of_setcategory}
           {G₃ : C₃ ⟶ cat_of_setcategory}
           (α : G₁ ⟹ F₁ ∙ G₂)
           (β : G₂ ⟹ F₂ ∙ G₃)
  : functor_total_category_of_set_functor F₁ α
    ∙ functor_total_category_of_set_functor F₂ β
    ⟹
    functor_total_category_of_set_functor
      (F₁ ∙ F₂)
      (nat_trans_comp _ _ _ α (pre_whisker F₁ β)).
Proof.
  use make_nat_trans.
  - exact (functor_total_category_of_set_functor_on_comp_data α β).
  - exact (functor_total_category_of_set_functor_on_comp_is_nat_trans α β).
Defined.

Definition is_nat_z_iso_functor_total_category_of_set_functor_on_comp
           {C₁ C₂ C₃ : setcategory}
           {F₁ : C₁ ⟶ C₂}
           {F₂ : C₂ ⟶ C₃}
           {G₁ : C₁ ⟶ cat_of_setcategory}
           {G₂ : C₂ ⟶ cat_of_setcategory}
           {G₃ : C₃ ⟶ cat_of_setcategory}
           (α : G₁ ⟹ F₁ ∙ G₂)
           (β : G₂ ⟹ F₂ ∙ G₃)
  : is_nat_z_iso
      (functor_total_category_of_set_functor_on_comp α β).
Proof.
  intro.
  apply identity_is_z_iso.
Defined.


Require Import AtomicCounter.
Require Import RGref.DSL.DSL.
Require Import RGref.DSL.Concurrency.

Local Obligation Tactic := intros; eauto with arith; compute; eauto with arith.

(* Extend the atomic counter with a lock-free increment-by-n *)
Program Definition incr {Δ} (p:monotonic_counter) (n:nat) : rgref Δ unit Δ :=
  RGFix _ _ (fun retry (b:bool) =>
  x <- !p;
  success <- (CAS(p,x,x+n));
  if success then rgret tt else retry false) false.

(* Write a generic imperative iterator *)
Definition forRG {T:Set} {Δ}  : list T -> (T -> rgref Δ unit Δ) -> rgref Δ unit Δ :=
  RGFixT2 _ _ _ (fun forRG (l:list T) (C:T -> rgref Δ unit Δ) =>
  match l with
  | nil => rgret tt
  | cons t l' => (_ <- C t;
                  forRG l' C)
  end).

(* We can write an iteration to increment the counter by each value in the list *)
Definition doIncrements {Δ} (c:monotonic_counter) (l:list nat) : rgref Δ unit Δ :=
  forRG l (fun n => incr c n).

(* And we can write a function of the same arguments, which does something arbitrary but respects the transition invariants of the counter. *)
Definition tooManyIncrements {Δ} (c:monotonic_counter) (l:list nat) : rgref Δ unit Δ :=
  forRG l (fun n => (_ <- incr c n; _ <- incr c n; incr c 1)).


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import compcert.lib.Coqlib.
Require Import compcert.common.Memory ccc26x86.Separation.
Require Import VST.ccc26x86.Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Saved values of integer callee-save registers used by the function.
- Saved values of float callee-save registers used by the function.
- Local stack slots.
- Space for the stack-allocated data declared in Cminor
- Return address.
*)

Definition fe_ofs_arg := 0.

(** Computation of the frame environment from the bounds of the current
  function. *)

Definition make_env (b: bounds) : frame_env :=
  let olink := 4 * b.(bound_outgoing) in  (* back link *)
  let ocs := olink + 4 in                 (* callee-saves *)
  let ol :=  align (size_callee_save_area b ocs) 8 in (* locals *)
  let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
  let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
  let sz := oretaddr + 4 in (* total size *)
  {| fe_size := sz;
     fe_ofs_link := olink;
     fe_ofs_retaddr := oretaddr;
     fe_ofs_local := ol;
     fe_ofs_callee_save := ocs;
     fe_stack_data := ostkdata;
     fe_used_callee_save := b.(used_callee_save) |}.

(** Separation property *)

Local Open Scope sep_scope.

Lemma frame_env_separated:
  forall b sp m P,
  let fe := make_env b in
  m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
  m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
       ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
       ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4)
       ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4)
       ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
       ** P.
Proof.
Local Opaque Z.add Z.mul sepconj range.
  intros; simpl.
  set (olink := 4 * b.(bound_outgoing)).
  set (ocs := olink + 4).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  assert (0 <= olink) by (unfold olink; omega).
  assert (olink + 4 <= ocs) by (unfold ocs; omega).
  assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
  assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
  assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
  assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
(* Reorder as:
     outgoing
     back link
     callee-save
     local
     retaddr *)
  rewrite sep_swap12.
  rewrite sep_swap23.
  rewrite sep_swap45.
  rewrite sep_swap34.
(* Apply range_split and range_split2 repeatedly *)
  unfold fe_ofs_arg.
  apply range_split. omega.
  apply range_split. omega.
  apply range_split_2. fold ol. omega. omega.
  apply range_drop_right with ostkdata. omega.
  rewrite sep_swap.
  apply range_drop_left with (ostkdata + bound_stack_data b). omega.
  rewrite sep_swap.
  exact H.
Qed.

Lemma frame_env_range:
  forall b,
  let fe := make_env b in
  0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
Proof.
  intros; simpl.
  set (olink := 4 * b.(bound_outgoing)).
  set (ocs := olink + 4).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  assert (0 <= olink) by (unfold olink; omega).
  assert (olink + 4 <= ocs) by (unfold ocs; omega).
  assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
  assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
  assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
  assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
  split. omega. omega.
Qed.

Lemma frame_env_aligned:
  forall b,
  let fe := make_env b in
     (8 | fe_ofs_arg)
  /\ (8 | fe_ofs_local fe)
  /\ (8 | fe_stack_data fe)
  /\ (4 | fe_ofs_link fe)
  /\ (4 | fe_ofs_retaddr fe).
Proof.
  intros; simpl.
  set (olink := 4 * b.(bound_outgoing)).
  set (ocs := olink + 4).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
  split. apply Zdivide_0.
  split. apply align_divides; omega.
  split. apply align_divides; omega.
  split. apply Z.divide_factor_l.
  apply align_divides; omega.
Qed.


Variables phi psi: Prop.

 Section landi.
  Hypothesis H1: phi.
  Hypothesis H2: psi.
  Lemma landi: phi /\ psi.
  Proof.
    split.
    - assumption.
    - assumption.
  Qed.
End landi.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-02-17
- Solange Coupet-Grimal and William Delobel, 2006-01-09

useful results on accessibility
*)

Set Implicit Arguments.

From Coq Require Import Morphisms Basics.
From Coq Require Export Wellfounded.
From CoLoR Require Import LogicUtil RelUtil.

Arguments wf_incl [A R1 R2] _ _ _.

(***********************************************************************)
(** Compatibility of accessibility wrt relation inclusion/equivalence. *)

Global Instance Acc_incl A : Proper (incl --> eq ==> impl) (@Acc A).

Proof.
  intros R R' R'R x x' xx'. subst x'. induction 1. apply Acc_intro. fo.
Qed.

Global Instance Acc_same A : Proper (same ==> eq ==> iff) (@Acc A).

Proof.
  intros R R' [RR' R'R] x x' xx'. subst x'. split; intro h.
  rewrite R'R. hyp. rewrite RR'. hyp.
Qed.

(*TODO: try to remove*)
Lemma Acc_eq_rel : forall A (R S : relation A) x,
  (forall a b, R a b <-> S a b) -> Acc R x -> Acc S x.

Proof.
  induction 2. constructor. intros z Szx; apply H1. exact (proj2 (H z x) Szx).
Qed.

Global Instance well_founded_incl A :
  Proper (incl --> impl) (@well_founded A).

Proof. intros R R' R'R h. intro x. rewrite <- R'R. fo. Qed.

Global Instance well_founded_same A : Proper (same ==> iff) (@well_founded A).

Proof.
  intros R R' [RR' R'R]. split; intro h. rewrite R'R. hyp. rewrite RR'. hyp.
Qed.

(***********************************************************************)
(** Transitive closure. *)

Section rtc.

  Variables (A : Type) (R : relation A).

  Lemma Acc_rtc : forall x y, clos_refl_trans R x y -> Acc R y -> Acc R x.

  Proof.
    induction 1.
    intro. eapply Acc_inv. apply H0. hyp.
    auto.
    intro. apply IHclos_refl_trans1. apply IHclos_refl_trans2. hyp.
  Qed.

  Lemma Acc_tc_ind : forall P : A->Prop,
    (forall x, (forall y, clos_trans R y x -> P y) -> P x)
    -> forall x, Acc R x -> P x.

  Proof.
    intros. eapply Acc_ind with (R := clos_trans R). clear x H0. intros.
    apply H. intros. apply H1. hyp.
    apply Acc_clos_trans. hyp.
  Qed.

End rtc.

(***********************************************************************)
(** Symmetric product. *)

Section symprod.

  Variables (A B : Type) (leA : relation A) (leB : relation B).

  Notation Symprod := (symprod leA leB).

  Lemma Acc_symprod_fst x : Acc Symprod x -> Acc leA (fst x).

  Proof.
    induction 1. destruct x. simpl. apply Acc_intro. intros. ded (H0 (y,b)).
    apply H2. apply left_sym. hyp.
  Qed.

  Lemma Acc_symprod_snd x : Acc Symprod x -> Acc leB (snd x).

  Proof.
    induction 1. destruct x. simpl. apply Acc_intro. intros. ded (H0 (a,y)).
    apply H2. apply right_sym. hyp.
  Qed.

  Lemma Acc_symprod_invl x y : Acc Symprod (x,y) -> Acc leA x.

  Proof. intros. ded (Acc_symprod_fst H). hyp. Qed.

  Lemma Acc_symprod_invr x y : Acc Symprod (x,y) -> Acc leB y.

  Proof. intros. ded (Acc_symprod_snd H). hyp. Qed.

  Lemma Acc_symprod_inv x y : Acc Symprod (x,y) -> Acc leA x /\ Acc leB y.

  Proof.
    intros. split. eapply Acc_symprod_invl. apply H. eapply Acc_symprod_invr.
    apply H.
  Qed.

End symprod.

(***********************************************************************)
(** Restricted accessibility. *)

Section RestrictedAcc.

  Variables (A : Type) (P : A -> Prop).

  Inductive Restricted_acc (R : relation A) : A -> Prop :=
  | Restricted_acc_cons : forall a,
    (forall a', P a' -> R a' a -> Restricted_acc R a') -> Restricted_acc R a.

  Lemma Restricted_acc_eq_acc : forall R a,
    Acc (fun a a' => P a /\ R a a') a <-> Restricted_acc R a.

  Proof.
    intros R a.
    split.
    (* => *)
    intro acc_a; induction acc_a as [a acc_a IHa].
    constructor; trivial.
    intros a' Pa' Ha'.
    apply IHa; split; trivial.
    (* <= *)
    intro Raa; induction Raa as [a Raa IHa].
    constructor.
    intros a' Ha'; elim Ha'; clear Ha'; intros Pa' Ra'a.
    apply (IHa a' Pa' Ra'a).
  Qed.

End RestrictedAcc.

(***********************************************************************)
(** List of accessible arguments. *)

From Coq Require Import List.

Definition Accs (A : Type) R l := forall a : A, In a l -> Acc R a.

(***********************************************************************)
(** Simulation and morphisms. *)

Section Accessibility.

  Variables (A B : Type) (R : relation A).

  Definition mimic (P : relation A) := forall x x', P x x' ->
    forall y', R y' x' -> exists2 y, R y x & P y y'.

  Lemma Acc_mimic : forall x (P: relation A),
    Acc R x -> mimic P -> forall x', P x x' -> Acc R x'.

  Proof.
    induction 1.
    intros mim x' Pxx'.
    constructor.
    intros y' Ry'x'.
    unfold mimic in mim.
    destruct (mim x x' Pxx' y' Ry'x') as [y Ryx Pyy'].
    apply H0 with y; trivial.
  Qed.

  Variables x y : A.

  Section AccHomo.

    Variable T : relation B.
    Variable z : B.
    Variable morphism : A -> B -> Prop.
    Variable comp : forall x y x',
      morphism x' x -> T y x -> exists2 y': A, R y' x' & morphism y' y.

    Lemma Acc_homo :
      forall x, Acc R x -> forall x', morphism x x' -> Acc T x'.

    Proof.
      induction 1.
      intros x' x0x'.
      constructor.
      intros w Twx'.
      destruct (comp x0x' Twx') as [x1 Rx x1w].
      eapply H0; eauto.
    Qed.

  End AccHomo.

  Section AccIso.

    Variable T : relation B.
    Variable z : B.
    Variable iso : A -> B -> Prop.
    Variable iso_comp : forall x y' x',
      iso x x' -> T y' x' -> {y: A | R y x & iso y y'}.

    Lemma Acc_iso : iso x z -> Acc R x -> Acc T z.

    Proof.
      intros iso_x_z Acc_x; generalize z iso_x_z; clear iso_x_z z.
      induction Acc_x as [x Acc_x Hind].
      intros z iso_x_z.
      constructor.
      intros z' T_z'_z.
      elim (iso_comp iso_x_z T_z'_z).
      intros x' Rx' iso_x'_z'.
      apply Hind with x'; hyp.
    Qed.

  End AccIso.

End Accessibility.

(***********************************************************************)
(** Wellfounded fixpoints: we extend [Fix_F_inv] to any relation [eq]. *)

Arguments Fix [A R] _ [P] _ _.
Arguments Fix_eq [A R] _ [P F] _ _.
Arguments Fix_F [A R P] _ [x] _.
Arguments Fix_F_eq [A R P] _ [x] _.
Arguments Fix_F_inv [A R] _ [P] _ _ [x] _ _.

Section Fix.

  Variables (A : Type) (R : relation A) (Rwf : well_founded R)
    (P : A -> Type) (F : forall x : A, (forall y : A, R y x -> P y) -> P x)
    (eq : forall x, relation (P x))
    (F_ext : forall x (f g : forall y, R y x -> P y),
      (forall y (p : R y x), eq (f y p) (g y p)) -> eq (F f) (F g)).

  Notation Fix_F := (Fix_F F).
  Notation Fix_F_eq := (Fix_F_eq F).
  Notation Fix := (Fix Rwf F).
  Infix "==" := eq (at level 70).

  Lemma Fix_F_inv : forall x (r s : Acc R x), Fix_F r == Fix_F s.

  Proof.
    intro x; induction (Rwf x); intros.
    rewrite <- (Fix_F_eq r), <- (Fix_F_eq s); intros.
    apply F_ext; auto.
  Qed.

  Lemma Fix_eq : forall x, Fix x == F (fun y (p : R y x) => Fix y).

  Proof.
    intro x; unfold Wf.Fix.
    rewrite <- Fix_F_eq.
    apply F_ext; intros.
    apply Fix_F_inv.
  Qed.

End Fix.

Arguments Fix_F_inv [A R] _ [P] _ _ _ [x] _ _.
Arguments Fix_eq [A R] _ [P F eq] _ _.

(***********************************************************************)
(** A well-founded relation is irreflexive. *)

Lemma wf_irrefl : forall A (R : relation A), well_founded R -> Irreflexive R.

Proof. intros A R wf x. induction (wf x). intro n. eapply H0. apply n. hyp. Qed.


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

(** Efficient implementation of [FSetInterface.S] for positive keys,
    inspired from the [FMapPositive] module.

   This module was adapted by Alexandre Ren, Damien Pous, and Thomas
   Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive]
   module of Pierre Letouzey and Jean-Christophe Filliâtre, which in
   turn comes from the [FMap] framework of a work by Xavier Leroy and
   Sandrine Blazy (used for building certified compilers).
*)

Require Import Bool BinPos OrderedType OrderedTypeEx FSetInterface.

Set Implicit Arguments.

Local Open Scope lazy_bool_scope.
Local Open Scope positive_scope.

Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.
Local Unset Boolean Equality Schemes.

Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.

  Module E:=PositiveOrderedTypeBits.

  Definition elt := positive.

  Inductive tree :=
    | Leaf : tree
    | Node : tree -> bool -> tree -> tree.

  Scheme tree_ind := Induction for tree Sort Prop.

  Definition t := tree.

  Definition empty := Leaf.

  Fixpoint is_empty (m : t) : bool :=
   match m with
    | Leaf => true
    | Node l b r => negb b &&& is_empty l &&& is_empty r
   end.

  Fixpoint mem (i : positive) (m : t) : bool :=
    match m with
    | Leaf => false
    | Node l o r =>
        match i with
        | 1 => o
        | i~0 => mem i l
        | i~1 => mem i r
        end
    end.

  Fixpoint add (i : positive) (m : t) : t :=
    match m with
    | Leaf =>
        match i with
        | 1 => Node Leaf true Leaf
        | i~0 => Node (add i Leaf) false Leaf
        | i~1 => Node Leaf false (add i Leaf)
        end
    | Node l o r =>
        match i with
        | 1 => Node l true r
        | i~0 => Node (add i l) o r
        | i~1 => Node l o (add i r)
        end
    end.

  Definition singleton i := add i empty.

  (** helper function to avoid creating empty trees that are not leaves *)

  Definition node l (b: bool) r :=
    if b then Node l b r else
     match l,r with
       | Leaf,Leaf => Leaf
       | _,_ => Node l false r end.

  Fixpoint remove (i : positive) (m : t) : t :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match i with
          | 1 => node l false r
          | i~0 => node (remove i l) o r
          | i~1 => node l o (remove i r)
        end
    end.

  Fixpoint union (m m': t) :=
    match m with
      | Leaf => m'
      | Node l o r =>
        match m' with
          | Leaf => m
          | Node l' o' r' => Node (union l l') (o||o') (union r r')
        end
    end.

  Fixpoint inter (m m': t) :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match m' with
          | Leaf => Leaf
          | Node l' o' r' => node (inter l l') (o&&o') (inter r r')
        end
    end.

  Fixpoint diff (m m': t) :=
    match m with
      | Leaf => Leaf
      | Node l o r =>
        match m' with
          | Leaf => m
          | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
        end
    end.

  Fixpoint equal (m m': t): bool :=
    match m with
      | Leaf => is_empty m'
      | Node l o r =>
        match m' with
          | Leaf => is_empty m
          | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
        end
    end.

  Fixpoint subset (m m': t): bool :=
    match m with
      | Leaf => true
      | Node l o r =>
        match m' with
          | Leaf => is_empty m
          | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
        end
    end.

  (** reverses [y] and concatenate it with [x] *)

  Fixpoint rev_append y x :=
    match y with
      | 1 => x
      | y~1 => rev_append y x~1
      | y~0 => rev_append y x~0
    end.
  Infix "@" := rev_append (at level 60).
  Definition rev x := x@1.

  Section Fold.

    Variables B : Type.
    Variable f : positive -> B -> B.

    (** the additional argument, [i], records the current path, in
       reverse order (this should be more efficient: we reverse this argument
       only at present nodes only, rather than at each node of the tree).
       we also use this convention in all functions below
     *)

    Fixpoint xfold (m : t) (v : B) (i : positive) :=
      match m with
        | Leaf => v
        | Node l true r =>
          xfold r (f (rev i) (xfold l v i~0)) i~1
        | Node l false r =>
          xfold r (xfold l v i~0) i~1
      end.
    Definition fold m i := xfold m i 1.

  End Fold.

  Section Quantifiers.

    Variable f : positive -> bool.

    Fixpoint xforall (m : t) (i : positive) :=
      match m with
        | Leaf => true
        | Node l o r =>
          (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
      end.
    Definition for_all m := xforall m 1.

    Fixpoint xexists (m : t) (i : positive) :=
      match m with
        | Leaf => false
        | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
      end.
    Definition exists_ m := xexists m 1.

    Fixpoint xfilter (m : t) (i : positive) :=
      match m with
        | Leaf => Leaf
        | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
      end.
    Definition filter m := xfilter m 1.

    Fixpoint xpartition (m : t) (i : positive) :=
      match m with
        | Leaf => (Leaf,Leaf)
        | Node l o r =>
          let (lt,lf) := xpartition l i~0 in
          let (rt,rf) := xpartition r i~1 in
             if o then
               let fi := f (rev i) in
                 (node lt fi rt, node lf (negb fi) rf)
             else
                 (node lt false rt, node lf false rf)
      end.
    Definition partition m := xpartition m 1.

  End Quantifiers.

  (** uses [a] to accumulate values rather than doing a lot of concatenations *)

  Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
    match m with
      | Leaf => a
      | Node l false r => xelements l i~0 (xelements r i~1 a)
      | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
    end.

  Definition elements (m : t) := xelements m 1 nil.

  Fixpoint cardinal (m : t) : nat :=
    match m with
      | Leaf => O
      | Node l false r => (cardinal l + cardinal r)%nat
      | Node l true r => S (cardinal l + cardinal r)
    end.

  Definition omap (f: elt -> elt) x :=
    match x with
      | None => None
      | Some i => Some (f i)
    end.

  (** would it be more efficient to use a path like in the above functions ? *)

  Fixpoint choose (m: t) :=
    match m with
      | Leaf => None
      | Node l o r => if o then Some 1 else
        match choose l with
          | None => omap xI (choose r)
          | Some i => Some i~0
        end
    end.

  Fixpoint min_elt (m: t) :=
    match m with
      | Leaf => None
      | Node l o r =>
        match min_elt l with
          | None => if o then Some 1 else omap xI (min_elt r)
          | Some i => Some i~0
        end
    end.

  Fixpoint max_elt (m: t) :=
    match m with
      | Leaf => None
      | Node l o r =>
        match max_elt r with
          | None => if o then Some 1 else omap xO (max_elt l)
          | Some i => Some i~1
        end
    end.

  (** lexicographic product, defined using a notation to keep things lazy *)

  Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.

  Definition compare_bool a b :=
    match a,b with
      | false, true => Lt
      | true, false => Gt
      | _,_ => Eq
    end.

  Fixpoint compare_fun (m m': t): comparison :=
    match m,m' with
      | Leaf,_ => if is_empty m' then Eq else Lt
      | _,Leaf => if is_empty m then Eq else Gt
      | Node l o r,Node l' o' r' =>
        lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r'))
    end.

  Definition In i t := mem i t = true.
  Definition Equal s s' := forall a : elt, In a  s <-> In a  s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.

  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).

  Definition eq := Equal.
  Definition lt m m' := compare_fun m m' = Lt.

  (** Specification of [In] *)

  Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s.
  Proof. intros s x y ->. trivial. Qed.

  (** Specification of [eq] *)

  Lemma eq_refl: forall s, eq s s.
  Proof. unfold eq, Equal. reflexivity. Qed.

  Lemma eq_sym: forall s s', eq s s' -> eq s' s.
  Proof. unfold eq, Equal. intros. symmetry. trivial. Qed.

  Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
  Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed.

  (** Specification of [mem] *)

  Lemma mem_1: forall s x, In x s -> mem x s = true.
  Proof. unfold In. trivial. Qed.

  Lemma mem_2: forall s x, mem x s = true -> In x s.
  Proof. unfold In. trivial. Qed.

  (** Additional lemmas for mem  *)

  Lemma mem_Leaf: forall x, mem x Leaf = false.
  Proof. destruct x; trivial. Qed.

  (** Specification of [empty] *)

  Lemma empty_1 : Empty empty.
  Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.

  (** Specification of node  *)

  Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
  Proof.
    intros x l o r.
    case o; trivial.
    destruct l; trivial.
    destruct r; trivial.
    symmetry. destruct x.
      apply mem_Leaf.
      apply mem_Leaf.
      reflexivity.
  Qed.
  Local Opaque node.

  (** Specification of [is_empty] *)

  Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true.
  Proof.
    unfold Empty, In.
    induction s as [|l IHl o r IHr]; simpl.
      setoid_rewrite mem_Leaf. firstorder.
      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr.
      destruct o; simpl; split.
        intro H. elim (H 1). reflexivity.
        intuition discriminate.
        intro H. split. split. reflexivity.
          intro a. apply (H a~0).
          intro a. apply (H a~1).
        intros H [a|a|]; apply H || intro; discriminate.
  Qed.

  Lemma is_empty_1: forall s, Empty s -> is_empty s = true.
  Proof. intro. rewrite is_empty_spec. trivial. Qed.

  Lemma is_empty_2: forall s, is_empty s = true -> Empty s.
  Proof. intro. rewrite is_empty_spec. trivial. Qed.

  (** Specification of [subset] *)

  Lemma subset_Leaf_s: forall s, Leaf [<=] s.
  Proof. intros s i Hi. elim (empty_1 Hi). Qed.

  Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true.
  Proof.
    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
      split; intros. reflexivity. apply subset_Leaf_s.

      split; intros. reflexivity. apply subset_Leaf_s.

      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec.
      destruct o; simpl.
        split.
          intro H. elim (@empty_1 1). apply H. reflexivity.
          intuition discriminate.
        split; intro H.
          split. split. reflexivity.
          unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption.
          unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption.
          destruct H as [[_ Hl] Hr].
          intros [i|i|] Hi.
            elim (Hr i Hi).
            elim (Hl i Hi).
            discriminate.

      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear.
      destruct o; simpl.
       split; intro H.
         split. split.
          destruct o'; trivial.
          specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
          intros i Hi. apply (H i~0). apply Hi.
          intros i Hi. apply (H i~1). apply Hi.
         destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
          intros i Hi. destruct i.
            apply (Hr i). assumption.
            apply (Hl i). assumption.
            assumption.
       split; intros.
         split. split. reflexivity.
           intros i Hi. apply (H i~0). apply Hi.
           intros i Hi. apply (H i~1). apply Hi.
           intros i Hi. destruct i; destruct H as [[H Hl] Hr].
             apply (Hr i). assumption.
             apply (Hl i). assumption.
             discriminate Hi.
  Qed.

  Lemma subset_1: forall s s', Subset s s' -> subset s s' = true.
  Proof. intros s s'. apply -> subset_spec; trivial. Qed.

  Lemma subset_2: forall s s', subset s s' = true -> Subset s s'.
  Proof. intros s s'. apply <- subset_spec; trivial. Qed.

  (** Specification of [equal] (via subset) *)

  Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
  Proof.
    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
      destruct o. reflexivity. rewrite andb_comm. reflexivity.
      rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
       rewrite 7andb_true_iff, eqb_true_iff.
      rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
       destruct o'; reflexivity.
       destruct o'; reflexivity.
       destruct o; auto. destruct o'; trivial.
  Qed.

  Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true.
  Proof.
    intros. rewrite equal_subset. rewrite andb_true_iff.
    rewrite <- 2subset_spec. unfold Equal, Subset. firstorder.
  Qed.

  Lemma equal_1: forall s s', Equal s s' -> equal s s' = true.
  Proof. intros s s'. apply -> equal_spec; trivial. Qed.

  Lemma equal_2: forall s s', equal s s' = true -> Equal s s'.
  Proof. intros s s'. apply <- equal_spec; trivial. Qed.

  Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
  Proof.
    unfold eq.
    intros. case_eq (equal s s'); intro H.
     left. apply equal_2, H.
     right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate).
  Defined.

  (** (Specified) definition of [compare] *)

  Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
    lex u v = CompOpp (lex u' v').
  Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed.

  Lemma compare_bool_inv: forall b b',
    compare_bool b b' = CompOpp (compare_bool b' b).
  Proof. intros [|] [|]; reflexivity. Qed.

  Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s).
  Proof.
    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
    unfold compare_fun. case is_empty; reflexivity.
    unfold compare_fun. case is_empty; reflexivity.
    simpl. rewrite compare_bool_inv.
     case compare_bool; simpl; trivial; apply lex_Opp; auto.
  Qed.

  Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
  Proof. intros u v; destruct u; intuition discriminate. Qed.

  Lemma compare_bool_Eq: forall b1 b2,
    compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
  Proof. intros [|] [|]; intuition discriminate. Qed.

  Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true.
  Proof.
    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
     simpl. tauto.
     unfold compare_fun, equal. case is_empty; intuition discriminate.
     unfold compare_fun, equal. case is_empty; intuition discriminate.
     simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
     rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
     rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
  Qed.

  Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s.
  Proof.
    unfold lt. intros s s'. rewrite compare_inv.
     case compare_fun; trivial; intros; discriminate.
  Qed.

  Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'.
  Proof.
    unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
  Qed.

  Lemma compare : forall s s' : t, Compare lt eq s s'.
  Proof.
    intros. case_eq (compare_fun s s'); intro H.
    apply EQ. apply compare_eq, H.
    apply LT. assumption.
    apply GT. apply compare_gt, H.
  Defined.

  Section lt_spec.

  Inductive ct: comparison -> comparison -> comparison -> Prop :=
  | ct_xxx: forall x, ct x  x  x
  | ct_xex: forall x, ct x  Eq x
  | ct_exx: forall x, ct Eq x  x
  | ct_glx: forall x, ct Gt Lt x
  | ct_lgx: forall x, ct Lt Gt x.

  Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
  Proof. destruct x; constructor. Qed.

  Lemma ct_lxl: forall x, ct Lt x Lt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_gxg: forall x, ct Gt x Gt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xll: forall x, ct x Lt Lt.
  Proof. destruct x; constructor. Qed.

  Lemma ct_xgg: forall x, ct x Gt Gt.
  Proof. destruct x; constructor. Qed.

  Local Hint Constructors ct: ct.
  Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
  Ltac ct := trivial with ct.

  Lemma ct_lex: forall u v w u' v' w',
    ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
  Proof.
    intros u v w u' v' w' H H'.
    inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
  Qed.

  Lemma ct_compare_bool:
    forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
  Proof.
    intros [|] [|] [|]; constructor.
  Qed.

  Lemma compare_x_Leaf: forall s,
    compare_fun s Leaf = if is_empty s then Eq else Gt.
  Proof.
    intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
  Qed.

  Lemma compare_empty_x: forall a, is_empty a = true ->
    forall b, compare_fun a b = if is_empty b then Eq else Lt.
  Proof.
    induction a as [|l IHl o r IHr]; trivial.
    destruct o. intro; discriminate.
    simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
    intros [Hl Hr].
    destruct b as [|l' [|] r']; simpl compare_fun; trivial.
     rewrite Hl, Hr. trivial.
     rewrite (IHl Hl), (IHr Hr). simpl.
     case (is_empty l'); case (is_empty r'); trivial.
  Qed.

  Lemma compare_x_empty: forall a, is_empty a = true ->
    forall b, compare_fun b a = if is_empty b then Eq else Gt.
  Proof.
    setoid_rewrite <- compare_x_Leaf.
    intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
  Qed.

  Lemma ct_compare_fun:
    forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c).
  Proof.
    induction a as [|l IHl o r IHr]; intros s' s''.
     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
      rewrite compare_inv. ct.
      unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'.
       rewrite (compare_empty_x _ H'). ct.
       unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
        rewrite (compare_x_empty _ H''), H'. ct.
        ct.

     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
      ct.
      unfold compare_fun at 2. rewrite compare_x_Leaf.
      case_eq (is_empty (Node l o r)); intro H.
       rewrite (compare_empty_x _ H). ct.
       case_eq (is_empty (Node l'' o'' r'')); intro H''.
        rewrite (compare_x_empty _ H''), H. ct.
        ct.

      rewrite 2 compare_x_Leaf.
      case_eq (is_empty (Node l o r)); intro H.
       rewrite compare_inv, (compare_x_empty _ H). ct.
       case_eq (is_empty (Node l' o' r')); intro H'.
        rewrite (compare_x_empty _ H'), H. ct.
        ct.

      simpl compare_fun. apply ct_lex. apply ct_compare_bool.
       apply ct_lex; trivial.
  Qed.

  End lt_spec.

  Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''.
  Proof.
    unfold lt. intros a b c. assert (H := ct_compare_fun a b c).
    inversion_clear H; trivial; intros; discriminate.
  Qed.

  Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'.
  Proof.
    unfold lt, eq. intros s s' H H'.
     rewrite equal_spec, <- compare_equal in H'. congruence.
  Qed.

  (** Specification of [add] *)

  Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s.
  Proof.
    unfold In. induction x; intros [y|y|] [|l o r]; simpl mem;
    try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
  Qed.

  Lemma add_1: forall s x y, x = y -> In y (add x s).
  Proof. intros. apply <- add_spec. left. assumption. Qed.

  Lemma add_2: forall s x y, In y s -> In y (add x s).
  Proof. intros. apply <- add_spec. right. assumption. Qed.

  Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s.
  Proof.
    intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial.
  Qed.

  (** Specification of [remove] *)

  Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s.
  Proof.
    unfold In.
    induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
     simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
     intuition congruence.
  Qed.

  Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s).
  Proof. intros. rewrite remove_spec. tauto. Qed.

  Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s).
  Proof. intros. rewrite remove_spec. split; assumption. Qed.

  Lemma remove_3: forall s x y, In y (remove x s) -> In y s.
  Proof. intros s x y. rewrite remove_spec. tauto. Qed.

  (** Specification of [singleton] *)

  Lemma singleton_1: forall x y, In y (singleton x) -> x=y.
  Proof.
    unfold singleton. intros x y. rewrite add_spec.
    unfold In. rewrite mem_Leaf. intuition discriminate.
  Qed.

  Lemma singleton_2: forall x y, x = y -> In y (singleton x).
  Proof.
    unfold singleton. intros. apply add_1. assumption.
  Qed.

  (** Specification of [union] *)

  Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'.
  Proof.
    unfold In.
    induction x; destruct s; destruct s'; simpl union; simpl mem;
      try (rewrite IHx; clear IHx); try intuition congruence.
      apply orb_true_iff.
  Qed.

  Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'.
  Proof. intros. apply -> union_spec. assumption. Qed.

  Lemma union_2: forall s s' x, In x s -> In x (union s s').
  Proof. intros. apply <- union_spec. left. assumption. Qed.

  Lemma union_3: forall s s' x, In x s' -> In x (union s s').
  Proof. intros. apply <- union_spec. right. assumption. Qed.

  (** Specification of [inter] *)

  Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'.
  Proof.
    unfold In.
    induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
     simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
     apply andb_true_iff.
  Qed.

  Lemma inter_1: forall s s' x, In x (inter s s') -> In x s.
  Proof. intros s s' x. rewrite inter_spec. tauto. Qed.

  Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'.
  Proof. intros s s' x. rewrite inter_spec. tauto. Qed.

  Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s').
  Proof. intros. rewrite inter_spec. split; assumption. Qed.

  (** Specification of [diff] *)

  Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'.
  Proof.
    unfold In.
    induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
     rewrite ?mem_node; simpl mem;
      try (rewrite IHx; clear IHx); try intuition congruence.
      rewrite andb_true_iff. destruct o'; intuition discriminate.
  Qed.

  Lemma diff_1: forall s s' x, In x (diff s s') -> In x s.
  Proof. intros s s' x. rewrite diff_spec. tauto. Qed.

  Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'.
  Proof. intros s s' x. rewrite diff_spec. tauto. Qed.

  Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s').
  Proof. intros. rewrite diff_spec. split; assumption. Qed.

  (** Specification of [fold] *)

  Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A),
      fold f s i = fold_left (fun a e => f e a) (elements s) i.
  Proof.
    unfold fold, elements. intros s A i f. revert s i.
    set (f' := fun a e => f e a).
    assert (H: forall s i j acc,
      fold_left f' acc (xfold f s i j) =
      fold_left f' (xelements s j acc) i).

    induction s as [|l IHl o r IHr]; intros; trivial.
      destruct o; simpl xelements; simpl xfold.
        rewrite IHr, <- IHl. reflexivity.
        rewrite IHr. apply IHl.

    intros. exact (H s i 1 nil).
  Qed.

  (** Specification of [cardinal] *)

  Lemma cardinal_1: forall s, cardinal s = length (elements s).
  Proof.
    unfold elements.
    assert (H: forall s j acc,
                (cardinal s + length acc)%nat = length (xelements s j acc)).

    induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
      rewrite <- IHl. simpl. rewrite <- IHr.
       rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
      rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.

    intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
  Qed.

  (** Specification of [filter] *)

  Lemma xfilter_spec: forall f s x i,
    In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
  Proof.
    intro f. unfold In.
    induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
     rewrite mem_Leaf. intuition discriminate.
     rewrite mem_node. destruct x; simpl.
       rewrite IHr. reflexivity.
       rewrite IHl. reflexivity.
       rewrite <- andb_lazy_alt. apply andb_true_iff.
  Qed.

  Lemma filter_1 : forall s x f, compat_bool E.eq f ->
    In x (filter f s) -> In x s.
  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.

  Lemma filter_2 : forall s x f, compat_bool E.eq f ->
    In x (filter f s) -> f x = true.
  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.

  Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s ->
    f x = true -> In x (filter f s).
  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.

  (** Specification of [for_all] *)

  Lemma xforall_spec: forall f s i,
    xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
  Proof.
    unfold For_all, In. intro f.
    induction s as [|l IHl o r IHr]; intros i; simpl.
     setoid_rewrite mem_Leaf. intuition discriminate.
     rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
     rewrite IHl, IHr. clear IHl IHr.
      split.
       intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
        apply Hr, H.
        apply Hl, H.
        rewrite H in Hi. assumption.
       intro H; intuition.
        specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
        apply H. assumption.
        apply H. assumption.
  Qed.

  Lemma for_all_1 : forall s f, compat_bool E.eq f ->
    For_all (fun x => f x = true) s -> for_all f s = true.
  Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.

  Lemma for_all_2 : forall s f, compat_bool E.eq f ->
    for_all f s = true -> For_all (fun x => f x = true) s.
  Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.

  (** Specification of [exists] *)

  Lemma xexists_spec: forall f s i,
    xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
  Proof.
    unfold Exists, In. intro f.
    induction s as [|l IHl o r IHr]; intros i; simpl.
     setoid_rewrite mem_Leaf. firstorder.
     rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
     rewrite IHl, IHr. clear IHl IHr.
      split.
       intros [[Hi|[x Hr]]|[x Hl]].
        exists 1. exact Hi.
        exists x~1. exact Hr.
        exists x~0. exact Hl.
       intros [[x|x|] H]; eauto.
  Qed.

  Lemma exists_1 : forall s f, compat_bool E.eq f ->
      Exists (fun x => f x = true) s -> exists_ f s = true.
  Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.

  Lemma exists_2 : forall s f, compat_bool E.eq f ->
      exists_ f s = true -> Exists (fun x => f x = true) s.
  Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.

  (** Specification of [partition] *)

  Lemma partition_filter : forall s f,
    partition f s = (filter f s, filter (fun x => negb (f x)) s).
  Proof.
    unfold partition, filter. intros s f. generalize 1 as j.
    induction s as [|l IHl o r IHr]; intro j.
      reflexivity.
      destruct o; simpl; rewrite IHl, IHr; reflexivity.
  Qed.

  Lemma partition_1 : forall s f, compat_bool E.eq f ->
      Equal (fst (partition f s)) (filter f s).
  Proof. intros. rewrite partition_filter. apply eq_refl. Qed.

  Lemma partition_2 : forall s f, compat_bool E.eq f ->
      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof. intros. rewrite partition_filter. apply eq_refl. Qed.

  (** Specification of [elements] *)

  Notation InL := (InA E.eq).

  Lemma xelements_spec: forall s j acc y,
    InL y (xelements s j acc)
    <->
    InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
  Proof.
    induction s as [|l IHl o r IHr]; simpl.
      intros. split; intro H.
        left. assumption.
        destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx').

      intros j acc y. case o.
        rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
          intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
            right. exists x~1. auto.
            right. exists x~0. auto.
          intros [H|[x [-> H]]].
            eauto.
            destruct x.
              left. right. right. exists x; auto.
              right. exists x; auto.
              left. left. reflexivity.

        rewrite IHl, IHr. clear IHl IHr. split.
          intros [[H|[x [-> H]]]|[x [-> H]]].
            eauto.
            right. exists x~1. auto.
            right. exists x~0. auto.
          intros [H|[x [-> H]]].
            eauto.
            destruct x.
              left. right.  exists x; auto.
              right. exists x; auto.
              discriminate.
  Qed.

  Lemma elements_1: forall s x, In x s -> InL x (elements s).
  Proof.
    unfold elements, In. intros.
    rewrite xelements_spec. right. exists x. auto.
  Qed.

  Lemma elements_2: forall s x, InL x (elements s) -> In x s.
  Proof.
    unfold elements, In. intros s x H.
    rewrite xelements_spec in H. destruct H as [H|[y [H H']]].
      inversion_clear H.
      rewrite H. assumption.
  Qed.

  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
  Proof. induction j; intros; simpl; auto. Qed.

  Lemma elements_3: forall s, sort E.lt (elements s).
  Proof.
    unfold elements.
    assert (H: forall s j acc,
      sort E.lt acc ->
      (forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
      sort E.lt (xelements s j acc)).

    induction s as [|l IHl o r IHr]; simpl; trivial.
    intros j acc Hacc Hsacc. destruct o.
      apply IHl. constructor.
       apply IHr. apply Hacc.
       intros x y Hx Hy. apply Hsacc; assumption.
       case_eq (xelements r j~1 acc). constructor.
       intros z q H. constructor.
       assert (H': InL z (xelements r j~1 acc)).
        rewrite H. constructor. reflexivity.
       clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
         apply (Hsacc 1 z); trivial. reflexivity.
         simpl. apply lt_rev_append. exact I.
       intros x y Hx Hy. inversion_clear Hy.
         rewrite H. simpl. apply lt_rev_append. exact I.
         rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
           apply Hsacc; assumption.
           simpl. apply lt_rev_append. exact I.

      apply IHl. apply IHr. apply Hacc.
       intros x y Hx Hy. apply Hsacc; assumption.
       intros x y Hx Hy. rewrite xelements_spec in Hy.
        destruct Hy as [Hy|[z [-> Hy]]].
         apply Hsacc; assumption.
         simpl. apply lt_rev_append. exact I.

    intros. apply H. constructor.
      intros x y _ H'. inversion H'.
  Qed.

  Lemma elements_3w: forall s, NoDupA E.eq (elements s).
  Proof.
    intro. apply SortA_NoDupA with E.lt.
      constructor.
       intro. apply E.eq_refl.
       intro. apply E.eq_sym.
       intro. apply E.eq_trans.
      constructor.
       intros x H. apply E.lt_not_eq in H. apply H. reflexivity.
       intro. apply E.lt_trans.
      intros ? ? <- ? ? <-. reflexivity.
      apply elements_3.
  Qed.

  (** Specification of [choose] *)

  Lemma choose_1: forall s x, choose s = Some x -> In x s.
  Proof.
    induction s as [| l IHl o r IHr]; simpl.
      intros. discriminate.
      destruct o.
        intros x H. injection H; intros; subst. reflexivity.
        revert IHl. case choose.
          intros p Hp x H. injection H; intros; subst; clear H. apply Hp.
           reflexivity.
          intros _ x. revert IHr. case choose.
            intros p Hp H. injection H; intros; subst; clear H. apply Hp.
            reflexivity.
            intros. discriminate.
  Qed.

  Lemma choose_2: forall s, choose s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_1.
      destruct o.
        discriminate.
        simpl in H. destruct (choose l).
          discriminate.
          destruct (choose r).
            discriminate.
            intros [a|a|].
              apply IHr. reflexivity.
              apply IHl. reflexivity.
              discriminate.
  Qed.

  Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
  Proof.
    intros s Hs. case_eq (choose s); trivial.
    intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp).
  Qed.

  Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'.
  Proof.
    setoid_rewrite equal_spec.
    induction s as [|l IHl o r IHr].
      intros. symmetry. apply choose_empty. assumption.

      destruct s' as [|l' o' r'].
        generalize (Node l o r) as s. simpl. intros. apply choose_empty.
        rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H.
        assumption.

        simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
        intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
  Qed.

  Lemma choose_3: forall s s' x y,
    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
  Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed.

  (** Specification of [min_elt] *)

  Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s.
  Proof.
   unfold In.
   induction s as [| l IHl o r IHr]; simpl.
     intros. discriminate.
     intros x. destruct (min_elt l); intros.
       injection H. intros <-. apply IHl. reflexivity.
       destruct o; simpl.
         injection H. intros <-. reflexivity.
         destruct (min_elt r); simpl in *.
           injection H. intros <-. apply IHr. reflexivity.
           discriminate.
  Qed.

  Lemma min_elt_3: forall s, min_elt s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_1.
      intros [a|a|].
        apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
          case min_elt; intros; try discriminate. destruct o; discriminate.
        apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
         intro; discriminate.
        revert H. clear. simpl. case min_elt; intros; try discriminate.
         destruct o; discriminate.
  Qed.

  Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
  Proof.
    unfold In.
    induction s as [|l IHl o r IHr]; intros x y H H'.
      discriminate.
      simpl in H. case_eq (min_elt l).
        intros p Hp. rewrite Hp in H. injection H; intros <-.
        destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
        intro Hp; rewrite Hp in H. apply min_elt_3 in Hp.
        destruct o.
          injection H. intros <- Hl. clear H.
          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

          destruct (min_elt r).
            injection H. intros <-. clear H.
            destruct y as [z|z|].
              apply (IHr p z); trivial.
              elim (Hp _ H').
              discriminate.
            discriminate.
  Qed.

  (** Specification of [max_elt] *)

  Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s.
  Proof.
   unfold In.
   induction s as [| l IHl o r IHr]; simpl.
     intros. discriminate.
     intros x. destruct (max_elt r); intros.
       injection H. intros <-. apply IHr. reflexivity.
       destruct o; simpl.
         injection H. intros <-. reflexivity.
         destruct (max_elt l); simpl in *.
           injection H. intros <-. apply IHl. reflexivity.
           discriminate.
  Qed.

  Lemma max_elt_3: forall s, max_elt s = None -> Empty s.
  Proof.
    unfold Empty, In. intros s H.
    induction s as [|l IHl o r IHr].
      intro. apply empty_1.
      intros [a|a|].
        apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
         intro; discriminate.
        apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
          case max_elt; intros; try discriminate. destruct o; discriminate.
        revert H. clear. simpl. case max_elt; intros; try discriminate.
         destruct o; discriminate.
  Qed.

  Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
  Proof.
    unfold In.
    induction s as [|l IHl o r IHr]; intros x y H H'.
      discriminate.
      simpl in H. case_eq (max_elt r).
        intros p Hp. rewrite Hp in H. injection H; intros <-.
        destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
        intro Hp; rewrite Hp in H. apply max_elt_3 in Hp.
        destruct o.
          injection H. intros <- Hl. clear H.
          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').

          destruct (max_elt l).
            injection H. intros <-. clear H.
            destruct y as [z|z|].
              elim (Hp _ H').
              apply (IHl p z); trivial.
              discriminate.
            discriminate.
  Qed.

End PositiveSet.


Require Export Coq.Unicode.Utf8.
Require Export FSubRcd.

(******************************************************************************)
(* Record lookups                                                             *)
(******************************************************************************)

Lemma eq_lab_dec (l k: Lab) : {l = k} + {l ≠ k}.
Proof.
  decide equality .
Qed.

Fixpoint trec_get (Tr : TRec) (l : Lab) : option Ty :=
  match Tr with
  | tcons k T Tr => if eq_lab_dec l k then Some T else trec_get Tr l
  | tnil         => None
  end.
Coercion trec_get : TRec >-> Funclass.

Fixpoint rec_get (tr : Rec) (l : Lab) : (option Tm) :=
  match tr with
  | rcons k t tr => if eq_lab_dec l k then Some t else rec_get tr l
  | rnil         => None
  end.

Coercion rec_get : Rec >-> Funclass.

Fixpoint prec_get (pr : PRec) (l : Lab) : (option Pat) :=
  match pr with
  | pcons k p pr => if eq_lab_dec l k then Some p else prec_get pr l
  | pnil         => None
  end.

Coercion prec_get : PRec >-> Funclass.

(******************************************************************************)
(* Subtyping relation                                                         *)
(******************************************************************************)

Inductive Sub (Γ: Env) : Ty → Ty → Prop :=
  | SA_Top {S} (wf_S: wfTy (domainEnv Γ) S) :
      Sub Γ S top
  | SA_Refl_TVar {X} :
      wfindex (domainEnv Γ) X → Sub Γ (tvar X) (tvar X)
  | SA_Trans_TVar {X T U} :
      lookup_etvar Γ X U → Sub Γ U T → Sub Γ (tvar X) T
  | SA_Arrow {T1 T2 S1 S2} :
      Sub Γ T1 S1 → Sub Γ S2 T2 → Sub Γ (tarr S1 S2) (tarr T1 T2)
  | SA_All {T1 T2 S1 S2} :
      Sub Γ T1 S1 → Sub (etvar Γ T1) S2 T2 → Sub Γ (tall S1 S2) (tall T1 T2)
  | SA_Rcd {Sr Tr : TRec}
      (wSr: wfTRec (domainEnv Γ) Sr)
      (wTr: wfTRec (domainEnv Γ) Tr)
      (incl: ∀ l T, Tr l = Some T → ∃ S, Sr l = Some S)
      (subs: ∀ l S T, Tr l = Some T → Sr l = Some S → Sub Γ S T) :
      Sub Γ (trec Sr) (trec Tr).

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive PTyping (Γ: Env) : Pat → Ty → Env → Prop :=
  | P_Var {T} (wT: wfTy (domainEnv Γ) T) :
      PTyping Γ (pvar T) T (evar empty T)
  | P_Rcd {Δ pr Tr} :
      PRTyping Γ pr Tr Δ →
      PTyping Γ (prec pr) (trec Tr) Δ
with PRTyping (Γ : Env) : PRec → TRec → Env → Prop :=
  | P_Rcd_Cons {Δp Δpr l p pr Tp Tr} :
      PTyping Γ p Tp Δp →
      PRTyping
        (appendEnv Γ Δp)
        (weakenPRec pr (domainEnv Δp))
        (weakenTRec Tr (domainEnv Δp)) Δpr →
      Tr l = None →
      PRTyping Γ (pcons l p pr) (tcons l Tp Tr) (appendEnv Δp Δpr)
  | P_Rcd_Nil :
      PRTyping Γ pnil tnil (empty).

Scheme ind_ptyping := Induction for PTyping Sort Prop
with ind_prtyping := Induction for PRTyping Sort Prop.
Combined Scheme ind_ptyping_prtyping from
  ind_ptyping, ind_prtyping.

Inductive Typing (Γ : Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Abs {t T1 T2} (wf_T1: wfTy (domainEnv Γ) T1) :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (FSubRcd.app t1 t2) T12
  | T_Tabs {t T1 T2} (wf_T1: wfTy (domainEnv Γ) T1) :
      Typing (etvar Γ T1) t T2 →
      Typing Γ (tabs T1 t) (tall T1 T2)
  | T_Tapp {t1 T11 T12 T2} :
      Typing Γ t1 (tall T11 T12) → Sub Γ T2 T11 →
      Typing Γ (tapp t1 T2) (tsubstTy X0 T2 T12)
  | T_Let {p t1 t2 T1 T2 Δ} :
      Typing Γ t1 T1 → PTyping Γ p T1 Δ →
      Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) →
      Typing Γ (lett p t1 t2) T2
  | T_Rcd {tr Tr} :
      RTyping Γ tr Tr →
      Typing Γ (rec tr) (trec Tr)
  | T_Proj {tr l T} {Tr: TRec} (lIn: Tr l = Some T) :
      Typing Γ tr (trec Tr) →
      Typing Γ (prj tr l) T
  | T_Sub {t T1 T2} :
      Typing Γ t T1 → Sub Γ T1 T2 →
      Typing Γ t T2
with RTyping (Γ : Env) : Rec → TRec → Prop :=
  | T_Rcd_Nil :
      RTyping Γ rnil tnil
  | T_Rcd_Cons {l t T tr Tr} :
      Typing Γ t T →
      RTyping Γ tr Tr →
      (*tr l = None →
      Tr l = None → *)
      RTyping Γ (rcons l t tr) (tcons l T Tr).

Scheme ind_typing := Induction for Typing Sort Prop
with ind_rtyping := Induction for RTyping Sort Prop.
Combined Scheme ind_typing_rtyping from
  ind_typing, ind_rtyping.