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

(*********************************************************)
(* speculative examples about multi-party computations   *)
(* we declassify the average salary of any two employees *)
(* without declassifying any of the individual salaries  *)
(*********************************************************)

Module Type EmployeeSig.
Parameter employee : Type.

(* employee + salary *)
Parameter flow : d employee -> d nat -> Pred (d heap).

Definition shape a v : Pred heap := fun m => (m, m) \In flow (a, a) (v, v).

Parameter shape_diag : 
  forall a v i, flow a v i -> shape a.1 v.1 i.1 /\ shape a.2 v.2 i.2.

Parameter read_access : d employee -> Pred (d heap). 

Definition shape_read a v : Pred heap := 
  fun m => m \In shape a v /\ (m, m) \In read_access (a, a).

Parameter read_diag : 
  forall a v i, flow a v i -> read_access a i -> 
    shape_read a.1 v.1 i.1 /\ shape_read a.2 v.2 i.2.

Parameter new : 
  nat -> STsec [:::] employee 
           (fun i => True, 
            fun i y m => exists h, exists k, m = i :++ h /\ h \In flow y k).

Parameter get_salary :
  STsec [::: employee] nat
    (fun a i => exists h, exists j, exists v, 
                  i = j :+ h /\ j \In shape_read a v,
     fun a i y m => 
       forall h j v, 
         i = j :++ h -> j \In flow a v -> j \In read_access a -> 
       exists s, m = s :++ h /\
          s \In flow a v /\ s \In read_access a /\ y = v /\ y.1 = y.2).

Parameter declassify : 
  STsec [::: employee; employee] nat
    (fun a1 a2 i => exists h, exists i1, exists i2, exists v1, exists v2, 
       i = i1 :+ i2 :+ h /\ i1 \In shape_read a1 v1 /\ i2 \In shape_read a2 v2,
     fun a1 a2 i y m => forall h i1 i2 v1 v2,
       i = i1 :++ i2 :++ h -> 
       i1 \In read_access a1 -> i2 \In read_access a2 ->
       i1 \In flow a1 v1 -> i2 \In flow a2 v2 ->
     exists m1, exists m2, 
         m = m1 :++ m2 :++ h /\ 
         m1 \In flow a1 v1 /\ m2 \In flow a2 v2 /\
         y.1 = y.2 /\ y.1 = (v1.1 + v2.1)./2) ->
  STsec [:: employee; employee] nat 
    (fun a1 a2 i => exists h, exists i1, exists i2, exists v1, exists v2, 
       i = i1 :+ i2 :+ h /\ i1 \In shape a1 v1 /\ i2 \In shape a2 v2,
     fun a1 a2 i y m => forall h i1 i2 v1 v2,
       i = i1 :++ i2 :++ h -> 
       i1 \In flow a1 v1 -> i2 \In flow a2 v2 ->
      exists m1, exists m2, 
        m = m1 :++ m2 :++ h /\ 
        m1 \In flow a1 v1 /\ m2 \In flow a2 v2 /\ 
        y.1 = y.2 /\ y.1 = (v1.1 + v2.1)./2).

End EmployeeSig.

Module Employee : EmployeeSig.
Definition employee : Type := ptr.

Definition flow (a : d employee) (v : d nat) : Pred (d heap) := 
  [Pred i | i.1 = a.1 :-> v.1 /\ i.2 = a.2 :-> v.2 /\ v.1 = v.2].

Definition shape a v : Pred heap :=
  fun m => (m, m) \In flow (a, a) (v, v).

Lemma shape_diag a v i : 
        flow a v i -> shape a.1 v.1 i.1 /\ shape a.2 v.2 i.2.
Proof. by case: a v i=>a1 a2 [v1 v2][i1 i2][/= ->][->] ->. Qed. 

Definition read_access (a : d employee) : Pred (d heap) := 
  [Pred i | exists v:nat, i.1 = a.1 :-> v /\ i.2 = a.2 :-> v].

Definition shape_read a v : Pred heap := 
  fun m => m \In shape a v /\ (m, m) \In read_access (a, a).

Lemma read_diag a v i : 
        flow a v i -> read_access a i -> 
        shape_read a.1 v.1 i.1 /\ shape_read a.2 v.2 i.2.
Proof.
case: i=>i1 i2 [/= ->][->] -> [w] /= [H1 H2]. 
by do !split=>//; exists v.2.
Qed.

Program 
Definition new (v : nat) : 
  STsec [:::] employee 
    (fun i => True, 
    fun i y m => exists h, exists k, m = i :++ h /\ h \In flow y k) :=
  Do (halloc @ [v];;
      ret @ (fun x => [x])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; sstep=>x; sstep.
move=>i1 i2 _ _; v2step=>x1 x2; v2step.
by rewrite -(unC i1) -(unC i2); eexists (_, _), (v, v).
Qed.

Program 
Definition get_salary : 
  STsec [::: employee] nat
    (fun a i => exists h, exists j, exists v, 
                  i = j :+ h /\ j \In shape_read a v,
     fun a i y m => 
       forall h j v, 
         i = j :++ h -> j \In flow a v -> j \In read_access a -> 
       exists s, m = s :++ h /\
          s \In flow a v /\ s \In read_access a /\ y = v /\ y.1 = y.2) :=
  Do (read _ @ (fun a => [a]);;
      ret @ (fun x a => [x])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=.
- by move=>i [h][j][v][->][[/= ->]] _ [w][/= _ _]; sstep. 
move=>i1 i2 [[[[]]]][h1 h2][j1 j2][v1 v2] /= [[[-> ->]]].
case=>[[/= ->]][->] -> _ _ _; v2step=> _ _.
by exists (a1 :-> v2, a2 :-> v2); do !split=>//; exists v2.
Qed.

Program
Definition declassify
  (e : STsec [::: employee; employee] nat
    (fun a1 a2 i => exists h, exists i1, exists i2, exists v1, exists v2, 
       i = i1 :+ i2 :+ h /\ i1 \In shape_read a1 v1 /\ i2 \In shape_read a2 v2,
     fun a1 a2 i y m => forall h i1 i2 v1 v2,
       i = i1 :++ i2 :++ h -> 
       i1 \In read_access a1 -> i2 \In read_access a2 ->
       i1 \In flow a1 v1 -> i2 \In flow a2 v2 ->
     exists m1, exists m2, 
         m = m1 :++ m2 :++ h /\ 
         m1 \In flow a1 v1 /\ m2 \In flow a2 v2 /\
         y.1 = y.2 /\ y.1 = (v1.1 + v2.1)./2)) :
  STsec [::: employee; employee] nat 
    (fun a1 a2 i => exists h, exists i1, exists i2, exists v1, exists v2, 
       i = i1 :+ i2 :+ h /\ i1 \In shape a1 v1 /\ i2 \In shape a2 v2,
     fun a1 a2 i y m => forall h i1 i2 v1 v2,
       i = i1 :++ i2 :++ h -> 
       i1 \In flow a1 v1 -> i2 \In flow a2 v2 ->
      exists m1, exists m2, 
        m = m1 :++ m2 :++ h /\ 
        m1 \In flow a1 v1 /\ m2 \In flow a2 v2 /\ 
        y.1 = y.2 /\ y.1 = (v1.1 + v2.1)./2) :=
  Do (e @ (fun a1 a2 => [a1, a2])).
Next Obligation.
rewrite !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [h][i1][i2][v1][v2][->][[/= -> _]][/= -> _]. 
  ssimpl; apply: sval_do=>/=; exists h; exists (a :-> v1); exists (b :-> v2).
  by exists v1, v2; do !split=>//; [exists v1 | exists v2].
move=>k1 k2 [[[[[[]]]]]] /= h [i1 i2][j1 j2] v1 v2 [[[-> ->{k1 k2}]]] 
      H1 H2 _ _. 
have [R1 R2]: (i1, i2) \In read_access (a1, a2) /\ 
              (j1, j2) \In read_access (b1, b2).
- by split; [exists v1.1; case: H1 | exists v2.1; case: H2]=>/= -> [->] ->.
v2simpl; apply: val_do=>[|y1 y2 m1 m2].
- case/shape_diag: H1=>/= L1 L2; case/shape_diag: H2=>/= L3 L4.
  split.
  - exists h.1, i1, j1, v1.1, v2.1.
    by do !split=>//; [case: R1 | case: R2]=>v [/= ->] _; exists v.
  exists h.2, i2, j2, v1.2, v2.2.
  by do !split=>//; [case: R1 | case: R2]=>v [/= _] ->; exists v.
case/(_ (_, _) (_, _) (_, _) v1 v2 (erefl _) R1 R2 H1 H2).
case=>n1 n2 [[t1 t2]][[-> ->]] /= [E1][E2][->] -> _ _. 
by exists (n1, n2), (t1, t2).
Qed.

End Employee.

Section EmployeeClient.

Program 
Definition add_up' : 
  STsec [::: Employee.employee; Employee.employee] nat
    (fun a1 a2 i => exists h, exists i1, exists i2, exists v1, exists v2, 
      i = i1 :+ i2 :+ h /\ i1 \In Employee.shape_read a1 v1 /\
                           i2 \In Employee.shape_read a2 v2,
     fun a1 a2 i y m => forall h i1 i2 v1 v2,
       i = i1 :++ i2 :++ h -> 
         i1 \In Employee.read_access a1 -> i2 \In Employee.read_access a2 ->
         i1 \In Employee.flow a1 v1 -> i2 \In Employee.flow a2 v2 ->
       exists m1, exists m2, 
         m = m1 :++ m2 :++ h /\ 
         m1 \In Employee.flow a1 v1 /\ m2 \In Employee.flow a2 v2 /\
         y.1 = y.2 /\ y.1 = (v1.1 + v2.1)./2) :=
  Do (Employee.get_salary @ (fun a1 a2 => [a1]);;
      Employee.get_salary @ (fun x1 a1 a2 => [a2]);;
      ret @ (fun x2 x1 a1 a2 => [(x1 + x2)./2])).
Next Obligation.
rewrite !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [h][i1][i2][v1][v2][->][[H1 R1]][H2 R2].
  ssimpl; apply: sbnd_do=>/= [|y m]; rewrite -unA.
  - by exists (i2 :+ h), i1, v1.
  case/(_ (_, _) (_, _) (_, _) (erefl _) H1 R1)=>{H1 R1}.
  move=>{i1} [i1 j][[->]] E [H1][R1][[-> _]] _ D.
  move: E; heap_cancel=>// _ E; rewrite -{j}E in H1 R1 *.
  move: D; ssimpl; apply: sbnd_do=>/=.
  - by exists (i1 :+ h), i2, v2; rewrite unCA.
  by move=>y1 m1 _; sstep. 
move=>i1 i2 [[[[[[]]]]]] [h1 h2][j1 j2][s1 s2] /= [v1 w1][v2 w2].
case=>[[[[]]]][-> ->] R1 R2 H1 H2 _ _.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; rewrite -!unA.
- case/(Employee.read_diag H1): R1=>/= R1' R2'.
  by split; [exists (s1 :+ h1); exists j1; exists v1 | 
             exists (s2 :+ h2); exists j2; exists w1]. 
case/(_ (_, _) (_, _) _ (erefl _) H1 R1)=>{j1 j2 H1 R1}.
case=>j1 j2 [[-> ->]][H1][R1][[-> ->]] E1.
rewrite (unCA j1) (unCA j2).
v2simpl; apply: bnd_do=>/= [|{y1 y2 m1 m2} y1 y2 m1 m2].
- case/(Employee.read_diag H2): R2=>/= R1' R2'.
  by split; [exists (j1 :+ h1); exists s1; exists v2 | 
             exists (j2 :+ h2); exists s2; exists w2]. 
case/(_ (_, _) (_, _) _ (erefl _) H2 R2)=>{s1 s2 H2 R2} /=.
case=>s1 s2 [[-> ->]][H2][R2][[-> ->]] E2; v2step=>_ _.
exists (j1, j2); exists (s1, s2). 
by rewrite -(unCA j1) -(unCA j2) !unA /= {2}E1 {2}E2.
Qed.

Definition add_up := Employee.declassify add_up'.

End EmployeeClient.

