(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export cequiv.

(* !!MOVE *)
Lemma not_value_like_approx_bot {o} :
  forall lib (a : @NTerm o),
    hasvalue_like lib a -> !approx lib a mk_bot.
Proof.
  introv hv ap.
  inversion ap as [cc]; subst.
  unfold close_comput in cc; repnd.
  unfold hasvalue_like, isvalue_like in hv; exrepnd.
  repndors.

  - apply iscan_implies in hv0; repndors; exrepnd; subst.

    + pose proof (cc2 c bterms) as h.
      autodimp h hyp.
      { split; auto.
        apply isvalue_iff; dands; auto.
        apply reduces_to_preserves_program in hv1; auto. }
      exrepnd.
      unfold computes_to_value in h1; repnd.
      apply not_bot_reduces_to_is_value_like in h2; eauto 3 with slow.

    + apply cc4 in hv1; exrepnd.
      apply not_bot_reduces_to_value_like in hv1; eauto 3 with slow.

  - apply isexc_implies2 in hv0; exrepnd; subst.
    applydup @reduces_to_preserves_program in hv1; auto.
    apply isprogram_exception_implies in hv0; exrepnd; subst; fold_terms.

    pose proof (cc3 a0 t) as h.
    autodimp h hyp.
    exrepnd.
    apply not_bot_reduces_to_is_value_like in h0; eauto 3 with slow.
Qed.

Lemma not_value_like_approxc_bot {o} :
  forall lib (a : @CTerm o),
    hasvalue_likec lib a -> !approxc lib a mkc_bot.
Proof.
  unfold approxc, hasvalue_likec; introv; destruct_cterms; simpl.
  apply not_value_like_approx_bot.
Qed.

Lemma approxc_alphaeqc_r {o} :
  forall lib (a b c : @CTerm o),
    approxc lib a b
    -> alphaeqc b c
    -> approxc lib a c.
Proof.
  introv apr aeq.
  destruct_cterms; allunfold @approxc; allunfold @alphaeqc; allsimpl.
  eapply approx_alpha_rw_r_aux;[|exact apr]; auto.
Qed.

Lemma approxc_alphaeqc_l {o} :
  forall lib (a b c : @CTerm o),
    alphaeqc a b
    -> approxc lib b c
    -> approxc lib a c.
Proof.
  introv aeq apr.
  destruct_cterms; allunfold @approxc; allunfold @alphaeqc; allsimpl.
  eapply approx_alpha_rw_l_aux;[|exact apr]; eauto 3 with slow.
Qed.

Lemma hasvalue_like_exc {o} :
  forall lib (a b : @NTerm o),
    hasvalue_like lib (mk_exception a b).
Proof.
  introv.
  unfold hasvalue_like.
  exists (mk_exception a b); dands; eauto 3 with slow.
Qed.
Hint Resolve hasvalue_like_exc : slow.

Lemma hasvalue_likec_exc {o} :
  forall lib (a b : @CTerm o),
    hasvalue_likec lib (mkc_exception a b).
Proof.
  introv; destruct_cterms; unfold hasvalue_likec; simpl; eauto 3 with slow.
Qed.
Hint Resolve hasvalue_likec_exc : slow.

Lemma approxc_decomp_axiom0 {o} :
  forall lib (a : @CTerm o),
    approxc lib mkc_axiom a
    <=> computes_to_valc lib a mkc_axiom.
Proof.
  introv; destruct_cterms; unfold approxc, computes_to_valc; simpl.
  rw @approx_decomp_axiom0.
  split; intro h; repnd; dands; eauto 3 with slow.
Qed.

Lemma computes_to_valc_exception {o} :
  forall lib (a e v : @CTerm o),
    computes_to_valc lib (mkc_exception a e) v -> False.
Proof.
  introv comp.
  destruct_cterms; unfold computes_to_valc in comp; allsimpl.
  apply computes_to_value_exception in comp; sp.
Qed.

(* !!MOVE *)
Lemma approxc_exc_implies_ex {o} :
  forall lib (n e t : @CTerm o),
    approxc lib (mkc_exception n e) t
    -> {a : CTerm
        & {b : CTerm
        & reduces_toc lib t (mkc_exception a b)}}.
Proof.
  introv apr.
  destruct_cterms.
  unfold approxc in apr; allsimpl.
  inversion apr as [cl]; clear apr.
  unfold close_comput in cl; repnd.
  pose proof (cl3 x1 x0) as h.
  autodimp h hyp.
  { apply reduces_to_symm. }
  exrepnd.
  applydup @reduces_to_preserves_program in h0; eauto 3 with slow.
  allrw @isprogram_exception_iff; repnd.
  exists (mk_cterm a' h4) (mk_cterm e' h3).
  unfold reduces_toc; simpl; auto.
Qed.

Lemma cover_vars_exception {o} :
  forall (t u : @NTerm o) s,
    cover_vars (mk_exception t u) s <=> (cover_vars t s # cover_vars u s).
Proof.
  introv.
  allrw @cover_vars_eq.
  simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw subvars_app_l; sp.
Qed.


Require Import
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.micromega.Lia
  Coq.Classes.Morphisms
  Coq.Relations.Relation_Definitions
  Coq.Strings.String
  Coq.Vectors.Vector
  Coq.Lists.List
  Coq.Sets.Ensembles
  Coq.Logic.EqdepFacts.

From Equations Require Import Equations.
Require Import Equations.Type.EqDec.
Set Equations With UIP.

Set Universe Polymorphism.

Generalizable All Variables.

Import ListNotations.

Definition stream (A : Type) : Type := nat → A.

Definition result_stream `(S : stream A) (B : A → Type) : Type :=
  ∀ n : nat, B (S n).

Definition dep_stream (A : Type) (B : A → Type) : Type :=
  ∀ S : stream A, result_stream S B.

Definition Schema : Type := list (string * Type).

Inductive Rec : Schema → Type :=
  | Empty : Rec []
  | Field name {ty S} : ty → Rec S → Rec ((name, ty) :: S).

(* jww (2022-06-15): Keys are just unique names at the moment *)
Definition Table (S : Schema) : Type := list (string * Rec S).

Open Scope string_scope.

Example same_record :
  Rec [("foo", nat : Type); ("bar", nat : Type); ("baz", nat : Type)].
Proof.
  exact (Field "foo" (1 : nat)
               (Field "bar" (2 : nat)
                      (Field "baz" (3 : nat) Empty))).
Qed.

Definition Database : Type := list (string * { S : Schema & Table S }).

Section Kadena.

Class EqDec (A : Type) := {
    eq_dec : ∀ x y : A, {x = y} + {x ≠ y}
}.

Fixpoint lookup {k v : Type} `{EqDec k} (i : k) (l : list (k * v)) : option v :=
  match l with
  | [] => None
  | (j, x) :: xs => if eq_dec i j then Some x else lookup i xs
  end.

(* At the moment all database operations are "global" and not constrained to
   what the capabilities of the contract permit it to see. *)
Inductive Op : Type :=
  | Noop
  | Query {a : Type} (q : Database → a)
  | Update (u : Database → Database).

Inductive Result : Op → Type :=
  | Nothing : Result Noop
  | Answer {a} {q : Database → a} : a → Result (Query q)
  | Updated {u} : Result (Update u)
  (* Any operation might result in an error. *)
  | Error {o} (msg : string) : Result o.

Definition Kadena := dep_stream Op Result.

Definition Contract : Type := list Op * Op.

Definition Modules : Schema := [ ("contract", Contract) ].

Definition NoopContract : Contract := ([], Noop).
Definition NoopModule : Rec Modules := Field "contract" NoopContract Empty.

Program Definition Store : Database :=
  [ ("modules", existT _ Modules [("noop", NoopModule)]) ].

Definition kda : Kadena.
Proof.
  repeat intro.
  induction (S n); constructor.
  apply q.
  exact Store.
Defined.

Fixpoint typeof {S : Schema} (r : Rec S) (field : string) : Type :=
  match r with
  | Empty => False
  | @Field name ty _ _ xs =>
      if name =? field then ty else typeof xs field
  end.

Equations get {S : Schema} (r : Rec S) (field : string) : typeof r field :=
  get Empty _ := False_rect _ _;
  get (Field name x xs) field := if name =? field then x else get xs field.

Program Definition call_noop_contract (k : Kadena) :=
  k (λ n, if Nat.eqb n 0
          then Update (λ _, Store) (* genesis *)
          else Query (λ db, match lookup "modules" db with
                            | Some (existT _ _ ms) =>
                                match lookup "noop" ms with
                                | Some r =>
                                    get r "contract"
                                | None => Error "failed"
                                end
                            | None => Error "failed"
                            end)) 1.

Lemma call_noop_contract_correct :
  call_noop_contract kda = Answer ().
Proof. reflexivity. Qed.

End Kadena.


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import Robustdef.
Require Import Setoid.
Require Import ClassicalExtras.
Require Import Logic.ClassicalFacts.
Require Import List.
Require Import TechnicalLemmas.
Require Import Criteria.

(** This file proves that R2rSC can imply RTEP *)

(* Definition two_rRSC : Prop := *)
(*   forall (r : finpref -> finpref -> Prop) P1 P2 , *)
(*     ((forall Cs m1 m2, psem (Cs [P1]) m1 -> *)
(*                   psem (Cs [P2]) m2 -> *)
(*                    r m1 m2) -> *)
(*      (forall Ct m1 m2, psem (Ct [P1 ↓]) m1 -> *)
(*                   psem (Ct [P2 ↓]) m2 -> *)
(*                   r m1 m2)). *)

(** *our assumptions *)
(**********************************************************)
Hypothesis input_totality_tgt : input_totality tgt.
Hypothesis determinacy_src    : determinacy src.
Hypothesis tgt_sem            : semantics_safety_like tgt.
Hypothesis no_divergence : forall P' t, sem tgt P' t -> ~ diverges t.
(**********************************************************)

Lemma three_continuations_tbd :
  forall l t, prefix (ftbd l) t ->
         ( (exists e, t = tstop l e) \/
                 (t = tsilent l) \/
            (exists e, prefix (ftbd (snoc l e)) t)).
Proof.
  intros l [] Hpref.
  + simpl in Hpref. apply list_proper_or_equal in Hpref. destruct Hpref.
    ++ subst. left. now exists e.
    ++ right. right. firstorder.
  + simpl in Hpref. apply list_proper_or_equal in Hpref. destruct Hpref.
    ++ subst. right. now left.
    ++ right. right. firstorder.
  + generalize dependent s. induction l.
    ++ right. right. destruct s. now exists e.
    ++ intros [] Hpref. inversion Hpref. simpl.
       destruct (IHl s) as [ [ef FALSE] | [ FALSE | [e0 HH] ]]; try now inversion FALSE; auto.
       now simpl. right. right. exists e0; firstorder.
Qed.

Definition myr ( m1 m2 : finpref) : Prop :=
  (fpr m1 m2) \/ (fpr m2 m1) \/
  (exists l i1 i2, is_input i1 /\
               is_input i2 /\
               i1 <> i2 /\
               fpr (ftbd (snoc l i1)) m1 /\
               fpr (ftbd (snoc l i2)) m2).

Lemma myr_symmetric : forall m1 m2, myr m1 m2 -> myr m2 m1.
Proof. firstorder. Qed.

(* equivalent version of auXiliary_tstop.
   ANON one might think to show myXr m1 m2 -> myr m1 m2
       and get a shorter proof.
       Here we re-do the proof to have it independent from Xprefix.v
*)
Lemma auxiliary_tstop :
  forall m2 l1 e1 t2, prefix m2 t2 ->
                  traces_match (tstop l1 e1) t2 -> myr (fstop l1 e1) m2.
Proof.
  intros m2 l1 e1 t2 prefix2 [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]].
  + rewrite <- Heq in *. destruct (same_ext (fstop l1 e1) m2 (tstop l1 e1)); simpl; auto;
                          [now left |  right; now left].
  + destruct m2, t2; simpl in prefix2; simpl in l_prefix1, l_prefix2; try now auto.
    ++ inversion prefix2; subst.
       right. right. now exists ll, i1, i2.
    ++ destruct (list_list_same_ext l (snoc ll i2) l0); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ destruct (list_list_same_ext l (snoc ll i2) l0); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
    ++ destruct (list_stream_same_ext l (snoc ll i2) s); auto.
       * destruct (list_proper_or_equal _ _ H) as [HH | [a HH]].
         ** subst. right. right. now exists ll, i1, i2.
         ** apply list_pref_snoc_pref in HH.
            right. left. simpl. apply (list_list_prefix_trans l (snoc ll i1) l1);auto.
            apply (list_list_prefix_trans l ll _); auto. now apply snoc_longer.
       * right. right. now exists ll, i1, i2.
Qed.

Lemma auxiliary_ftbd:
  forall l1 l2 t1 t2, prefix (ftbd l1) t1 -> prefix (ftbd l2) t2 ->
                  traces_match t1 t2 -> myr (ftbd l1) (ftbd l2).
Proof.
  intros l1 l2 t1 t2 pref1 pref2 [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]].
  + subst. destruct (same_ext (ftbd l1) (ftbd l2) t2); auto; [now left | right; now left].
  + assert (H1: prefix (ftbd (snoc ll i1)) t1).
    { destruct t1; simpl in *; now auto. }
    assert (H2 : prefix (ftbd (snoc ll i2)) t2).
    { destruct t2; simpl in *; now auto. }
    destruct (same_ext (ftbd l1) (ftbd (snoc ll i1)) t1) as [l1_shorter | l1_longer]; auto.
    ++ destruct (same_ext (ftbd l2) (ftbd (snoc ll i2)) t2) as [l2_shorter | l2_longer]; auto.
       destruct (list_proper_or_equal _ _ l1_shorter) as [l1_ll | [a1 l1_ll]]; subst.
       * destruct (list_proper_or_equal _ _ l2_shorter) as [l2_ll | [a2 l2_ll]]; subst.
          ** right. right. now exists ll, i1, i2.
          ** apply list_pref_snoc_pref in l2_ll. right. left. simpl.
             apply (list_list_prefix_trans l2 ll _); auto. now apply snoc_longer.
       * apply list_pref_snoc_pref in l1_ll.
         destruct (list_proper_or_equal _ _ l2_shorter) as [l2_ll | [a2 l2_ll]]; subst.
         **  left. simpl. apply (list_list_prefix_trans l1 ll _ ); auto. now apply snoc_longer.
         ** apply list_pref_snoc_pref in l2_ll. destruct (list_list_same_ext l1 l2 ll); auto;
                                                  [now left | right; now left].
       * destruct (list_proper_or_equal  _ _ l1_shorter); auto; subst.
         ** right. right. now exists ll, i1, i2.
         ** destruct H as [a H]. apply list_pref_snoc_pref in H. left.
            simpl. apply (list_list_prefix_trans l1 ll l2); auto.
            simpl in l2_longer. apply (list_list_prefix_trans ll (snoc ll i2) l2); auto.
            now apply snoc_longer.
    ++ destruct (same_ext (ftbd l2) (ftbd (snoc ll i2)) t2) as [l2_shorter | l2_longer]; auto.
       * destruct (list_proper_or_equal _ _ l2_shorter) as [l2_ll | [a2 l2_ll]]; subst.
          ** right. right. now exists ll, i1, i2.
          ** apply list_pref_snoc_pref in l2_ll. right. left. simpl.
             apply (list_list_prefix_trans l2 ll _); auto.
             apply (list_list_prefix_trans ll (snoc ll i1) _); auto. now apply snoc_longer.
        * right. right. now exists ll, i1, i2.
Qed.

Lemma auxiliary_lemma (t1 t2 : trace) :
  traces_match t1 t2 ->
  forall m1 m2, prefix m1 t1 -> prefix m2 t2 -> myr m1 m2.
Proof.
  intros [Heq | [ll [i1 [i2 [I1 [I2 [Idiff [l_prefix1 l_prefix2]]]]]]]] m1 m2 prefix1 prefix2.
  - subst. unfold myr. destruct (same_ext m1 m2 t2) as [go_left | go_right_left]; auto.
  - destruct m1, m2.
    ++ destruct t1, t2; inversion prefix1; inversion prefix2; subst.
       right. right. now exists ll, i1, i2.
    ++ destruct t1; inversion prefix1; subst.
       apply (auxiliary_tstop (ftbd l0) l1 e t2); auto.
       right. now exists ll, i1, i2.
    ++ destruct t2; inversion prefix2; subst. apply myr_symmetric.
       apply (auxiliary_tstop (ftbd l) l1 e t1); auto.
       right. exists ll, i2, i1. repeat (split; try now auto).
    ++ apply (auxiliary_ftbd l l0 t1 t2); auto. right. now exists ll, i1, i2.
Qed.

Lemma teq_premises_myXr_holds : forall P1 P2,
    (forall Cs t, sem src (Cs [P1]) t <-> sem src (Cs [P2]) t) ->
    (forall Cs m1 m2, psem (Cs [P1]) m1 -> psem (Cs [P2]) m2 ->
                 myr m1 m2).
Proof.
  intros P1 P2 H Cs m1 m2 [t1 [pref1 sem1]] [t2 [pref2 sem2]].
    rewrite (H Cs t1) in sem1.
   specialize (determinacy_src (Cs[P2]) t1 t2 sem1 sem2).
   intros Hmatch. now apply (auxiliary_lemma t1 t2).
Qed.

Lemma input_tot_consequence (W : prg tgt): forall l i1 i2,
    is_input i1 -> is_input i2 ->
    psem W (ftbd (snoc l i1)) -> psem W (ftbd (snoc l i2)).
Proof.
  intros l i1 i2 Hi1 Hi2 [t [pref_x_t Hsemt]].
  assert (psem W (ftbd  (snoc l i1))).
  { simpl in *. now exists t. }
  now apply (input_totality_tgt W l i1 i2) in H.
Qed.

Lemma t_being_tstop_leads_to_contra (W1 W2 : prg tgt) t l2 e2
                                    (sem1 : sem tgt W1 t) (sem2 : sem tgt W2 (tstop l2 e2))
                                    (nsem12: ~ sem tgt W2 t)
                                    (xpref_x_t : prefix (ftbd l2) t)
  :
    (forall m1 m2, psem W1 m1 -> psem W2 m2 -> myr m1 m2) -> False.
Proof.
 intros twoX. destruct t.
 - simpl in *. destruct (twoX (fstop l e) (fstop l2 e2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]].
   now exists (tstop l e). now exists (tstop l2 e2).
   + inversion xpr1; subst. contradiction.
   + inversion xpr2; subst. contradiction.
   + simpl in Hxpr1, Hxpr2.
     apply (list_list_prefix_trans (snoc xx i2) l2 l Hxpr2) in xpref_x_t.
     destruct (list_list_same_ext (snoc xx i1) (snoc xx i2) l) as [F | F]; auto;
       apply Hdiff; apply (list_snoc_diff xx _ _ ) in F; congruence.
 - now apply (no_divergence W1 (tsilent l)).
 - simpl in xpref_x_t.
   destruct (tgt_sem (tstream s) W2 nsem12) as [l [ebad [Hpsem [Hpref Hnpsem]]]]; auto.
   simpl in Hpref.
   destruct (twoX (ftbd (snoc l ebad)) (fstop l2 e2))
     as [xpr1 | [xpr2 | [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2]]]]]]]]]; auto.
   now exists (tstream s). now exists (tstop l2 e2).
   + simpl in xpr1. apply Hnpsem. now exists (tstop l2 e2).
   + simpl in *.
     apply (list_stream_prefix_trans _ _ s) in Hxpr1; auto.
     apply (list_stream_prefix_trans _ _ s) in Hxpr2; auto.
     destruct (list_stream_same_ext (snoc xx i1) (snoc xx i2) s) as [F | F]; auto;
     apply Hdiff; apply (list_snoc_diff xx _ _) in F; congruence.
Qed.

Lemma violates_xmax  (W1 W2 : prg tgt) t t2 l a aa
                     (sem1 : sem tgt W1 t) (sem2 : sem tgt W2 t2)
                     (nsem12: ~ sem tgt W2 t)
                     (xpref_x_t : prefix (ftbd (snoc l aa)) t)
                     (x_t2 : prefix (ftbd (snoc l a)) t2)

  :
    (forall m' : finpref, prefix m' t -> psem W2 m' -> fpr m' (ftbd l)) ->
    (forall m1 m2, psem W1 m1 -> psem W2 m2 ->  myr m1 m2) -> False.
Proof.
  intros xmax twoX.
  assert (xsem1 : psem W1 (ftbd (snoc l aa))) by now exists t.
  assert (xsem2 : psem W2 (ftbd (snoc l a))) by now exists t2.
  specialize (twoX (ftbd (snoc l aa)) (ftbd (snoc l a)) xsem1 xsem2).
  destruct twoX as [xpr1 | [xpr2 | matching]].
  + simpl in xpr1. apply list_snoc_diff in xpr1. subst.
    specialize (xmax (ftbd (snoc l a)) xpref_x_t xsem2).
    simpl in xmax. now apply snoc_strictly_longer in xmax.
  + simpl in xpr2. apply list_snoc_diff in xpr2. subst.
    specialize (xmax (ftbd (snoc l aa)) xpref_x_t xsem2).
    simpl in xmax. now apply snoc_strictly_longer in xmax.
  + destruct matching as [xx [i1 [i2 [Hi1 [Hi2 [Hdiff_is [Hxpr1 Hxpr2 ]]]]]]].
    simpl in Hxpr1, Hxpr2.
    apply (list_snoc_pointwise xx l i1 i2 aa a) in Hxpr2; auto.
    destruct Hxpr2 as [H1 H2]. subst.
    apply (input_tot_consequence W2 l a aa) in xsem2; auto.
    specialize (xmax (ftbd (snoc l aa)) xpref_x_t xsem2).
    simpl in xmax. now apply snoc_strictly_longer in xmax.
Qed.

Theorem R2rSP_RTEP : R2rSP -> RTEP.
Proof.
  rewrite <- R2rSC_R2rSP. rewrite R2rSC_R2rSC'.
  unfold R2rSC', RTEP.
  intros twoX P1 P2 Hsrc Ct t.
  specialize (twoX P1 P2 myr (teq_premises_myXr_holds P1 P2 Hsrc) Ct).
  split.
  + intros case1.
    apply NNPP. intros t_not_sem2.
    destruct (longest_in_psem tgt_sem (Ct [P2↓]) t t_not_sem2) as [x [xpref_x_t [xsem2_x x_max]]].
    destruct xsem2_x as [t2 [x_t2 t2_sem2]].
    destruct x.
    ++ (* it can only be t2 '=' fstop p e = t *)
       destruct t, t2; auto.
       inversion xpref_x_t; inversion x_t2; subst; congruence.
    ++ destruct (three_continuations_tbd l t2 x_t2) as [t2stop | [t2silent | t2longer]].
       +++ destruct t2stop as [e2 Ht2]. rewrite Ht2 in *.
           now apply (t_being_tstop_leads_to_contra (Ct [P1↓]) (Ct [P2↓]) t l e2).
       +++ rewrite t2silent in *.
           now apply (no_divergence (Ct [P2↓]) (tsilent l)).
       +++ destruct t2longer as [a t2longer].
           destruct (three_continuations_tbd l t xpref_x_t) as [ttstop | [ttsilent | ttlonger]].           - destruct ttstop as [e ttstop]. subst.
             destruct (twoX (fstop l e) (ftbd (snoc l a))) as [xpr1 | [xpr2 | matching]]; auto.
             now exists (tstop l e). now exists t2.
             -- simpl in xpr2. now apply snoc_strictly_longer in xpr2.
             -- destruct matching as [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2 ]]]]]]].
                simpl in Hxpr1, Hxpr2.
                apply (snocs_aux_lemma xx l i2 i1 a); congruence.
           - subst. now apply (no_divergence (Ct [P1↓]) (tsilent l)).
           - destruct ttlonger as [aa ttlonger].
             now apply (violates_xmax (Ct [P1↓]) (Ct [P2↓]) t t2 l a aa).
  + intros case2.
    apply NNPP. intros t_not_sem1.
    destruct (longest_in_psem tgt_sem (Ct [P1↓]) t t_not_sem1) as [x [xpref_x_t [xsem1_x x_max]]].
    destruct xsem1_x as [t1 [x_t1 t1_sem1]].
    assert (twoX' : forall m1 m2, psem (Ct [P2 ↓]) m1 -> psem (Ct [P1 ↓]) m2 -> myr m1 m2).
    { intros x1 x2 H H0. apply myr_symmetric. now apply twoX. }
    destruct x.
    ++ (* it can only be t2 '=' fstop p e = t *)
       destruct t, t1; auto.
       inversion xpref_x_t; inversion x_t1; subst; congruence.
    ++ destruct (three_continuations_tbd l t1 x_t1) as [t1stop | [t1silent | t1longer]].
       +++ destruct t1stop as [e1 Ht1]. rewrite Ht1 in *.
           now apply (t_being_tstop_leads_to_contra (Ct [P2↓]) (Ct [P1↓]) t l e1).
       +++ rewrite t1silent in *.
           now apply (no_divergence (Ct [P1↓]) (tsilent l)).
       +++ destruct t1longer as [a t1longer].
           destruct (three_continuations_tbd l t xpref_x_t) as [ttstop | [ttsilent | ttlonger]].
           - destruct ttstop as [e ttstop]. subst.
             destruct (twoX' (fstop l e) (ftbd (snoc l a))) as [xpr1 | [xpr2 | matching]]; auto.
             now exists (tstop l e). now exists t1.
             -- simpl in xpr2. now apply snoc_strictly_longer in xpr2.
             -- destruct matching as [xx [i1 [i2 [Hi1 [Hi2 [Hdiff [Hxpr1 Hxpr2 ]]]]]]].
                simpl in Hxpr1, Hxpr2.
                apply (snocs_aux_lemma xx l i2 i1 a); congruence.
           - subst. now apply (no_divergence (Ct [P2↓]) (tsilent l)).
           - destruct ttlonger as [aa ttlonger].
             now apply (violates_xmax (Ct [P2↓]) (Ct [P1↓]) t t1 l a aa).
Qed.


Set Warnings "-funind-cannot-define-graph".
Set Warnings "-funind".

Require Import ssreflect.
Require Import Tweetnacl.Libs.Export.
Require Import Tweetnacl.Low.Get_abcdef.
Require Import Tweetnacl.Low.ScalarMult_gen_small.
Require Import Tweetnacl.Gen.AMZubSqSel_List.
Require Import Tweetnacl.Gen.ABCDEF.
Require Import Tweetnacl.Gen.abstract_fn_rev.
Section ScalarRec.

Open Scope Z.

Context {O : Ops (list Z) (list Z) id}.
Context {OP : @Ops_List O}.

Lemma abstract_fn_Zlength : forall m p z a b c d e f x a' b' c' d' e' f',
  0 <= m ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  (a',b',c',d',e',f') = (abstract_fn_rev m p z a b c d e f x) ->
  Zlength a' = 16
  /\ Zlength b' = 16
   /\ Zlength c' = 16
    /\ Zlength d' = 16
     /\ Zlength e' = 16
      /\ Zlength f' = 16.
Proof.
  intros m p z a b c d e f x a' b' c' d' e' f' Hm.
  gen a' b' c' d' e' f'.
  gen p z a b c d e f x.
  gen m.
  apply (natlike_ind (fun m => forall (p : ℤ) (z a b c d e f x a' b' c' d' e' f' : list ℤ),
Zlength a = 16 ->
Zlength b = 16 ->
Zlength c = 16 ->
Zlength d = 16 ->
Zlength e = 16 ->
Zlength f = 16 ->
Zlength x = 16 ->
(a', b', c', d', e', f') = abstract_fn_rev m p z a b c d e f x ->
Zlength a' = 16 /\ Zlength b' = 16 /\ Zlength c' = 16 /\ Zlength d' = 16 /\ Zlength e' = 16 /\ Zlength f' = 16)).
move=> p z a b c d e f x a' b' c' d' e' f'.
move=> Ha Hb Hc Hd He Hf Hx.
rewrite abstract_fn_rev_equation Zle_imp_le_bool ; try omega.
go.
move=> m Hm IHm.
move=> p z a b c d e f x a' b' c' d' e' f'.
move=> Ha Hb Hc Hd He Hf Hx.
change (Z.succ m) with (m + 1).
rewrite abstract_fn_rev_equation.
replace (m + 1 - 1) with m by omega.
remember (abstract_fn_rev m p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0).
replace (m + 1 <=? 0) with false.
2: symmetry ; apply Z.leb_gt ; omega.
move=> Heq;inversion Heq.
assert(Ht:= IHm p z a b c d e f x a0 b0 c0 d0 e0 f0 Ha Hb Hc Hd He Hf Hx Heqk).
jauto_set.
apply fa_Zlength ; auto.
apply fb_Zlength ; auto.
apply fc_Zlength ; auto.
apply fd_Zlength ; auto.
apply fe_Zlength ; auto.
apply ff_Zlength ; auto.
Qed.

Lemma get_a_abstract_fn_Zlength : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  Zlength (get_a (abstract_fn_rev n p z a b c d e f x)) = 16.
Proof. intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_Zlength n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_b_abstract_fn_Zlength : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  Zlength (get_b (abstract_fn_rev n p z a b c d e f x)) = 16.
Proof. intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_Zlength n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_c_abstract_fn_Zlength : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  Zlength (get_c (abstract_fn_rev n p z a b c d e f x)) = 16.
Proof. intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_Zlength n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_d_abstract_fn_Zlength : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  Zlength (get_d (abstract_fn_rev n p z a b c d e f x)) = 16.
Proof. intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_Zlength n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_e_abstract_fn_Zlength : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  Zlength (get_e (abstract_fn_rev n p z a b c d e f x)) = 16.
Proof. intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_Zlength n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_f_abstract_fn_Zlength : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 -> Zlength b = 16 -> Zlength c = 16 ->
  Zlength d = 16 -> Zlength e = 16 -> Zlength f = 16 -> Zlength x = 16 ->
  Zlength (get_f (abstract_fn_rev n p z a b c d e f x)) = 16.
Proof. intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_Zlength n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 He).
rewrite -He; jauto_set; go.
Qed.

Lemma abstract_fn_rev_bound : forall n p z a b c d e f x a' b' c' d' e' f',
  0 <= n ->
  Zlength a = 16 ->
  Zlength b = 16 ->
  Zlength c = 16 ->
  Zlength d = 16 ->
  Zlength e = 16 ->
  Zlength f = 16 ->
  Zlength x = 16 ->
    Forall (fun x => -38 <= x < 2^16 + 38) a ->
    Forall (fun x => -38 <= x < 2^16 + 38) b ->
    Forall (fun x => -38 <= x < 2^16 + 38) c ->
    Forall (fun x => -38 <= x < 2^16 + 38) d ->
    Forall (fun x => 0 <= x < 2^16) x ->
    (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x) ->
    Forall (fun x => -38 <= x < 2^16 + 38) a'
    /\ Forall (fun x => -38 <= x < 2^16 + 38) b'
    /\ Forall (fun x => -38 <= x < 2^16 + 38) c'
    /\ Forall (fun x => -38 <= x < 2^16 + 38) d'.
Proof. intros m p z a b c d e f x a' b' c' d' e' f' Hm.
  gen a' b' c' d' e' f'.
  gen p z a b c d e f x.
  gen m.
  apply (natlike_ind (fun m => forall (p : ℤ) (z a b c d e f x a' b' c' d' e' f' : list ℤ),
Zlength a = 16 ->
Zlength b = 16 ->
Zlength c = 16 ->
Zlength d = 16 ->
Zlength e = 16 ->
Zlength f = 16 ->
Zlength x = 16 ->
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) a ->
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) b ->
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) c ->
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) d ->
Forall (fun x0 : ℤ => 0 <= x0 < 2 ^ 16) x ->
(a', b', c', d', e', f') = abstract_fn_rev m p z a b c d e f x ->
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) a' /\
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) b' /\
Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) c' /\ Forall (fun x0 : ℤ => -38 <= x0 < 2 ^ 16 + 38) d')).
move=> p z a b c d e f x a' b' c' d' e' f' (* Hn Hp Hnp*) Ha Hb Hc Hd He Hf Hx
Haa Hbb Hcc Hdd Hxx.
rewrite abstract_fn_rev_0 => Hh.
inv Hh ; go.
move => m Hm IHm p z a b c d e f x a' b' c' d' e' f' (* Hn Hp Hnp*) Ha Hb Hc Hd He Hf Hx
Haa Hbb Hcc Hdd Hxx.
rewrite abstract_fn_rev_n. 2: omega.
replace (Z.succ m - 1) with m.
2: omega.
remember (abstract_fn_rev m p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0).
remember (Getbit (p - m) z) as r.
simpl => Hh.
inv Hh.
assert(Ht:= IHm p z a b c d e f x a0 b0 c0 d0 e0 f0 Ha Hb Hc Hd He Hf Hx Haa Hbb Hcc Hdd Hxx Heqk) ; auto.
assert(Htt := abstract_fn_Zlength m p z a b c d e f x a0 b0 c0 d0 e0 f0 Hm Ha Hb Hc Hd He Hf Hx Heqk).
jauto_set.
apply fa_bound ; go.
apply fb_bound ; go.
apply fc_bound ; go.
apply fd_bound ; go.
Qed.

Lemma get_a_abstract_fn_bound : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 ->
  Zlength b = 16 ->
  Zlength c = 16 ->
  Zlength d = 16 ->
  Zlength e = 16 ->
  Zlength f = 16 ->
  Zlength x = 16 ->
    Forall (fun x => -38 <= x < 2^16 + 38) a ->
    Forall (fun x => -38 <= x < 2^16 + 38) b ->
    Forall (fun x => -38 <= x < 2^16 + 38) c ->
    Forall (fun x => -38 <= x < 2^16 + 38) d ->
    Forall (fun x => 0 <= x < 2^16) x ->
    Forall (fun x => -38 <= x < 2^16 + 38) (get_a (abstract_fn_rev n p z a b c d e f x)).
Proof.
intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_rev_bound n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_b_abstract_fn_bound : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 ->
  Zlength b = 16 ->
  Zlength c = 16 ->
  Zlength d = 16 ->
  Zlength e = 16 ->
  Zlength f = 16 ->
  Zlength x = 16 ->
    Forall (fun x => -38 <= x < 2^16 + 38) a ->
    Forall (fun x => -38 <= x < 2^16 + 38) b ->
    Forall (fun x => -38 <= x < 2^16 + 38) c ->
    Forall (fun x => -38 <= x < 2^16 + 38) d ->
    Forall (fun x => 0 <= x < 2^16) x ->
    Forall (fun x => -38 <= x < 2^16 + 38) (get_b (abstract_fn_rev n p z a b c d e f x)).
Proof.
intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_rev_bound n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_c_abstract_fn_bound : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 ->
  Zlength b = 16 ->
  Zlength c = 16 ->
  Zlength d = 16 ->
  Zlength e = 16 ->
  Zlength f = 16 ->
  Zlength x = 16 ->
    Forall (fun x => -38 <= x < 2^16 + 38) a ->
    Forall (fun x => -38 <= x < 2^16 + 38) b ->
    Forall (fun x => -38 <= x < 2^16 + 38) c ->
    Forall (fun x => -38 <= x < 2^16 + 38) d ->
    Forall (fun x => 0 <= x < 2^16) x ->
    Forall (fun x => -38 <= x < 2^16 + 38) (get_c (abstract_fn_rev n p z a b c d e f x)).
Proof.
intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_rev_bound n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 He).
rewrite -He; jauto_set; go.
Qed.
Lemma get_d_abstract_fn_bound : forall n p z a b c d e f x,
  0 <= n ->
  Zlength a = 16 ->
  Zlength b = 16 ->
  Zlength c = 16 ->
  Zlength d = 16 ->
  Zlength e = 16 ->
  Zlength f = 16 ->
  Zlength x = 16 ->
    Forall (fun x => -38 <= x < 2^16 + 38) a ->
    Forall (fun x => -38 <= x < 2^16 + 38) b ->
    Forall (fun x => -38 <= x < 2^16 + 38) c ->
    Forall (fun x => -38 <= x < 2^16 + 38) d ->
    Forall (fun x => 0 <= x < 2^16) x ->
    Forall (fun x => -38 <= x < 2^16 + 38) (get_d (abstract_fn_rev n p z a b c d e f x)).
Proof.
intros.
assert(He: exists a' b' c' d' e' f', (a',b',c',d',e',f') = (abstract_fn_rev n p z a b c d e f x)).
  remember (abstract_fn_rev n p z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  do 6 eexists ; reflexivity.
destruct He as [a' [b' [c' [d' [e' [f' He]]]]]].
assert(Ht := abstract_fn_rev_bound n p z a b c d e f x a' b' c' d' e' f' H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 He).
rewrite -He; jauto_set; go.
Qed.

Close Scope Z.

End ScalarRec.


(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.
Require Import Eqdep.
Require Import PeanoNat.
Require Import Omega.
Require Import ProofIrrelevance.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.
Require Import UniqueTypI1.
Require Import DerivDynI1.
Require Import TransPrelimI1.
Require Import TSoundnessI1.
Require Import SReducI1.
Require Import DetermI1.
Require Import PreReflI1.

Import ListNotations.

Module Reflect (IdT: ModTyp) <: ModTyp.

Module PreReflL := PreRefl IdT.
Export PreReflL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Open Scope type_scope.

(*********************************************************************)

Definition ExpTrans3_def (fenv: funEnv) (k1: FEnvWT fenv) (n: nat) :=
   fun (ftenv: funTC) (tenv: valTC) (e: Exp) (t: VTyp)
       (k: ExpTyping ftenv tenv e t) =>
          FEnvTyping fenv ftenv ->
          valTC_Trans tenv ->
          forall (n1: nat), n1 <= n -> W ->
                            (sVTyp t * W) * sigT (fun n2 => n2 <= n1).

Definition PrmsTrans3_def (fenv: funEnv) (k1: FEnvWT fenv) (n: nat) :=
   fun (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp)
       (k: PrmsTyping ftenv tenv ps pt) =>
          FEnvTyping fenv ftenv ->
          valTC_Trans tenv ->
          forall (n1: nat), n1 <= n -> W ->
                            (PTyp_TRN pt * W) * sigT (fun n2 => n2 <= n1).

Definition Trans_ExpTyping_mut3 (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :=
  ExpTyping_mut (ExpTrans3_def fenv D n) (PrmsTrans3_def fenv D n).

Definition Trans_PrmsTyping_mut3 (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :=
  PrmsTyping_mut (ExpTrans3_def fenv D n) (PrmsTrans3_def fenv D n).

Lemma ExpTrans_Val (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (v : Value)
    (t : VTyp) (v0 : VTyping v t),
  ExpTrans3_def fenv D n ftenv tenv (Val v) t (Val_Typing ftenv tenv v t v0).
 unfold ExpTrans3_def.
 intros.
 inversion v0; subst.
 split.
 exact (sValue v, X0).
 econstructor 1 with (x := n1).
 auto.
Defined.

(*********************************************************************)

Lemma ExpTrans_Var (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (t : VTyp) (i : IdTyping tenv x t),
  ExpTrans3_def fenv D n ftenv tenv (Var x) t (Var_Typing ftenv tenv x t i).
     unfold ExpTrans3_def.
     intros.
     eapply ExpDenI2_Var.
     exact i.
     exact X.
     exact X0.
Defined.

Lemma ExpTrans_BindN (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (e1 e2 : Exp)
    (t1 t2 : VTyp) (e : ExpTyping ftenv tenv e1 t1),
  ExpTrans3_def fenv D n ftenv tenv e1 t1 e ->
  forall e0 : ExpTyping ftenv tenv e2 t2,
  ExpTrans3_def fenv D n ftenv tenv e2 t2 e0 ->
  ExpTrans3_def fenv D n ftenv tenv (BindN e1 e2) t2
    (BindN_Typing ftenv tenv e1 e2 t1 t2 e e0).
     unfold ExpTrans3_def.
     intros.
     rename X2 into X3.
     rename X1 into X2.
     rename H into X1.
     rename H0 into H.
     specialize (X X1 X2 n1 H X3).
     destruct X as [p2 X].
     destruct X as [n2 q2].
     destruct p2 as [sv2 s2].
     assert (n2 <= n) as q3.
(*     omega. *)
     eapply le_trans with (m:=n1).
     exact q2.
     exact H.
     specialize (X0 X1 X2 n2 q3 s2).
     destruct X0 as [p3 X0].
     destruct X0 as [n3 q4].
     split.
     exact p3.
     econstructor 1 with (x:=n3).
     (*     omega. *)
     eapply le_trans with (m:=n2).
     exact q4.
     exact q2.
Defined.

Lemma ExpTrans_BindS (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv tenv' : valTC) (x : StaticSemL.Id)
    (e1 e2 : Exp) (t1 t2 : VTyp) (m : option VTyp)
    (m0 : Maybe t1 m) (e : tenv' = (x, t1) :: tenv)
    (e0 : ExpTyping ftenv tenv e1 t1),
  ExpTrans3_def fenv D n ftenv tenv e1 t1 e0 ->
  forall e3 : ExpTyping ftenv tenv' e2 t2,
  ExpTrans3_def fenv D n ftenv tenv' e2 t2 e3 ->
  ExpTrans3_def fenv D n ftenv tenv (BindS x m e1 e2) t2
                (BindS_Typing ftenv tenv tenv' x e1 e2 t1 t2 m m0 e e0 e3).
     unfold ExpTrans3_def.
     intros.
     rename X2 into X3.
     rename X1 into X2.
     rename H into X1.
     rename H0 into H.
     specialize (X X1 X2 n1 H X3).
     destruct X as [p2 X].
     destruct X as [n2 q2].
     destruct p2 as [sv1 s2].
     assert (n2 <= n) as q3.
(*     omega. *)
     eapply le_trans with (m:=n1).
     exact q2.
     exact H.
     inversion e; subst.
     clear H0.
     unfold valTC_Trans in *.
     specialize (X0 X1 (ext_senv tenv X2 x t1 sv1) n2 q3 s2).
     destruct X0 as [p3 X0].
     destruct X0 as [n3 q4].
     split.
     exact p3.
     econstructor 1 with (x:=n3).
     (*     omega. *)
     eapply le_trans with (m:=n2).
     exact q4.
     exact q2.
Defined.

Lemma ExpTrans_BindMS (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv tenv0 tenv1 : valTC)
    (env0 : valEnv) (e : Exp) (t : VTyp) (e0 : EnvTyping env0 tenv0)
    (e1 : tenv1 = tenv0 ++ tenv) (e2 : ExpTyping ftenv tenv1 e t),
  ExpTrans3_def fenv D n ftenv tenv1 e t e2 ->
  ExpTrans3_def fenv D n ftenv tenv (BindMS env0 e) t
    (BindMS_Typing ftenv tenv tenv0 tenv1 env0 e t e0 e1 e2).
     unfold ExpTrans3_def.
     intros.
     rename X1 into X2.
     rename X0 into X1.
     rename H into X0.
     rename H0 into H.
     specialize (X X0).
     inversion e1; subst.
     clear H0.
     eapply extend_valTC_Trans with (env0:=env0) (tenv0:=tenv0)
                                    (tenv:= tenv) in e0.
     specialize (X e0 n1 H X2).
     exact X.
     exact X1.
Defined.

Lemma ExpTrans_IfThenElse (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (e1 e2 e3 : Exp)
    (t : VTyp) (e : ExpTyping ftenv tenv e1 Bool),
  ExpTrans3_def fenv D n ftenv tenv e1 Bool e ->
  forall e0 : ExpTyping ftenv tenv e2 t,
  ExpTrans3_def fenv D n ftenv tenv e2 t e0 ->
  forall e4 : ExpTyping ftenv tenv e3 t,
  ExpTrans3_def fenv D n ftenv tenv e3 t e4 ->
  ExpTrans3_def fenv D n ftenv tenv (IfThenElse e1 e2 e3) t
    (IfThenElse_Typing ftenv tenv e1 e2 e3 t e e0 e4).
     unfold ExpTrans3_def.
     intros.
     rename X3 into X4.
     rename X2 into X3.
     rename H into X2.
     rename H0 into H.
     specialize (X X2 X3 n1 H X4).
     destruct X as [p2 X].
     destruct X as [n2 q2].
     destruct p2 as [sv1 s2].
     assert (n2 <= n) as q3.
     (* omega. *)
     eapply le_trans.
     exact q2.
     exact H.
     simpl in sv1.
     destruct sv1.
     specialize (X0 X2 X3 n2 q3 s2).
     destruct X0 as [p3 X0].
     destruct X0 as [n3 q4].
     split.
     exact p3.
     econstructor 1 with (x:=n3).
     (* omega. *)
     eapply le_trans.
     exact q4.
     exact q2.
     specialize (X1 X2 X3 n2 q3 s2).
     destruct X1 as [p3 X1].
     destruct X1 as [n3 q4].
     split.
     exact p3.
     econstructor 1 with (x:=n3).
     (* omega. *)
     eapply le_trans.
     exact q4.
     exact q2.
Defined.

Lemma ExpTrans_Apply0 :
  forall (fenv: funEnv) (D: FEnvWT fenv)
         (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (e : Exp) (ps : Prms) (pt : PTyp) (t : VTyp) (p : Pure e)
    (i : IdFTyping ftenv x (FT pt t)) (p0 : PrmsTyping ftenv tenv ps pt),
  PrmsTrans3_def fenv D 0 ftenv tenv ps pt p0 ->
  forall e0 : ExpTyping ftenv tenv e Nat,
  ExpTrans3_def fenv D 0 ftenv tenv e Nat e0 ->
  ExpTrans3_def fenv D 0 ftenv tenv (Apply x ps e) t
                (Apply_Typing ftenv tenv x e ps pt t p i p0 e0).
     unfold ExpTrans3_def, PrmsTrans3_def.
     intros.
     rename X2 into X3.
     rename X1 into X2.
     rename H into X1.
     rename H0 into H.
     specialize (X0 X1 X2 n1 H X3).
     destruct X0 as [p2 X0].
     destruct X0 as [n2 q2].
     destruct p2 as [sv1 s2].
     assert (n2 <= 0) as q3.
     omega.
     specialize (X X1 X2 n2 q3 s2).
     destruct X as [p3 X].
     destruct X as [n3 q4].
     inversion i; subst.
     eapply (ExtRelVal2 funFTyp ftenv fenv x (FT pt t)) in H1.
     destruct H1 as [f H0 H1].
     destruct f.
     unfold funFTyp in H1.
     destruct v.
     destruct v.
     simpl in *.
     inversion H1; subst.
     split.
     exact (v,(snd p3)).
     econstructor 1 with (x:=n3).
     omega.
     exact X1.
Defined.

Lemma ExpTrans_Call0 :
  forall (fenv: funEnv) (D: FEnvWT fenv)
         (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (ls : list Exp) (pt : PTyp) (t : VTyp) (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D 0 ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D 0 ftenv tenv (Call x (PS ls)) t
    (Call_Typing ftenv tenv x ls pt t i p).
     unfold ExpTrans3_def, PrmsTrans3_def.
     intros.
     rename X1 into X2.
     rename X0 into X1.
     rename H into X0.
     rename H0 into H.
     specialize (X X0 X1 n1 H X2).
     destruct X as [p3 X].
     destruct X as [n3 q4].
     inversion i; subst.
     eapply (ExtRelVal2 funFTyp ftenv fenv x (FT pt t)) in H1.
     destruct H1 as [f H0 H1].
     destruct f.
     unfold funFTyp in H1.
     destruct v.
     destruct v.
     simpl in *.
     inversion H1; subst.
     split.
     exact (v,(snd p3)).
     econstructor 1 with (x:=n3).
     omega.
     exact X0.
Defined.

Lemma ExpTrans_Modify (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (t1 t2 : VTyp)
    (XF : XFun t1 t2) (e : Exp) (e0 : ExpTyping ftenv tenv e t1),
  ExpTrans3_def fenv D n ftenv tenv e t1 e0 ->
  ExpTrans3_def fenv D n ftenv tenv (Modify t1 t2 XF e) t2
    (Modify_Typing ftenv tenv t1 t2 XF e e0).
     unfold ExpTrans3_def.
     intros.
     rename X1 into X2.
     rename X0 into X1.
     rename H into X0.
     rename H0 into H.
     specialize (X X0 X1 n1 H X2).
     destruct X as [p3 X].
     destruct X as [n3 q4].
     destruct p3 as [sv s3].
     destruct XF.
     set (x_mod0 sv s3) as p.
     subst inpT0.
     subst outT0.
     split.
     exact p.
     econstructor 1 with (x:=n3).
     (* omega. *)
     assumption.
Defined.

Lemma ExpTrans_PrmsNil (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC),
    PrmsTrans3_def fenv D n ftenv tenv (PS []) (PT [])
                   (PSNil_Typing ftenv tenv).
     unfold PrmsTrans3_def.
     intros.
     split.
     split.
     constructor.
     exact X0.
     econstructor 1 with (x:=n1).
     auto.
Defined.

Lemma ExpTrans_Prms (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp)
    (es : list Exp) (ts : list VTyp) (e0 : ExpTyping ftenv tenv e t),
  ExpTrans3_def fenv D n ftenv tenv e t e0 ->
  forall p : PrmsTyping ftenv tenv (PS es) (PT ts),
  PrmsTrans3_def fenv D n ftenv tenv (PS es) (PT ts) p ->
  PrmsTrans3_def fenv D n ftenv tenv (PS (e :: es)) (PT (t :: ts))
                 (PSCons_Typing ftenv tenv e t es ts e0 p).
     unfold ExpTrans3_def, PrmsTrans3_def.
     intros.
     rename X2 into X3.
     rename X1 into X2.
     rename H into X1.
     rename H0 into H.
     specialize (X X1 X2 n1 H X3).
     destruct X as [p2 X].
     destruct X as [n2 q2].
     destruct p2 as [sv1 s2].
     assert (n2 <= n) as q3.
     eapply le_trans.
     exact q2.
     exact H.
     (* omega *)
     specialize (X0 X1 X2 n2 q3 s2).
     destruct X0 as [p3 X0].
     destruct p3 as [svs3 s3].
     destruct X0 as [n3 q4].
     split.
     split.
     constructor.
     exact sv1.
     exact svs3.
     exact s3.
     econstructor 1 with (x:=n3).
     (* omega. *)
     eapply le_trans.
     exact q4.
     exact q2.
Defined.

(*****************************************************************)

Lemma ExpTrans_ApplyE (fenv: funEnv) (D: FEnvWT fenv) (n : nat)
 (IHn : forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
        ExpTyping ftenv tenv e t ->
        FEnvTyping fenv ftenv ->
        valTC_Trans tenv ->
        forall n1 : nat, n1 <= n -> W -> sVTyp t * W * {n2 : nat & n2 <= n1}) :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (e : Exp) (ps : Prms) (pt : PTyp) (t : VTyp) (p : Pure e)
    (i : IdFTyping ftenv x (FT pt t)) (p0 : PrmsTyping ftenv tenv ps pt),
  PrmsTrans3_def fenv D (S n) ftenv tenv ps pt p0 ->
  forall e0 : ExpTyping ftenv tenv e Nat,
  ExpTrans3_def fenv D (S n) ftenv tenv e Nat e0 ->
  ExpTrans3_def fenv D (S n) ftenv tenv (Apply x ps e) t
    (Apply_Typing ftenv tenv x e ps pt t p i p0 e0).
     unfold ExpTrans3_def, PrmsTrans3_def.
     intros.
     rename X2 into X3.
     rename X1 into X2.
     rename H into X1.
     rename H0 into H.
     specialize (X0 X1 X2 n1 H X3).
     destruct X0 as [p2 X0].
     destruct X0 as [n2 q2].
     destruct p2 as [sv1 s2].
     assert (n2 <= S n) as q3.
     omega.
     specialize (X X1 X2 n2 q3 s2).
     destruct X as [p3 X].
     destruct p3 as [svs2 s3].
     destruct X as [n3 q4].

     inversion i; subst.
     eapply (ExtRelVal2 funFTyp ftenv fenv x (FT pt t)) in H1.
     destruct H1 as [f H0 H1].
     generalize D.
     intro k3.
     unfold FEnvWT in D.
     specialize (D ftenv X1 x f H0).
     unfold FunWT in D.
     destruct f.
     unfold funFTyp in H1.
     destruct v.
     destruct v.
     simpl in *.
     inversion H1; subst.
     clear H1.

     assert (n3 <= S n) as q5.
     omega.

     destruct n3.
     assert (0 <= n) as q6.
     omega.

     specialize (IHn ftenv tenv0 e1 t D X1 svs2 0 q6 s3).
     destruct IHn as [p4 IH].
     split.
     exact p4.
     destruct IH as [n5 IH].
     econstructor 1 with (x:=n5).
     omega.

     assert (n3 <= n) as q6.
     omega.

     specialize (IHn ftenv tenv0 e1 t D X1 svs2 n3 q6 s3).
     destruct IHn as [p4 IH].
     split.
     exact p4.
     destruct IH as [n5 IH].
     econstructor 1 with (x:=n5).
     omega.

     exact X1.
Defined.

Lemma ExpTrans_ApplyXXX (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
     (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
      (IHn : FEnvTyping fenv ftenv ->
          valTC_Trans tenv0 ->
          forall (n0 : nat),
          n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0}) :
    forall (e9 : Exp) (ls : list Exp) (pt : PTyp) (p9 : Pure e9)
           (i1 : IdFTyping ftenv x (FT pt t))
           (p : PrmsTyping ftenv tenv (PS ls) pt),
      PrmsTrans3_def fenv D (S n) ftenv tenv (PS ls) pt p ->
   forall m9 : ExpTyping ftenv tenv e9 Nat,
   ExpTrans3_def fenv D (S n) ftenv tenv e9 Nat m9 ->
   ExpTrans3_def fenv D (S n) ftenv tenv (Apply x (PS ls) e9) t
                 (Apply_Typing ftenv tenv x e9 (PS ls) pt t p9 i1 p m9).
    unfold ExpTrans3_def, PrmsTrans3_def.
    intros e9 ls pt p9 i1 p.
    intros X m9 Y H X0 n1 H0 X1.
    specialize (Y H X0 n1 H0 X1).

    destruct Y as [pp9 Y].
    destruct pp9 as [n10 s9].
    destruct Y as [n9 q9].
    simpl in *.

    specialize (X H X0 n1 H0 X1).

    destruct X as [p3 X].
    destruct p3 as [svs2 s3].
    destruct X as [n3 q4].
    simpl in *.

    set (f:=FC tenv0 v e).
    set (ft:=FT pt t).
    unfold VTyping in m.

    generalize i1.
    intro i3.

    assert (0 <= n1) as qq.
    intuition.

    eapply (RelatedByEnv funFTyp fenv ftenv x f ft H i2) in i3.

    remember (min n3 n10) as n11.

    destruct n11.

    split.
    destruct v.
    destruct v.
    simpl in m.
    inversion m; subst.
    exact (v, s3).
    econstructor 1 with (x:=0).
    auto.

(* case S *)
    assert (n3 <= S n) as q02a.
    eapply le_trans.
    exact q4.
    exact H0.
    assert (S n11 <= n3) as q02b.
    rewrite Heqn11.
    intuition.
    assert (S n11 <= S n) as q02.
    eapply le_trans.
    exact q02b.
    exact q02a.
    assert (n11 <= n) as q2.
    eapply (le_inject _ _ q02).

    unfold PTyp_TRN in svs2.
    destruct pt.
    simpl in i3.
    inversion i3; subst.

    specialize (IHn H svs2 n11 q2 s3).

    destruct IHn as [IH1 IH2].

    split.
    exact IH1.
    destruct IH2 as [n4 IH2].

    econstructor 1 with (x:=n4).
    eapply le_trans.
    exact IH2.
    assert (n11 <= n3).
    eapply (le_decrease _ _ q02b).
    eapply le_trans.
    exact H1.
    exact q4.
Defined.

Lemma ExpTrans_ApplyX_aux4_0 (fenv: funEnv) (D: FEnvWT fenv) (* n: nat *)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : Id)
    (v: Value) (e: Exp)
    (t : VTyp) (m: valueVTyp v = t)
    (i2 : findE fenv x = Some (FC tenv0 v e))
  (e9 : Exp)
  (ls : list Exp)
  (pt : PTyp)
  (i1 : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (svs2 : PTyp_TRN pt)
  (s3 : W)
  (n3: nat)
  (q4 : n3 <= n1)
  (m9 : ExpTyping ftenv tenv e9 Nat)
  (n10 : nat)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (X1 : W)
  (i3 : funFTyp (FC tenv0 v e) = FT pt t)
  (Heqn11 : 0 = Init.Nat.min n3 n10)
  :
  sVTyp t * W * {n2 : nat & n2 <= n1}.

    split.
    destruct v.
    destruct v.
    simpl in m.
    inversion m; subst.
    exact (v, s3).
    econstructor 1 with (x:=0).
    intuition.
Defined.

Lemma ExpTrans_ApplyX_aux4 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : Id)
    (v: Value) (e: Exp)
    (i2 : findE fenv x = Some (FC tenv0 v e))
    (n11 : nat)
    (IHn : sVTyp (valueVTyp v) * W * {n1 : nat & n1 <= n11})
  (e9 : Exp)
  (ls : list Exp)
  (p : PrmsTyping ftenv tenv (PS ls) (PT (map snd tenv0)))
  (i : IdFTyping ftenv x (FT (PT (map snd tenv0)) (valueVTyp v)))
  (n1 : nat)
  (svs2 : tlist2type (PTyp_ListTrans (PT (map snd tenv0))))
  (s3 : W)
  (n3: nat)
  (q4 : n3 <= n1)
  (m9 : ExpTyping ftenv tenv e9 Nat)
  (n10 : nat)
  (s9 : W)
  (n9 : nat)
  (q9 : n9 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W)
  (i3 : FT (PT (map snd tenv0)) (projT1 v) =
        FT (PT (map snd tenv0)) (valueVTyp v))
  (Heqn11 : S n11 = Init.Nat.min n3 n10)
  (q02b : S n11 <= n3)
  (H3 : projT1 v = valueVTyp v) :
  sVTyp (projT1 v) * W * {n2 : nat & n2 <= n1}.

    destruct IHn as [IH1 IH2].

    split.
    exact IH1.
    destruct IH2 as [n4 IH2].

    econstructor 1 with (x:=n4).
    eapply le_trans.
    exact IH2.
    assert (n11 <= n3).
    eapply (le_decrease _ _ q02b).
    eapply le_trans.
    exact H1.
    exact q4.
Defined.

Lemma ExpTrans_ApplyX_aux3 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
    (v: Value) (e: Exp)
    (t : VTyp) (m: valueVTyp v = t)
    (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (e9 : Exp)
  (ls : list Exp)
  (pt : PTyp)
  (i1 : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (svs2 : PTyp_TRN pt)
  (s3 : W)
  (n3 : nat)
  (q4 : n3 <= n1)
  (m9 : ExpTyping ftenv tenv e9 Nat)
  (n10 : nat)
  (s9 : W)
  (n9 : nat)
  (q9 : n9 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W)
  (i3 : funFTyp (FC tenv0 v e) = FT pt t) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.

    remember (min n3 n10) as n11.

    destruct n11.

(* case 0 *)
    eapply (ExpTrans_ApplyX_aux4_0 fenv D ftenv tenv tenv0
                                x v e t m i2 e9 ls pt i1 p n1
                                svs2 s3 n3 q4 m9 n10 H X0
                                X1 i3 Heqn11).

(* case S *)
    assert (n3 <= S n) as q02a.
    eapply le_trans.
    exact q4.
    exact H0.
    assert (S n11 <= n3) as q02b.
    rewrite Heqn11.
    intuition.
    assert (S n11 <= S n) as q02.
    eapply le_trans.
    exact q02b.
    exact q02a.
    assert (n11 <= n) as q2.
    eapply (le_inject _ _ q02).

    unfold PTyp_TRN in svs2.
    destruct pt.
    simpl in i3.
    inversion i3; subst.

    specialize (IHn H svs2 n11 q2 s3).

    eapply (ExpTrans_ApplyX_aux4 fenv D n ftenv tenv tenv0
                                x v e i2 n11 IHn e9 ls p i1 n1
                                svs2 s3 n3 q4 m9 n10 s9 n9 q9
                                H X0 H0 X1 i3 Heqn11 q02b H3).
Defined.

Lemma ExpTrans_ApplyX_aux2 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
    (v: Value) (e: Exp)
    (t : VTyp) (m: VTyping v t)
    (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (e9 : Exp)
  (ls : list Exp)
  (pt : PTyp)
  (i1 : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (svs2 : PTyp_TRN pt)
  (s3 : W)
  (n3 : nat)
  (q4 : n3 <= n1)
  (m9 : ExpTyping ftenv tenv e9 Nat)
  (n10 : nat)
  (s9 : W)
  (n9 : nat)
  (q9 : n9 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.

    set (f:=FC tenv0 v e).
    set (ft:=FT pt t).
    unfold VTyping in m.

    generalize i1.
    intro i3.

    assert (0 <= n1) as qq.
    intuition.

    eapply (RelatedByEnv funFTyp fenv ftenv x f ft H i2) in i3.

    eapply (ExpTrans_ApplyX_aux3 fenv D n ftenv tenv tenv0
                         x v e t m i2 IHn e9 ls pt i1 p n1 svs2 s3 n3 q4
                                 m9 n10 s9 n9 q9 H X0 H0 X1 i3).
Defined.

Lemma ExpTrans_ApplyX_aux1 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
    (v: Value) (e: Exp)
    (t : VTyp) (m: VTyping v t)
    (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (e9: Exp)
  (ls : list Exp)
  (pt : PTyp)
  (i1 : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (X : PTyp_TRN pt * W * {n2 : nat & n2 <= n1})
  (m9 : ExpTyping ftenv tenv e9 Nat)
  (n10 : nat)
  (s9 : W)
  (n9 : nat)
  (q9 : n9 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.

    destruct X as [p3 X].
    destruct p3 as [svs2 s3].
    destruct X as [n3 q4].
    simpl in *.

    eapply (ExpTrans_ApplyX_aux2 fenv D n ftenv tenv tenv0
                         x v e t m i2 IHn e9 ls pt i1 p n1 svs2 s3 n3 q4
                                 m9 n10 s9 n9 q9 H X0 H0 X1).
Defined.

Lemma ExpTrans_ApplyX_aux0 (fenv : funEnv)
    (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
    (v: Value) (e: Exp)
    (t : VTyp) (m: VTyping v t)
    (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (e9: Exp)
  (ls : list Exp)
  (pt : PTyp)
  (i1 : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (X : FEnvTyping fenv ftenv ->
      valTC_Trans tenv ->
      forall n1 : nat,
      n1 <= S n ->
      W -> PTyp_TRN pt * W * {n2 : nat & n2 <= n1})
  (m9 : ExpTyping ftenv tenv e9 Nat)
  (n1 : nat)
  (Y : sVTyp Nat * W * {n2 : nat & n2 <= n1})
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.

    destruct Y as [pp9 Y].
    destruct pp9 as [n10 s9].
    destruct Y as [n9 q9].
    simpl in *.

    specialize (X H X0 n1 H0 X1).

    eapply (ExpTrans_ApplyX_aux1 fenv D n ftenv tenv tenv0
           x v e t m i2 IHn e9 ls pt i1 p n1 X m9 n10 s9 n9 q9 H X0 H0 X1).
Defined.

Lemma ExpTrans_ApplyX (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
     (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
      (IHn : FEnvTyping fenv ftenv ->
          valTC_Trans tenv0 ->
          forall (n0 : nat),
          n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0}) :
    forall (e9 : Exp) (ls : list Exp) (pt : PTyp) (p9 : Pure e9)
           (i1 : IdFTyping ftenv x (FT pt t))
           (p : PrmsTyping ftenv tenv (PS ls) pt),
      PrmsTrans3_def fenv D (S n) ftenv tenv (PS ls) pt p ->
   forall m9 : ExpTyping ftenv tenv e9 Nat,
   ExpTrans3_def fenv D (S n) ftenv tenv e9 Nat m9 ->
   ExpTrans3_def fenv D (S n) ftenv tenv (Apply x (PS ls) e9) t
                 (Apply_Typing ftenv tenv x e9 (PS ls) pt t p9 i1 p m9).
    unfold ExpTrans3_def, PrmsTrans3_def.
    intros e9 ls pt p9 i1 p.
    intros X m9 Y H X0 n1 H0 X1.
    specialize (Y H X0 n1 H0 X1).

    eapply (ExpTrans_ApplyX_aux0 fenv D n ftenv tenv tenv0
           x v e t m i2 IHn e9 ls pt i1 p X m9 n1 Y H X0 H0 X1).
Defined.

(*********************************************************************)

Lemma ExpTrans_CallE_old (fenv: funEnv) (D: FEnvWT fenv) (n : nat)
 (IHn : forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
        ExpTyping ftenv tenv e t ->
        FEnvTyping fenv ftenv ->
        valTC_Trans tenv ->
        forall n1 : nat, n1 <= n -> W -> sVTyp t * W * {n2 : nat & n2 <= n1}) :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (ls : list Exp) (pt : PTyp) (t : VTyp) (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D (S n) ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D (S n) ftenv tenv (Call x (PS ls)) t
    (Call_Typing ftenv tenv x ls pt t i p).
     unfold ExpTrans3_def, PrmsTrans3_def.
     intros.
     rename X1 into X2.
     rename X0 into X1.
     rename H into X0.
     rename H0 into H.
     specialize (X X0 X1 n1 H X2).
     destruct X as [p3 X].
     destruct p3 as [svs2 s3].
     destruct X as [n3 q4].

     inversion i; subst.
     eapply (ExtRelVal2 funFTyp ftenv fenv x (FT pt t)) in H1.
     destruct H1 as [f H0 H1].
     generalize D.
     intro k3.
     unfold FEnvWT in D.
     specialize (D ftenv X0 x f H0).
     unfold FunWT in D.
     destruct f.
     unfold funFTyp in H1.
     destruct v.
     destruct v.
     simpl in *.
     inversion H1; subst.
     clear H1.

     assert (n3 <= S n) as q5.
     omega.

     destruct n3.
     assert (0 <= n) as q6.
     omega.

     specialize (IHn ftenv tenv0 e t D X0 svs2 0 q6 s3).
     destruct IHn as [p4 IH].
     split.
     exact p4.
     destruct IH as [n5 IH].
     econstructor 1 with (x:=n5).
     omega.

     assert (n3 <= n) as q6.
     omega.

     specialize (IHn ftenv tenv0 e t D X0 svs2 n3 q6 s3).
     destruct IHn as [p4 IH].
     split.
     exact p4.
     destruct IH as [n5 IH].
     econstructor 1 with (x:=n5).
     omega.

     exact X0.
Defined.

Lemma ExpTrans_CallX_aux4 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : Id)
           (v: Value) (e: Exp)
           (i2 : findE fenv x = Some (FC tenv0 v e))
           (n3 : nat)
  (IHn : sVTyp (valueVTyp v) * W * {n1 : nat & n1 <= n3})
  (ls : list Exp)
  (p : PrmsTyping ftenv tenv (PS ls) (PT (map snd tenv0)))
  (i : IdFTyping ftenv x (FT (PT (map snd tenv0)) (valueVTyp v)))
  (n1 : nat)
  (svs2 : tlist2type (PTyp_ListTrans (PT (map snd tenv0))))
  (s3 : W)
  (q4 : S n3 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W)
  (i3 : FT (PT (map snd tenv0)) (projT1 v) =
        FT (PT (map snd tenv0)) (valueVTyp v))
  (q2 : n3 <= n)
  (H3 : projT1 v = valueVTyp v) :
  sVTyp (projT1 v) * W * {n2 : nat & n2 <= n1}.
    destruct IHn as [IH1 IH2].

    split.
    exact IH1.
    destruct IH2 as [n4 IH2].

    econstructor 1 with (x:=n4).
    eapply le_trans.
    exact IH2.
    eapply (le_decrease _ _ q4).
Defined.

Lemma ExpTrans_CallX_aux4_0 (fenv: funEnv) (D: FEnvWT fenv)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: valueVTyp v = t)
  (i2 : findE fenv x = Some (FC tenv0 v e))
  (ls : list Exp)
  (pt : PTyp)
  (i : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (svs2 : PTyp_TRN pt)
  (s3 : W)
  (q4 : 0 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (X1 : W)
  (i3 : funFTyp (FC tenv0 v e) = FT pt t) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.
    split.
    destruct v.
    destruct v.
    simpl in m.
    inversion m; subst.
    exact (v, s3).
    econstructor 1 with (x:=0).
    auto.
Defined.

Lemma ExpTrans_CallX_aux3 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: valueVTyp v = t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (ls : list Exp)
  (pt : PTyp)
  (i : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (svs2 : PTyp_TRN pt)
  (s3 : W)
  (n3 : nat)
  (q4 : n3 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W)
  (i3 : funFTyp (FC tenv0 v e) = FT pt t) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.
    destruct n3.

(* case 0 *)
    eapply (ExpTrans_CallX_aux4_0 fenv D ftenv tenv tenv0
                                x v e t m i2 ls pt i p n1
                                svs2 s3 q4 H X0 X1 i3).

(* case S *)
    assert (S n3 <= S n) as q02.
    eapply le_trans.
    exact q4.
    exact H0.
    assert (n3 <= n) as q2.
    eapply (le_inject _ _ q02).

    unfold PTyp_TRN in svs2.
    destruct pt.
    simpl in i3.
    inversion i3; subst.

    specialize (IHn H svs2 n3 q2 s3).
    eapply (ExpTrans_CallX_aux4 fenv D n ftenv tenv tenv0
                                x v e i2 n3 IHn ls p i n1
                                svs2 s3 q4 H X0 H0 X1 i3 q2 H3).
Defined.

Lemma ExpTrans_CallX_aux2 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (ls : list Exp)
  (pt : PTyp)
  (i : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (svs2 : PTyp_TRN pt)
  (s3 : W)
  (n3 : nat)
  (q4 : n3 <= n1)
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.
    set (f:=FC tenv0 v e).
    set (ft:=FT pt t).
    unfold VTyping in m.

    generalize i.
    intro i3.

    eapply (RelatedByEnv funFTyp fenv ftenv x f ft H i2) in i3.
    eapply (ExpTrans_CallX_aux3 fenv D n ftenv tenv tenv0
                                x v e t m i2 IHn ls pt i p n1
                                svs2 s3 n3 q4 H X0 H0 X1 i3).
Defined.

Lemma ExpTrans_CallX_aux1 (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
    (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
  (IHn : FEnvTyping fenv ftenv ->
        valTC_Trans tenv0 ->
        forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0})
  (ls : list Exp)
  (pt : PTyp)
  (i : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (X : PTyp_TRN pt * W * {n2 : nat & n2 <= n1})
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= S n)
  (X1 : W) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.
    destruct X as [p3 X].
    destruct p3 as [svs2 s3].
    destruct X as [n3 q4].
    simpl in *.
    eapply (ExpTrans_CallX_aux2 fenv D n ftenv tenv tenv0
                                x v e t m i2 IHn ls pt i p n1
                                svs2 s3 n3 q4 H X0 H0 X1).
Defined.

Lemma ExpTrans_CallX : forall (fenv: funEnv) (D: FEnvWT fenv) (n: nat),
    forall (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
      (IHn : FEnvTyping fenv ftenv ->
          valTC_Trans tenv0 ->
          forall (n0 : nat),
          n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0}),
    forall (ls : list Exp) (pt : PTyp)
           (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D (S n) ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D (S n) ftenv tenv (Call x (PS ls)) t
    (Call_Typing ftenv tenv x ls pt t i p).
    unfold ExpTrans3_def, PrmsTrans3_def.
    intros.
    specialize (X H X0 n1 H0 X1).
    eapply (ExpTrans_CallX_aux1 fenv D n ftenv tenv tenv0
           x v e t m i2 IHn ls pt i p n1 X H X0 H0 X1).
Defined.

Lemma ExpTrans_CallX0_aux1 (fenv : funEnv)
  (D : FEnvWT fenv)
  (ftenv : funTC)
  (tenv tenv0 : valTC)
  (x : Id)
  (v : Value)
  (e : Exp)
  (t : VTyp)
  (m : VTyping v t)
  (i2 : findE fenv x = Some (FC tenv0 v e))
  (ls : list Exp)
  (pt : PTyp)
  (i : IdFTyping ftenv x (FT pt t))
  (p : PrmsTyping ftenv tenv (PS ls) pt)
  (n1 : nat)
  (X : PTyp_TRN pt * W * {n2 : nat & n2 <= n1})
  (H : FEnvTyping fenv ftenv)
  (X0 : valTC_Trans tenv)
  (H0 : n1 <= 0)
  (X1 : W) :
  sVTyp t * W * {n2 : nat & n2 <= n1}.

    destruct X as [p3 X].
    destruct p3 as [svs2 s3].
    destruct X as [n3 q4].
    simpl in *.

    set (f:=FC tenv0 v e).
    set (ft:=FT pt t).
    unfold VTyping in m.

    generalize i.
    intro i3.

    assert (0 <= n1) as qq.
    intuition.

    eapply (RelatedByEnv funFTyp fenv ftenv x f ft H i2) in i3.

    eapply (ExpTrans_CallX_aux4_0 fenv D ftenv tenv tenv0
                                x v e t m i2 ls pt i p n1
                                svs2 s3 qq H X0 X1 i3).
Defined.

Lemma ExpTrans_CallX0 : forall (fenv: funEnv) (D: FEnvWT fenv),
    forall (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e)),
    forall (ls : list Exp) (pt : PTyp)
           (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D 0 ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D 0 ftenv tenv (Call x (PS ls)) t
    (Call_Typing ftenv tenv x ls pt t i p).
    unfold ExpTrans3_def, PrmsTrans3_def.
    intros.
    specialize (X H X0 n1 H0 X1).

    eapply (ExpTrans_CallX0_aux1 fenv D ftenv tenv tenv0 x v e t m i2
                                 ls pt i p n1 X H X0 H0 X1).
Defined.

Lemma Convert_Trans_Call (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  (forall (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e))
      (IHn : FEnvTyping fenv ftenv ->
          valTC_Trans tenv0 ->
          forall (n0 : nat),
          n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0}),
    forall (ls : list Exp) (pt : PTyp)
           (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D (S n) ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D (S n) ftenv tenv (Call x (PS ls)) t
                (Call_Typing ftenv tenv x ls pt t i p)) ->
  (forall (IHn : forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
        ExpTyping ftenv tenv e t ->
        FEnvTyping fenv ftenv ->
        valTC_Trans tenv ->
        forall n1 : nat, n1 <= n -> W -> sVTyp t * W * {n2 : nat & n2 <= n1})
    (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (ls : list Exp) (pt : PTyp) (t : VTyp) (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D (S n) ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D (S n) ftenv tenv (Call x (PS ls)) t
                (Call_Typing ftenv tenv x ls pt t i p)).
  intros.
  generalize i.
  intro i2.
  unfold IdFTyping in i.
  unfold EnvrAssign in i.

  unfold ExpTrans3_def.
  intros.

  eapply ExtRelVal2 with (f:=funFTyp) (venv:=fenv) in i.
  destruct i as [f m d].
  Focus 2.
  assumption.

  generalize D.
  intro D1.
  unfold FEnvWT in D1.
  specialize (D1 ftenv H x f m).
  unfold FunWT in D1.

  destruct f.
  simpl in d.
  inversion d; subst.
  set (t:= projT1 v).

  assert ((forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
        ExpTyping ftenv tenv e t ->
        FEnvTyping fenv ftenv ->
        valTC_Trans tenv ->
        forall n1 : nat, n1 <= n -> W -> sVTyp t * W * {n2 : nat & n2 <= n1})
          ->
         (FEnvTyping fenv ftenv ->
       valTC_Trans tenv0 ->
       forall n0 : nat, n0 <= n -> W -> sVTyp t * W * {n1 : nat & n1 <= n0}))
    as IHc.

  intros.
  subst t.
  specialize (X3 ftenv tenv0 e (projT1 v) D1 H X4 n0 H2 X5).
  exact X3.

  specialize (X ftenv tenv tenv0 x v e (projT1 v) eq_refl m (IHc IHn)
                ls (PT (map snd tenv0)) i2 p X0).
  eapply X.
  assumption.
  assumption.
  assumption.
  exact X2.
Defined.

Lemma Convert_Trans_Call0 (fenv: funEnv) (D: FEnvWT fenv) :
  (forall (ftenv : funTC) (tenv tenv0 : valTC) (x : StaticSemL.Id)
           (v: Value) (e: Exp)
           (t : VTyp) (m: VTyping v t)
      (i2 : findE fenv x = Some (FC tenv0 v e)),
    forall (ls : list Exp) (pt : PTyp)
           (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D 0 ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D 0 ftenv tenv (Call x (PS ls)) t
                (Call_Typing ftenv tenv x ls pt t i p)) ->
  (forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (ls : list Exp) (pt : PTyp) (t : VTyp) (i : IdFTyping ftenv x (FT pt t))
    (p : PrmsTyping ftenv tenv (PS ls) pt),
  PrmsTrans3_def fenv D 0 ftenv tenv (PS ls) pt p ->
  ExpTrans3_def fenv D 0 ftenv tenv (Call x (PS ls)) t
    (Call_Typing ftenv tenv x ls pt t i p)).
  intros.
  generalize i.
  intro i2.
  unfold IdFTyping in i.
  unfold EnvrAssign in i.

  unfold ExpTrans3_def.
  intros.

  eapply ExtRelVal2 with (f:=funFTyp) (venv:=fenv) in i.
  destruct i as [f m d].
  Focus 2.
  assumption.

  generalize D.
  intro D1.
  unfold FEnvWT in D1.
  specialize (D1 ftenv H x f m).
  unfold FunWT in D1.

  destruct f.
  simpl in d.
  inversion d; subst.
  set (t:= projT1 v).

  intros.
  subst t.

  specialize (X ftenv tenv tenv0 x v e (projT1 v) eq_refl m
                ls (PT (map snd tenv0)) i2 p X0).
  eapply X.
  assumption.
  assumption.
  assumption.
  exact X2.
Defined.

Lemma Prms2ExpIH (fenv: funEnv) (D: FEnvWT fenv) (n : nat)
 (IHn : forall (ftenv : funTC) (tenv : valTC) (ps : Prms) (pt : PTyp),
        PrmsTyping ftenv tenv ps pt ->
        FEnvTyping fenv ftenv ->
        valTC_Trans tenv ->
        forall n1 : nat,
        n1 <= n -> W -> PTyp_TRN pt * W * {n2 : nat & n2 <= n1}) :
  forall (ftenv : funTC) (tenv : valTC) (e : Exp) (t : VTyp),
  ExpTyping ftenv tenv e t ->
  FEnvTyping fenv ftenv ->
  valTC_Trans tenv ->
  forall n1 : nat, n1 <= n -> W -> sVTyp t * W * {n2 : nat & n2 <= n1}.
Proof.
  intros.
  set (ps := PS [e]).
  set (pt := PT [t]).
  assert (PrmsTyping ftenv tenv  ps pt) as X4.
  constructor.
  assumption.
  constructor.
  specialize  (IHn ftenv tenv ps pt X4 H X0 n1 H0 X1).
  destruct IHn as [p1 c].
  destruct p1 as [sps w].
  simpl in sps.
  unfold PTyp_TRN in sps.
  simpl in sps.
  exact (fst sps, w, c).
Defined.

(*********************** main ****************************************)

Program Fixpoint ExpTransB (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
        (ftenv: funTC) (tenv: valTC) (e: Exp) (t: VTyp)
        (k: ExpTyping ftenv tenv e t) :
               FEnvTyping fenv ftenv ->
               valTC_Trans tenv ->
          forall (n1: nat), n1 <= n -> W ->
                      (sVTyp t * W) * sigT (fun n2 => n2 <= n1) := _
with PrmsTransB (fenv: funEnv) (D: FEnvWT fenv) (n: nat)
       (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp)
       (k: PrmsTyping ftenv tenv ps pt) :
              FEnvTyping fenv ftenv ->
              valTC_Trans tenv ->
          forall (n1: nat), n1 <= n -> W ->
                     (PTyp_TRN pt * W) * sigT (fun n2 => n2 <= n1) := _.
Next Obligation.
   intros fenv D n.
   induction n.
   eapply (Trans_ExpTyping_mut3 fenv D 0).
   - eapply (ExpTrans_Val fenv D 0).
   - eapply (ExpTrans_Var fenv D 0).
   - eapply (ExpTrans_BindN fenv D 0).
   - eapply (ExpTrans_BindS fenv D 0).
   - eapply (ExpTrans_BindMS fenv D 0).
   - eapply (ExpTrans_IfThenElse fenv D 0).
   - eapply (ExpTrans_Apply0 fenv D).
   - eapply (Convert_Trans_Call0 fenv D (ExpTrans_CallX0 fenv D)).
   - eapply (ExpTrans_Modify fenv D 0).
   - eapply (ExpTrans_PrmsNil fenv D 0).
   - eapply (ExpTrans_Prms fenv D 0).
   - eapply (Trans_ExpTyping_mut3 fenv D (S n)).
     * eapply (ExpTrans_Val fenv D (S n)).
     * eapply (ExpTrans_Var fenv D (S n)).
     * eapply (ExpTrans_BindN fenv D (S n)).
     * eapply (ExpTrans_BindS fenv D (S n)).
     * eapply (ExpTrans_BindMS fenv D (S n)).
     * eapply (ExpTrans_IfThenElse fenv D (S n)).
     * eapply (ExpTrans_ApplyE fenv D n).
       assumption.
     * eapply (Convert_Trans_Call fenv D n (ExpTrans_CallX fenv D n)).
       assumption.
     * eapply (ExpTrans_Modify fenv D (S n)).
     * eapply (ExpTrans_PrmsNil fenv D (S n)).
     * eapply (ExpTrans_Prms fenv D (S n)).
Defined.

Next Obligation.
   intros fenv D n.
   induction n.
   eapply (Trans_PrmsTyping_mut3 fenv D 0).
   - eapply (ExpTrans_Val fenv D 0).
   - eapply (ExpTrans_Var fenv D 0).
   - eapply (ExpTrans_BindN fenv D 0).
   - eapply (ExpTrans_BindS fenv D 0).
   - eapply (ExpTrans_BindMS fenv D 0).
   - eapply (ExpTrans_IfThenElse fenv D 0).
   - eapply (ExpTrans_Apply0 fenv D).
   - eapply (Convert_Trans_Call0 fenv D (ExpTrans_CallX0 fenv D)).
   - eapply (ExpTrans_Modify fenv D 0).
   - eapply (ExpTrans_PrmsNil fenv D 0).
   - eapply (ExpTrans_Prms fenv D 0).
   - eapply (Trans_PrmsTyping_mut3 fenv D (S n)).
     * eapply (ExpTrans_Val fenv D (S n)).
     * eapply (ExpTrans_Var fenv D (S n)).
     * eapply (ExpTrans_BindN fenv D (S n)).
     * eapply (ExpTrans_BindS fenv D (S n)).
     * eapply (ExpTrans_BindMS fenv D (S n)).
     * eapply (ExpTrans_IfThenElse fenv D (S n)).
     * eapply (ExpTrans_ApplyE fenv D n).
       eapply (Prms2ExpIH fenv D).
       assumption.
     * eapply (Convert_Trans_Call fenv D n (ExpTrans_CallX fenv D n)).
       eapply (Prms2ExpIH fenv D).
       assumption.
     * eapply (ExpTrans_Modify fenv D (S n)).
     * eapply (ExpTrans_PrmsNil fenv D (S n)).
     * eapply (ExpTrans_Prms fenv D (S n)).
Defined.

Lemma ExpTransA (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv: funTC) (tenv: valTC) (e: Exp) (t: VTyp)
        (k: ExpTyping ftenv tenv e t),
               FEnvTyping fenv ftenv ->
               valTC_Trans tenv ->
          forall (n1: nat), n1 <= n -> W ->
                      (sVTyp t * W) * sigT (fun n2 => n2 <= n1).
Proof.
   induction n.
   eapply (Trans_ExpTyping_mut3 fenv D 0).
   - eapply (ExpTrans_Val fenv D 0).
   - eapply (ExpTrans_Var fenv D 0).
   - eapply (ExpTrans_BindN fenv D 0).
   - eapply (ExpTrans_BindS fenv D 0).
   - eapply (ExpTrans_BindMS fenv D 0).
   - eapply (ExpTrans_IfThenElse fenv D 0).
   - eapply (ExpTrans_Apply0 fenv D).
   - eapply (Convert_Trans_Call0 fenv D (ExpTrans_CallX0 fenv D)).
   - eapply (ExpTrans_Modify fenv D 0).
   - eapply (ExpTrans_PrmsNil fenv D 0).
   - eapply (ExpTrans_Prms fenv D 0).
   - eapply (Trans_ExpTyping_mut3 fenv D (S n)).
     * eapply (ExpTrans_Val fenv D (S n)).
     * eapply (ExpTrans_Var fenv D (S n)).
     * eapply (ExpTrans_BindN fenv D (S n)).
     * eapply (ExpTrans_BindS fenv D (S n)).
     * eapply (ExpTrans_BindMS fenv D (S n)).
     * eapply (ExpTrans_IfThenElse fenv D (S n)).
     * eapply (ExpTrans_ApplyE fenv D n).
       assumption.
     * eapply (Convert_Trans_Call fenv D n (ExpTrans_CallX fenv D n)).
       assumption.
     * eapply (ExpTrans_Modify fenv D (S n)).
     * eapply (ExpTrans_PrmsNil fenv D (S n)).
     * eapply (ExpTrans_Prms fenv D (S n)).
Defined.

Lemma PrmsTransA (fenv: funEnv) (D: FEnvWT fenv) (n: nat) :
  forall (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp)
       (k: PrmsTyping ftenv tenv ps pt),
              FEnvTyping fenv ftenv ->
              valTC_Trans tenv ->
          forall (n1: nat), n1 <= n -> W ->
                     (PTyp_TRN pt * W) * sigT (fun n2 => n2 <= n1).
   induction n.
   eapply (Trans_PrmsTyping_mut3 fenv D 0).
   - eapply (ExpTrans_Val fenv D 0).
   - eapply (ExpTrans_Var fenv D 0).
   - eapply (ExpTrans_BindN fenv D 0).
   - eapply (ExpTrans_BindS fenv D 0).
   - eapply (ExpTrans_BindMS fenv D 0).
   - eapply (ExpTrans_IfThenElse fenv D 0).
   - eapply (ExpTrans_Apply0 fenv D).
   - eapply (Convert_Trans_Call0 fenv D (ExpTrans_CallX0 fenv D)).
   - eapply (ExpTrans_Modify fenv D 0).
   - eapply (ExpTrans_PrmsNil fenv D 0).
   - eapply (ExpTrans_Prms fenv D 0).
   - eapply (Trans_PrmsTyping_mut3 fenv D (S n)).
     * eapply (ExpTrans_Val fenv D (S n)).
     * eapply (ExpTrans_Var fenv D (S n)).
     * eapply (ExpTrans_BindN fenv D (S n)).
     * eapply (ExpTrans_BindS fenv D (S n)).
     * eapply (ExpTrans_BindMS fenv D (S n)).
     * eapply (ExpTrans_IfThenElse fenv D (S n)).
     * eapply (ExpTrans_ApplyE fenv D n).
       eapply (Prms2ExpIH fenv D).
       assumption.
     * eapply (Convert_Trans_Call fenv D n (ExpTrans_CallX fenv D n)).
       eapply (Prms2ExpIH fenv D).
       assumption.
     * eapply (ExpTrans_Modify fenv D (S n)).
     * eapply (ExpTrans_PrmsNil fenv D (S n)).
     * eapply (ExpTrans_Prms fenv D (S n)).
Defined.

End Reflect.


From hahn Require Import Hahn.
Require Import PromisingLib.

From imm Require Import Events Execution.
From imm Require Import ProgToExecution.
From imm Require Import ProgToExecutionProperties.
Require Import PromiseLTS.

Set Implicit Arguments.

Inductive sim_mode := sim_normal | sim_certification.

Definition sim_state_helper G smode thread
           (state state' : Language.state (thread_lts thread)) : Prop :=
  ⟪ STEPS : (step thread)＊ state state' ⟫ /\
  ⟪ TERMINAL : smode = sim_normal -> is_terminal state' ⟫ /\
  ⟪ TEH  : thread_restricted_execution G thread state'.(ProgToExecution.G) ⟫.

Definition sim_state G smode (C : actid -> Prop) thread
           (state : Language.state (thread_lts thread)) : Prop :=
  ⟪ PCOV : forall index , C (ThreadEvent thread index) <-> index < state.(eindex)⟫ /\
  exists state', sim_state_helper G smode state state'.

Lemma sim_state_other_thread_step G
      (C C' : actid -> Prop) smode thread (state : Language.state (thread_lts thread))
      (CINCL : C ⊆₁ C')
      (COVSTEP : forall a, tid a = thread -> C' a -> C a)
      (SIMSTATE: sim_state G smode C state) :
  sim_state G smode C' state.
Proof using.
  cdes SIMSTATE.
  red. splits; eauto.
  ins. split; ins.
  { apply PCOV. apply COVSTEP; eauto. }
  apply CINCL. by apply PCOV.
Qed.

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Lemma sim_state_set_tid_eq G mode thread s s' state
      (EQ : s ∩₁ Tid_ thread ≡₁ s' ∩₁ Tid_ thread):
  @sim_state G mode s thread state <->
  @sim_state G mode s' thread state.
Proof using.
  split; intros AA.
  all: red; splits; [|by apply AA].
  all: ins; split; intros BB.
  1,3: by apply AA; apply EQ.
  all: by apply EQ; split; auto; apply AA.
Qed.

Lemma sim_state_set_eq G mode thread s s' state
      (EQ : s ≡₁ s'):
  @sim_state G mode s thread state <->
  @sim_state G mode s' thread state.
Proof using. apply sim_state_set_tid_eq. by rewrite EQ. Qed.


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

(** Recognition of combined operations, addressing modes and conditions
  during the [CSE] phase. *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import CombineOp.
Require Import CSE.

Section COMBINE.

Variable ge: genv.
Variable sp: val.
Variable m: mem.
Variable get: valnum -> option rhs.
Variable valu: valnum -> val.
Hypothesis get_sound: forall v rhs, get v = Some rhs -> equation_holds valu ge sp m v rhs.

Lemma combine_compimm_ne_0_sound:
  forall x cond args,
  combine_compimm_ne_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_eq_0_sound:
  forall x cond args,
  combine_compimm_eq_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_eq_1_sound:
  forall x cond args,
  combine_compimm_eq_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_ne_1_sound:
  forall x cond args,
  combine_compimm_ne_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  exploit get_sound; eauto. unfold equation_holds. simpl. intro EQ; inv EQ.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Theorem combine_cond_sound:
  forall cond args cond' args',
  combine_cond get cond args = Some(cond', args') ->
  eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m.
Proof.
  intros. functional inversion H; subst.
  (* compimm ne zero *)
  simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compimm ne one *)
  simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compimm eq zero *)
  simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compimm eq one *)
  simpl; eapply combine_compimm_eq_1_sound; eauto.
  (* compuimm ne zero *)
  simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compuimm ne one *)
  simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compuimm eq zero *)
  simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compuimm eq one *)
  simpl; eapply combine_compimm_eq_1_sound; eauto.
Qed.

Theorem combine_addr_sound:
  forall addr args addr' args',
  combine_addr get addr args = Some(addr', args') ->
  eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
Proof.
  intros. functional inversion H; subst.
  (* indexed - addimm *)
  exploit get_sound; eauto. unfold equation_holds; simpl; intro EQ. FuncInv.
  rewrite <- H0. rewrite Val.add_assoc. auto.
Qed.

Theorem combine_op_sound:
  forall op args op' args',
  combine_op get op args = Some(op', args') ->
  eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
Proof.
  intros. functional inversion H; subst.
(* addimm - addimm *)
  exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
  rewrite <- H1. rewrite Val.add_assoc. auto.
(* addimm - subimm *)
Opaque Val.sub.
  exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
  rewrite <- H1. change (Vint (Int.add m0 n)) with (Val.add (Vint m0) (Vint n)).
  rewrite Val.sub_add_l. auto.
(* subimm - addimm *)
  exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
  rewrite <- H1.
Transparent Val.sub.
  destruct v; simpl; auto. repeat rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  rewrite Int.neg_add_distr. decEq. decEq. decEq. apply Int.add_commut.
(* andimm - andimm *)
  exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
  rewrite <- H1. rewrite Val.and_assoc. auto.
(* orimm - orimm *)
  exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
  rewrite <- H1. rewrite Val.or_assoc. auto.
(* xorimm - xorimm *)
  exploit get_sound; eauto. unfold equation_holds; simpl; intros. FuncInv.
  rewrite <- H1. rewrite Val.xor_assoc. auto.
(* cmp *)
  simpl. decEq; decEq. eapply combine_cond_sound; eauto.
Qed.

End COMBINE.


(* En este archivo se demuestra que la ejecución de
*  la acción revokeDel preserva los invariantes del sistema *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import MyList.
Require Import ListAuxFuns.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.
Require Import Semantica.

Section RevokeDelInv.

Lemma RevokeDelIsInvariant : forall (s s':System) (sValid:validstate s) (ic:iCmp) (cp:CProvider) (u:uri) (pt:PType) , pre_revokeDel ic cp u pt s -> post_revokeDel ic cp u pt s s' -> validstate s'.
Proof.
    intros.
    unfold validstate.
    unfold pre_revokeDel in H.
    unfold post_revokeDel in H0.
    destruct H0 as [verifeid H0].
    destruct_conj H0.

    unfold allCmpDifferent.
    split.
    intros.

    apply (inAppS'InAppS a1 s) in H14;auto.
    apply (inAppS'InAppS a2 s) in H16;auto.
    apply (inAppSameCmpId s sValid c1 c2 a1 a2);auto.

    unfold notRepeatedCmps.
    split.
    intros.
    apply (inAppS'InAppS a1 s) in H14;auto.
    apply (inAppS'InAppS a2 s) in H16;auto.
    apply (inAppSameCmp s sValid c a1 a2);auto.

    unfold notCPrunning.
    split.
    rewrite <-H12.
    destructVS sValid.
    auto.

    split.
    unfold delTmpRun.
    intros.
    specialize (H1 ic0 cp0 u0 pt0 H14).
    destruct H1.
    destruct H1.
    destructVS sValid.
    destruct (delTmpRunVS ic0 cp0 u0 x);auto.
    split.
    destruct H17.
    exists x0.
    apply (inAppS'InAppS x0 s);auto.
    destruct H18.
    destruct H18.
    destruct H18.
    exists x0,x1.
    split.
    apply (inAppS'InAppS x1 s);auto.
    rewrite<-H12;auto.

    split.
    apply (cmpRunAppInsS' s);auto.

    split.
    apply (resContAppInstS' s);auto.

    split.
    apply (consistencyUnchanged s);auto.

    unfold notDupApp.
    split.
    rewrite <- H8.
    rewrite<-H9.
    destructVS sValid.
    auto.

    unfold notDupSysApp.
    split.
    rewrite <-H8.
    destructVS sValid.
    auto.

    split.
    apply (notDupPermS' s);auto.

    unfold allMapsCorrect.
    split.
    rewrite <-H8, <-H10, <-H11, <- H12, <-H13.
    repeat (split;auto; try mapcorrect sValid).

    split.
    apply (grantedPermsExistS' s);auto.

    unfold noDupSentIntents.
    rewrite<- H15.
    destructVS sValid.
    auto.
Qed.

End RevokeDelInv.