Program Definition just (v:value) : pred world :=
fun w => snd w = v.
Next Obligation.
destruct a; destruct a'; simpl in *.
hnf in H; simpl in H.
rewrite knot_age1 in H.
case_eq (unsquash m); intros; rewrite H1 in H.
destruct n; inv H; auto.
Qed.
Program Definition with_val (v:value) (p:pred world) : pred world :=
fun w => p (fst w,v).
Next Obligation.
apply pred_hereditary with (fst a,v).
unfold age, age1 in *; simpl in *.
rewrite knot_age1 in *.
destruct a; destruct a'; simpl in *.
case_eq (unsquash m); intros; rewrite H1 in H; auto.
destruct n; inv H; auto.
auto.
Qed.
Definition ty_ref (tau: pred world) : pred world :=
EX a:addr, just (v_Loc a) && type_at a tau.
(* Section 5.1, equation 28 *)
Program Definition mtype_valid (m : mem) : pred world :=
fun w =>
match w with (k, v) =>
let (n,phi) := unsquash k in
forall (a : addr),
match phi a with
| None => fst m <= a
| Some tau => fst m > a /\ forces k (deref m a) (%|>tau)
end
end.
Next Obligation.
unfold age, age1 in H.
simpl in H.
rewrite knot_age1 in H.
destruct a; destruct a'.
simpl in *.
case_eq (unsquash m0); intros; rewrite H1 in H.
destruct n; try discriminate.
inv H.
rewrite H1 in H0.
rewrite unsquash_squash; simpl; intros.
spec H0 a.
case_eq (f a); simpl; intros.
rewrite H in H0.
intuition.
unfold fidentity_fmap. red.
rewrite approx_spec. split; auto.
apply lt_le_trans with (level (fst a')).
apply laterR_level in H4. auto.
destruct a'. simpl.
hnf in H0.
destruct H0.  hnf in H0.
rewrite unsquash_squash in H0.
simpl; rewrite knot_level.
case_eq (unsquash m1); intros; rewrite H6 in H0.
destruct H0; subst.
simpl; auto.
eapply pred_nec_hereditary.
apply Rt_Rft; auto.  apply H4.
assert ((%|> p) (m0,deref m a)); auto.
rewrite later_commute in H5.
eapply H5.
hnf; apply t_step.
unfold age, age1; simpl.
rewrite knot_age1.
rewrite H1; auto.
auto.
rewrite H in H0. auto.
Qed.
Definition expr_typeF (tau:pred world) (F: expr -> pred world) (e : expr) : pred world :=
%ALL m:mem, mtype_valid m -->
(ALL m':mem, ALL e':expr, !!(step (m,e) (m',e')) -->
|>(predicates_hered.diamond contractsM (mtype_valid m' && F e'))) &&
(!!(stopped m e) --> EX H:isValue e,
with_val (exp_to_val e H) (%tau)).

(* Specifications: *)
Lemma sub_with_val : forall G P P' e,
G |-- P >=> P' ->
G |-- with_val e P >=> with_val e P'.
Lemma extend_level : forall w1 w2,
R_extends w1 w2 -> level w1 = level w2.
Lemma sub_extend :
forall G P Q,
G |-- P >=> Q  ->
G |-- %P >=> %Q.
Lemma sub_contract :
forall G P Q,
G |-- P >=> Q ->
G |-- predicates_hered.diamond contractsM P >=>
predicates_hered.diamond contractsM Q.
Lemma expr_type_sub1 :
forall tau P Q,
ALL e:expr, |>(P e >=> Q e)
|-- ALL e:expr, expr_typeF tau P e >=> expr_typeF tau Q e.
Lemma expr_type_cont : forall tau, HOcontractive (expr_typeF tau).
Definition expr_type e tau := HORec (expr_typeF tau) e.
Lemma expr_type_eqn : forall tau e,
expr_type e tau =
%ALL m:mem, mtype_valid m -->
(ALL m':mem, ALL e':expr, !!(step (m,e) (m',e')) -->
|>(predicates_hered.diamond contractsM (mtype_valid m' && expr_type e' tau)))
&&
(!!(stopped m e) --> EX H:isValue e, with_val (exp_to_val e H) (%tau)).