Set Automatic Coercion Import.
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
Require Import heaps rels hprop stmod stsep stlog stlogR llistR.
Set Implicit Arguments. 
Unset Strict Implicit. 
Import Prenex Implicits.

Definition stack (T : Type) := ptr.
Definition EmptyStack := exn_from_nat 25.

Module Stack. Section Stack.
Variable T : Type. 
Notation stack := (stack T).

Definition shape s xs := 
  [Pred h | exists p, exists h', def (s :-> p :+ h') /\ 
              s :-> p :+ h' = h /\ h' \In @lseq T p xs].
  
Program Definition new : STsep (emp, fun y i h => exists v, y = Val v /\ 
                                                    shape v [::] h) :=
  Do (alloc null).
Next Obligation. by move=>_ [->]; apply: val_alloc=>//; hauto. Qed.

Program Definition free s : STsep (shape s [::], 
                                   fun y i h => y = Val tt /\ h = empty) :=
  Do (dealloc s).
Next Obligation. by move=>_ [_][_][_][<-][->->]; heval. Qed.

Program 
Definition push s x : STsep (fun i => exists xs, shape s xs i, 
                             fun y i h => forall xs, shape s xs i -> 
                               y = Val tt /\ shape s (x :: xs) h) :=
  Do (hd <-- !s; 
      nd <-- allocb x 2;
      nd .+ 1 ::= (hd : ptr);;
      s ::= nd).
Next Obligation.
apply: ghE=>// _ xs [p][h][_][<-] H _ _; do ![hstep]=>nd /=; rewrite unh0 -unA.
do !hstep; split=>//; eexists _, _; do !split=>//; first by [].
by rewrite unCA; hauto.
Qed.

Program Definition pop s : 
  STsep (fun i => exists xs, shape s xs i, 
         fun y i h => forall xs, shape s xs i -> shape s (behead xs) h /\
           match y with Val v => xs = v :: behead xs
                      | Exn e => e = EmptyStack /\ xs = [::] end) :=
  Do (hd <-- !s;
      If hd == null then throw [T] EmptyStack
      else
        x <-- !hd;
        next <-- !(hd .+ 1);
        dealloc hd;; 
        dealloc hd .+ 1;;
        s ::= (next : ptr);;
        ret x).
Next Obligation.
apply: ghE=>// i xs [p][h][D][<-] H _ _; hstep.
case: eqP D H=>[->|N _]; first by move/defUnr=>D; case/(lseq_null D)=>->->; heval.
by case/(lseq_pos (introN (eq_ptrP _ _) N))=>x [?][?][->][<-] /= H; heval.
Qed.

End Stack. End Stack.

