Open Scope pred.
(* Various utility lemmas *)
Fixpoint ageN (n : nat) (p1 p2 : prog) : Prop :=
match n with
| 0 => p1 = p2
| S n' => exists p', age p1 p' /\ ageN n' p' p2
end.
Implicit Arguments ageN_det.
Let closedR (w1 w2:world) := fst w1 = fst 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); simpl; auto.
hnf; simpl.
destruct (@age1 _ K.ageable_knot p0).
inv H. auto. discriminate.
hnf in H0; simpl in H0.
exists (p1,s); 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',
r' = r#v <- x ->
setR v x (p,r) (p,r').
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).
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)).
hnf. simpl. rewrite H. auto.
constructor; auto.
discriminate.
Qed.
Program Definition world_op (Pp : pred prog) (Pr : store -> Prop) : pred world :=
fun pr => let (p,r) := pr in Pp p /\ Pr r.
Next Obligation.
unfold hereditary; intros.
destruct a as [p r].
destruct a' as [p' r'].
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.
Definition prog_op (X:pred prog) :=  world_op X (fun _ => True).
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').

Lemma stepstar_approxprog: forall n p1 p2 p1' p2' r1 s1 s1' r2 s2,
stepstar p1 p2 r1 s1 r2 s2 ->
ageN n p1 p1' ->
ageN n p2 p2' ->
stack_approx_rel (S (level p1')) s1 s1' ->
exists s2',
stepstar p1' p2' r1 s1' r2 s2' /\
stack_approx_rel (S (level p2')) s2 s2'.