Require Import List.
Require Export Util Get Drop Var Val Isa.Ops IL.Exp
        Envs Map CSet AutoIndTac MoreList OptionMap.
Require Export IL.Events SizeInduction SmallStepRelations StateType.
Require Import SetOperations While IL.
Require Import Sim SimTactics SimI Infra.Status Position ILN Sawtooth Program.Tactics.

Program Fixpoint whileToILI (s:list statement) (cont:nat) {measure (size s)} : stmt :=
  match s with
  | WhileLet x e::p =>
    stmtLet x e (whileToILI p cont)
  | WhileCond e s t::p =>
    stmtFun ((nil, whileToILI p (S cont))::nil)
            (stmtIf e (whileToILI s 0) (whileToILI t 0))
  | WhileWhile e s::p =>
    stmtFun ((nil, (stmtIf e
                           (whileToILI s 0)
                           (whileToILI p (S cont))))::nil)
            (stmtApp (LabI 0) nil)
  | WhileReturn e::p => stmtReturn e
  | nil => stmtApp (LabI cont) nil
  end.

Require Import Program.Equality Program.Wf.

Lemma whileToILI_nil cont
  :  whileToILI nil cont = stmtApp (LabI cont) nil.
Proof.
  unfold whileToILI at 1. unfold whileToILI_func.
  WfExtensionality.unfold_sub whileToILI (whileToILI nil cont).
  reflexivity.
Qed.

Lemma whileToILI_let x e p cont
  :  whileToILI (WhileLet x e::p) cont = stmtLet x e (whileToILI p cont).
Proof.
  unfold whileToILI at 1. unfold whileToILI_func.
  WfExtensionality.unfold_sub whileToILI (whileToILI (WhileLet x e::p) cont).
  reflexivity.
Qed.

Lemma whileToILI_return e p cont
  :  whileToILI (WhileReturn e::p) cont = stmtReturn e.
Proof.
  unfold whileToILI at 1. unfold whileToILI_func.
  WfExtensionality.unfold_sub whileToILI (whileToILI (WhileReturn e::p) cont).
  reflexivity.
Qed.

Lemma whileToILI_cond e s t p cont
  :  whileToILI (WhileCond e s t :: p) cont
     = stmtFun ((nil, whileToILI p (S cont))::nil)
               (stmtIf e (whileToILI s 0) (whileToILI t 0)).
Proof.
  unfold whileToILI at 1. unfold whileToILI_func.
  WfExtensionality.unfold_sub whileToILI (whileToILI (WhileCond e s t :: p) cont).
  reflexivity.
Qed.

Lemma whileToILI_while e s p cont
  :  whileToILI (WhileWhile e s:: p) cont
     =  stmtFun ((nil, (stmtIf e
                           (whileToILI s 0)
                           (whileToILI p (S cont))))::nil)
                (stmtApp (LabI 0) nil).
Proof.
  unfold whileToILI at 1. unfold whileToILI_func.
  WfExtensionality.unfold_sub whileToILI (whileToILI (WhileWhile e s::p) cont).
   reflexivity.
Qed.

Ltac single_step_while :=
  match goal with
  | [ H : val2bool _ = false |- @StateType.step _ statetype_While _ _ _ ] =>
    econstructor 4; try eassumption; try reflexivity
  | [ H : val2bool _ = true |- @StateType.step _ statetype_While _ _ _ ] =>
    econstructor 3; try eassumption; try reflexivity
  | [ H : val2bool _ = false |- @StateType.step _ statetype_While _ _ _ ] =>
    econstructor 5; try eassumption; try reflexivity
  | [ H : val2bool _ = true |- @StateType.step _ statetype_While _ _ _ ] =>
    econstructor 6; try eassumption; try reflexivity
  | [ |- @StateType.step _ statetype_While _ _ _ ] =>
    econstructor; eauto
  end.

Smpl Add single_step_while : single_step.

Lemma whileToILI_correct_while r (L:list IL.I.block) E e s p (t:stmt)
      (IH:forall q (L:IL.I.labenv) E r,
          (exists v, op_eval E e = Some v /\ val2bool v = true) ->
          sawtooth L ->
          (forall E, sim r Bisim
                      (E, q) (L, E, stmtApp (LabI 0) nil))
          -> sim r Bisim (E, s ++ q) (L, E, whileToILI s 0))
      (SM:sawtooth L)
      v (EV:op_eval E e = Some v)
      (TR:val2bool v = true)
      (CONT:forall E0,
          sim r Bisim
                   (E0, p) (IL.I.mkBlock 0 (nil, stmtIf e (whileToILI s 0) t) :: L, E0, t))
  :  sim r Bisim (E, s ++ WhileWhile e s :: p)
         (IL.I.mkBlock 0 (nil, stmtIf e (whileToILI s 0) t) :: L, E,
          whileToILI s 0).
Proof.
  revert_all. pcofix CIH. intros.
  eapply (IH (WhileWhile e s :: p)); eauto.
  - intros.
    eapply (sawtooth_I_mkBlocks ((nil, stmtIf e (whileToILI s 0) t)::nil)); eauto.
  - intros. dcr.
    + case_eq (op_eval E0 e); intros.
      * case_eq (val2bool v0); intros.
        -- pone_step_right.
           pone_step.
           right. eapply CIH; eauto.
        -- pone_step_right.
           pone_step.
           left. eapply paco3_mon. eapply CONT. eauto.
      * pone_step_right.
        pno_step.
Qed.

Lemma whileToILI_correct r (L:IL.I.labenv) E p q cont
      (SM:sawtooth L)
  :  (forall E, sim r Bisim
               (E, q) (L, E, stmtApp (LabI cont) nil))
    -> sim r Bisim (E, p ++ q) (L, E, whileToILI p cont).
Proof.
  revert_except p.
  sind p; destruct p; simpl; intros.
  { rewrite whileToILI_nil. simpl. eauto. }
  destruct s; simpl.
  - rewrite whileToILI_cond.
    pone_step_right.
    case_eq (op_eval E e); intros.
    + case_eq (val2bool v); intros.
      * pone_step.
        left. eapply IH; eauto; intros.
        pone_step_right.
        eapply IH; eauto. eapply sawtooth_I_mkBlocks; eauto.
        intros.
        eapply stmtApp_sim_tl; eauto.
        eapply sawtooth_smaller; eauto.
      * pone_step.
        left. eapply IH; eauto. intros.
        pone_step_right.
        eapply IH; eauto. eapply sawtooth_I_mkBlocks; eauto.
        intros.
        eapply stmtApp_sim_tl; eauto.
        eapply sawtooth_smaller; eauto.
    + clear IH.
      pno_step.
  - rewrite whileToILI_while.
    pone_step_right.
    + case_eq (op_eval E e); intros.
      * case_eq (val2bool v); intros.
        -- pone_step_right.
           pone_step. simpl.
           left.
           eapply whileToILI_correct_while; eauto.
           ++ intros. eapply IH; eauto.
             eapply (sawtooth_I_mkBlocks ((nil, stmtIf e (whileToILI s 0) _)::nil)); eauto.
             intros.
             eapply stmtApp_sim_tl; eauto.
             eapply sawtooth_smaller; eauto.
        -- intros.
           pone_step_right.
           pone_step.
           left. eapply IH; eauto.
           eapply (sawtooth_I_mkBlocks ((nil, stmtIf e (whileToILI s 0) _)::nil)); eauto.
           intros. eapply stmtApp_sim_tl; eauto.
           eapply sawtooth_smaller; eauto.
      * pone_step_right. simpl.
        pno_step.
  - rewrite whileToILI_let.
    destruct e.
    + case_eq (op_eval E e); intros.
      * pone_step.
        left. eapply IH; eauto.
      * pno_step.
    + case_eq (omap (op_eval E) Y); intros.
      * pextern_step.
        -- econstructor; eauto. eexists. single_step.
        -- left. eapply IH; eauto.
        -- assert (l = vl) by congruence; subst.
           left. eapply IH; eauto.
      * pno_step.
  - rewrite whileToILI_return.
    pno_step.
    Grab Existential Variables.
    eapply default_val.
Qed.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Preservation.

Lemma canonical_form_abs : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_arrow U1 U2) ->
  exists V, exists e1, e = exp_abs V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;try solve [inversion H|inversion H1|inversion H2]...
  -
    exists V.
    exists e1...
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_tabs : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_all U1 U2) ->
  exists V, exists e1, e = exp_tabs V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;try solve [inversion H|inversion H1|inversion H2]...
  -
    exists V.
    exists e1...
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_fold : forall e U S,
  value e ->
  typing empty e S ->
  sub empty S (typ_mu U) ->
  exists V, exists e1, (sub empty (typ_mu V) (typ_mu U) /\ value e1 /\ e = exp_fold (typ_mu V) e1).
Proof with auto.
  intros.
  generalize dependent U.
  dependent induction H0;intros;try solve [inversion H|inversion H1|inversion H2]...
  -
    dependent destruction H.
    exists A...
    exists e...
  -
    apply IHtyping with (U:=U)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma value_expr: forall e,
    value e -> expr e.
Proof with auto.
  intros.
  induction H...
Qed.

Lemma progress : forall e T,
  typing empty e T ->
  value e \/ exists e', step e e'.
Proof with eauto.
  intros.
  dependent induction H...
  -
    inversion H0...
  - (* abs *)
    left.
    constructor.
    apply expr_abs with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* app *)
    right.
    destruct IHtyping1;destruct IHtyping2...
    +
      apply canonical_form_abs with (S:=typ_arrow T1 T2) (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_ee x0 e2).
      subst.
      apply step_beta...
      apply value_expr...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_app e1 x).
      apply step_app2...
    +
      destruct_hypos.
      exists (exp_app x e2).
      apply step_app1...
      apply value_expr...
    +
      destruct_hypos.
      exists (exp_app x0 e2).
      apply step_app1...
      apply typing_regular in H0.
      destruct_hypos...
  - (* tabs *)
    left.
    constructor.
    apply expr_tabs with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* tapp *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_tabs with (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_te x0 T).
      subst.
      apply step_tabs...
      apply value_expr...
      get_type...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_tapp x T).
      apply step_tapp...
      get_type...
  - (* fold *)
    assert (empty ~= empty) by auto.
    apply IHtyping in H1.
    destruct H1.
    left.
    constructor...
    apply WF_type in H0...
    right.
    destruct H1.
    exists (exp_fold (typ_mu A) x).
    constructor...
    apply typing_regular in H.
    destruct H.
    destruct H2.
    apply WF_type in H0...
  - (* unfold *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_fold with (S:=typ_mu T) (U:=T) in H0...
      destruct_hypos.
      exists x0...
      rewrite H2.
      get_well_form...
      apply step_fld...
      apply WF_type in H3...
      apply WF_type in H4...
      apply Reflexivity...
      apply typing_regular in H...
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_unfold (typ_mu T) x).
      apply step_unfold...
      apply typing_regular in H...
      destruct_hypos.
      apply WF_type in H2...
Qed.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From QuickChick Require Import QuickChick.
Require Import Arith.

Require Import Foo.

(*! Section prop_plus_one_again *)(*! extends plus_one *)
Definition prop_plus_one_again x :=
  whenFail (show (x, plus_one x)) (x <? plus_one x).

(*! QuickChick prop_plus_one_again. *)


(* * Kripke Semantics *)

From Undecidability Require Import FOL.Semantics.Tarski.FragmentFacts.
From Undecidability Require Import FOL.Semantics.Kripke.FragmentCore.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.

Set Default Proof Using "Type".

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Notation vec := Vector.t.

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

(* ** Connection to Tarski Semantics *)

Section ToTarski.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Program Instance interp_kripke {domain} (I : interp domain) : kmodel domain :=
    {| nodes := unit ; reachable u v := True |}.
  Next Obligation.
    - now apply I in X.
  Defined.

  Lemma kripke_tarski {ff : falsity_flag} domain (I : interp domain) rho phi :
    rho ⊨ phi <-> ksat (interp_kripke I) tt rho phi.
  Proof.
    revert rho. induction phi; intros rho.
    - tauto.
    - tauto.
    - destruct b0. cbn. rewrite IHphi1, IHphi2. intuition. destruct v. tauto.
    - destruct q. cbn. split; intros H; cbn in *.
      + intros i. apply IHphi, H.
      + intros i. apply IHphi, H.
  Qed.

  Lemma kvalid_valid b (phi : form b) :
    kvalid phi -> valid phi.
  Proof.
    intros H domain I rho. apply kripke_tarski, H.
  Qed.

  Lemma ksatis_satis b (phi : form b) :
    satis phi -> ksatis phi.
  Proof.
    intros (domain & I & rho & ?). eapply kripke_tarski in H.
    now exists domain, (interp_kripke I), tt, rho.
  Qed.

End ToTarski.


From Undecidability.L Require Export Util.L_facts Tactics.Extract.
Require Import Undecidability.Shared.Libs.PSL.Bijection String.

(* * Correctness and time bounds *)

(* Typeclass for registering types *)

Class registered (X : Type) := mk_registered
  {
    enc :> encodable X ; (* the encoding function for X *)
    proc_enc : forall x, proc (enc x) ; (* encodings need to be a procedure *)
    inj_enc : injective enc (* encoding is injective *)
  }.

#[export] Hint Mode registered + : typeclass_instances. (* treat argument as input and force evar-freeness*)

Arguments enc : simpl never.  (* Never unfold with cbn/simpl *)

(* ** Correctness *)

(* Definition of the valid types for extraction *)

Inductive TT : Type -> Type :=
  TyB t (R : registered t) : TT t
| TyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2)
  : TT (t1 -> t2).

Existing Class TT.
Existing Instance TyB.
Existing Instance TyArr.

Arguments TyB _ {_}.
Arguments TyArr {_} {_} _ _.

#[export] Hint Mode TT + : typeclass_instances. (* treat argument as input and force evar-freeness*)

Notation "! X" := (TyB X) (at level 69).
Notation "X ~> Y" := (TyArr X Y) (right associativity, at level 70).

Fixpoint computes {A} (tau : TT A) {struct tau}: A -> L.term -> Type :=
  match tau with
    !_ => fun x xInt => (xInt = enc x)
  | @TyArr A B tau1 tau2 =>
    fun f t_f  =>
      proc t_f * forall (a : A) t_a,
        computes tau1 a t_a
        ->  {v : term & (app t_f t_a >* v) * computes tau2 (f a) v}
  end%type.

Lemma computesProc t (ty : TT t) (f : t) fInt:
  computes ty f fInt -> proc fInt.
Proof.
  destruct ty.
  -intros ->. unfold enc. now destruct R.
  -now intros [? _].
Qed.

(* This is for a user to give an definition *)
Class computable X {ty : TT X} (x : X) : Type :=
  {
    ext : extracted x;
    extCorrect : computes ty x ext;
  }.

Global Arguments computable {X} {ty} x.
Global Arguments extCorrect {X} ty x {computable} : simpl never.
Global Arguments ext {X} {ty} x {computable} : simpl never.

#[export] Hint Mode computable + - +: typeclass_instances. (* treat argument as input and force evar-freeness*)
#[export] Hint Extern 4 (@extracted ?t ?f) => let ty := constr:(_ : TT t) in notypeclasses refine (ext (ty:=ty) f) : typeclass_instances.

Typeclasses Opaque ext.

Lemma proc_ext X (ty : TT X) (x : X) ( H : computable x) : proc (ext x).
Proof.
  unfold ext. destruct H. apply (computesProc extCorrect0).
Qed.

Instance reg_is_ext ty (R : registered ty) (x : ty) : computable x.
Proof.
  exists (enc x). reflexivity.
Defined. (* because ? *)

Lemma computesTyB (t:Type) (x:t) `{registered t}: computes (TyB t) x (ext x).
Proof.
  unfold ext. now destruct R.
Qed.

Instance extApp' t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) : computable (f x).
Proof.
  destruct Hf, Hx.
  edestruct extCorrect0 as [? H].
  edestruct H as (?&?&?).
  eassumption.
  now eapply (@Build_computable _ _ _ x0).
Defined. (* because ? *)

Lemma extApp t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) :
  app (ext f) (ext x) >* ext (f x).
Proof.
  unfold ext, extApp'.
  destruct Hf, Hx.
  destruct extCorrect0 as (? & correct0).
  destruct correct0 as (?&?&?). tauto.
Qed.

Lemma ext_is_enc t1 (R:registered t1) (x: t1) (Hf : computable x) :
  @ext _ _ x Hf = enc x.
Proof.
  now destruct Hf.
Defined. (* because ? *)

Definition computesExp {t} (ty : TT t) (f:t) (s fExt : term) : Type :=
  eval s fExt * computes ty f fExt.

Lemma computesExpStart t1 (tt1 : TT t1) (f : t1) (fExt : term):
  proc fExt ->
  {v :term & computesExp tt1 f fExt v} ->  computes tt1 f fExt.
Proof.
  intros ? (?&?&?). replace fExt with x. tauto. apply unique_normal_forms. eapply e. eapply H. destruct e as [e ?]. now rewrite e.
Qed.

Lemma computesExpStep t1 t2 (tt1 : TT t1) (tt2 : TT t2) (f : t1 -> t2) (s:term) (fExt : term):
  eval s fExt -> closed s ->
  (forall (y : t1) (yExt : term), computes tt1 y yExt -> {v : term & computesExp tt2 (f y) (app s yExt) v}%type) ->
  computesExp (tt1 ~> tt2) f s fExt.
Proof.
  intros ? ? H. split. assumption. split. split. now rewrite <-H0. now destruct H0.
  intros ? ? exted.
  edestruct H as (v&?&?). eassumption.
  eexists v. split. rewrite H0 in e. now rewrite e. eauto.
Qed.

Lemma computesTyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2) f fExt :
  proc fExt
  -> (forall (y : t1) (yExt : term),
        computes tt1 y yExt
        -> {v : term & eval (app fExt yExt) v * (proc v -> computes tt2 (f y) v)}%type)
  -> computes (tt1 ~> tt2) f fExt.
Proof.
  intros ? H'.
  split;[assumption|].
  intros y yExt yCorrect.
  edestruct H' as (?&(R&?) & H''). eassumption.
  eexists. split.
  eassumption.
  eapply H''.
  split. 2:assumption.
  rewrite <- R. apply app_closed. now destruct H. specialize (computesProc yCorrect) as []. easy.
Qed.

(* Extensional equality to extract similar functions without unsopported features (e.g. informative deciders) instead *)

Fixpoint extEq t {tt:TT t} : t -> t -> Prop:=
  match tt with
    TyB _ _ => eq
  | @TyArr t1 t2 _ _ => fun f f' => forall (x : t1), extEq (f x) (f' x)
  end.

Instance extEq_refl t (tt:TT t): Reflexive (extEq (tt:=tt)).
Proof.
  unfold Reflexive.
  induction tt;cbn.
  -reflexivity.
  -intros f x. eauto.
Qed.

Lemma computesExt X (tt : TT X) (x x' : X) s:
  extEq x x' -> computes tt x s -> computes tt x' s.
Proof.
  induction tt in x,x',s |-*;intros eq.
  -inv eq. tauto.
  -cbn in eq|-*. intros [H1 H2]. split. 1:tauto.
   intros y t exts.
   specialize (H2 y t exts) as (v&R&H2).
   exists v. split. 1:assumption.
   eapply IHtt2. 2:now eassumption.
   apply eq.
Qed.

Lemma computableExt X (tt : TT X) (x x' : X):
  extEq x x' -> computable x -> computable x'.
Proof.
  intros ? (s&?). exists s. eauto using computesExt.
Defined. (* because ? *)

(* register a datatype via an (injectve) function to another, e.g. vectors as lists *)

Lemma registerAs X Y `{registered X} (f:Y -> X) : injective f -> registered Y.
Proof.
  intros Hf. eexists (fun x => enc (f x)). now destruct H.
  intros ? ? ?. now eapply H, Hf in H0.
Defined. (* because ? *)
Arguments registerAs {_ _ _} _ _.

(* Support for extracting registerAs-ed functions *)

Fixpoint changeResType t1 t2 (tt1:TT t1) (tt2 : TT t2) : {t & TT t}:=
  match tt1 with
    TyB _ _ => existT _ t2 tt2
  | TyArr _ _ tt11 tt12 =>
    existT _ _ (TyArr tt11 (projT2 (changeResType tt12 tt2)))
  end.

Fixpoint resType t1 (tt1 : TT t1) : {t & registered t} :=
  match tt1 with
    @TyB _ R => existT _ _ R
  | TyArr _ _ _ t2 => resType t2
  end.

Fixpoint insertCast t1 (tt1 : TT t1) Y (R: registered Y) {struct tt1}:
  forall (cast : projT1 (resType tt1) -> Y) (f : t1), projT1 (changeResType tt1 (TyB Y)) :=
  match tt1 with
    TyB _ _ => fun cast x => cast x
  | TyArr _ _ tt11 tt12 => fun cast f x=> (insertCast (tt1:=tt12) R cast (f x))
  end.

Lemma cast_registeredAs t1 (tt1 : TT t1) Y (R: registered Y) (cast : projT1 (resType tt1) -> Y) (f:t1)
  (Hc : injective cast) :
  projT2 (resType tt1) = registerAs cast Hc ->
  computable (ty:=projT2 (changeResType tt1 (TyB Y))) (insertCast R cast f) ->
  computable f.
Proof.
  intros H (s&exts).
  exists s.
  induction tt1 in cast,f,H,s,exts,Hc |- *.
  -cbn in H,exts|-*;unfold enc in *. rewrite H. exact exts.
  -destruct exts as (?&exts). split. assumption.
   intros x s__x ext__x.
   specialize (exts x s__x ext__x) as (v &?&exts).
   exists v. split. tauto.
   eapply IHtt1_2. all:eassumption.
Qed.

Opaque computes.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon BBUle.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

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

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

Definition bit_blast_uge g ls1 ls2 : generator * cnf * literal :=
  bit_blast_ule g ls2 ls1.

Definition mk_env_uge E g ls1 ls2 : env * generator * cnf * literal :=
  mk_env_ule E g ls2 ls1.

Lemma bit_blast_uge_correct g bs1 bs2 E ls1 ls2 g' cs lr :
  bit_blast_uge g ls1 ls2 = (g', cs, lr) ->
  size ls1 = size ls2 ->
  enc_bits E ls1 bs1 ->
  enc_bits E ls2 bs2 ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (geB bs1 bs2).
Proof.
  rewrite /geB.
  rewrite /bit_blast_uge.
  move => Hule Hsz Henc1 Henc2 Hcnf.
  symmetry in Hsz.
  exact : (bit_blast_ule_correct Hule Hsz Henc2 Henc1 Hcnf) => Hrule.
Qed.

Lemma mk_env_uge_is_bit_blast_uge E g ls1 ls2 E' g' cs lr:
    mk_env_uge E g ls1 ls2 = (E', g', cs, lr) ->
    bit_blast_uge g ls1 ls2 = (g', cs, lr).
Proof.
  rewrite /mk_env_uge /bit_blast_uge.
  exact: mk_env_ule_is_bit_blast_ule.
Qed.

Lemma mk_env_uge_newer_gen E g ls1 ls2 E' g' cs lr:
    mk_env_uge E g ls1 ls2 = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  rewrite /mk_env_uge.
  exact: mk_env_ule_newer_gen.
Qed.

Lemma mk_env_uge_newer_res E g ls1 ls2 E' g' cs lr:
    mk_env_uge E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g' lr.
Proof.
  rewrite /mk_env_uge. move=> H.
  exact: (mk_env_ule_newer_res H).
Qed.

Lemma mk_env_uge_newer_cnf E g ls1 ls2 E' g' cs lr:
    mk_env_uge E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 -> newer_than_lits g ls2 ->
    newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_uge.
  move=> H e0 e1 e2.
  exact: (mk_env_ule_newer_cnf H e0 e2 e1).
Qed.

Lemma mk_env_uge_preserve E g ls1 ls2 E' g' cs lr:
    mk_env_uge E g ls1 ls2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_uge.
  exact: mk_env_ule_preserve.
Qed.

Lemma mk_env_uge_sat E g ls1 ls2 E' g' cs lr:
    mk_env_uge E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 -> newer_than_lits g ls2 ->
    interp_cnf E' cs.
Proof.
  rewrite /mk_env_uge.
  move=> H e0 e1 e2.
  exact: (mk_env_ule_sat H e0 e2 e1).
Qed.

Lemma mk_env_uge_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_uge E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_uge E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof. exact: mk_env_ule_env_equal. Qed.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

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

(**********************************************************************)
(*                           Marks.v                                  *)
(*                                                                    *)
(* adapted from Marks.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Test.
Require Import Lambda.General.
Require Import Lambda.Terms.
Require Import Lambda.Redexes.
Require Import Lambda.Residuals.

(* Translation from terms to redexes *)

Fixpoint mark (e : lambda) : redexes :=
  match e with
  | Ref i => Var i
  | App M N => Ap false (mark M) (mark N)
  | Abs M => Fun (mark M)
  end.

(* Reverse translation : erasing the marks *)

Fixpoint unmark (e : redexes) : lambda :=
  match e with
  | Var i => Ref i
  | Ap b U V => App (unmark U) (unmark V)
  | Fun U => Abs (unmark U)
  end.

Lemma inverse : forall M : lambda, M = unmark (mark M).
Proof.
simple induction M; simpl in |- *; trivial; simple induction 1; trivial.
simple induction 1; trivial.
Qed.

Lemma comp_unmark_eq : forall U V : redexes, comp U V -> unmark U = unmark V.
Proof.
simple induction 1; simpl in |- *; trivial; split_all.
Qed.

(* The converse is true, but not needed in the rest of the development *)

Lemma residuals_mark :
forall M, residuals (mark M) (mark M) (mark M).
Proof. induction M; split_all. Qed.

Hint Resolve residuals_mark.


(*
 * Defining Hexadecimal
 *)
Inductive address :=
 | Nil
 | D0 (_:address)
 | D1 (_:address)
 | D2 (_:address)
 | D3 (_:address)
 | D4 (_:address)
 | D5 (_:address)
 | D6 (_:address)
 | D7 (_:address)
 | D8 (_:address)
 | D9 (_:address)
 | Da (_:address)
 | Db (_:address)
 | Dc (_:address)
 | Dd (_:address)
 | De (_:address)
 | Df (_:address).

Fixpoint compare_address (h1 : address) (h2 : address) : bool :=
    match h1 with
    | Nil =>
        match h2 with
        | Nil => true
        | _ => false
        end
    | D0 h1' =>
        match h2 with
        | D0 h2' => compare_address h1' h2'
        | _ => false
        end
    | D1 h1' =>
        match h2 with
        | D1 h2' => compare_address h1' h2'
        | _ => false
        end
    | D2 h1' =>
        match h2 with
        | D2 h2' => compare_address h1' h2'
        | _ => false
        end
    | D3 h1' =>
        match h2 with
        | D3 h2' => compare_address h1' h2'
        | _ => false
        end
    | D4 h1' =>
        match h2 with
        | D4 h2' => compare_address h1' h2'
        | _ => false
        end
    | D5 h1' =>
        match h2 with
        | D5 h2' => compare_address h1' h2'
        | _ => false
        end
    | D6 h1' =>
        match h2 with
        | D6 h2' => compare_address h1' h2'
        | _ => false
        end
    | D7 h1' =>
        match h2 with
        | D7 h2' => compare_address h1' h2'
        | _ => false
        end
    | D8 h1' =>
        match h2 with
        | D8 h2' => compare_address h1' h2'
        | _ => false
        end
    | D9 h1' =>
        match h2 with
        | D9 h2' => compare_address h1' h2'
        | _ => false
        end
    | Da h1' =>
        match h2 with
        | Da h2' => compare_address h1' h2'
        | _ => false
        end
    | Db h1' =>
        match h2 with
        | Db h2' => compare_address h1' h2'
        | _ => false
        end
    | Dc h1' =>
        match h2 with
        | Dc h2' => compare_address h1' h2'
        | _ => false
        end
    | Dd h1' =>
        match h2 with
        | Dd h2' => compare_address h1' h2'
        | _ => false
        end
    | De h1' =>
        match h2 with
        | De h2' => compare_address h1' h2'
        | _ => false
        end
    | Df h1' =>
        match h2 with
        | Df h2' => compare_address h1' h2'
        | _ => false
        end
    end.

Lemma compare_same_address : forall (addr : address),
    compare_address addr addr = true.
Proof.
    intros. induction addr as [ | l' | l' | l' | l' | l' | l' | l' |
    l' | l' | l' | l' | l' | l' | l' | l' | l' IHl'].
    - simpl. reflexivity.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
    - simpl. apply IHl'.
Qed.


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

Require Import List.
Require Import Equality.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.
Require Import UniqueTypI1.

Import ListNotations.

(** * DEC 2.0 language specification *)

(** Derived dynamic rules *)

Module DerivDyn (IdT: ModTyp) <: ModTyp.

Module UniqueTypL := UniqueTyp IdT.
Export UniqueTypL.

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

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

(** big-step lifting of congruence rules *)

Lemma BindN_extended_congruence :
   forall (fenv: funEnv) (env: valEnv)
                          (s1 s2: W) (n1 n2: nat) (p1 p2 p3: Exp),
     EClosure fenv env (Conf Exp s1 n1 p1) (Conf Exp s2 n2 p2) ->
     EClosure fenv env (Conf Exp s1 n1 (BindN p1 p3))
                            (Conf Exp s2 n2 (BindN p2 p3)).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p5.
  specialize (IHX state s2).
  specialize (IHX fuel n2).
  specialize (IHX qq).
  specialize (IHX p2).
  econstructor.
  - instantiate (1:= Conf Exp state fuel (BindN qq p3)).
    eapply BindN_Cg_EStep.
    assumption.
  - apply IHX.
    reflexivity.
    reflexivity.
Defined.

Lemma BindMS_extended_congruence :
        forall (fenv: funEnv) (env envL env': valEnv)
                (s1 s2: W) (n1 n2: nat) (e1 e2: Exp),
          env' = envL ++ env ->
          EClosure fenv env' (Conf Exp s1 n1 e1) (Conf Exp s2 n2 e2) ->
          EClosure fenv env (Conf Exp s1 n1 (BindMS envL e1))
                   (Conf Exp s2 n2 (BindMS envL e2)).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2.
  econstructor.
  - instantiate (1 := Conf Exp state fuel (BindMS envL qq)).
    econstructor.
    reflexivity.
    assumption.
  - eapply IHX.
    reflexivity.
    reflexivity.
    reflexivity.
Defined.

Lemma BindS_extended_congruence :
   forall (fenv: funEnv) (env: valEnv)
      (s1 s2: W) (n1 n2: nat) (x: Id) (mt: option VTyp) (p1 p2 p3: Exp),
           EClosure fenv env (Conf Exp s1 n1 p1) (Conf Exp s2 n2 p2) ->
           EClosure fenv env (Conf Exp s1 n1 (BindS x mt p1 p3))
                             (Conf Exp s2 n2 (BindS x mt p2 p3)).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p5.
  econstructor.
  - econstructor.
    eassumption.
  - eapply IHX.
    reflexivity.
    reflexivity.
Defined.

Lemma Apply1_extended_congruence :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (x: Id) (ps ps': Prms) (v: Value),
     PClosure fenv env (Conf Prms s n ps) (Conf Prms s' n' ps') ->
     EClosure fenv env (Conf Exp s n (Apply x ps (Val v)))
                            (Conf Exp s' n' (Apply x ps' (Val v))).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2.
  econstructor.
  - instantiate (1 := Conf Exp state fuel (Apply x qq (Val v))).
    econstructor.
    assumption.
  - specialize (IHX state s' fuel n' qq ps').
    eapply IHX.
    reflexivity.
    reflexivity.
Defined.

Lemma Apply2_extended_congruence
      (fenv: funEnv) (env: valEnv) (s s': W) (n n': nat)
      (x: Id) (ps: Prms) (e e': Exp) :
     EClosure fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     EClosure fenv env (Conf Exp s n (Apply x ps e))
                            (Conf Exp s' n' (Apply x ps e')).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2.
  econstructor.
  - instantiate (1:= Conf Exp state fuel (Apply x ps qq)).
    econstructor.
    eassumption.
  - eapply IHX.
    reflexivity.
    reflexivity.
Defined.

Lemma IfThenElse_extended_congruence :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (e e' e1 e2: Exp),
     EClosure fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     EClosure fenv env (Conf Exp s n
                                 (IfThenElse e e1 e2))
                            (Conf Exp s' n'
                                 (IfThenElse e' e1 e2)).
Proof.
  intros.
  dependent induction X.
  constructor.
  intros.
  destruct p2.
  specialize (IHX state s' fuel n' qq e' eq_refl eq_refl).
  econstructor.
  - econstructor.
    eassumption.
  - assumption.
Defined.

Lemma Call_extended_congruence :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (x: Id) (ps ps': Prms),
     PClosure fenv env (Conf Prms s n ps) (Conf Prms s' n' ps') ->
     EClosure fenv env (Conf Exp s n (Call x ps))
                            (Conf Exp s' n' (Call x ps')).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2.
  econstructor.
  - instantiate (1 := Conf Exp state fuel (Call x qq)).
    econstructor.
    assumption.
  - specialize (IHX state s' fuel n' qq ps').
    eapply IHX.
    reflexivity.
    reflexivity.
Defined.

Lemma Modify_extended_congruence :
     forall (fenv: funEnv) (env: valEnv)
            (s s': W) (n n': nat) (t1 t2: VTyp)
            (xf: XFun t1 t2) (e e': Exp),
     EClosure fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     EClosure fenv env (Conf Exp s n
                                 (Modify t1 t2 xf e))
                       (Conf Exp s' n'
                                 (Modify t1 t2 xf e')).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2.
  specialize (IHX state s' fuel n' xf qq e' eq_refl eq_refl).
  econstructor.
  - econstructor.
    eassumption.
  - assumption.
Defined.

Lemma Prms_extended_congruence1 :
    forall (fenv: funEnv) (env: valEnv)
                   (s s': W) (n n': nat)
                   (es es': list Exp) (v: Value),
         PClosure fenv env (Conf Prms s n (PS es))
                                   (Conf Prms s' n' (PS es')) ->
         PClosure fenv env (Conf Prms s n (PS (Val v :: es)))
                                   (Conf Prms s' n' (PS (Val v :: es'))).
Proof.
  intros.
  revert v.
  dependent induction X.
  - intros.
    constructor.
  - intros.
    destruct p2.
    destruct qq.
    specialize (IHX state s' fuel n' es0 es').
    specialize (IHX eq_refl eq_refl v).
    econstructor.
    econstructor.
    eassumption.
    assumption.
Defined.

Lemma Prms_extended_congruence2 :
    forall (fenv: funEnv) (env: valEnv)
           (s s': W) (n n': nat) (es: list Exp) (e e': Exp),
         EClosure fenv env (Conf Exp s n e)
                                (Conf Exp s' n' e') ->
         PClosure fenv env (Conf Prms s n (PS (e::es)))
                           (Conf Prms s' n' (PS (e'::es))).
  intros.
  revert es.
  dependent induction X.
  - constructor.
  - intros.
    destruct p2.
    specialize (IHX state s' fuel n' qq e').
    specialize (IHX eq_refl eq_refl es).
    econstructor.
    econstructor.
    eassumption.
    assumption.
Defined.

Lemma Prms_extended_congruence3 :
       forall (fenv: funEnv) (env: valEnv)
                   (s s': W) (n n': nat)
                   (es evs: list Exp) (vs: list Value),
         isValueList2T evs vs ->
         PClosure fenv env (Conf Prms s n (PS es))
                                   (Conf Prms s' n' (PS evs)) ->
         PClosure fenv env (Conf Prms s n (PS es))
                                   (Conf Prms s' n' (PS (map Val vs))).
Proof.
  intros.
  inversion X; subst.
  assumption.
Defined.

Lemma Prms_extended_congruence4 :
    forall (fenv: funEnv) (env: valEnv)
           (s s' s'': W) (n n' n'': nat)
           (es es': list Exp) (e: Exp) (v: Value),
         EClosure fenv env (Conf Exp s n e)
                                (Conf Exp s' n' (Val v)) ->
         PClosure fenv env (Conf Prms s' n' (PS es))
                                   (Conf Prms s'' n'' (PS es')) ->
         PClosure fenv env (Conf Prms s n (PS (e::es)))
                                   (Conf Prms s'' n'' (PS (Val v::es'))).
  intros.
  revert es es' X0.
  revert s'' n''.
  dependent induction X.
  - intros.
    eapply PConcat.
    econstructor.
    eapply Prms_extended_congruence1.
    assumption.
  - intros.
    destruct p2.
    specialize (IHX state s' fuel n' qq v).
    specialize (IHX eq_refl eq_refl s'' n'' es es' X0).
    econstructor.
    econstructor.
    eassumption.
    assumption.
Defined.

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

Lemma BindN_FStep :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1 s2: W) (n0 n1 n2: nat)
          (e1 e2: Exp) (v1 v2: Value),
    EClosure fenv env (Conf Exp s0 n0 e1) (Conf Exp s1 n1 (Val v1)) ->
    EClosure fenv env (Conf Exp s1 n1 e2) (Conf Exp s2 n2 (Val v2)) ->
    EClosure fenv env (Conf Exp s0 n0 (BindN e1 e2))
                      (Conf Exp s2 n2 (Val v2)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 n1 (BindN (Val v1) e2)).
  eapply BindN_extended_congruence.
  assumption.
  econstructor.
  econstructor.
  assumption.
Defined.

Lemma BindS_FStep :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1 s2: W) (n0 n1 n2: nat)
          (e1 e2: Exp) (x: Id) (m: option VTyp) (v1 v2: Value),
    EClosure fenv env (Conf Exp s0 n0 e1) (Conf Exp s1 n1 (Val v1)) ->
    EClosure fenv ((x,v1)::env) (Conf Exp s1 n1 e2) (Conf Exp s2 n2 (Val v2)) ->
    EClosure fenv env (Conf Exp s0 n0 (BindS x m e1 e2))
                      (Conf Exp s2 n2 (Val v2)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 n1 (BindS x m (Val v1) e2)).
  eapply BindS_extended_congruence.
  assumption.
  econstructor.
  econstructor.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s2 n2 (BindMS (singleE x v1) (Val v2))).
  eapply BindMS_extended_congruence.
  reflexivity.
  unfold singleE.
  simpl.
  assumption.
  econstructor.
  econstructor.
  econstructor.
Defined.

Lemma BindMS_FStep :
   forall (fenv: funEnv) (env env0: valEnv)
          (s0 s1: W) (n0 n1: nat)
          (e: Exp) (v: Value),
    EClosure fenv (env0 ++ env) (Conf Exp s0 n0 e) (Conf Exp s1 n1 (Val v)) ->
    EClosure fenv env (Conf Exp s0 n0 (BindMS env0 e))
                      (Conf Exp s1 n1 (Val v)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 n1 (BindMS env0 (Val v))).
  eapply BindMS_extended_congruence.
  reflexivity.
  assumption.
  econstructor.
  econstructor.
  constructor.
Defined.

Lemma IfThenElse_FStep1 :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1 s2: W) (n0 n1 n2: nat)
          (e1 e2 e3: Exp) (v: Value),
  EClosure fenv env (Conf Exp s0 n0 e1)
         (Conf Exp s1 n1 (Val (existT ValueI Bool (Cst Bool true)))) ->
  EClosure fenv env (Conf Exp s1 n1 e2) (Conf Exp s2 n2 (Val v)) ->
  EClosure fenv env (Conf Exp s0 n0 (IfThenElse e1 e2 e3))
    (Conf Exp s2 n2 (Val v)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 n1 (IfThenElse (Val (cst Bool true)) e2 e3)).
  eapply IfThenElse_extended_congruence.
  assumption.
  econstructor.
  econstructor.
  assumption.
Defined.

Lemma IfThenElse_FStep2 :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1 s2: W) (n0 n1 n2: nat)
          (e1 e2 e3: Exp) (v: Value),
  EClosure fenv env (Conf Exp s0 n0 e1)
         (Conf Exp s1 n1 (Val (existT ValueI Bool (Cst Bool false)))) ->
  EClosure fenv env (Conf Exp s1 n1 e3) (Conf Exp s2 n2 (Val v)) ->
  EClosure fenv env (Conf Exp s0 n0 (IfThenElse e1 e2 e3))
    (Conf Exp s2 n2 (Val v)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 n1 (IfThenElse (Val (cst Bool false)) e2 e3)).
  eapply IfThenElse_extended_congruence.
  assumption.
  econstructor.
  econstructor.
  assumption.
Defined.

Lemma Apply_FStep :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1: W) (n0 n1 n2 n3: nat) (x: Id)
          (e: Exp) (v: Value) (vs: list Value) (f: Fun) (ps: Prms),
     EClosure fenv env (Conf Exp s0 n0 e) (Conf Exp s0 n0 (Val v)) ->
     PClosure fenv env (Conf Prms s0 n0 ps)
              (Conf Prms s1 n1 (PS (map Val vs))) ->
     v = cst Nat n2 ->
     n3 = min n1 n2 ->
     findE fenv x = Some f ->
     EClosure fenv env (Conf Exp s0 n0 (Apply x ps e))
              (Conf Exp s1 n3 (Call x (PS (map Val vs)))).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s0 n0 (Apply x ps (Val v))).
  eapply Apply2_extended_congruence.
  eapply EClosWeaken.
  eassumption.
  instantiate (1:=nil).
  rewrite app_nil_r.
  auto.
  instantiate (1:=nil).
  rewrite app_nil_r.
  auto.
  eapply (EClosConcat fenv env).
  instantiate (1:= Conf Exp s1 n1 (Apply x (PS (map Val vs)) (Val v))).
  eapply Apply1_extended_congruence.
  assumption.
  eapply StepIsEClos.
  econstructor.
  exact f.
  exact H.
  unfold isValueListT.
  eapply forallValues.
  assumption.
Defined.

Lemma Call_FStep0 :
   forall (fenv: funEnv) (env: valEnv)
          (s: W) (n: nat) (x: Id)
          (v: Value) (vs: list Value) (f: Fun),
     findE fenv x = Some f ->
     v = fun0Exp f ->
     funArity f = length vs ->
     n = 0 ->
     EClosure fenv env (Conf Exp s n (Call x (PS (map Val vs))))
                       (Conf Exp s n (Val v)).
  intros.
  eapply StepIsEClos.
  rewrite H2.
  econstructor.
  eassumption.
  econstructor.
  assumption.
  reflexivity.
  assumption.
Defined.

Lemma Call_FStep01 :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1: W) (n0 n1: nat) (x: Id)
          (v: Value) (vs: list Value) (f: Fun) (ps: Prms),
     PClosure fenv env (Conf Prms s0 n0 ps)
              (Conf Prms s1 n1 (PS (map Val vs))) ->
     findE fenv x = Some f ->
     v = fun0Exp f ->
     funArity f = length vs ->
     n1 = 0 ->
     EClosure fenv env (Conf Exp s0 n0 (Call x ps))
                       (Conf Exp s1 n1 (Val v)).
  intros.
  eapply (EClosConcat fenv env).
  eapply Call_extended_congruence.
  eassumption.
  eapply Call_FStep0.
  eassumption.
  assumption.
  assumption.
  assumption.
Defined.

Lemma Call_FStepS :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s2 s3: W) (n0 n2 n3: nat) (x: Id)
          (v3: Value) (vs: list Value) (f: Fun) (ls: list Exp),
    findE fenv x = Some f ->
     funArity f = length vs ->
    EClosure fenv env
         (Conf Exp s2 n2 (BindMS (mkVEnv (funValTC f) vs) (funSExp f)))
         (Conf Exp s3 n3 (Val v3)) ->
    PClosure fenv env (Conf Prms s0 n0 (PS ls))
         (Conf Prms s2 (S n2) (PS (map Val vs))) ->
    EClosure fenv env (Conf Exp s0 n0 (Call x (PS ls)))
                           (Conf Exp s3 n3 (Val v3)).
Proof.
  intros.
  eapply Call_extended_congruence with (x:=x) in X0.
  eapply EClosConcat.
  exact X0.
  econstructor.
  instantiate (1:= Conf Exp s2 n2
                        (BindMS (mkVEnv (funValTC f) vs) (funSExp f))).
  econstructor.
  econstructor.
  eassumption.
  assumption.
  auto.
  auto.
  assumption.
Defined.

Lemma Call_FStepS1 :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s3: W) (n0 n3: nat) (x: Id)
          (v3: Value) (vs: list Value) (f: Fun) (ls: list Exp),
    findE fenv x = Some f ->
     funArity f = length vs ->
    EClosure fenv env
         (Conf Exp s0 n0 (BindMS (mkVEnv (funValTC f) vs) (funSExp f)))
         (Conf Exp s3 n3 (Val v3)) ->
    isValueList2T ls vs ->
    EClosure fenv env (Conf Exp s0 (S n0) (Call x (PS ls)))
                           (Conf Exp s3 n3 (Val v3)).
Proof.
  intros.
  econstructor.
  eapply Call_EStepS.
  exact X0.
  exact H.
  exact H0.
  reflexivity.
  reflexivity.
  exact X.
Defined.

Lemma Apply_FStepS :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s2 s3: W) (n0 n2 n3 n5 n6: nat) (x: Id)
          (v3: Value) (vs: list Value) (e: Exp) (f: Fun) (ls: list Exp),
    findE fenv x = Some f ->
    funArity f = length vs ->
    n6 = min n2 n5 ->
    EClosure fenv env (Conf Exp s0 n0 e)
             (Conf Exp s0 n0 (Val (cst Nat (S n5)))) ->
    EClosure fenv env
             (Conf Exp s2 n6
                   (BindMS (mkVEnv (funValTC f) vs) (funSExp f)))
         (Conf Exp s3 n3 (Val v3)) ->
    PClosure fenv env (Conf Prms s0 n0 (PS ls))
         (Conf Prms s2 (S n2) (PS (map Val vs))) ->
    EClosure fenv env (Conf Exp s0 n0 (Apply x (PS ls) e))
                           (Conf Exp s3 n3 (Val v3)).
Proof.
  intros.
  eapply Apply2_extended_congruence with (x:=x) (e:=e) (ps:=PS ls) in X.
  eapply EClosConcat.
  exact X.
  eapply Apply1_extended_congruence
            with (x:=x) (ps:=PS ls) (v:=cst Nat (S n5)) in X1.
  eapply EClosConcat.
  exact X1.
  econstructor.
  instantiate (1:= Conf Exp s2 (S n6)
                        (Call x (PS (map Val vs)))).
  econstructor.
  exact f.
  reflexivity.
  eapply forallValues.
  simpl.
  inversion H1; subst.
  auto.
  econstructor.
  instantiate (1:=(Conf Exp s2 n6
                        (BindMS (mkVEnv (funValTC f) vs) (funSExp f)))).
  econstructor.
  econstructor.
  eassumption.
  assumption.
  reflexivity.
  reflexivity.
  assumption.
Defined.

Lemma Apply_FStep0 :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1: W) (n0 n1 n2: nat) (x: Id)
          (e: Exp) (v0 v: Value) (vs: list Value) (f: Fun) (ps: Prms),
     EClosure fenv env (Conf Exp s0 n0 e) (Conf Exp s0 n0 (Val v0)) ->
     PClosure fenv env (Conf Prms s0 n0 ps)
              (Conf Prms s1 n1 (PS (map Val vs))) ->
     findE fenv x = Some f ->
     v = fun0Exp f ->
     v0 = cst Nat n2 ->
     n1 = 0 ->
     funArity f = length vs ->
     EClosure fenv env (Conf Exp s0 n0 (Apply x ps e))
                       (Conf Exp s1 n1 (Val v)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 0 (Call x (PS (map Val vs)))).
  eapply Apply_FStep.
  eassumption.
  eassumption.
  eassumption.
  rewrite H2.
  simpl.
  reflexivity.
  eassumption.
  rewrite H2.
  eapply Call_FStep0.
  eassumption.
  assumption.
  assumption.
  reflexivity.
Defined.

Lemma Apply_FStep01 :
   forall (fenv: funEnv) (env: valEnv)
          (s0 s1: W) (n0 n1 n2: nat) (x: Id)
          (e: Exp) (v0 v: Value) (vs: list Value) (f: Fun) (ps: Prms),
     EClosure fenv env (Conf Exp s0 n0 e) (Conf Exp s0 n0 (Val v0)) ->
     PClosure fenv env (Conf Prms s0 n0 ps)
              (Conf Prms s1 n1 (PS (map Val vs))) ->
     findE fenv x = Some f ->
     v = fun0Exp f ->
     v0 = cst Nat n2 ->
     0 = min n1 n2 ->
     funArity f = length vs ->
     EClosure fenv env (Conf Exp s0 n0 (Apply x ps e))
                       (Conf Exp s1 0 (Val v)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 (min n1 n2) (Call x (PS (map Val vs)))).
  eapply Apply_FStep.
  eassumption.
  eassumption.
  eassumption.
  reflexivity.
  eassumption.
  rewrite <- H2.
  eapply Call_FStep0.
  eassumption.
  assumption.
  assumption.
  reflexivity.
Defined.

Lemma Modify_FStep :
   forall (n: nat) (fenv: funEnv) (env: valEnv)
          (s0 s1 s2: W) (n0 n1: nat) (t1 t2: VTyp)
          (xf: XFun t1 t2)
          (e: Exp) (v1: sVTyp t1) (v2: Value),
     EClosure fenv env (Conf Exp s0 n0 e) (Conf Exp s1 n1 (Val (cst t1 v1))) ->
     v2 = (cst t2 (x_eval t1 t2 xf v1 s1)) ->
     s2 = x_exec t1 t2 xf v1 s1 ->
     EClosure fenv env (Conf Exp s0 n0 (Modify t1 t2 xf e))
                       (Conf Exp s2 n1 (Val v2)).
  intros.
  eapply (EClosConcat fenv env).
  instantiate (1:=Conf Exp s1 n1 (Modify t1 t2 xf (Val (cst t1 v1)))).
  eapply Modify_extended_congruence.
  eassumption.
  eapply StepIsEClos.
  inversion H; subst.
  econstructor.
Defined.

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

Lemma Pure_step_inv1 :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (e e': Exp),
     Pure e ->
     EStep fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     Pure e'.
Proof.
  intros.
  revert X0.
  revert s s' n n' e'.
  induction X.
  intros.
  inversion X0.
  intros.
  inversion X0; subst.
  constructor.
Defined.

Lemma Pure_inv1 :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (e e': Exp),
     Pure e ->
     EClosure fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     Pure e'.
Proof.
  intros.
  dependent induction X0.
  assumption.
  destruct p2.
  specialize (IHX0 e' qq).
  eapply IHX0.
  eapply Pure_step_inv1 with (e':=qq) (e:=e).
  assumption.
  eassumption.
  reflexivity.
  reflexivity.
Defined.

Lemma Pure_step_sideffect :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (e e': Exp),
     Pure e ->
     EStep fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     s = s' /\ n = n'.
Proof.
  intros.
  inversion X; subst.
  inversion X0.
  inversion X0; subst.
  auto.
Defined.

Lemma Pure_sideffect :
     forall (fenv: funEnv) (env: valEnv)
                           (s s': W) (n n': nat)
                           (e e': Exp),
     Pure e ->
     EClosure fenv env (Conf Exp s n e) (Conf Exp s' n' e') ->
     s = s' /\ n = n'.
Proof.
  intros.
  dependent induction X0.
  auto.
  destruct p2.
  generalize e0.
  intro k.
  eapply Pure_step_sideffect in k.
  destruct k.
  inversion H; subst.
  specialize (IHX0 e' qq).
  eapply Pure_step_inv1 in e0.
  specialize (IHX0 e0).
  specialize (IHX0 n' fuel s' state).
  specialize (IHX0 eq_refl eq_refl).
  assumption.
  assumption.
  assumption.
Defined.

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

(** lemmas about parameters *)

Lemma PrmsStep_aux0 :
    forall (fenv: funEnv) (env: valEnv)
           (s s': W) (n n': nat) (es es': list Exp),
         PStep fenv env (Conf Prms s n (PS es))
                     (Conf Prms s' n' (PS es')) ->
         length es = length es'.
Proof.
  intros.
  dependent induction X.
  specialize (IHX s s' n n' es0 es'0 eq_refl eq_refl).
  simpl.
  auto.
  auto.
Defined.

Lemma PrmsClos_aux0 :
    forall (fenv: funEnv) (env: valEnv)
            (s s': W) (n n': nat) (es es': list Exp),
         PClosure fenv env (Conf Prms s n (PS es))
                     (Conf Prms s' n' (PS es')) ->
         length es = length es'.
Proof.
  intros.
  dependent induction X.
  auto.
  destruct p2.
  destruct qq.
  eapply PrmsStep_aux0 in p.
  specialize (IHX state s' fuel n' es0 es' eq_refl eq_refl).
  rewrite <- p in IHX.
  auto.
Defined.

Lemma PrmsClos_aux1 (fenv: funEnv) (env: valEnv)
                     (e: Exp) (v: Value) (es es': list Exp) (w: W * nat)
      : {w' : W * nat &
      PClosure fenv env (Conf Prms (fst w) (snd w) (PS (e :: es)))
                  (Conf Prms (fst w') (snd w') (PS (Val v :: es')))} ->
      {w' : W * nat &
         prod (EClosure fenv env (Conf Exp (fst w) (snd w) e)
               (Conf Exp (fst w') (snd w') (Val v)))
            {w'' : W * nat &
                  PClosure fenv env (Conf Prms (fst w') (snd w') (PS es))
                                (Conf Prms (fst w'') (snd w'') (PS es'))} }.
Proof.
  intros.
  destruct X as [w2 X].
  dependent induction X.
  - econstructor.
    split.
    econstructor.
    econstructor.
    econstructor.
  - destruct p2.
    destruct qq.
    destruct es0 as [| e1 es1].
    inversion p.
    specialize (IHX e1 v es1 es' (state,fuel) w2 eq_refl eq_refl).
    destruct IHX.
    destruct p0.
    destruct s.
    inversion e0; subst.
    inversion p; subst.
    econstructor.
    split.
    econstructor.
    econstructor.
    econstructor.
    exact X0.
    exact p0.
    econstructor.
    split.
    eapply StepIsEClos.
    exact X0.
    econstructor.
    exact p0.
    (**)
    inversion e0; subst.
    inversion X0.
    inversion p; subst.
    inversion X0.
    econstructor.
    split.
    econstructor.
    exact X4.
    exact e0.
    econstructor.
    exact p0.
Defined.

Lemma PrmsClos_aux2 (fenv: funEnv) (env: valEnv)
      (e: Exp) (v: Value) (es es': list Exp)
      (w0 w1: W) (n0 n1: nat) :
      PClosure fenv env (Conf Prms w0 n0 (PS (Val v :: es)))
                  (Conf Prms w1 n1 (PS (Val v :: es'))) ->
      PClosure fenv env (Conf Prms w0 n0 (PS es))
                  (Conf Prms w1 n1 (PS es')).
Proof.
  intros.
  dependent induction X.
  - constructor.
  - destruct p2.
    destruct qq.
    destruct es0.
    inversion p.
    inversion p; subst.
    specialize (IHX v es0 es' state w1 fuel n1 eq_refl eq_refl).
    econstructor.
    exact X0.
    exact IHX.
    inversion X0.
Defined.

Lemma PrmsClos_aux3 (fenv: funEnv) (env: valEnv)
      (e: Exp) (v: Value) (es es': list Exp)
      (w0 w1: W) (n0 n1: nat) :
      PClosure fenv env (Conf Prms w0 n0 (PS (e :: es)))
                  (Conf Prms w1 n1 (PS (Val v :: es'))) ->
      {s : W * nat &
        prod (EClosure fenv env (Conf Exp w0 n0 e)
               (Conf Exp (fst s) (snd s) (Val v)))
             (PClosure fenv env (Conf Prms (fst s) (snd s) (PS es))
                                (Conf Prms w1 n1 (PS es'))) }.
Proof.
  intros.
  dependent induction X.
  - econstructor 1 with (x:=(w1,n1)).
    split.
    simpl.
    econstructor.
    simpl.
    econstructor.
  - destruct p2.
    destruct qq.
    destruct es0 as [| e1 es1].
    inversion p.
    inversion p; subst.

    specialize (IHX (Val v0) v es1 es' state w1 fuel n1 eq_refl eq_refl).
    destruct IHX.
    destruct p0.
    destruct x.

    constructor 1 with (x:=(w0,n0)).
    simpl in *.
    inversion e; subst.
    split.
    constructor.
    econstructor.
    exact X0.
    exact p0.

    inversion X1.

    specialize (IHX e1 v es1 es' state w1 fuel n1 eq_refl eq_refl).
    destruct IHX.
    destruct p0.
    destruct x.

    constructor 1 with (x:=(w,n)).
    simpl in *.
    split.
    econstructor.
    exact X0.
    exact e0.
    exact p0.
Defined.

Lemma prmsAux1
      (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp) :
  forall (fenv: funEnv) (env: valEnv),
    FEnvTyping fenv ftenv ->
    EnvTyping env tenv ->
    forall w: W * nat,
    (sigT (fun (w': W * nat) =>
           sigT (fun (es: list Exp) =>
           prod (isValueListT es)
           (prod (PClosure fenv env (Conf Prms (fst w) (snd w) ps)
                                    (Conf Prms (fst w') (snd w') (PS es)))
                 (PrmsTyping ftenv tenv (PS es) pt))))) ->
    (sigT (fun (w': W * nat) =>
           sigT (fun (vs: list Value) =>
           prod (PClosure fenv env (Conf Prms (fst w) (snd w) ps)
                            (Conf Prms (fst w') (snd w') (PS (map Val vs))))
                (PrmsTyping ftenv tenv (PS (map Val vs)) pt)))).
Proof.
  intros.
  destruct X as [n1 X].
  destruct X as [es X].
  destruct X as [X1 X2].
  destruct X2 as [X2 X3].
  exists n1.
  eapply isValueList22_T in X1.
  inversion X1.
  destruct X1 as [vs].
  constructor 1 with (x:=vs).
  split.
  - eapply PConcat.
    eassumption.
    inversion i; subst.
    constructor.
  - destruct pt.
    inversion i; subst.
    exact X3.
Defined.

Lemma NoPrmsStep (fenv: funEnv) (env: valEnv)
                  (w0 w1: W * nat) (es1 es2: list Exp):
  PStep fenv env (Conf Prms (fst w0) (snd w0) (PS es1))
                      (Conf Prms (fst w1) (snd w1) (PS es2)) ->
   isValueListT es1 -> False.
Proof.
  intros.
  revert X0.
  dependent induction X.
  intros.
  inversion X0; subst.
  eapply IHX.
  reflexivity.
  reflexivity.
  auto.
  intro.
  inversion X0; subst.
  inversion X; subst.
  inversion e0.
Defined.

Lemma NoNilPrmsClos1 (fenv: funEnv) (env: valEnv)
                  (s0 s1: W) (n0 n1: nat) (e: Exp) (es: list Exp):
  PClosure fenv env (Conf Prms s0 n0 (PS (e::es)))
                      (Conf Prms s1 n1 (PS nil)) -> False.
  intros.
  dependent induction X.
  destruct p2.
  destruct qq.
  destruct es0.
  inversion p.
  specialize (IHX state s1 fuel n1 e0 es0 eq_refl eq_refl).
  exact IHX.
Defined.

Lemma NoNilPrmsClos2 (fenv: funEnv) (env: valEnv)
                  (s0 s1: W) (n0 n1: nat) (e: Exp) (es: list Exp):
  PClosure fenv env (Conf Prms s0 n0 (PS nil))
                      (Conf Prms s1 n1 (PS (e::es))) -> False.
  intros.
  dependent induction X.
  destruct p2.
  destruct qq.
  destruct es0.
  specialize (IHX state s1 fuel n1 e es eq_refl eq_refl).
  exact IHX.
  inversion p.
Defined.

(************* from TSoundness ***************************************)
(********************************************************************)

Program Definition ExtRelTyp (tenv : valTC) (x : Id)
      (v : Value) (t : VTyp) (mB: valueVTyp v = t)
       (env: valEnv) (m2: EnvTyping env tenv) (mA: findE env x = Some v) :
   findE tenv x = Some t.
  unfold EnvTyping in m2.
  unfold MatchEnvs in m2.
  rewrite m2.
  unfold thicken.
  rewrite <- mB.
  revert m2.
  revert tenv.
  induction env.
  inversion mA.
  intros tenv m2.
  destruct a.
  simpl in *.
  destruct (IdT.IdEqDec x i).
  injection mA; intro.
  rewrite H.
  reflexivity.
  specialize (IHenv mA (map (thicken StaticSemL.Id valueVTyp) env) eq_refl).
  exact IHenv.
Defined.

Program Definition ExtRelVal2A {K V1 V2: Type} {h: DEq K} (f: V1 -> V2)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2):
    MatchEnvs K f venv tenv ->
    findE tenv x = Some t ->
    sigT2 (fun v: V1 => findE venv x = Some v) (fun v: V1 => f v = t).
Proof.
  unfold MatchEnvs.
  unfold thicken.
  intros.
  rewrite H in H0.
  clear H.
  clear tenv.
  induction venv.
  simpl in *.
  discriminate H0.
  destruct a.
  simpl in *.
  destruct (dEq x k).
  injection H0; intro.
  clear H0.
  constructor 1 with (x:=v).
  reflexivity.
  rewrite H in *.
  reflexivity.
  eapply IHvenv.
  intuition n.
Defined.

Definition ExtRelVal2A_1 {K V1 V2: Type} {h: DEq K} (f: V1 -> V2)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2)
    (k1: MatchEnvs K f venv tenv)
    (k2: findE tenv x = Some t) : V1 :=
   proj1_of_sigT2 (ExtRelVal2A f tenv venv x t k1 k2).

Definition ExtRelVal2A_2 {K V1 V2: Type} {h: DEq K} (f: V1 -> V2)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2)
    (k1: MatchEnvs K f venv tenv)
    (k2: findE tenv x = Some t) :
  findE venv x = Some (ExtRelVal2A_1 f tenv venv x t k1 k2) :=
  projT2 (fst_sigT_of_sigT2 (ExtRelVal2A f tenv venv x t k1 k2)).

Definition ExtRelVal2A_3 {K V1 V2: Type} {h: DEq K} (f: V1 -> V2)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2)
    (k1: MatchEnvs K f venv tenv)
    (k2: findE tenv x = Some t) : sigT (fun v: V1 => f v = t) :=
  snd_sigT_of_sigT2 (ExtRelVal2A f tenv venv x t k1 k2).

Definition ExtRelVal2A_4 {K V1 V2: Type} {h: DEq K} (f: V1 -> V2)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2)
    (k1: MatchEnvs K f venv tenv)
    (k2: findE tenv x = Some t) :
  f (ExtRelVal2A_1 f tenv venv x t k1 k2) = t :=
  projT2 (snd_sigT_of_sigT2 (ExtRelVal2A f tenv venv x t k1 k2)).

Lemma TransformA_Var (P : valEnv -> Exp -> VTyp -> Type)
      (Q : VTyp -> Type)
      (F1 : forall (env: valEnv) (x: Id) (t: VTyp), P env (Var x) t -> Type)
      (F2: forall t: VTyp, Q t -> Type)
  : (forall (tenv : valTC) (x : Id)
    (v : Value)
    (t : VTyp) (i : findE tenv x = Some t) (mB: valueVTyp v = t)
    (env: valEnv) (mA: findE env x = Some v)
    (m2: EnvTyping env tenv),
    (P env (Var x) t * Q t) ->
     sigT (fun I: (P env (Var x) t * Q t) =>
             F1 env x t (fst I) = F2 t (snd I))) ->
    forall (tenv : valTC) (x : Id) (t: VTyp)
    (i : findE tenv x = Some t)
    (env: valEnv)
    (m2: EnvTyping env tenv),
    (P env (Var x) t * Q t) ->
     sigT (fun I: (P env (Var x) t * Q t) =>
             F1 env x t (fst I) = F2 t (snd I)).
Proof.
  intros.
  specialize (X tenv x (ExtRelVal2A_1 valueVTyp tenv env x t m2 i) t i
         (ExtRelVal2A_4 valueVTyp tenv env x t m2 i)
         env
         (ExtRelVal2A_2 valueVTyp tenv env x t m2 i)
         m2 X0).
  exact X.
Defined.

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

Program Definition ExtRelVal2B
       (env: valEnv) (x: Id) (t: VTyp):
    findE (valEnv2valTC env) x = Some t ->
    sigT2 (fun v: Value => findE env x = Some v)
          (fun v: Value => projT1 v = t).
Proof.
  induction env.
  simpl in *.
  intros.
  discriminate H.
  destruct a.
  simpl in *.
  destruct (IdT.IdEqDec x i).
  intro.
  injection H; intro.
  constructor 1 with (x:=v).
  reflexivity.
  exact H0.
  intro.
  eapply IHenv.
  exact H.
Defined.

Lemma ExtRelVal2B_ok (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v) :
  v = proj1_of_sigT2 (ExtRelVal2B env x t k1).
  induction env.
  inversion k1.
  destruct a.
  simpl in k1, k2.
  simpl.
  unfold ExtRelVal2B.
  unfold proj1_of_sigT2.
  unfold sigT_of_sigT2.
  simpl.
  destruct (IdT.IdEqDec x i).
  inversion k2; subst.
  reflexivity.
  specialize (IHenv k1 k2).
  rewrite IHenv.
  reflexivity.
Defined.

Lemma ExtRelVal2B_Typ_ok (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v) :
  (sVTyp (projT1 v)) =
      sVTyp (projT1
       (proj1_of_sigT2
          (ExtRelVal2B env x t k1))).
  rewrite (ExtRelVal2B_ok env x t v k1 k2).
  reflexivity.
Defined.

Lemma ExtRelVal2B_TypS_ok (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v) :
    sVTyp (projT1
       (proj1_of_sigT2
          (ExtRelVal2B env x t k1))) =
    (sVTyp (projT1 v)).
  rewrite (ExtRelVal2B_ok env x t v k1 k2).
  reflexivity.
Defined.

Definition ExtRelVal2B_1
           (env: valEnv) (x: Id) (t: VTyp)
           (k: findE (valEnv2valTC env) x = Some t) : Value :=
 proj1_of_sigT2 (ExtRelVal2B env x t k).

Definition ExtRelVal2B_2
           (env: valEnv) (x: Id) (t: VTyp)
           (k: findE (valEnv2valTC env) x = Some t) :
  findE env x = Some (ExtRelVal2B_1 env x t k) :=
 projT2 (fst_sigT_of_sigT2 (ExtRelVal2B env x t k)).

Definition ExtRelVal2B_3 (env: valEnv) (x: Id) (t: VTyp)
           (k: findE (valEnv2valTC env) x = Some t) :
    sigT (fun v: Value => valueVTyp v = t) :=
 snd_sigT_of_sigT2 (ExtRelVal2B env x t k).

Definition ExtRelVal2B_4
           (env: valEnv) (x: Id) (t: VTyp)
           (k: findE (valEnv2valTC env) x = Some t) :
  valueVTyp (ExtRelVal2B_1 env x t k) = t :=
 projT2 (snd_sigT_of_sigT2 (ExtRelVal2B env x t k)).

End DerivDyn.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ E Z /\ (wd_ A D /\ (wd_ D E /\ (wd_ A E /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Dprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ X E Z /\ (col_ A E Z /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ col_ E X A))))))))))))))))))))))))))))))))))) -> col_ A C E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Raft.
Require Import RaftRefinementInterface.

Require Import LeadersHaveLeaderLogsInterface.
Require Import EveryEntryWasCreatedInterface.
Require Import EveryEntryWasCreatedHostLogInterface.

Section EveryEntryWasCreated.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {lhlli : leaders_have_leaderLogs_interface}.
  Context {rri : raft_refinement_interface}.
  Context {eewci : every_entry_was_created_interface}.

  Instance eewchli : every_entry_was_created_host_log_interface.
  split.
  unfold every_entry_was_created_host_log. intros.
  apply every_entry_was_created_in_any_log_invariant; eauto using in_log.
  Qed.
End EveryEntryWasCreated.


(******************************************************************************)
(** * Proof of Power fairness for Power-consistent,                           *)
(** * location- and thread-finite executions.                                 *)
(******************************************************************************)

From hahn Require Import Hahn.
From ZornsLemma Require Classical_Wf.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import Power_fences.
Require Import Power_ppo.
Require Import Power.
Require Import imm_bob.
Require Import imm_ppo.
Require Import imm_hb.
Require Import imm_rfppo.
Require Import imm.
Require Import ImmFair.
Require Import FairExecution.
Require Import immToPower.
Require Import FinThreads.
Require Import Lia.
Require Import ClassicalChoice.
Require Import ChoiceFacts.
Require Import IndefiniteDescription.
Require Import AuxRel2.
Require Import Program.Basics.
Require Import EnumProperties.
Require Import HardwareFairness.
Require Import AuxDef.
Import ListNotations.

Set Implicit Arguments.

Section immToPowerFairness.

Variable G : execution.

Notation "'E'" := (acts_set G).
Notation "'lab'" := (lab G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'rmw'" := (rmw G).
Notation "'data'" := (data G).
Notation "'addr'" := (addr G).
Notation "'ctrl'" := (ctrl G).
Notation "'deps'" := (deps G).
Notation "'rmw_dep'" := (rmw_dep G).

Notation "'fre'" := (fre G).
Notation "'rfe'" := (rfe G).
Notation "'coe'" := (coe G).
Notation "'rfi'" := (rfi G).
Notation "'fri'" := (fri G).
Notation "'coi'" := (coi G).
Notation "'fr'" := (fr G).
Notation "'eco'" := (eco G).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'W_ex'" := (W_ex G).
Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (mod lab).
Notation "'same_loc'" := (same_loc lab).

(* power *)
Notation "'ctrli'" := (ctrli G).
Notation "'sync'" := (sync G).
Notation "'lwsync'" := (lwsync G).
Notation "'fence'" := (fence G).
Notation "'ppop'" := (Power_ppo.ppo G).
Notation "'hbp'" := (Power.hb G).
(* Notation "'S'" := (S G). *)
Notation "'detour'" := (detour G).

Notation "'F^isync'" := (F ∩₁ (fun a => is_true (is_rlx lab a))).
Notation "'F^lwsync'" := (F ∩₁ (fun a => is_true (is_ra lab a))).
Notation "'F^sync'" := (F ∩₁ (fun a => is_true (is_sc lab a))).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'Loc_' l" := (fun x => loc x = l) (at level 1).

Hypothesis SC_F: Sc ⊆₁ F∩₁Sc.
Hypothesis NO_W_REL : W∩₁Rel ≡₁ ∅.
Hypothesis R_ACQ_SB : ⦗R∩₁Acq⦘ ⨾ sb ⊆ rmw ∪ ctrl ⨾ ⦗F^isync⦘ ⨾ sb^? ∪ sb ⨾ ⦗F^lwsync⦘ ⨾ sb^?.
Hypothesis RMW_DEPS : rmw ⊆ ctrl ∪ data.
Hypothesis RMW_CTRL_FAIL : ⦗R_ex⦘ ⨾ sb ⊆ ctrl.
Hypothesis DATA_RMW : data ⨾ ⦗W_ex⦘ ⨾ sb ⊆ ctrl.
Hypothesis DEPS_RMW_FAIL : rmw_dep ⨾ (rmw ∪ ctrl) ⊆ ctrl.

Hypothesis CON: PowerConsistent G.

Lemma wf_hbpE:
  hbp ≡ ⦗E⦘ ⨾ hbp ⨾ ⦗E⦘.
Proof using CON.
  apply dom_helper_3. unfold "hbp".
  rewrite Power_ppo.wf_ppoE, wf_fenceE, wf_rfeE; auto; try apply CON.
  basic_solver.
Qed.

Lemma hb_po_loc_hb:
  hbp⁺ ⨾ sb ∩ same_loc ⊆ hbp⁺.
Proof using CON.
Admitted.

Lemma exists_inf_thread (f: nat -> actid) (S: actid -> Prop) b
      (IN_E: f ↑₁ set_full ⊆₁ E \₁ is_init)
      (INF: ~ set_finite (f ↓₁ S))
      (FINTHREADS : threads_bound G b):
    exists t, BinPos.Pos.lt t b /\ ~ set_finite (f ↓₁ (S ∩₁ Tid_ t)).
Proof using.
  apply set_infinite_bunion.
  { exists (mk_list (Datatypes.S (BinPos.Pos.to_nat b)) BinPos.Pos.of_nat). intros.
    apply in_mk_list_iff. eexists. split.
    2: { symmetry. apply Pnat.Pos2Nat.id. }
    red in IN. apply Pnat.Pos2Nat.inj_lt in IN. lia. }
  intros FIN. destruct INF.
  rewrite AuxRel2.set_bunion_separation with (fab := tid).
  rewrite set_map_bunion.
  rewrite AuxRel2.set_full_split with (S := flip BinPos.Pos.lt b).
  rewrite set_bunion_union_l, set_finite_union. split; auto.
  exists []. ins. unfolder in IN. desc. destruct IN. red.
  rewrite <- IN1. apply FINTHREADS. apply IN_E. vauto.
Qed.

Lemma exists_inf_loc (f: nat -> actid) (S: actid -> Prop) locs
      (IN_E: f ↑₁ set_full ⊆₁ E \₁ is_init)
      (INF: ~ set_finite (f ↓₁ S))
      (FINLOCS: forall e (ENIe: (E \₁ is_init) e), In (loc e) locs):
    exists l, In l locs /\ ~ set_finite (f ↓₁ (S ∩₁ Loc_ l)).
Proof using.
  eapply set_infinite_bunion; [by vauto| ].
  intros FIN. destruct INF.
  rewrite AuxRel2.set_bunion_separation with (fab := loc).
  rewrite set_map_bunion.
  rewrite AuxRel2.set_full_split with (S := fun l => In l locs).
  rewrite set_bunion_union_l, set_finite_union. split; auto.
  exists []. ins. unfolder in IN. desc.
  destruct IN. rewrite <- IN1. apply FINLOCS. apply IN_E. vauto.
Qed.

Lemma fin_threads_locs_power_hb_ct_fsupp
      (FINLOCS: exists locs, forall e (ENIe: (E \₁ is_init) e), In (loc e) locs)
      (FINTHREADS: exists b, threads_bound G b):
  fsupp (⦗set_compl is_init⦘ ⨾ hbp^+).
Proof using CON.
  desc.
  assert (Wf G) as WF by apply CON.
  rewrite clos_trans_domb_begin.
  2: { rewrite no_hbp_to_init; basic_solver. }
  apply AuxDef.fsupp_wf_implies_fsupp_ct.
  2: { unfold "hbp".
       rewrite Power_ppo.ppo_in_sb, fence_in_sb, unionK, rfe_in_rf; auto.
       rewrite seq_union_r. apply fsupp_union.
       { by apply fsupp_sb. }
       eapply fsupp_mori; [| by apply fsupp_rf; eauto]. red. basic_solver. }

  contra NWF. apply not_wf_inf_decr_enum in NWF as [f DECR].
  assert (forall i, (transp hbp) (f i) (f (i + 1))) as DECR'.
  { ins. red. eapply seq_eqv_l. eauto. }

  assert (f ↑₁ set_full ⊆₁ E \₁ is_init) as ENUM_E.
  { intros e [i [_ Fie]].
    specialize (DECR i). eapply same_relation_exp in DECR.
    2: { rewrite no_hbp_to_init, wf_hbpE; auto. }
    generalize DECR. subst e. basic_solver. }

  assert (~ set_finite (f ↓₁ W)) as INFW'.
  { intros [iws FINW].
    set (wb := list_max iws + 1).
    assert (forall j (GE: j >= wb), sb (f (j + 1)) (f j)) as SB_STEPS.
    { intros. specialize (DECR j). apply seq_eqv_l in DECR. desc.
      unfold "hbp" in DECR0. eapply hahn_inclusion_exp in DECR0.
      2: { rewrite Power_ppo.ppo_in_sb, fence_in_sb, unionK; auto. reflexivity. }
      destruct DECR0; auto.
      specialize (FINW (j + 1)). specialize_full FINW.
      { apply wf_rfeD, seq_eqv_lr in H; auto. desc. vauto. }
      apply In_gt_list_max in FINW; vauto. lia. }

    forward eapply fsupp_dom_enum with (f := fun k => f (wb + k))
                                       (r := ⦗set_compl is_init⦘ ⨾ sb) as [].
    { ins. apply seq_eqv_l. split.
      { apply ENUM_E. vauto. }
      rewrite PeanoNat.Nat.add_assoc. apply SB_STEPS. lia. }
    { eapply acyclic_mori; [| by apply sb_acyclic]. red. basic_solver. }
    eapply fsupp_mori; [| by apply fsupp_sb; eauto].
    red. rewrite inclusion_ct_seq_eqv_l.
    rewrite ct_of_trans; vauto. apply sb_trans. }

  eapply exists_inf_thread in INFW' as [t [TBt INFt]]; eauto.

  eapply exists_inf_loc in INFt as [ol [Ll INFtl]]; eauto.
  destruct ol.
  2: { destruct INFtl. exists []. unfolder. ins. desc.
       forward eapply is_w_loc; eauto. ins. desc. vauto. }

  eapply enum_order_contradiction with (r' := sb ∩ same_loc)
                                       (S := (E \₁ is_init) ∩₁ (W ∩₁ Tid_ t ∩₁ Loc_ (Some l))); eauto.
  { intros FIN. destruct INFtl. eapply set_finite_mori; eauto.
    red. rewrite set_map_inter with (d := _ \₁ _).
    apply set_subset_inter_r. split; [| basic_solver].
    red. ins. red. red in H. apply ENUM_E. vauto. }
  { red. ins. forward eapply sb_total with (a := a) (b := b0) (t := t) as SB;
      try by (generalize IWa; generalize IWb; vauto || basic_solver).
    unfolder in IWa. unfolder in IWb. desc.
    des; [left | right]; split; congruence. }
  { by apply CON. }
  { by apply fsupp_sb_loc. }

  apply hb_po_loc_hb.
Qed.

End immToPowerFairness.


Require Import VST.progs.conclib.
Require Import VST.progs.ghost.
(*Require Import VST.progs.list_dt. Import LsegSpecial.*)
Require Import VST.floyd.library.
Require Import VST.progs.lock_coupling.
Require Import Sorting.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).

Definition surely_malloc_spec :=
 DECLARE _surely_malloc
   WITH n:Z
   PRE [ _n OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh n p * memory_block Tsh n p).

Definition tnode := Tstruct _node noattr.

Module ZOrder <: Orders.TotalLeBool.
  Definition t := Z.
  Definition leb x y := Z.leb x y.
  Theorem leb_total : forall x y, leb x y = true \/ leb y x = true.
  Proof. intros; destruct (Zle_bool_total x y); auto. Qed.
End ZOrder.

Module Import ZSort := Sort ZOrder.

Lemma StronglySorted_imp : forall (R R' : Z -> Z -> Prop) l (HR' : forall x y, R x y -> R' x y)
  (HR : StronglySorted R l), StronglySorted R' l.
Proof.
  intros; induction HR; constructor; auto.
  eapply Forall_impl, H; auto.
Qed.

Notation sorted := (StronglySorted Z.le).

Lemma sort_sorted : forall l, sorted (sort l).
Proof.
  intro; eapply StronglySorted_imp, StronglySorted_sort.
  - intros.
    rewrite <- Z.leb_le; auto.
  - intros ???; apply Zle_bool_trans.
Qed.

Inductive set_op := Add (e : Z) | Remove (e : Z).

Fixpoint apply_hist S h :=
  match h with
  | [] => S
  | Add e :: h' => if in_dec Z_eq_dec e S then apply_hist S h' else apply_hist (sort (e :: S)) h'
  | Remove e :: h' => apply_hist (remove Z_eq_dec e S) h'
  end.

Lemma apply_hist_app : forall h1 S h2, apply_hist S (h1 ++ h2) = apply_hist (apply_hist S h1) h2.
Proof.
  induction h1; auto; simpl; intros.
  destruct a; auto.
  destruct (in_dec _ _ _); auto.
Qed.

(* up *)
Lemma In_remove : forall A (a : A) dec l, incl (remove dec a l) l.
Proof.
  induction l; simpl; auto.
  destruct (dec a a0).
  - apply incl_tl; auto.
  - apply incl_same_head; auto.
Qed.

Lemma remove_sorted : forall a l, sorted l -> sorted (remove Z_eq_dec a l).
Proof.
  induction l; auto; simpl; intro.
  inv H.
  destruct (Z.eq_dec a a0); auto.
  constructor; auto.
  rewrite Forall_forall in *; intros ? Hin.
  apply In_remove in Hin; auto.
Qed.

Lemma apply_hist_sorted : forall h S, sorted S -> sorted (apply_hist S h).
Proof.
  induction h; auto; simpl; intros.
  destruct a.
  - destruct (in_dec _ _ _); auto.
    apply IHh, sort_sorted.
  - apply IHh, remove_sorted; auto.
Qed.

Definition hist := hist_part set_op.

(*Definition q_lock_pred' (t : type) P p (vals : list (val * reptype t)) head (addc remc : val) lock gsh h :=
  !!(Zlength vals <= MAX /\ 0 <= head < MAX /\ consistent h [] vals) &&
  (data_at Tsh tqueue (rotate (complete MAX (map fst vals)) head MAX, (vint (Zlength vals),
                      (vint head, (vint ((head + Zlength vals) mod MAX), (addc, remc))))) p *
   cond_var Tsh addc * cond_var Tsh remc * malloc_token Tsh (sizeof tqueue_t) p *
   malloc_token Tsh (sizeof tcond) addc * malloc_token Tsh (sizeof tcond) remc *
   malloc_token Tsh (sizeof tlock) lock * ghost gsh (Tsh, h) p *
   fold_right sepcon emp (map (fun x => let '(p, v) := x in
     !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals)).

Definition q_lock_pred A P p lock gsh := EX vals : list (val * reptype A), EX head : Z,
  EX addc : val, EX remc : val, EX h : hist _, q_lock_pred' A P p vals head addc remc lock gsh h.*)

Definition node_lock_inv e p := EX n : val, EX l : val,(*EX h : list set_op,*)
  field_at Tsh tnode [StructField _val] (vint e) p *
  field_at Tsh tnode [StructField _next] n p * field_at Tsh tnode [StructField _lock] l n *
  node_lock_inv.

Definition node_pred sh e p := EX l : val,
  !!((*sepalg.join gsh1 gsh2 Tsh /\*) repable_signed e /\ field_compatible tnode [] p) &&
  (field_at sh tnode [StructField _lock] l p *
   lock_inv sh l (node_lock_inv e p) (* * ghost gsh1 (lsh, h) p*)).

Definition new_node_spec :=
 DECLARE _new_node
  WITH e : Z
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e))
   SEP ()
  POST [ tptr tnode ]
   EX p : val,
   PROP ()
   LOCAL (temp ret_temp p)
   SEP (node_pred Tsh e p).

Definition del_node_spec :=
 DECLARE _new_node
  WITH e : Z, p : val
  PRE [ _n OF tptr tnode ]
   PROP ()
   LOCAL (temp _n p)
   SEP (node_pred Tsh e p)
  POST [ tvoid ]
   PROP ()
   LOCAL ()
   SEP ().

Definition tnode_pair := Tstruct _node_pair noattr.

Definition list_inv sh H h := node_pred sh Int.min_signed H * ghost_hist h H.

Definition locate_spec :=
 DECLARE _locate
  WITH e : Z, sh : share, H : val, h : hist
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e); gvar _head H)
   SEP (list_inv sh H h)
  POST [ tptr tnode_pair ]
   EX h' : hist, EX p : val, EX n1 : val, EX n2 : val, EX e1 : Z, EX e2 : Z, EX sh : share,
   PROP (incl h h'; e1 < e <= e2)
   LOCAL ()
   SEP (list_inv H h'; data_at Tsh tnode_pair (n1, n2) p; node_pred sh e1 n1;
        field_at Tsh tnode [StructField _val] (vint e1) n1; field_at Tsh tnode [StructField _next] n2 n1;
        node_pred sh e2 n2; node_lock_inv e2 n2).

Definition add_spec :=
 DECLARE _add
  WITH e : Z, H : val, h : hist
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e); gvar _head H)
   SEP (list_inv H h)
  POST [ tint ]
   EX h' : hist, EX S : list Z, EX t' : nat,
   PROP (incl h h'; apply_hist [] h' = S)
   LOCAL (temp ret_temp (if in_dec Z_eq_dec e S then 0 else 1))
   SEP (list_inv H (h' ++ [(t', Add e)]).

Definition remove_spec :=
 DECLARE _remove
  WITH e : Z, H : val, h : hist
  PRE [ _e OF tint ]
   PROP (repable_signed e)
   LOCAL (temp _e (vint e); gvar _head H)
   SEP (list_inv H h)
  POST [ tint ]
   EX h' : hist, EX S : list Z, EX t' : nat,
   PROP (incl h h'; apply_hist [] h' = S)
   LOCAL (temp ret_temp (if in_dec Z_eq_dec e S then 1 else 0))
   SEP (list_inv H (h' ++ [(t', Remove e)]).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Gprog : funspecs :=   ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
  freelock_spec; surely_malloc_spec; new_node_spec; del_node_spec; locate_spec; add_spec; remove_spec; main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     n.
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (malloc_token Tsh n p * memory_block Tsh n p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. inv H0.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma ctr_inv_precise : forall p,
  precise (cptr_lock_inv p).
Proof.
  intro; eapply derives_precise, data_at__precise with (sh := Ews)(t := tint); auto.
  intros ? (? & H); apply data_at_data_at_ in H; eauto.
Qed.
Hint Resolve ctr_inv_precise.

Lemma ctr_inv_positive : forall ctr,
  positive_mpred (cptr_lock_inv ctr).
Proof.
  intro; apply ex_positive; auto.
Qed.
Hint Resolve ctr_inv_positive.

Lemma body_incr: semax_body Vprog Gprog f_incr incr_spec.
Proof.
  start_function.
  forward.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  unfold cptr_lock_inv at 2; simpl.
  Intro z.
  forward.
  forward.
  rewrite field_at_isptr; Intros.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    unfold cptr_lock_inv; Exists (z + 1); entailer!. }
  forward.
Qed.

Lemma body_read : semax_body Vprog Gprog f_read read_spec.
Proof.
  start_function.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  unfold cptr_lock_inv at 2; simpl.
  Intro z.
  forward.
  rewrite data_at_isptr; Intros.
  forward_call (lock, sh, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    unfold cptr_lock_inv; Exists z; entailer!. }
  forward.
  Exists z; entailer!.
Qed.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  Intros.
  forward.
  forward_call (ctr, sh, lock).
  forward_call (lockt, sh, lock_inv sh lock (cptr_lock_inv ctr), thread_lock_inv sh ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { unfold thread_lock_inv; lock_props.
    rewrite selflock_eq at 2; cancel.
    eapply derives_trans; [apply lock_inv_later | cancel]. }
  forward.
Qed.

Lemma lock_struct : forall p, data_at_ Ews (Tstruct _lock_t noattr) p |-- data_at_ Ews tlock p.
Proof.
  intros.
  unfold data_at_, field_at_; unfold_field_at 1%nat.
  unfold field_at; simpl.
  rewrite field_compatible_cons; simpl; entailer.
  (* temporarily broken *)
Admitted.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  name ctr _ctr; name lockt _thread_lock; name lock _ctr_lock.
  start_function.
  forward.
  forward.
  forward.
  forward_call (lock, Ews, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { rewrite (sepcon_comm _ (fold_right_sepcon _)); apply sepcon_derives; [cancel | apply lock_struct]. }
  rewrite field_at_isptr; Intros.
  forward_call (lock, Ews, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    unfold cptr_lock_inv; Exists 0; cancel. }
  (* need to split off shares for the locks here *)
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  forward_call (lockt, Ews, thread_lock_inv sh1 ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { rewrite (sepcon_comm _ (fold_right_sepcon _)); apply sepcon_derives; [cancel | apply lock_struct]. }
  get_global_function'' _thread_func.
  apply extract_exists_pre; intros f_.
  forward_spawn (val * share * val * val)%type (f_, Vint (Int.repr 0), (ctr, sh1, lock, lockt),
    fun (x : (val * share * val * val)) (_ : val) => let '(ctr, sh, lock, lockt) := x in
         !!readable_share sh && emp * lock_inv sh lock (cptr_lock_inv ctr) *
         lock_inv sh lockt (thread_lock_inv sh ctr lock lockt)).
  { simpl spawn_pre; entailer!.
    Exists _args (fun x : val * share * val * val => let '(ctr, sh, lock, lockt) := x in
      [(_ctr, ctr); (_ctr_lock, lock); (_thread_lock, lockt)]); entailer.
    rewrite !sepcon_assoc; apply sepcon_derives.
    { apply derives_refl'. f_equal.
      unfold NDmk_funspec.
      apply mk_funspec_congr; auto.
      apply eq_JMeq.
      extensionality x x0.
      destruct x0 as (?, (((?, ?), ?), ?)); simpl.
      rewrite <- !sepcon_assoc; reflexivity.  }
    erewrite <- lock_inv_share_join; try apply Hsh; auto.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto.
    entailer!. }
  forward_call (ctr, sh2, lock).
  forward_call (lockt, sh2, thread_lock_inv sh1 ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  forward_call (ctr, sh2, lock).
  Intro z.
  forward_call (lock, sh2, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  forward_call (lockt, Ews, sh1, |>lock_inv sh1 lock (cptr_lock_inv ctr), |>thread_lock_inv sh1 ctr lock lockt).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { unfold thread_lock_inv; lock_props.
    - apply later_positive; auto.
    - unfold rec_inv.
      rewrite selflock_eq at 1.
      rewrite later_sepcon; f_equal.
      apply lock_inv_later_eq.
    - rewrite selflock_eq at 2.
      erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel.
      rewrite sepcon_comm, <- !sepcon_assoc, sepcon_comm.
      apply sepcon_derives; [apply lock_inv_later | cancel]. }
  forward_call (lock, Ews, cptr_lock_inv ctr).
  { apply prop_right; rewrite sem_cast_neutral_ptr; rewrite sem_cast_neutral_ptr; auto. }
  { lock_props.
    erewrite sepcon_assoc, lock_inv_share_join; eauto; cancel. }
  forward.
Qed.

Definition extlink := ext_link_prog prog.

Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons body_incr.
semax_func_cons body_read.
semax_func_cons body_thread_func.
semax_func_cons body_main.
Qed.