Load loadpath.
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun tuple.
Require Import prelude heaps rels hprop domains secmod seclog datatypes array.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module A := Array.

Definition bump_slot (I : finType) k (f : {ffun I -> nat}) :=
  A.updf k ((f k).+1) f.

(* Uniquely represented insert-only bounded multisets --- i.e., UR multisets
   with finite domains, no delete operation. 

   UR insert-only multisets are useful in voting machine software. See, e.g.,
   "Tamper-evident, history-independent, subliminal-free data structures on PROM
   storage" by Molnar et al., Oakland 2006, for details. *)

Definition mset (I : finType) := {array I -> nat}.

Module MultiSet. Section MultiSet.
Variables (I : finType) (v0 : nat).
Notation mset := (mset I).

Definition shape (s : mset) (f : {ffun I -> nat}) := A.shape s f.

Definition sshape ss ff := fun ii =>
  shape ss.1 ff.1 ii.1 /\ shape ss.2 ff.2 ii.2.

Lemma sshape_fun s f i1 i2 : sshape (s, s) (f, f) (i1, i2) -> i1 = i2.
Proof. by move=>[[/=-> _]][[/=-> _]]. Qed.

Program Definition new : STsec [:::] mset
  (fun i => True, 
   fun yy ii mm => 
     exists jj, mm = jj :++ ii /\ 
       sshape (yy.1, yy.2) ([ffun => v0], [ffun => v0]) jj /\
       (ii.1 =~ ii.2 -> yy.1 = yy.2 /\ jj.1 = jj.2)) :=
  Do (Array.new I v0 @0 tt;;
      ret @ (fun a => [a])).
Next Obligation.
split=> [a i _ D|a1 a2 i1 i2 _ _ D1 D2]; first by apply: sbnd_do=>//.
vauto. apply: Array.bnd_new=> j1 j2 a3 a4; vauto=> D3 D4 [[/= A B] C] _.
by exists (j1, j2); split.
Qed.

Definition pre_insert s i :=
  exists f, exists j, exists h, i = j :+ h /\ shape s f j.

Definition post_insert s kk (yy : d unit) ii mm :=
  forall ff jj hh, ii = jj :++ hh -> sshape (s, s) ff jj ->
    exists jj', 
      mm = jj' :++ hh /\ 
      sshape (s, s) (bump_slot kk.1 ff.1, bump_slot kk.2 ff.2) jj'.

Program Definition insert (s : mset) : STsec [::: I] unit
  (fun k i => pre_insert s i,
   fun kk yy ii mm => post_insert s kk yy ii mm) :=
  Do (A.read s @ (fun k => [k]);;
      A.write s @ (fun n k => [k, n.+1])).
Next Obligation.
rewrite !gh; split.
move=> a i [f][j][h][->][->]A; sauto. apply: sbnd_do=>//=.
by exists (updi2 s (fgraph f)); exists h; exists f. 
move=> y m [[/= -> ->]]B C. apply: sval_do=>//= _.
by exists (updi2 s (fgraph f)); exists h; exists f.
move=> a1 a2 i1 i2 [[[[[]]]]] f1 f2 [j1 j2] [h1 h2] [[/= -> ->]].
move=> D[f1'][j1'][h1']A [f2'][j2'][h2']B _ _; vauto.
apply: (A.bnd_read D); vauto. apply: val_do=>//=. 
case: D=> D1 D2. split=> _; by do 3!eexists; eauto. 
move=> y1 y2 m1 m2 /= C _ _. case: D=> D1 D2. 
case: (C (j1, j2) (h1, h2) (f1, f2)). 
by rewrite /plus2. by split. move=> [j1a j2a] [[/= -> ->]].
move=> [/= [-> F] [-> G]]. set k1 := updi2 s _. set k2 := updi2 s _. 
by exists (k1, k2); rewrite /plus2.
Qed.

End MultiSet. End MultiSet.

Module S := MultiSet.

Module MultiSetModel. Section MultiSetModel.
Variables (I : finType) (v0 : nat) (s : mset I). 

Inductive op : Type := Insert.

Definition init := [ffun _ : I => v0].

Definition shape f := S.shape s f.

Lemma shape_fun f h1 h2 : 
  shape f h1 -> shape f h2 -> h1 = h2.
Proof. by move=> /= [-> _] [-> _]. Qed.

Definition args_of (op : op) := [::: I].

Definition res_of (op : op) := unit.

Definition trans op (f : {ffun I -> nat})
  : args (args_of op) -> {ffun I -> nat} * res_of op := 
  match op as op' return 
    args (args_of op') -> {ffun I -> nat} * res_of op' with
  | Insert => fun av => (bump_slot av.1 f, tt) 
  end.

Definition spec_of op : spec (args_of op) (res_of op) 
  := match op as op' return 
       spec (args_of op') (res_of op') with 
  | Insert => (fun k => S.pre_insert s, S.post_insert s)
  end.

Implicit Arguments trans [].

Lemma shape_inv aalpha op av1 av2 yy ii mm :
  spec2 (spec_of op) av1 av2 yy ii mm ->
  shape aalpha.1 ii.1 -> shape aalpha.2 ii.2 ->
  shape (trans op aalpha.1 av1).1 mm.1 /\
  shape (trans op aalpha.2 av2).1 mm.2.
Proof.
elim: op yy av1 av2; rewrite /shape=>//= yy av1 av2 A [B0 B] [C0 C].
case: (A aalpha ii (empty, empty)); first by rewrite /plus2 /= 2!unh0; case ii.
by split. rewrite /plus2 /= => [[/= j1 j2]][[-> [/= [-> D1] [-> D2]] /=]]. 
by rewrite 2!unh0 /bump_slot /=.
Qed.

Implicit Arguments D.Datatype [].

Definition MultiSetType := 
  D.Datatype {ffun I -> nat} _ init shape _ _ _ trans 
             shape_inv.

Lemma MultiSetType_UR : D.UR MultiSetType.
Proof. by apply: shape_fun. Qed.

Lemma MultiSetType_SHI : D.SHI MultiSetType.
Proof. apply: D.UR_SHI MultiSetType_UR. Qed.

End MultiSetModel. End MultiSetModel.

