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

(*************************)
(* Properties of verify2 *)
(*************************)

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

Lemma safeD A i (e : ST [:::] A) : (def i -> safe i e) -> safe i e.
Proof. by move=>H D; apply: (H D) D. Qed.

Section Verify.
Variable A : Type.

Lemma vrf2_mono i1 i2 e1 e2 (r1 r2 : cont2 A) : 
        r1 <== r2 -> verify2 i1 i2 e1 e2 r1 <== verify2 i1 i2 e1 e2 r2.
Proof. by move=>H1 H2 D1 D2 *; apply: H1; apply: H2. Qed.  

Lemma vrfC i1 i2 e1 e2 (r : cont2 A) : 
        verify2 i1 i2 e1 e2 r <-> 
        verify2 i2 i1 e2 e1 (fun y1 y2 m1 m2 => r y2 y1 m2 m1).
Proof.
move: i1 i2 e1 e2 r.
have L: forall i1 i2 (e1 e2 : ST [::] A) r, verify2 i1 i2 e1 e2 r ->
  verify2 i2 i1 e2 e1 (fun y1 y2 m1 m2 => r y2 y1 m2 m1).
- by move=>i1 i2 e1 e2 r H /= y1 y2 m1 m2 /= D1 D2 S1 S2; apply: H.
move=>i1 i2 e1 e2 r; split; first by apply: L.
by move/L; apply: vrf2_mono=>y1 y2 m1 m2.
Qed.

(* self-composition *)

Lemma vrfS1 i1 i2 e1 e2 (r : cont2 A) : 
        verify2 i1 i2 e1 e2 r <->
          verify i1 e1 (fun y1 m1 => 
            verify i2 e2 (fun y2 m2 => r y1 y2 m1 m2)).
Proof.
split; first by move=>H y1 m1 D1 S1 y2 m2 D2 S2; apply: H.
by move=>H y1 y2 m1 m2 /= D1 D2 S1 S2; apply: H.
Qed.

Lemma vrfS2 i1 i2 e1 e2 (r : cont2 A) : 
        verify2 i1 i2 e1 e2 r <->
          verify i2 e2 (fun y2 m2 => 
            verify i1 e1 (fun y1 m1 => r y1 y2 m1 m2)).
Proof. by rewrite vrfC vrfS1. Qed.

Lemma vrf2TI i1 i2 e1 e2 (p : Type) (r : cont2 A) : 
        (p -> verify2 i1 i2 e1 e2 r) ->
        verify2 i1 i2 e1 e2 (fun y1 y2 m1 m2 => p -> r y1 y2 m1 m2).
Proof. by move=>H y1 y2 m1 m2 D1 D2 H1 H2 /= V; apply: H. Qed.

Lemma vrf2I i1 i2 e1 e2 (p : Prop) (r : cont2 A) : 
        (p -> verify2 i1 i2 e1 e2 r) ->
        verify2 i1 i2 e1 e2 (fun y1 y2 m1 m2 => p -> r y1 y2 m1 m2).
Proof. by move=>H y1 y2 m1 m2 D1 D2 H1 H2 /= V; apply: H. Qed.

(* definedness *)
Lemma vrf2D i1 i2 e1 e2 (r : cont2 A) : 
        (def i1 -> def i2 -> verify2 i1 i2 e1 e2 r) ->
        verify2 i1 i2 e1 e2 r.
Proof. by move=>H D1 D2; apply: H. Qed.

Lemma vrfD i e (r : cont1 A) : 
        (def i -> verify i e r) -> verify i e r.
Proof. by move=>H D; apply: H. Qed.

(* the rule of conjunction *)

Lemma vrf2_conj i1 i2 e1 e2 (r1 r2 : cont2 A) : 
        verify2 i1 i2 e1 e2 r1 -> verify2 i1 i2 e1 e2 r2 ->
        verify2 i1 i2 e1 e2 (fun y1 y2 m1 m2 => 
          r1 y1 y2 m1 m2 /\ r2 y1 y2 m1 m2).
Proof.
move=>H1 H2 D1 D2 y1 y2 m1 m2 S1 S2.
by split; [apply: H1 | apply: H2].
Qed.

Lemma vrf_conj i e (r1 r2 : cont1 A) : 
        verify i e r1 -> verify i e r2 ->
        verify i e (fun y m => r1 y m /\ r2 y m).
Proof. by move=>H1 H2 D y m S; split; [apply: H1 | apply: H2]. Qed.

End Verify.

(***********************************************************************)
(* Derived custom structural rules for Floyd-style symbolic evaluation *)
(***********************************************************************)

(* Proving safety *)

(* first lemmas for pushing the substitutions inward *)

Lemma sval_inst As Bs A (e : ST Bs A) (f : funtp As (args Bs)) a i : 
        safe i (e @0 fun_app f a) -> 
        safe i ((e @ f) @0 a).
Proof. by rewrite /Defs.safe' !instE -!toPredE /= instE fun_beta. Qed.

Lemma sbnd_push As A B (e1 : ST As A) (e2 : ST [::: A & As] B) (a : args As) i : 
         safe i (bind (e1 @0 a) (e2 @1 (fun y => (y, a)))) -> 
         safe i (bind e1 e2 @0 a).
Proof. by rewrite /Defs.safe' instE /= !bindE fun_beta /= !instE. Qed.

Lemma sbnd_inst As Bs A B (e1 : ST Bs A) (f : funtp As (args Bs))
                (e2 : ST [::: A] B) (a : args As) i : 
        safe i (bind (e1 @0 fun_app f a) e2) ->
        safe i (bind (e1 @ f @0 a) e2).
Proof. 
rewrite /Defs.safe' /= !bindE /= !instE /= instE fun_beta !dfun_beta.
by rewrite dargs_beta1 dargs_beta2.
Qed.

Lemma sval_do' A (e : ST [:::] A) i : 
        (def i -> pre_of e i) -> safe i e.
Proof. by move=>H; move/H. Qed.

Lemma sbnd_do' A B (e1 : ST [:::] A) (e2 : ST [::: A] B) i : 
        (def i -> pre_of e1 i) -> 
        (forall y m, post_of e1 (i, i) (y, y) (m, m) -> safe m (e2 @0 [y])) -> 
        safe i (bind e1 e2).
Proof. 
rewrite /Defs.safe' /= !bindE => H1 H2 D.
split=>[|y m]; first by apply: H1.
by move/H2; rewrite instE.
Qed.

Lemma sval_do As A (e : ST As A) a i : 
        (def i -> fun_app (pre_of e) a i) -> safe i (e @0 a).
Proof. by move=>H; move/H; rewrite /Defs.safe' instE. Qed.

Lemma sbnd_do As A B (e1 : ST As A) (e2 : ST [::: A] B) a i : 
        (def i -> fun_app (pre_of e1) a i) -> 
        (forall y m, dfun_app (post_of e1) (dpair a a) (i, i) (y, y) (m, m) -> 
           safe m (e2 @0 [y])) -> 
         safe i (bind (e1 @0 a) e2).
Proof.
rewrite /Defs.safe' /= !bindE => H1 H2 D.
split=>[|y m] /=; first by rewrite instE; apply: H1.
by rewrite instE; move/H2; rewrite instE.
Qed.

Lemma sval_ret A (v : A) i : safe i (ret @0 [v]). 
Proof. by move=>D; apply: sval_do. Qed.

Lemma sbnd_ret A B (v : A) (e :  ST [::: A] B) i : 
        safe i (e @0 [v]) -> 
        safe i (bind (ret @0 [v]) e).
Proof. by move=>H; apply: sbnd_do=>//=; move=>y m [[-> _]][-> _]. Qed.

Lemma sval_read A (v : A) x i :
        safe (x :-> v :+ i) (read A @0 [x]).
Proof. by apply: sval_do=>//= D; exists i; exists v. Qed.

Lemma sbnd_read A B (e : ST [::: A] B) l v i :
        safe (l :-> v :+ i) (e @0 [v]) -> 
        safe (l :-> v :+ i) (bind (read A @0 [l]) e).
Proof.
move=>H; apply: sbnd_do=>[|y m] /=; first by exists i; exists v.
by case=>[[-> _]]; case/(_ (i, i) (v, v) (erefl _))=>->.
Qed.

Lemma sval_write A B (v : A) (w : B) l i :
        safe (l :-> w :+ i) (write @0 [l, v]). 
Proof. by apply: sval_do=>//=; exists i; exists B; exists w. Qed.
 
Lemma sbnd_write A1 A2 B (e : ST [::: unit] B) (v : A1) (w : A2) l i :
        safe (l :-> v :+ i) (e @0 [tt]) -> 
        safe (l :-> w :+ i) (bind (write @0 [l, v]) e).
Proof.
move=>H; apply: sbnd_do=>[D|[] m] /=.
- by exists i; exists A2; exists w.
by case/(_ (i, i) A2 A2 w w (erefl _))=>->.
Qed.

Lemma sval_lalloc A (v : A) i : safe i (lalloc @0 [v]).
Proof. by rewrite /Defs.safe' instE. Qed.

Lemma sbnd_lalloc A B (e : ST [::: ptr] B) (v : A) i :
        (forall l : ptr, safe (l :-> v :+ i) (e @0 [l])) -> 
         safe i (bind (lalloc @0 [v]) e).
Proof. by move=>H; apply: sbnd_do=>//=; move=>y m [[-> _]] _; apply: H. Qed.

Lemma sval_halloc A (v : A) i : safe i (halloc @0 [v]).
Proof. by rewrite /Defs.safe' instE. Qed.

Lemma sbnd_halloc A B (e : ST [::: ptr] B) (v : A) i :
        (forall l : ptr, safe (l :-> v :+ i) (e @0 [l])) -> 
         safe i (bind (halloc @0 [v]) e).
Proof. by move=>H; apply: sbnd_do=>//= y m [[-> _]] _; apply: H. Qed.

Lemma sval_dealloc A (v : A) l i : 
        safe (l :-> v :+ i) (dealloc @0 [l]).
Proof. by apply: sval_do=>/=; exists i; exists A; exists v. Qed.     

Lemma sbnd_dealloc A B (e : ST [::: unit] B) (v : A) l i :
        safe i (e @0 [tt]) -> 
        safe (l :-> v :+ i) (bind (dealloc @0 [l]) e).
Proof.
move=>H; apply: sbnd_do=>[|[] m] /=.
- by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _))=>->.
Qed.

(*  
Lemma sbnd_bnd A B C (e1 : ST [:::] A) (e2 : ST [:: A] B) 
                     (e3 : ST [::: B] C) i : 
        reflective (rspec_of e1) ->
        reflective (rspec_of e2) ->
        (def i -> i \In safe (bind e1 (bind e2 (e3 @2 fun x y => [x])))) -> 
         def i -> i \In safe (bind (bind e1 e2) e3).
Proof.
move=>R1 R2 H D; move: (H D).
rewrite /safe /= -!toPredE /= !bindE /= !bindE /= !instE /=.
case=>H1 H2.  
split=>[|y m]; first by split=>// y m H3; case/(H2 _ _ H3).
case=>[[x1 x2]][[h1 h2]][] L [D1][D2].
case/(_ tt tt (x1, x2) (i, i) (h1, h2) D D H1 H1 L): R1=>/= L1 L2.
case: (H2 x1 h1 L1 D1)=>L3 L4.
case: (H2 x2 h2 L2 D2)=>L5 L6.
move/(_ (x1, tt) (x2, tt) (y, y) (h1, h2) (m, m) D1 D2 L3 L5): R2=>O.
by case/O=>O1 O2 D3; apply: L4.
Qed.
*)

(* Now correctness *)

(* first some structural lemmas showing how instantiations *)
(* (i.e. simultaneous applications) commutes *)

(* instantiations compose as follows *)

Lemma val_instV As Bs A (e1 : ST Bs A) (f : funtp As (args Bs)) a i r : 
        verify i (e1 @0 fun_app f a) r ->
        verify i (e1 @ f @0 a) r. 
Proof. 
move=>H D y m S; apply: H=>//.
by rewrite inst_runs -inst_assoc -inst_runs.
Qed.

(* when instantiating bind, we can push the instantiation into branches *)

Lemma bnd_pushV As A B (e1 : ST As A) (e2 : ST [::: A & As] B) 
                (a : args As) i r : 
        verify i (bind (e1 @0 a) (e2 @1 (fun y => (y, a)))) r ->
        verify i (bind e1 e2 @0 a) r.
Proof. 
move=>H D y m S. apply: H=>//.
by rewrite -bindR -inst_runs.
Qed.

(* once inside the branches, compose all the instantiations to reveal *)
(* the main term in the branch *)

Lemma bnd_instV As Bs A B (e1 : ST Bs A) (e2 : ST [::: A] B) 
                 (f : funtp As (args Bs)) (a : args As) i r : 
        verify i (bind (e1 @0 fun_app f a) e2) r ->
        verify i (bind (e1 @ f @0 a) e2) r.
Proof.
move=>H y m D' S; apply: H=>//.
case: (def_runs S)=>_ D _; case/bindS: S=>x [h][H1] H2.
apply: bindC H2; last by rewrite !inst_assoc in H1 *.
rewrite !bindE /= instE /= instE fun_beta dfun_beta in D.
rewrite dargs_beta1 dargs_beta2 in D.
by rewrite /bind_pre /= instE.
Qed.

(* now the lemmas for dealing with the connectives *)

Lemma val_doV As A (e : ST As A) (a : args As) i (r : A -> heap -> Prop) : 
        (def i -> fun_app (pre_of e) a i) ->
        (forall y m, dfun_app (post_of e) (dpair a a) (i, i) (y, y) (m, m) -> 
                     def m -> r y m) -> 
         verify i (e @0 a) r.
Proof.
move=>H1 H2 y m D' S; case/def_runs: (S)=>_ _ D.
move: S; rewrite inst_runs=>S.
by move/H2: (spec_runs S S); apply.
Qed.

Lemma val_do As B (e : ST As B) (a1 a2 : args As) i1 i2 (r : cont2 B) : 
        ((def i1 -> fun_app (pre_of e) a1 i1) /\
         (def i2 -> fun_app (pre_of e) a2 i2)) ->
        (forall y1 y2 m1 m2, 
           dfun_app (post_of e) (dpair a1 a2) (i1, i2) (y1, y2) (m1, m2) -> 
           def m1 -> def m2 -> r y1 y2 m1 m2) -> 
         verify2 i1 i2 (e @0 a1) (e @0 a2) r.
Proof.
move=>/= [H1 H2] H3 D1' D2' y1 y2 m1 m2 /=. 
rewrite !inst_runs /= => S1 S2. 
case: (def_runs S1)=>_ _ D1; case: (def_runs S2)=>_ _ D2.
by move/H3: (spec_runs S1 S2); apply.
Qed.

Lemma bnd_doV As A B (e1 : ST As A) (e2 : ST [::: A] B) a i r :
        (def i -> fun_app (pre_of e1) a i) ->
        (forall y m, dfun_app (post_of e1) (dpair a a) (i, i) (y, y) (m, m) -> 
           verify m (e2 @0 [y]) r) -> 
         verify i (bind (e1 @0 a) e2) r.
Proof.
move=>H1 H2 D y m; case/bindS=>x [h1][H3] H4.
move: (spec_runs H3 H3); rewrite /= instE; move/H2; apply=>//.
- by case/def_runs: H3.
by rewrite inst_runs.
Qed.
 
Lemma bnd_do As A B (e : ST As A) (e1 e2 : ST [::: A] B) 
              (a1 a2 : args As) i1 i2 r :
        ((def i1 -> fun_app (pre_of e) a1 i1) /\
         (def i2 -> fun_app (pre_of e) a2 i2)) ->
        (forall y1 y2 m1 m2, 
           dfun_app (post_of e) (dpair a1 a2) (i1, i2) (y1, y2) (m1, m2) -> 
           verify2 m1 m2 (e1 @0 [y1]) (e2 @0 [y2]) r) -> 
         verify2 i1 i2 
                 (bind (e @0 a1) e1) (bind (e @0 a2) e2) r.
Proof.
move=>[H1 H2] H3 D1' D2' y1 y2 m1 m2 /=.
case/bindS=>x1 [h1][S1] T1.
case/bindS=>x2 [h2][S2] T2.
case: (def_runs S2) T2=>_ _ D2; case: (def_runs S1) T1=>_ _ D1. 
move: S1 S2; rewrite !inst_runs=>S1 S2 L1 L2.
move/H3: (spec_runs S1 S2); apply=>//;
by rewrite inst_runs.
Qed.

(* ret *)

Lemma val_retV A v i (r : A -> heap -> Prop) : 
        (def i -> r v i) -> verify i (ret @0 [v]) r.
Proof. by move=>H; apply: val_doV=>//= =>y m [[-> _]][-> _]. Qed.

Lemma val_ret A v1 v2 i1 i2 (r : cont2 A) : 
        (def i1 -> def i2 -> r v1 v2 i1 i2) -> 
         verify2 i1 i2 (ret @0 [v1]) (ret @0 [v2]) r.
Proof. 
by move=>H; apply/vrfS1; apply: val_retV=>D; apply: val_retV; apply: H.
Qed.

Lemma bnd_retV A B (e : ST [::: A] B) v i r :
        verify i (e @0 [v]) r -> verify i (bind (ret @0 [v]) e) r.
Proof. by move=>H; apply: bnd_doV=>//= =>y m [[-> _]][-> _]. Qed.
 
Lemma bnd_ret A B (e1 e2 : ST [::: A] B) v1 v2 i1 i2 r : 
        verify2 i1 i2 (e1 @0 [v1]) (e2 @0 [v2]) r -> 
        verify2 i1 i2 (bind (ret @0 [v1]) e1) (bind (ret @0 [v2]) e2) r.
Proof. 
move/vrfS1=>H; apply/vrfS2; apply: bnd_retV; apply/vrfS2.
by apply/vrfS1; apply: bnd_retV.
Qed.

(* read *)

Lemma val_readV A v l i (r : A -> heap -> Prop) : 
        (def (l :-> v :+ i) -> r v (l :-> v :+ i)) -> 
         verify (l :-> v :+ i) (read A @0 [l]) r.
Proof.
move=>H; apply: val_doV=>[|y m] /=; first by exists i; exists v.
by case=>[[-> _]]; case/(_ (i, i) (v, v) (erefl _))=>->.
Qed.

Lemma val_read A v1 v2 l1 l2 i1 i2 (r : cont2 A) : 
        (def (l1 :-> v1 :+ i1) -> def (l2 :-> v2 :+ i2) -> 
           r v1 v2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)) -> 
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) 
                (read A @0 [l1]) (read A @0 [l2]) r.
Proof. 
by move=>H; apply/vrfS1; apply: val_readV=>D; apply: val_readV; apply: H.
Qed.

Lemma bnd_readV A B (e : ST [::: A] B) l v i r : 
        verify (l :-> v :+ i) (e @0 [v]) r -> 
        verify (l :-> v :+ i) (bind (read A @0 [l]) e) r.
Proof.
move=>H; apply: bnd_doV=>[|y m] /=; first by exists i; exists v.
by case=>[[-> _]]; case/(_ (i, i) (v, v) (erefl _))=>->.
Qed.

Lemma bnd_read A1 A2 B (e1 : ST [::: A1] B) (e2 : ST [::: A2] B) 
               l1 l2 v1 v2 i1 i2 r :
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @0 [v1]) (e2 @0 [v2]) r -> 
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)
                (bind (read A1 @0 [l1]) e1) (bind (read A2 @0 [l2]) e2) r.
Proof. 
move/vrfS1=>H; apply/vrfS2; apply: bnd_readV; apply/vrfS2.
by apply/vrfS1; apply: bnd_readV.
Qed.

(* write *)

Lemma val_writeV A B l (v : A) (w : B) i (r : unit -> heap -> Prop) : 
        (def (l :-> v :+ i) -> r tt (l :-> v :+ i)) -> 
         verify (l :-> w :+ i) (write @0 [l, v]) r.
Proof.
move=>H; apply: val_doV=>[|[] m] /=; first by exists i; exists B; exists w.
by case/(_ (i, i) B B w w (erefl _))=>[[-> _]].
Qed.  

Lemma val_write A1 A2 B1 B2 l1 l2 (v1 : A1) (v2 : A2)  
                 (w1 : B1) (w2 : B2) i1 i2 (r : cont2 unit) : 
        (def (l1 :-> v1 :+ i1) -> def (l2 :-> v2 :+ i2) -> 
           r tt tt (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)) ->
        verify2 (l1 :-> w1 :+ i1) (l2 :-> w2 :+ i2)
                (write @0 [l1, v1]) (write @0 [l2, v2]) r.
Proof. 
by move=>H; apply/vrfS1; apply: val_writeV=>D; apply: val_writeV; apply: H. 
Qed.

Lemma bnd_writeV A A' B (e : ST [::: unit] B) l (v : A) (w : A') i r : 
        verify (l :-> v :+ i) (e @0 [tt]) r ->
        verify (l :-> w :+ i) (bind (write @0 [l, v]) e) r.
Proof.
move=>H; apply: bnd_doV=>[|[] m] /=; first by exists i; exists A'; exists w.
by case/(_ (i, i) A' A' w w (erefl _))=>[[-> _]].
Qed.

Lemma bnd_write A1 A2 A1' A2' B (e1 e2 : ST [::: unit] B) 
                l1 l2 (v1 : A1) (v2 : A2) (w1 : A1') (w2 : A2') i1 i2 r : 
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) 
                  (e1 @0 [tt]) (e2 @0 [tt]) r ->
        verify2 (l1 :-> w1 :+ i1) (l2 :-> w2 :+ i2)
                (bind (write @0 [l1, v1]) e1) (bind (write @0 [l2, v2]) e2) r.
Proof. 
move/vrfS1=>H; apply/vrfS2; apply: bnd_writeV; apply/vrfS2.
by apply/vrfS1; apply: bnd_writeV.
Qed.

(* low alloc *)

Lemma val_lallocV A (v : A) i (r : ptr -> heap -> Prop) : 
        (forall l:ptr, def (l :-> v :+ i) -> r l (l :-> v :+ i)) -> 
         verify i (lalloc @0 [v]) r.
Proof. by move=>H; apply: val_doV=>//= =>y m [[-> _]] _; apply: H. Qed.

Lemma val_lalloc A (v1 v2 : A) i1 i2 (r : cont2 ptr) : 
        (forall l1 l2 : ptr, def (l1 :-> v1 :+ i1) -> def (l2 :-> v2 :+ i2) -> 
           (i1 =~ i2 -> l1 = l2 /\ l1 :-> v1 :+ i1 =~ l2 :-> v2 :+ i2) ->
           r l1 l2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)) ->
         verify2 i1 i2 (lalloc @0 [v1]) (lalloc @0 [v2]) r.
Proof.
by move=>H; apply: val_do=>//= =>y1 y2 m1 m2 [[-> ->]] /= L D1 D2; apply: H.
Qed.

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

Lemma bnd_lalloc A B (e1 e2 : ST [::: ptr] B) (v1 v2 : A) 
                 i1 i2 (r : cont2 B) : 
        (forall l1 l2 : ptr, 
           verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @0 [l1]) (e2 @0 [l2]) 
             (fun y1 y2 m1 m2 =>
                (i1 =~ i2 -> l1 = l2 /\ 
                                l1 :-> v1 :+ i1 =~ l2 :-> v2 :+ i2) ->
                 r y1 y2 m1 m2)) ->
         verify2 i1 i2 (bind (lalloc @0 [v1]) e1) (bind (lalloc @0 [v2]) e2) r.
Proof.
move=>H; apply: bnd_do=>//=.
by move=>y1 y2 m1 m2 [[-> ->]] L z1 z2 n1 n2 D1 D2 S1 S2; apply: H L.
Qed.   

(* high alloc *)

Lemma val_hallocV A (v : A) i (r : ptr -> heap -> Prop) : 
        (forall l : ptr, high l -> def (l :-> v :+ i) -> r l (l :-> v :+ i)) -> 
         verify i (halloc @0 [v]) r.
Proof. by move=>H; apply: val_doV=>//= =>y m [[-> _]][_]; apply: H. Qed.

Lemma val_halloc A1 A2 (v1 : A1) (v2 : A2) i1 i2 (r : cont2 ptr) :
        (forall l1 l2 : ptr, 
           high l1 -> high l2 -> 
           def (l1 :-> v1 :+ i1) -> def (l2 :-> v2 :+ i2) -> 
           r l1 l2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)) ->
         verify2 i1 i2 (halloc @0 [v1]) (halloc @0 [v2]) r.
Proof. 
by move=>H; apply/vrfS1; do 2![apply: val_hallocV=>*]; apply: H.
Qed. 

Lemma bnd_hallocV A B (e : ST [::: ptr] B) (v : A) i (r : B -> heap -> Prop) :
        (forall l : ptr, verify (l :-> v :+ i) (e @0 [l]) 
                     (fun y m => high l -> r y m)) ->
         verify i (bind (halloc @0 [v]) e) r.
Proof.
move=>H; apply: bnd_doV=>//=.
by move=>y m [[-> _]][L] _ z n D S; apply: H L. 
Qed.

Lemma bnd_halloc A1 A2 B (e1 e2 : ST [::: ptr] B) (v1 : A1) (v2 : A2) 
                 i1 i2 (r : cont2 B) : 
        (forall l1 l2 : ptr, 
           verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @0 [l1]) (e2 @0 [l2]) 
                   (fun y1 y2 m1 m2 => high l1 -> high l2 -> r y1 y2 m1 m2)) ->
         verify2 i1 i2 (bind (halloc @0 [v1]) e1) (bind (halloc @0 [v2]) e2) r.
Proof.
move=>H; apply/vrfS1; apply: bnd_hallocV=>l1 D1 y1 m1 T1 G1.
by apply: bnd_hallocV=>l2 D2 y2 m2 T2 G2; apply: (H l1 l2).
Qed.

(* dealloc *)

Lemma val_deallocV A (l : ptr) (v : A) i (r : unit -> heap -> Prop) : 
        (def i -> r tt i) -> verify (l :-> v :+ i) (dealloc @0 [l]) r.
Proof.
move=>H; apply: val_doV=>[|[] m] /=; first by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _))=>-> _.
Qed.

Lemma val_dealloc A1 A2 (l1 l2 : ptr) (v1 : A1) (v2 : A2) i1 i2 
                  (r : cont2 unit) : 
        (def i1 -> def i2 -> r tt tt i1 i2) ->
         verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) 
                 (dealloc @0 [l1]) (dealloc @0 [l2]) r.
Proof. 
by move=>H; apply/vrfS1; do 2![apply: val_deallocV=>*]; apply: H. 
Qed.

Lemma bnd_deallocV A B (e : ST [::: unit] B) (l : ptr) (v : A) i r : 
        verify i (e @0 [tt]) r -> 
          verify (l :-> v :+ i) (bind (dealloc @0 [l]) e) r.
Proof.
move=>H; apply: bnd_doV=>[|[] m] /=; first by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _))=>->.
Qed.

Lemma bnd_dealloc A1 A2 B (e1 e2 : ST [::: unit] B) 
                  (l1 l2 : ptr) (v1 : A1) (v2 : A2) i1 i2 r : 
        verify2 i1 i2 (e1 @0 [tt]) (e2 @0 [tt]) r ->
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)
                (bind (dealloc @0 [l1]) e1) (bind (dealloc @0 [l2]) e2) r.
Proof.
move/vrfS1=>H; apply/vrfS2; apply: bnd_deallocV; apply/vrfS2.
by apply/vrfS1; apply: bnd_deallocV.
Qed. 

(* associativity *)

Lemma bnd_bndV A B C (e1 : ST [:::] A) (e2 : ST [::: A] B) 
               (e3 : ST [::: B] C) i r : 
        verify i (bind e1 (bind e2 (e3 @2 fun x y => [x]))) r ->
        verify i (bind (bind e1 e2) e3) r.
Proof.
have L1: bind_pre (bind e1 e2) e3 <== 
         bind_pre e1 (bind e2 (e3 @2 fun x y => [x])). 
- rewrite /= !bindE; move=>j [[/= H1]] H2 H3; split=>// y1 m1 H4 D4.
  move: (H2 _ _ H4 D4)=>H2'; split=>// y2 m2 H5.
  rewrite instE /=; apply: H3.
  by exists (y1, y1); exists (m1, m1).
move=>H D' z m H1.
case: (def_runs H1)=>/= _ S1 _; case/bindS: H1=>x2 [t2][H1].
case: (def_runs H1)=>/= _ S2 _; case/bindS: H1=>x1 [t1][R1].
rewrite -inst_runs=>R2 R3. 
apply: H=>//; apply: bindC (R1) _.
- case: (def_runs R2)=>D H _.
  apply: L1; split=>//= y h R2'.
  by rewrite !bindE /= in S1; apply: (proj2 S1); apply: R2'. 
rewrite bindR; apply: bindC (R2) _; last by rewrite !inst_assoc.
case: (def_runs R2)=>D H _; split=>//= y h R2'.
rewrite !instE /= in R2' *; rewrite instE. 
rewrite !bindE /= in S1; apply: (proj2 S1); rewrite !bindE /=.
exists (x1, x1); exists (t1, t1); do !split=>//. 
by apply: (spec_runs R1 R1).
Qed.

Lemma bnd_bnd A1 A2 B1 B2 C (e1 : ST [:::] A1) (e2 : ST [::: A1] B1) 
              (e3 : ST [::: B1] C) (f1 : ST [:::] A2) (f2 : ST [::: A2] B2) 
              (f3 : ST [::: B2] C) i1 i2 r : 
        verify2 i1 i2 (bind e1 (bind e2 (e3 @2 fun x y => [x]))) 
                      (bind f1 (bind f2 (f3 @2 fun x y => [x]))) r ->
        verify2 i1 i2 (bind (bind e1 e2) e3) (bind (bind f1 f2) f3) r. 
Proof.
move/vrfS1=>H; apply/vrfS2; apply: bnd_bndV; apply/vrfS2.
by apply/vrfS1; apply: bnd_bndV.
Qed.

Section Ghosts.
Variables (As : seq Type) (B : Type) (e : ST As B).
Variables (p : args As -> pre [:::]).

(* collecting all the quantifiers *)
Lemma allC B1 B2 (q : B1 -> B2 -> args As -> args As -> 
                      heap -> heap -> B -> B -> heap -> heap -> Prop) : 
       conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
                     forall x1 x2, q x1 x2 a1 a2 i1 i2 y1 y2 m1 m2) <->
       conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
                     forall x, q x.1 x.2 a1 a2 i1 i2 y1 y2 m1 m2).
Proof.
split; case=>H1 H2; 
split=>// a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2.
- by case=>x1 x2; apply: H2.
by move=>x1 x2; apply: (H2 a1 a2 i1 i2 H3 H4 D1 D2 
                        y1 y2 m1 m2 S1 S2 (x1, x2)).
Qed.

(* collecting the implications *) 
Lemma impC A (q1 q2 : A -> args As -> args As -> heap -> heap -> Prop)
             (r : A -> args As -> args As -> heap -> heap -> 
                  B -> B -> heap -> heap -> Prop) :
        conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
          forall x, q1 x a1 a2 i1 i2 -> q2 x a1 a2 i1 i2 -> 
                    r x a1 a2 i1 i2 y1 y2 m1 m2) <->
        conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
          forall x, q1 x a1 a2 i1 i2 /\ q2 x a1 a2 i1 i2 -> 
                    r x a1 a2 i1 i2 y1 y2 m1 m2).
Proof.
by split; case=>H1 H2; 
   split=>// a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2;
[move=>x [H5 H6] | move=>x H5 H6]; apply: H2.
Qed.

(* commuting quantifier and implication *)
Lemma alimC B1 B2 
            (q : B1 -> args As -> args As -> heap -> heap -> Prop)
            (r : B1 -> B2 -> args As -> args As -> heap -> heap -> 
                 B -> B -> heap -> heap -> Prop) : 
        conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
          forall x1, q x1 a1 a2 i1 i2 -> 
          forall x2, r x1 x2 a1 a2 i1 i2 y1 y2 m1 m2) <->
        conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 =>
          forall x1 x2, q x1 a1 a2 i1 i2 -> r x1 x2 a1 a2 i1 i2 y1 y2 m1 m2).
Proof.
split; case=>H1 H2.
- split=>// a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2 x1 x2.
  by move/(H2 a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2 x1); apply.
by split=>// a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2 x1 H x2; apply: H2.
Qed.

Lemma ghE A (q : A -> args As -> args As -> heap -> heap -> Prop) 
            (r : A -> args As -> args As -> heap -> heap -> 
                 B -> B -> heap -> heap -> Prop) : 
        conseq e p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
          forall x, q x a1 a2 i1 i2 -> r x a1 a2 i1 i2 y1 y2 m1 m2) <->
        (forall a i, p a i -> safe i (e @0 a)) /\
         forall a1 a2 i1 i2 x, 
           q x a1 a2 i1 i2 -> p a1 i1 -> p a2 i2 -> 
           verify2 i1 i2 (e @0 a1) (e @0 a2) (r x a1 a2 i1 i2). 
Proof.
split=>//; case=>H1 H2; split=>//.
- by move=>a1 a2 i1 i2 x H3 H4 H5 D1 D2 y1 y2 m1 m2 S1 S2; apply: H2.
by move=>a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2 x H5; apply: H2.
Qed. 

End Ghosts.

Section GhostsIf.
Variables (As : seq Type) (B : Type) (f : funtp As bool) (e1 e2 : ST As B).
Variables (p : args As -> pre [:::]).

(* collecting all the quantifiers *)
Lemma ifallC2 B1 B2 (q : B1 -> B2 -> args As -> args As -> 
                     heap -> heap -> B -> B -> heap -> heap -> Prop) : 
       if_conseq f e1 e2 p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
         forall x1 x2, q x1 x2 a1 a2 i1 i2 y1 y2 m1 m2) <->
       if_conseq f e1 e2 p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
         forall x, q x.1 x.2 a1 a2 i1 i2 y1 y2 m1 m2).
Proof.
split; case=>H1 H2; 
split=>//= a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2.
- by case=>x1 x2; apply: H2.
by move=>x1 x2; apply: (H2 a1 a2 i1 i2 H3 H4 D1 D2 
                        y1 y2 m1 m2 S1 S2 (x1, x2)).
Qed.

(* collecting the implications *) 
Lemma ifimpC2 A (q1 q2 : A -> args As -> args As -> heap -> heap -> Prop)
             (r : A -> args As -> args As -> heap -> heap ->  
                  B -> B -> heap -> heap -> Prop) :
        if_conseq f e1 e2 p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
            forall x, q1 x a1 a2 i1 i2 -> q2 x a1 a2 i1 i2 -> 
                      r x a1 a2 i1 i2 y1 y2 m1 m2) <->
        if_conseq f e1 e2 p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
            forall x, q1 x a1 a2 i1 i2 /\ q2 x a1 a2 i1 i2 -> 
                      r x a1 a2 i1 i2 y1 y2 m1 m2).
Proof.
by split; case=>H1 H2; 
   split=>// a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2;
[move=>x [H5 H6] | move=>x H5 H6]; apply: H2.
Qed.

Lemma ifghE2 A (q : A -> args As -> args As -> heap -> heap -> Prop) 
               (r : A -> args As -> args As -> heap -> heap -> 
                    B -> B -> heap -> heap -> Prop) : 
        if_conseq f e1 e2 p (fun a1 a2 i1 i2 y1 y2 m1 m2 => 
          forall x, q x a1 a2 i1 i2 -> r x a1 a2 i1 i2 y1 y2 m1 m2) <->
        (forall a i, p a i -> 
           safe i (if fun_app f a then e1 @0 a else e2 @0 a)) /\
         forall a1 a2 i1 i2 x, 
           q x a1 a2 i1 i2 -> p a1 i1 -> p a2 i2 -> 
           verify2 i1 i2 (if fun_app f a1 then e1 @0 a1 else e2 @0 a1) 
                         (if fun_app f a2 then e1 @0 a2 else e2 @0 a2)
                         (r x a1 a2 i1 i2).
Proof.
split=>//; case=>H1 H2; split=>//.
- by move=>a1 a2 i1 i2 x H3 H4 H5 D1 D2 y1 y2 m1 m2 S1 S2; apply: H2. 
by move=>a1 a2 i1 i2 H3 H4 D1 D2 y1 y2 m1 m2 S1 S2 x H5; apply: H2.
Qed. 

End GhostsIf.

Implicit Arguments STsec [].

Definition gh := ((allC, impC, alimC, ghE), (ifallC2, ifimpC2, ifghE2)).
Definition pull A x (v:A) := (unC (x :-> v), unCA (x :-> v)).
Definition push A x (v:A) := (unCA (x :-> v), unC (x :-> v)).

