Load loadpath.
Require Import ssreflect ssrbool eqtype ssrnat ssrfun seq.
Require Import prelude heaps rels hprop domains secmod seclog.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**************************************************************)
(* an overloaded lemma that selects the val_* or bind_* lemma *)
(* to apply when appropriate, during symbolic evaluation      *)             
(**************************************************************)

Local Notation cont1 A := (A -> heap -> Prop). 
Local Notation cont2 A := (A -> A -> heap -> heap -> Prop). 

(*****************************************)
(* normalize programs wrt instantiations *)
(*****************************************)

Module Normalize.

Section Defs.

Structure init_tagged_ST A := InitTag {init_untag : ST [:::] A}.
Local Coercion init_untag : init_tagged_ST >-> ST. 

Definition init_bnd_tag := InitTag.
Canonical init_inst_tag A e := @init_bnd_tag A e.

Definition normalize_axiom A (e1 e2 : ST [:::] A) := 
  (forall i, safe i e1 <-> safe i e2) /\ (runs0 e1 <~> runs0 e2).

Structure normalize A := Normalize {
  normalize_pivot : init_tagged_ST A;
  _ : {e : ST [:::] A | normalize_axiom e normalize_pivot}}. 

Local Coercion normalize_pivot : normalize >-> init_tagged_ST.

(* inst state; the head of the expression is inst *)
Structure inst_tagged_ST As A := InstTag {inst_untag :> ST As A}.
Definition inst_bnd_tag := InstTag.
Canonical inst_inst_tag As A e := @inst_bnd_tag As A e.

Structure inst_form As A := Inst_Form {
  inst_pivot :> inst_tagged_ST As A;
  _ : {e : args As -> ST [:::] A | 
       forall a, normalize_axiom (e a) (inst_pivot @0 a)}}.

Definition inst_norm As A (e : @inst_form As A) :=
  let: Inst_Form _ (exist p _) := e in p.

(* bnd_state; the head of the expression is bnd *)
(* and the left sequent is an inst *)
Structure bnd_tagged_ST As B := BndTag {bnd_untag :> ST As B}.
Canonical bnd_bnd_tag As B e := @BndTag As B e.

Structure bnd_form As A B := Bnd_Form {
  bnd_pivot :> bnd_tagged_ST As B; 
  _ : {e : args As -> ST [::: B] A -> ST [:::] A | 
       forall b e', normalize_axiom (e b e') (bnd_pivot @0 b;; e')}}.        

Definition bnd_norm As A B (e : @bnd_form As A B) := 
  let: Bnd_Form _ (exist p _) := e in p.

(* transitions *)

(* if the main constructor is inst or bnd with an inst *) 
(* then branch to an appropriate state *)
(* otherwise, we have reached normal form, so accept *)

Lemma init_inst_pf As A (a : args As) (e : inst_form As A) : 
        normalize_axiom (inst_norm e a) (init_inst_tag (e @0 a)).
Proof. by case: e; case=>e1 [/=]. Qed.

Canonical init_inst As A a (e : inst_form As A) := 
  Normalize (exist _ (inst_norm e a) (@init_inst_pf As A a e)). 

Lemma init_bnd_pf As A B b e' (e : bnd_form As A B) : 
        normalize_axiom (bnd_norm e b e') (init_bnd_tag (e @0 b;; e')).
Proof. by case: e; case=>e1 [/=]. Qed.

Canonical init_bnd As A B b e' e := 
  Normalize (exist _ (bnd_norm e b e') (@init_bnd_pf As A B b e' e)).

Lemma init_accept_pf A (e : ST [:::] A) : normalize_axiom e (InitTag e).
Proof. by []. Qed.

Canonical init_accept A e := 
  Normalize (exist (fun x => normalize_axiom x (InitTag e)) e 
            (@init_accept_pf A e)).

(* loop in inst as long as the secondary constructor is inst *)
(* keep pushing that inst outward *)
(* if the secondary constructor becomes bnd, move into bnd state *)
(* if the secondary constructor becomes something else, accept *)

Lemma inst_inst_pf As Bs A f (e : inst_form Bs A) (a : args As) :
        normalize_axiom (inst_norm e (fun_app f a)) 
                        (inst_inst_tag (e @ f) @0 a).
Proof. 
case: e; case=>e1 [e2] /=; case/(_ (fun_app f a))=>H1 H2.
split; last by rewrite H2 !inst_runs inst_assoc.
by move=>i; rewrite H1 /Defs.safe' !instE /= instE /= fun_beta.
Qed.

Canonical inst_inst As Bs A f e :=
  Inst_Form (exist _ (fun a => inst_norm e (fun_app f a)) 
                     (@inst_inst_pf As Bs A f e)).

Lemma inst_bnd_pf As A B (e : bnd_form As A B) (e' : ST (B::As) A) a : 
        normalize_axiom (bnd_norm e a (e' @1 fun x => (x, a))) 
                        (inst_bnd_tag (e ;; e') @0 a).
Proof.
case: e; case=>e1 [e2] /=; case/(_ a (e' @1 fun x => (x, a)))=>H1 H2.
split; last by rewrite H2 inst_runs -bindR.
move=>i; rewrite H1 /Defs.safe' /= bindE instE /=.
by rewrite !instE /= bindE /= fun_beta.
Qed.
     
Canonical inst_bnd As A B (e : bnd_form As A B) (e' : ST (B::As) A) :=
  Inst_Form (exist _ (fun a => bnd_norm e a (e' @1 fun x => (x, a)))
                     (@inst_bnd_pf As A B e e')). 

Lemma inst_accept_pf As A (e : ST As A) (a : args As) :
        normalize_axiom (e @0 a) (InstTag e @0 a).
Proof.
split; last by rewrite inst_runs.
by move=>i; rewrite /Defs.safe' instE.
Qed.

Canonical inst_accept As A e :=
  Inst_Form (exist _ (fun a => e @0 a) (@inst_accept_pf As A e)).

(* loop in bnd state while the secondary branch constructor is inst *)

Lemma bnd_bnd_pf As Bs A B f (e : bnd_form As A B) (b : args Bs) e' :
        normalize_axiom (bnd_norm e (fun_app f b) e') 
                        (bnd_bnd_tag (e @ f) @0 b ;; e').
Proof. 
case: e; case=>e1 [e2] /=; case/(_ (fun_app f b) e')=>H1 H2.
split; last by rewrite H2 bndP.
move=>i; rewrite H1 /Defs.safe' !bindE /= !instE /= instE /=.
by rewrite fun_beta dfun_beta dargs_beta1 dargs_beta2.
Qed.

Canonical bnd_bnd As Bs A B f e :=
  Bnd_Form (exist _ (fun b e' => bnd_norm e (fun_app f b) e')
                    (@bnd_bnd_pf As Bs A B f e)).

(* otherwise accept *)

Lemma bnd_accept_pf As A B (e : ST As B) a (e' : ST [::: B] A) :
        normalize_axiom (e @0 a ;; e') (BndTag e @0 a ;; e'). 
Proof. by []. Qed.

Canonical bnd_accept As A B e := 
  Bnd_Form (exist _ (fun a e' => e @0 a ;; e') (@bnd_accept_pf As A B e)).

End Defs.

Module Exports.

Notation normalize := Normalize.normalize.
Coercion normalize_pivot : normalize >-> Normalize.init_tagged_ST.
Coercion init_untag : init_tagged_ST >-> ST.

Definition norm A (e : normalize A) := 
  let: Normalize _ (exist p _) := e in p.

Canonical init_inst_tag.
Canonical inst_inst_tag.
Canonical bnd_bnd_tag.
Canonical init_inst.
Canonical init_bnd.
Canonical init_accept.
Canonical inst_inst.
Canonical inst_bnd.
Canonical inst_accept.
Canonical bnd_bnd.
Canonical bnd_accept.

End Exports.

End Normalize.

Export Normalize.Exports.

(******************************************************************)
(* Simplification routines                                        *)
(*                                                                *)
(* Normalize expressions, but don't bother with lemma selection.  *)
(******************************************************************)

(* safety *)

Module SafeSimpl.

(* initial state *)
Structure init_form A (e : ST [:::] A) := Init_Form {
  init_pivot :> heap;
  _ : {p : Prop | p -> safe init_pivot e}}.

Definition init_prop A e (i : @init_form A e) := 
  let: Init_Form _ (exist p _) := i in p.

Lemma init_accept_pf A (e : ST [:::] A) i : 
        safe i e -> safe i e. 
Proof. by []. Qed.

Canonical init_accept A e i := 
  Init_Form (exist _ _ (@init_accept_pf A e i)).

Module Exports.

Canonical init_accept.

Lemma ssimpl A (e : normalize A) (i : @init_form A (norm e)) : 
        init_prop i -> safe i e.
Proof. by case: e i=>e [e'][H _][i'][p] /= X; move/X; move/H. Qed.

End Exports.

End SafeSimpl.

Export SafeSimpl.Exports.

(* verify *)

Module VerifySimpl.

(* initial state *)
Structure init_form A (e : ST [:::] A) := 
  Init_Form {init_pivot :> cont1 A;
             _ : {p : heap -> Prop | 
                  forall i, p i -> verify i e init_pivot}}.

Definition init_prop A e (r : @init_form A e) := 
  let: Init_Form _ (exist p _) := r in p.

Lemma init_accept_pf A e (r : cont1 A) i : 
        verify i e r -> verify i e r.
Proof. by []. Qed.

Canonical init_accept A e r := 
  Init_Form (exist _ _ (@init_accept_pf A e r)).

Module Exports.

Canonical init_accept.

Lemma vsimpl A i (e : normalize A) (r : @init_form A (norm e)) : 
        init_prop r i -> verify i e r.
Proof.
case: e r=>e [e'][_ H] /= [r][r'] /= X.
by move/X=>{X} H' D y m; move/H; apply: H'.
Qed.

End Exports.

End VerifySimpl.

Export VerifySimpl.Exports.

(* verify2 *)

Module Verify2Simpl.

(* initial state *)
Structure init_form A (e1 e2 : ST [:::] A) := 
  Init_Form {init_pivot :> cont2 A;
             _ : {p : heap -> heap -> Prop | 
                  forall i j, p i j -> verify2 i j e1 e2 init_pivot}}.

Definition init_prop A e1 e2 (r : @init_form A e1 e2) := 
  let: Init_Form _ (exist p _) := r in p.

Lemma init_accept_pf A e1 e2 (r : cont2 A) i j : 
        verify2 i j e1 e2 r -> verify2 i j e1 e2 r.
Proof. by []. Qed.

Canonical init_accept A e1 e2 r := 
  Init_Form (exist _ _ (@init_accept_pf A e1 e2 r)).

Module Exports.

Canonical init_accept.

Lemma v2simpl A i j (e1 e2 : normalize A) 
        (r : @init_form A (norm e1) (norm e2)) : 
        init_prop r i j -> verify2 i j e1 e2 r.
Proof.
case: e1 e2 r=>e1 [e1'][_ H1][e2][e2'][_ H2][r][r'] /= X.
move/X=>{X} H D1 D2 y1 y2 m1 m2; move/H1=>S1; move/H2=>S2.
by apply: H S1 S2.
Qed.

End Exports.

End Verify2Simpl.

Export Verify2Simpl.Exports.

(*******************************************)
(* Stepping routines                       *)
(*                                         *)
(* Normalize, then select a lemma to apply *)
(*******************************************)

(* safety *)

Module SafeStep. 

Structure tagged_heap := TagHeap {untag_heap :> heap}.
Canonical inst_tag h := @TagHeap h.

Structure init_form A (e : ST [:::] A) := 
  Init_Form {init_pivot :> tagged_heap; 
             _ : {p : Prop | p -> safe init_pivot e}}. 

Definition init_prop A e (i : @init_form A e) := 
  let: Init_Form _ (exist p _) := i in p.

(* temporary structure to get a to appear before e *)
(* can this be simplified by some lighter tagging? *)
Structure val_temp_form As A (a : args As) (e : ST As A) := Val_Temp {
  val_tpivot :> tagged_heap;
  _ : {p : Prop | p -> safe val_tpivot (e @0 a)}}.

Definition val_temp_prop As A a e (i : @val_temp_form As A a e) := 
  let: Val_Temp _ (exist p _) := i in p.

(* switch from init to the temporary inst structure *)
Lemma init_val_temp_pf As A a (e : ST As A) 
                   (i : @val_temp_form As A a e) :
        val_temp_prop i -> safe (inst_tag i) (e @0 a).
Proof. by case: i=>i []. Qed.

Canonical init_val_temp As A a e i :=
  Init_Form (exist _ _ (@init_val_temp_pf As A a e i)).

(* and now from the temporary structure to the real one *)
Structure val_form As A (a : args As) i := Val_Form {
  val_pivot :> ST As A;
  _ : {p :  Prop | p -> safe i (val_pivot @0 a)}}.

Definition val_prop As A a i (e : @val_form As A a i) := 
  let: Val_Form _ (exist p _) := e in p.

Lemma init_val_pf As A a i (e : @val_form As A a i) :
        val_prop e -> safe i (e @0 a).
Proof. by case: e=>e [p]; apply. Qed.

Canonical init_val As A a i e :=
  Val_Temp (exist _ _ (@init_val_pf As A a i e)).

(* temporary structure for bind, to get a and e' to appear before e *)
Structure bnd_temp_form As A B a (e' : ST [::: B] A) (e : ST As B) :=
  Bnd_Temp {
    bnd_tpivot :> tagged_heap;
    _ : {p : Prop | p -> safe bnd_tpivot (e @0 a ;; e')}}.

Definition bnd_temp_prop As A B a e' e (i : @bnd_temp_form As A B a e' e) := 
  let: Bnd_Temp _ (exist p _) := i in p.

(* switch from init to the temporary bnd structure in case of bnd *)
Lemma init_bnd_temp_pf As A B a e' e (i : @bnd_temp_form As A B a e' e) :
        bnd_temp_prop i -> 
        safe (TagHeap i) (e @0 a ;; e').
Proof. by case: i=>i []. Qed.

Canonical init_bnd_temp As A B a e' e i :=  
  Init_Form (exist _ _ (@init_bnd_temp_pf As A B a e' e i)).

(* and then from the temporary structure to the real one *)
Structure bnd_form As A B a (e' : ST [::: B] A) i := Bnd_Form {
  bnd_pivot :> ST As B;
  _ : {p : Prop | p -> safe i (bnd_pivot @0 a ;; e')}}.

Definition bnd_prop As A B a e' i (e : @bnd_form As A B a e' i) := 
  let: Bnd_Form _ (exist p _) := e in p.

Lemma init_bnd_pf As A B a e' i 
                  (e : @bnd_form As A B a e' i) :
        bnd_prop e -> safe i (e @0 a ;; e').
Proof. by case: e=>e [p]; apply. Qed.

Canonical init_bnd As A B a e' i e :=  
  Bnd_Temp (exist _ _ (@init_bnd_pf As A B a e' i e)).

Module Exports.

Canonical inst_tag.
Canonical init_val_temp.
Canonical init_val.
Canonical init_bnd_temp.
Canonical init_bnd.

Lemma sstep A (e : normalize A) (i : @init_form A (norm e)) : 
        init_prop i -> safe i e.
Proof. by case: e i=>e [e'] /= [H _][i'][p] /= X; move/X; move/H. Qed.

Notation SVal_Form p := (SafeStep.Val_Form (exist _ _ p)).
Notation SBnd_Form p := (SafeStep.Bnd_Form (exist _ _ p)).

End Exports.

End SafeStep.

Export SafeStep.Exports.

(* verify *)

Module VerifyStep. 

Structure tagged_cont1 A := TagCont {untag_cont :> cont1 A}.
Canonical inst_tag A r := @TagCont A r.

Structure init_form A i (e : ST [:::] A) := 
  Init_Form {init_pivot :> tagged_cont1 A; 
             _ : {p : Prop | p -> verify i e init_pivot}}. 

Definition init_prop A i  e (r : @init_form A i e) := 
  let: Init_Form _ (exist p _) := r in p.

(* temporary structure to get a to appear before e *)
(* can this be simplified by some lighter tagging? *)
Structure val_temp_form As A i (a : args As) e := Val_Temp {
  val_tpivot :> cont1 A;
  _ : {p : Prop | p -> verify i (e @0 a) val_tpivot}}.

Definition val_temp_prop As A i a e (r : @val_temp_form As A i a e) := 
  let: Val_Temp _ (exist p _) := r in p.

(* switch from init to the temporary inst structure *)
Lemma init_val_temp_pf As A i a (e : ST As A) 
                   (r : @val_temp_form As A i a e) :
        val_temp_prop r -> verify i (e @0 a) (inst_tag r).
Proof. by case: r=>r []. Qed.

Canonical init_val_temp As A i a e r :=
  Init_Form (exist _ _ (@init_val_temp_pf As A i a e r)).

(* and now from the temporary structure to the real one *)
(* pushing i after a, so that searching through the heap *)
(* happens only after the args have been resolved *)
(* eventually push a e i inside the structure *)
(* they are just taking parameter space now, but I don't *)
(* want to bother with anonymizing projections *)
Structure val_form As A (a : args As) i := Val_Form {
  val_pivot :> ST As A;
  _ : {p : cont1 A -> Prop | 
       forall r, p r -> 
         verify i (val_pivot @0 a) r}}.

Definition val_prop As A a i (e : @val_form As A a i) := 
  let: Val_Form _ (exist p _) := e in p.

Lemma init_val_pf As A a i (e : @val_form As A a i) r :
        val_prop e r -> verify i (e @0 a) r.
Proof. by case: e=>e [p]; apply. Qed.

Canonical init_val As A a i e r :=
  Val_Temp (exist _ _ (@init_val_pf As A a i e r)).

(* temporary structure for bind, to get a and e' to appear before e *)
Structure bnd_temp_form As A B i a e' (e : ST As B) :=
  Bnd_Temp {
    bnd_tpivot :> cont1 A;
    _ : {p : Prop | p -> verify i (e @0 a ;; e') bnd_tpivot}}.

Definition bnd_temp_prop As A B i a e' e
             (r : @bnd_temp_form As A B i a e' e) := 
  let: Bnd_Temp _ (exist p _) := r in p.

(* switch from init to the temporary bnd structure in case of bnd *)
Lemma init_bnd_temp_pf As A B i a e' e 
          (r : @bnd_temp_form As A B i a e' e) :
        bnd_temp_prop r -> verify i (e @0 a ;; e') (TagCont r).
Proof. by case: r=>r []. Qed.

Canonical init_bnd_temp As A B i a e' e r :=  
  Init_Form (exist _ _ (@init_bnd_temp_pf As A B i a e' e r)).

(* and then from the temporary structure to the real one *)
Structure bnd_form As A B a e' i := Bnd_Form {
  bnd_pivot :> ST As B;
  _ : {p : cont1 A -> Prop | 
         forall r, p r -> verify i (bnd_pivot @0 a ;; e') r}}.

Definition bnd_prop As A B a e' i 
             (e : @bnd_form As A B a e' i) := 
  let: Bnd_Form _ (exist p _) := e in p.

Lemma init_bnd_pf As A B a e' i (e : @bnd_form As A B a e' i) r :
        bnd_prop e r -> verify i (e @0 a ;; e') r.
Proof. by case: e=>e [p]; apply. Qed.

Canonical init_bnd As A B a e' e i r :=  
  Bnd_Temp (exist _ _ (@init_bnd_pf As A B a e' e i r)).

Module Exports.

Canonical inst_tag.
Canonical init_val_temp.
Canonical init_val.
Canonical init_bnd_temp.
Canonical init_bnd.

Lemma vstep A i (e : normalize A) (r : @init_form A i (norm e)) : 
        init_prop r -> verify i e r.
Proof.
case: e r=>e [e'][_ H1][r][r'] /= X.
by move/X=>{X} H D y m; move/H1=>S1; apply: H S1.
Qed.

Notation Val_Form p := (VerifyStep.Val_Form (exist _ _ p)).
Notation Bnd_Form p := (VerifyStep.Bnd_Form (exist _ _ p)).

End Exports.

End VerifyStep.

Export VerifyStep.Exports.

(* verify2 *)

Module Verify2Step. 

Structure tagged_cont2 A := TagCont {untag_cont :> cont2 A}.
Canonical inst_tag A r := @TagCont A r.

Structure init_form A i j (e1 e2 : ST [:::] A) := 
  Init_Form {init_pivot :> tagged_cont2 A; 
             _ : {p : Prop | p -> verify2 i j e1 e2 init_pivot}}. 

Definition init_prop A i j e1 e2 (r : @init_form A i j e1 e2) := 
  let: Init_Form _ (exist p _) := r in p.

(* temporary structure to get a2 to appear before e2 *)
(* can this be simplified by some lighter tagging? *)
Structure val_temp_form As A i j (a1 a2 : args As) e1 e2 := Val_Temp {
  val_tpivot :> cont2 A;
  _ : {p : Prop | p -> verify2 i j (e1 @0 a1) (e2 @0 a2) val_tpivot}}.

Definition val_temp_prop As A i j a1 a2 e1 e2 
                         (r : @val_temp_form As A i j a1 a2 e1 e2) := 
  let: Val_Temp _ (exist p _) := r in p.

(* switch from init to the temporary inst structure *)
Lemma init_val_temp_pf As A i j a1 a2 (e1 e2 : ST As A) 
                   (r : @val_temp_form As A i j a1 a2 e1 e2) :
        val_temp_prop r -> verify2 i j (e1 @0 a1) (e2 @0 a2) (inst_tag r).
Proof. by case: r=>r []. Qed.

Canonical init_val_temp As A i j a1 a2 e1 e2 r :=
  Init_Form (exist _ _ (@init_val_temp_pf As A i j a1 a2 e1 e2 r)).

(* and now from the temporary structure to the real one *)
(* pushing i j after a1 a2, so that seacrhing through the heap *)
(* happens only after the args have been resolved *)
(* eventually push a1 a2 e1 i j inside the structure *)
(* they are just taking parameter space now, but I don't *)
(* want to bother with anonymizing projections *)
Structure val_form As A (a1 a2 : args As) e1 i j := Val_Form {
  val_pivot :> ST As A;
  _ : {p : cont2 A -> Prop | 
       forall r, p r -> 
         verify2 i j (e1 @0 a1) (val_pivot @0 a2) r}}.

Definition val_prop As A a1 a2 e1 i j (e2 : @val_form As A a1 a2 e1 i j) := 
  let: Val_Form _ (exist p _) := e2 in p.

Lemma init_val_pf As A a1 a2 e1 i j (e2 : @val_form As A a1 a2 e1 i j) r :
        val_prop e2 r -> verify2 i j (e1 @0 a1) (e2 @0 a2) r.
Proof. by case: e2=>e2 [p]; apply. Qed.

Canonical init_val As A a1 a2 e1 i j e2 r :=
  Val_Temp (exist _ _ (@init_val_pf As A a1 a2 e1 i j e2 r)).

(* temporary structure for bind, to get a2 and e2' to appear before e2 *)
Structure bnd_temp_form As A B i j a1 a2 e1' e2' (e1 e2 : ST As B) :=
  Bnd_Temp {
    bnd_tpivot :> cont2 A;
    _ : {p : Prop | p -> verify2 i j (e1 @0 a1 ;; e1') 
                                     (e2 @0 a2 ;; e2') bnd_tpivot}}.

Definition bnd_temp_prop As A B i j a1 a2 e1' e2' e1 e2
             (r : @bnd_temp_form As A B i j a1 a2 e1' e2' e1 e2) := 
  let: Bnd_Temp _ (exist p _) := r in p.

(* switch from init to the temporary bnd structure in case of bnd *)
Lemma init_bnd_temp_pf As A B i j a1 a2 e1' e2' e1 e2 
          (r : @bnd_temp_form As A B i j a1 a2 e1' e2' e1 e2) :
        bnd_temp_prop r -> 
        verify2 i j (e1 @0 a1 ;; e1') (e2 @0 a2 ;; e2') (TagCont r).
Proof. by case: r=>r []. Qed.

Canonical init_bnd_temp As A B i j a1 a2 e1' e2' e1 e2 r :=  
  Init_Form (exist _ _ (@init_bnd_temp_pf As A B i j a1 a2 e1' e2' e1 e2 r)).

(* and then from the temporary structure to the real one *)
Structure bnd_form As A B a1 a2 e1' e2' (e1 : ST As B) i j := Bnd_Form {
  bnd_pivot :> ST As B;
  _ : {p : cont2 A -> Prop | 
         forall r, p r -> 
           verify2 i j (e1 @0 a1 ;; e1') (bnd_pivot @0 a2 ;; e2') r}}.

Definition bnd_prop As A B a1 a2 e1' e2' e1 i j
             (e2 : @bnd_form As A B a1 a2 e1' e2' e1 i j) := 
  let: Bnd_Form _ (exist p _) := e2 in p.

Lemma init_bnd_pf As A B a1 a2 e1' e2' e1 i j
                  (e2 : @bnd_form As A B a1 a2 e1' e2' e1 i j) r :
        bnd_prop e2 r -> 
        verify2 i j (e1 @0 a1 ;; e1') (e2 @0 a2 ;; e2') r.
Proof. by case: e2=>e2 [p]; apply. Qed.

Canonical init_bnd As A B a1 a2 e1' e2' e1 i j e2 r :=  
  Bnd_Temp (exist _ _ (@init_bnd_pf As A B a1 a2 e1' e2' e1 i j e2 r)).

Module Exports.

Canonical inst_tag.
Canonical init_val_temp.
Canonical init_val.
Canonical init_bnd_temp.
Canonical init_bnd.

Lemma v2step A i j  (e1 e2 : normalize A) 
        (r : @init_form A i j (norm e1) (norm e2)) : 
        init_prop r -> verify2 i j e1 e2 r.
Proof.
case: e1 e2 r=>e1 [e1'][_ H1][e2][e2'][_ H2][r][r'] /= X.
move/X=>{X} H D1 D2 y1 y2 m1 m2; move/H1=>S1; move/H2=>S2.
by apply: H S1 S2.
Qed.

Notation Val2_Form p := (Verify2Step.Val_Form (exist _ _ p)).
Notation Bnd2_Form p := (Verify2Step.Bnd_Form (exist _ _ p)).

End Exports.

End Verify2Step.

Export Verify2Step.Exports.

(***************************************)
(* registration of the stepping lemmas *)
(***************************************)

(* safety *)

Lemma sval_retO A (v : A) i : true -> safe i (ret @0 [v]).
Proof. by move=>_; apply: sval_ret. Qed.

Canonical sval_ret_form A v i := 
  SVal_Form (@sval_retO A v i).
Canonical sbnd_ret_form A B s v i := 
  SBnd_Form (@sbnd_ret A B s v i).

Lemma sval_readO A (v : A) x i (f : partition (x :-> v) i) : 
        true -> safe f (read A @0 [x]).
Proof. by rewrite partitionE; move=>_; apply: sval_read. Qed.

Lemma sbnd_readO A B (e : ST [::: A] B) x v i (f : partition (x :-> v) i) :
        safe f (e @0 [v]) -> 
        safe f (read A @0 [x] ;; e).
Proof. by rewrite !partitionE; apply: sbnd_read. Qed.

Canonical sval_read_form A v x i f :=
  SVal_Form (@sval_readO A v x i f).

Canonical sbnd_read_form A B e x v i f :=
  SBnd_Form (@sbnd_readO A B e x v i f).

Lemma sval_writeO A B x i (v : A) (w : B) (f : forall k, partition k i) :
        true -> safe (f (x :-> w)) (write @0 [x, v]). 
Proof. by rewrite !partitionE; move=>_; apply: sval_write. Qed.
 
Lemma sbnd_writeO A1 A2 B (e : ST [::: unit] B) (v : A1) (w : A2) x i 
                  (f : forall k, partition k i) :
        safe (f (x :-> v)) (e @0 [tt]) -> 
        safe (f (x :-> w)) (write @0 [x, v] ;; e).
Proof. by rewrite !partitionE; apply: sbnd_write. Qed.

Canonical sval_write_form A B x i v w f := 
  SVal_Form (@sval_writeO A B x i v w f). 

Canonical sbnd_write_form A1 A2 B e v w x i f := 
  SBnd_Form (@sbnd_writeO A1 A2 B e v w x i f).

Lemma sval_lallocO A (v : A) i : true -> safe i (lalloc @0 [v]).
Proof. by move=>_; apply: sval_lalloc. Qed.

Canonical sval_lalloc_form A v i :=
  SVal_Form (@sval_lallocO A v i).

Canonical sbnd_lalloc_form A B e v i :=
  SBnd_Form (@sbnd_lalloc A B e v i).

Lemma sval_hallocO A (v : A) i : true -> safe i (halloc @0 [v]).
Proof. by move=>_; apply: sval_halloc. Qed.

Canonical sval_halloc_form A v i := 
  SVal_Form (@sval_hallocO A v i).

Canonical sbnd_halloc_form A B e v i := 
  SBnd_Form (@sbnd_halloc A B e v i).

Lemma sval_deallocO A (v : A) x i (f : partition (x :-> v) i) : 
        true -> safe f (dealloc @0 [x]).
Proof. by rewrite partitionE=>_; apply: sval_dealloc. Qed.
 
Lemma sbnd_deallocO A B (e : ST [::: unit] B) (v : A) x i 
                   (f : partition (x :-> v) i) : 
        safe i (e @0 [tt]) -> 
        safe f (dealloc @0 [x] ;; e).
Proof. by rewrite partitionE; apply: sbnd_dealloc. Qed.

Canonical sval_dealloc_form A v x i f :=
  SVal_Form (@sval_deallocO A v x i f).

Canonical sbnd_dealloc_form A B e v x i f := 
  SBnd_Form (@sbnd_deallocO A B e v x i f).

(* verify *)

Canonical val_ret_form A v i := 
  Val_Form (@val_retV A v i).
Canonical vbnd_ret_form A B e v i := 
  Bnd_Form (@bnd_retV A B e v i).

Lemma val_readO A v x i (f : partition (x :-> v) i) (r : cont1 A) :
        (def f -> r v f) -> verify f (read A @0 [x]) r.
Proof. by rewrite !partitionE; apply: val_readV. Qed.

Lemma bnd_readO A B (e : ST [::: A] B) x v i  
          (f : partition (x :-> v) i) r :
        verify f (e @0 [v]) r -> 
        verify f (read A @0 [x] ;; e) r.
Proof. by rewrite !partitionE; apply: bnd_readV. Qed.

Canonical val_read_form A v x i f :=
  Val_Form (@val_readO A v x i f). 

Canonical bnd_read_form A B e x v i f :=
  Bnd_Form (@bnd_readO A B e x v i f) . 

Lemma val_writeO A B x (v : A) (w : B) i 
          (f : forall k, partition k i) (r : cont1 unit) :
        (def (f (x :-> v)) -> r tt (f (x :-> v))) ->
        verify (f (x :-> w)) (write @0 [x, v]) r.
Proof. by rewrite !partitionE; apply: val_writeV. Qed.

Lemma bnd_writeO A A' B (e : ST [::: unit] B) x (v : A) (w : A') i  
                  (f : forall k, partition k i) r :
        verify (f (x :-> v)) (e @0 [tt]) r ->
        verify (f (x :-> w))
               (write @0 [x, v] ;; e) r.
Proof. by rewrite !partitionE; apply: bnd_writeV. Qed.

Canonical val_write_form A B x v w i f := 
  Val_Form (@val_writeO A B x v w i f). 

Canonical bnd_write_form A A' B e x v w i f :=
  Bnd_Form (@bnd_writeO A A' B e x v w i f).

Canonical val_lalloc_form A v i :=
  Val_Form (@val_lallocV A v i).

Canonical bnd_lalloc_form A B e v i :=
  Bnd_Form (@bnd_lallocV A B e v i).

Canonical val_halloc_form A v i :=
  Val_Form (@val_hallocV A v i).

Lemma bnd_hallocO A B (e : ST [::: ptr] B) (v : A) i (r : cont1 B) :
        (forall x : ptr, high x -> verify (x :-> v :+ i) (e @0 [x]) r) ->
        verify i (bind (halloc @0 [v]) e) r.
Proof. by move=>H; apply: bnd_doV=>//= y m [[-> _]][_]; apply: H. Qed.

Canonical bnd_halloc_form A B e v i :=
  Bnd_Form (@bnd_hallocO A B e v i).

Lemma val_deallocO A x (v : A) i (f : partition (x :-> v) i) (r : cont1 unit) :
        (def i -> r tt i) -> verify f (dealloc @0 [x]) r.
Proof. by rewrite partitionE; apply: val_deallocV. Qed.

Lemma bnd_deallocO A B (e : ST [::: unit] B) (x : ptr) (v : A) i 
                   (f : partition (x :-> v) i) r : 
        verify i (e @0 [tt]) r -> 
        verify f (dealloc @0 [x] ;; e) r.
Proof. by rewrite partitionE; apply: bnd_deallocV. Qed.

Canonical val_dealloc_form A x v i f := 
  Val_Form (@val_deallocO A x v i f).

Canonical bnd_dealloc_form A B e x v i f := 
  Bnd_Form (@bnd_deallocO A B e x v i f).
 
(* verify2 *)

Canonical val2_ret_form A v1 v2 i1 i2 := 
  Val2_Form (@val_ret A v1 v2 i1 i2).
Canonical bnd2_ret_form A B e1 e2 v1 v2 i1 i2 := 
  Bnd2_Form (@bnd_ret A B e1 e2 v1 v2 i1 i2).

Lemma val2_readO A v1 v2 x1 x2 i1 i2 
          (f1 : partition (x1 :-> v1) i1) 
          (f2 : partition (x2 :-> v2) i2) (r : cont2 A) :
        (def f1 -> def f2 -> r v1 v2 f1 f2) -> 
        verify2 f1 f2 (read A @0 [x1]) (read A @0 [x2]) r.
Proof. by rewrite !partitionE; apply: val_read. Qed.

Lemma bnd2_readO A B (e1 e2 : ST [::: A] B) x1 x2 v1 v2 i1 i2  
          (f1 : partition (x1 :-> v1) i1) 
          (f2 : partition (x2 :-> v2) i2) r :
        verify2 f1 f2 (e1 @0 [v1]) (e2 @0 [v2]) r -> 
        verify2 f1 f2 (read A @0 [x1] ;; e1) (read A @0 [x2] ;; e2) r.
Proof. by rewrite !partitionE; apply: bnd_read. Qed.

Canonical val2_read_form A v1 v2 x1 x2 i1 i2 f1 f2 :=
  Val2_Form (@val2_readO A v1 v2 x1 x2 i1 i2 f1 f2). 

Canonical bnd2_read_form A B e1 e2 x1 x2 v1 v2 i1 i2 f1 f2 :=
  Bnd2_Form (@bnd2_readO A B e1 e2 x1 x2 v1 v2 i1 i2 f1 f2). 

Lemma val2_writeO A B1 B2 x1 x2 (v1 v2 : A) 
          (w1 : B1) (w2 : B2) i1 i2 
          (f1 : forall k, partition k i1) 
          (f2 : forall k, partition k i2) (r : cont2 unit) :
        (def (f1 (x1 :-> v1)) -> def (f2 (x2 :-> v2)) -> 
           r tt tt (f1 (x1 :-> v1)) (f2 (x2 :-> v2))) ->
        verify2 (f1 (x1 :-> w1)) (f2 (x2 :-> w2))
                (write @0 [x1, v1]) (write @0 [x2, v2]) r.
Proof. by rewrite !partitionE; apply: val_write. Qed.

Lemma bnd2_writeO A A1' A2' B (e1 e2 : ST [::: unit] B) 
          x1 x2 (v1 v2 : A) (w1 : A1') (w2 : A2') i1 i2  
          (f1 : forall k, partition k i1) 
          (f2 : forall k, partition k i2) r :
        verify2 (f1 (x1 :-> v1)) (f2 (x2 :-> v2))
                (e1 @0 [tt]) (e2 @0 [tt]) r ->
        verify2 (f1 (x1 :-> w1)) (f2 (x2 :-> w2))
                (write @0 [x1, v1] ;; e1) (write @0 [x2, v2] ;; e2) r.
Proof. by rewrite !partitionE; apply: bnd_write. Qed.

Canonical val2_write_form A B1 B2 x1 x2 v1 v2 w1 w2 i1 i2 f1 f2 := 
  Val2_Form (@val2_writeO A B1 B2 x1 x2 v1 v2 w1 w2 i1 i2 f1 f2). 

Canonical bnd2_write_form A A1' A2' B e1 e2 x1 x2 v1 v2 w1 w2 i1 i2 f1 f2 :=
  Bnd2_Form (@bnd2_writeO A A1' A2' B e1 e2 x1 x2 v1 v2 w1 w2 i1 i2 f1 f2).

Canonical val2_lalloc_form A v1 v2 i1 i2 := 
  Val2_Form (@val_lalloc A v1 v2 i1 i2).

Canonical bnd2_lalloc_form A B e1 e2 v1 v2 i1 i2 := 
  Bnd2_Form (@bnd_lalloc A B e1 e2 v1 v2 i1 i2).

Canonical val2_halloc_form A v1 v2 i1 i2 := 
  Val2_Form (@val_halloc A A v1 v2 i1 i2).

Canonical bnd2_halloc_form A B e1 e2 v1 v2 i1 i2 := 
  Bnd2_Form (@bnd_halloc A A B e1 e2 v1 v2 i1 i2).

Lemma val2_deallocO A1 A2 (x1 x2 : ptr) (v1 : A1) (v2 : A2) i1 i2 
                    (f1 : partition (x1 :-> v1) i1)
                    (f2 : partition (x2 :-> v2) i2) (r : cont2 unit) : 
        (def i1 -> def i2 -> r tt tt i1 i2) ->
         verify2 f1 f2 (dealloc @0 [x1]) (dealloc @0 [x2]) r.
Proof. by rewrite !partitionE; apply: val_dealloc. Qed.

Lemma bnd2_deallocO A1 A2 B (e1 e2 : ST [::: unit] B) 
                    (x1 x2 : ptr) (v1 : A1) (v2 : A2) i1 i2 
                    (f1 : partition (x1 :-> v1) i1)
                    (f2 : partition (x2 :-> v2) i2) r : 
        verify2 i1 i2 (e1 @0 [tt]) (e2 @0 [tt]) r ->
        verify2 f1 f2 (dealloc @0 [x1] ;; e1) (dealloc @0 [x2] ;; e2) r.
Proof. by rewrite !partitionE; apply: bnd_dealloc. Qed.

Canonical val2_dealloc_form A1 A2 x1 x2 v1 v2 i1 i2 f1 f2 := 
  Val2_Form (@val2_deallocO A1 A2 x1 x2 v1 v2 i1 i2 f1 f2).

Canonical bnd2_dealloc_form A1 A2 B e1 e2 x1 x2 v1 v2 i1 i2 f1 f2 :=
  Bnd2_Form (@bnd2_deallocO A1 A2 B e1 e2 x1 x2 v1 v2 i1 i2 f1 f2).

(****************************************************************) 
(* specialized versions of do lemmas, to handle ghost variables *)
(****************************************************************) 

(* deals with the case of one ghost and the framing heap *)
(* should generalize to 2, 3 ghosts eventually *)

(* safety *)
Section SafeGhost1.
Variables (As : seq Type) (A B : Type) (s : spec As A).
Variables (e1 : STsec As A s) (e2 : ST [::: A] B) (a : args As).
Variables (C : Type) (p : funtp As (C -> heap -> Prop)). 
Variables (pp : dfuntp As (d C -> d heap -> Prop)).
Variables (qq : dfuntp As (d C -> d heap -> d heap -> 
                           d heap -> d A -> d heap -> d heap -> Prop)).

Lemma sval_do1 v j h : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (def (j :+ h) -> fun_app p a v j) -> 
        safe (j :+ h) (e1 @0 a).
Proof.
move=>E; move: e1; rewrite E=>e1' H D; rewrite instE /= fun_beta.
by exists v, j, h; split=>//; apply: H D.
Qed.

Lemma svalO1 v j h (f : forall k, partition k h) :
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (def (f j) -> fun_app p a v j) -> 
        safe (f j) (e1 @0 a).
Proof. by move=>H; rewrite partitionE; apply: sval_do1. Qed.

Lemma sbnd_do1 v j h : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y j', dfun_app qq (dpair a a) (v, v) (j, j) (h, h) 
           (j', j') (y, y) (j :+ h, j :+ h) (j' :+ h, j' :+ h) -> 
           safe (j' :+ h) (e2 @0 [y])) -> 
        fun_app p a v j -> 
        dfun_app pp (dpair a a) (v, v) (j, j) ->
        safe (j :+ h) (e1 @0 a;; e2).
Proof.
move=>E; move: e1; rewrite E=>e1'. 
rewrite /Defs.safe' !bindE /= => H1 H H2 D.
split=>[|y m] /=; first by rewrite instE /= fun_beta; exists v, j, h.
rewrite instE /= dfun_beta.
case/(_ (v, v) (_, _) (_, _) (erefl _) H2)=>[[j1 j2]][[->]] E' Eq D'.
move: (H1 y j1); rewrite /= instE; apply=>//.
by rewrite -(unKhl D' E') in Eq.
Qed.

Lemma sbndO1 v j h (f : forall k, partition k h) :
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y j', dfun_app qq (dpair a a) (v, v) (j, j) (h, h) (j', j') 
           (y, y) (f j : heap, f j : heap) (f j' : heap, f j' : heap) -> 
           safe (f j') (e2 @0 [y])) -> 
        fun_app p a v j -> 
        dfun_app pp (dpair a a) (v, v) (j, j) ->
        safe (f j) (e1 @0 a ;; e2).
Proof.
move=>H1 H2 H3; rewrite partitionE; apply: sbnd_do1 H1 _ H3.
by move=>y j'; move: (H2 y j'); rewrite !partitionE.
Qed.

End SafeGhost1.

Implicit Arguments sval_do1 [As A s e1 a C p pp qq v j h].
Implicit Arguments svalO1 [As A s e1 a C p pp qq v h f].
Implicit Arguments sbnd_do1 [As A B s e1 e2 a C p pp qq v j h].
Implicit Arguments sbndO1 [As A B s e1 e2 a C p pp qq v h f].

(* verify *)

Section VerifyGhost1.
Variables (As : seq Type) (A B : Type) (s : spec As A).
Variables (e1 : STsec As A s) (e2 : ST [::: A] B) (a : args As).
Variables (C : Type) (v : C) (p : funtp As (C -> heap -> Prop)). 
Variables (pp : dfuntp As (d C -> d heap -> Prop)).
Variables (qq : dfuntp As (d C -> d heap -> d heap -> 
                           d heap -> d A -> d heap -> d heap -> Prop)).

Lemma val_do1 j h (r : cont1 A) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y j', def (j' :+ h) -> 
           dfun_app qq (dpair a a) (v, v) (j, j) (h, h) (j', j') 
                      (y, y) (j :+ h, j :+ h) (j' :+ h, j' :+ h) -> 
           r y (j' :+ h)) ->
        fun_app p a v j ->
        dfun_app pp (dpair a a) (v, v) (j, j) ->
        verify (j :+ h) (e1 @0 a) r.
Proof.
move=>E; move: e1; rewrite {}E; move=>e1' H1 H2 H3 D y m R.
move: (spec_runs R R); rewrite instE /= dfun_beta. 
case/(_ (v, v) (_, _) (_, _) (erefl _) H3)=>[[j1 j2]][[E1 E2]] H4.
rewrite {m}E1 in R E2 H4 *; case: (def_runs R)=>_ _ D'.
move: H4; rewrite -{E2}(unKhl D' E2).
by move/H1; move/(_ D'); apply; rewrite inst_runs; apply: R.
Qed.

Lemma valO1 j h (r : cont1 A) (f : forall k, partition k h) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y j', def (f j') -> 
           dfun_app qq (dpair a a) (v, v) (j, j) (h, h) (j', j') 
           (y, y) (f j : heap, f j : heap) (f j' : heap, f j' : heap) -> 
           r y (f j')) ->
        fun_app p a v j ->
        dfun_app pp (dpair a a) (v, v) (j, j) ->
        verify (f j) (e1 @0 a) r.
Proof.
move=>H1 H2 H3; rewrite partitionE; apply: val_do1 H1 _ H3.
by move=>y j'; move: (H2 y j'); rewrite !partitionE.
Qed.

Lemma bnd_do1 j h (r : cont1 B) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y j', dfun_app qq (dpair a a) (v, v) (j, j) (h, h) (j', j') 
           (y, y) (j :+ h, j :+ h) (j' :+ h, j' :+ h) -> 
           verify (j' :+ h) (e2 @0 [y]) r) -> 
        fun_app p a v j ->
        dfun_app pp (dpair a a) (v, v) (j, j) ->
        verify (j :+ h) (e1 @0 a ;; e2) r.
Proof.
move=>E; move: e1; rewrite {}E; move=>e1' H1 H2 H3 D y m.
case/bindS=>x [h'][H]; move: (spec_runs H H); rewrite instE /= dfun_beta. 
case/(_ (v, v) (_, _) (_, _) (erefl _) H3)=>[[j1 j2]][[->]] E' H4 R.
case: (def_runs R)=>D' _ _; move: H4; rewrite -{E'}(unKhl D' E').
by move/H1; move/(_ D'); apply; rewrite inst_runs; apply: R.
Qed.

Lemma bndO1 j h (r : cont1 B) (f : forall k, partition k h) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y j', dfun_app qq (dpair a a) (v, v) (j, j) (h, h) (j', j') 
           (y, y) (f j : heap, f j : heap) (f j' : heap, f j' : heap) -> 
           verify (f j') (e2 @0 [y]) r) -> 
        fun_app p a v j ->
        dfun_app pp (dpair a a) (v, v) (j, j) ->
        verify (f j) (e1 @0 a ;; e2) r.
Proof.
move=>H1 H2 H3; rewrite partitionE; apply: bnd_do1 H1 _ H3.
by move=>y j'; move: (H2 y j'); rewrite !partitionE.
Qed.

End VerifyGhost1.

Implicit Arguments val_do1 [As A s e1 a C p pp qq r v j h].
Implicit Arguments valO1 [As A s e1 a C p pp qq r v h f].
Implicit Arguments bnd_do1 [As A B s e1 e2 a C p pp qq r v j h].
Implicit Arguments bndO1 [As A B s e1 e2 a C p pp qq r v h f].

(* verify *)

Section Verify2Ghost1.
Variables (As : seq Type) (A B : Type) (s : spec As A).
Variables (e : STsec As A s) (e1' e2' : ST [::: A] B) (a1 a2 : args As).
Variables (C : Type) (p : funtp As (C -> heap -> Prop)). 
Variables (pp : dfuntp As (d C -> d heap -> Prop)).
Variables (qq : dfuntp As (d C -> d heap -> d heap -> 
                           d heap -> d A -> d heap -> d heap -> Prop)).

Lemma val2_do1 v1 v2 j1 j2 h1 h2 (r : cont2 A) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y1 y2 j1' j2', 
           def (j1' :+ h1) -> def (j2' :+ h2) ->
           dfun_app qq (dpair a1 a2) (v1, v2) (j1, j2) (h1, h2) (j1', j2') 
                       (y1, y2) (j1 :+ h1, j2 :+ h2) (j1' :+ h1, j2' :+ h2) -> 
           r y1 y2 (j1' :+ h1) (j2' :+ h2)) ->
        fun_app p a1 v1 j1 -> fun_app p a2 v2 j2 ->
        dfun_app pp (dpair a1 a2) (v1, v2) (j1, j2) ->
        verify2 (j1 :+ h1) (j2 :+ h2) (e @0 a1) (e @0 a2) r.
Proof.
move=>E; move: e; rewrite {}E; move=>e' H1 H2 H3 H4 D1 D2 y1 y2 m1 m2 R1 R2.
case: (def_runs R1)=>_ _ D1'; case: (def_runs R2)=>_ _ D2'.
move: R1 R2; rewrite !inst_runs=>R1 R2.
move: (spec_runs R1 R2); rewrite /= dfun_beta.
case/(_ (v1, v2) (_, _) (_, _) (erefl _) H4)=>[[k1 k2]][[E1 E2]].
rewrite {}E1 {}E2 in D1' D2' R1 R2 *.
by move/H1; move/(_ D1' D2'); apply; rewrite inst_runs.
Qed.

Lemma val2O1 v1 v2 j1 j2 h1 h2 (r : cont2 A)  
             (f1 : forall k, partition k h1) 
             (f2 : forall k, partition k h2) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y1 y2 j1' j2', 
           def (j1' :+ h1) -> def (j2' :+ h2) ->
           dfun_app qq (dpair a1 a2) (v1, v2) (j1, j2) (h1, h2) (j1', j2') 
                       (y1, y2) (f1 j1 : heap, f2 j2 : heap) 
                       (f1 j1' : heap, f2 j2' : heap) -> 
           r y1 y2 (f1 j1') (f2 j2')) ->
        fun_app p a1 v1 j1 -> fun_app p a2 v2 j2 ->
        dfun_app pp (dpair a1 a2) (v1, v2) (j1, j2) ->
        verify2 (f1 j1) (f2 j2) (e @0 a1) (e @0 a2) r.
Proof.
move=>H1 H2 H3 H4 H5; rewrite !partitionE; apply: val2_do1 H3 H4 H5=>//.
by move=>y1 y2 j1' j2'; move: (H2 y1 y2 j1' j2'); rewrite !partitionE.
Qed.

Lemma bnd2_do1 v1 v2 j1 j2 h1 h2 (r : cont2 B) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y1 y2 j1' j2', 
           dfun_app qq (dpair a1 a2) (v1, v2) (j1, j2) (h1, h2) (j1', j2') 
                       (y1, y2) (j1 :+ h1, j2 :+ h2) (j1' :+ h1, j2' :+ h2) -> 
           verify2 (j1' :+ h1) (j2' :+ h2) (e1' @0 [y1]) (e2' @0 [y2]) r) -> 
        fun_app p a1 v1 j1 -> fun_app p a2 v2 j2 ->
        dfun_app pp (dpair a1 a2) (v1, v2) (j1, j2) ->
        verify2 (j1 :+ h1) (j2 :+ h2) 
                (e @0 a1 ;; e1') (e @0 a2 ;; e2') r.
Proof.
move=>E; move: e; rewrite {}E; move=>e' H1 H2 H3 H4 D1 D2 y1 y2 m1 m2.
case/bindS=>x1 [h1'][S1] R1; case/bindS=>x2 [h2'][S2] R2.
case: (def_runs R1)=>D1' _ _; case: (def_runs R2)=>D2' _ _.
move: S1 S2; rewrite !inst_runs=>S1 S2.
move: (spec_runs S1 S2); rewrite /= dfun_beta.
case/(_ (v1, v2) (_, _) (_, _) (erefl _) H4)=>[[k1 k2]][[E1 E2]].
rewrite {}E1 {}E2 in D1' D2' R1 R2 *.
by move/H1; move/(_ D1' D2'); apply; rewrite inst_runs.
Qed.

Lemma bnd2O1 v1 v2 j1 j2 h1 h2 (r : cont2 B)  
             (f1 : forall k, partition k h1) 
             (f2 : forall k, partition k h2) : 
        s = (fun_lam (fun a i => exists v, exists j, exists h, 
               i = j :+ h /\ fun_app p a v j),
             dfun_lam (fun aa ii (yy : d A) mm => forall vv jj hh, 
               ii = jj :++ hh -> dfun_app pp aa vv jj ->
             exists jj', mm = jj' :++ hh /\ 
               dfun_app qq aa vv jj hh jj' yy ii mm)) ->
        (forall y1 y2 j1' j2', 
           dfun_app qq (dpair a1 a2) (v1, v2) (j1, j2) (h1, h2) (j1', j2') 
                       (y1, y2) (f1 j1 : heap, f2 j2 : heap) 
                                (f1 j1' : heap, f2 j2' : heap) -> 
           verify2 (f1 j1') (f2 j2') (e1' @0 [y1]) (e2' @0 [y2]) r) -> 
        fun_app p a1 v1 j1 -> fun_app p a2 v2 j2 ->
        dfun_app pp (dpair a1 a2) (v1, v2) (j1, j2) ->
        verify2 (f1 j1) (f2 j2) 
                (e @0 a1 ;; e1') (e @0 a2 ;; e2') r.
Proof.
move=>H1 H2 H3 H4 H5; rewrite !partitionE; apply: bnd2_do1 H3 H4 H5=>//.
by move=>y1 y2 j1' j2'; move: (H2 y1 y2 j1' j2'); rewrite !partitionE.
Qed.

End Verify2Ghost1.

Implicit Arguments val2_do1 [As A s e a1 a2 C 
                             p pp qq r v1 v2 j1 j2 h1 h2].
Implicit Arguments val2O1 [As A s e a1 a2 C 
                           p pp qq r v1 v2 h1 h2 f1 f2].
Implicit Arguments bnd2_do1 [As A B s e e1' e2' a1 a2 C 
                             p pp qq r v1 v2 j1 j2 h1 h2].
Implicit Arguments bnd2O1 [As A B s e e1' e2' a1 a2 C 
                           p pp qq r v1 v2 h1 h2 f1 f2].

(****************************************************************)
(* tactics to package the applications and iterate the stepping *)
(****************************************************************)

Ltac ssimpl := apply: ssimpl=>/=.
Ltac vsimpl := apply: vsimpl=>/=.
Ltac v2simpl := apply: v2simpl=>/=.

Ltac sstep := do ![apply: sstep=>/=].
Ltac vstep := do ![apply: vstep=>/=].
Ltac v2step := do ![apply: v2step=>/=].
