Open Scope pred.
Program Definition haltsn (n : nat) (stk : stack) : pred world :=
fun pr => let (p,r) := pr in
(level p >= n -> eventually_halts_n n p r stk).
Next Obligation.
unfold hereditary; intros.
destruct a as [p r'].
destruct a' as [p' r''].
intros.
unfold prog in *.
spec H0.
apply age_level in H; simpl in H; omega.
hnf in H.
simpl in H.
unfold prog_lookup, prog in *.
remember (age1 p).
icase o.
rewrite K.knot_age1 in Heqo.
remember (K.unsquash p).
destruct p0.
icase n0.
inv H.
inv Heqo.
destruct H0 as [px [rx [? ?]]].
repeat rewrite K.knot_level in *.
rewrite <- Heqp0 in H.
rewrite K.unsquash_squash in H1.
remember (K.unsquash px).
destruct p0.
simpl in *.
destruct n1.
omegac.
exists (K.squash (n1, f0)).
exists rx.
split.
repeat rewrite K.knot_level in *.
repeat rewrite K.unsquash_squash.
trivial.
generalize (stepstar_approxprog 1 _ _ (K.squash (n0,f)) (K.squash (n1, f0)) _ _ stk _ _ H0); intro.
spec H2.
exists (K.squash (n0,f)). split; try reflexivity.
hnf. rewrite K.knot_age1.
rewrite <- Heqp0. trivial.
spec H2.
exists (K.squash (n1,f0)). split; try reflexivity.
hnf. rewrite K.knot_age1.
rewrite <- Heqp1. trivial.
spec H2. apply stack_approx_rel_refl.
destruct H2 as [s2' [? ?]].
inversion H3. subst s2'.
trivial.
Qed.
Definition guardsn (n : nat) (P : pred world) (stk : stack) : pred world :=
P --> haltsn n stk.
Definition termMeas :=
{ R : store -> nat -> Prop |
forall x y y', R x y -> R x y' -> y = y' }.
Program Definition code (l : label) (c : instruction) : pred prog :=
fun p =>
exists i, prog_lookup p l = Some i /\ instr_approx_rel (level p) c i.
Next Obligation.
unfold hereditary; intros.
hnf in H.
unfold prog_lookup, prog in *.
destruct H0 as [i [? ?]].
exists (fmap_instr (K.approx (level a')) c).
split.
2: red; symmetry; apply collapse_instr_approx_same.
rewrite K.knot_age1 in H.
remember (K.unsquash a).
destruct p.
icase n.
inv H.
rewrite K.knot_level in *.
rewrite <- Heqp in H1.
rewrite K.unsquash_squash.
simpl in *.
unfold KnotInput.fmap.
erewrite fmap_eqn.
2: apply H0.
red in H1.
replace n with (min n (S n)) by (apply min_l; auto with arith).
do 2 rewrite <- collapse_instr_approx.
rewrite H1.
trivial.
Qed.
Program Definition evalTM (t : termMeas) (n : nat) : pred world :=
fun w => let (_, r) := w in
proj1_sig t r n.
Next Obligation.
unfold hereditary; intros.
destruct a. destruct a'.
hnf in H. simpl in H. unfold prog in *.
icase (age1 p).
inv H. trivial.
Qed.
Program Definition embedWP (P : pred world) : pred prog :=
fun p => forall r, P (p,r).
Next Obligation.
unfold hereditary; intros.
spec H0 r.
apply pred_hereditary with (a,r); auto.
unfold age,age1; simpl. change K.knot with prog.
rewrite H; auto.
Qed.
Definition funptr (l:label) (A:Type) (t:termMeas) (P Q: A -> pred world) : pred prog :=
EX c : instruction, code l c &&
ALL stk : stack, ALL n : nat, ALL x : A,
|> ((embedWP (guardsn n (Q x) stk)) -->
(ALL n' : nat, embedWP (evalTM t n'   -->
guardsn (n+n') (P x) ((c;;instr_assert FF)::stk) ))).
(* Definition of the hoare relation and rules *)
Definition hoare (n':nat) (G:pred prog) (R P:pred world) (c:instruction) (Q:pred world) :=
forall p n k stk,
G p ->
(forall r', guardsn n R stk       (p,r')) ->
(forall r', guardsn n Q (k::stk)  (p,r')) ->
(forall r,  guardsn (n'+n) P ((c ;; k)::stk) (p,r)).

(* Specifications: *)
Lemma hoare_weaken : forall x x' G G' (R R' P P' Q Q':pred world) i,
x <= x' ->
G' |-- G  ->
prog_op G' && R  |-- R' ->
prog_op G' && P' |-- P  ->
prog_op G' && Q  |-- Q' ->
hoare x  G  R  P  i Q ->
hoare x' G' R' P' i Q'.
Lemma hoare_weaken_time : forall x x' G R P i Q,
x <= x' ->
hoare x G R P i Q ->
hoare x' G R P i Q.
Lemma hoare_weaken_pre : forall x G R P P' i Q,
prog_op G && P' |-- P ->
hoare x G R P i Q ->
hoare x G R P' i Q .
Lemma hoare_weaken_post : forall x G R P i Q Q',
prog_op G && Q |-- Q' ->
hoare x G R P i Q ->
hoare x G R P i Q'.
Lemma hoare_ex_pre : forall x G R T P i Q,
(forall z:T, hoare x G R (P z) i Q) ->
hoare x G R (exp P) i Q.
Lemma hoare_ex_pre' : forall x G R T P i Q,
hoare x G R (exp P) i Q ->
(forall z:T, hoare x G R (P z) i Q).
Lemma hoare_fact_pre : forall x G R (X:Prop) P i Q,
(X -> hoare x G R P i Q) ->
hoare x G R (!!X && P) i Q.
Lemma hoare_return : forall G R,
hoare 0 G R R instr_return FF.
Lemma hoare_getlabel : forall l v G R P,
hoare 0 G R
(box (setM v (value_label l)) P)
(instr_getlabel l v)
P.
Lemma hoare_call : forall x G R v Q l A t lP lQ a,
let wp :=
store_op (fun r => r#v = Some (value_label l)) &&
evalTM t x &&
(prog_op (funptr l A t lP lQ)) &&
lP a && (closed (lQ a --> Q))
in
hoare (S x) G R wp (instr_call v) Q.
Lemma hoare_call' : forall x G R v Q,
let wp :=
EX l:label, EX A:Type, EX t:termMeas,
EX lP:(A->pred world), EX lQ:(A -> pred world), EX a:A,
store_op (fun r => r#v = Some (value_label l)) &&
(evalTM t x) &&
(prog_op (funptr l A t lP lQ)) &&
lP a && (closed (lQ a --> Q))
in
hoare (S x) G R wp (instr_call v) Q.
Lemma hoare_step_fetch0 : forall v1 v2 x1 x2 G R P,
hoare 0 G R
(store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x1) P)
(instr_fetch_field v1 0 v2)
P.
Lemma hoare_step_fetch1 : forall v1 v2 x1 x2 G R P,
hoare 0 G R
(store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x2) P)
(instr_fetch_field v1 1 v2)
P.
Lemma hoare_cons : forall v1 v2 v3 x1 x2 G R P,
hoare 0 G R
(store_op (fun r => r#v1 = Some x1 /\ r#v2 = Some x2) &&
box (setM v3 (value_cons x1 x2)) P)
(instr_cons v1 v2 v3)
P.
Lemma hoare_if : forall x v s1 s2 P1 P2 G R Q,
let wp :=
EX val:value,
store_op (fun r => r#v = Some val) &&
(
((!!(val = value_label (L 0)) && P1))
||
((EX x1:value, (EX x2:value,
!!(val = (value_cons x1 x2)))) && P2)
)
in
hoare x G R P1 s1 Q ->
hoare x G R P2 s2 Q ->
hoare x G R wp (instr_if_nil v s1 s2) Q.
Lemma hoare_assert : forall G R P (Q:assert),
prog_op G && P |-- Q ->
hoare 0 G R P (instr_assert Q) P.
Lemma hoare_seq : forall x y G R P Q S i1 i2,
hoare x G R P i1 Q ->
hoare y G R Q i2 S ->
hoare (x+y) G R P (i1 ;; i2) S.