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

(* Another module for singly-linked lists, this time *)
(* with a shape predicate that is not abstract, but *)
(* precisely captures and reveals how the list is linked *)
(* The latter allows reasoning about the security of the linkage *)
(* e.g., inserting, then removing, did not change the security *)
(* of the linkage. *)

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

Definition list := ptr : Type.

Fixpoint lseq (x : ptr) (vs : seq (T * ptr)) : Pred heap := 
  if vs is (v, z)::vt then 
    fun i => 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 z] vs IH] i D; first by case.
by case=>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, z) :: (behead vs), i = x :-> Node v z :+ j & 
              j \In lseq z (behead vs)].
Proof.
case: vs=>[|[v z] vt] E /=; first by move=>H; case: H E=>->.
by case=>j [->] H; exists v; exists z; exists j.
Qed.

Lemma lseq_func x vs h1 h2 : h1 \In lseq x vs -> h2 \In lseq x vs -> h1 = h2.
Proof.
elim: vs x h1 h2=>[|[z v] vs IH] /= x h1 h2; first by case=>-> -> [_ ->].
by case=>j1 [->] H1 [j2][->] H2; rewrite (IH _ _ _ H1 H2).
Qed. 

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

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

Lemma shape_func p z vs h1 h2 : 
        h1 \In shape p z vs -> h2 \In shape p z vs -> h1 = h2.
Proof. by case=>j1 [->] H1 [j2][->] H2; rewrite (lseq_func H1 H2). Qed.

Program 
Definition new : 
  STsec [::] list
    (fun i => True, 
     fun yy ii mm => 
       exists jj, exists zz, 
         mm = jj :++ ii /\ jj \In sshape yy zz (nil, nil) /\
         ii.1 =~ ii.2 -> yy.1 = yy.2 /\ zz.1 = zz.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); exists (null, null)=>[[_]][_] /=.  
by case/L=>->.
Qed.

(* inserting low *)
Program 
Definition insert : 
  STsec [:: ptr:Set; T] unit 
    (fun p v i => exists h, exists j, exists z, exists vs,
                    i = j :+ h /\ j \In shape p z vs, 
     fun pp vv yy ii mm => 
       forall hh jj zz vvs, 
         ii = jj :++ hh -> jj \In sshape pp zz vvs -> 
       exists jj', exists zz', 
         mm = jj' :++ hh /\ 
         jj' \In sshape pp zz' ((vv.1, zz.1)::vvs.1, 
                                (vv.2, zz.2)::vvs.2) /\
         (jj.1 :+ hh.1 =~ jj.2 :+ hh.2 -> zz'.1 = zz'.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][_][z][vs][->][j][->] H; rewrite -unA.
  by sauto=>l; sauto.
move=>i1 i2 [[[[[]]]]] /= h [j1 j2][z1 z2] vs [[[-> ->]]][/=].
case=>k1 [->] H1 [k2][->] H2 _ _ D1 D2.
rewrite -!unA in D1 D2 *; vauto=>l1 l2; vauto=>_ _ H.
rewrite !unA; eexists (_, _); exists (l1, l2); rewrite /plus2 /=.
split=>//; rewrite -!unA.
split; first by hhauto.
by case/H.
Qed. 

Program 
Definition remove : 
  STsec [:: list] (option T)
    (fun p i => exists h, exists j, exists z, exists vs, 
                  i = j :+ h /\ j \In shape p z vs,
     fun pp yy ii mm => 
       forall hh jj zz vvs, 
         ii = jj :++ hh -> jj \In sshape pp zz vvs -> 
       exists jj', exists zz',
         mm = jj' :++ hh /\ jj' \In sshape pp zz' (behead vvs.1, behead vvs.2) /\ 
         (if vvs.1 is (v1, z1)::vs1 return Prop then 
             zz'.1 = z1 /\ yy.1 = Some v1 else zz'.1 = null /\ yy.1 = None) /\
         (if vvs.2 is (v2, z2)::vs2 return Prop then 
             zz'.2 = z2 /\ yy.2 = Some v2 else zz'.2 = null /\ yy.2 = 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, exists z',
             m = s :++ h /\
             s.1 \In shape p.1 z'.1 (behead vs.1) /\ 
             s.2 \In shape p.2 z'.2 (behead vs.2) /\ 
             (if vs.1 is (v1, z1)::vs1 return Prop then 
                 z'.1 = z1 /\ y.1 = Some v1 else z'.1 = null /\ y.1 = None) /\
             (if vs.2 is (v2, z2)::vs2 return Prop then 
                 z'.2 = z2 /\ y.2 = Some v2 else z'.2 = null /\ y.2 = 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 z1] vs1] /=; case: vs.2 H2=>[|[v2 z2] vs2] /=.
- case=>-> -> [-> ->]; rewrite eq_refl !unh0=>_ _.
  by vauto=>_ _; eexists (_, _); eexists (_, _); hhauto.
- case=>h [->] H1 [-> ->] _; rewrite -!unA unCA => D2. 
  rewrite eq_refl (negbTE (defPt_null D2)) !un0h. 
  lauto; exists (p1 :-> null, p2 :-> z2 :+ h); exists (null, z2). 
  by rewrite !unA; hhauto.
- case=>-> -> [h][->] H1; rewrite -!unA unCA=>D1 _.
  rewrite (negbTE (defPt_null D1)) eq_refl !un0h.
  lauto; exists (p1 :-> z1 :+ h, p2 :-> null); exists (z1, null).
  by rewrite !unA; hhauto.
case=>j2 [->] H2 [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); exists (z1, z2).
by rewrite !unA; hhauto.
Qed.
Next Obligation.
rewrite !gh;split=>[[p][]|[p1][][p2][]] /=.
- move=>i [h][j][head][vs][->][k][->] H1; rewrite -!unA.
  by sauto; apply: sval_do=>/=; rewrite unA; eauto.
move=>i1 i2 [[[[[]]]]] h j z' vs /= [[[-> ->]]][] /=.
case=>k1 [->] H1 [k2][->] H2 _ _ _ _.
rewrite -!unA; vauto; apply: val_do=>/=[|y1 y2 m1 m2]; rewrite !unA.
- by eauto 10.
case/(_ (_, _) (_, _) vs (erefl _) H1 H2)=>t [[z1' z2']][[-> ->]]{H1 H2} /=.
case=>[[s1]][->] H1 [[s2]][->]; move: H1. 
case: vs.1 => [|[v1 z1] vs1]; case: vs.2 => [|[v2 z2] vs2] /=;
[case=>-> -> [-> ->][[_ ->]][_ ->]; rewrite !unh0 |
 case=>-> -> /= H2 [[_ ->]][<- ->]; rewrite !unh0 |
 move=>H1 [-> ->][[<- ->]][_ ->] | 
 move=>H1 H2 [[<- ->]][[<- ->]]];
by eexists (_, _); eexists (_, _); hhauto.
Qed.

End List2. End List2.

(* okay, now the ratification for this implementation of linked lists *)

Module Type AliceSig4.
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 AliceSig4.

Module Alice4 : AliceSig4.

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

(* now let's say Bob is using this kind of lists for his local state *)

Module LinkedListClient2.

Definition bob := List2.list.
Definition G := seq nat : Type.

Definition bbshape (bb : d bob) (kk : d G) := 
  [Pred ii | exists zz, exists xx, 
               ii \In List2.sshape bb zz (zip kk.1 xx.1, zip kk.2 xx.2) 
               /\ bb.1 = bb.2].
Definition bcmp : G -> G := fun k => [:: 1 & k]. 

Lemma brefl : Alice4.breflP bbshape.
Proof.
move=>[b1 b2][k1 k2][t1 t2][[/= z1 z2]][[x1 x2]][[/= H1 H2]] E. 
by split; [exists (z1, z1); exists (x1, x1) | exists (z2, z2); exists (x2, x2)].
Qed.

Program
Definition linked_client :=
  Alice4.ratify (bcmp := bcmp) brefl
    (Do (Alice4.read_salary @@ (fun a b => [a]);;
         hide (List2.insert _) @@ (fun x a b => [b, 1]);;
         ret @@ (fun _ x a b => [x./2]))).
Next Obligation.
rewrite /Alice4.epost !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][H1][s][p][k][t][h][->] H2 [[/= z1 z2]][[x1 x2]].
  case=>[[/= H3 H4]] E; 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=>[[z1' z2']][[->]] E1 {H3 H4} [[/= H3 H4]] F; sauto. 
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[R]]][-> ->] S [[z1 z2]][[x1 x2]][[/= H1 H2]] E1 _ _ D1 D2.
rewrite -!unA in D1 D2 *.
case/Alice4.srefl: (S)=>/= S1 S2; case/Alice4.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=>[[z1' z2']][[->{m1} ->{m2}]][[/= H1' H2' H3']]; vauto=>D1' D2'.
exists (j1, j2); exists (t1', t2'); rewrite (unCA t1') (unCA t2') !unA. 
do !split=>//; first by exists (z1', z2'); exists (z1::x1, z2::x2). 
move=>E2 E3 /=. 
case: H1' H2' D1' D2'=>l1 [->] /= [l1'][->] H1' [l2][/= ->][l2'][->]  
      H2' D1' D2'.
case: H1 H2 D1 D2 E3 H3' =>r1' [->] R1' [r2'][->] R2'.
rewrite (unCA j1) (unCA j2) -E1=>D1 D2; move/defUnl: (D1)=>D3.
heap_cancel=>// _ E3 Z3 E. 
rewrite (_ : l1' = l2').
- by rewrite -Z3 E //; apply: lowUn=>//; rewrite E3 Z3.
by rewrite (List2.lseq_func H1' R1') (List2.lseq_func H2' R2').
Qed.

End LinkedListClient2.

(* todo : in-place reversal for lists of this kind *)
(* it has a weird loop invariant, because one has to *)
(* specify how the reversal modifies the linkage *)
