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.

(*
In this file, the interface to the list library is defined so that we
can state that the linkage of the list is low, no matter the security
level of the list contents. In particular, we can have list elements
of heterogeneous security level.

(Notice, however, that if linkage is low, this means that the size of
the list must be low too, as the size of a list can be inferred from
the linkage alone).

In the previous file, llist.v, we could also have heterogeneous
levels, but the specs were not quite so precise as here. For example,
we could only state that the linkage is low if and only if the
elements are low too. It wasn't possible to state the status of the
linkage separately from the status of the elements.

Thus, the specs in the current file are a bit better, although we pay
for that by having the theory be a bit more involved, as one could
expect.
*)

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.

Lemma lseq_func vs1 vs2 x h : 
        def h -> h \In lseq x vs1 -> h \In lseq x vs2 -> vs1 = vs2.
Proof.
elim: vs1 vs2 x h=>[|v1 vs1 IH] vs2 x h /= D; 
  first by case=> -> ->; case/lseq_null.
case=>z [j][H]; move: H D => -> D H.
case/(lseq_pos (defPt_null D))=>v2 [z2][j2][->] /=.
by case/(cancel D)=>[[<- <-]] D' <-; move/(IH _ _ _ D' H)=><-.
Qed.
 
(* p is pointer to the head; it's the default place to keep the *)
(* changes to the list head after insertion or removal *)

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.

Lemma shape_func vs1 vs2 p h : 
        def h -> h \In shape p vs1 -> h \In shape p vs2 -> vs1 = vs2.
Proof.
move=>D; case=>x1 [j1][E]; move: E D=>-> D H1 [x2][j2][].
by case/(cancel D)=><- D' <-; move/(lseq_func D' H1).
Qed.

(* now predicates and lemmas to capture the low privacy of linkage *)

Fixpoint low_link' (x : list) (vs1 vs2 : seq T) : Pred (d heap) := 
  if vs1 is v1::vt1 then 
    fun ii => exists z, exists jj, exists v2, 
                [/\ vs2 = v2::(behead vs2), 
                    ii = (x :-> Node v1 z :+ jj.1, 
                          x :-> Node v2 z :+ jj.2) &
                    jj \In low_link' z vt1 (behead vs2)]
  else fun ii => [/\ x = null, vs2 = [::] & ii = (empty, empty)].

Lemma link_invert (x : list) (vs1 vs2 vs3 vs4 : seq T) ii : 
        def ii.1 -> def ii.2 ->        
        ii.1 \In lseq x vs1 -> ii.2 \In lseq x vs2 -> 
        ii \In low_link' x vs3 vs4 -> vs1 = vs3 /\ vs2 = vs4.
Proof.
elim: vs3 x vs1 vs2 vs4 ii=>[|v vs3 IH] x vs1 vs2 vs4 ii /=.
- move=>D1 D2 H1 H2 [E] -> _; rewrite E /= in H1 H2.
  by case/(lseq_null D1): H1=>->; case/(lseq_null D2): H2=>->.
move=>D1 D2 H1 H2 /= [z][j][v4][->] /= E1 E2.
rewrite {}E1 /= in D1 D2 H1 H2 *.
case: vs1 H1=>[|v1 vs1] /= H.
- by case: H def0=>-> <-; move/(@defPt_null _ _ _ _).
case: H=>z1 [j1][H]; case/(cancel D1): H=>[[-> <-]] {D1} D1 <- S1.
case: vs2 H2=>[|v2 vs2] /= H.
- by case: H def0=>-> <-; move/(@defPt_null _ _ _ _).
case: H=>z2 [j2][H].
case/(cancel D2): H=>[[-> <-]] {D2} D2 <- S2.
by case: (IH _ _ _ _ _ D1 D2 S1 S2 E2)=>-> ->.
Qed.

Lemma low_link'_null vs1 vs2 ii : 
        def ii.1 -> def ii.2 -> ii \In low_link' null vs1 vs2 -> 
        [/\ vs1 = [::], vs2 = [::] & ii = (empty, empty)].
Proof.
elim: vs1 vs2 ii=>[|v1 vs1 /= IH] vs2 ii D1 D2; first by case=>_ /= -> ->.
by case=>z [jj][v2][->] H; move: H D1 ->.
Qed.

Lemma low_link'_pos vs1 vs2 (x : ptr) ii : 
        x != null -> ii \In low_link' x vs1 vs2 -> 
        exists vv, exists z, exists jj, 
        [/\ vs1 = vv.1::behead vs1, 
            vs2 = vv.2::behead vs2, 
            ii = (x :-> Node vv.1 z :+ jj.1, x :-> Node vv.2 z :+ jj.2) &
            jj \In low_link' z (behead vs1) (behead vs2)].
Proof.
case: vs1=>[|v1 vt1] E; first by move=>H; case: H E=>->.
by case=>z [jj][v2][/= -> ->] H; exists (v1, v2); exists z; exists jj.
Qed.

Lemma low_link'_refl vs x i : 
        i \In lseq x vs -> (i, i) \In low_link' x vs vs.
Proof.
elim: vs x i=>[|v1 vs1 /= IH] x i /=; first by case=>->->.
by case=>z [j][->]; move/IH=>H; eexists _; eexists (_, _); eexists _.
Qed.

(* advice for the future: do not quantify existentially over pairs *)
(* if you don't, eauto can figure many more things automatically *)

Definition low_link (pp : d list) : Pred (d heap) :=  
  fun ii => pp.1 = pp.2 /\ 
            exists z, exists jj, exists vs1, exists vs2,
            ii = (pp.1 :-> z :+ jj.1, pp.2 :-> z :+ jj.2) /\
            jj \In low_link' z vs1 vs2.

Lemma low_linkP pp ii : 
        ii \In low_link pp -> 
        [/\ pp.1 = pp.2, def ii.1 = def ii.2 & dom ii.1 =i dom ii.2].
Proof.
case: pp ii=>p' p jj[/= ->{p'}][x][ii][vs1][vs2][->{jj}] /=.
elim: vs1 vs2 x ii=>[|v vs1 IH] vs2 x ii /=; first by case=>_ _ ->. 
case=>z [j][v2][-> ->] /=; case/IH=>_ /=.
rewrite !(unCA (p :-> x)) !defPtUn => H1 H2.
have {H2} H2: dom (p :-> x :+ j.1) =i dom (p :-> x :+ j.2). 
- by move=>y; move: (H2 y); rewrite !domPtUn !inE !defPtUn.
rewrite H1 H2; split=>// y. 
by rewrite !domPtUn !inE !defPtUn H1 !H2.
Qed.

Lemma low_linkQ pp ii : ii \In low_link pp -> ii.1 =~ ii.2.
Proof. by case/low_linkP=>H1 _ H3; apply/loweqP=>y; rewrite !ldomP H3. Qed.

Lemma low_linkR vs pp ii : 
        ii \In sshape pp (vs, vs) -> ii \In low_link pp -> ii.1 = ii.2.
Proof.
case: pp=>[q p][/= H1 H2] H.
case: {H} (low_linkP H) (H) H1 H2=>/= ->{q} E1 _ H.
case D1: (def ii.1) E1; move/esym; last first.
- by move/negbT; move/negbT: D1; rewrite !undefE=>->->.
case: H D1=>/= _ [z][j][v1][v2][->{ii}] /= H D1 D2.
case=>z1 [i1][]; case/(cancel D1)=>{D1} <-{z1} D1 <-{i1} H1.
case=>z2 [i2][]; case/(cancel D2)=>{D2} <-{z2} D2 <-{i2} H2.
suff: j.1 = j.2 by move=>->.
elim: vs j z v1 v2 H1 H2 H D1 D2=>[|v vs IH] j z v1 v2 /=; 
  first by case=>_ -> [_] ->.
case: j=>j1 j2 [z1][i1][/= ->{j1}] H1 [z2][i2][/= ->{j2}] H2 H D1 D2.
have N: z != null by apply: defPt_null D1.
case: {N H} (low_link'_pos N H) H1 H2.
case=>[w1 w2][x][[k1 k2]][-> ->][] /=.
case/(cancel D1)=>{D1} [[_ {w1}]] ->{z1} D1 <-{k1}.
case/(cancel D2)=>{D2} [[_ {w2}]] ->{z2} D2 <-{k2} /= S S1 S2.
by move: (IH (i1, i2) _ _ _ S1 S2 S D1 D2)=>/= ->.
Qed.

Lemma low_link_refl i p vs : 
        i \In shape p vs -> (i, i) \In low_link (p, p).
Proof.
move=>[x][j][->]; move/low_link'_refl=>H.
by split=>//; exists x; exists (j, j); eauto.
Qed.

Program
Definition new : 
  STsec [::] ptr
    (fun i => True, 
     fun yy ii mm => 
       exists jj, mm = jj :++ ii /\ sshape yy ([::], [::]) jj /\
                  (ii.1 =~ ii.2 -> jj \In low_link yy)) := 
  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); do 2!split; first by hhauto.
case/L=>-> E; split=>//; exists null; exists (empty, empty).
by exists [::]; exists [::]; rewrite unh0.
Qed.

(* inserting *)
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) /\
         (jj \In low_link pp -> hh.1 =~ hh.2 -> jj' \In low_link pp)) := 
  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][k][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.
rewrite !unA in D1 D2.
move=>E1.
move/low_linkQ: (E1)=>/= E2; move/(lowUn D1 D2 E2).
rewrite -!unA; case/H=>-> L2.
case: E1=>/= E [z][jj][vs1][vs2][S1] S2; split=>//. 
exists l2; exists (l2 :-> Node v1 x1 :+ j1, l2 :-> Node v2 x2 :+ j2).
exists (v1 :: vs1); exists (v2 :: vs2); split=>//.
exists z; exists jj; exists v2; split=>//; case: S1.
by case/(cancel (defUnl D1))=><- _ ->; case/(cancel (defUnl 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) /\
         (jj \In low_link pp -> jj' \In low_link pp)) := 
  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) /\
             (p.1 = p.2 -> head.1 = head.2 -> 
              (j.1, j.2) \In low_link' head.1 vs.1 vs.2 -> 
               s \In low_link p))).
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=>_ _.
  vauto=>_ _; exists (p1 :-> null, p2 :-> null).
  do 3![split; first by hhauto]; split=>//.
  case=>/= -> _ _; split=>//. 
  exists null; exists (empty, empty); exists [::]; exists [::]. 
  by rewrite !unh0. 
- case=>z [h][->] H1 [-> ->] _; rewrite -!unA unCA => D2. 
  rewrite eq_refl (negbTE (defPt_null D2)) !un0h. 
  lauto; exists (p1 :-> null, p2 :-> z :+ h); rewrite !unA.
  do 3![split; first by hhauto]; split=>//.
  by move=>_ E; rewrite -E in D2; move: (defPt_null D2).
- case=>-> -> [z][h][->] H1; rewrite -!unA unCA=>D1 _.
  rewrite (negbTE (defPt_null D1)) eq_refl !un0h.
  lauto; exists (p1 :-> z :+ h, p2 :-> null); rewrite !unA.
  do 3![split; first by hhauto]; split=>//.
  by move=>_ E; rewrite E in D1; move: (defPt_null D1).   
case=>z2 [j2][->] H2 [z1][j1][->] H1.
rewrite -!unA -(pull head1) -(pull head2)=>D1 D2.
rewrite (negbTE (defPt_null D1)) (negbTE (defPt_null D2)).
vauto=>_ _; exists (p1 :-> z1 :+ j1, p2 :-> z2 :+ j2); rewrite !unA. 
do 3![split; first by hhauto]; split=>//.
move=>E1 E2; rewrite -{p2}E1 -{head2}E2 in D1 D2 *.
case=>z [jj][v3][S1][S2] S3; split=>//.
exists z; exists jj; exists vs1; exists vs2.
rewrite -(unCA j1) unA in D1; rewrite -(unCA j2) unA in D2.
move/defUnl: D1=>D1; move/defUnl: D2=>D2.
case/(cancel D1): S2=>[[-> _ ->]].
by case/(cancel D2): S3=>[[_ -> _ ->]]. 
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 [j1 j2] vs /= [[[-> ->]]][] /=.
case=>head1 [k1][->] H1 [head2][k2][->] H2 _ _ Y1 Y2 /=. 
rewrite -!unA; vauto; apply: val_do=>/=[|y1 y2 m1 m2]; rewrite !unA.
- by eauto 10.
case/(_ (_, _) (_, _) vs (erefl _) H1 H2)=>[[t1 t2]][[-> ->]] /= [W1][W2].
case=>-> /= L D1 D2; exists (t1, t2); do 3!split=>//.
case=>/= L1 [z] [[kk1 kk2]][vs1][vs2][[R1 R2]].
move/defUnl: Y1=>Y1; move/defUnl: Y2=>Y2.
case/(cancel Y1): R1=>S1 _ <-; case/(cancel Y2): R2=>S2 _ <-.
rewrite {head2}S2 -{z}S1 in H2 L Y2 *; move=>S; apply: L=>//.
by case: (link_invert (ii:=(k1, k2)) (defUnr Y1) (defUnr Y2) H1 H2 S)=>->->.
Qed.

End List. End List.

(* a few silly examples *)

Program 
Definition heterogenous1 : 
  STsec [:: bool] List.list
    (fun b i => True,
     fun bb yy ii mm => 
           exists jj, mm = jj :++ ii /\ 
             jj \In List.sshape yy ([:: if bb.1 then 1 else 2; 0], 
                                    [:: if bb.2 then 1 else 2; 0]) /\
             (ii.1 =~ ii.2 -> jj \In List.low_link nat yy)) :=
  Do (List.new nat @@ (fun b => tt);;
      List.insert _ @@ (fun p b => [p, 0]);;
      Ifbool (fun _ p b => b) then List.insert _ @@ (fun _ p b => [p, 1])
      else List.insert _ @@ (fun _ p b => [p, 2])
      with [:: unit:Type; ptr; bool], unit, 
        (fun _ p b i => exists j, exists h, i = j :+ h /\ j \In List.shape p [:: 0],
         fun _ pp bb yy ii mm =>  
           forall jj hh, ii = jj :++ hh -> jj \In List.sshape pp ([:: 0], [:: 0]) ->
           exists jj', mm = jj' :++ hh /\ 
             jj' \In List.sshape pp ([:: if bb.1 then 1 else 2; 0], 
                                     [:: if bb.2 then 1 else 2; 0]) /\
             (jj \In List.low_link nat pp -> hh.1 =~ hh.2 -> jj' \In List.low_link nat pp));;
      ret @@ (fun _ _ y b => [y])).
Next Obligation.
rewrite !gh; split=>[[][][p][b][]|[][][p1][b1][][][][p2][b2][]] /=.
- by move=>_ [i][h][->] H; case: b; sauto; apply: sval_do=>/=; eauto.
move=>i1 i2 [[[]]][j1 j2][h1 h2][[/= -> ->]] H _ _ _ _; case: (H)=>/= H1 H2.
case: b1; case: b2; vauto;
(apply: val_do=>[|[][] m1 m2] /=; first by eauto 10);
case/(_ (h1, h2) (j1, j2) _ (erefl _) H)=>{H H1 H2} [[k1 k2]][[-> ->]] /= [H];
by eexists (_, _).
Qed.
Next Obligation.
split=>[[b][]|[b1][][b2][]].
- move=>i _; sauto. 
  apply: sbnd_do=>[//|p m /=]; case=>jj [[-> _]][[/= H1 H2]] _; sauto.
  apply: sbnd_do=>[|[] m1] /=; first by [eauto].
  case/(_ (i, i) (jj.1, jj.1) (_, _) (erefl _) (conj H1 H1)).
  move=>m2 [[-> _]][[/= H3 H4]] _; sauto.
  apply: sbnd_do=>[|[] m3] /=; first by eauto.
  case/(_ (m2.1, m2.1) (i, i) (erefl _) (conj H3 H3)).
  by move=>m4 [[-> _]][[/= H5 H6]] _; sauto.
move=>i1 i2 _ _ _ _; vauto.
apply: bnd_do=>[|y1 y2 m1 m2] //= [[j1 j2]][[-> ->]][[/= H1 H2]] L1; vauto.
apply: bnd_do=>[|y3 y4 m3 m4] /=; first by eauto 10.
case/(_ (i1, i2) (j1, j2) (_, _) (erefl _) (conj H1 H2)).
move=>[n5 n6][[-> ->]][[/= H3 H4]] L2; vauto.
apply: bnd_do=>[|y5 y6 m5 m6] /=; first by eauto 10.
case/(_ (n5, n6) (i1, i2) (erefl _) (conj H3 H4)).
move=>[n7 n8][[-> ->]][[/= H5 H6]] L3; vauto.
exists (n7, n8); do 2!split=>//.
by move=>I; apply: L3=>//; apply: L2=>//; apply: L1.
Qed.

Program 
Definition heterogeneous2 : 
  STsec [:: bool] List.list
    (fun h i => True,
     fun hh yy ii mm => 
           exists jj, mm = jj :++ ii /\ 
             jj \In List.sshape yy ([:: 0], [:: 0]) /\ 
             (ii.1 =~ ii.2 -> jj \In List.low_link nat yy)) :=
  Do (List.new nat @@ (fun b => tt);;
      List.insert _ @@ (fun p b => [p, 0]);;
      Ifbool (fun _ p b => b) then List.insert _ @@ (fun _ p b => [p, 1])
      else List.insert _ @@ (fun _ p b => [p, 2])
      with [:: unit:Type; ptr; bool], unit, 
        (fun _ p b i => exists j, exists h, i = j :+ h /\ j \In List.shape p [:: 0],
         fun _ pp bb yy ii mm =>  
           forall jj hh, ii = jj :++ hh -> jj \In List.sshape pp ([:: 0], [:: 0]) ->
           exists jj', mm = jj' :++ hh /\ 
             jj' \In List.sshape pp ([:: if bb.1 then 1 else 2; 0], 
                                     [:: if bb.2 then 1 else 2; 0]) /\ 
             (jj \In List.low_link nat pp -> hh.1 =~ hh.2 -> jj' \In List.low_link nat pp));;
      List.remove nat @@ (fun _ _ p b => [p]);;
      ret @@ (fun _ _ _ y b => [y])).
Next Obligation.
rewrite !gh; split=>[[][][p][b][]|[][][p1][b1][][][][p2][b2][]] /=.
- by move=>_ [i][h][->] H; case: b; sauto; apply: sval_do=>/=; eauto.
move=>i1 i2 [[[]]][j1 j2][h1 h2][[/= -> ->]] H _ _ _ _; case: (H)=>H1 H2.
case: b1; case: b2; vauto;
(apply: val_do=>[|[][] m1 m2] /=; first by eauto 10);
case/(_ (h1, h2) (j1, j2) _ (erefl _) H)=>{H H1 H2} [[k1 k2]][[-> ->]] /= [H];
by eexists (_, _).
Qed.
Next Obligation.
split=>[[b][]|[b1][][b2][]].
- move=>i _; sauto. 
  apply: sbnd_do=>[//|p m /=]; case=>jj [[-> _]][[/= H1 H2]] _; sauto.
  apply: sbnd_do=>[|[] m1] /=; first by [eauto].
  case/(_ (i, i) (jj.1, jj.1) (_, _) (erefl _) (conj H1 H1)).
  move=>m2 [[-> _]][[/= H3 H4]] _; sauto.
  apply: sbnd_do=>[|[] m3] /=; first by eauto.
  case/(_ (m2.1, m2.1) (i, i) (erefl _) (conj H3 H3)).
  move=>m4 [[-> _]][[/= H5 H6]] _; sauto.
  apply: sbnd_do=>[|y m5] /=; first by eauto .
  case/(_ (i, i) (m4.1, m4.1) (_, _) (erefl _) (conj H5 H5)).
  by move=>jj' [[->]] E4 [H7][[->]] _ _; sauto.
move=>i1 i2 _ _ _ _; vauto.
apply: bnd_do=>[|y1 y2 m1 m2] //= [[j1 j2]][[-> ->]][[/= H1 H2]] L1; vauto.
apply: bnd_do=>[|y3 y4 m3 m4] /=; first by eauto 10.
case/(_ (i1, i2) (j1, j2) (_, _) (erefl _) (conj H1 H2)).
move=>[n5 n6][[-> ->]][[/= H3 H4]] L2; vauto.
apply: bnd_do=>[|y5 y6 m5 m6] /=; first by eauto 10.
case/(_ (n5, n6) (i1, i2) (erefl _) (conj H3 H4)).
move=>[n7 n8][[-> ->]][[/= H5 H6]] L3; vauto.
apply: bnd_do=>[|y7 y8 m7 m8] /=; first by eauto 10.
case/(_ (i1, i2) (n7, n8) (_, _) (erefl _) (conj H5 H6)).
move=>jj' [[/= -> ->]][H7][[-> ->]] L4; vauto=>_ _ _. 
exists jj'; do 2!split=>//.
by move=>I; apply: L4; apply: L3=>//; apply: L2=>//; apply: L1.
Qed.

(* On the other hand, the following can't be given a low_link status *)

Program 
Definition heterogeneous3 : 
  STsec [:: bool] List.list
    (fun b i => True,
     fun bb yy ii mm => 
       exists jj, mm = ii :++ jj /\ 
          jj \In List.sshape yy (if bb.1 then [:: 0] else [:: 1; 0],
                                 if bb.2 then [:: 0] else [:: 1; 0])) := 
  Do (List.new nat @@ (fun b => tt);;
      List.insert _ @@ (fun p b => [p, 0]);;
      List.insert _ @@ (fun _ p b => [p, 1]);;
      Ifbool (fun _ _ p b => b) then 
        List.remove nat @@ (fun _ _ p b => [p]);;
        ret @@ (fun _ _ _ p b => [p])
      else ret @@ (fun _ _ p b => [p])
      with [:: unit:Type; unit:Type; List.list; bool], ptr, 
        (fun _ _ p b i => exists j, exists h, i = j :+ h /\ j \In List.shape p [:: 1; 0],
         fun _ _ pp bb yy ii mm => 
           forall jj hh, ii = jj :++ hh -> jj \In List.sshape pp ([:: 1; 0], [:: 1; 0]) -> 
           exists jj', mm = jj' :++ hh /\ 
             jj' \In List.sshape yy (if bb.1 then [:: 0] else [:: 1; 0], 
                                     if bb.2 then [:: 0] else [:: 1; 0]))).
Next Obligation.
rewrite !gh; split=>[[][][][][p][b][]|[][][][][p1][b1][][][][][][p2][b2][]] /=.
- move=>i [j][h][->] H1.
  case: b; sauto; apply: sbnd_do=>[|y1 m1] /=; first by eauto.
  case/(_ (h, h) (j, j) (_, _) (erefl _) (conj H1 H1)).
  by move=>jj' [[-> _]][[/= H2 _]][[-> _]] _; sauto.
move=>i1 i2 [[[]]][j1 j2][h1 h2] /= [[-> ->]][/= H1 H2] _ _ _ _. 
case: b1; case: b2; vauto.
- apply: bnd_do=>[|y1 y2 m1 m2] /=; first by eauto 10.  
  case/(_ (h1, h2) (j1, j2) (_, _) (erefl _) (conj H1 H2)).
  move=>[n1 n2] /= [[-> ->]][[/= H3 H4]][[-> ->]] _.
  by vauto; exists (n1, n2).
- apply/vrfC; lauto.
  apply: bnd_doV=>[|y m] /=; first by eauto 10.
  case/(_ (h1, h1) (j1, j1) (_, _) (erefl _) (conj H1 H1)).
  move=>[n1 n2][[-> _]][[/= H3 _]][[-> _]] _. 
  by lauto; exists (n1, j2).
- lauto; apply: bnd_doV=>[|y m] /=; first by eauto 10.
  case/(_ (h2, h2) (j2, j2) (_, _) (erefl _) (conj H2 H2)).
  move=>[n1 n2][[-> _]][[/= H3 H4]][[-> ->]] _.
  by lauto; exists (j1, n1).
by exists (j1, j2).
Qed.
Next Obligation.
split=>[[b][]|[b1][][b2][]] /=.
- move=>i _; sauto; apply: sbnd_do=>[//|y1 m1] /= [jj][[-> _]][[/= H1 H2]] _.
  sauto; apply: sbnd_do=>[|y2 m2] /=; first by eauto 10.
  case/(_ (i, i) (jj.1, jj.1) (_, _) (erefl _) (conj H1 H1)).
  move=>[n1 n2][[-> _]][[/= H3 H4]] _.
  sauto; apply: sbnd_do=>[|y3 m3] /=; first by eauto 10.
  case/(_ (i, i) (n1, n1) (_, _) (erefl _) (conj H3 H3)).
  move=>[n3 n4][[-> _]][[/= H5 H6]] _.
  by sauto; apply: sval_do=>/=; eauto.
move=>i1 i2 _ _ _ _.
vauto; apply: bnd_do=>[|y1 y2 m1 m2] //= [[j1 j2]][[-> ->]][[/= H1 H2]] L1.
vauto; apply: bnd_do=>[|y3 y4 m3 m4] /=; first by eauto 10.
case/(_ (i1, i2) (j1, j2) (_, _) (erefl _) (conj H1 H2)).
move=>[n3 n4][[-> ->]][[/= H3 H4]] L2.
vauto; apply: bnd_do=>[|y5 y6 m5 m6] /=; first by eauto 10.
case/(_ (i1, i2) (n3, n4) (_, _) (erefl _) (conj H3 H4)).
move=>[n5 n6][[-> ->]][[/= H5 H6]] L3.
vauto; apply: val_do=>[|y7 y8 m7 m8] /=; first by eauto 10.
case/(_ (n5, n6) (i1, i2) (erefl _) (conj H5 H6)).
by move=>[n7 n8][[-> ->]] /= H7; exists (n7, n8); rewrite unC2.
Qed.

(* okay, now the endorsement for linked lists *)

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 Endorse.
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 endorse : 
  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 Endorse.

End AliceSig3.

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 Endorse.
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 endorse (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 Endorse.

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.

(* bbshape here must express only shape, no low_linkage *)
(* because the latter is not preserved unconditionally *)
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][[/= H1 H2]] E. Qed.

Program
Definition linked_client :=
  Alice3.endorse (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'; vauto=>D1' D2'.
exists (j1, j2); exists (t1', t2'); rewrite (unCA t1') (unCA t2') !unA.
do !split=>//; move=>E1 E2 /=.
rewrite -{b2}B -{t2}E2 in H2 H1' H2' D2 *.
move: (List.shape_func (defUnl (defUnr D1)) H1 H2)=>E.
rewrite -{k2}E in  H1' H2.
by apply: (List.low_linkR H1'); apply: H2' E1; apply: List.low_link_refl H2.
Qed. 

End LinkedListClient.

(* in-place reversal of a 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.

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)).  

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.

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.
