Open Scope pred.
Program Definition guards (n:nat) (X:pred world) (stk:stack) : pred world :=
fun prt =>
match prt with (p,(r,t)) =>
forall p',
necR p p' ->
X (p',(r,t)) ->
safe t p' r stk /\
(level p' >= n -> eventually_halts t p' r stk)
end.
Next Obligation.
unfold hereditary; intros.
destruct a as [p [r' t]].
destruct a' as [p' [r'' t']].
hnf in H.
simpl in H.
unfold prog in *.
case_eq (age1 p); intros.
rewrite H1 in H.
inv H.
spec H0 p'0.
spec H0.
apply rt_trans with p'; auto.
apply rt_step; auto.
spec H0; auto.
rewrite H1 in H; discriminate.
Qed.
Program Definition term_guards (t:store -> option nat) (n:nat) (X:pred world) (stk:stack) : pred world :=
fun prt =>
match prt with (p,(r,t')) =>
forall p',
necR p p' ->
X (p',(r,t')) ->
exists n',
t r = Some n' /\
safe t' p' r stk /\
(level p' >= (n'+n) -> eventually_halts t' p' r stk)
end.
Next Obligation.
unfold hereditary; intros.
destruct a as [? [? ?]].
destruct a' as [? [? ?]].
intros.
hnf in H.
unfold prog in *.
simpl in H.
case_eq (age1 p); intros; rewrite H3 in H; inv H.
spec H0 p'. spec H0.
apply rt_trans with p0; auto.
apply rt_step; auto.
spec H0; auto.
Qed.
Program Definition funptr (l:label) (A:Type) (P Q: A -> pred world) : pred world :=
fun prt =>
match prt with (p,(_,t)) =>
exists i,  prog_lookup p l = Some i /\
(forall stk p' n t' (x:A),
termMeasure_incr t t' ->
laterR p p' ->
(forall r', guards n (Q x) stk (p',(r' ,t'))) ->
(forall r , term_guards (t l) n (P x) ((i;;instr_nil _)::stk) (p',(r,t'))))
end.
Next Obligation.
unfold hereditary; intros.
destruct a as [p [r' t]].
destruct a' as [p' [r'' t']].
hnf in H; simpl in H.
case_eq (age1 p); intros.
unfold prog in *.
rewrite H1 in H.
inv H.
rename t' into t.
destruct H0 as [i [? ?]].
rewrite K.knot_age1 in H1.
case_eq (K.unsquash p); intros.
rewrite H2 in H1.
destruct n; try discriminate.
inv H1.
exists (fmap_instr (K.approx n) i).
split.
unfold prog_lookup.
rewrite K.unsquash_squash; simpl.
unfold KnotInput.fmap.
apply fmap_eqn.
unfold prog_lookup in H.
rewrite H2 in H.
auto.
intros.
spec H0 stk p' n0 t' x.
spec H0; auto.
spec H0.
apply t_trans with (K.squash (n,f)); auto.
apply t_step.
hnf. simpl.
rewrite K.knot_age1. rewrite H2. auto.
spec H0. auto.
hnf; intros.
spec H0 r p'0 H5 H6.
destruct H0 as [n' [? ?]].
exists n'; split; auto.
destruct H7; split.
revert H7; apply safe_approx with n; eauto.
replace n with (level (K.squash (n,f))).
apply later_level.
apply Rt_Rft_trans with p'; auto.
rewrite K.knot_level.
rewrite K.unsquash_squash; auto.
hnf; eauto.
hnf; auto.
constructor; auto.
apply (intro_instr_approx_rel _ _ (i;;instr_nil _)); auto.
apply stack_approx_rel_refl.
intros; spec H8; auto.
revert H8.
apply ev_halts_approx with n.
replace n with (level (K.squash (n,f))).
apply later_level.
apply Rt_Rft_trans with p'; auto.
rewrite K.knot_level.
rewrite K.unsquash_squash; auto.
hnf; eauto.
hnf; auto.
constructor; auto.
apply (intro_instr_approx_rel _ _ (i;;instr_nil _)); auto.
apply stack_approx_rel_refl.
unfold prog in *.
rewrite H1 in H.
discriminate.
Qed.
(* Definition of the hoare relation and rules *)
Definition hoare (t:terminationMeasure) (n':nat) (G R P:pred world) (c:instruction) (Q:pred world) :=
forall t', termMeasure_incr t t' ->
forall p n k stk,
(forall s, G (p,(s,t'))) ->
(forall r', guards n R stk       (p,(r',t'))) ->
(forall r', guards n Q (k::stk)  (p,(r',t'))) ->
(forall r,  guards (n'+n) P ((c ;; k)::stk) (p,(r,t'))).

Lemma hoare_if : forall t x v s1 s2 G R P Q,
P |-- store_op (fun r => match r#v with
| Some (value_label l) => l = L 0
| Some (value_cons _ _) => True
| _ => False
end) ->
hoare t x G R (P && store_op (fun r => r#v = Some (value_label (L 0)))) s1 Q ->
hoare t x G R (P && store_op (fun r => exists x1, exists x2, r#v = Some (value_cons x1 x2))) s2 Q ->
hoare t x G R P (instr_if_nil v s1 s2) Q.