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

(************************************************************)
(* 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 yy ii 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 _; sauto.
case=>[[]] i1 i2 _ _ _ _; vauto=>y1 y2 D1 D2 L _.
exists (y1 :-> null, y2 :-> null)=>[[_]][_] /=.  
by case/L=>->.
Qed.

(* inserting low *)
Program 
Definition insert : 
  STsec [:: ptr:Set; T] unit 
    (fun p v i => exists h, exists j, exists vs,
                    i = j :+ h /\ j \In shape p vs, 
     fun pp vv yy ii 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][]] /=.
- move=>i [h][_][vs][->][x][j][->] H; rewrite -unA.
  by sauto=>l; sauto.
move=>i1 i2 [[[[]]]] /= h [k1 k2] vs [[[-> ->]]][/=].
case=>x1 [j1][/= ->{k1}] H1 [x2][j2][->{k2}] H2 _ _ D1 D2.
rewrite -!unA in D1 D2 *; vauto=>l1 l2; vauto=>_ _ H. 
exists (p1 :-> l1 :+ (l1 :-> Node v1 x1 :+ j1), 
        p2 :-> l2 :+ (l2 :-> Node v2 x2 :+ j2))=>/=.
split; first by rewrite /= !unA.
split; first by split=>/=; 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 yy ii 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 y i 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 sauto.
  case: (lseq_pos (negbT E) H)=>x [z][k][_ -> H1].
  by rewrite -!unA; sauto.
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 vauto=>_ _; eexists (_, _); hhauto.
- case=>z [h][->] H1 [-> ->] _; rewrite -!unA unCA => D2. 
  rewrite eq_refl (negbTE (defPt_null D2)) !un0h. 
  by lauto; exists (p1 :-> null, p2 :-> z :+ h); rewrite !unA; hhauto.
- case=>-> -> [z][h][->] H1; rewrite -!unA unCA=>D1 _.
  rewrite (negbTE (defPt_null D1)) eq_refl !un0h.
  by lauto; exists (p1 :-> z :+ h, p2 :-> null); rewrite !unA; hhauto.
case=>z2 [j2][->] H2 [z1][j1][->] H1.
rewrite -!unA -(pull head1) -(pull head2)=>D1 D2.
rewrite (negbTE (defPt_null D1)) (negbTE (defPt_null D2)).
by vauto=>_ _; exists (p1 :-> z1 :+ j1, p2 :-> z2 :+ j2); rewrite !unA; hhauto.
Qed.
Next Obligation.
rewrite !gh;split=>[[p][]|[p1][][p2][]] /=.
- move=>i [h][j][vs][->][head][k][->] H1; rewrite -!unA.
  by sauto; apply: sval_do=>/=; rewrite unA; eauto.
move=>i1 i2 [[[[]]]] h j vs /= [[[-> ->]]][].
case=>head1 [k1][->] H1 [head2][k2][->] H2 _ _ _ _.
rewrite -!unA; vauto; apply: val_do=>/=[|y1 y2 m1 m2]; rewrite !unA.
- 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 yy ii 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 yy ii 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 yy ii 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 yy ii 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][->][[/= -> _ _ _]] _; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->] _.
by move=>_ _ _ _; rewrite -!unA; vauto.
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 yy ii 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 yy ii 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.
  sauto; apply: sval_do=>/=.
  eexists _; split; last by exists s; exists p; exists k; exists t; exists h.
  by exists (s, s); exists (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 (_, _).
vauto; 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.
  sauto; apply: sbnd_do=>[|y m] /=; first by eauto 10.     
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2 H1)=>[[-> _]][-> _].
  sauto; apply: sbnd_do=>[|y1 m1] /=; rewrite unCA; first by eauto 10.
  case/(_ (_, _) (_, _) (_, _) (erefl _) (conj H3 H3))=>[[t1' t2']] /=.
  by case=>[[->]] E {H3} [[/= H3 _]] F; sauto.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[R]]][-> ->] S [[/= H1 H2 B]] _ _ D1 D2; rewrite -!unA in D1 D2 *.
case/Alice3.srefl: (S)=>/= S1 S2; case/Alice3.rrefl: (R)=>/= R1 R2.
vauto; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S R)=>[[->{m1}->{m2}]][->{y1}->{y2}].
vauto; 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']]; vauto=>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:Type; ptr:Type] 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 yy ii 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 yy ii 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 sauto.
  case: (List.lseq_pos (negbT E) H1)=>v [n][j3][_] -> H3.
  rewrite -!unA; sauto; 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 _ _ 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.
- vauto=>_ _; eexists (_, _); rewrite /plus2 /=; split=>//.
  rewrite (eqP E1) (eqP E2) in L1 L2.
  by split; apply: Pnull.
- lauto; rewrite (eqP E1) in L1.
  case: (List.lseq_pos (negbT E2) L2)=>v2 [n2][r2][-> -> {L2} /= L2].
  rewrite -!unA.
  lauto; 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/vrfC=>/=; lauto; rewrite (eqP E2) in L2.
  case: (List.lseq_pos (negbT E1) L1)=>v1 [n1][r1][-> -> {L1} /= L1].
  rewrite -!unA.
  lauto; apply: val_doV=>[|y m] /=; rewrite !unA.
  - eexists _; eexists _; exists (behead vs1); exists (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; vauto; 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_cont2; first by apply: const_stcont.
do 2![apply: bind_cont; first by apply: const_stcont].
by apply: inst_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 yy ii 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; sauto; 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 sauto.
move=>i1 i2 [[[[]]]][j1 j2][h1 h2][vs1 vs2] /=.
case=>[[-> ->]][/= [v1][k1][->] H1 [v2][k2][->] H2] _ _ _ _.
rewrite -!unA; vauto; 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]; vauto=>_ _; rewrite !unA.
eexists (_, _)=>/=; rewrite /plus2 /=; do !split=>//;
[exists y1; exists j1' | exists y2; exists j2'];
by rewrite unC; rewrite !cats0 in R1 R2.
Qed.