Load loadpath.
Require Import ssreflect ssrbool eqtype ssrnat ssrfun seq.
Require Import prelude heaps rels hprop domains secmod.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.
Set Automatic Coercion Import.

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

Local Notation cont A := (d A -> d heap -> Prop). 

Section Verify.
Variable A : Type.

Lemma vrf2_mono i1 i2 e1 e2 (r1 r2 : cont 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 : cont A) : 
        verify2 i1 i2 e1 e2 r <-> 
        verify2 i2 i1 e2 e1 (fun y m => r (y.2, y.1) (m.2, m.1)).
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 y m  => r (y.2, y.1) (m.2, m.1)).
- 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]][].
Qed.

(* self-composition *)

Lemma vrfS i1 i2 e1 e2 (r : cont 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 vrfSym As (e : ST As A) i1 i2 a1 a2 (r : cont A)  : 
          (forall y1 y2 m1 m2, r (y1, y1) (m1, m1) -> r (y2, y2) (m2, m2) -> r (y1, y2) (m1, m2)) ->
          (forall i a, verify i (e @0 a) (fun y m => r (y, y) (m, m))) -> 
          verify2 i1 i2 (e @0 a1) (e @0 a2) r.
Proof.
move=>H1 H2 D1 D2 y1 y2 m1 m2; move/(H2 i1 a1 D1)=>R1; move/(H2 i2 a2 D2)=>R2.
by apply: H1 R1 R2.
Qed.

Lemma vrfSym_if As (f : funtp As bool) (e1 e2 : ST As A) 
                i1 i2 a1 a2 (r : cont A) :
          (forall y1 y2 m1 m2, r (y1, y1) (m1, m1) -> 
                               r (y2, y2) (m2, m2) -> r (y1, y2) (m1, m2)) ->
          (forall i a, verify i (if fun_app f a then e1 @0 a else e2 @0 a) 
                                (fun y m => r (y, y) (m, m))) -> 
          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.
Proof.
move=>H1 H2 D1 D2 y1 y2 m1 m2; move/(H2 i1 a1 D1)=>R1; move/(H2 i2 a2 D2)=>R2.
by apply: H1 R1 R2.
Qed.

Lemma vrf2TI i1 i2 e1 e2 (p : Type) (r : cont A) : 
        (p -> verify2 i1 i2 e1 e2 r) ->
        verify2 i1 i2 e1 e2 (fun y m => p -> r y m).
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 : cont A) : 
        (p -> verify2 i1 i2 e1 e2 r) ->
        verify2 i1 i2 e1 e2 (fun y m => p -> r y m).
Proof. by move=>H y1 y2 m1 m2 D1 D2 H1 H2 /= V; apply: H. Qed.

(* definedness *)
Lemma vrf2D i1 i2 e1 e2 (r : cont 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 : A -> heap -> Prop) :
        (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 : cont A) : 
        verify2 i1 i2 e1 e2 r1 -> verify2 i1 i2 e1 e2 r2 ->
        verify2 i1 i2 e1 e2 (fun y m => r1 y m /\ r2 y m).
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 : A -> heap -> Prop) : 
        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 : 
        (def i -> i \In safe (e @0 fun_app f a)) -> 
        (def i -> i \In safe ((e @ f) @0 a)).
Proof. by move=>H; move/H; rewrite /safe -!toPredE /= pre_beta. Qed.

Lemma sbnd_push As A B (e1 : ST As A) (e2 : ST [::: A & As] B) (a : args As) i : 
         (def i -> i \In safe (bind (e1 @0 a)
                                    (e2 @1 (fun y => (y, a))))) -> 
         (def i -> i \In safe (bind e1 e2 @0 a)).
Proof. by rewrite /safe /= pre_beta. 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 : 
         (def i -> i \In safe (bind (e1 @0 fun_app f a) e2)) ->
         (def i -> i \In safe (bind (e1 @ f @0 a) e2)).
Proof. by rewrite /safe /= pre_beta post_beta. Qed.

Lemma sval_do' A (e : ST [:::] A) i : 
        (def i -> pre_of e i) -> def i -> i \In safe 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 (y, y) (i, i) (m, m) -> 
           def m -> m \In safe (e2 @0 [y])) -> 
         def i -> i \In safe (bind e1 e2).
Proof. 
by rewrite /safe /= => H1 H2 D; split=>[|y m]; [apply: H1 | move/H2]. 
Qed.

Lemma sval_do As A (e : ST As A) a i : 
        (def i -> pre_app (pre_of e) a i) -> def i -> i \In safe (e @0 a).
Proof. by move=>H; move/H. Qed.

Lemma sbnd_do As A B (e1 : ST As A) (e2 : ST [::: A] B) a i : 
        (def i -> pre_app (pre_of e1) a i) -> 
        (forall y m, post_app (post_of e1) a a (y, y) (i, i) (m, m) -> 
           def m -> m \In safe (e2 @0 [y])) -> 
         def i -> i \In safe (bind (e1 @0 a) e2).
Proof.
rewrite /safe /= => H1 H2 D.
by split=>[|y m] /=; [apply: H1 | move/H2].
Qed.

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

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

Lemma sval_read A (v : A) x i :
        def (x :-> v :+ i) -> x :-> v :+ i \In safe (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 :
        (def (l :-> v :+ i) -> l :-> v :+ i \In safe (e @0 [v])) -> 
        def (l :-> v :+ i) -> l :-> v :+ i \In safe (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 :
        def (l :-> w :+ i) -> l :-> w :+ i \In safe (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 :
        (def (l :-> v :+ i) -> l :-> v :+ i \In safe (e @0 [tt])) -> 
        def (l :-> w :+ i) -> l :-> w :+ i \In safe (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 : def i -> i \In safe (lalloc @0 [v]).
Proof. by []. Qed.

Lemma sbnd_lalloc A B (e : ST [::: ptr] B) (v : A) i :
        (forall l : ptr, def (l :-> v :+ i) -> 
                      l :-> v :+ i \In safe (e @0 [l])) -> 
         def i -> i \In safe (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 : def i -> i \In safe (halloc @0 [v]).
Proof. by []. Qed.

Lemma sbnd_halloc A B (e : ST [::: ptr] B) (v : A) i :
        (forall l : ptr, def (l :-> v :+ i) -> 
            l :-> v :+ i \In safe (e @0 [l])) -> 
         def i -> i \In safe (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 : 
        def (l :-> v :+ i) -> l :-> v :+ i \In safe (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 :
        (def i -> i \In safe (e @0 [tt])) -> 
        def (l :-> v :+ i) -> l :-> v :+ i \In safe (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_instL As Bs A (e1 : ST Bs A) (e2 : ST [:::] A) 
                 (f : funtp As (args Bs)) a i j r : 
        verify2 i j (e1 @0 fun_app f a) e2 r ->
        verify2 i j ((e1 @ f) @0 a) e2 r. 
Proof.
move=>H D1 D2 y1 y2 m1 m2 S1 S2; apply: H=>//.
by rewrite inst_runs -inst_assoc -inst_runs.
Qed.

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.

Lemma val_instR As Bs A (e1 : ST Bs A) (e2 : ST [:::] A) 
                 (f : funtp As (args Bs)) a i j r : 
        verify2 i j e2 (e1 @0 fun_app f a) r ->
        verify2 i j e2 (e1 @ f @0 a) r.
Proof. by move/vrfC=>H; apply/vrfC; apply: val_instL. Qed.

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

Lemma bnd_pushL As A B (e1 : ST As A) (e2 : ST [::: A & As] B) 
                (e3 : ST [:::] B) (a : args As) i j r : 
        verify2 i j (bind (e1 @0 a) (e2 @1 (fun y => (y, a)))) e3 r ->
        verify2 i j (bind e1 e2 @0 a) e3 r.
Proof.
move=>H D1 D2 y1 y2 m1 m2 S1 S2; apply: H=>//. 
by rewrite -bindR -inst_runs.
Qed.

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.

Lemma bnd_pushR As A B (e1 : ST As A) (e2 : ST [::: A & As] B) 
                (e3 : ST [:::] B) (a : args As) i j r : 
        verify2 i j e3 (bind (e1 @0 a) (e2 @1 (fun y => (y, a)))) r ->
        verify2 i j e3 (bind e1 e2 @0 a) r.
Proof. by move/vrfC=>H; apply/vrfC; apply: bnd_pushL. Qed.

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

Lemma bnd_instL As Bs A B (e1 : ST Bs A) (e2 : ST [::: A] B) (e3 : ST [::] B) 
                 (f : funtp As (args Bs)) (a : args As) i j r : 
        verify2 i j (bind (e1 @0 fun_app f a) e2) e3 r ->
        verify2 i j (bind (e1 @ f @0 a) e2) e3 r.
Proof.
move=>H D1 D2 y1 y2 m1 m2 S1 S2; apply: H=>//.
case: (def_runs S1)=>_ D _; case/bindS: S1=>x [h][H1] H2.
apply: bindC H2; last by rewrite !inst_assoc in H1 *.
by rewrite /= pre_beta post_beta in D.
Qed.

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 *.
by rewrite /= pre_beta post_beta in D.
Qed.

Lemma bnd_instR As Bs A B (e1 : ST Bs A) (e2 : ST [::: A] B) (e3 : ST [:::] B) 
                 (f : funtp As (args Bs)) (a : args As) i j r : 
        verify2 i j e3 (bind (e1 @0 fun_app f a) e2) r ->
        verify2 i j e3 (bind (e1 @ f @0 a) e2) r.
Proof. by move/vrfC => H; apply/vrfC; apply: bnd_instL. Qed.

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

Lemma val_doL As A (e1 : ST As A) (e2 : ST [:::] A) 
                   (a : args As) i j (r : cont A) : 
        (def i -> pre_app (pre_of e1) a i) ->
        (forall y1 m1, post_app (post_of e1) a a (y1, y1) (i, i) (m1, m1) -> 
           verify j e2 (fun y2 m2 => def m1 -> r (y1, y2) (m1, m2))) ->
         verify2 i j (e1 @0 a) e2 r.
Proof.
move=>H1 /= H2 y1 y2 m1 m2 /= D1 D2 S1 S2. 
move: S1; rewrite inst_runs=>S1.
move/H2: (spec_runs S1 S1); move/(_ y2 m2 D2 S2).
by apply; case: (def_runs S1).
Qed.
 
Lemma val_doV As A (e : ST As A) (a : args As) i (r : A -> heap -> Prop) : 
        (def i -> pre_app (pre_of e) a i) ->
        (forall y m, post_app (post_of e) a a (y, y) (i, i) (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 : cont B) : 
        ((def i1 -> pre_app (pre_of e) a1 i1) /\
         (def i2 -> pre_app (pre_of e) a2 i2)) ->
        (forall y1 y2 m1 m2, 
           post_app (post_of e) a1 a2 (y1, y2) (i1, i2) (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_doL As A B (e1 : ST As A) (e2 : ST [::: A] B) e a i j r :
        (def i -> pre_app (pre_of e1) a i) ->
        (forall y m, post_app (post_of e1) a a (y, y) (i, i) (m, m) -> 
                       verify2 m j (e2 @0 [y]) e r) -> 
         verify2 i j (bind (e1 @0 a) e2) e r.
Proof.
move=>H1 H2 D1' D2' y1 y2 m1 m2 /= S1 S2.
case: (def_runs S1)=>D1 _ D2; case: (def_runs S2)=>D3 _ _. 
case/bindS: S1=>x [h1][H3] H4; case: (def_runs H3)=>_ _ D4.
by move/H2: (spec_runs H3 H3); apply=>//; rewrite inst_runs.
Qed.

Lemma bnd_doV As A B (e1 : ST As A) (e2 : ST [::: A] B) a i r :
        (def i -> pre_app (pre_of e1) a i) ->
        (forall y m, post_app (post_of e1) a a (y, y) (i, i) (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/H2: (spec_runs H3 H3); apply=>//; first 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 -> pre_app (pre_of e) a1 i1) /\
         (def i2 -> pre_app (pre_of e) a2 i2)) ->
        (forall y1 y2 m1 m2, 
           post_app (post_of e) a1 a2 (y1, y2) (i1, i2) (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_retL A (e2 : ST [:::] A) v i1 i2 (r : cont A) : 
        verify i2 e2 (fun y2 m2 => def i1 -> r (v, y2) (i1, m2)) ->
        verify2 i1 i2 (ret @0 [v]) e2 r.
Proof. by move=>H; apply: val_doL=>//= =>y1 m1 [[-> _]][-> _]. Qed.

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 : cont 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: val_retL; apply: val_retV=>*; apply: H. Qed.

Lemma bnd_retL A B (e1 : ST [::: A] B) (e2 : ST [:::] B) v i1 i2 r :
        verify2 i1 i2 (e1 @0 [v]) e2 r -> 
        verify2 i1 i2 (bind (ret @0 [v]) e1) e2 r.
Proof. by move=>H; apply: bnd_doL=>//= =>y m [[-> _]][-> _]. 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. by move/vrfC=>H; apply: bnd_retL; apply/vrfC; apply: bnd_retL. Qed. 

(* read *)

Lemma val_readL A e2 l v i1 i2 (r : cont A) : 
         verify i2 e2 (fun y2 m2 => 
           def (l :-> v :+ i1) -> r (v, y2) (l :-> v :+ i1, m2)) ->
         verify2 (l :-> v :+ i1) i2 (read A @0 [l]) e2 r.
Proof.
move=>H; apply: val_doL=>[|y m] /=; first by exists i1; exists v.
by case=>[[-> _]]; case/(_ (i1, i1) (v, v) (erefl _))=>-> _.
Qed.

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 : cont 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: val_readL; apply: val_readV=>*; apply: H. Qed.

Lemma bnd_readL A B (e1 : ST [::: A] B) (e2 : ST [:::] B) l v i1 i2 r : 
        verify2 (l :-> v :+ i1) i2 (e1 @0 [v]) e2 r ->
        verify2 (l :-> v :+ i1) i2 (bind (read A @0 [l]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>[|y m] /=; first by exists i1; exists v.
by case=>[[-> _]]; case/(_ (i1, i1) (v, v) (erefl _))=>->.
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. by move/vrfC=>H; apply: bnd_readL; apply/vrfC; apply: bnd_readL. Qed.

(* write *)

Lemma val_writeL A B e l (v : A) (w : B) i j (r : cont unit) : 
        verify j e (fun y m => def (l :-> v :+ i) -> 
                      r (tt, y) (l :-> v :+ i, m)) ->
        verify2 (l :-> w :+ i) j (write @0 [l, v]) e r.
Proof.
move=>H; apply: val_doL=>[|[] m] /=; first by exists i; exists B; exists w.
by case/(_ (i, i) B B w w (erefl _))=>[[-> _]].
Qed.

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 : cont 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: val_writeL; apply: val_writeV=>*; apply: H. Qed.

Lemma bnd_writeL A A' B (e1 : ST [::: unit] B) (e2 : ST [:::] B) 
                 l (v : A) (w : A') i j r : 
        verify2 (l :-> v :+ i) j (e1 @0 [tt]) e2 r -> 
        verify2 (l :-> w :+ i) j (bind (write @0 [l, v]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>[|[] m] /=; first by exists i; exists A'; exists w.
by case/(_ (i, i) A' A' w w (erefl _))=>[[-> _]].
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. by move/vrfC=>H; apply: bnd_writeL; apply/vrfC; apply: bnd_writeL. Qed.

(* low alloc *)

Lemma val_lallocL A e (v : A) i1 i2 (r : cont ptr) : 
        (forall l:ptr, verify i2 e (fun y2 m2, def (l :-> v :+ i1) -> 
                         r (l, y2) (l :-> v :+ i1, m2))) ->
         verify2 i1 i2 (lalloc @0 [v]) e r.
Proof. by move=>H; apply: val_doL=>//= =>y m [[-> _]]. Qed.
 
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 : cont 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_lallocL A B (e1 : ST [::: ptr] B) 
                      (e2 : ST [:::] B) (v : A) i1 i2 r : 
        (forall l : ptr, verify2 (l :-> v :+ i1) i2 (e1 @0 [l]) e2 r) ->
         verify2 i1 i2 (bind (lalloc @0 [v]) e1) e2 r.
Proof. by move=>H; apply: bnd_doL=>//= =>y m [[-> _]]. 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 : cont B) : 
        (forall l1 l2 : ptr, 
           verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @0 [l1]) (e2 @0 [l2]) 
             (fun y m =>
                (i1 =~ i2 -> l1 = l2 /\ 
                                l1 :-> v1 :+ i1 =~ l2 :-> v2 :+ i2) ->
                 r y m)) ->
         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_hallocL A e (v : A) i1 i2 (r : cont ptr) : 
        (forall l : ptr, verify i2 e (fun y2 m2, 
           high l -> def (l :-> v :+ i1) -> r (l, y2) (l :-> v :+ i1, m2))) ->
         verify2 i1 i2 (halloc @0 [v]) e r.
Proof.
move=>H; apply: val_doL=>//=.
by move=>y m [[-> _]] /= [L _] y2 m2 D S /=; apply: H.
Qed.
 
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 : cont 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: val_hallocL=>l1; apply: val_hallocV=>*; apply: H. Qed.

Lemma bnd_hallocL A B (e1 : ST [::: ptr] B) (e2 : ST [:::] B) (v : A) 
                  i1 i2 (r : cont B) : 
        (forall l : ptr, verify2 (l :-> v :+ i1) i2 (e1 @0 [l]) e2 
                     (fun y m, high l -> r y m)) ->
         verify2 i1 i2 (bind (halloc @0 [v]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>//=.
by move=>y m [[-> _]] /= [L] _ y1 y2 m1 m2 D1 D2 S1 S2; apply: H L.
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 : cont B) : 
        (forall l1 l2 : ptr, 
           verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @0 [l1]) (e2 @0 [l2]) 
                   (fun y m => high l1 -> high l2 -> r y m)) ->
         verify2 i1 i2 (bind (halloc @0 [v1]) e1) (bind (halloc @0 [v2]) e2) r.
Proof.
move=>H; apply: bnd_hallocL=>l1.
apply/vrfC; apply: bnd_hallocL=>l2 D1 D2 y1 y2 m1 m2 S1 S2 /= H1 H2.
by move/vrfC: (H l1 l2); apply.
Qed.

(* low block alloc *)

Lemma val_lallocbL A e (v : A) (n : nat) i1 i2 (r : cont ptr) : 
        (forall l:ptr, verify i2 e (fun y2 m2, def (updi2 l (nseq n v) :+ i1) -> 
          r (l, y2) (updi2 l (nseq n v) :+ i1, m2))) ->
        verify2 i1 i2 (lallocb @0 [v, n]) e r.
Proof. by move=>H; apply: val_doL=>//= =>y m [[-> _]]. Qed.
 
Lemma val_lallocbV A (v : A) (n : nat) i (r : ptr -> heap -> Prop) : 
        (forall l:ptr, def (updi2 l (nseq n v) :+ i) -> r l (updi2 l (nseq n v) :+ i)) -> 
         verify i (lallocb @0 [v, n]) r.
Proof. by move=>H; apply: val_doV=>//= =>y m [[-> _]] _; apply: H. Qed.

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

Lemma bnd_lallocbL A B (e1 : ST [::: ptr] B) 
                       (e2 : ST [:::] B) (v : A) (n : nat) i1 i2 r : 
        (forall l : ptr, verify2 (updi2 l (nseq n v) :+ i1) i2 (e1 @0 [l]) e2 r) ->
         verify2 i1 i2 (bind (lallocb @0 [v, n]) e1) e2 r.
Proof. by move=>H; apply: bnd_doL=>//= =>y m [[-> _]]. Qed.

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

Lemma bnd_lallocb A B (e1 e2 : ST [::: ptr] B) (v1 v2 : A) (n1 n2 : nat)
                 i1 i2 (r : cont B) : 
        (forall l1 l2 : ptr, 
           verify2 (updi2 l1 (nseq n1 v1) :+ i1) (updi2 l2 (nseq n2 v2) :+ i2) 
                   (e1 @0 [l1]) (e2 @0 [l2]) 
             (fun y m =>
                (i1 =~ i2 -> n1 = n2 -> v1 = v2 -> l1 = l2 /\ 
                    updi2 l1 (nseq n1 v1) :+ i1 =~ updi2 l2 (nseq n2 v2) :+ i2) ->
                 r y m)) ->
         verify2 i1 i2 (bind (lallocb @0 [v1, n1]) e1) (bind (lallocb @0 [v2, n2]) 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.   

(* dealloc *)

Lemma val_deallocL A e (l : ptr) (v : A) i j (r : cont unit) : 
        verify j e (fun y m => def i -> r (tt, y) (i, m)) ->
        verify2 (l :-> v :+ i) j (dealloc @0 [l]) e r.
Proof.
move=>H; apply: val_doL=>[|[] m] /=; first by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _))=>[-> _].
Qed.

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 : cont 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: val_deallocL; apply: val_deallocV=>*; apply: H.
Qed.

Lemma bnd_deallocL A B (e1 : ST [::: unit] B) (e2 : ST [::] B) 
                   (l : ptr) (v : A) i j r : 
        verify2 i j (e1 @0 [tt]) e2 r ->
        verify2 (l :-> v :+ i) j (bind (dealloc @0 [l]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>[|[] m] /=; first by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _))=>->.
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.
by move/vrfC=>H; apply: bnd_deallocL; apply/vrfC; apply: bnd_deallocL.
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])). 
- move=>j [[/= H1]] H2 H3; split=>// y1 m1 H4 D4.
  move: (H2 _ _ H4 D4)=>H2'; split=>// y2 m2 H5; 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 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'.
apply: (proj2 S1).
exists (x1, x1); exists (t1, t1); do !split=>//. 
by apply: (spec_runs R1 R1).
Qed.

Lemma bnd_bndL A B C (e1 : ST [:::] A) (e2 : ST [::: A] B) 
               (e3 : ST [::: B] C) e4 i1 i2 r : 
        verify2 i1 i2 (bind e1 (bind e2 (e3 @2 fun x y => [x]))) e4 r ->
        verify2 i1 i2 (bind (bind e1 e2) e3) e4 r.
Proof. by move/vrfS=>H1; apply/vrfS; apply: bnd_bndV. 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. by move/vrfC=>H; apply: bnd_bndL; apply/vrfC; apply: bnd_bndL. 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 -> 
                      d B -> d heap -> d heap -> Prop) : 
       conseq e p (fun a1 a2 y i m => forall x1 x2, q x1 x2 a1 a2 y i m) <->
       conseq e p (fun a1 a2 y i m => forall x, q x.1 x.2 a1 a2 y i m).
Proof.
split; case=>H1 H2; 
split=>// a1 a2 i1 i2 H3 H4 D1 D2 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 
                        D1' D2' y1 y2 m1 m2 S1 S2 (x1, x2)).
Qed.

(* collecting the implications *) 
Lemma impC A (q1 q2 : d heap -> A -> args As -> args As -> Prop)
             (r : A -> args As -> args As -> d B -> d heap -> d heap -> Prop) :
        conseq e p (fun a1 a2 y i m => forall x, q1 i x a1 a2 -> q2 i x a1 a2 -> 
                                                 r x a1 a2 y i m) <->
        conseq e p (fun a1 a2 y i m => 
                      forall x, q1 i x a1 a2 /\ q2 i x a1 a2 -> 
                                r x a1 a2 y i m).
Proof.
by split; case=>H1 H2; 
   split=>// a1 a2 i1 i2 H3 H4 D1 D2 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 : d heap -> B1 -> args As -> args As -> Prop)
            (r : B1 -> B2 -> args As -> args As -> 
                   d B -> d heap -> d heap -> Prop) : 
        conseq e p (fun a1 a2 y i m => forall x1, q i x1 a1 a2 -> 
                                         forall x2, r x1 x2 a1 a2 y i m) <->
        conseq e p (fun a1 a2 y i m => forall x1 x2, q i x1 a1 a2 -> 
                                                     r x1 x2 a1 a2 y i m).
Proof.
split; case=>H1 H2.
- split=>// a1 a2 i1 i2 H3 H4 D1 D2 D1' D2' y1 y2 m1 m2 S1 S2 x1 x2.
  by move/(H2 a1 a2 i1 i2 H3 H4 D1 D2 D1' D2' y1 y2 m1 m2 S1 S2 x1); apply.
by split=>// a1 a2 i1 i2 H3 H4 D1 D2 D1' D2' y1 y2 m1 m2 S1 S2 x1 H x2; apply: H2.
Qed.

Lemma ghE A (q : d heap -> A -> args As -> args As -> Prop) 
            (r : A -> args As -> args As -> d B -> d heap -> d heap -> Prop) : 
        conseq e p (fun a1 a2 y i m => 
                      forall x, q i x a1 a2 -> r x a1 a2 y i m) <->
        (forall a i, p a i -> def i -> i \In safe (e @0 a)) /\
         forall a1 a2 i1 i2 x, 
           q (i1, i2) x a1 a2 -> p a1 i1 -> p a2 i2 -> def i1 -> def i2 ->
           verify2 i1 i2 (e @0 a1) (e @0 a2) 
             (fun y m => r x a1 a2 y (i1, i2) m).
Proof.
split=>//; case=>H1 H2; split=>//.
- by move=>a1 a2 i1 i2 x H3 H4 H5 D1 D2 D1' D2' y1 y2 m1 m2 S1 S2; apply: H2. 
by move=>a1 a2 i1 i2 H3 H4 D1 D2 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 -> 
                      d B -> d heap -> d heap -> Prop) : 
       if_conseq f e1 e2 p (fun a1 a2 y i m => 
                              forall x1 x2, q x1 x2 a1 a2 y i m) <->
       if_conseq f e1 e2 p (fun a1 a2 y i m => 
                              forall x, q x.1 x.2 a1 a2 y i m).
Proof.
split; case=>H1 H2; 
split=>//= a1 a2 i1 i2 H3 H4 D1 D2 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 
                        D1' D2' y1 y2 m1 m2 S1 S2 (x1, x2)).
Qed.

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

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

(****************)
(* Some tactics *)
(****************)

(* for safety *)

Ltac sstep := 
  match goal with 
    | |- is_true (def ?h) -> ?h \In safe (inst0 (inst _ _) _) => 
      apply: sval_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (inst0 (inst0 _ _) _) => 
      apply: sval_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (inst0 (inst1 _ _) _) => 
      apply: sval_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (inst0 (inst2 _ _) _) => 
      apply: sval_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (inst0 (bind _ _) _) => 
      apply: sbnd_push=>/=
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 (inst _ _) _) _) => 
      apply: sbnd_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 (inst0 _ _) _) _) => 
      apply: sbnd_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 (inst1 _ _) _) _) => 
      apply: sbnd_inst=>/=
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 (inst2 _ _) _) _) => 
      apply: sbnd_inst=>/=

    | |- is_true (def ?h) -> ?h \In safe (inst0 ret _) => 
      apply: sval_ret
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 ret _) _) => 
      apply: sbnd_ret

    | |- is_true (def ?h) -> ?h \In safe (inst0 (read _) (?l, tt)) =>
      rewrite -?(pull l); apply: sval_read
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 (read _) (?l, tt)) _) => 
      rewrite -?(pull l); apply: sbnd_read

    | |- is_true (def ?h) -> ?h \In safe (inst0 write (?l, _)) =>
      rewrite -?(pull l); apply: sval_write
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 write (?l, _)) _) => 
      rewrite -?(pull l); apply: sbnd_write

    | |- is_true (def ?h) -> ?h \In safe (inst0 lalloc _) => 
      apply: sval_lalloc
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 lalloc _) _) => 
      apply: sbnd_lalloc

    | |- is_true (def ?h) -> ?h \In safe (inst0 halloc _) => 
      apply: sval_halloc
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 halloc _) _) => 
      apply: sbnd_halloc

    | |- is_true (def ?h) -> ?h \In safe (inst0 dealloc (?l, tt)) => 
      rewrite -?(pull l); apply: sval_dealloc
    | |- is_true (def ?h) -> ?h \In safe (bind (inst0 dealloc (?l, tt)) _) =>
      rewrite -?(pull l); apply: sbnd_dealloc
  end.

Ltac sauto := do !sstep.

(* for correctness *)

(* we first need to pick in which heap we rewrite *)

(* Coq 8.3 screwed up fresh and let *)
(* so the variables XX and YY will actually not be alpha renamed *)
(* if something of the same name already exists *)
(* this is really intolerable, and these tactics have to be *)
(* replaced with lemmas ASAP *)

Ltac pull1 h1 h2 l := 
  let XX := fresh "XX" in
  let YY := fresh "YY" in
  set XX := h1; set YY := h2; 
  rewrite -?(pull l) in XX *; 
  rewrite {}/XX {}/YY. 

Ltac pull2 h1 h2 l1 l2 := 
  let XX := fresh "XX" in
  let YY := fresh "YY" in
  set XX := h1; set YY := h2; 
  rewrite -?(pull l1) in XX *;
  rewrite -?(pull l2) in YY *;
  rewrite {}/XX {}/YY.

(* stepping in lock-step on both sides *) 

Ltac vstep := 
  match goal with 
    | |- verify2 ?h1 ?h2 (inst0 (inst _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (inst0 _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (inst1 _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (inst2 _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 _ (inst0 (inst _ _) _) _ =>
      apply: val_instR=>/=
    | |- verify2 ?h1 ?h2 _ (inst0 (inst0 _ _) _) _ =>
      apply: val_instR=>/=
    | |- verify2 ?h1 ?h2 _ (inst0 (inst1 _ _) _) _ =>
      apply: val_instR=>/=
    | |- verify2 ?h1 ?h2 _ (inst0 (inst2 _ _) _) _ =>
      apply: val_instR=>/=
    | |- verify2 ?h1 ?h2 (inst0 (bind _ _) _) _ _ =>
      apply: bnd_pushL=>/=
    | |- verify2 ?h1 ?h2 _ (inst0 (bind _ _) _) _ =>
      apply: bnd_pushR=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst0 _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst1 _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst2 _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 _ (bind (inst0 (inst _ _) _) _) _ =>
      apply: bnd_instR=>/=
    | |- verify2 ?h1 ?h2 _ (bind (inst0 (inst0 _ _) _) _) _ =>
      apply: bnd_instR=>/=
    | |- verify2 ?h1 ?h2 _ (bind (inst0 (inst1 _ _) _) _) _ =>
      apply: bnd_instR=>/=
    | |- verify2 ?h1 ?h2 _ (bind (inst0 (inst2 _ _) _) _) _ =>
      apply: bnd_instR=>/=

    | |- verify2 ?h1 ?h2 (bind (bind _ _) _) 
                         (bind (bind _ _) _) _ => 
      apply: bnd_bnd

    | |- verify2 ?h1 ?h2 (inst0 ret _) (inst0 ret _) _ => 
      apply: val_ret
    | |- verify2 ?h1 ?h2 (bind (inst0 ret _) _) 
                         (bind (inst0 ret _) _) _ => 
      apply: bnd_ret

    | |- verify2 ?h1 ?h2 (inst0 (read _) (?l1, tt)) 
                         (inst0 (read _) (?l2, tt)) _ =>
      pull2 h1 h2 l1 l2; apply: val_read
    | |- verify2 ?h1 ?h2 (bind (inst0 (read _) (?l1, tt)) _)
                         (bind (inst0 (read _) (?l2, tt)) _) _ => 
      pull2 h1 h2 l1 l2; apply: bnd_read

    | |- verify2 ?h1 ?h2 (inst0 write (?l1, _)) (inst0 write (?l2, _)) _ =>
      pull2 h1 h2 l1 l2; apply: val_write
    | |- verify2 ?h1 ?h2 (bind (inst0 write (?l1, _)) _) 
                         (bind (inst0 write (?l2, _)) _) _ => 
      pull2 h1 h2 l1 l2; apply: bnd_write

    | |- verify2 ?h1 ?h2 (inst0 lalloc _) (inst0 lalloc _) _ => 
      apply: val_lalloc
    | |- verify2 ?h1 ?h2 (bind (inst0 lalloc _) _) 
                         (bind (inst0 lalloc _) _) _ => 
      apply: bnd_lalloc

    | |- verify2 ?h1 ?h2 (inst0 halloc _) (inst0 halloc _) _ => 
      apply: val_halloc
    | |- verify2 ?h1 ?h2 (bind (inst0 halloc _) _) 
                         (bind (inst0 halloc _) _) _ => 
      apply: bnd_halloc

    | |- verify2 ?h1 ?h2 (inst0 dealloc (?l1, tt)) 
                         (inst0 dealloc (?l2, tt)) _ => 
      pull2 h1 h2 l1 l2; apply: val_dealloc
    | |- verify2 ?h1 ?h2 (bind (inst0 dealloc (?l1, tt)) _) 
                         (bind (inst0 dealloc (?l2, tt)) _) _ =>
      pull2 h1 h2 l1 l2; apply: bnd_dealloc
  end.

Ltac vauto := do !vstep.

(* stepping just on one side *)

Ltac lstep := 
  match goal with 
    | |- verify2 ?h1 ?h2 (inst0 (inst _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (inst0 _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (inst1 _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (inst2 _ _) _) _ _ =>
      apply: val_instL=>/=
    | |- verify2 ?h1 ?h2 (inst0 (bind _ _) _) _ _ =>
      apply: bnd_pushL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst0 _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst1 _ _) _) _) _ _ =>
      apply: bnd_instL=>/=
    | |- verify2 ?h1 ?h2 (bind (inst0 (inst2 _ _) _) _) _ _ =>
      apply: bnd_instL=>/=

    | |- verify2 ?h1 ?h2 (bind (bind _ _) _) _ _ => 
      apply: bnd_bndL

    | |- verify2 ?h1 ?h2 (inst0 ret _) _ _ => 
      apply: val_retL
    | |- verify2 ?h1 ?h2 (bind (inst0 ret _) _) _ _ =>
      apply: bnd_retL

    | |- verify2 ?h1 ?h2 (inst0 (read _) (?l, tt)) _ _ =>
      pull1 h1 h2 l; apply: val_readL
    | |- verify2 ?h1 ?h2 (bind (inst0 (read _) (?l, tt)) _) _ _ =>
      pull1 h1 h2 l; apply: bnd_readL

    | |- verify2 ?h1 ?h2 (inst0 write (?l, _)) _ _ =>
      pull1 h1 h2 l; apply: val_writeL
    | |- verify2 ?h1 ?h2 (bind (inst0 write (?l, _)) _) _ _ =>
      pull1 h1 h2 l; apply: bnd_writeL

    | |- verify2 ?h1 ?h2 (inst0 lalloc _) _ _ => 
      apply: val_lallocL
    | |- verify2 ?h1 ?h2 (bind (inst0 lalloc _) _) _ _ =>
      apply: bnd_lallocL

    | |- verify2 ?h1 ?h2 (inst0 halloc _) _ _ => 
      apply: val_hallocL
    | |- verify2 ?h1 ?h2 (bind (inst0 halloc _) _) _ _ =>
      apply: bnd_hallocL

    | |- verify2 ?h1 ?h2 (inst0 dealloc (?l, tt)) _ _ => 
      pull1 h1 h2 l; apply: val_deallocL
    | |- verify2 ?h1 ?h2 (bind (inst0 dealloc (?l, tt)) _) _ _ =>
      pull1 h1 h2 l; apply: bnd_deallocL

    (* and if we run out of lefts *)
    | |- verify ?h (inst0 (inst _ _) _) _ =>
      apply: val_instV=>/=
    | |- verify ?h (inst0 (inst0 _ _) _) _ =>
      apply: val_instV=>/=
    | |- verify ?h (inst0 (inst1 _ _) _) _ =>
      apply: val_instV=>/=
    | |- verify ?h (inst0 (inst2 _ _) _) _ =>
      apply: val_instV=>/=
    | |- verify ?h (inst0 (bind _ _) _) _ =>
      apply: bnd_pushV=>/=
    | |- verify ?h (bind (inst0 (inst _ _) _) _) _ =>
      apply: bnd_instV=>/=
    | |- verify ?h (bind (inst0 (inst0 _ _) _) _) _ =>
      apply: bnd_instV=>/=
    | |- verify ?h (bind (inst0 (inst1 _ _) _) _) _ =>
      apply: bnd_instV=>/=
    | |- verify ?h (bind (inst0 (inst2 _ _) _) _) _ =>
      apply: bnd_instV=>/=

    | |- verify ?h (bind (bind _ _) _) _ => 
      apply: bnd_bndV

    | |- verify ?h (inst0 ret _) _ => 
      apply: val_retV
    | |- verify ?h (bind (inst0 ret _) _) _ =>
      apply: bnd_retV

    | |- verify ?h (inst0 (read _) (?l, tt)) _ =>
      rewrite -?(pull l); apply: val_readV
    | |- verify ?h (bind (inst0 (read _) (?l, tt)) _) _ =>
      rewrite -?(pull l); apply: bnd_readV

    | |- verify ?h (inst0 write (?l, _)) _ =>
      rewrite -?(pull l); apply: val_writeV
    | |- verify ?h (bind (inst0 write (?l, _)) _) _ =>
      rewrite -?(pull l); apply: bnd_writeV

    | |- verify ?h (inst0 lalloc _) _ => 
      apply: val_lallocV
    | |- verify ?h (bind (inst0 lalloc _) _) _ =>
      apply: bnd_lallocV

    | |- verify ?h (inst0 halloc _) _ => 
      apply: val_hallocV
    | |- verify ?h (bind (inst0 halloc _) _) _ =>
      apply: bnd_hallocV

    | |- verify ?h (inst0 dealloc (?l, tt)) _ => 
      rewrite -?(pull l); apply: val_deallocV
    | |- verify ?h (bind (inst0 dealloc (?l, tt)) _) _ =>
      rewrite -?(pull l); apply: bnd_deallocV
  end.

Ltac lauto := do !lstep.
