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.

(* Nonzero nats*)

Definition pnat := {n : nat & n > 0}.
Coercion pnat2nat (p : pnat) := let n := projT1 p in n.

Lemma pnat0lt (n : pnat) : 0 < n.
Proof. by apply: (projT2 n). Qed.

(* Functions on ordinals *)

Section Ordinals.
Variable (n : pnat).

Definition mkord (m : nat) (pf : m.+1 <= n) : 'I_n := widen_ord pf ord_max.

Definition mkord0 := mkord (pnat0lt n).

Lemma mkord_eq m (pf : m.+1 <= n) : m = mkord pf.
Proof. by rewrite /mkord /=. Qed.

Lemma ltn_predn m : m < n -> m.-1 < n.
Proof. 
elim: m=>//= m' IH A. 
suff B: (m' < m'.+1) by eapply leq_trans; eauto.
by apply: ltnSn.
Qed.

Definition predord (m : 'I_n) : 'I_n := Ordinal (ltn_predn (ltn_ord m)).

Lemma predord_eq (m : 'I_n) : m.-1 = predord m.
Proof. by rewrite /predord /=. Qed.

End Ordinals.

Section Bump.
Variables (n : pnat) (T : Type).

(* bump increments ix unless ix = n - 1, in which case bump returns ix unchanged
*)

Definition bump (ix : 'I_n) : 'I_n :=
  (if ix.+1 < n as b return ((ix.+1 < n) = b -> 'I_n) then fun pf => mkord pf
   else fun _ => ix) (erefl _).

(* unbump decrements ix unless ix = 0, in which case unbump returns ix unchanged
*)

Definition unbump (ix : 'I_n) : 'I_n := predord ix.

Lemma unbumpP (ix : 'I_n) : ix.-1 = unbump ix.
Proof. by []. Qed.

(* bumpval ix v v0 returns v if ix.+1 < n, else v0 *)

Definition bumpval (ix : 'I_n) (v v0 : T) := if ix.+1 < n then v else v0.

End Bump.

(* Bounded stacks *)

Module A := Array.

(* to represent stacks, I would like to write something like

Record stack (n : pnat) (T : Type) : Type := 
  Stack {arr : {array 'I_n -> T}; sz : 'I_n}

and then pass around "stack" as an abstract type, but need to make the orig
ptr. of the base array a function arg. in order to model the data structure (an
issue related to "initial allocation").

letting the stack size be a local arg. (as in the second Stack module below)
causes encapsulation problems.  in particular, a client could forge the size and
push/pop illegal array cells.

the first stack module below fixes this issue by: 
-making the #elements in the stack a part of the logical state 
-storing the stack size in the heap, alongside the base array

this way, the shape function still uniquely determines the corresponding heap
but the stack size is inaccessible to clients, except in specs.  *)

Module Stack. Section Stack.
Variables (n : pnat) (T : Type) (v0 : T).

Notation stack := (({array 'I_n -> T} * ptr)%type).

Definition arr := [fun s : stack => s.1].
Definition sz := [fun s : stack => s.2].

(* abstract stacks *)

Record stack_ty := StackTy {size : 'I_n; f : {ffun 'I_n -> T}}. (* NOTE: maybe want a proof here that 
                                                                   values (f m) st. m >= size are equal
                                                                   to v0 *)

Definition shape (s : stack) (ty : stack_ty) := 
  [Pred i | exists j, exists h,
    i = j :+ h /\ A.shape (arr s) (f ty) j /\ h = (sz s) :-> (size ty)].

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

Lemma sshape_fun s f i1 i2 : sshape (s, s) (f, f) (i1, i2) -> i1 = i2.
Proof. by move=> [/= [j1][h1][-> [[-> A] ->]] [j2][h2][-> [[-> B] ->]]]. Qed.

Notation "'_0_'" := (mkord0 n).

Program Definition new : STsec [:::] stack
  (fun i => True, 
   fun yy ii mm => 
     exists jj, mm = jj :++ ii /\ 
       sshape (yy.1, yy.2) (StackTy _0_ [ffun => v0], StackTy _0_ [ffun => v0]) jj /\
       (ii.1 =~ ii.2 -> yy.1 = yy.2 /\ jj.1 = jj.2)) :=
  Do (A.new [finType of 'I_n] v0 @0 tt;;
      lalloc @ (fun orig => [ _0_ ]);;
      ret @ (fun size orig => [(orig, size)])).
Next Obligation.
split=> [a i _ D|a1 a2 i1 i2 _ _ D1 D2]; first by apply: sbnd_do=>//.
vauto; apply: A.bnd_new=> j1 j2 a3 a4; vauto=> l1 l2; vauto. 
move=> D3 D4 A [/= [/= [B0 B] [C0 C]]] D _; rewrite B0 C0 in A B C D D3 D4 |- *.
move: A B C D D3 D4; set u1 := updi2 _ _; set u2 := updi2 _ _ => A B C D D3 D4.
exists (l1 :-> _0_ :+ u1, l2 :-> _0_ :+ u2) =>/=.
split; first by rewrite /plus2 /= 2!unA. split=>/=. split=>//=.
exists u1; exists (l1 :-> _0_); split=>//=; first by rewrite unC.
exists u2; exists (l2 :-> _0_); split=>//=; first by rewrite unC.
move=> EQ. have EQ' : (u1 :+ i1 =~ u2 :+ i2). 
- case: (D EQ)=> _ R. rewrite R in D3 |- *. apply: lowUn=>//=. 
  by apply: (defUnr D3). by apply: (defUnr D4).
by case: (D EQ) (A EQ')=> -> -> [/= -> E]. 
Qed.

Definition pre_stack s i := 
  exists j, exists h, exists ty, i = j :+ h /\ shape s ty j.

(* specs of push and pop *)

Definition post_push s v (yy : d unit) ii mm :=
  forall jj hh tty, ii = jj :++ hh -> sshape (s, s) tty jj -> 
    exists jj', mm = jj' :++ hh /\
      let: ix1 := bump (size tty.1) in
      let: ix2 := bump (size tty.2) in
      let: val1 := bumpval (size tty.1) v (f tty.1 (size tty.1)) in
      let: val2 := bumpval (size tty.2) v (f tty.2 (size tty.2)) in
        sshape (s, s) (StackTy ix1 (A.updf ix1 val1 (f tty.1)),
                       StackTy ix2 (A.updf ix2 val2 (f tty.2))) jj'.

Definition post_pop s yy ii mm :=
  forall jj hh tty, ii = jj :++ hh -> sshape (s, s) tty jj -> 
    yy.1 = f tty.1 (size tty.1) /\ yy.2 = f tty.2 (size tty.2) /\
    exists jj', mm = jj' :++ hh /\
      let: ix1 := unbump (size tty.1) in
      let: ix2 := unbump (size tty.2) in
        sshape (s, s) (StackTy ix1 (A.updf (size tty.1) v0 (f tty.1)),
                       StackTy ix2 (A.updf (size tty.2) v0 (f tty.2))) jj'.

Program Definition push (s : stack) (v : T) : 
  STsec [:::] unit (pre_stack s, post_push s v) :=
  Do (read _ @0 [sz s];;
      A.read (arr s) @ (fun ix => [ix]);;
      A.write (arr s) @ (fun v0 ix => [bump ix, bumpval ix v v0]);;
      write @ (fun _ v0 ix => [sz s, bump ix])).
Next Obligation.
rewrite !gh; split=> [av i [j][h][ty][-> [j1 [j2 [-> [[-> A] ->]]]]] | ]. 
rewrite -unA unC -unA /=; sauto. 
rewrite unA unC; apply A.sbnd_read with (f := f ty)=>// v' B; sauto. 
apply: A.sbnd_write=>// j' C; sauto.
move=> a1 a2 i1 i2 [[[[[]]]]] j1 j2 [h1 h2] [f1 f2] [[/= -> ->]]. 
move=> [/= [ja][ha][-> [[-> A1] ->]]] [jb][hb][-> [[-> A2] ->]]. 
rewrite -unA unC -(unA (updi2 _(fgraph (f f2)))) (unC (updi2 _(fgraph (f f2)))).
rewrite -unA -(unA (p :-> size f2))=> B1 B2 C1 C2; vauto.
rewrite unA unC (unC (p :-> size f2)) -(unA h2) (unC h2) -(unA (updi2 _ (fgraph (f f2)))).
apply A.bnd_read with (f1 := f f1) (f2 := f f2)=>//; vauto.
apply A.bnd_write with (f1 := f f1) (f2 := f f2)=>// j1' j2' /= D; vauto=> D1 D2.
exists (p :-> bump (size f1) :+ j1', p :-> bump (size f2) :+ j2'). 
split; first by rewrite /plus2 /= 2!unA. split =>/=.
case: D =>/= [[-> D3] [-> D4]]. set k1 := (updi2 _ _) in D3 |- *. 
by exists k1; exists (p :-> bump (size f1)); rewrite unC.
case: D =>/= [[-> D3] [-> D4]]. set k2 := (updi2 _ _) in D4 |- *. 
by exists k2; exists (p :-> bump (size f2)); rewrite unC.
Qed.

Program Definition pop (s : stack) :
  STsec [:::] T (pre_stack s, post_pop s) :=
  Do (read _ @0 [sz s];;
      A.read (arr s) @ (fun ix => [ix]);;
      A.write (arr s) @ (fun v ix => [ix, v0]);;
      write @ (fun _ v ix => [sz s, unbump ix]);;
      ret @ (fun _ _ v ix => [v])).
Next Obligation. 
rewrite !gh; split=> [av i [j][h][ty][-> [j1 [j2 [-> [[-> A] ->]]]]] | ]. 
rewrite -unA unC -unA /=; sauto. 
rewrite unA unC; apply A.sbnd_read with (f := f ty)=>// v' B; sauto. 
apply: A.sbnd_write=>// j' C; sauto.
move=> a1 a2 i1 i2 [[[[[]]]]] j1 j2 [h1 h2] [f1 f2] [[/= -> ->]]. 
move=> [/= [ja][ha][-> [[-> A1] ->]]] [jb][hb][-> [[-> A2] ->]]. 
rewrite -unA unC -(unA (updi2 _(fgraph (f f2)))) (unC (updi2 _(fgraph (f f2)))).
rewrite -unA -(unA (p :-> size f2))=> B1 B2 C1 C2; vauto.
rewrite unA unC (unC (p :-> size f2)) -(unA h2) (unC h2) -(unA (updi2 _ (fgraph (f f2)))).
apply A.bnd_read with (f1 := f f1) (f2 := f f2)=>//; vauto.
apply A.bnd_write with (f1 := f f1) (f2 := f f2)=>// j1' j2' /= D; vauto=> D1 D2.
split=>//=. split=>//=.
exists (p :-> unbump (size f1) :+ j1', p :-> unbump (size f2) :+ j2'). 
split; first by rewrite /plus2 /= 2!unA. split =>/=.
case: D =>/= [[-> D3] [-> D4]]. set k1 := (updi2 _ _) in D3 |- *. 
by exists k1; exists (p :-> unbump (size f1)); rewrite unC. 
case: D =>/= [[-> D3] [-> D4]]. set k2 := (updi2 _ _) in D4 |- *. 
by exists k2; exists (p :-> unbump (size f2)); rewrite unC.
Qed.

End Stack. End Stack.

(* the alternative implementation of stacks mentioned in the note above *)

Module Stack1. Section Stack.
Variables (n : pnat) (T : Type) (v0 : T).

Notation arr := ({array 'I_n -> T}).
Notation stack := ((arr * 'I_n)%type).

Definition f := [fun s : stack => s.1].
Definition size := [fun s : stack => s.2].

Definition shape (s : arr) (f : {ffun 'I_n -> T}) := 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 [:::] stack
  (fun i => True, 
   fun yy ii mm => 
     exists jj, mm = jj :++ ii /\ 
       sshape (f yy.1, f yy.2) ([ffun => v0], [ffun => v0]) jj /\
       (ii.1 =~ ii.2 -> yy.1 = yy.2 /\ jj.1 = jj.2)) :=
  Do (A.new [finType of 'I_n] v0 @0 tt;;
      ret @ (fun a => [(a, mkord0 n)])).
Next Obligation.
split=> [a i _ D|a1 a2 i1 i2 _ _ D1 D2]; first by apply: sbnd_do=>//.
vauto. apply: A.bnd_new=> j1 j2 a3 a4; vauto=> D3 D4 [[/= A B] C] _.
exists (j1, j2); split=>//=. split. split=>//=. move=> D; case: (C D)=> E F. 
by split; f_equal.
Qed.

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

Definition post_push s v (iix : d 'I_n) yy ii mm :=
  forall jj hh ff, ii = jj :++ hh -> sshape (s, s) ff jj -> 
    yy.1 = bump iix.1 /\ yy.2 = bump iix.2 /\ 
    exists jj', mm = jj' :++ hh /\
      sshape (s, s) (A.updf yy.1 (bumpval iix.1 v (ff.1 iix.1)) ff.1, 
                     A.updf yy.2 (bumpval iix.2 v (ff.2 iix.2)) ff.2) jj'.

Definition post_pop s (iix : d 'I_n) yy ii mm :=
  forall jj hh ff, ii = jj :++ hh -> sshape (s, s) ff jj -> 
    exists jj', mm = jj' :++ hh /\
      yy.1 = (unbump iix.1, ff.1 iix.1) /\ yy.2 = (unbump iix.2, ff.2 iix.2) /\
      sshape (s, s) (A.updf iix.1 v0 ff.1, A.updf iix.2 v0 ff.2) jj'.

Program Definition push (s : arr) (v : T) : 
  STsec [::: 'I_n] 'I_n (fun ix => pre_stack s, post_push s v) :=
  Do (A.read s @ (fun ix => [ix]);;
      A.write s @ (fun v0 ix => [bump ix, bumpval ix v v0]);;
      ret @ (fun _ v0 ix => [bump ix])).
Next Obligation.
rewrite !gh; split=> [a i A /= | ]. 
sauto; apply: sbnd_do=>// y m /= [[/= -> ->]]B; sauto; apply: sbnd_do=>//=.
move=> a1 a2 i1 i2 [[[[[]]]]] j1 j2 [h1 h2] [f1 f2] [[/= -> ->]]. 
move=> A B C D E; vauto; eapply A.bnd_read; eauto; vauto.
eapply A.bnd_write; eauto=> j1' j2' H; vauto=> D1 D2. split=>//; split=>//. 
exists (j1', j2'); split=>/=; first by rewrite /plus2 /=.
by case: H =>/= [[-> D3]][[-> D4]].
Qed.

Program Definition pop (s : arr) :
  STsec [::: 'I_n] ('I_n * T) (fun ix => pre_stack s, post_pop s) :=
  Do (A.read s @ (fun ix => [ix]);;
      A.write s @ (fun v ix => [ix, v0]);;
      ret @ (fun _ v ix => [(unbump ix, v)])).
Next Obligation.
rewrite !gh; split=> [a i A /= | ]. 
sauto; apply: sbnd_do=>// y m /= [[/= -> ->]]B; sauto; apply: sbnd_do=>//=.
move=> a1 a2 i1 i2 [[[[[]]]]] j1 j2 [h1 h2] [f1 f2] [[/= -> ->]]. 
move=> A B C D E; vauto; eapply A.bnd_read; eauto; vauto.
eapply A.bnd_write; eauto=> j1' j2' H; vauto=> D1 D2.
by exists (j1', j2'); rewrite /plus2 /=.
Qed.

End Stack. End Stack1. 

