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

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

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

(* First, the mechanism for search-and-replace for the overloaded lemas, *)
(* pattern-matching on heap expressions.                                 *)

Structure tagged_heap := Tag {untag :> heap}.

Definition right_tag := Tag.
Definition left_tag := right_tag.
Canonical Structure found_tag i := left_tag i.

Definition partition_axiom k r (h : tagged_heap) := untag h = k :+ r.

Structure partition (k r : heap) :=
  Partition {heap_of :> tagged_heap; 
             _ : partition_axiom k r heap_of}.

Lemma partitionE r k (f : partition k r) : untag f = k :+ r.
Proof. by case: f=>[[j]] /=; rewrite /partition_axiom /= => ->. Qed.

Lemma found_pf k : partition_axiom k empty (found_tag k). 
Proof. by rewrite /partition_axiom unh0. Qed.

Canonical Structure found_struct k := Partition (found_pf k).

Lemma left_pf h r (f : forall k, partition k r) k : 
        partition_axiom k (r :+ h) (left_tag (f k :+ h)).
Proof. by rewrite partitionE /partition_axiom /= unA. Qed.

Canonical Structure left_struct h r (f : forall k, partition k r) k :=
  Partition (left_pf h f k).

Lemma right_pf h r (f : forall k, partition k r) k :
        partition_axiom k (h :+ r) (right_tag (h :+ f k)).
Proof. by rewrite partitionE /partition_axiom /= unCA. Qed.

Canonical Structure right_struct h r (f : forall k, partition k r) k := 
  Partition (right_pf h f k).

(* automating the lemma selection *)

(* First an algorithm to bring the safety expression into a canonical
form wrt the instantiation. Essentially pull the instantiations
outwards and then in the case of bnd, push them inside the branch. *)

(*********************)
(* Stepping for safe *)
(*********************)

Module SafeStep. 

(* initial state *)
Structure init_tagged_ST As A := InitTag {init_untag :> ST As A}.
Definition init_bnd_tag := InitTag.
Canonical init_inst_tag As A e := @init_bnd_tag As A e.

Structure init_form A (b : bool) i := Init_Form {
  init_pivot :> init_tagged_ST [:::] A;
  _ : {p : Prop | p -> safe i init_pivot}}.

(* hide the prop, so we don't introduce projections for it *)
(* the hiding speeds up typechecking when the application should fail *)

(* we still need the projection, but not it's not a label *)
Definition init_prop A b i (e : @init_form A b i) := 
  let: Init_Form _ (exist p _) := e in p.

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

Structure inst_form As A (b : bool) i a := Inst_Form {
  inst_pivot :> inst_tagged_ST As A;
  _ : {p : Prop | p -> safe i (inst_pivot @0 a)}}.

Definition inst_prop As A b i a (e : @inst_form As A b i a) := 
  let: Inst_Form _ (exist p _) := e in p.

(* bnd_state; the head of the expression is bnd *)
Structure bnd_tagged_ST As A := BndTag {bnd_untag :> ST As A}.
Definition bnd_accept_tag := BndTag.
Canonical bnd_bnd_tag As A e := @bnd_accept_tag As A e.

Structure bnd_form As A B (b : bool) i (e2 : ST [::: A] B) a := 
  Bnd_Form {
    bnd_pivot :> bnd_tagged_ST As A;
    _ : {p : Prop | p -> safe i (bnd_pivot @0 a;; e2)}}.

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

(* the interface for the user *)
(* just removes the tags from ST *)
Structure sval_form As A i (a : args As) := 
  SVal_Form {
    sval_pivot :> ST As A;
    _ : {p : Prop | p -> safe i (sval_pivot @0 a)}}.

Definition sval_prop As A i a (e : @sval_form As A i a) := 
  let: SVal_Form _ (exist p _) := e in p.

Structure sbnd_form As A B i (e2 : ST [::: A] B) (a : args As) :=
  SBnd_Form {
    sbnd_pivot :> ST As A;
    _ : {p : Prop | p -> safe i (sbnd_pivot @0 a;; e2)}}.

Definition sbnd_prop As A B i e2 a (e : @sbnd_form As A B i e2 a) := 
  let: SBnd_Form _ (exist p _) := e in p.

(* transitions *)

(* if the main constructor is inst or bnd with an inst branch then *)
(* branch to an appropriate state; otherwise, nothing to simplify *)

Lemma init_inst_pf As A b i a (e : @inst_form As A b i a) : 
        inst_prop e -> safe i (init_inst_tag (e @0 a)).
Proof. by case: e=>e []. Qed. 

Canonical init_inst As A b i a e := 
  Init_Form b (exist _ _ (@init_inst_pf As A b i a e)).

Lemma init_bnd_pf As A B b i e2 a (e1 : @bnd_form As A B b i e2 a) : 
        bnd_prop e1 -> safe i (init_bnd_tag (e1 @0 a;; e2)).
Proof. by case: e1=>e1 []. Qed. 

Canonical init_bnd As A B b i e2 a e1 := 
  Init_Form b (exist _ _ (@init_bnd_pf As A B b i e2 a e1)).

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

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

(* loop in inst until the secondary constructor is inst; *)
(* keep pushing that inst outward *)
(* if the secondary constructor becomes bnd, move into bnd state *)
(* else terminate *)

Lemma inst_inst_pf As Bs A b i f (a : args As)  
        (e : @inst_form Bs A b i (fun_app f a)) : 
        inst_prop e -> safe i (inst_inst_tag (e @ f) @0 a).
Proof. by case: e=>e [p] H; move/H; apply: sval_inst. Qed.

Canonical inst_inst As Bs A b i f a e :=
  Inst_Form b (exist _ _ (@inst_inst_pf As Bs A b i f a e)).

Lemma inst_bnd_pf As A B b i (e2 : ST (A::As) B) (a : args As) 
        (e1 : @bnd_form As A B b i (e2 @1 fun x => (x, a)) a) :
        bnd_prop e1 -> safe i (inst_bnd_tag (e1;; e2) @0 a).
Proof. by case: e1=>e1 [p] H; move/H; apply: sbnd_push. Qed.

Canonical inst_bnd As A B b i e2 a e1 :=
  Inst_Form b (exist _ _ (@inst_bnd_pf As A B b i e2 a e1)).

Lemma inst_accept_pf As A i (e : ST As A) a : 
        safe i (e @0 a) -> 
        safe i (inst_accept_tag e @0 a).
Proof. by []. Qed.

Canonical inst_accept As A i e a :=
  Inst_Form false (exist _ _ (@inst_accept_pf As A i e a)). 

Lemma inst_call_pf As A i a (e : @sval_form As A i a) : 
        sval_prop e -> safe i (InstTag e @0 a).
Proof. by case: e=>e []. Qed.

Canonical inst_call As A i a e :=
  Inst_Form true (exist _ _ (@inst_call_pf As A i a e)).

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

Lemma bnd_bnd_pf As Bs A B b i f e2 (a : args As)  
        (e1 : @bnd_form Bs A B b i e2 (fun_app f a)) : 
        bnd_prop e1 -> safe i (bnd_bnd_tag (e1 @ f) @0 a;; e2).
Proof. by case: e1=>e1 [p] H; move/H; apply: sbnd_inst. Qed.

Canonical bnd_bnd As Bs A B b i f e2 a e1 := 
  Bnd_Form b (exist _ _ (@bnd_bnd_pf As Bs A B b i f e2 a e1)).

Lemma bnd_accept_pf As A B i (e1 : ST As A) (e2 : ST [::: A] B) a : 
        safe i (e1 @0 a;; e2) -> 
        safe i (bnd_accept_tag e1 @0 a;; e2).
Proof. by []. Qed.

Canonical bnd_accept As A B i e1 e2 a :=
  Bnd_Form false (exist _ _ (@bnd_accept_pf As A B i e1 e2 a)).

Lemma bnd_call_pf As A B i a (e2 : ST [::: A] B) 
                  (e1 : @sbnd_form As A B i e2 a) :
         sbnd_prop e1 -> safe i (BndTag e1 @0 a;; e2).
Proof. by case: e1=>e1 []. Qed.

Canonical bnd_call As A B i a e2 e1 :=
  Bnd_Form true (exist _ _ (@bnd_call_pf As A B i a e2 e1)).

Module Exports.

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

Lemma sstep A i (e : init_form A true i) :
        init_prop e -> safe i e.
Proof. by case: e=>e []. Qed.

Lemma ssimpl A i (e : init_form A false i) :
        init_prop e -> safe i e.
Proof. by case: e=>e []. Qed.

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

End Exports.

End SafeStep.

Export SafeStep.Exports.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End SafeGhost1.

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

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



(***********************)
(* stepping for verify *)
(***********************)

Module VerifyStep. 

(* initial state *)
Structure init_tagged_ST As A := InitTag {init_untag :> ST As A}.
Definition init_bnd_tag := InitTag.
Canonical init_inst_tag As A e := @init_bnd_tag As A e.

Structure init_form A (b : bool) i r := 
  Init_Form {
    init_pivot :> init_tagged_ST [:::] A;
    _ : {p : Prop | p -> verify i init_pivot r}}.

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

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

Structure inst_form As A (b : bool) i a r := 
  Inst_Form {
    inst_pivot :> inst_tagged_ST As A;
    _ : {p : Prop | p -> verify i (inst_pivot @0 a) r}}.

Definition inst_prop As A b i a r (e : @inst_form As A b i a r) := 
  let: Inst_Form _ (exist p _) := e in p.

(* bnd_state; the head of the expression is bnd *)
Structure bnd_tagged_ST As A := BndTag {bnd_untag :> ST As A}.
Definition bnd_accept_tag := BndTag.
Canonical bnd_bnd_tag As A e := @bnd_accept_tag As A e.

Structure bnd_form As A B (b : bool) i a 
                   (e : ST [::: A] B) r := 
  Bnd_Form {
    bnd_pivot :> bnd_tagged_ST As A;
    _ : {p : Prop | p -> verify i (bnd_pivot @0 a;; e) r}}.

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

(* the interface for the user *)
(* just removes the tags from ST *)
Structure vval_form As A i (a : args As) r := 
  VVal_Form {
    vval_pivot :> ST As A;
    _ : {p : Prop | p -> verify i (vval_pivot @0 a) r}}.

Definition vval_prop As A i a r (e : @vval_form As A i a r) := 
  let: VVal_Form _ (exist p _) := e in p.

Structure vbnd_form As A B i (a : args As) (e : ST [::: A] B) r :=
  VBnd_Form {
    vbnd_pivot :> ST As A;
    _ : {p : Prop | p -> verify i (vbnd_pivot @0 a;; e) r}}.

Definition vbnd_prop As A B i a e' r (e : @vbnd_form As A B i a e' r) := 
  let: VBnd_Form _ (exist p _) := e in p.

(* transitions *)

(* if the main constructor is inst or bnd with an inst branch *) 
(* then branch to an appropriate state; otherwise, terminate *)

Lemma init_inst_pf As A b i a r (e : @inst_form As A b i a r) : 
        inst_prop e -> verify i (init_inst_tag (e @0 a)) r.
Proof. by case: e=>pivot []. Qed.

Canonical init_inst As A b i a r e := 
  Init_Form b (exist _ _ (@init_inst_pf As A b i a r e)).

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

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

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

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

(* loop in inst until the secondary constructor is inst; *)
(* keep pushing that inst outward *)
(* if the secondary constructor becomes bnd, move into bnd state *)
(* else terminate *)

Lemma inst_inst_pf As Bs A b i f (a : args As) r  
        (e : @inst_form Bs A b i (fun_app f a) r) : 
        inst_prop e -> verify i (inst_inst_tag (e @ f) @0 a) r.
Proof. by case: e=>e [p] H; move/H; apply: val_instV. Qed.

Canonical inst_inst As Bs A b i f a r e :=
  Inst_Form b (exist _ _ (@inst_inst_pf As Bs A b i f a r e)).

Lemma inst_bnd_pf As A B b i (a : args As) (e' : ST (A::As) B) r 
        (e : @bnd_form As A B b i a (e' @1 fun x => (x, a)) r) :
        bnd_prop e -> verify i (inst_bnd_tag (e;; e') @0 a) r.
Proof. by case: e=>e [p] H; move/H; apply: bnd_pushV. Qed.

Canonical inst_bnd As A B b i a e' r e :=
  Inst_Form b (exist _ _ (@inst_bnd_pf As A B b i a e' r e)).

Lemma inst_accept_pf As A i a (e : ST As A) r :
        verify i (e @0 a) r -> verify i (inst_accept_tag e @0 a) r.
Proof. by []. Qed.

Canonical inst_accept As A i a e r :=
  Inst_Form false (exist _ _ (@inst_accept_pf As A i a e r)).

(* WARNING: here the resolution of e2 will start before the *)
(* unification picked up a2 *)
(* some reordering will be needed here *)

Lemma inst_call_pf As A i a r (e : @vval_form As A i a r) :
        vval_prop e -> verify i (InstTag e @0 a) r.
Proof. by case: e=>e []. Qed.

Canonical inst_call As A i a r e := 
  Inst_Form true (exist _ _ (@inst_call_pf As A i a r e)).

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

Lemma bnd_bnd_pf As Bs A B b i f (a : args As) e' r  
        (e : @bnd_form Bs A B b i (fun_app f a) e' r) : 
        bnd_prop e -> verify i (bnd_bnd_tag (e @ f) @0 a;; e') r.
Proof. by case: e=>e [p] H; move/H; apply: bnd_instV. Qed.

Canonical bnd_bnd As Bs A B b i f a e' r e :=
  Bnd_Form b (exist _ _ (@bnd_bnd_pf As Bs A B b i f a e' r e)).

Lemma bnd_accept_pf As A B i (a : args As) (e : ST As B) 
                    (e' : ST [::: B] A) r :
        verify i (e @0 a;; e') r -> verify i (bnd_accept_tag e @0 a;; e') r. 
Proof. by []. Qed.

Canonical bnd_accept As A B i a e e' r := 
  Bnd_Form false (exist _ _ (@bnd_accept_pf As A B i a e e' r)).

(* WARNING: same problem here as above: e2' is not picked up before
the projection from e2. we may want to introduce notation for bind and
for inst, to reorder the arguments *)
Lemma bnd_call_pf As A B i (a : args As) 
        (e' : ST [::: A] B) r  (e : @vbnd_form As A B i a e' r) :
        vbnd_prop e -> verify i (BndTag e @0 a;; e') r. 
Proof. by case: e=>e []. Defined. 

Canonical bnd_call As A B i a e' r e := 
  Bnd_Form true (exist _ _ (@bnd_call_pf As A B i a e' r e)).

Module Exports.

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

Lemma vvstep A i r (e : @init_form A true i r) :
        init_prop e -> verify i e r.
Proof. by case: e=>e []. Qed.

Lemma vvsimpl A i r (e : @init_form A false i r) :
        init_prop e -> verify i e r. 
Proof. by case: e=>e []. Qed.

Notation VVal_Form p := (VerifyStep.VVal_Form (exist _ _ p)).
Notation VBnd_Form p := (VerifyStep.VBnd_Form (exist _ _ p)).

End Exports.

End VerifyStep.

Export VerifyStep.Exports.

Ltac vvstep := do ![apply: vvstep=>/=].

Canonical vval_ret_form A v i r := 
  VVal_Form (@val_retV A v i r).
Canonical vbnd_ret_form A B e v i r := 
  VBnd_Form (@bnd_retV A B e v i r).

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

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

Canonical vval_read_form A v x i r f :=
  VVal_Form (@vval_readO A v x i f r). 

Canonical vbnd_read_form A B e x v i f r :=
  VBnd_Form (@vbnd_readO A B e x v i f r). 

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

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

Canonical vval_write_form A B x v w i f r := 
  VVal_Form (@vval_writeO A B x v w i f r). 

Canonical vbnd_write_form A A' B e x v w i r f :=
  VBnd_Form (@vbnd_writeO A A' B e x v w i r f). 


(************************)
(* stepping for verify2 *)
(************************)

Module Verify2Step. 

(* initial state *)
Structure linit_tagged_ST As A := LInitTag {linit_untag :> ST As A}.
Definition linit_bnd_tag := LInitTag.
Canonical linit_inst_tag As A e := @linit_bnd_tag As A e.

Structure linit_form A (b : bool) i j e2 r := 
  LInit_Form {
    linit_pivot :> linit_tagged_ST [:::] A;
    _ : {p: Prop | p -> verify2 i j linit_pivot e2 r}}.

Definition linit_prop A b i j e2 r (e : @linit_form A b i j e2 r) := 
  let: LInit_Form _ (exist p _) := e in p.

(* right-hand side of the initial state *)
Structure rinit_tagged_ST As A := RInitTag {rinit_untag :> ST As A}.
Definition rinit_bnd_tag := RInitTag.
Canonical rinit_inst_tag As A e := @rinit_bnd_tag As A e.

Structure rinit_form A (b : bool) i j e1 r := 
  RInit_Form {
    rinit_pivot :> rinit_tagged_ST [:::] A;
    _ : {p : Prop | p -> verify2 i j e1 rinit_pivot r}}.

Definition rinit_prop A b i j e1 r (e : @rinit_form A b i j e1 r) := 
  let: RInit_Form _ (exist p _) := e in p.

(* linst state; the head of the left expression is inst *)
Structure linst_tagged_ST As A := LInstTag {linst_untag :> ST As A}.
Definition linst_bnd_tag := LInstTag. 
Canonical linst_inst_tag As A e := @linst_bnd_tag As A e.

Structure linst_form As A (b : bool) i j a e2 r := 
  LInst_Form {
    linst_pivot :> linst_tagged_ST As A;
    _ : {p : Prop | p -> verify2 i j (linst_pivot @0 a) e2 r}}.

Definition linst_prop As A b i j a e2 r (e : @linst_form As A b i j a e2 r) := 
  let: LInst_Form _ (exist p _) := e in p.

(* rinst state; the head of the right expression is inst *)
Structure rinst_tagged_ST As A := RInstTag {rinst_untag :> ST As A}.
Definition rinst_accept_tag := RInstTag.
Definition rinst_bnd_tag := rinst_accept_tag.
Canonical rinst_inst_tag As A e := @rinst_bnd_tag As A e.

Structure rinst_form As A (b : bool) i j a e1 r := 
  RInst_Form {
    rinst_pivot :> rinst_tagged_ST As A;
    _ : {p : Prop | p -> verify2 i j e1 (rinst_pivot @0 a) r}}.

Definition rinst_prop As A b i j a e1 r (e : @rinst_form As A b i j a e1 r) := 
  let: RInst_Form _ (exist p _) := e in p.

(* lbnd_state; the head of the left expression is bnd *)
Structure lbnd_tagged_ST As A := LBndTag {lbnd_untag :> ST As A}.
Canonical lbnd_bnd_tag As A e := @LBndTag As A e.

Structure lbnd_form As A B (b : bool) i j a
                    (e1' : ST [::: A] B) e2' r := 
  LBnd_Form {
    lbnd_pivot :> lbnd_tagged_ST As A;
    _ : {p : Prop | p -> verify2 i j (lbnd_pivot @0 a;; e1') e2' r}}.

Definition lbnd_prop As A B b i j a e1' e2' r 
                     (e : @lbnd_form As A B b i j a e1' e2' r) := 
  let: LBnd_Form _ (exist p _) := e in p.

(* rbnd_state; the head of the right expression is bnd *)
Structure rbnd_tagged_ST As A := RBndTag {rbnd_untag :> ST As A}.
Definition rbnd_accept_tag := RBndTag.
Canonical rbnd_bnd_tag As A e := @rbnd_accept_tag As A e.

Structure rbnd_form As A B (b : bool) i j a e1'
                    (e2' : ST [::: A] B) r := 
  RBnd_Form {
    rbnd_pivot :> rbnd_tagged_ST As A;
    _ : {p : Prop | p -> verify2 i j e1' (rbnd_pivot @0 a;; e2') r}}.

Definition rbnd_prop As A B b i j a e1' e2' r 
                     (e : @rbnd_form As A B b i j a e1' e2' r) := 
  let: RBnd_Form _ (exist p _) := e in p.

(* the interface for the user *)
(* just removes the tags from ST *)
Structure val_form As A i j (a1 a2 : args As) e1 r := 
  Val_Form {
    val_pivot :> ST As A;
    _ : {p : Prop | p -> verify2 i j (e1 @0 a1) (val_pivot @0 a2) r}}.

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

Structure bnd_form As A B i j (a1 a2 : args As) (e1 : ST As A) e1'  
                   (e2' : ST [::: A] B) r :=
  Bnd_Form {
    bnd_pivot :> ST As A;
    _ : {p : Prop | p -> verify2 i j (e1 @0 a1;; e1') 
                                     (bnd_pivot @0 a2;; e2') r}}.

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

(* transitions *)

(* if the main constructor on the left is inst or bnd with an inst *) 
(* branch then branch to an appropriate state; otherwise, switch to right *)

Lemma linit_linst_pf As A b i j a e2 r (e1 : @linst_form As A b i j a e2 r) : 
        linst_prop e1 -> verify2 i j (linit_inst_tag (e1 @0 a)) e2 r.
Proof. by case: e1=>e1 []. Qed. 

Canonical linit_linst As A b i j a e2 r e1 := 
  LInit_Form b (exist _ _ (@linit_linst_pf As A b i j a e2 r e1)).

Lemma linit_lbnd_pf As A B b i j a e2 e2' r  
        (e1 : @lbnd_form As A B b i j a e2 e2' r) : 
        lbnd_prop e1 -> verify2 i j (linit_bnd_tag (e1 @0 a;; e2)) e2' r.
Proof. by case: e1=>e1 []. Qed. 

Canonical linit_lbnd As A B b i j a e2 e2' r e1 := 
  LInit_Form b (exist _ _ (@linit_lbnd_pf As A B b i j e2 e2' a r e1)).

Lemma linit_rinit_pf A b i j e1 r (e2 : @rinit_form A b i j e1 r) : 
        rinit_prop e2 -> verify2 i j (LInitTag e1) e2 r.
Proof. by case: e2=>e2 []. Qed.

Canonical linit_rinit A b i j e1 r e2 := 
  LInit_Form b (exist _ _ (@linit_rinit_pf A b i j e1 r e2)).

Lemma rinit_rinst_pf As A b i j a e1 r (e2 : @rinst_form As A b i j a e1 r) : 
        rinst_prop e2 -> verify2 i j e1 (rinit_inst_tag (e2 @0 a)) r.
Proof. by case: e2=>e2 []. Qed.

Canonical rinit_rinst As A b i j a e1 r e2 := 
  RInit_Form b (exist _ _ (@rinit_rinst_pf As A b i j a e1 r e2)).

Lemma rinit_rbnd_pf As A B b i j a e1' e2' r  
        (e2 : @rbnd_form As A B b i j a e1' e2' r) : 
        rbnd_prop e2 -> verify2 i j e1' (rinit_bnd_tag (e2 @0 a;; e2')) r.
Proof. by case: e2=>e2 []. Qed. 

Canonical rinit_rbnd As A B b i j a e1' e2' r e1 := 
  RInit_Form b (exist _ _ (@rinit_rbnd_pf As A B b i j e1' e2' a r e1)).

Lemma rinit_accept_pf A i j (e1 : ST [:::] A) e2 r : 
        verify2 i j e1 e2 r -> verify2 i j e1 (RInitTag e2) r.
Proof. by []. Qed.

Canonical rinit_accept A i j e1 e2 r :=
   RInit_Form false (exist _ _ (@rinit_accept_pf A i j e1 e2 r)).

(* loop in linst until the secondary constructor is inst; *)
(* keep pushing that inst outward *)
(* if the secondary constructor becomes bnd, move into lbnd state *)
(* else move to rinit *)

Lemma linst_linst_pf As Bs A b i j f (a : args As) e2 r  
        (e1 : @linst_form Bs A b i j (fun_app f a) e2 r) : 
        linst_prop e1 -> verify2 i j (linst_inst_tag (e1 @ f) @0 a) e2 r.
Proof. by case: e1=>e1 [p] H; move/H; apply: val_instL. Qed.

Canonical linst_linst As Bs A b i j f a e2 r e1 :=
  LInst_Form b (exist _ _ (@linst_linst_pf As Bs A b i j f a e2 r e1)).

Lemma linst_lbnd_pf As A B b i j (a : args As) (e1' : ST (A::As) B) e2' r
        (e1 : @lbnd_form As A B b i j a (e1' @1 fun x => (x, a)) e2' r) :
        lbnd_prop e1 -> verify2 i j (linst_bnd_tag (e1;; e1') @0 a) e2' r.
Proof. by case: e1=>e1 [p] H; move/H; apply: bnd_pushL. Qed.

Canonical linst_lbnd As A B b i j a e1' e2' r e1 :=
  LInst_Form b (exist _ _ (@linst_lbnd_pf As A B b i j a e1' e2' r e1)).

Lemma linst_rinit_pf As A b i j a (e1 : ST As A) r 
        (e2 : @rinit_form A b i j (e1 @0 a) r) :
        rinit_prop e2 -> verify2 i j (LInstTag e1 @0 a) e2 r.
Proof. by case: e2=>e2 []. Qed.

Canonical linst_rinit As A b i j a e1 r e2 :=
  LInst_Form b (exist _ _ (@linst_rinit_pf As A b i j a e1 r e2)).

(* loop in rinst until the secondary constructor is inst; *)
(* keep pushing that inst outward *)
(* if the secondary constructor becomes bnd, move into rbnd state *)
(* else terminate *)

Lemma rinst_rinst_pf As Bs A b i j f (a : args As) e1 r 
        (e2 : @rinst_form Bs A b i j (fun_app f a) e1 r) : 
        rinst_prop e2 -> verify2 i j e1 (rinst_inst_tag (e2 @ f) @0 a) r.
Proof. by case: e2=>e2 [p] H; move/H; apply: val_instR. Qed.

Canonical rinst_rinst As Bs A b i j f a e1 r e2 :=
  RInst_Form b (exist _ _ (@rinst_rinst_pf As Bs A b i j f a e1 r e2)).

Lemma rinst_rbnd_pf As A B b i j (a : args As) e1' (e2' : ST (A::As) B) r
        (e2 : @rbnd_form As A B b i j a e1' (e2' @1 fun x => (x, a)) r) :
        rbnd_prop e2 -> verify2 i j e1' (rinst_bnd_tag (e2;; e2') @0 a) r.
Proof. by case: e2=>e2 [p] H; move/H; apply: bnd_pushR. Qed.

Canonical rinst_rbnd As A B b i j a e1' e2' r e2 :=
  RInst_Form b (exist _ _ (@rinst_rbnd_pf As A B b i j a e1' e2' r e2)).

Lemma rinst_accept_pf As A i j a e1 (e2 : ST As A) r :
        verify2 i j e1 (e2 @0 a) r -> 
        verify2 i j e1 (rinst_accept_tag e2 @0 a) r.
Proof. by []. Qed.

Canonical rinst_accept As A i j a e1 e2 r :=
  RInst_Form false (exist _ _ (@rinst_accept_pf As A i j a e1 e2 r)).

(* WARNING: here the resolution of e2 will start before the unification picked up a2 *)
(* some reordering will be needed here *)
(* not sure why this worked in safety *)

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

Canonical rinst_call As A i j a1 a2 e1 r e2 := 
  RInst_Form true (exist _ _ (@rinst_call_pf As A i j a1 a2 e1 r e2)).

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

Lemma lbnd_lbnd_pf As Bs A B b i j f (a : args As) e1' e2' r 
        (e1 : @lbnd_form Bs A B b i j (fun_app f a) e1' e2' r) : 
        lbnd_prop e1 -> verify2 i j (lbnd_bnd_tag (e1 @ f) @0 a;; e1') e2' r.
Proof. by case: e1=>e1 [p] H; move/H; apply: bnd_instL. Qed.

Canonical lbnd_lbnd As Bs A B b i j f a e1' e2' r e1 :=
  LBnd_Form b (exist _ _ (@lbnd_lbnd_pf As Bs A B b i j f a e1' e2' r e1)).

Lemma lbnd_rinit_pf As A B b i j (a : args As) (e1 : ST As B) e1' r  
        (e2 : @rinit_form A b i j (e1 @0 a;; e1') r) :
        rinit_prop e2 -> verify2 i j (LBndTag e1 @0 a;; e1') e2 r. 
Proof. by case: e2=>e2 []. Qed.

Canonical lbnd_rinit As A B b i j a e1 e1' r e2 := 
  LBnd_Form b (exist _ _ (@lbnd_rinit_pf As A B b i j a e1 e1' r e2)).

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

Lemma rbnd_rbnd_pf As Bs A B b i j f (a : args As) e1' e2' r  
        (e2 : @rbnd_form Bs A B b i j (fun_app f a) e1' e2' r) : 
        rbnd_prop e2 -> verify2 i j e1' (rbnd_bnd_tag (e2 @ f) @0 a;; e2') r.
Proof. by case: e2=>e2 [p] H; move/H; apply: bnd_instR. Qed.

Canonical rbnd_rbnd As Bs A B b i j f a e1' e2' r e1 :=
  RBnd_Form b (exist _ _ (@rbnd_rbnd_pf As Bs A B b i j f a e1' e2' r e1)).

Lemma rbnd_accept_pf As A B i j (a : args As) (e1 : ST [:::] A) 
                     (e2 : ST As B) e2' r :
        verify2 i j e1 (e2 @0 a;; e2') r -> 
        verify2 i j e1 (rbnd_accept_tag e2 @0 a;; e2') r. 
Proof. by []. Qed.

Canonical rbnd_accept As A B i j a e1 e2 e2' r := 
  RBnd_Form false (exist _ _ (@rbnd_accept_pf As A B i j a e1 e2 e2' r)).

(* WARNING: same problem here as above: e2' is not picked up before
the projection from e2. we may want to introduce notation for bind and
for inst, to reorder the arguments *)
Lemma rbnd_call_pf As A B i j (a1 a2 : args As) (e1 : ST As A) e1'
        (e2' : ST [::: A] B) r  
        (e2 : @bnd_form As A B i j a1 a2 e1 e1' e2' r) :
        bnd_prop e2 -> verify2 i j (e1 @0 a1;; e1') (RBndTag e2 @0 a2;; e2') r. 
Proof. by case: e2=>e2 []. Qed.

Canonical rbnd_call As A B i j a1 a2 e1 e1' e2' r e2 := 
  RBnd_Form true (exist _ _ (@rbnd_call_pf As A B i j a1 a2 e1 e1' e2' r e2)).

Module Exports.

Canonical linit_inst_tag.
Canonical rinit_inst_tag.
Canonical linst_inst_tag.
Canonical rinst_inst_tag.
Canonical lbnd_bnd_tag.
Canonical rbnd_bnd_tag.
Canonical linit_linst.
Canonical linit_lbnd.
Canonical linit_rinit.
Canonical rinit_rinst.
Canonical rinit_rbnd.
Canonical rinit_accept.
Canonical linst_linst.
Canonical linst_lbnd.
Canonical linst_rinit.
Canonical rinst_rinst.
Canonical rinst_rbnd.
Canonical rinst_accept.
Canonical rinst_call.
Canonical lbnd_lbnd.
Canonical lbnd_rinit. 
Canonical rbnd_rbnd.
Canonical rbnd_accept.
Canonical rbnd_call.

Lemma vstep A i j r e2 (e1 : @linit_form A true i j e2 r) :
        linit_prop e1 -> verify2 i j e1 e2 r.
Proof. by case: e1=>e1 []. Qed.

Lemma vsimpl A i j r e2 (e1 : @linit_form A false i j e2 r) :
        linit_prop e1 -> verify2 i j e1 e2 r. 
Proof. by case: e1=>e1 []. Qed.

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

End Exports.

End Verify2Step.

Export Verify2Step.Exports.

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

Canonical val_ret_form A v1 v2 i1 i2 r := 
  Val_Form (@val_ret A v1 v2 i1 i2 r).
Canonical bnd_ret_form A B e1 e2 v1 v2 i1 i2 r := 
  Bnd_Form (@bnd_ret A B e1 e2 v1 v2 i1 i2 r).

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

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

Canonical val_read_form A v1 v2 x1 x2 i1 i2 r f1 f2 :=
  Val_Form (@val_readO A v1 v2 x1 x2 i1 i2 f1 f2 r). 

Canonical bnd_read_form A B e1 e2 x1 x2 v1 v2 i1 i2 f1 f2 r :=
  Bnd_Form (@bnd_readO A B e1 e2 x1 x2 v1 v2 i1 i2 f1 f2 r). 

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

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

Canonical val_write_form A B1 B2 x1 x2 v1 v2 w1 w2 i1 i2 f1 f2 r := 
  Val_Form (@val_writeO A B1 B2 x1 x2 v1 v2 w1 w2 i1 i2 f1 f2 r). 

Canonical bnd_write_form A A1' A2' B e1 e2 x1 x2 v1 v2 w1 w2 i1 i2 r f1 f2 :=
  Bnd_Form (@bnd_writeO A A1' A2' B e1 e2 x1 x2 v1 v2 w1 w2 i1 i2 r f1 f2). 

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

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






(* testing *)

Fixpoint public (ls : seq ptr) : Pred (d heap) :=
  if ls is l::ls then 
    fun i => look l i.1 = look l i.2 /\ public ls i
  else PredT.

Lemma public_refl ls i : public ls (i, i).
Proof. by elim: ls. Qed.

Hint Resolve public_refl. 

Section Silly.
Variables x y z h l : ptr.

Definition spec1 : spec [::: bool; unit] unit :=
    (fun _ _ i => exists u:nat, exists j, exists h, 
                    i = j :+ h /\ j = x :-> u, 
     fun bb _ ii yy mm=> 
       forall (uu : d nat) jj hh, 
         ii = jj :++ hh -> jj = (x :-> uu.1, x :-> uu.2) ->
         exists jj', mm = jj' :++ hh /\ 
           jj' = (if bb.1 then x :-> 1 else jj.1, 
                 (if bb.2 then x :-> 1 else jj.2))).

Definition spec2 : spec [::: unit; bool; unit] unit := 
  (fun _ _ _ i => exists u:nat, exists j, exists h, 
                    i = j :+ h /\ j = x :-> u :+ z :-> 1, 
   fun _ bb _ ii yy mm=> 
     forall (uu : d nat) jj hh, 
       ii = jj :++ hh -> jj = (x :-> uu.1 :+ z :-> 1, x :-> uu.2 :+ z :-> 1) ->
       exists jj', mm = jj' :++ hh /\ 
         jj' = (if ~~ bb.1 then x :-> 1 :+ z :-> 1 else jj.1, 
                if ~~ bb.2 then x :-> 1 :+ z :-> 1 else jj.2)).

Program
Definition silly' :
  STsec [:::] unit
    (fun i => 
       exists f, exists u:nat, exists v:nat, 
       exists w:nat, exists b:bool, exists c:nat, 
         i = x :-> u :+ y :-> v :+ z :-> w :+ h :-> b :+ l :-> c :+ f, 
     fun i r m => public [:: l; y] i -> public [:: l; y] m) :=
  Do (write @ [z, 1];;
      read bool @ (fun _ => [h]);;
      Ifbool (fun b _ => b) then 
        write @ (fun b _ => [x, 1])
        else ret @ (fun b _ => [tt])
      with [::: bool; unit], unit, spec1;;
      Ifbool (fun _ b _ => ~~ b) then 
        read nat @ (fun _ _ _ => [z]);;
        write @ (fun w _ _ _ => [x, w])
      else ret @ (fun _ _ _ => [tt]) 
      with [::: unit; bool; unit], unit, spec2;;
      read nat @ (fun _ _ b _ => [x]);;
      read nat @ (fun u _ _ b _ => [y]);;
      write @ (fun v u _ _ b _ => [l, u + v]);;
      ret @ (fun _ v u _ _ b _ => [tt])).
Next Obligation.
rewrite !gh; split.
- by case=>b g i [u][j][k][->] ->; case: b; sstep.
case=>b1 g1 [b2 g2] i1 i2 [[[[]]]][u1 u2][j1 j2][k1 k2][] /= [->->][->->] _ _.
by case: b1; case: b2; apply/vrfS1; vvstep=>_; vvstep; eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>/=.
- by move=>[[]][b][[][]] i [u][j][k][->->]; case: b; sstep.
case=>[[]][b1][[][]][[]][b2][[][]] i1 i2 [[[[]]]][u1 u2][j1 j2][k1 k2][] /=.
case=>[->->][->->] _ _; apply/vrfS1.
by case: b1; case: b2; do 2![vvstep=>_]; eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>/=.
- move=>[] i [f][u][v][w][b][c] ->; sstep; apply: ssimpl=>/=.
  apply: (sbndO1 (x:->_))=>//= [[j]][->] _.
  apply: ssimpl; rewrite /= -(unAC _ (z :-> _)). 
  by case: b; apply: (sbndO1 (x:->_ :+ z:->_))=>//= [[j']][->] _; sstep.
move=>[][] i1 i2 _ [E1][E2] _.
move=>[h1][u1][v1][w1][b1][c1] -> [h2][u2][v2][w2][b2][c2] ->.
apply: vstep=>/=.
apply: vstep=>/=.
set j1 := hide (ifbool _ then _ else _).
set j2 := hide (ifbool _ then _ else _).
have U1 : ST [::: bool; unit] unit. admit.
have U2 : ST [::: unit; bool; unit] unit. admit.
have [<-<-] : U1 = j1 /\ U2 = j2. admit.
set j3 := (read _ @ _).
set j4 := (read _ @ _).
set j5 := (write @ _).
set j6 := (ret @ _).
apply: vsimpl. simpl.
set j7 := (U2 ;; _).
have V1 : ST [::: unit; bool; unit] unit. admit.
have <- : V1 = j7. admit.
set j8 := x :-> u1 :+ _ :+ _ :+ _.
set j9 := x :-> u2 :+ _ :+ _ :+ _.
have W1 : heap. admit.
have W2 : heap. admit.
apply/vrfS1.
apply: vvstep=>/=.

apply: vstep=>/=. (* why does this take so long to fail? maybe the order at the WARNING line above is a problem *)
apply: vsimpl. simpl.
apply: vstep.
apply: vvstep.
apply: vsimpl. simpl.
admit.
Qed.
