Open Scope pred.
(* Various utility lemmas *)
Definition instr_approx_rel (n:nat) (i1 i2:instruction) : Prop :=
fmap_instr (K.approx n) i1 = fmap_instr (K.approx n) i2.
Inductive stack_approx_rel (n:nat) : stack -> stack -> Prop :=
| stack_approx_nil : stack_approx_rel n nil nil
| stack_approx_cons : forall i i' stk stk',
instr_approx_rel n i i' ->
stack_approx_rel n stk stk' ->
stack_approx_rel n (i::stk) (i'::stk').
Program Definition agedfrom {A} `{ageable A} (x:A) : pred A := necR x.
Next Obligation.
unfold hereditary; intros.
apply rt_trans with a; auto.
apply rt_step; auto.
Qed.
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).

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.