(* * Copyright (c) 2009 Robert Dockins and Aquinas Hobor. * *)
(* Coq development: using indirection theory to model types in l-calculus *)
(* lam_ref_type_defs.v: the definition of the type system; this is the main event. *)
Require Export lam_ref_type_prelim.
Open Scope pred.
(* From introduction; this is the judgment psi |- v : tau *)
Definition forces (psi : mtype) (v : value) (tau : pred world) :=
tau (psi, v).
(* Section 4.1, equation 17 *)
Program Definition ty_nat : pred world :=
fun w => match w with (k, v) =>
exists n, v = v_Nat n
end.
Next Obligation.
destruct a; destruct a'.
replace v0 with v; auto.
assert (necR (m,v) (m0,v0)).
apply rt_step; auto.
rewrite value_knot_necR in H1.
intuition.
Qed.
Program Definition type_at (l:addr) (tau:pred world) : pred world :=
fun w:world =>
let (n,psi) := unsquash (fst w) in
match psi l with
| None => False
| Some p => approx_eq n p tau
end.
Next Obligation.
unfold age, age1 in H.
destruct a; destruct a'.
simpl in *.
rewrite knot_age1 in H.
case_eq (unsquash m); intros; rewrite H1 in H, H0.
destruct n; try discriminate.
inv H.
rewrite unsquash_squash.
simpl.
case_eq (f l); simpl; intros; rewrite H in H0.
unfold approx_eq in *.
unfold fidentity_fmap.
change (approx n (approx n p)) with
((approx n oo approx n) p).
rewrite <- (approx_approx1 0).
rewrite (approx_approx1 1).
unfold compose; simpl.
rewrite H0; auto.
auto.
Qed.

Lemma type_at_extends : forall l tau,
%(type_at l tau) = type_at l tau.