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

Module D := DataType.

(* an RHTT counter *)

Module Counter.

Definition counter : Type := ptr. 

Definition sshape (cc: d counter) (nn: d nat) : Pred (d heap) :=
  fun ii => ii.1 = cc.1 :-> nn.1 /\ ii.2 = cc.2 :-> nn.2.

Definition shape (c: counter) (n: nat) : Pred heap := 
  fun i => sshape (c, c) (n, n) (i, i).

Definition pre_ctr c :=
  fun i =>
    exists n, exists j, exists h,
      i = j :+ h /\ j \In shape c n.

Program Definition new :
  STsec [:::] counter 
    (fun i => True, 
     fun yy ii mm => 
       exists jj, exists cc, mm = jj :++ ii /\
         pre_ctr cc.1 mm.1 /\ pre_ctr cc.2 mm.2 /\
         (ii.1 =~ ii.2 -> cc.1 = cc.2 /\ jj.1 = jj.2)) :=
  Do (lalloc @0 [0]).
Next Obligation.
split=>//a1 a2 i1 i2 _ _ _ _; vauto=>l1 l2 _ _ H1 _.
exists (l1 :-> 0, l2 :-> 0); rewrite /plus2 /=; exists (l1, l2); split=>//. 
split; first by exists 0, (l1 :-> 0), i1; split.
split; first by exists 0, (l2 :-> 0), i2; split.
by move=>H2; case: (H1 H2)=>->.
Qed.

Definition post_inc cc :=
  fun (yy: d unit) ii mm => 
    forall nn jj hh, ii = jj :++ hh -> 
      jj \In sshape cc nn ->
      exists jj', mm = jj' :++ hh /\
        jj' \In sshape cc (succn nn.1, succn nn.2).

Program Definition inc (c : counter) : 
  STsec [:::] unit (pre_ctr c, post_inc (c, c)) :=
  Do (read nat @0 [c];; 
      write @ (fun n => [c, n.+1])).
Next Obligation.
rewrite !gh; split=>[a i [n][j][h][[/= ->]][/=-> _]|]; first by sauto.
move=> a1 a2 i1 i2[[[[]]]][n1 n2][j1 j2][h1 h2]/=. 
move=> [[-> ->]][/= ->][/= ->] _ _ _ _; vauto=> _ _.
rewrite /plus2 =>/=; set jj'1 := c :-> _; set jj'2 := c :-> _.
by exists (jj'1, jj'2) =>/=; split.
Qed.

Definition post_dec cc :=
  fun (yy: d unit) ii mm => 
    forall nn jj hh, ii = jj :++ hh -> 
      jj \In sshape cc nn ->
      exists jj', mm = jj' :++ hh /\
        jj' \In sshape cc (predn nn.1, predn nn.2).

Program Definition dec (c : counter) : 
  STsec [:::] unit (pre_ctr c, post_dec (c, c)) :=
  Do (read nat @0 [c];; 
      write @ (fun n => [c, predn n])).
Next Obligation.
rewrite !gh; split=>[a i [n][j][h][[/= ->]][/=-> _]|]; first by sauto.
move=> a1 a2 i1 i2[[[[]]]][n1 n2][j1 j2][h1 h2]/=. 
move=> [[-> ->]][/= ->][/= ->] _ _ _ _; vauto=> _ _.
rewrite /plus2 =>/=; set jj'1 := c :-> _; set jj'2 := c :-> _.
by exists (jj'1, jj'2) =>/=; split.
Qed.

Definition post_read cc :=
  fun yy ii mm => mm = ii /\ 
    forall nn jj hh, ii = jj :++ hh -> 
      jj \In sshape cc nn -> 
      yy.1 = nn.1 /\ yy.2 = nn.2.

Program Definition read (c : counter) : 
  STsec [:::] nat (pre_ctr c, post_read (c, c)) :=
  Do (read nat @0 [c]).
Next Obligation.
split=>[a i [n][j][h][[/= ->]][/=-> _]|]; first by sauto.
move=> a1 a2 i1 i2 [n1][j1][h1][->][/= -> ->] [n2][j2][h2][->][/= -> ->] D1 D2.
vauto=> _ _ _. rewrite /post_read /plus2 =>/=. split=>// nn jj hh A.
move=> B; move: B A=> [/= -> ->] [A B]. 
split; first by case: (cancel D1 A). by case: (cancel D2 B).
Qed.

(* the model *)

Module CounterModel. Section CounterModel.
Variable c : counter. (* models initial allocation *)

Definition T := nat.

Inductive O : Type := Inc | Dec | Read.

Definition shape (n : nat) := fun i => i = c :-> n.

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

Definition res_of (op : O) := 
  match op with Inc => unit | Dec => unit | Read => nat end.

Definition spec_of op : spec (args_of op) (res_of op) :=
  (pre_ctr c,
   match op as op' return post (args_of op') (res_of op') with 
   | Inc => post_inc (c, c)
   | Dec => post_dec (c, c)
   | Read => post_read (c, c)
   end).

Definition trans op n (u : args (args_of op)) := 
  match op as op' return (nat * res_of op') with 
  | Inc => (succn n, tt) 
  | Dec => (predn n, tt)
  | Read => (n, n)
  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 tt).1 mm.1 /\
  shape (trans op aalpha.2 tt).1 mm.2.
Proof.
elim: op yy av1 av2; rewrite /shape=>//= yy av1 av2 A.
case: ii A=> i1 i2 A /= B C; move: B C A=>->-> A.
case: (A aalpha (c :-> aalpha.1, c :-> aalpha.2) (empty, empty)).
by rewrite /plus2 /= !unh0.
rewrite -toPredE /=. 
split=>//=. move=> [j1 j2][->][[/=-> ->]].
by rewrite !unh0.
case: ii A=> i1 i2 A /= B C; move: B C A=>->-> A.
case: (A aalpha (c :-> aalpha.1, c :-> aalpha.2) (empty, empty)).
by rewrite /plus2 /= !unh0.
rewrite -toPredE /=. 
split=>//=. move=> [j1 j2][->][[/=-> ->]].
by rewrite !unh0.
by case: ii A=> i1 i2 A /= B C; move: B C A=>->-> [-> B].
Qed.

Implicit Arguments D.Datatype [].

Definition CounterType := 
  D.Datatype _ _ 0 shape _ _ _ trans shape_inv.

Lemma CounterType_UR : D.UR CounterType.
Proof. by move=>a g1 g2 H I; case: a H I; [move=>-> ->|move=> n -> ->]. Qed.

Lemma CounterType_SHI : D.SHI CounterType.
Proof. apply: D.UR_SHI CounterType_UR. Qed.

End CounterModel. End CounterModel.

End Counter.

Module C := Counter.

Section CounterClient.
Variable (c: C.counter). (* models 'random bits' before initialization *)

(* specialty proof rules for inc/dec *)

Lemma sval_inc (n : nat) i :
  def (c :-> n :+ i) -> c :-> n :+ i \In safe (C.inc c @0 tt).
Proof. by apply: sval_do=>//= D; do 2!eexists; exists i. Qed.

Lemma sbnd_inc B (e : ST [::: unit] B) n i :
  (def (c :-> n.+1 :+ i) -> c :-> n.+1 :+ i \In safe (e @0 [tt])) -> 
  def (c :-> n :+ i) -> c :-> n :+ i \In safe (bind (C.inc c @0 tt) e).
Proof.
move=>H; apply: sbnd_do=>[|y m] /=; first by do 2!eexists; exists i.
case/(_ (n, n) (c :-> n, c :-> n) (i, i) (erefl _)); first by split.
by move=>[u u'][[/= -> _ ]][[/= -> _]]; case y.
Qed.

Lemma sval_dec (n : nat) i :
  def (c :-> n :+ i) -> c :-> n :+ i \In safe (C.dec c @0 tt).
Proof. by apply: sval_do=>//= D; do 2!eexists; exists i. Qed.

Lemma sbnd_dec B (e : ST [::: unit] B) n i :
  (def (c :-> n.-1 :+ i) -> c :-> n.-1 :+ i \In safe (e @0 [tt])) -> 
  def (c :-> n :+ i) -> c :-> n :+ i \In safe (bind (C.dec c @0 tt) e).
Proof.
move=>H; apply: sbnd_do=>[|y m] /=; first by do 2!eexists; exists i.
case/(_ (n, n) (c :-> n, c :-> n) (i, i) (erefl _)); first by split.
by move=>[u u'][[/= -> _ ]][[/= -> _]]; case y.
Qed.

(* still working on updating stuff here *)

End CounterClient.

