Require Import ssreflect ssrbool eqtype ssrnat ssrfun seq.
Require Import Eqdep heaps rels hprop domains stmod stcont.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*************************)
(* 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 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 @ fun_app f a)) -> 
        (def i -> i \In safe ((e @@ f) @ a)).
Proof. 
move=>H; move/H.
by rewrite /safe -!toPredE instE /= instE /= instE /= 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 @ a)
                                    (e2 @1 (fun y => (y, a))))) -> 
         (def i -> i \In safe (bind e1 e2 @ a)).
Proof. by rewrite /safe !instE /= !bindE /= !instE /= 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 @ fun_app f a) e2)) ->
         (def i -> i \In safe (bind (e1 @@ f @ a) e2)).
Proof. by rewrite /safe !bindE /= !instE /= !instE /= !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 @ [y])) -> 
         def i -> i \In safe (bind e1 e2).
Proof.
rewrite /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 -> pre_app (pre_of e) a i) -> def i -> i \In safe (e @ a).
Proof. by move=>H; move/H; rewrite /safe instE. 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 @ [y])) -> 
         def i -> i \In safe (bind (e1 @ a) e2).
Proof.
rewrite /safe /= bindE /= => H1 H2 D.
split=>[|y m] /=; rewrite instE /=; first by apply: H1. 
by move/H2; rewrite instE.
Qed.

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

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

Lemma sval_read A (v : A) x i :
        def (x :-> v :+ i) -> x :-> v :+ i \In safe (read A @ [x]).
Proof. 
apply: sval_do=>//= D.
by rewrite readE /=; 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 @ [v])) -> 
        def (l :-> v :+ i) -> l :-> v :+ i \In safe (bind (read A @ [l]) e).
Proof.
move=>H; apply: sbnd_do=>[|y m] /=; rewrite readE /=.
- by exists i; exists v.
by case=>[[-> _]]; case/(_ (i, i) (v, v) (erefl _) (erefl _))=>->.
Qed.

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

Lemma sval_lalloc A (v : A) i : def i -> i \In safe (lalloc @ [v]).
Proof. by move=>D; apply: sval_do=>//=; rewrite lallocE. Qed.

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

Lemma sval_halloc A (v : A) i : def i -> i \In safe (halloc @ [v]).
Proof. by move=>D; apply: sval_do=>//=; rewrite hallocE. Qed.

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

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

Lemma sbnd_dealloc A B (e : ST [:: unit:Type] B) (v : A) l i :
        (def i -> i \In safe (e @ [tt])) -> 
        def (l :-> v :+ i) -> l :-> v :+ i \In safe (bind (dealloc @ [l]) e).
Proof.
move=>H; apply: sbnd_do=>[|[] m] /=; rewrite deallocE.
- by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _) (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 application) 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 @ (fun_app f a)) e2 r ->
        verify2 i j ((e1 @@ f) @ a) e2 r. 
Proof.
move=>H y1 y2 m1 m2 D1 D2 S1 S2; apply: H=>//.
by rewrite -inst_assoc.
Qed.

Lemma val_instV As Bs A (e1 : ST Bs A) (f : funtp As (args Bs)) a i r : 
        verify i (e1 @ (fun_app f a)) r ->
        verify i ((e1 @@ f) @ a) r. 
Proof. by move=>H y m D S; apply: H=>//; rewrite -inst_assoc. 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 @ (fun_app f a)) r ->
        verify2 i j e2 ((e1 @@ f) @ a) r.
Proof. by move/vrfC=>H; apply/vrfC; apply: val_instL. Qed.

(* when instantiating bind, we can push the instantiaion 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 @ a) (e2 @1 (fun y => (y, a)))) e3 r ->
        verify2 i j (bind e1 e2 @ a) e3 r.
Proof.
move=>H D' D2' y y2 m m2 S S2; apply: H=>{S2} //. 
by rewrite -bindR.
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 @ a) (e2 @1 (fun y => (y, a)))) r ->
        verify i (bind e1 e2 @ a) r.
Proof. by move=>H y m D' S; apply: H=>//; rewrite -bindR. 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 @ a) (e2 @1 (fun y => (y, a)))) r ->
        verify2 i j e3 (bind e1 e2 @ 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 @ fun_app f a) e2) e3 r ->
        verify2 i j (bind ((e1 @@ f) @ 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 move/inst_assoc: H1.
move: D; rewrite /Model.bind_pre bindE /=.
by rewrite !instE /= instE /= !pre_beta post_beta.
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 @ fun_app f a) e2) r ->
        verify i (bind ((e1 @@ f) @ 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 move/inst_assoc: H1.
move: D; rewrite /Model.bind_pre bindE /=.
by rewrite !instE /= instE /= pre_beta !post_beta.
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 @ fun_app f a) e2) r ->
        verify2 i j e3 (bind ((e1 @@ f) @ 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 @ 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 (a1:=a) (a2:=a) (code_of e1) S1 S1).
by move/(_ y2 m2 D2 S2); 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 @ 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 (a1:=a) (a2:=a) (code_of e) 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 @ a1) (e @ 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 (a1:=a1) (a2:=a2) (code_of e) 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 @ [y]) e r) -> 
         verify2 i j (bind (e1 @ 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.
move: H3; rewrite inst_runs=>H3.
by move/H2: (spec_runs (a1:=a) (a2:=a) (code_of e1) H3 H3); apply.
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 @ [y]) r) -> 
         verify i (bind (e1 @ a) e2) r.
Proof.
move=>H1 H2 D y m; case/bindS=>x [h1][H3] H4.
move: H3; rewrite inst_runs=>H3.
move/H2: (spec_runs (a1:=a) (a2:=a) (code_of e1) H3 H3); apply=>//.
by case/def_runs: H3.
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 @ [y1]) (e2 @ [y2]) r) -> 
         verify2 i1 i2 
                 (bind (e @ a1) e1) (bind (e @ a2) e2) r.
Proof.
move=>[H1 H2] H3 D1' D2' y1 y2 m1 m2 /=.
case/(bindS (e1:=(e @ a1)))=>x1 [h1][S1] T1.
case/(bindS (e1:=(e @ a2)))=>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 (a1:=a1) (a2:=a2) (code_of e) 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 @ [v]) e2 r.
Proof. 
move=>H; apply: val_doL=>/=; rewrite retE //=.
by move=>y1 m1 [[-> _]][-> _]. 
Qed.

Lemma val_retV A v i (r : A -> heap -> Prop) : 
        (def i -> r v i) -> verify i (ret @ [v]) r.
Proof. 
move=>H; apply: val_doV=>//=; rewrite retE //=.
by move=>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 @ [v1]) (ret @ [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 @ [v]) e2 r -> 
        verify2 i1 i2 (bind (ret @ [v]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>/=; rewrite retE //=.
by move=>y m [[-> _]][-> _]. 
Qed.
 
Lemma bnd_retV A B (e : ST [:: A] B) v i r :
        verify i (e @ [v]) r -> verify i (bind (ret @ [v]) e) r.
Proof. 
move=>H; apply: bnd_doV=>/=; rewrite retE //=.
by move=>y m [[-> _]][-> _].
Qed.
 
Lemma bnd_ret A B (e1 e2 : ST [:: A] B) v1 v2 i1 i2 r : 
        verify2 i1 i2 (e1 @ [v1]) (e2 @ [v2]) r -> 
        verify2 i1 i2 (bind (ret @ [v1]) e1) (bind (ret @ [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 @ [l]) e2 r.
Proof.
move=>H; apply: val_doL=>[|y m] /=; rewrite readE /=.
- by exists i1; exists v.
by case=>[[-> _]]; case/(_ (i1, i1) (v, v) (erefl _) (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 @ [l]) r.
Proof.
move=>H; apply: val_doV=>[|y m] /=; rewrite readE /=.
- by exists i; exists v.
by case=>[[-> _]]; case/(_ (i, i) (v, v) (erefl _) (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 @ [l1]) (read A @ [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 @ [v]) e2 r ->
        verify2 (l :-> v :+ i1) i2 (bind (read A @ [l]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>[|y m] /=; rewrite readE /=.
- by exists i1; exists v.
by case=>[[-> _]]; case/(_ (i1, i1) (v, v) (erefl _) (erefl _))=>->.
Qed.

Lemma bnd_readV A B (e : ST [:: A] B) l v i r : 
        verify (l :-> v :+ i) (e @ [v]) r -> 
        verify (l :-> v :+ i) (bind (read A @ [l]) e) r.
Proof.
move=>H; apply: bnd_doV=>[|y m] /=; rewrite readE /=.
- by exists i; exists v.
by case=>[[-> _]]; case/(_ (i, i) (v, v) (erefl _) (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 @ [v1]) (e2 @ [v2]) r -> 
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)
                (bind (read A1 @ [l1]) e1) (bind (read A2 @ [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 @ [l, v]) e r.
Proof.
move=>H; apply: val_doL=>[|[] m] /=; rewrite writeE /=. 
- by exists i; exists B; exists w.
by case/(_ (i, i) B B w w (erefl _) (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 @ [l, v]) r.
Proof.
move=>H; apply: val_doV=>[|[] m] /=; rewrite writeE /=.
- by exists i; exists B; exists w.
by case/(_ (i, i) B B w w (erefl _) (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 @ [l1, v1]) (write @ [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:Type] B) (e2 : ST [::] B) 
                 l (v : A) (w : A') i j r : 
        verify2 (l :-> v :+ i) j (e1 @ [tt]) e2 r -> 
        verify2 (l :-> w :+ i) j (bind (write @ [l, v]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>[|[] m] /=; rewrite writeE /=.
- by exists i; exists A'; exists w.
by case/(_ (i, i) A' A' w w (erefl _) (erefl _))=>[[-> _]].
Qed.

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

Lemma bnd_write A1 A2 A1' A2' B (e1 e2 : ST [:: unit:Type] B) 
                l1 l2 (v1 : A1) (v2 : A2) (w1 : A1') (w2 : A2') i1 i2 r : 
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @ [tt]) (e2 @ [tt]) r ->
        verify2 (l1 :-> w1 :+ i1) (l2 :-> w2 :+ i2)
                (bind (write @ [l1, v1]) e1) (bind (write @ [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 @ [v]) e r.
Proof. 
move=>H; apply: val_doL=>/=; rewrite lallocE //=.
by move=>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 @ [v]) r.
Proof. 
move=>H; apply: val_doV=>//=; rewrite lallocE //=.
by move=>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 @ [v1]) (lalloc @ [v2]) r.
Proof. 
move=>H; apply: val_do=>//=; rewrite lallocE //=.
by move=>y1 y2 m1 m2 [[-> ->]] /= L D1 D2; apply: H.
Qed.

Lemma bnd_lallocL A B (e1 : ST [:: ptr:Type] B) 
                      (e2 : ST [::] B) (v : A) i1 i2 r : 
        (forall l : ptr, verify2 (l :-> v :+ i1) i2 (e1 @ [l]) e2 r) ->
         verify2 i1 i2 (bind (lalloc @ [v]) e1) e2 r.
Proof. 
move=>H; apply: bnd_doL=>/=; rewrite lallocE //=.
by move=>y m [[-> _]].
Qed.

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

Lemma bnd_lalloc A B (e1 e2 : ST [:: ptr:Type] B) (v1 v2 : A) 
                 i1 i2 (r : cont B) : 
        (forall l1 l2 : ptr, 
            verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @ [l1]) (e2 @ [l2]) 
              (fun y m =>
                 (i1 =~ i2 -> l1 = l2 /\ 
                                 l1 :-> v1 :+ i1 =~ l2 :-> v2 :+ i2) ->
                  r y m)) ->
         verify2 i1 i2 (bind (lalloc @ [v1]) e1) (bind (lalloc @ [v2]) e2) r.
Proof.
move=>H; apply: bnd_do=>/=; rewrite lallocE //=.
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 @ [v]) e r.
Proof.
move=>H; apply: val_doL=>/=; rewrite hallocE //=.
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 @ [v]) r.
Proof. 
move=>H; apply: val_doV=>/=; rewrite hallocE //=.
by move=>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 @ [v1]) (halloc @ [v2]) r.
Proof. by move=>H; apply: val_hallocL=>l1; apply: val_hallocV=>*; apply: H. Qed.

Lemma bnd_hallocL A B (e1 : ST [:: ptr:Type] B) (e2 : ST [::] B) (v : A) 
                  i1 i2 (r : cont B) : 
        (forall l : ptr, verify2 (l :-> v :+ i1) i2 (e1 @ [l]) e2 
                     (fun y m, high l -> r y m)) ->
         verify2 i1 i2 (bind (halloc @ [v]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>/=; rewrite hallocE //=.
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:Type] B) (v : A) i (r : B -> heap -> Prop) :
        (forall l : ptr, verify (l :-> v :+ i) (e @ [l]) 
                     (fun y m => high l -> r y m)) ->
         verify i (bind (halloc @ [v]) e) r.
Proof.
move=>H; apply: bnd_doV=>//=; rewrite hallocE //=.
by move=>y m [[-> _]][L] _ z n D S; apply: H L. 
Qed.

Lemma bnd_halloc A1 A2 B (e1 e2 : ST [:: ptr:Type] B) (v1 : A1) (v2 : A2) 
                 i1 i2 (r : cont B) : 
        (forall l1 l2 : ptr, 
           verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2) (e1 @ [l1]) (e2 @ [l2]) 
                   (fun y m => high l1 -> high l2 -> r y m)) ->
         verify2 i1 i2 (bind (halloc @ [v1]) e1) (bind (halloc @ [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.

(* 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 @ [l]) e r.
Proof.
move=>H; apply: val_doL=>[|[] m] /=; rewrite deallocE /=.
- by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _) (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 @ [l]) r.
Proof.
move=>H; apply: val_doV=>[|[] m] /=; rewrite deallocE /=.
- by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _) (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 @ [l1]) (dealloc @ [l2]) r.
Proof. 
by move=>H; apply: val_deallocL; apply: val_deallocV=>*; apply: H.
Qed.

Lemma bnd_deallocL A B (e1 : ST [:: unit:Type] B) (e2 : ST [::] B) 
                   (l : ptr) (v : A) i j r : 
        verify2 i j (e1 @ [tt]) e2 r ->
        verify2 (l :-> v :+ i) j (bind (dealloc @ [l]) e1) e2 r.
Proof.
move=>H; apply: bnd_doL=>[|[] m] /=; rewrite deallocE /=.
- by exists i; exists A; exists v.
by case/(_ (i, i) A A v v (erefl _) (erefl _))=>->.
Qed.

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

Lemma bnd_dealloc A1 A2 B (e1 e2 : ST [:: unit:Type] B) 
                  (l1 l2 : ptr) (v1 : A1) (v2 : A2) i1 i2 r : 
        verify2 i1 i2 (e1 @ [tt]) (e2 @ [tt]) r ->
        verify2 (l1 :-> v1 :+ i1) (l2 :-> v2 :+ i2)
                (bind (dealloc @ [l1]) e1) (bind (dealloc @ [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.
move: i r.
have L1: Model.bind_pre (rspec_of (bind e1 e2)) (rspec_of e3) <== 
         Model.bind_pre (rspec_of e1) 
                        (rspec_of (bind e2 (e3 @2 fun x y => [x]))).
- rewrite !bindE /= instE /=.
  move=>i [[/= 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=>i r 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] R2 R3. 
apply: H=>//; apply: (bindC (x:=x1) (h:=t1))=>//.
- case: (def_runs R2)=>D H _.
  apply: L1; split=>// y h R2'.
  rewrite bindE /= in S1; apply: (proj2 S1)=>/=.  
  by apply: R2'.
rewrite bindR /=; apply: (bindC (x:=x2) (h:=t2))=>//; last first.
- by rewrite !inst_assoc.
case: (def_runs R2)=>D H _; split=>//= y h R2'.
rewrite instE /= instE /=; rewrite instE /= in R2'. 
rewrite bindE /= in S1; apply: (proj2 S1).
rewrite bindE /=. 
exists (x1, x1); exists (t1, t1); do !split=>//. 
by apply: (spec_runs (code_of e1) (a1:=tt) (a2:=tt) 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 @ 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 @ a1) (e @ 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) (e1 e2 : ST As B).
Variables (p : args [:: bool:Type & As] -> pre [::]).

(* collecting all the quantifiers *)
Lemma ifallC B1 B2 (q : B1 -> B2 -> args [:: _ & As] -> args [:: _ & As] -> 
                      d B -> d heap -> d heap -> Prop) : 
       ifconseq e1 e2 p (fun a1 a2 y i m => forall x1 x2, q x1 x2 a1 a2 y i m) <->
       ifconseq 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=>//= b1 b2 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 b1 b2 a1 a2 i1 i2 H3 H4 D1 D2 
                        D1' D2' y1 y2 m1 m2 S1 S2 (x1, x2)).
Qed.

(* collecting the implications *) 
Lemma ifimpC A (q1 q2 : d heap -> A -> args [:: _ & As] -> args [:: _ & As] -> Prop)
             (r : A -> args [:: _ & As] -> args [:: _ & As] -> d B -> 
                   d heap -> d heap -> Prop) :
        ifconseq 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) <->
        ifconseq 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=>// b1 b2 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 ifghE A (q : d heap -> A -> args [:: _ & As] -> args [:: _ & As] -> Prop) 
              (r : A -> args [:: _ & As] -> args [:: _ & As] -> 
                     d B -> d heap -> d heap -> Prop) : 
        ifconseq e1 e2 p (fun a1 a2 y i m => 
                           forall x, q i x a1 a2 -> r x a1 a2 y i m) <->
        (forall b a i, p (b, a) i -> def i -> 
           i \In safe (if b then e1 @ a else e2 @ a)) /\
         forall b1 b2 a1 a2 i1 i2 x, 
           q (i1, i2) x (b1, a1) (b2, a2) -> 
           p (b1, a1) i1 -> p (b2, a2) i2 -> def i1 -> def i2 ->
           verify2 i1 i2 (if b1 then e1 @ a1 else e2 @ a1) 
                         (if b2 then e1 @ a2 else e2 @ a2)
             (fun y m => r x (b1, a1) (b2, a2) y (i1, i2) m).
Proof.
split=>//; case=>H1 H2; split=>//.
- by move=>b1 b2 a1 a2 i1 i2 x H3 H4 H5 D1 D2 
           D1' D2' y1 y2 m1 m2 S1 S2; apply: H2. 
by move=>b1 b2 a1 a2 i1 i2 H3 H4 D1 D2 
         D1' D2' y1 y2 m1 m2 S1 S2 x H5; apply: H2.
Qed. 

End GhostsIf.

Section GhostsIf2.
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) : 
       ifconseq2 f e1 e2 p (fun a1 a2 y i m => 
                              forall x1 x2, q x1 x2 a1 a2 y i m) <->
       ifconseq2 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) :
        ifconseq2 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) <->
        ifconseq2 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) : 
        ifconseq2 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 @ a else e2 @ 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 @ a1 else e2 @ a1) 
                         (if fun_app f a2 then e1 @ a2 else e2 @ 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 GhostsIf2.

Implicit Arguments STsec [].

Definition gh := ((allC, impC, alimC, ghE), (ifallC2, ifimpC2, ifghE2), 
                  (ifallC, ifimpC, ifghE)).
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
    
    | |- is_true (def ?h) -> ?h \In safe (bind (bind _ _) _) => 
      apply: sbnd_bnd
  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.
