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

(************************************************************)
(* Section 5 in the paper: A module for singly-linked lists *)
(* with a shape predicate that doesn't specify the linkage  *)
(************************************************************)

Module List. Section List.
Variable T : Type.
Inductive node : Type := Node {elem : T; next : ptr}.

Definition list := ptr.

Fixpoint lseq (x : ptr) (vs : seq T) : Pred heap := 
  if vs is v::vt then 
    fun i => exists z, exists j, i = x :-> Node v z :+ j /\ 
                                 j \In lseq z vt
  else fun i => x = null /\ i = empty.

Lemma lseq_null vs i : def i -> i \In lseq null vs -> vs = [::] /\ i = empty.
Proof.
elim: vs i=>[|v vs IH] i D; first by case.
by case=>z [j][E]; move: E D => -> E; move: (defPt_null E).
Qed.

Lemma lseq_pos vs (x : ptr) i : 
        x != null -> i \In lseq x vs -> 
        exists v, exists z, exists j, 
          [/\ vs = v :: (behead vs), i = x :-> Node v z :+ j & 
              j \In lseq z (behead vs)].
Proof.
case: vs=>[|v vt] E /=; first by move=>H; case: H E=>->.
by case=>z [j][->] H; exists v; exists z; exists j.
Qed.

Definition shape (p : list) (vs : seq T) : Pred heap :=
  fun i => exists z, exists j, i = p :-> z :+ j /\ j \In lseq z vs.

Definition sshape (pp : d list) (vvs : d (seq T)) : Pred (d heap) := 
  fun ii => ii.1 \In shape pp.1 vvs.1 /\ ii.2 \In shape pp.2 vvs.2.

Program 
Definition new : 
  STsec [::] ptr
    (fun i => True, 
     fun ii yy mm => 
       exists jj, mm = jj :++ ii /\ sshape yy (nil, nil) jj /\
                  ii.1 =~ ii.2 -> yy.1 = yy.2 /\ jj.1 = jj.2) :=
  Do (lalloc @ [null]).
Next Obligation.
split; first by case=>i _; sstep.
case=>[[]] i1 i2 _ _; v2step=>y1 y2 D1 D2 L _.
exists (y1 :-> null, y2 :-> null)=>[[_]][_] /=.  
by case/L=>->.
Qed.

(* inserting low *)
Program 
Definition insert : 
  STsec [::: ptr; T] unit 
    (fun p v i => exists h, exists j, exists vs,
                    i = j :+ h /\ j \In shape p vs, 
     fun pp vv ii yy mm => 
       forall hh jj vvs, 
         ii = jj :++ hh -> jj \In sshape pp vvs -> 
       exists jj', 
         mm = jj' :++ hh /\ jj' \In sshape pp (vv.1::vvs.1, vv.2::vvs.2) /\
         (pp.1 = pp.2 -> vv.1 = vv.2 -> jj.1 = jj.2 -> 
          hh.1 =~ hh.2 -> jj'.1 = jj'.2)) :=
  Do (read ptr @ (fun p v => [p]);;
      lalloc @ (fun head p v => [Node v head]);;
      write @ (fun x (head :ptr) p v => [p, x])).
Next Obligation.
rewrite !gh; split=>[[p][v][]|[p1][v1][][p2][v2][]] /=.
- by move=>i [h][_][vs][->][x][j][->] H; sstep=>l; sstep.
move=>i1 i2 [[[[]]]] /= h [k1 k2] vs [[[-> ->]]][/=].
case=>x1 [j1][/= ->{k1}] H1 [x2][j2][->{k2}] H2 _ _; apply: vrf2D=>D1 D2.
v2step=>l1 l2; v2step=> _ _; rewrite !unA -!(pull p1) -!(pull p2) /plus2 => H.
eexists (_, _); split=>//=; rewrite -!unA; hhauto.
move=>E1 E2 L1 L2. 
rewrite -{p2}E1 -{v2}E2 in D1 D2 H L1 *.
move: (D1); rewrite !unA; move/defUnl=>D.
case/(cancel D): L1=>E2 _ E1.
rewrite -{j2}E1 -{x2}E2 in D2 H2 H *.
suff: p1 :-> x1 :+ j1 :+ h.1 =~ p1 :-> x1 :+ j1 :+ h.2 by case/H=>->.
by apply: lowUn=>//; move/defUnr: D1=>D1; apply: lowUn=>//; apply: defUnr D2.
Qed.

Program 
Definition remove : 
  STsec [::: list] (option T)
    (fun p i => exists h, exists j, exists vs, 
                  i = j :+ h /\ j \In shape p vs,
     fun pp ii yy mm => 
       forall hh jj vvs, 
         ii = jj :++ hh -> jj \In sshape pp vvs -> 
       exists jj',
         mm = jj' :++ hh /\ jj' \In sshape pp (behead vvs.1, behead vvs.2) /\ 
         yy = (if vvs.1 is v1::_ return option T then Some v1 else None, 
               if vvs.2 is v2::_ return option T then Some v2 else None)) := 
  Do (read ptr @ (fun p => [p]);; 
      Ifbool (fun head p => head == null) then 
        ret @ (fun head p => [None])
      else
        read _ @ (fun head p => [head]);;
        write @ (fun v head p => [p, next v]);;
        dealloc @ (fun _ v head p => [head]);;
        ret @ (fun _ _ v head p => [Some (elem v)])
      with [::: ptr; ptr], option T, 
        (fun head p i => exists h, exists j, exists vs, 
                           i = p :-> head :+ j :+ h /\ j \In lseq head vs,
         fun head p i y m => 
           forall h j vs, 
             i = (p.1 :-> head.1, p.2 :-> head.2) :++ j :++ h ->
             j.1 \In lseq head.1 vs.1 -> j.2 \In lseq head.2 vs.2 -> 
           exists s, 
             m = s :++ h /\
             s.1 \In shape p.1 (behead vs.1) /\ 
             s.2 \In shape p.2 (behead vs.2) /\ 
             y = (if vs.1 is v1::_ return option T then Some v1 else None, 
                  if vs.2 is v2::_ return option T then Some v2 else None))).
Next Obligation.
rewrite !gh; split=>[[head][p][]|[head1][p1][][head2][p2][]] /=.
- move=>i [h][j][vs][->] H.
  case: ifP=>E; first by sstep. 
  case: (lseq_pos (negbT E) H)=>x [z][k][_ -> H1].
  by sstep.
move=>i1 i2 [[[[]]]] [h1 h2] j vs /= [[[-> ->]]] H1 H2 _ _. 
case: vs.1 H1=>[|v1 vs1] /=; case: vs.2 H2=>[|v2 vs2] /=.
- case=>-> -> [-> ->]; rewrite eq_refl !unh0.
  by v2step=>_ _; eexists (_, _); hhauto.
- case=>z [h][->] H1 [-> ->] /=; apply: vrf2D=>_; rewrite -!unA unCA => D2. 
  rewrite (negbTE (defPt_null D2)) !un0h; apply/vrfS1; do !vstep=>_.
  by exists (p1 :-> null, p2 :-> z :+ h); rewrite un0h !unA; hhauto.
- case=>-> -> [z][h][->] H1; apply: vrf2D; rewrite -!unA unCA=>D1 _.
  rewrite (negbTE (defPt_null D1)) !un0h; apply/vrfS1; do !vstep=>_.
  by exists (p1 :-> z :+ h, p2 :-> null); rewrite un0h !unA; hhauto.
case=>z2 [j2][->] H2 [z1][j1][->] H1; apply: vrf2D.
rewrite -!unA -(pull head1) -(pull head2) => D1 D2.
rewrite (negbTE (defPt_null D1)) (negbTE (defPt_null D2)). 
by v2step; exists (p1 :-> z1 :+ j1, p2 :-> z2 :+ j2); rewrite !un0h !unA; hhauto.
Qed.
Next Obligation.
rewrite !gh;split=>[[p][]|[p1][][p2][]] /=.
- move=>i [h][j][vs][->][head][k][->] H1.
  by sstep; ssimpl; apply: sval_do=>/=; eauto.
move=>i1 i2 [[[[]]]] h j vs /= [[[-> ->]]][].
case=>head1 [k1][->] H1 [head2][k2][->] H2 _ _ /=.
v2step; v2simpl; apply: val_do=>/=[|y1 y2 m1 m2].
- by eauto 10.
case/(_ (_, _) (_, _) vs (erefl _) H1 H2)=>t [[-> ->]]{H1 H2} [H1][H2].
by case=> -> -> _ _; exists (t.1, t.2).
Qed.

End List. End List.

(**********************************************************)
(* Example 8 in the paper: ratification with linked lists *)
(**********************************************************)

(* we first repeat the Alice structure and signature *)
(* with some changes to the epost predicate, as described in the paper *)

Module Type AliceSig3.
Parameter alice : Type.

Parameter sshape : d alice -> d nat -> d nat -> Pred (d heap).
Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Parameter srefl : 
  forall aa ss pp ii, ii \In sshape aa ss pp -> 
    ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2. 

Parameter rreadable : d alice -> Pred (d heap). 
Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Parameter rrefl : 
  forall aa ii, ii \In rreadable aa -> 
                ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2. 

Parameter read_salary : 
  STsec [:: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> 
         jj \In rreadable aa -> mm = ii /\ yy = ss).

Section Ratify.
Variables bob G : Type.
Variables bbshape : d bob -> d G -> Pred (d heap).
Variables bcmp : G -> G.

Definition bshape b k : Pred heap := 
  fun t => (t, t) \In bbshape (b, b) (k, k). 

Definition breflP := 
  forall bb kk tt, tt \In bbshape bb kk -> 
    tt.1 \In bshape bb.1 kk.1 /\ tt.2 \In bshape bb.2 kk.2.

Definition epre a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (jj.1 :+ hh.1 =~ jj.2 :+ hh.2 -> tt.1 = tt.2 -> tt'.1 = tt'.2). 

Parameter ratify : 
  breflP -> 
  STsec [::: alice; bob] nat 
    (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
     fun aa bb ii yy mm => 
       forall jj, rreadable aa jj -> epost aa bb jj yy ii mm) ->
  STsec [::: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm).

End Ratify.

End AliceSig3.

(* Implementation *)

Module Alice3 : AliceSig3.

Definition alice : Type := (ptr * ptr) % type.

Definition salary (a : alice) := a.1.
Definition passwd (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | [/\ ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1, 
                 ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2,
                 ss.1 = ss.2 & pp.1 = pp.2]]. 

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl : forall aa ss pp ii,
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. by move=>[a1 a2][s1 s2][p1 p2][i1 i2][/= -> ->]. Qed.

Definition rreadable (aa : d alice) : Pred (d heap) := 
  [Pred ii | exists ss:d nat, exists pp:d nat, 
               ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 /\
               ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2].

Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Lemma rrefl aa ii : 
        ii \In rreadable aa -> 
        ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2.
Proof.
move: aa ii=>[a1 a2][i1 i2][[s1 s2]][[p1 p2]][/= -> ->].
by split; [exists (s1, s1); exists (p1, p1) | 
           exists (s2, s2); exists (p2, p2)].
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa -> 
         mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [salary a])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=. 
- by move=>i [s][p][j][h][->][[/= -> _ _ _]] _; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->] _.
by move=>_ _; v2step.
Qed.

Section Ratify.
Variables bob G : Type.
Variables bbshape : d bob -> d G -> Pred (d heap).
Variables bcmp : G -> G.

Definition bshape b k : Pred heap := 
  fun t => (t, t) \In bbshape (b, b) (k, k). 

Definition breflP := 
  forall bb kk tt, tt \In bbshape bb kk -> 
    tt.1 \In bshape bb.1 kk.1 /\ tt.2 \In bshape bb.2 kk.2.

Definition epre a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (jj.1 :+ hh.1 =~ jj.2 :+ hh.2 -> tt.1 = tt.2 -> tt'.1 = tt'.2). 

Program
Definition ratify (pf : breflP) 
  (e : STsec [::: alice; bob] nat 
         (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
          fun aa bb ii yy mm => 
            forall jj, rreadable aa jj -> epost aa bb jj yy ii mm)) : 
  STsec [::: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm) :=
   Do (e @ (fun a b => [a, b])).
Next Obligation.
rewrite !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][s][p][k][t][h][->][/= -> _ _ _] H.
  ssimpl; apply: sval_do=>/=.
  eexists _; split; last by exists s, p, k, t, h.
  by exists (s, s), (p, p).
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[-> ->]]] H1; case: (H1)=>/= E1 E2 E3 E4 H _ _.
rewrite {s1}E3 {p1}E4 in E1 E2 H1 *. 
case: (pf _ _ _ H)=>/= H2 H3; rewrite E1 E2.
have H4 : (j1, j2) \In rreadable (a1, a2).
- by rewrite /rreadable E1 E2; eexists (_, _); eexists (_, _).
v2simpl; apply: val_do=>[|y1 y2 m1 m2] /=.
- by split; (eexists _; split; last by [hhauto; eauto];
             by eexists (_, _); eexists (_, _)).
move/(_ (j1, j2) H4 (s2, s2) (p2, p2) (k1, k2) (t1, t2) (h1, h2))=>/= L _ _.
by rewrite -E1 -E2 in L *; apply: L.
Qed.

End Ratify.

End Alice3.

(* now let's say Bob is using a list for his local state *)

Module LinkedListClient.
Definition bob := List.list.
Definition G := seq nat.
Definition bbshape (bb : d bob) (kk : d G) := 
  [Pred ii | ii \In List.sshape bb kk /\ bb.1 = bb.2].
Definition bcmp : G -> G := fun k => [:: 1 & k]. 

Lemma brefl : Alice3.breflP bbshape.
Proof. by move=>[b1 b2][k1 k2][t1 t2][[/=]]. Qed.

Program
Definition linked_client :=
  Alice3.ratify (bcmp := bcmp) brefl
    (Do (Alice3.read_salary @ (fun a b => [a]);;
         hide (List.insert _) @ (fun x a b => [b, 1]);;
         ret @ (fun _ x a b => [x./2]))).
Next Obligation.
rewrite /Alice3.epost !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][H1][s][p][k][t][h][->] H2 [/= [/= H3 _] _]; rewrite -!unA.
  ssimpl; apply: sbnd_do=>[|y m] /=; first by eauto 10.     
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2 H1)=>[[-> _]][-> _].
  ssimpl; apply: sbnd_do=>[|y1 m1] /=; rewrite unCA; first by eauto 10.
  case/(_ (_, _) (_, _) (_, _) (erefl _) (conj H3 H3))=>[[t1' t2']] /=.
  by case=>[[->]] E {H3} [[/= H3 _]] F; sstep.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[R]]][-> ->] S [[/= H1 H2 B]] _ _; apply: vrf2D=>D1 D2.
rewrite -!unA in D1 D2 *.
case/Alice3.srefl: (S)=>/= S1 S2; case/Alice3.rrefl: (R)=>/= R1 R2.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S R)=>[[->{m1}->{m2}]][->{y1}->{y2}].
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; rewrite -(unCA t1) -(unCA t2).
- by split; eauto 10. 
case/(_ (_, _) (_, _) (_, _) (erefl _) (conj H1 H2))=>/= [[t1' t2']].
case=>[[->{m1} ->{m2}]][[/= H1' H2' H3']]; v2step=>D1' D2'.
exists (j1, j2); exists (t1', t2'); rewrite (unCA t1') (unCA t2') !unA. 
by do !split=>//; move=>E1 E2 /=; apply: H3'. 
Qed.
 
End LinkedListClient.

(* some more examples *)

(**********************************************)
(* In-place reversal of a singly-linked list. *)
(**********************************************)

(* z1 is the pointer to the non-reversed part, z2 is the pointer to *)
(* already reversed. *)

Definition shape_rev z1 z2 (vs1 vs2 : seq nat) : Pred heap := 
  fun i => i \In List.lseq z1 vs1 # List.lseq z2 vs2.

(* the (relational) loop invariant is given by the following type *)

Definition revT : Type := 
  STsec [::: ptr; ptr] ptr 
    (fun z1 z2 i => exists j, exists h, exists vs1, exists vs2, 
                      i = j :+ h /\ j \In shape_rev z1 z2 vs1 vs2,
     fun zz1 zz2 ii yy mm => forall jj hh vs1 vs2, 
       ii = jj :++ hh -> 
         jj.1 \In shape_rev zz1.1 zz2.1 vs1.1 vs2.1 -> 
         jj.2 \In shape_rev zz1.2 zz2.2 vs1.2 vs2.2 -> 
     exists jj', 
       mm = jj' :++ hh /\ 
        jj'.1 \In List.lseq yy.1 (rev vs1.1 ++ vs2.1) /\ 
        jj'.2 \In List.lseq yy.2 (rev vs1.2 ++ vs2.2)).  

(* the loop *)

Program 
Definition reverse' : revT := 
  Fix (fun reverse' : revT => 
         Ifbool (fun z1 z2 => z1 == null) then 
           ret @ (fun z1 z2 => [z2]) 
         else 
           read (List.node nat) @ (fun z1 z2 => [z1]);;
           write @ (fun n z1 z2 => [z1, List.Node (List.elem n) z2]);;
           hide reverse' @ (fun _ n z1 z2 => [List.next n, z1]) 
         with [::: ptr; ptr], ptr, 
           (fun z1 z2 i => exists j, exists h, exists vs1, exists vs2, 
                             i = j :+ h /\ j \In shape_rev z1 z2 vs1 vs2,
            fun zz1 zz2 ii yy mm => forall jj hh vs1 vs2, 
              ii = jj :++ hh -> 
                jj.1 \In shape_rev zz1.1 zz2.1 vs1.1 vs2.1 -> 
                jj.2 \In shape_rev zz1.2 zz2.2 vs1.2 vs2.2 -> 
            exists jj', 
              mm = jj' :++ hh /\ 
                jj'.1 \In List.lseq yy.1 (rev vs1.1 ++ vs2.1) /\ 
                jj'.2 \In List.lseq yy.2 (rev vs1.2 ++ vs2.2))).
Next Obligation.
rewrite !gh; split=>[[z][w][]|[z1][w1][][z2][w2][]] /=.
- move=>i [_][h][vs][ws][->][j1][j2][->][H1] H2.
  case: ifP=>E; first by sstep.
  case: (List.lseq_pos (negbT E) H1)=>v [n][j3][_] -> H3.
  rewrite -!unA; sstep; ssimpl; apply: sval_do; rewrite !unA /=.
  eexists _; exists h; exists (behead vs); exists (v::ws); split; first by eauto.
  by rewrite -(unC j3) -unA; hhauto.
move=>i1 i2 [[[[[]]]]][j1 j2][h1 h2][vs1 vs2][ws1 ws2] /=.
case=>[[[-> ->]]][k1][t1][->][L1] R1 [k2][t2][->][L2] R2 _ _.
apply: vrf2D=>Dl Dr.
move: Dl; do 2![move/defUnl]; move: Dr; do 2![move/defUnl]=>Dr Dl.
have Pnull: forall (z : ptr) w k t vs ws, 
  def k -> z == null -> k \In List.lseq z vs -> t \In List.lseq w ws ->
  k :+ t \In List.lseq w (rev vs ++ ws).
- move=>T z w k t vs ws D; move/eqP=>->; case/(List.lseq_null D)=>-> ->. 
  by rewrite un0h.
have Ppos : forall (z w n : ptr) v t k (vs ws : seq nat), 
  k \In List.lseq z vs -> t \In List.lseq w ws ->
  n :-> List.Node v w :+ k :+ t \In shape_rev z n vs (v::ws). 
- by move=>z w n v t k vs ws E1 E2; rewrite -(unC k) -unA; hhauto.
case: ifP=>E1; case: ifP=>E2.
- v2step=>_ _; eexists (_, _); rewrite /plus2 /=; split=>//.
  rewrite (eqP E1) (eqP E2) in L1 L2.
  by split; apply: Pnull.
- apply/vrfS1; do !vstep=>_; rewrite (eqP E1) in L1.
  case: (List.lseq_pos (negbT E2) L2)=>v2 [n2][r2][-> -> {L2} /= L2].
  rewrite -!unA. 
  vstep; vsimpl; apply: val_doV=>[|y m] /=; rewrite !unA.
  - eexists _; eexists _; exists (behead vs2); exists (v2::ws2).
    by split=>//; apply: Ppos.
  have H : z2 :-> List.Node v2 w2 :+ r2 :+ t2 \In 
             shape_rev n2 z2 (behead vs2) (v2::ws2).
  - by apply: Ppos.
  move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) H H).
  case=>[[j1' j2']][[->]] E /= [E3 E4] D.
  rewrite /plus2; eexists (_, _)=>/=; do !split=>//; first by apply: Pnull.
  by rewrite rev_cons cat_rcons.
- apply/vrfS2=>/=; vstep=>_; rewrite (eqP E2) in L2.
  case: (List.lseq_pos (negbT E1) L1)=>v1 [n1][r1][-> -> {L1} /= L1].
  rewrite -!unA.
  do !vstep; vsimpl; apply: val_doV=>[|y m] /=; rewrite !unA.
  - eexists _, _, (behead vs1), (v1::ws1).
    by split=>//; apply: Ppos.
  have H : z1 :-> List.Node v1 w1 :+ r1 :+ t1 \In 
           shape_rev n1 z1 (behead vs1) (v1::ws1).
  - by apply: Ppos.
  move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) H H).
  case=>[[j1' j2']][[->]] E /= [E3 E4] D.
  rewrite /plus2; eexists (_, _)=>/=; do !split=>//; last by apply: Pnull.
  by rewrite rev_cons cat_rcons.
case: (List.lseq_pos (negbT E1) L1)=>n1 [v1][r1][-> -> {L1} /= L1].
case: (List.lseq_pos (negbT E2) L2)=>n2 [v2][r2][-> -> {L2} /= L2].
rewrite -!unA; v2step; v2simpl; apply: val_do=>[|y1 y2 m1 m2] /=; rewrite !unA.
- by split; eexists _; eexists _; 
     [exists (behead vs1); exists (n1::ws1) | 
      exists (behead vs2); exists (n2::ws2)]; split=>//; apply Ppos.
have H1: z1 :-> List.Node n1 w1 :+ r1 :+ t1 \In 
         shape_rev v1 z1 (behead vs1) (n1::ws1).
- by apply: Ppos.
have H2: z2 :-> List.Node n2 w2 :+ r2 :+ t2 \In 
         shape_rev v2 z2 (behead vs2) (n2::ws2).
- by apply: Ppos.
move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) H1 H2).
case=>[[j1' j2']][[-> ->]] /= [E3 E4] D _.
by rewrite /plus2; eexists (_, _)=>/=; 
   do !split=>//; rewrite rev_cons cat_rcons.
Qed.
Next Obligation.
apply: if_bool_cont; first by apply: const_stcont.
do 2![apply: bind_stcont; first by apply: const_stcont].
by apply: inst_stcont; apply: hide_stcont; apply: id_cont.
Qed.

(* the whole program *)
(* first read off the head pointer, loop to reverse the list, then write back *)
(* the new head pointer *)

Program 
Definition reverse : 
  STsec [::: List.list] unit
    (fun p i => exists j, exists h, exists vs : seq nat, 
                  i = j :+ h /\ j \In List.shape p vs, 
     fun pp ii yy mm => forall jj hh (vvs : d (seq nat)), 
       ii = jj :++ hh -> jj \In List.sshape pp vvs -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In List.sshape pp (rev vvs.1, rev vvs.2)) := 
  Do (read _ @ (fun p => [p]);;
      hide reverse' @ (fun z1 p => [z1, null]);;
      write @ (fun z2 z1 p => [p, z2]);;
      ret @ (fun _ z2 z1 p => [tt])).
Next Obligation.
rewrite !gh; split=>[[p][]|[p1][][p2][]] /=.
- move=>i [j][h][vs][->] /= H. 
  (* here, we're breaking the abstraction of List.shape *)
  (* but that's ok; just means we need an additional method *)
  (* in the List signature *)
  case: H=>v [k][->] H; rewrite -!unA; sstep; ssimpl; apply: sbnd_do=>[|y m] /=.
  - rewrite -(unCA k); eexists _; eexists _; exists vs; exists [::].
    by split=>//; exists k; exists empty; rewrite unh0.
  have S : k \In shape_rev v null vs [::].
  - by exists k; exists empty; rewrite unh0.
  rewrite -(unCA k).
  case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S S)=>
    [[j1' j2']][[-> E]] /= [H1 H2].
  by sstep.
move=>i1 i2 [[[[]]]][j1 j2][h1 h2][vs1 vs2] /=.
case=>[[-> ->]][/= [v1][k1][->] H1 [v2][k2][->] H2] _ _.
rewrite -!unA; v2step; v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; 
rewrite -(unCA k1) -(unCA k2).
- split; eexists _; eexists _;
  [exists vs1; exists [::] | exists vs2; exists [::]]; split=>//.
  - by exists k1; exists empty; rewrite unh0.
  by exists k2; exists empty; rewrite unh0.
have [S1 S2] : k1 \In shape_rev v1 null vs1 [::] /\ 
               k2 \In shape_rev v2 null vs2 [::]. 
- by split; [exists k1 | exists k2]; exists empty; rewrite unh0.
move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S1 S2)=>/=.
case=>[[j1' j2']][[-> ->]] /= [R1 R2]; v2step=>_ _; rewrite !unA.
eexists (_, _)=>/=; rewrite /plus2 /=; do !split=>//=;
[exists y1; exists j1' | exists y2; exists j2'];
by rewrite unC; rewrite !cats0 in R1 R2.
Qed.