Require Import BenB.

(* Domeinen *)
Definition T := R.
  (* Betekenis: Tijd in minuten in reele getallen. *)
Variable A : Set.
  (* Betekenis: De verzameling auto's. *)
Definition G := R.
  (* Betekenis: De verzameling geldbedragen in euro's. *)

(* Predikaten *)
Variable autoAangeleverd (* t a *): T -> A -> B.
  (* Auto a staat in de entreeruimte op tijdstip t. *)
  (* Kijk of de auto er staat op dat moment. *)
Variable autoUitgeleverd (* t a *): T -> A -> B.
  (* Auto a staat in de uitleverruimte op tijdstip t. *)
  (* Kijk of de auto er staat op dat moment. *)
Variable pasUitgegeven (* t a *): T -> A -> B.
  (* Pasje is uitgegeven voor auto a op tijdstip t. *)
  (* Voel in het bakje op dat moment. *)
Variable geldBetaald (* t g *): T -> G -> B.
  (* Geldbedrag g is in de betaalautomaat gestopt op tijdstip t. *)
  (* Kijk op het display op dat moment. *)
Variable inBerging (* t a *): T -> A -> B.
  (* Auto a staat in berging op tijdstip t. *)
  (* Doorzoek de berging op dat moment. *)
Variable autoOpgeborgenBericht (* t a *): T -> A -> B.
  (* Signaal dat auto a in berging staat op tijdstip t. *)
  (* Meet spanning op de verbindingskabel op dat moment. *)
Variable isBetaaldBericht (* t a *): T -> A -> B.
  (* Signaal dat er betaald is voor auto a op tijdstip t. *)
  (* Meet spanning op de verbindingskabel op dat moment. *)
Variable uitBerging (* t a *): T -> A -> B.
  (* Auto a gaat naar uitleverruimte op tijdstip t. *)
  (* Luister of je de machine hoort werken op dat moment. *)

(* Functies *)
(* Tijdens het college zijn we hier niet aan toegekomen, maar het
   is noodzakelijk om aan de hand van een tijd(sduur) een
   verschuldigd bedrag te kunnen bepalen.

   Dat kan via functies en wel op twee manieren:

   1. Met een abstracte functie via Variable:

      Variable tijdIsGeld : T -> G.

      Hierbij wordt alleen maar vastgelegd dat er een orakel is dat bij een
      gegeven tijd(sduur) een bedrag berekent, zonder te zeggen hoe dat
      precies gebeurt.

   2. Met een concrete functie via Definition:

      Definition tijdIsGeld (d:T) := d.

      Hierbij wordt vastgelegd dat er (zoals in de spec staat) voor
      d minuten parkeren d euro moet worden betaald.

   De tweede manier maakt echter stiekem gebruik van het feit dat Coq
   geen onderscheid ziet tussen de verzamelingen T en G, want het zijn
   allebei kopieen van de reele getallen.

   Daarom kiezen we voor de eerste manier.
*)

Variable tijdIsGeld : T -> G.

(* Specificaties onderdelen *)

Definition Opberger :=
(*! term *)

forall t:T,
  forall a:A,
      autoAangeleverd t a
    ->
        inBerging (t+1) a
      /\
        autoOpgeborgenBericht (t+2) a

.

Definition Pasuitgaveautomaat :=
(*! term *)

forall t:T,
  forall a:A,
      autoOpgeborgenBericht t a
    ->
      pasUitgegeven t a

.

Definition Berging :=
(*! term *)

forall t:T,
  forall a:A,
      inBerging t a
    ->
        (~isBetaaldBericht (t+1) a  /\ inBerging (t+1) a)
      \/
        (isBetaaldBericht (t+1) a  /\ autoUitgeleverd (t+1) a)

.

(* De specificatie van de overige onderdelen hebben we niet in het college
   behandeld.
   Die moet u dan ook zelf bedenken.
*)

Definition Betaalautomaat :=
(*! term *)
(* Waarschijnlijk heeft u hier ergens de functie tijdIsGeld nodig
   om een tijd(sduur) te converteren naar een geldbedrag.
   We hebben dat hier gedaan met een abstracte functie.
   Zie de uitleg onder Functies.
*)
forall t:T,
  forall a:A,
    forall d:T,
        pasUitgegeven t a /\ geldBetaald (t+d) (tijdIsGeld d)
      ->
        isBetaaldBericht (t+d) a
.

Definition Uitvoerplatform :=
(*! term *)
forall t:T,
  forall a:A,
      isBetaaldBericht t a /\ uitBerging t a
    ->
      autoUitgeleverd t a
.

(* Specificatie van het geheel *)

(* De specificatie van het geheel hebben we ook niet behandeld,
   maar hier is een suggestie.
*)

Definition Parkeergarage :=
(*! term *)

forall a:A,
  forall t:T,
     forall d:T,
           autoAangeleverd t a
        /\
           geldBetaald (t+d) (tijdIsGeld d)
     ->
        autoUitgeleverd (t+d+1) a

.

(* Correctheidsstelling *)

(* Omdat we hem nu toch nog niet kunnen bewijzen zetten we hem
   tussen commentaar, want anders klaagt de verifier dat er
   'pending proofs' zijn en komt er een rood kruisje.
Theorem CorStelling :
    Opberger
  /\
    Pasuitgaveautomaat
  /\
    Berging
  /\
    Betaalautomaat
  /\
    Uitvoerplatform
->
  Parkeergarage
.
*)


Section ml.
Variables A:Prop.
Theorem InDN: A -> ~~A.
Proof.
    intro Ha.
    intro NotA.
    (* contradiction. *)
    apply NotA.
    assumption.
Qed.
End ml.

Check InDN.


Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.Judgments.
Require Export SystemFR.RedTactics.
Require Export SystemFR.EquivalentContext.

Opaque reducible_values.

Lemma annotated_equivalent_pair_ext:
  forall Θ Γ t A B,
    is_annotated_term t ->
    wf t 0 ->
    [[ Θ; Γ ⊨ t: T_prod A B ]] ->
    [[ Θ; Γ ⊨ t ≡ pp (pi1 t) (pi2 t) ]].
Proof.
  unfold open_reducible, reduces_to, open_equivalent;
    repeat step || t_instantiate_sat3 || simp_red.

  apply equivalent_trans with (pp a b).
  - equivalent_star; t_closer.
  - apply equivalent_trans with (pp (pi1 (psubstitute (erase_term t) l term_var) ) b).
    + unshelve epose proof (equivalent_context (pp (lvar 0 term_var) b) a (pi1 (psubstitute (erase_term t) l term_var)) _ _ _ _);
        repeat step || rewrite (open_none b) in * by t_closer;
        t_closer.
      apply equivalent_sym;
        try solve [ equivalent_star; t_closer ].
    + unshelve epose proof (equivalent_context (pp (pi1 (psubstitute (erase_term t) l term_var)) (lvar 0 term_var))
        b (pi2 (psubstitute (erase_term t) l term_var)) _ _ _ _);
        repeat step || list_utils || rewrite open_none in * by t_closer;
        t_closer.
      apply equivalent_sym;
        try solve [ equivalent_star; t_closer ].
Qed.


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

Require Export Ring.
Require Import ZArith_base.
Require Import Zpow_def.

Import InitialRing.

Set Implicit Arguments.

Ltac Zcst t :=
  match isZcst t with
    true => t
  | _ => constr:NotConstant
  end.

Ltac isZpow_coef t :=
  match t with
  | Zpos ?p => isPcst p
  | Z0 => constr:true
  | _ => constr:false
  end.

Definition N_of_Z x :=
 match x with
 | Zpos p => Npos p
 | _ => N0
 end.

Ltac Zpow_tac t :=
 match isZpow_coef t with
 | true => constr:(N_of_Z t)
 | _ => constr:NotConstant
 end.

Ltac Zpower_neg :=
  repeat match goal with
  | [|- ?G] =>
    match G with
    | context c [Zpower _ (Zneg _)] =>
      let t := context c [Z0] in
      change t
    end
  end.

Add Ring Zr : Zth
  (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
   power_tac Zpower_theory [Zpow_tac],
    (* The two following option are not needed, it is the default chose when the set of
        coefficiant is usual ring Z *)
    div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
   sign get_signZ_th).


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

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Import VariablesProofsSigDef.
Require Import TypingInfoSigDef.

Module Type TauTypingInfo <: TypingInfoSig.
  Include VariablesProofsSig.
  (* this is going to be a problem in some contexts as Var will appear twice. *)

Inductive Tau : Type :=
 | tv_t   : Var -> Tau                              (* A type variable is a type. *)
 | cint   : Tau                                      (* Cyclone's Integers. *)
 | cross  : Tau -> Tau -> Tau                        (* Pairs. *)
 | arrow  : Tau -> Tau -> Tau                        (* Function    type. *)
 | ptype  : Tau -> Tau                               (* Pointer     type. *)
 | utype  : Var -> Kappa -> Tau -> Tau              (* Universal   type. *)
 | etype  : Phi -> Var -> Kappa -> Tau -> Tau.      (* Existential type. *)

Definition T := Tau.

Function beq_kappa (k k' : Kappa) : bool :=
   match k, k' with
     |  A, A => true
     |  B, B => true
     |  _, _ => false
  end.
Hint Resolve beq_kappa.

Lemma beq_kappa_refl:
  forall k, beq_kappa k k = true.
Proof.
  induction k; crush.
Qed.
Hint Rewrite beq_kappa_refl.

Lemma beq_kappa_sym:
  forall k k', beq_kappa k k' = beq_kappa k' k.
Proof.
  induction k; crush.
Qed.
Hint Rewrite beq_kappa_sym.

Function beq_phi (p p' : Phi) : bool :=
  match p, p' with
    | witnesschanges, witnesschanges => true
    | aliases, aliases => true
    | _, _ => false
  end.
Hint Resolve beq_phi.

Lemma beq_phi_refl:
  forall p, beq_phi p p = true.
Proof.
  induction p; crush.
Qed.
Hint Resolve beq_phi_refl.

Lemma beq_phi_sym:
  forall p p', beq_phi p p' = beq_phi p' p.
Proof.
  induction p; crush.
Qed.
Hint Rewrite beq_phi_sym.

Function beq_tau (t t' : T) : bool :=
 match t, t' with
 | tv_t alpha, tv_t beta => beq_var alpha beta
 | cint, cint => true
 | (cross t0 t1), (cross t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | (arrow t0 t1), (arrow t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | ptype t, ptype t' => (beq_tau t t')
(* No alpha conversion for the moment. *)
 | utype alpha kappa tau, utype alpha' kappa' tau' =>
   andb (andb (beq_var alpha alpha') (beq_kappa kappa kappa'))
        (beq_tau tau tau')
 | etype p alpha kappa tau, etype p' alpha' kappa' tau' =>
   andb (andb (beq_phi p p')  (beq_var alpha alpha'))
        (andb (beq_kappa kappa kappa') (beq_tau tau tau'))

 | _ , _ => false
end.
Hint Resolve beq_tau.

Definition beq_t := beq_tau.
End TauTypingInfo.


From mathcomp Require Import all_ssreflect.
From chip Require Import extra connect acyclic closure check change.

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

Section Hierarchy.

Variable (A_top : eqType) (A_bot : eqType).

Variable (U' : finType) (V' : finType).

Variable (f'_top : U' -> A_top) (f'_bot : V' -> A_bot).

Variable (P_top : pred U') (P_bot : pred V').

Local Notation U := (sig_finType P_top).

Local Notation V := (sig_finType P_bot).

Variable (g_top : rel U) (g_bot : rel V).

Local Notation g_top_rev := [rel x y | g_top y x].

Local Notation g_bot_rev := [rel x y | g_bot y x].

Variable (f_top : U -> A_top) (f_bot : V -> A_bot).

Variable (checkable : pred V').

Variable (R : eqType).

Variable (check : V' -> R).

Variables (p : U -> {set V}) (p' : U' -> {set V'}).

Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'.

Hypothesis p'_neq : forall (u u' : U'), u <> u' -> p' u <> p' u'.

Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V].

Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V'].

Hypothesis g_bot_top : forall (v v' : V) (u u' : U),
 u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'.

Hypothesis f_top_partition : forall (u : U),
 f_top u = f'_top (val u) -> [set val v | v in p u] = p' (val u).

Hypothesis f_top_bot : forall (u : U),
 f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v).

Lemma exist_pu_for_v : forall v, exists u, v \in p u.
Proof.
move => v.
have Hp := p_partition.
move/andP: Hp => [Hp Hp'].
rewrite /cover in Hp.
rewrite /cover in Hp.
have Hvi: v \in [set: V] by [].
move/eqP: Hp => Hp.
rewrite -Hp in Hvi.
move/bigcupP: Hvi => [vs Hc] Hvvs.
move/bigcupP: Hc => [u Hu] Huvs.
move/set1P: Huvs => Huvs.
exists u.
by rewrite -Huvs.
Qed.

Lemma exist_list_pu_for_seq_v : forall (vs : seq V),
 exists vus, unzip1 vus = vs /\ forall v u, (v,u) \in vus -> v \in p u.
elim; first by exists [::]; split.
move => v l [vus [Hvu Hp]].
have [u Hu] := exist_pu_for_v v.
exists ((v,u) :: vus).
split; first by rewrite /= Hvu.
move => v0 u0.
rewrite in_cons.
move/orP.
case; first by move/eqP; case =>->->.
by move/Hp.
Qed.

Fixpoint adjundup (u : U) (s : seq U) :=
  if s is x :: s' then
    if u == x then adjundup u s'
    else x :: adjundup x s'
  else [::].

Lemma exist_p'u_for_v : forall v, exists u, v \in p' u.
Proof.
move => v.
have Hp := p'_partition.
move/andP: Hp => [Hp Hp'].
rewrite /cover in Hp.
rewrite /cover in Hp.
have Hvi: v \in [set: V'] by [].
move/eqP: Hp => Hp.
rewrite -Hp in Hvi.
move/bigcupP: Hvi => [vs Hc] Hvvs.
move/bigcupP: Hc => [u Hu] Huvs.
move/set1P: Huvs => Huvs.
exists u.
by rewrite -Huvs.
Qed.

Definition impacted_U : {set U} := impacted g_top^-1 (modifiedV f'_top f_top).

Definition pimpacted_V : {set V} := \bigcup_( u | u \in impacted_U ) (p u).

Lemma connect_rev_v_u : forall x v u u',
  x \in p u ->
  v \in p u' ->
  connect g_bot_rev v x ->
  connect g_top_rev u' u.
Proof.
move => x v u u' Hx Hv.
move/connect_rev.
rewrite /=.
have ->: connect [rel x0 y | g_bot x0 y] x v = connect g_bot x v by [].
move => Hc.
have ->: g_top_rev = [rel x y | g_top y x] by [].
apply/connect_rev.
move/connectP: Hc => [vs Hvs] Hl.
have [uvs [Huz Hin]] := exist_list_pu_for_seq_v vs.
move: Hvs Hl.
rewrite -Huz {Huz vs} => Hp Hl.
apply/connectP.
exists (adjundup u (unzip2 uvs)).
- clear Hl Hv u' v.
  elim: uvs u x Hx Hin Hp => //.
  case => v1 u1 uvs IH u x Hx.
  rewrite [unzip1 _]/=.
  rewrite [unzip2 _]/=.
  move => Hin.
  rewrite /=.
  move/andP => [Hg Hp].
  case: ifP.
  * move/eqP => Hu.
    move: Hu Hin =><- {u1}.
    move => Hin.
    move: Hp.
    apply: IH.
    + apply: Hin.
      by apply/orP; left.
    + move => v u0 Hin'.
      apply: Hin.
      apply/orP.
      by right.
  * rewrite /=.
    move/negP/negP/eqP => Hu.
    apply/andP.
    have Hv1: v1 \in p u1.
      apply: Hin.
      apply/orP.
      by left.
    split; first by eapply g_bot_top; eauto.
    have Hin': forall (v0 : V) (u0 : U), (v0, u0) \in uvs -> v0 \in p u0.
      move => v0 u0 Hin'.
      apply: Hin.
      rewrite inE.
      apply/orP.
      by right.
    exact: IH _ _ Hv1 Hin' Hp.
- elim: uvs u u' x v Hx Hv Hin Hp Hl => //.
  * move => u u' x v Hx Hv.
    rewrite [unzip1 _]/=.
    rewrite [unzip2 _]/=.
    rewrite [adjundup _ _]/=.
    rewrite 2![last _ _]/=.
    move => Hin Ht Hvx.
    move: Hvx Hv =>-> {v Ht Hin}.
    move => Hp.
    case Hu: (u' == u); first by move/eqP: Hu.
    move/negP/negP/eqP: Hu => Hu.
    have Hneq := p_neq Hu.
    have Hpp := p_partition.
    move/andP: Hpp => [Hc Hpp].
    move/andP: Hpp => [Htr H0].
    move/trivIsetP: Htr => Htr.
    have Hpu: p u \in \bigcup_(u1 in U) [set p u1].
      apply/bigcupP.
      exists u; first by [].
      by rewrite in_set1.
    have Hpu': p u' \in \bigcup_(u1 in U) [set p u1].
      apply/bigcupP.
      exists u'; first by [].
      by rewrite in_set1.
    have Hneq': p u != p u'.
      apply/negP/negP/eqP => Hpp.
      by case: Hneq.
    have Hpp := Htr _ _ Hpu Hpu' Hneq'.
    move/setDidPl: Hpp => Hpp.
    move: Hx.
    rewrite -Hpp.
    move/setDP => [Hx Hx'].
    move/negP: Hx'.
    by case.
  * case => v1 u1 uvs IH u u' x v Hx Hv.
    rewrite [unzip1 _]/=.
    rewrite [unzip2 _]/=.
    rewrite [adjundup _ _]/=.
    move => Hin.
    move/andP => [Hg Hp].
    move: Hp.
    rewrite -/(path _ _) => Hp.
    rewrite [last _ _]/=.
    move => Hl.
    case: ifP => Hu.
    + move/eqP: Hu => Hu.
      move: Hx.
      rewrite Hu {Hu u} => Hu.
      have Hv1: v1 \in p u1.
        apply: Hin.
        rewrite inE.
        apply/orP.
        by left.
      have Hin': forall (v0 : V) (u0 : U), (v0, u0) \in uvs -> v0 \in p u0.
        move => v0 u0 Hin'.
        apply: Hin.
        rewrite inE.
        apply/orP.
        by right.
      exact: IH u1 u' v1 v Hv1 Hv Hin' Hp Hl.
    + rewrite /=.
      move/negP/negP/eqP: Hu => Hu.
      have Hv1: v1 \in p u1.
        apply: Hin.
        rewrite inE.
        apply/orP.
        by left.
      have Hin': forall (v0 : V) (u0 : U), (v0, u0) \in uvs -> v0 \in p u0.
        move => v0 u0 Hin'.
        apply: Hin.
        rewrite inE.
        apply/orP.
        by right.
      exact: IH u1 u' v1 v Hv1 Hv Hin' Hp Hl.
Qed.

Lemma neq_connect_in_pimpacted_V : forall x v,
 f_bot v <> f'_bot (val v) -> connect g_bot_rev v x -> x \in pimpacted_V.
Proof.
move => x v Hv Hc.
apply/bigcupP.
have [u Hu] := exist_pu_for_v x.
exists u; last by [].
have Hp := p_partition.
move/andP: Hp => [Hcv Hp'].
move/eqP: Hcv => Hcv.
apply/impactedVP.
have Hvi: v \in [set: V] by [].
rewrite -Hcv in Hvi.
move/bigcupP: Hvi => [xs Hc'] Hvvs.
move/bigcupP: Hc' => [u' Hu'] Huvs.
move/set1P: Huvs => Huvs.
move: Huvs Hvvs =>->.
move => Hvx.
exists u'.
- rewrite inE.
  apply/negP.
  move => Hf.
  move/eqP: Hf.
  move/f_top_bot => Hf.
  case: Hv.
  exact: Hf.
- move: Hc.
  exact: connect_rev_v_u.
Qed.

Lemma impactedV_in_pimpacted_V :
  forall x, x \in impacted g_bot^-1 (modifiedV f'_bot f_bot) ->
       x \in pimpacted_V.
Proof.
move => x.
move/impactedVP.
case => v Hm Hc.
move/not_modifiedP: Hm.
move => Hf.
move/negP/eqP: Hf => Hf.
move: Hf Hc.
exact: neq_connect_in_pimpacted_V.
Qed.

Definition impacted_U' : {set U'} := impactedV' f'_top f_top g_top.

Definition pimpacted_V' : {set V'} := \bigcup_( u | u \in impacted_U' ) (p' u).

Lemma pimpacted_V'_fresh :
  forall v, v \in freshV' P_bot -> v \in pimpacted_V'.
Proof.
move => v'.
move/freshV'P => Hv.
apply/bigcupP.
have [u' Hu] := exist_p'u_for_v v'.
exists u'; last by [].
case Hfr: (u' \in freshV' P_top).
- move/negP/negP: Hfr => Hfr.
  apply/impactedV'P.
  right.
  split => //.
  apply/negP.
  move => Hu'.
  move/imsetP: Hu' => [u Hi] Hu'.
  move/freshV'P: Hfr.
  move => Hvu.
  have Hvu' := Hvu u.
  case/negP: Hvu'.
  by apply/eqP.
- move/negP/negP: Hfr => Hfr.
  apply/impactedV'P.
  left.
  split => //.
  move/negP: Hfr.
  rewrite -sub_freshV'.
  move/negP/negPn.
  have H_sp := (insubP [subType of U] u').
  destruct H_sp; last by [].
  move => Hs.
  apply/imsetP.
  exists u; last by [].
  apply/impactedVP.
  exists u; last by [].
  apply/not_modifiedP.
  move/eqP.
  move/f_top_partition => Hvs.
  rewrite e in Hvs.
  move: Hu.
  rewrite -Hvs.
  move/imsetP => [v Hi] Hv'.
  have Hvv' := Hv v.
  move/negP: Hvv'.
  case.
  by apply/eqP.
Qed.

Lemma pimpacted_V'_impactedVV' :
  forall v, v \in impactedVV' g_bot (modifiedV f'_bot f_bot) ->
  v \in pimpacted_V'.
Proof.
move => v'.
move/imsetP => [v Hi] Hv.
have Hi' := impactedV_in_pimpacted_V Hi.
move/bigcupP: Hi' => [u Hu] Huv.
apply/bigcupP.
have [u' Hu'] := exist_p'u_for_v v'.
exists u'; last by [].
case Hfr: (u' \in freshV' P_top).
- move/negP/negP: Hfr => Hfr.
  apply/impactedV'P.
  right; split => //.
  apply/negP => Hui.
  move/freshV'P: Hfr => Hfr.
  move/imsetP: Hui => [u'' Hu''] Hvu.
  have Hfr' := Hfr u''.
  move/negP: Hfr'.
  case.
  by apply/eqP.
- move/negP/negP: Hfr.
  move/negP.
  rewrite -sub_freshV'.
  move/negP/negPn.
  have H_sp := (insubP [subType of U] u').
  destruct H_sp; last by [].
  move => Hs.
  case Hu0: (u0 == u).
  * move: e.
    move/eqP: Hu0 =>->.
    move => Hvu.
    rewrite /impacted_U' /impactedV'.
    apply/setUP.
    left.
    apply/imsetP.
    by exists u.
  * move/negP/negP/eqP: Hu0 => Hu0.
    case Hf: (f_top u0 == f'_top (val u0)).
    + move/eqP: Hf.
      move/f_top_partition => Hst.
      move: Hst.
      rewrite e.
      have H_neq: val u <> u'.
        rewrite -e => Huu.
        apply val_inj in Huu.
        by rewrite Huu in Hu0.
      move => Hp.
      rewrite -Hp in Hu'.
      move/imsetP: Hu' => [x Hvp] Hvx.
      rewrite Hvx in Hv.
      apply val_inj in Hv.
      rewrite Hv in Hvp.
      have Hpp := p_partition.
      move/andP: Hpp => [Hpp Hpp'].
      move/andP: Hpp' => [Hpp' Hpp''].
      move/trivIsetP: Hpp'.
      have Hpu: p u \in \bigcup_(u1 in U) [set p u1].
        apply/bigcupP.
        exists u; first by [].
        by rewrite in_set1.
      have Hpu0: p u0 \in \bigcup_(u1 in U) [set p u1].
        apply/bigcupP.
        exists u0; first by [].
        by rewrite in_set1.
      move => Hpp'.
      have H_p := Hpp' _ _ Hpu Hpu0.
      case Hpe: (p u == p u0).
        move/eqP: Hpe => Hpe.
        apply sym_eq in Hpe.
        contradict Hpe.
        exact: p_neq.
      move/negP/negP: Hpe.
      move/H_p.
      move/setDidPl => H_pp.
      rewrite -H_pp /= in Huv.
      move/setDP: Huv => [Hvpp Hvvp].
      move/negP: Hvvp.
      by case.
    + move/negP/negP/eqP: Hf => Hf.
      rewrite /impacted_U'.
      apply/setUP.
      left.
      apply/imsetP.
      exists u0; last by [].
      apply/impactedVP.
      exists u0; last by [].
      apply/not_modifiedP.
      by apply/negP/eqP.
Qed.

Lemma pimpacted_V'_impactedV' :
  forall v, v \in impactedV' f'_bot f_bot g_bot -> v \in pimpacted_V'.
Proof.
move => v.
move/impactedV'P.
case; move => [Ha Hb].
- exact: pimpacted_V'_impactedVV'.
- exact: pimpacted_V'_fresh.
Qed.

Definition checkable_pimpacted_V' :=
 [set v in pimpacted_V' | checkable v].

Definition checkable_pimpacted_fresh : seq V' :=
 enum checkable_pimpacted_V'.

Definition check_pimpacted_V'_cert :=
 [seq (v, check v) | v <- checkable_pimpacted_fresh].

Lemma check_pimpacted_V'_certP v r :
  reflect
    (checkable v /\ check v == r /\ v \in pimpacted_V')
    ((v,r) \in check_pimpacted_V'_cert).
Proof.
apply: (iffP idP).
- move/mapP => [v' Hv'].
  move: Hv'.
  rewrite mem_enum in_set.
  move/andP => [Hp Hc].
  by case =>->->.
- move => [Hc [Hcr Hv]].
  move/eqP: Hcr =><-.
  apply/mapP.
  exists v; last by [].
  rewrite mem_enum in_set.
  by apply/andP; split.
Qed.

Lemma check_pimpacted_V'_cert_uniq :
  uniq [seq vr.1 | vr <- check_pimpacted_V'_cert].
Proof.
rewrite map_inj_in_uniq.
- rewrite map_inj_uniq; first by rewrite enum_uniq.
  by move => x y; case.
- case => v1 r1.
  case => v2 r2.
  move => H1 H2 /= Heq.
  move: Heq H1 H2 =>-<-.
  move/mapP => [v1' Hv1' Hc1].
  rewrite mem_enum in Hv1'.
  case: Hc1 =><- Hr1.
  move/mapP => [v2' Hv2' Hc2].
  rewrite mem_enum in Hv2'.
  case: Hc2 =><- Hr2.
  by rewrite Hr1 Hr2.
Qed.

End Hierarchy.


Require Import BinNums BinInt.
Require Import Coq.Bool.Bool.

From compcert Require Import Integers Floats.

Require Import Types BValues.

Inductive unary_operation : Type :=
  | Onotbool : unary_operation
  | Onotint : unary_operation
  | Oneg : unary_operation
  | Oabsfloat : unary_operation.

Inductive operation_kind : Type :=
  | OInt
  | OInt64
  | OFloat32
  | OFloat64.

Inductive binarith_operation : Type :=
  | Oadd
  | Osub
  | Omul
  | Odivs
  | Odivu
  | Omods
  | Omodu.
  (* | Oshr
     | Oshl. *)

Inductive logical_operation : Type :=
  | Oand
  | Oor
  | Oxor.

Inductive cmp_operation : Type :=
  | Oeq
  | One
  | Olt
  | Ogt
  | Ole
  | Oge.

Inductive cmpu_operation : Type :=
  | Oltu
  | Ogtu
  | Oleu
  | Ogeu.

(* Sémantique des opérateurs unaires *)

Definition sem_notbool (v: value) : option value :=
  match v with
  | Vbool b => Some (Vbool (negb b))
  | _ => None
  end.

Definition sem_notint (k: operation_kind) (v: value) : option value :=
  match k, v with
  | OInt, Vint sz sig n => Some (Vint sz sig (Int.not n))
  | OInt64, Vint64 sig n => Some (Vint64 sig (Int64.not n))
  | _, _ => None
  end.

Definition sem_neg (k: operation_kind) (v: value) : option value :=
  match k, v with
  | OInt, Vint sz sig n => Some (Vint sz sig (Int.neg n))
  | OInt64, Vint64 sig n => Some (Vint64 sig (Int64.neg n))
  | OFloat32, Vfloat32 f => Some (Vfloat32 (Float32.neg f))
  | OFloat64, Vfloat64 f => Some (Vfloat64 (Float.neg f))
  | _, _ => None
  end.

Definition sem_absfloat (k: operation_kind) (v: value) : option value :=
  match k, v with
  | OFloat32, Vfloat32 f => Some (Vfloat64 (Float.abs (Float.of_single f)))
  | OFloat64, Vfloat64 f => Some (Vfloat64 (Float.abs f))
  | _, _ => None
  end.

Definition sem_unop (op: unary_operation) (k: operation_kind) (v: value) :=
  match op with
  | Onotbool => sem_notbool v
  | Onotint => sem_notint k v
  | Oneg => sem_neg k v
  | Oabsfloat => sem_absfloat k v
  end.

Definition sem_binarith
           (sem_int32: intsize -> signedness -> int -> int -> option value)
           (sem_int64: signedness -> int64 -> int64 -> option value)
           (sem_float32: Floats.float32 -> Floats.float32 -> option value)
           (sem_float64: Floats.float -> Floats.float -> option value)
           (k: operation_kind)
           (v1: value) (v2: value) : option value :=
  match k, v1, v2 with
  | OInt, Vint sz1 sig1 n1, Vint sz2 sig2 n2 =>
    if eq_intsize sz1 sz2 && eq_signedness sig1 sig2 then sem_int32 sz1 sig1 n1 n2 else None
  | OInt64, Vint64 sig1 n1, Vint64 sig2 n2 => if eq_signedness sig1 sig2 then sem_int64 sig1 n1 n2 else None
  | OFloat32, Vfloat32 f1, Vfloat32 f2 => sem_float32 f1 f2
  | OFloat64, Vfloat64 f1, Vfloat64 f2 => sem_float64 f1 f2
  | _, _, _ => None
  end.

Definition opf {A B C: Type} (f: A -> B -> C) : A -> B -> option C :=
  fun x y => Some (f x y).

Definition sem_logical (sem_bool: bool -> bool -> option value)
           (v1 v2: value) : option value :=
  match v1, v2 with
  | Vbool b1, Vbool b2 => sem_bool b1 b2
  | _, _ => None
  end.

Definition sem_cmp (c: Integers.comparison) (k: operation_kind)
           (v1: value) (v2: value) : option value :=
  match k, v1, v2 with
  | OInt, Vint sz1 sig1 n1, Vint sz2 sig2 n2 =>
    if eq_intsize sz1 sz2 && eq_signedness sig1 sig2 then Some (Vbool (Int.cmp c n1 n2)) else None
  | OInt64, Vint64 sig1 n1, Vint64 sig2 n2 => if eq_signedness sig1 sig2 then Some (Vbool (Int64.cmp c n1 n2)) else None
  | OFloat32, Vfloat32 f1, Vfloat32 f2 => Some (Vbool (Float32.cmp c f1 f2))
  | OFloat64, Vfloat64 f1, Vfloat64 f2 => Some (Vbool (Float.cmp c f1 f2))
  | _, _, _ => None
  end.

Definition sem_cmpu (c: Integers.comparison) (k: operation_kind)
           (v1: value) (v2: value) : option value :=
  match k, v1, v2 with
  | OInt, Vint sz1 sig1 n1, Vint sz2 sig2 n2 =>
    if eq_intsize sz1 sz2 && eq_signedness sig1 sig2 then Some (Vbool (Int.cmpu c n1 n2)) else None
  | OInt64, Vint64 sig1 n1, Vint64 sig2 n2 => if eq_signedness sig1 sig2 then Some (Vbool (Int64.cmpu c n1 n2)) else None
  | _, _, _ => None
  end.

Definition opb (f: bool -> bool -> bool) : bool -> bool -> option value :=
  fun x y => Some (Vbool (f x y)).

Definition opi (f: int -> int -> int) : intsize -> signedness -> int -> int -> option value :=
  fun sz sig x y => Some (Vint sz sig (f x y)).

Definition opi64 (f: int64 -> int64 -> int64) : signedness -> int64 -> int64 -> option value :=
  fun sig x y => Some (Vint64 sig (f x y)).

Definition opf32 (f: float32 -> float32 -> float32) : float32 -> float32 -> option value :=
  fun x y => Some (Vfloat32 (f x y)).

Definition opf64 (f: float -> float -> float) : float -> float -> option value :=
  fun x y => Some (Vfloat64 (f x y)).

Definition divu (sz: intsize) (sig: signedness) (n1 n2: int) : option value :=
  if Int.eq n2 Int.zero then None
  else Some (Vint sz sig (Int.divu n1 n2)).

Definition divs (sz: intsize) (sig: signedness) (n1 n2: int) : option value :=
  if Int.eq n2 Int.zero
     || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone then None
  else Some (Vint sz sig (Int.divs n1 n2)).

Definition divu64 (sig: signedness) (n1 n2: int64) : option value :=
  if Int64.eq n2 Int64.zero then None
  else Some (Vint64 sig (Int64.divu n1 n2)).

Definition divs64 (sig: signedness) (n1 n2: int64) : option value :=
  if Int64.eq n2 Int64.zero
     || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone then None
  else Some (Vint64 sig (Int64.divs n1 n2)).

Definition modu (sz: intsize) (sig: signedness) (n1 n2: int) : option value :=
  if Int.eq n2 Int.zero then None
  else Some (Vint sz sig (Int.modu n1 n2)).

Definition mods (sz: intsize) (sig: signedness) (n1 n2: int) : option value :=
  if Int.eq n2 Int.zero
     || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone then None
  else Some (Vint sz sig (Int.mods n1 n2)).

Definition modu64 (sig: signedness) (n1 n2: int64) : option value :=
  if Int64.eq n2 Int64.zero then None
  else Some (Vint64 sig (Int64.modu n1 n2)).

Definition mods64 (sig: signedness) (n1 n2: int64) : option value :=
  if Int64.eq n2 Int64.zero
     || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone then None
  else Some (Vint64 sig (Int64.mods n1 n2)).

Definition sem_binarith_operation (op: binarith_operation)
           (k: operation_kind) (v1 v2: value) : option value :=
  match op with
  | Oadd =>
    sem_binarith
      (opi Int.add) (opi64 Int64.add) (opf32 Float32.add) (opf64 Float.add) k v1 v2
  | Osub =>
    sem_binarith
      (opi Int.sub) (opi64 Int64.sub) (opf32 Float32.sub) (opf64 Float.sub) k v1 v2
  | Omul =>
    sem_binarith
      (opi Int.mul) (opi64 Int64.mul) (opf32 Float32.mul) (opf64 Float.mul) k v1 v2
  | Odivu =>
    sem_binarith
      divu divu64 (opf32 Float32.div) (opf64 Float.div) k v1 v2
  | Odivs =>
    sem_binarith
      divs divs64 (opf32 Float32.div) (opf64 Float.div) k v1 v2
  | Omodu =>
    sem_binarith
      modu modu64 (fun _ _ => None) (fun _ _ => None) k v1 v2
  | Omods =>
    sem_binarith
      mods mods64 (fun _ _ => None) (fun _ _ => None) k v1 v2
  end.

Definition sem_logical_operation (op: logical_operation)
           (v1 v2: value) : option value :=
  match op with
  | Oand =>
    sem_logical (opb andb) v1 v2
  | Oor =>
    sem_logical (opb orb) v1 v2
  | Oxor =>
    sem_logical (opb xorb) v1 v2
  end.

Definition sem_cmp_operation (op: cmp_operation) (k: operation_kind)
           (v1 v2: value) : option value :=
  match op with
  | Oeq => sem_cmp Integers.Ceq k v1 v2
  | One => sem_cmp Integers.Cne k v1 v2
  | Olt => sem_cmp Integers.Clt k v1 v2
  | Ogt => sem_cmp Integers.Cgt k v1 v2
  | Ole => sem_cmp Integers.Cle k v1 v2
  | Oge => sem_cmp Integers.Cge k v1 v2
  end.

Definition sem_cmpu_operation (op: cmpu_operation) (k: operation_kind)
           (v1 v2: value) : option value :=
  match op with
  | Oltu => sem_cmpu Integers.Clt k v1 v2
  | Ogtu => sem_cmpu Integers.Cgt k v1 v2
  | Oleu => sem_cmpu Integers.Cle k v1 v2
  | Ogeu => sem_cmpu Integers.Cge k v1 v2
  end.

Definition cast_int_int (sz: intsize) (sig: signedness) (i: int) : int :=
  match sz, sig with
  | I8,  Signed   => Int.sign_ext 8 i
  | I8,  Unsigned => Int.zero_ext 8 i
  | I16, Signed   => Int.sign_ext 16 i
  | I16, Unsigned => Int.zero_ext 16 i
  | I32, _        => i
  end.

Definition sem_cast (v: value) (tv: typ) (t: typ) : option value :=
  match v, tv, t with
  | Vint _ _ n, Tint _ _, Tint sz sig => Some (Vint sz sig (cast_int_int sz sig n))
  | Vint _ _ n, Tint _ Signed, Tint64 sig  => Some (Vint64 sig (Int64.repr (Int.signed n)))
  | Vint _ _ n, Tint _ Unsigned, Tint64 sig => Some (Vint64 sig (Int64.repr (Int.unsigned n)))
  | Vint _ _ n, Tint _ Signed, Tfloat F32 => Some (Vfloat32 (Float32.of_int n))
  | Vint _ _ n, Tint _ Unsigned, Tfloat F32 => Some (Vfloat32 (Float32.of_intu n))
  | Vint _ _ n, Tint _ Signed, Tfloat F64 => Some (Vfloat64 (Float.of_int n))
  | Vint _ _ n, Tint _ Unsigned, Tfloat F64 => Some (Vfloat64 (Float.of_intu n))
  | Vint64 _ n, Tint64 _, Tint64 sig => Some (Vint64 sig n)
  | Vint64 _ n, Tint64 _, Tint sz sig =>
    Some (Vint sz sig (cast_int_int sz sig (Int.repr (Int64.unsigned n))))
  | Vint64 _ n, Tint64 Signed, Tfloat F32 => Some (Vfloat32 (Float32.of_long n))
  | Vint64 _ n, Tint64 Unsigned, Tfloat F32 => Some (Vfloat32 (Float32.of_longu n))
  | Vint64 _ n, Tint64 Signed, Tfloat F64 => Some (Vfloat64 (Float.of_long n))
  | Vint64 _ n, Tint64 Unsigned, Tfloat F64 => Some (Vfloat64 (Float.of_longu n))
  | Vfloat32 f, Tfloat F32, Tint sz Signed =>
    match Float32.to_int f with
    | Some i => Some (Vint sz Signed (cast_int_int sz Signed i))
    | None => None
    end
  | Vfloat32 f, Tfloat F32, Tint sz Unsigned =>
    match Float32.to_intu f with
    | Some i => Some (Vint sz Unsigned (cast_int_int sz Unsigned i))
    | None => None
    end
  | Vfloat32 f, Tfloat F32, Tint64 Signed =>
    match Float32.to_long f with
    | Some i => Some (Vint64 Signed i)
    | None => None
    end
  | Vfloat32 f, Tfloat F32, Tint64 Unsigned =>
    match Float32.to_longu f with
    | Some i => Some (Vint64 Unsigned i)
    | None => None
    end
  | Vfloat32 f, Tfloat F32, Tfloat F32 => Some v
  | Vfloat32 f, Tfloat F32, Tfloat F64 => Some (Vfloat64 (Float.of_single f))
  | Vfloat64 f, Tfloat F64, Tint sz Signed =>
    match Float.to_int f with
    | Some i => Some (Vint sz Signed (cast_int_int sz Signed i))
    | None => None
    end
  | Vfloat64 f, Tfloat F64, Tint sz Unigned =>
    match Float.to_intu f with
    | Some i => Some (Vint sz Unsigned (cast_int_int sz Unsigned i))
    | None => None
    end
  | Vfloat64 f, Tfloat F64, Tint64 Signed =>
    match Float.to_long f with
    | Some i => Some (Vint64 Signed i)
    | None => None
    end
  | Vfloat64 f, Tfloat F64, Tint64 Unsigned =>
    match Float.to_longu f with
    | Some i => Some (Vint64 Unsigned i)
    | None => None
    end
  | Vfloat64 f, Tfloat F64, Tfloat F32 => Some (Vfloat32 (Float.to_single f))
  | Vfloat64 f, Tfloat F64, Tfloat F64 => Some v
  | Vunit, Tvoid, Tvoid => Some Vunit
  | Vbool b, Tbool, Tbool => Some (Vbool b)
  | Varr idarr lv, Tarr b0 t0, Tarr b1 t1 =>
    if eqb b0 b1 && eq_typ t0 t1 then Some (Varr idarr lv) else None
  (* | Vmutarr idarr, Tarr b0 t0, Tarr b1 t1 =>
       if eqb b0 b1 && eq_typ t0 t1 then Some (Vmutarr idarr) else None *)
  | _, _, _ => None
  end.


(* generated by Ott 0.32, locally-nameless lngen from: ../Qualitative.ott *)
Require Import Metalib.Metatheory.
Require Export Metalib.LibLNgen.
Require Export Qual.grade_sig.
Require Export Qual.sort_sig.

(** syntax *)
Definition tmvar : Set := var. (*r variables *)
Definition qualityvar : Set := atom. (*r qualities *)

Definition grade : Set := grade.

Definition sort : Set := sort.

Inductive tm : Set :=  (*r terms and types *)
 | a_TyUnit : tm (*r unit type *)
 | a_TmUnit : tm (*r unit term *)
 | a_Pi (psi:grade) (A:tm) (B:tm) (*r dependent function type *)
 | a_Abs (psi:grade) (A:tm) (a:tm) (*r function *)
 | a_App (a:tm) (psi:grade) (b:tm) (*r function application *)
 | a_Type (s:sort) (*r sort *)
 | a_Var_b (_:nat) (*r variable *)
 | a_Var_f (x:tmvar) (*r variable *)
 | a_Sum (A1:tm) (A2:tm) (*r sum type *)
 | a_Inj1 (a:tm) (*r injection into sum type *)
 | a_Inj2 (a:tm) (*r injection into sum type *)
 | a_Case (psi:grade) (a:tm) (b1:tm) (b2:tm) (*r case elimination of sum type *)
 | a_WSigma (psi:grade) (A:tm) (B:tm) (*r dependent tuple type *)
 | a_WPair (a:tm) (psi:grade) (b:tm) (*r tuple creation *)
 | a_LetPair (psi:grade) (a:tm) (b:tm) (*r tuple elimination *)
 | a_SSigma (psi:grade) (A:tm) (B:tm)
 | a_SPair (a:tm) (psi:grade) (b:tm)
 | a_Proj1 (psi:grade) (a:tm)
 | a_Proj2 (psi:grade) (a:tm).

Definition econtext : Set := list ( atom * grade ).

Definition context : Set := list ( atom * (grade * tm) ).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_tm_wrt_tm_rec (k:nat) (a5:tm) (a_6:tm) {struct a_6}: tm :=
  match a_6 with
  | a_TyUnit => a_TyUnit
  | a_TmUnit => a_TmUnit
  | (a_Pi psi A B) => a_Pi psi (open_tm_wrt_tm_rec k a5 A) (open_tm_wrt_tm_rec (S k) a5 B)
  | (a_Abs psi A a) => a_Abs psi (open_tm_wrt_tm_rec k a5 A) (open_tm_wrt_tm_rec (S k) a5 a)
  | (a_App a psi b) => a_App (open_tm_wrt_tm_rec k a5 a) psi (open_tm_wrt_tm_rec k a5 b)
  | (a_Type s) => a_Type s
  | (a_Var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => a_Var_b nat
        | inleft (right _) => a5
        | inright _ => a_Var_b (nat - 1)
      end
  | (a_Var_f x) => a_Var_f x
  | (a_Sum A1 A2) => a_Sum (open_tm_wrt_tm_rec k a5 A1) (open_tm_wrt_tm_rec k a5 A2)
  | (a_Inj1 a) => a_Inj1 (open_tm_wrt_tm_rec k a5 a)
  | (a_Inj2 a) => a_Inj2 (open_tm_wrt_tm_rec k a5 a)
  | (a_Case psi a b1 b2) => a_Case psi (open_tm_wrt_tm_rec k a5 a) (open_tm_wrt_tm_rec k a5 b1) (open_tm_wrt_tm_rec k a5 b2)
  | (a_WSigma psi A B) => a_WSigma psi (open_tm_wrt_tm_rec k a5 A) (open_tm_wrt_tm_rec (S k) a5 B)
  | (a_WPair a psi b) => a_WPair (open_tm_wrt_tm_rec k a5 a) psi (open_tm_wrt_tm_rec k a5 b)
  | (a_LetPair psi a b) => a_LetPair psi (open_tm_wrt_tm_rec k a5 a) (open_tm_wrt_tm_rec (S k) a5 b)
  | (a_SSigma psi A B) => a_SSigma psi (open_tm_wrt_tm_rec k a5 A) (open_tm_wrt_tm_rec (S k) a5 B)
  | (a_SPair a psi b) => a_SPair (open_tm_wrt_tm_rec k a5 a) psi (open_tm_wrt_tm_rec k a5 b)
  | (a_Proj1 psi a) => a_Proj1 psi (open_tm_wrt_tm_rec k a5 a)
  | (a_Proj2 psi a) => a_Proj2 psi (open_tm_wrt_tm_rec k a5 a)
end.

Definition open_tm_wrt_tm a5 a_6 := open_tm_wrt_tm_rec 0 a_6 a5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_tm *)
Inductive lc_tm : tm -> Prop :=    (* defn lc_tm *)
 | lc_a_TyUnit :
     (lc_tm a_TyUnit)
 | lc_a_TmUnit :
     (lc_tm a_TmUnit)
 | lc_a_Pi : forall (psi:grade) (A B:tm),
     (lc_tm A) ->
      ( forall x , lc_tm  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     (lc_tm (a_Pi psi A B))
 | lc_a_Abs : forall (psi:grade) (A a:tm),
     (lc_tm A) ->
      ( forall x , lc_tm  ( open_tm_wrt_tm a (a_Var_f x) )  )  ->
     (lc_tm (a_Abs psi A a))
 | lc_a_App : forall (a:tm) (psi:grade) (b:tm),
     (lc_tm a) ->
     (lc_tm b) ->
     (lc_tm (a_App a psi b))
 | lc_a_Type : forall (s:sort),
     (lc_tm (a_Type s))
 | lc_a_Var_f : forall (x:tmvar),
     (lc_tm (a_Var_f x))
 | lc_a_Sum : forall (A1 A2:tm),
     (lc_tm A1) ->
     (lc_tm A2) ->
     (lc_tm (a_Sum A1 A2))
 | lc_a_Inj1 : forall (a:tm),
     (lc_tm a) ->
     (lc_tm (a_Inj1 a))
 | lc_a_Inj2 : forall (a:tm),
     (lc_tm a) ->
     (lc_tm (a_Inj2 a))
 | lc_a_Case : forall (psi:grade) (a b1 b2:tm),
     (lc_tm a) ->
     (lc_tm b1) ->
     (lc_tm b2) ->
     (lc_tm (a_Case psi a b1 b2))
 | lc_a_WSigma : forall (psi:grade) (A B:tm),
     (lc_tm A) ->
      ( forall x , lc_tm  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     (lc_tm (a_WSigma psi A B))
 | lc_a_WPair : forall (a:tm) (psi:grade) (b:tm),
     (lc_tm a) ->
     (lc_tm b) ->
     (lc_tm (a_WPair a psi b))
 | lc_a_LetPair : forall (psi:grade) (a b:tm),
     (lc_tm a) ->
      ( forall x , lc_tm  ( open_tm_wrt_tm b (a_Var_f x) )  )  ->
     (lc_tm (a_LetPair psi a b))
 | lc_a_SSigma : forall (psi:grade) (A B:tm),
     (lc_tm A) ->
      ( forall x , lc_tm  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     (lc_tm (a_SSigma psi A B))
 | lc_a_SPair : forall (a:tm) (psi:grade) (b:tm),
     (lc_tm a) ->
     (lc_tm b) ->
     (lc_tm (a_SPair a psi b))
 | lc_a_Proj1 : forall (psi:grade) (a:tm),
     (lc_tm a) ->
     (lc_tm (a_Proj1 psi a))
 | lc_a_Proj2 : forall (psi:grade) (a:tm),
     (lc_tm a) ->
     (lc_tm (a_Proj2 psi a)).
(** free variables *)
Fixpoint fv_tm_tm (a5:tm) : vars :=
  match a5 with
  | a_TyUnit => {}
  | a_TmUnit => {}
  | (a_Pi psi A B) => (fv_tm_tm A) \u (fv_tm_tm B)
  | (a_Abs psi A a) => (fv_tm_tm A) \u (fv_tm_tm a)
  | (a_App a psi b) => (fv_tm_tm a) \u (fv_tm_tm b)
  | (a_Type s) => {}
  | (a_Var_b nat) => {}
  | (a_Var_f x) => {{x}}
  | (a_Sum A1 A2) => (fv_tm_tm A1) \u (fv_tm_tm A2)
  | (a_Inj1 a) => (fv_tm_tm a)
  | (a_Inj2 a) => (fv_tm_tm a)
  | (a_Case psi a b1 b2) => (fv_tm_tm a) \u (fv_tm_tm b1) \u (fv_tm_tm b2)
  | (a_WSigma psi A B) => (fv_tm_tm A) \u (fv_tm_tm B)
  | (a_WPair a psi b) => (fv_tm_tm a) \u (fv_tm_tm b)
  | (a_LetPair psi a b) => (fv_tm_tm a) \u (fv_tm_tm b)
  | (a_SSigma psi A B) => (fv_tm_tm A) \u (fv_tm_tm B)
  | (a_SPair a psi b) => (fv_tm_tm a) \u (fv_tm_tm b)
  | (a_Proj1 psi a) => (fv_tm_tm a)
  | (a_Proj2 psi a) => (fv_tm_tm a)
end.

(** substitutions *)
Fixpoint subst_tm_tm (a5:tm) (x5:tmvar) (a_6:tm) {struct a_6} : tm :=
  match a_6 with
  | a_TyUnit => a_TyUnit
  | a_TmUnit => a_TmUnit
  | (a_Pi psi A B) => a_Pi psi (subst_tm_tm a5 x5 A) (subst_tm_tm a5 x5 B)
  | (a_Abs psi A a) => a_Abs psi (subst_tm_tm a5 x5 A) (subst_tm_tm a5 x5 a)
  | (a_App a psi b) => a_App (subst_tm_tm a5 x5 a) psi (subst_tm_tm a5 x5 b)
  | (a_Type s) => a_Type s
  | (a_Var_b nat) => a_Var_b nat
  | (a_Var_f x) => (if eq_var x x5 then a5 else (a_Var_f x))
  | (a_Sum A1 A2) => a_Sum (subst_tm_tm a5 x5 A1) (subst_tm_tm a5 x5 A2)
  | (a_Inj1 a) => a_Inj1 (subst_tm_tm a5 x5 a)
  | (a_Inj2 a) => a_Inj2 (subst_tm_tm a5 x5 a)
  | (a_Case psi a b1 b2) => a_Case psi (subst_tm_tm a5 x5 a) (subst_tm_tm a5 x5 b1) (subst_tm_tm a5 x5 b2)
  | (a_WSigma psi A B) => a_WSigma psi (subst_tm_tm a5 x5 A) (subst_tm_tm a5 x5 B)
  | (a_WPair a psi b) => a_WPair (subst_tm_tm a5 x5 a) psi (subst_tm_tm a5 x5 b)
  | (a_LetPair psi a b) => a_LetPair psi (subst_tm_tm a5 x5 a) (subst_tm_tm a5 x5 b)
  | (a_SSigma psi A B) => a_SSigma psi (subst_tm_tm a5 x5 A) (subst_tm_tm a5 x5 B)
  | (a_SPair a psi b) => a_SPair (subst_tm_tm a5 x5 a) psi (subst_tm_tm a5 x5 b)
  | (a_Proj1 psi a) => a_Proj1 psi (subst_tm_tm a5 x5 a)
  | (a_Proj2 psi a) => a_Proj2 psi (subst_tm_tm a5 x5 a)
end.

(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Local Open Scope grade_scope.

Definition labels : context -> econtext :=
  map (fun '(u , s) => u).

Definition subst_ctx (a : tm) (x:var) : context -> context :=
  map (fun '(g, A) => (g, (subst_tm_tm a x A))).

Definition join_ctx_l (psi : grade) : context -> context :=
  map (fun '(g, A) => (psi * g, A)).

Definition join_ctx_r (psi : grade) : context -> context :=
  map (fun '(g, A) => (g * psi, A)).

Definition meet_ctx_l (psi : grade) : context -> context :=
  map (fun '(g, A) => (psi + g, A)).

Definition meet_ctx_r (psi : grade) : context -> context :=
  map (fun '(g, A) => (g + psi, A)).

Fixpoint close_tm_wrt_tm_rec (n1 : nat) (x1 : tmvar) (a1 : tm) {struct a1} : tm :=
  match a1 with
    | a_TyUnit => a_TyUnit
    | a_TmUnit => a_TmUnit
    | a_Pi psi1 A1 B1 => a_Pi psi1 (close_tm_wrt_tm_rec n1 x1 A1) (close_tm_wrt_tm_rec (S n1) x1 B1)
    | a_Abs psi1 A1 a2 => a_Abs psi1 (close_tm_wrt_tm_rec n1 x1 A1) (close_tm_wrt_tm_rec (S n1) x1 a2)
    | a_App a2 psi1 b1 => a_App (close_tm_wrt_tm_rec n1 x1 a2) psi1 (close_tm_wrt_tm_rec n1 x1 b1)
    | a_Type s => a_Type s
    | a_Var_f x2 => if (x1 == x2) then (a_Var_b n1) else (a_Var_f x2)
    | a_Var_b n2 => if (lt_ge_dec n2 n1) then (a_Var_b n2) else (a_Var_b (S n2))
    | a_Sum A1 A2 => a_Sum (close_tm_wrt_tm_rec n1 x1 A1) (close_tm_wrt_tm_rec n1 x1 A2)
    | a_Inj1 a2 => a_Inj1 (close_tm_wrt_tm_rec n1 x1 a2)
    | a_Inj2 a2 => a_Inj2 (close_tm_wrt_tm_rec n1 x1 a2)
    | a_Case psi a2 b1 b2 => a_Case psi (close_tm_wrt_tm_rec n1 x1 a2) (close_tm_wrt_tm_rec n1 x1 b1) (close_tm_wrt_tm_rec n1 x1 b2)
    | a_WSigma psi1 A1 B1 => a_WSigma psi1 (close_tm_wrt_tm_rec n1 x1 A1) (close_tm_wrt_tm_rec (S n1) x1 B1)
    | a_WPair a2 psi1 b1 => a_WPair (close_tm_wrt_tm_rec n1 x1 a2) psi1 (close_tm_wrt_tm_rec n1 x1 b1)
    | a_LetPair psi1 a2 b1 => a_LetPair psi1 (close_tm_wrt_tm_rec n1 x1 a2) (close_tm_wrt_tm_rec (S n1) x1 b1)
    | a_SSigma psi1 A1 B1 => a_SSigma psi1 (close_tm_wrt_tm_rec n1 x1 A1) (close_tm_wrt_tm_rec (S n1) x1 B1)
    | a_SPair a2 psi1 b1 => a_SPair (close_tm_wrt_tm_rec n1 x1 a2) psi1 (close_tm_wrt_tm_rec n1 x1 b1)
    | a_Proj1 psi1 a2 => a_Proj1 psi1 (close_tm_wrt_tm_rec n1 x1 a2)
    | a_Proj2 psi1 a2 => a_Proj2 psi1 (close_tm_wrt_tm_rec n1 x1 a2)
  end.

Definition close_tm_wrt_tm x1 a1 := close_tm_wrt_tm_rec 0 x1 a1.

(** definitions *)

(* defns JOp *)
Inductive Step : tm -> tm -> Prop :=    (* defn Step *)
 | S_AppCong : forall (a:tm) (psi:grade) (b a':tm),
     lc_tm b ->
     Step a a' ->
     Step (a_App a psi b) (a_App a' psi b)
 | S_Beta : forall (psi:grade) (A a b:tm),
     lc_tm A ->
     lc_tm (a_Abs psi A a) ->
     lc_tm b ->
     Step (a_App  ( (a_Abs psi A a) )  psi b)  (open_tm_wrt_tm  a   b )
 | S_CaseCong : forall (psi:grade) (a b1 b2 a':tm),
     lc_tm b1 ->
     lc_tm b2 ->
     Step a a' ->
     Step (a_Case psi a b1 b2) (a_Case psi a' b1 b2)
 | S_Case1Beta : forall (psi:grade) (a b1 b2:tm),
     lc_tm b2 ->
     lc_tm b1 ->
     lc_tm a ->
     Step (a_Case psi  ( (a_Inj1 a) )  b1 b2) (a_App b1 psi a)
 | S_Case2Beta : forall (psi:grade) (a b1 b2:tm),
     lc_tm b1 ->
     lc_tm b2 ->
     lc_tm a ->
     Step (a_Case psi  ( (a_Inj2 a) )  b1 b2) (a_App b2 psi a)
 | S_Proj1Cong : forall (psi:grade) (a a':tm),
     Step a a' ->
     Step (a_Proj1 psi a) (a_Proj1 psi a')
 | S_Proj2Cong : forall (psi:grade) (a a':tm),
     Step a a' ->
     Step (a_Proj2 psi a) (a_Proj2 psi a')
 | S_Proj1Beta : forall (psi:grade) (a1 a2:tm),
     lc_tm a2 ->
     lc_tm a1 ->
     Step (a_Proj1 psi (a_SPair a1 psi a2)) a1
 | S_Proj2Beta : forall (psi:grade) (a1 a2:tm),
     lc_tm a1 ->
     lc_tm a2 ->
     Step (a_Proj2 psi (a_SPair a1 psi a2)) a2
 | S_LetPairCong : forall (psi:grade) (a b a':tm),
     lc_tm (a_LetPair psi a b) ->
     Step a a' ->
     Step (a_LetPair psi a b) (a_LetPair psi a' b)
 | S_LetPairBeta : forall (psi:grade) (a1 a2 b:tm),
     lc_tm (a_LetPair psi (a_WPair a1 psi a2) b) ->
     lc_tm a1 ->
     lc_tm a2 ->
     Step (a_LetPair psi (a_WPair a1 psi a2) b) (a_App  (open_tm_wrt_tm  b   a1 )   q_Bot  a2).

(* defns Jsub *)
Inductive P_sub : econtext -> econtext -> Prop :=    (* defn P_sub *)
 | P_Empty :
     P_sub  nil   nil
 | P_Cons : forall (P1:econtext) (x:tmvar) (psi1:grade) (P2:econtext) (psi2:grade),
      ( psi1  <=  psi2 )  ->
     P_sub P1 P2 ->
      ~ AtomSetImpl.In  x  (dom  P1 )  ->
      ~ AtomSetImpl.In  x  (dom  P2 )  ->
     P_sub  (  ( x ~ psi1 )  ++ P1 )   (  ( x ~ psi2 )  ++ P2 ) .

(* defns Wsub *)
Inductive ctx_sub : context -> context -> Prop :=    (* defn ctx_sub *)
 | CS_Empty :
     ctx_sub  nil   nil
 | CS_ConsTm : forall (W1:context) (x:tmvar) (psi1:grade) (A:tm) (W2:context) (psi2:grade),
      ( psi1  <=  psi2 )  ->
     ctx_sub W1 W2 ->
      ~ AtomSetImpl.In  x  (dom  W1 )  ->
      ~ AtomSetImpl.In  x  (dom  W2 )  ->
      True  ->
     ctx_sub  (  ( x ~( psi1 , A ))  ++ W1 )   (  ( x ~( psi2 , A ))  ++ W2 ) .

(* defns JGrade *)
Inductive CGrade : econtext -> grade -> grade -> tm -> Prop :=    (* defn CGrade *)
 | CG_Leq : forall (P:econtext) (phi phi0:grade) (a:tm),
      ( phi0  <=  phi )  ->
     Grade P phi a ->
     CGrade P phi phi0 a
 | CG_Nleq : forall (P:econtext) (phi phi0:grade) (a:tm),
     lc_tm a ->
      not (  (  ( phi0  <=  phi )  )  )  ->
      uniq  P  ->
     CGrade P phi phi0 a
with Grade : econtext -> grade -> tm -> Prop :=    (* defn Grade *)
 | G_Type : forall (P:econtext) (psi:grade) (s:sort),
      uniq  P  ->
     Grade P psi (a_Type s)
 | G_Var : forall (P:econtext) (psi:grade) (x:tmvar) (psi0:grade),
      uniq  P  ->
      ( psi0  <=  psi )  ->
      binds  x   psi0   P  ->
     Grade P psi (a_Var_f x)
 | G_Pi : forall (L:vars) (P:econtext) (psi psi0:grade) (A B:tm),
     Grade P psi A ->
      ( forall x , x \notin  L  -> Grade  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     Grade P psi (a_Pi psi0 A B)
 | G_Abs : forall (L:vars) (P:econtext) (psi psi0:grade) (A b:tm),
      ( forall x , x \notin  L  -> Grade  (  ( x ~ psi0 )  ++ P )  psi  ( open_tm_wrt_tm b (a_Var_f x) )  )  ->
     CGrade P psi  q_Top  A ->
     Grade P psi (a_Abs psi0 A b)
 | G_App : forall (P:econtext) (psi:grade) (b:tm) (psi0:grade) (a:tm),
     Grade P psi b ->
     CGrade P psi psi0 a ->
     Grade P psi (a_App b psi0 a)
 | G_WSigma : forall (L:vars) (P:econtext) (psi psi0:grade) (A B:tm),
     Grade P psi A ->
      ( forall x , x \notin  L  -> Grade  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     Grade P psi (a_WSigma psi0 A B)
 | G_WPair : forall (P:econtext) (psi:grade) (a:tm) (psi0:grade) (b:tm),
     CGrade P psi psi0 a ->
     Grade P psi b ->
     Grade P psi (a_WPair a psi0 b)
 | G_LetPair : forall (L:vars) (P:econtext) (psi psi0:grade) (a c:tm),
     Grade P psi a ->
      ( forall x , x \notin  L  -> Grade  (  (  ( x ~ psi0 )  ++ P )  )  psi  ( open_tm_wrt_tm c (a_Var_f x) )  )  ->
     Grade P psi (a_LetPair psi0 a c)
 | G_SSigma : forall (L:vars) (P:econtext) (psi psi0:grade) (A B:tm),
     Grade P psi A ->
      ( forall x , x \notin  L  -> Grade  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     Grade P psi (a_SSigma psi0 A B)
 | G_SPair : forall (P:econtext) (psi:grade) (a:tm) (psi0:grade) (b:tm),
     CGrade P psi psi0 a ->
     Grade P psi b ->
     Grade P psi (a_SPair a psi0 b)
 | G_Proj1 : forall (P:econtext) (psi psi0:grade) (a:tm),
     Grade P psi a ->
      ( psi0  <=  psi )  ->
     Grade P psi (a_Proj1 psi0 a)
 | G_Proj2 : forall (P:econtext) (psi psi0:grade) (a:tm),
     Grade P psi a ->
     Grade P psi (a_Proj2 psi0 a)
 | G_Sum : forall (P:econtext) (psi:grade) (A B:tm),
     Grade P psi A ->
     Grade P psi B ->
     Grade P psi (a_Sum A B)
 | G_Inj1 : forall (P:econtext) (psi:grade) (a1:tm),
     Grade P psi a1 ->
     Grade P psi (a_Inj1 a1)
 | G_Inj2 : forall (P:econtext) (psi:grade) (a2:tm),
     Grade P psi a2 ->
     Grade P psi (a_Inj2 a2)
 | G_Case : forall (P:econtext) (psi psi0:grade) (a b1 b2:tm),
     Grade P psi a ->
     Grade P psi b1 ->
     Grade P psi b2 ->
      ( psi0  <=  psi )  ->
     Grade P psi (a_Case psi0 a b1 b2)
 | G_TyUnit : forall (P:econtext) (psi:grade),
      uniq  P  ->
     Grade P psi a_TyUnit
 | G_TmUnit : forall (P:econtext) (psi:grade),
      uniq  P  ->
     Grade P psi a_TmUnit.

(* defns JGEq *)
Inductive CEq : econtext -> grade -> grade -> tm -> tm -> Prop :=    (* defn CEq *)
 | CEq_Leq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
      ( psi0  <=  psi )  ->
     GEq P psi a1 a2 ->
     CEq P psi psi0 a1 a2
 | CEq_Nleq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     lc_tm a1 ->
     lc_tm a2 ->
      not (  (  ( psi0  <=  psi )  )  )  ->
      uniq  P  ->
     CEq P psi psi0 a1 a2
with GEq : econtext -> grade -> tm -> tm -> Prop :=    (* defn GEq *)
 | GEq_Var : forall (P:econtext) (psi:grade) (x:tmvar) (psi0:grade),
      uniq  P  ->
      binds  x   psi0   P  ->
      ( psi0  <=  psi )  ->
     GEq P psi (a_Var_f x) (a_Var_f x)
 | GEq_Type : forall (P:econtext) (psi:grade) (s:sort),
      uniq  P  ->
     GEq P psi (a_Type s) (a_Type s)
 | GEq_Pi : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 B1 A2 B2:tm),
     GEq P psi A1 A2 ->
      ( forall x , x \notin  L  -> GEq  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     GEq P psi (a_Pi psi0 A1 B1) (a_Pi psi0 A2 B2)
 | GEq_Abs : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 b1 A2 b2:tm),
      ( forall x , x \notin  L  -> GEq  (  ( x ~ psi0 )  ++ P )  psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
     CEq P psi  q_Top  A1 A2 ->
     GEq P psi (a_Abs psi0 A1 b1) (a_Abs psi0 A2 b2)
 | GEq_App : forall (P:econtext) (psi:grade) (b1:tm) (psi0:grade) (a1 b2 a2:tm),
     GEq P psi b1 b2 ->
     CEq P psi psi0 a1 a2 ->
     GEq P psi (a_App b1 psi0 a1) (a_App b2 psi0 a2)
 | GEq_WSigma : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 B1 A2 B2:tm),
     GEq P psi A1 A2 ->
      ( forall x , x \notin  L  -> GEq  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     GEq P psi (a_WSigma psi0 A1 B1) (a_WSigma psi0 A2 B2)
 | GEq_WPair : forall (P:econtext) (psi:grade) (a1:tm) (psi0:grade) (b1 a2 b2:tm),
     CEq P psi psi0 a1 a2 ->
     GEq P psi b1 b2 ->
     GEq P psi (a_WPair a1 psi0 b1) (a_WPair a2 psi0 b2)
 | GEq_LetPair : forall (L:vars) (P:econtext) (psi psi0:grade) (a1 b1 a2 b2:tm),
     GEq P psi a1 a2 ->
      ( forall x , x \notin  L  -> GEq   (  ( x ~ psi0 )  ++ P )   psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
     GEq P psi (a_LetPair psi0 a1 b1) (a_LetPair psi0 a2 b2)
 | GEq_SSigma : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 B1 A2 B2:tm),
     GEq P psi A1 A2 ->
      ( forall x , x \notin  L  -> GEq  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     GEq P psi (a_SSigma psi0 A1 B1) (a_SSigma psi0 A2 B2)
 | GEq_SPair : forall (P:econtext) (psi:grade) (a1:tm) (psi0:grade) (b1 a2 b2:tm),
     CEq P psi psi0 a1 a2 ->
     GEq P psi b1 b2 ->
     GEq P psi (a_SPair a1 psi0 b1) (a_SPair a2 psi0 b2)
 | GEq_Proj1 : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     GEq P psi a1 a2 ->
      ( psi0  <=  psi )  ->
     GEq P psi (a_Proj1 psi0 a1) (a_Proj1 psi0 a2)
 | GEq_Proj2 : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     GEq P psi a1 a2 ->
     GEq P psi (a_Proj2 psi0 a1) (a_Proj2 psi0 a2)
 | GEq_Sum : forall (P:econtext) (psi:grade) (A1 A2 A1' A2':tm),
     GEq P psi A1 A1' ->
     GEq P psi A2 A2' ->
     GEq P psi (a_Sum A1 A2) (a_Sum A1' A2')
 | GEq_Inj1 : forall (P:econtext) (psi:grade) (a1 a1':tm),
     GEq P psi a1 a1' ->
     GEq P psi (a_Inj1 a1) (a_Inj1 a1')
 | GEq_Inj2 : forall (P:econtext) (psi:grade) (a2 a2':tm),
     GEq P psi a2 a2' ->
     GEq P psi (a_Inj2 a2) (a_Inj2 a2')
 | GEq_Case : forall (P:econtext) (psi psi0:grade) (a b1 b2 a' b1' b2':tm),
     GEq P psi a a' ->
     GEq P psi b1 b1' ->
     GEq P psi b2 b2' ->
      ( psi0  <=  psi )  ->
     GEq P psi (a_Case psi0 a b1 b2) (a_Case psi0 a' b1' b2')
 | GEq_TyUnit : forall (P:econtext) (psi:grade),
      uniq  P  ->
     GEq P psi a_TyUnit a_TyUnit
 | GEq_TmUnit : forall (P:econtext) (psi:grade),
      uniq  P  ->
     GEq P psi a_TmUnit a_TmUnit.

(* defns JUnTyDefEq *)
Inductive CDefEq : econtext -> grade -> grade -> tm -> tm -> Prop :=    (* defn CDefEq *)
 | CDefEq_Leq : forall (P:econtext) (phi phi0:grade) (a b:tm),
      ( phi0  <=  phi )  ->
     DefEq P phi a b ->
     CDefEq P phi phi0 a b
 | CDefEq_Nleq : forall (P:econtext) (phi phi0:grade) (a b:tm),
     lc_tm a ->
     lc_tm b ->
      not (  (  ( phi0  <=  phi )  )  )  ->
      uniq  P  ->
     CDefEq P phi phi0 a b
with DefEq : econtext -> grade -> tm -> tm -> Prop :=    (* defn DefEq *)
 | Eq_Refl : forall (P:econtext) (psi:grade) (a:tm),
     Grade P psi a ->
     DefEq P psi a a
 | Eq_Trans : forall (P:econtext) (psi:grade) (a c b:tm),
     DefEq P psi a b ->
     DefEq P psi b c ->
     DefEq P psi a c
 | Eq_Sym : forall (P:econtext) (psi:grade) (b a:tm),
     DefEq P psi a b ->
     DefEq P psi b a
 | Eq_Beta : forall (P:econtext) (psi:grade) (a b:tm),
     Grade P psi a ->
     Step a b ->
     Grade P psi b ->
     DefEq P psi a b
 | Eq_Pi : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 B1 A2 B2:tm),
     DefEq P psi A1 A2 ->
      ( forall x , x \notin  L  -> DefEq  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     DefEq P psi (a_Pi psi0 A1 B1) (a_Pi psi0 A2 B2)
 | Eq_Abs : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 b1 A2 b2:tm),
     CDefEq P psi  q_Top  A1 A2 ->
      ( forall x , x \notin  L  -> DefEq  (  ( x ~ psi0 )  ++ P )  psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
     DefEq P psi (a_Abs psi0 A1 b1) (a_Abs psi0 A2 b2)
 | Eq_App : forall (P:econtext) (psi:grade) (b1:tm) (psi0:grade) (a1 b2 a2:tm),
     DefEq P psi b1 b2 ->
     CDefEq P psi psi0 a1 a2 ->
     DefEq P psi (a_App b1 psi0 a1) (a_App b2 psi0 a2)
 | Eq_PiFst : forall (P:econtext) (psi:grade) (A1 A2:tm) (psi0:grade) (B1 B2:tm),
     DefEq P psi (a_Pi psi0 A1 B1) (a_Pi psi0 A2 B2) ->
     DefEq P psi A1 A2
 | Eq_PiSnd : forall (P:econtext) (psi:grade) (B1 a1 B2 a2:tm) (psi0:grade) (A1 A2:tm),
     DefEq P psi (a_Pi psi0 A1 B1) (a_Pi psi0 A2 B2) ->
     DefEq P psi a1 a2 ->
     DefEq P psi  (open_tm_wrt_tm  B1   a1 )   (open_tm_wrt_tm  B2   a2 )
 | Eq_WSigma : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 B1 A2 B2:tm),
     DefEq P psi A1 A2 ->
      ( forall x , x \notin  L  -> DefEq  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     DefEq P psi (a_WSigma psi0 A1 B1) (a_WSigma psi0 A2 B2)
 | Eq_WSigmaFst : forall (P:econtext) (psi:grade) (A1 A2:tm) (psi0:grade) (B1 B2:tm),
     DefEq P psi (a_WSigma psi0 A1 B1) (a_WSigma psi0 A2 B2) ->
     DefEq P psi A1 A2
 | Eq_WSigmaSnd : forall (P:econtext) (psi:grade) (B1 a B2:tm) (psi0:grade) (A1 A2:tm),
     DefEq P psi (a_WSigma psi0 A1 B1) (a_WSigma psi0 A2 B2) ->
     Grade P psi a ->
     DefEq P psi  (open_tm_wrt_tm  B1   a )   (open_tm_wrt_tm  B2   a )
 | Eq_WPair : forall (P:econtext) (psi:grade) (a1:tm) (psi0:grade) (b1 a2 b2:tm),
     CDefEq P psi psi0 a1 a2 ->
     DefEq P psi b1 b2 ->
     DefEq P psi (a_WPair a1 psi0 b1) (a_WPair a2 psi0 b2)
 | Eq_LetPair : forall (L:vars) (P:econtext) (psi psi0:grade) (a1 b1 a2 b2:tm),
     DefEq P psi a1 a2 ->
      ( forall x , x \notin  L  -> DefEq   (  ( x ~ psi0 )  ++ P )   psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
     DefEq P psi (a_LetPair psi0 a1 b1) (a_LetPair psi0 a2 b2)
 | Eq_SSigma : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 B1 A2 B2:tm),
     DefEq P psi A1 A2 ->
      ( forall x , x \notin  L  -> DefEq  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     DefEq P psi (a_SSigma psi0 A1 B1) (a_SSigma psi0 A2 B2)
 | Eq_SSigmaFst : forall (P:econtext) (psi:grade) (A1 A2:tm) (psi0:grade) (B1 B2:tm),
     DefEq P psi (a_SSigma psi0 A1 B1) (a_SSigma psi0 A2 B2) ->
     DefEq P psi A1 A2
 | Eq_SSigmaSnd : forall (P:econtext) (psi:grade) (B1 a1 B2 a2:tm) (psi0:grade) (A1 A2:tm),
     DefEq P psi (a_SSigma psi0 A1 B1) (a_SSigma psi0 A2 B2) ->
     DefEq P psi a1 a2 ->
     DefEq P psi  (open_tm_wrt_tm  B1   a1 )   (open_tm_wrt_tm  B2   a2 )
 | Eq_SPair : forall (P:econtext) (psi:grade) (a1:tm) (psi0:grade) (b1 a2 b2:tm),
     CDefEq P psi psi0 a1 a2 ->
     DefEq P psi b1 b2 ->
     DefEq P psi (a_SPair a1 psi0 b1) (a_SPair a2 psi0 b2)
 | Eq_Proj1 : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     DefEq P psi a1 a2 ->
      ( psi0  <=  psi )  ->
     DefEq P psi (a_Proj1 psi0 a1) (a_Proj1 psi0 a2)
 | Eq_Proj2 : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     DefEq P psi a1 a2 ->
     DefEq P psi (a_Proj2 psi0 a1) (a_Proj2 psi0 a2)
 | Eq_Sum : forall (P:econtext) (psi:grade) (A1 A2 A1' A2':tm),
     DefEq P psi A1 A1' ->
     DefEq P psi A2 A2' ->
     DefEq P psi (a_Sum A1 A2) (a_Sum A1' A2')
 | Eq_SumFst : forall (P:econtext) (psi:grade) (A1 A1' A2 A2':tm),
     DefEq P psi (a_Sum A1 A2) (a_Sum A1' A2') ->
     DefEq P psi A1 A1'
 | Eq_SumSnd : forall (P:econtext) (psi:grade) (A2 A2' A1 A1':tm),
     DefEq P psi (a_Sum A1 A2) (a_Sum A1' A2') ->
     DefEq P psi A2 A2'
 | Eq_Inj1 : forall (P:econtext) (psi:grade) (a1 a1':tm),
     DefEq P psi a1 a1' ->
     DefEq P psi (a_Inj1 a1) (a_Inj1 a1')
 | Eq_Inj2 : forall (P:econtext) (psi:grade) (a2 a2':tm),
     DefEq P psi a2 a2' ->
     DefEq P psi (a_Inj2 a2) (a_Inj2 a2')
 | Eq_Case : forall (P:econtext) (psi psi0:grade) (a b1 b2 a' b1' b2':tm),
     DefEq P psi a a' ->
     DefEq P psi b1 b1' ->
     DefEq P psi b2 b2' ->
      ( psi0  <=  psi )  ->
     DefEq P psi (a_Case psi0 a b1 b2) (a_Case psi0 a' b1' b2')
 | Eq_TyUnit : forall (P:econtext) (psi:grade),
      uniq  P  ->
     DefEq P psi a_TyUnit a_TyUnit
 | Eq_TmUnit : forall (P:econtext) (psi:grade),
      uniq  P  ->
     DefEq P psi a_TmUnit a_TmUnit
 | Eq_SubstIrrel : forall (L:vars) (P:econtext) (phi:grade) (b1 a1 b2 a2:tm) (psi:grade),
     lc_tm a1 ->
     lc_tm a2 ->
      True  ->
      True  ->
      ( forall x , x \notin  L  -> DefEq  (  ( x ~ psi )  ++ P )  phi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
      not (  (  ( psi  <=  phi )  )  )  ->
     DefEq P phi  (open_tm_wrt_tm  b1   a1 )   (open_tm_wrt_tm  b2   a2 ) .

(* defns JTyping *)
Inductive Typing : context -> grade -> tm -> tm -> Prop :=    (* defn Typing *)
 | T_Type : forall (W:context) (psi:grade) (s1 s2:sort),
      uniq  W  ->
      ( psi  <=   q_C  )  ->
      axiom  s1   s2  ->
     Typing W psi (a_Type s1) (a_Type s2)
 | T_Conv : forall (W:context) (psi:grade) (a B A:tm) (s:sort),
     Typing W psi a A ->
     DefEq  (labels   (meet_ctx_l   q_C    W )  )   q_C  A B ->
     Typing  (meet_ctx_l   q_C    W )   q_C  B (a_Type s) ->
     Typing W psi a B
 | T_Var : forall (W:context) (psi:grade) (x:tmvar) (A:tm) (psi0:grade),
      uniq  W  ->
      ( psi0  <=  psi )  ->
      binds  x  ( psi0 ,  A )  W  ->
      ( psi  <=   q_C  )  ->
     Typing W psi (a_Var_f x) A
 | T_Pi : forall (L:vars) (W:context) (psi psi0:grade) (A B:tm) (s3 s1 s2:sort),
     Typing W psi A (a_Type s1) ->
      ( forall x , x \notin  L  -> Typing  (  ( x ~( psi , A ))  ++ W )  psi  ( open_tm_wrt_tm B (a_Var_f x) )  (a_Type s2) )  ->
      rule_pi  s1   s2   s3  ->
     Typing W psi (a_Pi psi0 A B) (a_Type s3)
 | T_Abs : forall (L:vars) (W:context) (psi psi0:grade) (A b B:tm) (s:sort),
      ( forall x , x \notin  L  -> Typing  (  ( x ~(  (q_join  psi0   psi )  , A ))  ++ W )  psi  ( open_tm_wrt_tm b (a_Var_f x) )   ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     Typing  (meet_ctx_l   q_C    W )   q_C   ( (a_Pi psi0 A B) )  (a_Type s) ->
     Typing W psi (a_Abs psi0 A b) (a_Pi psi0 A B)
 | T_App : forall (W:context) (psi:grade) (b:tm) (psi0:grade) (a B A:tm),
     Typing W psi b (a_Pi psi0 A B) ->
     Typing W  (q_join  psi0   psi )  a A ->
      ( psi0  <=   q_C  )  ->
     Typing W psi (a_App b psi0 a)  (open_tm_wrt_tm  B   a )
 | T_AppIrrel : forall (W:context) (psi:grade) (b:tm) (psi0:grade) (a B A:tm),
     Typing W psi b (a_Pi psi0 A B) ->
     Typing  (meet_ctx_l   q_C    W )   q_C  a A ->
      (  q_C   <  psi0 )  ->
     Typing W psi (a_App b psi0 a)  (open_tm_wrt_tm  B   a )
 | T_WSigma : forall (L:vars) (W:context) (psi psi0:grade) (A B:tm) (s3 s1 s2:sort),
     Typing W psi A (a_Type s1) ->
      ( forall x , x \notin  L  -> Typing  (  ( x ~( psi , A ))  ++ W )  psi  ( open_tm_wrt_tm B (a_Var_f x) )  (a_Type s2) )  ->
      rule_sig  s1   s2   s3  ->
     Typing W psi (a_WSigma psi0 A B) (a_Type s3)
 | T_WPair : forall (W:context) (psi:grade) (a:tm) (psi0:grade) (b A B:tm) (s:sort),
     Typing  (meet_ctx_l   q_C    W )   q_C   ( (a_WSigma psi0 A B) )  (a_Type s) ->
     Typing W  (q_join  psi0   psi )  a A ->
     Typing W psi b  (open_tm_wrt_tm  B   a )  ->
      ( psi0  <=   q_C  )  ->
     Typing W psi (a_WPair a psi0 b) (a_WSigma psi0 A B)
 | T_WPairIrrel : forall (W:context) (psi:grade) (a:tm) (psi0:grade) (b A B:tm) (s:sort),
     Typing  (meet_ctx_l   q_C    W )   q_C   ( (a_WSigma psi0 A B) )  (a_Type s) ->
     Typing  (meet_ctx_l   q_C    W )   q_C  a A ->
      (  q_C   <  psi0 )  ->
     Typing W psi b  (open_tm_wrt_tm  B   a )  ->
     Typing W psi (a_WPair a psi0 b) (a_WSigma psi0 A B)
| T_LetPair : forall (L:vars) (W:context) (psi psi0:grade) (a c C B A:tm) (s:sort),
       ( forall x , x \notin  L  ->
               Typing ((x ~ (q_C, a_WSigma psi0 A B)) ++ meet_ctx_l q_C W) q_C (open_tm_wrt_tm C (a_Var_f x)) (a_Type s))  ->
       Typing W psi a (a_WSigma psi0 A B) ->
       ( forall x , x \notin  L  ->
         forall y,  y \notin L \u {{x}} ->
               Typing ((x ~ ((q_join psi0 psi), A)) ++ W) psi (open_tm_wrt_tm c (a_Var_f x))
                    (a_Pi q_Bot (open_tm_wrt_tm B (a_Var_f x))
                           (close_tm_wrt_tm y (open_tm_wrt_tm C (a_WPair (a_Var_f x) psi0 (a_Var_f y)))))) ->
       (Typing W psi (a_LetPair psi0 a c)  (open_tm_wrt_tm C a))
 | T_SSigma : forall (L:vars) (W:context) (psi psi0:grade) (A B:tm) (s3 s1 s2:sort),
     Typing W psi A (a_Type s1) ->
      ( forall x , x \notin  L  -> Typing  (  ( x ~( psi , A ))  ++ W )  psi  ( open_tm_wrt_tm B (a_Var_f x) )  (a_Type s2) )  ->
      rule_sig  s1   s2   s3  ->
     Typing W psi (a_SSigma psi0 A B) (a_Type s3)
 | T_SPair : forall (W:context) (psi:grade) (a:tm) (psi0:grade) (b A B:tm) (s:sort),
     Typing  (meet_ctx_l   q_C    W )   q_C  (a_SSigma psi0 A B) (a_Type s) ->
     Typing W  (q_join  psi0   psi )  a A ->
     Typing W psi b  (open_tm_wrt_tm  B   a )  ->
      ( psi0  <=   q_C  )  ->
     Typing W psi (a_SPair a psi0 b) (a_SSigma psi0 A B)
 | T_Proj1 : forall (W:context) (psi psi0:grade) (a A B:tm),
     Typing W psi a (a_SSigma psi0 A B) ->
      ( psi0  <=  psi )  ->
     Typing W psi (a_Proj1 psi0 a) A
 | T_Proj2 : forall (W:context) (psi psi0:grade) (a B A:tm),
     Typing W psi a (a_SSigma psi0 A B) ->
      ( psi0  <=   q_C  )  ->
     Typing W psi (a_Proj2 psi0 a)  (open_tm_wrt_tm  B   (a_Proj1 psi0 a) )
 | T_Sum : forall (W:context) (psi:grade) (A B:tm) (s:sort),
     Typing W psi A (a_Type s) ->
     Typing W psi B (a_Type s) ->
     Typing W psi (a_Sum A B) (a_Type s)
 | T_Inj1 : forall (W:context) (psi:grade) (a1 A1 A2:tm) (s:sort),
     Typing W psi a1 A1 ->
     Typing  (meet_ctx_l   q_C    W )   q_C  (a_Sum A1 A2) (a_Type s) ->
     Typing W psi (a_Inj1 a1) (a_Sum A1 A2)
 | T_Inj2 : forall (W:context) (psi:grade) (a2 A1 A2:tm) (s:sort),
     Typing W psi a2 A2 ->
     Typing  (meet_ctx_l   q_C    W )   q_C  (a_Sum A1 A2) (a_Type s) ->
     Typing W psi (a_Inj2 a2) (a_Sum A1 A2)
| T_Case : forall (L:vars) (W:context) (psi psi0:grade) (a b1 b2 B:tm) (A1 A2 B1 B2:tm) s,
       ( forall z, z \notin    L ->  Typing  (  (  ( z ~(  q_C  , (a_Sum A1 A2) ))  ++  (  (meet_ctx_l   q_C    W )  )  )  )   q_C  (open_tm_wrt_tm B (a_Var_f z)) (a_Type s)) ->
     Typing W psi a (a_Sum A1 A2) ->
      ( forall x , x \notin  L  ->   ( open_tm_wrt_tm B1 (a_Var_f x) )  =   (open_tm_wrt_tm  B   (a_Inj1 (a_Var_f x)) )    )  ->
      ( forall y , y \notin  L  ->   ( open_tm_wrt_tm B2 (a_Var_f y) )  =   (open_tm_wrt_tm  B   (a_Inj2 (a_Var_f y)) )    )  ->
     Typing W psi b1 (a_Pi psi0 A1 B1) ->
     Typing W psi b2 (a_Pi psi0 A2 B2) ->
      ( psi0  <=  psi )  ->
     Typing W psi (a_Case psi0 a b1 b2)  (open_tm_wrt_tm  B   a )
 | T_TmUnit : forall (W:context) (psi:grade) (s:sort),
      uniq  W  ->
      ( psi  <=   q_C  )  ->
     Typing W psi a_TyUnit (a_Type s)
 | T_TyUnit : forall (W:context) (psi:grade),
      uniq  W  ->
      ( psi  <=   q_C  )  ->
     Typing W psi a_TmUnit a_TyUnit.

(* defns JCTyping *)
Inductive CTyping : context -> grade -> tm -> tm -> Prop :=    (* defn CTyping *)
 | CT_Leq : forall (W:context) (psi:grade) (a A:tm),
     Typing W psi a A ->
      ( psi  <=   q_C  )  ->
     CTyping W psi a A
 | CT_Top : forall (W:context) (psi:grade) (a A:tm),
     Typing  (meet_ctx_l   q_C    W )   q_C  a A ->
      (  q_C   <  psi )  ->
     CTyping W psi a A.

(* defns JCtx *)
Inductive Ctx : context -> Prop :=    (* defn Ctx *)
 | Ctx_Empty :
     Ctx  nil
 | Ctx_Cons : forall (W:context) (x:tmvar) (psi0:grade) (A:tm) (s:sort),
     Ctx W ->
     Typing  (meet_ctx_l   q_C    W )   q_C  A (a_Type s) ->
      ~ AtomSetImpl.In  x  (dom  W )  ->
     Ctx  (  ( x ~( psi0 , A ))  ++ W ) .

(* defns JValueType *)
Inductive ValueType : tm -> Prop :=    (* defn ValueType *)
 | ValueType_Type : forall (s:sort),
     ValueType (a_Type s)
 | ValueType_Unit :
     ValueType a_TyUnit
 | ValueType_Pi : forall (psi:grade) (A B:tm),
     lc_tm A ->
     lc_tm (a_Pi psi A B) ->
     ValueType (a_Pi psi A B)
 | ValueType_WSigma : forall (psi:grade) (A B:tm),
     lc_tm A ->
     lc_tm (a_WSigma psi A B) ->
     ValueType (a_WSigma psi A B)
 | ValueType_SSigma : forall (psi:grade) (A B:tm),
     lc_tm A ->
     lc_tm (a_SSigma psi A B) ->
     ValueType (a_SSigma psi A B)
 | ValueType_Sum : forall (A B:tm),
     lc_tm A ->
     lc_tm B ->
     ValueType (a_Sum A B).

(* defns JConsistent *)
Inductive Consistent : tm -> tm -> Prop :=    (* defn Consistent *)
 | Consistent_a_Type : forall (s:sort),
     Consistent (a_Type s) (a_Type s)
 | Consistent_a_Unit :
     Consistent a_TyUnit a_TyUnit
 | Consistent_a_Pi : forall (psi:grade) (A B A' B':tm),
     lc_tm A ->
     lc_tm (a_Pi psi A B) ->
     lc_tm A' ->
     lc_tm (a_Pi psi A' B') ->
     Consistent  ( (a_Pi psi A B) )   ( (a_Pi psi A' B') )
 | Consistent_a_WSigma : forall (psi:grade) (A B A' B':tm),
     lc_tm A ->
     lc_tm (a_WSigma psi A B) ->
     lc_tm A' ->
     lc_tm (a_WSigma psi A' B') ->
     Consistent  ( (a_WSigma psi A B) )   ( (a_WSigma psi A' B') )
 | Consistent_a_SSigma : forall (psi:grade) (A B A' B':tm),
     lc_tm A ->
     lc_tm (a_SSigma psi A B) ->
     lc_tm A' ->
     lc_tm (a_SSigma psi A' B') ->
     Consistent  (a_SSigma psi A B)   (a_SSigma psi A' B')
 | Consistent_a_Sum : forall (A B A' B':tm),
     lc_tm A ->
     lc_tm B ->
     lc_tm A' ->
     lc_tm B' ->
     Consistent  ( (a_Sum A B) )   ( (a_Sum A' B') )
 | Consistent_a_Step_R : forall (a b:tm),
     lc_tm b ->
      not ( ValueType a )  ->
     Consistent a b
 | Consistent_a_Step_L : forall (a b:tm),
     lc_tm a ->
      not ( ValueType b )  ->
     Consistent a b.

(* defns JPar *)
Inductive CPar : econtext -> grade -> grade -> tm -> tm -> Prop :=    (* defn CPar *)
 | CPar_Leq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
      ( psi0  <=  psi )  ->
     Par P psi a1 a2 ->
     CPar P psi psi0 a1 a2
 | CPar_Nleq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     lc_tm a1 ->
     lc_tm a2 ->
      not (  (  ( psi0  <=  psi )  )  )  ->
      uniq  P  ->
     CPar P psi psi0 a1 a2
with Par : econtext -> grade -> tm -> tm -> Prop :=    (* defn Par *)
 | Par_Refl : forall (P:econtext) (psi:grade) (a:tm),
     Grade P psi a ->
     Par P psi a a
 | Par_Pi : forall (L:vars) (P:econtext) (psi psi1:grade) (A1 B1 A2 B2:tm),
     Par P psi A1 A2 ->
      ( forall x , x \notin  L  -> Par  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     Par P psi (a_Pi psi1 A1 B1) (a_Pi psi1 A2 B2)
 | Par_AppBeta : forall (P:econtext) (psi:grade) (a:tm) (psi0:grade) (b a' b' A:tm),
     Par P psi a  ( (a_Abs psi0 A a') )  ->
     CPar P psi psi0 b b' ->
     Par P psi (a_App a psi0 b)  (open_tm_wrt_tm  a'   b' )
 | Par_App : forall (P:econtext) (psi:grade) (a:tm) (psi0:grade) (b a' b':tm),
     Par P psi a a' ->
     CPar P psi psi0 b b' ->
     Par P psi (a_App a psi0 b) (a_App a' psi0 b')
 | Par_Abs : forall (L:vars) (P:econtext) (psi psi0:grade) (A1 b1 A2 b2:tm),
      ( forall x , x \notin  L  -> Par  (  ( x ~ psi0 )  ++ P )  psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
     CPar P psi  q_Top  A1 A2 ->
     Par P psi (a_Abs psi0 A1 b1) (a_Abs psi0 A2 b2)
 | Par_WSigma : forall (L:vars) (P:econtext) (psi psi1:grade) (A1 B1 A2 B2:tm),
     Par P psi A1 A2 ->
      ( forall x , x \notin  L  -> Par  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     Par P psi (a_WSigma psi1 A1 B1) (a_WSigma psi1 A2 B2)
 | Par_WPair : forall (P:econtext) (psi:grade) (a1:tm) (psi0:grade) (b1 a2 b2:tm),
     CPar P psi psi0 a1 a2 ->
     Par P psi b1 b2 ->
     Par P psi (a_WPair a1 psi0 b1) (a_WPair a2 psi0 b2)
 | Par_WPairBeta : forall (L:vars) (P:econtext) (psi psi0:grade) (a1 b1 b2 a1' a2':tm),
     Par P psi a1 (a_WPair a1' psi0 a2') ->
      ( forall x , x \notin  L  -> Par  (  ( x ~ psi0 )  ++ P )  psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   (open_tm_wrt_tm  b2   (a_Var_f x) )  )  ->
     Par P psi (a_LetPair psi0 a1 b1) (a_App  (open_tm_wrt_tm  b2   a1' )   q_Bot  a2')
 | Par_LetPair : forall (L:vars) (P:econtext) (psi psi0:grade) (a1 b1 a2 b2:tm),
     Par P psi a1 a2 ->
      ( forall x , x \notin  L  -> Par  (  ( x ~ psi0 )  ++ P )  psi  ( open_tm_wrt_tm b1 (a_Var_f x) )   ( open_tm_wrt_tm b2 (a_Var_f x) )  )  ->
     Par P psi (a_LetPair psi0 a1 b1) (a_LetPair psi0 a2 b2)
 | Par_SSigma : forall (L:vars) (P:econtext) (psi psi1:grade) (A1 B1 A2 B2:tm),
     Par P psi A1 A2 ->
      ( forall x , x \notin  L  -> Par  (  ( x ~ psi )  ++ P )  psi  ( open_tm_wrt_tm B1 (a_Var_f x) )   ( open_tm_wrt_tm B2 (a_Var_f x) )  )  ->
     Par P psi (a_SSigma psi1 A1 B1) (a_SSigma psi1 A2 B2)
 | Par_SPair : forall (P:econtext) (psi:grade) (a1:tm) (psi0:grade) (b1 a2 b2:tm),
     CPar P psi psi0 a1 a2 ->
     Par P psi b1 b2 ->
     Par P psi (a_SPair a1 psi0 b1) (a_SPair a2 psi0 b2)
 | Par_Proj1Beta : forall (P:econtext) (psi psi0:grade) (a1 a1' a2:tm),
     Par P psi a1 (a_SPair a1' psi0 a2) ->
      ( psi0  <=  psi )  ->
     Par P psi (a_Proj1 psi0 a1) a1'
 | Par_Proj1 : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     Par P psi a1 a2 ->
      ( psi0  <=  psi )  ->
     Par P psi (a_Proj1 psi0 a1) (a_Proj1 psi0 a2)
 | Par_Proj2Beta : forall (P:econtext) (psi psi0:grade) (a1 a2 a1':tm),
     Par P psi a1 (a_SPair a1' psi0 a2) ->
     Par P psi (a_Proj2 psi0 a1) a2
 | Par_Proj2 : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     Par P psi a1 a2 ->
     Par P psi (a_Proj2 psi0 a1) (a_Proj2 psi0 a2)
 | Par_Sum : forall (P:econtext) (psi:grade) (A1 A2 A1' A2':tm),
     Par P psi A1 A1' ->
     Par P psi A2 A2' ->
     Par P psi (a_Sum A1 A2) (a_Sum A1' A2')
 | Par_Inj1 : forall (P:econtext) (psi:grade) (a1 a1':tm),
     Par P psi a1 a1' ->
     Par P psi (a_Inj1 a1) (a_Inj1 a1')
 | Par_Inj2 : forall (P:econtext) (psi:grade) (a2 a2':tm),
     Par P psi a2 a2' ->
     Par P psi (a_Inj2 a2) (a_Inj2 a2')
 | Par_CaseBeta1 : forall (P:econtext) (psi psi0:grade) (a b1 b2 b1' a' b2':tm),
     Par P psi a (a_Inj1 a') ->
     Par P psi b1 b1' ->
     Par P psi b2 b2' ->
      ( psi0  <=  psi )  ->
     Par P psi (a_Case psi0 a b1 b2) (a_App b1' psi0 a')
 | Par_CaseBeta2 : forall (P:econtext) (psi psi0:grade) (a b1 b2 b2' a' b1':tm),
     Par P psi a (a_Inj2 a') ->
     Par P psi b1 b1' ->
     Par P psi b2 b2' ->
      ( psi0  <=  psi )  ->
     Par P psi (a_Case psi0 a b1 b2) (a_App b2' psi0 a')
 | Par_Case : forall (P:econtext) (psi psi0:grade) (a b1 b2 a' b1' b2':tm),
     Par P psi a a' ->
     Par P psi b1 b1' ->
     Par P psi b2 b2' ->
      ( psi0  <=  psi )  ->
     Par P psi (a_Case psi0 a b1 b2) (a_Case psi0 a' b1' b2').

(* defns JMultiPar *)
Inductive MultiPar : econtext -> grade -> tm -> tm -> Prop :=    (* defn MultiPar *)
 | MP_Refl : forall (P:econtext) (psi:grade) (a:tm),
     Grade P psi a ->
     MultiPar P psi a a
 | MP_Step : forall (P:econtext) (psi:grade) (a a' b:tm),
     Par P psi a b ->
     MultiPar P psi b a' ->
     MultiPar P psi a a'.

(* defns JJoins *)
Inductive Joins : econtext -> grade -> tm -> tm -> Prop :=    (* defn Joins *)
 | join : forall (P:econtext) (psi:grade) (a1 a2 b1 b2:tm),
     MultiPar P psi a1 b1 ->
     MultiPar P psi a2 b2 ->
     GEq P psi b1 b2 ->
     Joins P psi a1 a2.

(* defns JValue *)
Inductive Value : tm -> Prop :=    (* defn Value *)
 | V_ValueType : forall (a:tm),
     ValueType a ->
     Value a
 | V_TmUnit :
     Value a_TmUnit
 | V_Abs : forall (psi:grade) (A a:tm),
     lc_tm A ->
     lc_tm (a_Abs psi A a) ->
     Value (a_Abs psi A a)
 | V_WPair : forall (a:tm) (psi:grade) (b:tm),
     lc_tm a ->
     lc_tm b ->
     Value (a_WPair a psi b)
 | V_SPair : forall (a:tm) (psi:grade) (b:tm),
     lc_tm a ->
     lc_tm b ->
     Value (a_SPair a psi b)
 | V_Inj1 : forall (a:tm),
     lc_tm a ->
     Value (a_Inj1 a)
 | V_Inj2 : forall (a:tm),
     lc_tm a ->
     Value (a_Inj2 a).

(* defns JCMultiPar *)
Inductive CMultiPar : econtext -> grade -> grade -> tm -> tm -> Prop :=    (* defn CMultiPar *)
 | CMP_Leq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
      ( psi0  <=  psi )  ->
     MultiPar P psi a1 a2 ->
     CMultiPar P psi psi0 a1 a2
 | CMP_Nleq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     lc_tm a1 ->
     lc_tm a2 ->
      not (  (  ( psi0  <=  psi )  )  )  ->
      uniq  P  ->
     CMultiPar P psi psi0 a1 a2.

(* defns JCJoins *)
Inductive CJoins : econtext -> grade -> grade -> tm -> tm -> Prop :=    (* defn CJoins *)
 | CJ_Leq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
      ( psi0  <=  psi )  ->
     Joins P psi a1 a2 ->
     CJoins P psi psi0 a1 a2
 | CJ_Nleq : forall (P:econtext) (psi psi0:grade) (a1 a2:tm),
     lc_tm a1 ->
     lc_tm a2 ->
      not (  (  ( psi0  <=  psi )  )  )  ->
      uniq  P  ->
     CJoins P psi psi0 a1 a2.

(** infrastructure *)
Hint Constructors Step P_sub ctx_sub CGrade Grade CEq GEq CDefEq DefEq Typing CTyping Ctx ValueType Consistent CPar Par MultiPar Joins Value CMultiPar CJoins lc_tm : core.


From mathcomp.ssreflect Require Import ssrnat ssrbool div.
Require Import List Omega.

Require PArith.

Ltac inv H :=
  inversion H; clear H; subst; simpl in *.

Record Order : Type :=
  mk_order {
      amountS : nat;
      amountB : nat;
      fillS : nat;
      fillB : nat;
    }.

Definition Ring : Type := list Order.

(**
    Loopring order ring structure :

    | S0 |  / | S1 |  / ...  / | SN |
    | B0 | /  | B1 | /  ... /  | BN |

    In this file we organize ring as
    Order_{N-1} :: Order_{N-2} :: ... :: Order_0 :: nil

 *)

Definition upd_order (order: Order) (fillS' fillB': nat) :=
  mk_order (amountS order) (amountB order) fillS' fillB'.

Definition shrink_S (B': nat) (order: Order) : nat := (B' * amountS order) %/ amountB order.

Definition shrink_order (prev cur: Order) : Order :=
  if fillS prev < fillB cur
  then upd_order cur (shrink_S (fillS prev) cur) (fillS prev)
  else cur.

(** shrink Order_{k-1} according to Order_{k},
    k in {1, ..., N-1} *)

Fixpoint shrink_ring_aux (prev: Order) (orderring: Ring) : Ring :=
  match orderring with
  | nil => nil
  | cur :: orderring' =>
    let cur' :=  shrink_order prev cur in
    cur' :: shrink_ring_aux cur' orderring'
  end.

Definition shrink_ring (orderring: Ring) : option Ring :=
  match orderring with
  | nil
  | _ :: nil => None
  | lastorder :: orderring =>
    Some (lastorder :: shrink_ring_aux lastorder orderring)
  end.

Definition check_last_can_fill (orderring: Ring) : bool :=
  match orderring with
  | nil
  | _ :: nil => false
  | lastorder :: orderring =>
    let order0' := last orderring lastorder in
    fillS order0' >= fillB lastorder
  end.

Definition calc_fill_amount (orderring: Ring) : option Ring :=
  (** The first pass *)
  match shrink_ring orderring with
  | None
  | Some nil
  | Some (_ :: nil) => None
  | Some (lastorder :: orderring') =>
    if check_last_can_fill (lastorder :: orderring')
    then Some (lastorder :: orderring')
    else
      let order0' := last orderring' lastorder in
      let lastorder' := shrink_order order0' lastorder in
      shrink_ring (lastorder' :: orderring')
  end.

(** * Correctness *)
Require Import QArith.

Section Correctness.

  (** Pre-conditions *)

  Definition PreConditionFill : Ring -> Prop :=
    Forall (fun order => fillS order = amountS order /\ fillB order = amountB order).

  Definition mult_gamma (product: Q) (order: Order) : Q :=
    product * inject_Z (Z.of_nat (amountS order)) / inject_Z (Z.of_nat (amountB order)).

  Definition mult_gamma_nat (product: nat) (order: Order) : nat :=
    (product * (amountS order) %/ (amountB order))%nat.

  Definition fillB_mult_gamma (fillB: nat) (r: Ring) : nat :=
    fold_left mult_gamma_nat r fillB.

  Definition PreConditionGamma (r : Ring) : Prop :=
    forall  o r1,
      shrink_ring r = Some (o :: r1) ->
      let last' := shrink_order (last r1 o ) o in
      (fillB last' <= fillB_mult_gamma (fillB last') r)%nat.

  Lemma pre_condition_gamma_implies:
    forall r,
      PreConditionGamma r ->
      forall  o o0 r1,
        shrink_ring r = Some (o :: o0 :: r1) ->
        let last' := shrink_order (last (o0 :: r1) o ) o in
        (fillB last' <=
         fillB_mult_gamma (fillB last') r)%nat.
  Proof. auto. Qed.

  Definition PreConditionLength (orderring : Ring ) : Prop :=
    (length orderring >= 2)%nat.

  (** Post-conditions *)

  Definition AlmostCanFill (orderring : Ring) : Prop :=
    forall n orderprev ordercur,
      nth_error orderring n = Some orderprev ->
      nth_error orderring n.+1 = Some ordercur ->
      (fillS orderprev >= fillB ordercur)%nat.

  Definition CanFill (orderring : Ring) : Prop :=
    AlmostCanFill orderring
    /\ check_last_can_fill orderring = true.

  Definition OrderWinWin : Order -> Prop :=
    (fun order => fillS order * amountB order <= amountS order * fillB order
               /\ fillS order <= amountS order
               /\ fillB order <= amountB order)%nat.

  Definition WinWin : Ring -> Prop :=
    Forall OrderWinWin.

  Definition OrderRateUnchanged : Order -> Order -> Prop :=
    (fun order order' => amountS order = amountS order' /\ amountB order = amountB order').

  Definition RateUnchanged : Ring -> Ring -> Prop :=
    Forall2 OrderRateUnchanged.

  Definition Correct (orderring orderring': Ring) :=
    RateUnchanged orderring orderring'
    /\ CanFill orderring'
    /\ WinWin orderring'.

  (** Lemmas *)

  (** ** Rate unchanged *)
  Lemma rate_unchanged_after_shrinking_order:
    forall order prev,
      OrderRateUnchanged order (shrink_order prev order).
  Proof.
    unfold shrink_order, upd_order, OrderRateUnchanged; intros.
    destruct leq; auto.
  Qed.

  Lemma rate_unchanged_after_shrinking_ring_aux:
    forall ring1 prev ring2,
      shrink_ring_aux prev ring1 = ring2 ->
      RateUnchanged ring1 ring2.
  Proof.
    induction ring1; simpl; intros.
    destruct ring2; [constructor|discriminate].
    destruct ring2. discriminate.
    inv H. constructor. apply rate_unchanged_after_shrinking_order.
    eapply IHring1; eauto.
  Qed.

  Lemma rate_unchanged_after_shrinking_ring:
    forall ring1 ring2,
      shrink_ring ring1 = Some ring2 ->
      RateUnchanged ring1 ring2.
  Proof.
    intros ring1 ring2 Hshrink.
    destruct ring1. simpl in *. discriminate.
    destruct ring1. simpl in *. discriminate.
    inv Hshrink. constructor. unfold OrderRateUnchanged; auto.
    eapply rate_unchanged_after_shrinking_ring_aux.
    simpl. eauto.
  Qed.

  Lemma OrderRateUnchanged_trans:
    forall o1 o2 o3,
      OrderRateUnchanged o1 o2 ->
      OrderRateUnchanged o2 o3 ->
      OrderRateUnchanged o1 o3.
  Proof. unfold OrderRateUnchanged. intuition; congruence. Qed.

  Lemma RateUnchanged_trans:
    forall ring1 ring2 ring3,
      RateUnchanged ring1 ring2 ->
      RateUnchanged ring2 ring3 ->
      RateUnchanged ring1 ring3.
  Proof.
    induction ring1; intros.
    inv H. inv H0. constructor.
    inv H. inv H0. constructor.
    eapply OrderRateUnchanged_trans; eauto.
    eapply IHring1; eauto.
  Qed.

  Lemma RateUnchanged_refl:
    forall orderring,
      RateUnchanged orderring orderring.
  Proof.
    induction orderring; constructor;
      unfold OrderRateUnchanged; auto.
  Qed.

  Lemma rate_unchanged_after_calc_fill_amount:
    forall ring1 ring2,
      calc_fill_amount ring1 = Some ring2 ->
      RateUnchanged ring1 ring2.
  Proof.
    unfold calc_fill_amount. intros.
    destruct (shrink_ring ring1) eqn:Hpass1;[|discriminate].
    apply rate_unchanged_after_shrinking_ring in Hpass1.
    destruct r; [discriminate|].
    destruct r; [discriminate|].
    destruct (check_last_can_fill _) eqn:Hchecklast.
    inv H; auto.
    eapply RateUnchanged_trans. eauto.
    eapply RateUnchanged_trans.
    econstructor. eapply rate_unchanged_after_shrinking_order.
    eapply RateUnchanged_refl.
    eapply rate_unchanged_after_shrinking_ring. eauto.
  Qed.

  (** * WinWin *)

  Lemma PreConditionFill_WinWin:
    forall r, PreConditionFill r -> WinWin r.
  Proof.
    induction r; constructor.
    inv H. unfold OrderWinWin. inv H2. rewrite H, H0. auto.
    inv H. apply IHr. auto.
  Qed.

  Lemma order_winwin_stable_wrt_shrink:
    forall prev cur, OrderWinWin cur -> OrderWinWin (shrink_order prev cur).
  Proof.
    intros. unfold shrink_order.
    destruct (fillS prev < fillB cur)%nat eqn:Hlt; auto.
    inv H; split; simpl; unfold shrink_S.

    rewrite (mulnC (fillS prev) (amountS cur)).
    apply leq_trunc_div.

    inv H1. split.
    eapply leq_trans.
    eapply leq_div2r.
    eapply leq_mul. instantiate (1:= fillB cur). auto.
    instantiate (1:= amountS cur). auto. clear H0 Hlt H.
    rewrite mulnC. eapply leq_trans. eapply leq_div2r.
    instantiate (1:= (amountS cur * amountB cur)%nat). eapply leq_mul; auto.
    destruct (amountB cur). auto.
    rewrite mulnK; auto.

    eapply leq_trans. instantiate (1:= fillB cur). auto. auto.
  Qed.

  Lemma winwin_stable_wrt_shrink_aux:
    forall prev ring1 ring2,
      shrink_ring_aux prev ring1 = ring2 ->
      WinWin ring1 ->
      WinWin ring2.
  Proof.
    intros prev ring1. revert prev. induction ring1; intros.
    inv H. constructor.
    inv H. inv H0. constructor.
    apply order_winwin_stable_wrt_shrink. auto.
    eapply IHring1; eauto.
  Qed.

  Lemma winwin_stable_wrt_shrink:
    forall ring1 ring2,
      shrink_ring ring1 = Some ring2 ->
      WinWin ring1 ->
      WinWin ring2.
  Proof.
    unfold shrink_ring.
    destruct ring1. discriminate.
    destruct ring1. discriminate.
    intros. inv H. inv H0. constructor. auto.
    eapply winwin_stable_wrt_shrink_aux.
    instantiate (1:= o0 :: ring1). simpl. eauto. eauto.
  Qed.

  Lemma winwin_stable_wrt_calc_fill_amount:
    forall ring1 ring2,
      calc_fill_amount ring1 = Some ring2 ->
      WinWin ring1 ->
      WinWin ring2.
  Proof.
    destruct ring1. discriminate.
    destruct ring1. discriminate.
    unfold calc_fill_amount.
    destruct (shrink_ring (o :: o0 :: ring1)) eqn:Hshrink1; [|discriminate].
    destruct r. discriminate.
    destruct r. discriminate.
    intros ring2 Hshrink2 Hwinwin.
    eapply winwin_stable_wrt_shrink in Hshrink1; auto.
    destruct (check_last_can_fill (o1 :: o2 :: r)) eqn:Hcheck. inv Hshrink2. auto.
    eapply winwin_stable_wrt_shrink in Hshrink2; auto.
    inv Hshrink1.
    constructor; auto. apply order_winwin_stable_wrt_shrink. auto.
  Qed.

  (** * Almostcanfill *)

  Lemma almost_can_fill_after_shrinking_order:
    forall prev cur,
      (fillB (shrink_order prev cur) <= fillS prev)%nat.
  Proof.
    intros. unfold shrink_order.
    destruct (fillS prev < fillB cur)%nat eqn: Hlt.
    simpl. auto.
    revert Hlt. generalize (fillS prev) (fillB cur). clear. intros m n H.
    destruct (@ltP m n). discriminate. apply not_lt in n0.
    destruct (@leP n m); auto.
  Qed.

  Lemma almost_can_fill_after_shrinking_aux:
    forall ring1 prev ring2,
      shrink_ring_aux prev ring1 = ring2 ->
      AlmostCanFill (prev :: ring2).
  Proof.
    induction ring1.
    intros. inv H. intros N op oc. destruct N; discriminate.
    intros. simpl in H. inv H.
    specialize (IHring1 (shrink_order prev a)
                        (shrink_ring_aux (shrink_order prev a) ring1) eq_refl).
    intros N op oc Hop Hoc.
    destruct N. simpl in *. inv Hop; inv Hoc.
    apply almost_can_fill_after_shrinking_order.
    simpl in Hop, Hoc.
    eapply IHring1; eauto.
  Qed.

  Lemma almost_can_fill_after_shrinking:
    forall ring1 ring2,
      shrink_ring ring1 = Some ring2 ->
      AlmostCanFill ring2.
  Proof.
    destruct ring1. simpl. discriminate.
    destruct ring1. simpl. discriminate.
    simpl. intros. inv H.
    intros N op oc. destruct N; simpl.
    intros. inv H; inv H0. apply almost_can_fill_after_shrinking_order.
    intros. eapply almost_can_fill_after_shrinking_aux; eauto.
  Qed.

  Lemma almost_can_fill_after_calc_fill_amount:
    forall ring1 ring2,
      calc_fill_amount ring1 = Some ring2 ->
      AlmostCanFill ring2.
  Proof.
    unfold calc_fill_amount. intros ring1 ring2.
    destruct (shrink_ring ring1) eqn:Hshrink1; [|discriminate].
    destruct r. discriminate.
    destruct r. discriminate.
    destruct (check_last_can_fill _) eqn:Hcheck. intro H; inv H.
    eapply almost_can_fill_after_shrinking. eauto.
    intro. eapply almost_can_fill_after_shrinking. eauto.
  Qed.

  (** Soundness *)
  Theorem soundness:
    forall orderring orderring',
      PreConditionFill orderring ->
      PreConditionLength orderring ->
      PreConditionGamma orderring ->
      calc_fill_amount orderring = Some orderring' ->
      check_last_can_fill orderring' = true ->
      Correct orderring orderring'.
  Proof.
    intros.
    split. apply rate_unchanged_after_calc_fill_amount. auto.
    split. split; auto. eapply almost_can_fill_after_calc_fill_amount; eauto.
    eapply winwin_stable_wrt_calc_fill_amount; eauto.
    apply PreConditionFill_WinWin. auto.
  Qed.

  (** Completeness *)

  Lemma PreConditionLength_calc_fill_Some:
    forall orderring,
      PreConditionLength orderring ->
      exists orderring',
        calc_fill_amount orderring = Some orderring'.
  Proof.
    intros.
    destruct orderring. inv H.
    destruct orderring. inv H.
    unfold calc_fill_amount. simpl.
    match goal with
    | |- context[if ?b then _ else _] =>
      destruct b; eauto
    end.
  Qed.

  (** post condition of shrink pass 2 *)
  Lemma fillB_mult_gamma_shrink_canc:
    forall r n r',
      shrink_ring r = Some r' ->
      fillB_mult_gamma n r' = fillB_mult_gamma n r.
  Proof.
    intros. apply rate_unchanged_after_shrinking_ring in H.
    revert n. induction H. auto.
    simpl. intro n. rewrite IHForall2. inv H.
    unfold mult_gamma_nat. rewrite H1, H2. auto.
  Qed.

  Lemma fillB_mult_gamma_shrink_order_canc:
    forall r o n o',
      fillB_mult_gamma n (shrink_order o' o :: r) = fillB_mult_gamma n (o :: r).
  Proof.
    intros. unfold shrink_order. destruct (fillS o' < fillB o)%nat; simpl; auto.
  Qed.

  Lemma mult_gamma_nat_shrink_order_canc:
    forall o o' amount,
      mult_gamma_nat amount (shrink_order o' o) =
      mult_gamma_nat amount o.
  Proof.
    unfold mult_gamma_nat, shrink_order. intros.
    destruct (fillS o' < fillB o)%nat; auto.
  Qed.

  Lemma almost_can_fill_tail:
    forall olast r,
      AlmostCanFill (olast :: r) ->
      AlmostCanFill r.
  Proof.
    intros. intros N prev cur Hprev Hcur.
    specialize (H N.+1). simpl in H, Hcur. rewrite Hprev, Hcur in H.
    eapply H; eauto.
  Qed.

  Lemma lt_ge_False:
    forall a b,
      (a <= b)%nat ->
      (b < a = true)%nat ->
      False.
  Proof.
    intros. destruct (@leP a b); destruct (@leP (S b) a); try discriminate.
    omega.
  Qed.

  Lemma lt_false_le:
    forall a b,
      (b < a)%nat = false ->
      (a <= b)%nat.
  Proof.
    intros. destruct (@leP a b); destruct (@leP (S b) a); try discriminate; auto.
    omega.
  Qed.

  Lemma almost_can_fill_tail':
    forall olast a r,
      AlmostCanFill (a :: r) ->
      (fillB a <= fillS olast)%nat ->
      AlmostCanFill (olast :: a :: r).
  Proof.
    intros. intro N. destruct N; simpl; [|apply H]. intros.
    inv H1; inv H2. auto.
  Qed.

  Lemma check_pass_shrink_order_unchanged:
    forall a b,
      (fillB a <= fillS b)%nat ->
      shrink_order b a = a.
  Proof.
    unfold shrink_order. intros.
    destruct (fillS b < fillB a)%nat eqn:?; auto.
    exfalso. eapply lt_ge_False; eauto.
  Qed.

  Lemma almost_can_fill_shrinking_unchanged:
    forall r olast r',
      AlmostCanFill (olast :: r) ->
      shrink_ring (olast :: r) = Some r' ->
      r' = olast :: r.
  Proof.
    induction r; intros. discriminate.
    simpl in H0. inv H0. destruct r.
    clear IHr. simpl. unfold shrink_order.
    destruct (fillS olast < fillB a)%nat eqn:Hlt; auto.
    exfalso. specialize (H 0%nat). simpl in H. specialize (H _ _ eq_refl eq_refl).
    eapply lt_ge_False; eauto.
    assert (shrink_order olast a = a).
    { specialize (H 0%nat _ _ eq_refl eq_refl).
      apply check_pass_shrink_order_unchanged; auto. }
    rewrite H0.
    apply almost_can_fill_tail in H. eapply IHr in H; eauto.
    rewrite H. auto.
  Qed.

  Lemma shrink_ring_post_condition:
    forall olast r r' anyorder,
      AlmostCanFill r ->
      shrink_ring (olast :: r) = Some (olast :: r') ->
      (* case 1: check passed in the middle of the second pass *)
      (last r' anyorder = last r anyorder)
      \/
      (* case 2: check failed till the end of the second pass *)
      fillS (last r' anyorder) =
      fillB_mult_gamma (fillS olast) r'.
  Proof.
    intros olast r.
    revert olast. induction r.
    discriminate.
    intros olast r' anyorder Hfill Hshrink.
    assert (AlmostCanFill r) by (eapply almost_can_fill_tail; eauto).
    simpl in Hshrink.
    destruct r as [|b r].
    (* ring of 2 *)
    clear IHr. inv Hshrink. clear H Hfill.
    rewrite mult_gamma_nat_shrink_order_canc.
    unfold shrink_order. destruct (fillS olast < fillB a)%nat; auto.
    (* ring of more .. *)
    destruct (fillS olast < fillB a)%nat eqn:Hfail.
    (* check failed at the beginning of the pass *)
    specialize (IHr (shrink_order olast a)
                    (shrink_ring_aux (shrink_order olast a) (b :: r))
                    anyorder H eq_refl).
    clear H. destruct IHr;[left|right].
    (* check passed in the middle of the pass *)
    inv Hshrink. auto.
    (* check failed till the end of the pass *)
    inv Hshrink. rewrite H. clear H.
    repeat rewrite mult_gamma_nat_shrink_order_canc.
    clear Hfill. generalize (shrink_ring_aux (shrink_order (shrink_order olast a) b) r).
    clear r anyorder. intro r.
    unfold shrink_order. rewrite Hfail. clear Hfail. simpl.
    unfold fillB_mult_gamma. f_equal.
    (* check passed at the beginning of the pass *)
    left. rename Hfail into Hpass.
    apply lt_false_le in Hpass. apply check_pass_shrink_order_unchanged in Hpass.
    rewrite Hpass in *.
    assert (shrink_ring (a :: b :: r) = Some r').
    { inv Hshrink. auto. }
    apply almost_can_fill_shrinking_unchanged in H0; auto. subst r'. auto.
  Qed.

  Lemma mult_gamma_eq_wrt_shrink_order:
    forall a o o',
      mult_gamma a o = mult_gamma a (shrink_order o' o).
  Proof.
    unfold shrink_order, mult_gamma. intros.
    destruct (fillS o' < fillB o)%nat; auto.
  Qed.

  Lemma completeness':
    forall orderring orderring',
      WinWin orderring ->
      PreConditionGamma orderring ->
      calc_fill_amount orderring = Some orderring' ->
      check_last_can_fill orderring' = true.
  Proof.
    unfold calc_fill_amount. intros r r' Hwinwin Hgamma.
    destruct (shrink_ring r) as [r1|] eqn:Hshrink1; [|discriminate].
    pose proof (almost_can_fill_after_shrinking _ _ Hshrink1) as Hcanfill1.
    pose proof (winwin_stable_wrt_shrink _ _ Hshrink1 Hwinwin) as Hwinwin1.
    (* pose proof (PreConditionGamma_stable_wrt_shrink _ _ Hshrink1 Hgamma) as Hgamma1. *)
    clear Hwinwin.
    destruct r1; [discriminate|].
    destruct r1; [discriminate|].
    destruct (check_last_can_fill (o :: o0 :: r1)) eqn:Hcheck1.
    intro A. inv A. auto.
    intros.
    destruct r'. inv H.
    pose proof H as Hshrink2.
    assert (o1 = shrink_order (last (o0 :: r1) o) o).
    { inv H. auto. }
    subst o1.
    eapply shrink_ring_post_condition in H; try eauto using almost_can_fill_tail.
    destruct H.
    (* case 1: check passed *)
    unfold check_last_can_fill. destruct r'. discriminate.
    rewrite H. clear.
    unfold shrink_order at 1. destruct (fillS (last (o0 :: r1) o) < fillB o)%nat eqn:Hlt.
    simpl. clear Hlt.
    match goal with
    | |- context[shrink_order ?x ?y] => generalize (shrink_order x y)
    end.
    revert o o0. induction r1; intros. apply leqnn. simpl. apply IHr1.
    assert (forall o', last (o0 :: r1) o = last (o0 :: r1) o').
    { clear. revert o0 o. induction r1; auto. intros. simpl in *. apply IHr1. }
    rewrite <- H. apply lt_false_le. auto.
    (* case 2: check failed till the end *)
    eapply pre_condition_gamma_implies in Hgamma; [|exact Hshrink1].
    unfold check_last_can_fill.
    destruct r'. discriminate.
    rewrite H.
    assert (fillB_mult_gamma (fillS (shrink_order (last (o0 :: r1) o) o)) (o1 :: r') =
            fillB_mult_gamma (fillB (shrink_order (last (o0 :: r1) o) o))
                             ((shrink_order (last (o0 :: r1) o ) o :: o1 :: r'))).
    { unfold shrink_order. unfold check_last_can_fill in Hcheck1.
      destruct (fillS (last (o0 :: r1) o) < fillB o)%nat eqn:Hlt. auto.
      exfalso. revert Hcheck1 Hlt. clear.
      generalize (fillB o) (fillS (last (o0 :: r1) o)). clear. intros m n A B.
      destruct (@leP m n); try discriminate.
      destruct (@leP (S n) m); try discriminate.
      omega.
    }
    rewrite H0.
    erewrite fillB_mult_gamma_shrink_canc; [|exact Hshrink2].
    rewrite fillB_mult_gamma_shrink_order_canc.
    erewrite fillB_mult_gamma_shrink_canc; [|exact Hshrink1].
    auto.
  Qed.

  Theorem completeness:
    forall orderring,
      PreConditionFill orderring ->
      PreConditionLength orderring ->
      PreConditionGamma orderring ->
      exists orderring',
        calc_fill_amount orderring = Some orderring'
        /\ check_last_can_fill orderring' = true.
  Proof.
    intros. apply PreConditionLength_calc_fill_Some in H0.
    destruct H0 as [orderring' Hcalc].
    eexists. split. eauto.
    eapply completeness'; eauto.
    apply PreConditionFill_WinWin; auto.
  Qed.

End Correctness.