Let closedR (w1 w2:world) := fst w1 = fst w2 /\ snd (snd w1) = snd (snd w2).
Program Definition closedM : @modality world _ := exist _ closedR _.
Next Obligation.
split; repeat intro; unfold closedR in *;
destruct x as [? [? ?]]; destruct y as [? [? ?]];
destruct z as [? [? ?]]; simpl in *; intuition subst.
hnf in H; simpl in H.
exists  (p,(s1,t)); simpl; auto.
hnf; simpl.
destruct (@age1 _ K.ageable_knot p0).
inv H. auto. discriminate.
hnf in H0; simpl in H0.
exists (p1,(s,t1)); simpl; auto.
hnf; simpl in *.
destruct (@age1 _ K.ageable_knot p1).
inv H0. auto. discriminate.
Qed.
Definition closed := box closedM.
Inductive setR v x : relation world :=
intro_setR : forall p r r' t,
r' = r#v <- x ->
setR v x (p,(r,t)) (p,(r',t)).
Program Definition setM v x : @modality world _ := setR v x.
Next Obligation.
split; hnf; intros.
inv H0.
hnf in H; simpl in H.
case_eq (age1 p); intros; unfold prog in *;
rewrite H0 in H; try discriminate.
inv H.
exists (p0,(r,t)).
constructor; auto.
hnf. simpl. rewrite H0. auto.
inv H.
destruct z.
hnf in H0; simpl in H0.
case_eq (age1 p0); unfold prog in *; intros;
rewrite H in H0.
inv H0.
exists (p0,(r#v <- x,t)).
hnf. simpl. rewrite H. auto.
constructor; auto.
discriminate.
Qed.
Program Definition world_op (Pp : pred prog) (Pr : store -> Prop) (Pt: terminationMeasure -> Prop) : pred world :=
fun prt =>
match prt with (p,(r,t)) =>
Pp p /\ Pr r /\ Pt 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.
rewrite K.knot_age1 in H.
case_eq (K.unsquash p); intros; rewrite H1 in H.
destruct n; try discriminate.
inv H.
intuition.
destruct Pp as [Pp HPp].
simpl.
simpl in H.
eapply HPp.
2: apply H.
hnf.
rewrite K.knot_age1.
rewrite H1; auto.
Qed.
Definition store_op (Pr : store -> Prop) :=
world_op TT Pr (fun _ => True).

(* Specifications: *)
Lemma worldNec_unfold : forall p r t p' r' t',
@necR world _ (p,(r,t)) (p',(r',t')) <->
necR p p' /\ r = r' /\ t = t'.
Lemma worldLater_unfold : forall p r t p' r' t',
@laterR world _ (p,(r,t)) (p',(r',t')) <->
laterR p p' /\ r = r' /\ t = t'.
Lemma collapse_instr_approx : forall n m i,
fmap_instr (K.approx n) (fmap_instr (K.approx m) i) =
fmap_instr (K.approx (min n m)) i.
Lemma collapse_instr_approx_same : forall n  i,
fmap_instr (K.approx n) (fmap_instr (K.approx n) i) =
fmap_instr (K.approx n) i.
Lemma nec_prog_lookup : forall p p' l i,
necR p p' ->
prog_lookup p l = Some i ->
prog_lookup p' l = Some (fmap_instr (K.approx (level p')) i).
Lemma termMeasure_incr_trans : forall t1 t2 t3,
termMeasure_incr t1 t2 ->
termMeasure_incr t2 t3 ->
termMeasure_incr t1 t3.