From 8ab960b4574d8ab27fa92fc95cc034a8e122de78 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 23 Oct 2025 11:58:03 +0200 Subject: [PATCH 01/61] splitting vis nodes into two transitions: wip on the transition theory --- theories/Eq/Trans.v | 833 ++++++++++++++++++++++++++++---------------- 1 file changed, 525 insertions(+), 308 deletions(-) diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 910860e..f2757db 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -73,13 +73,29 @@ Section Trans. Context {E B : Type -> Type} {R : Type}. - Notation S' := (ctree' E B R). - Notation S := (ctree E B R). - + Variant S := | Active (t : ctree E B R) | Passive {X} (e : E X) (k : X -> ctree E B R). + (* Notation S' := (ctree' E B R). *) + (* Notation S := (ctree E B R). *) + Variant Seq : S -> S -> Prop := + | ActAct t u (EQ: equ eq t u) : Seq (Active t) (Active u) + | PasPas {X} e (k g : X -> _) (EQ: pointwise_relation _ (equ eq) k g) : Seq (Passive e k) (Passive e g) + . + Hint Constructors Seq : core. + #[global] Instance Seq_equiv : Equivalence Seq. + Proof. + constructor. + - intros []; auto. + - intros ? ? []; constructor; intros; now symmetry. + - intros ? ? ? EQ1 EQ2. + inv EQ1. + inv EQ2; constructor; intros; etransitivity; eauto. + dependent induction EQ2; constructor; intros; etransitivity; eauto. + Qed. + Definition SS : EqType := - {| type_of := S ; Eq := equ eq |}. + {| type_of := S ; Eq := Seq |}. - (*| +(*| The domain of labels of the LTS. Note that it could be typed more strongly: [val] labels can only be of type [R]. However typing it statically makes lemmas about @@ -88,7 +104,8 @@ least annoying solution. |*) Variant label : Type := | τ - | obs {X : Type} (e : E X) (v : X) + | ask {X : Type} (e : E X) + | rcv {X : Type} (e : E X) (v : X) (* Note: I think we need to remember which request led to the response for the bisimilarity to be right, but I am not 100% sure, [e] might be spurious *) | val {X : Type} (v : X). Variant is_val : label -> Prop := @@ -99,7 +116,12 @@ least annoying solution. intro H. inversion H. Qed. - Lemma is_val_obs {X} (e : E X) x : ~ is_val (obs e x). + Lemma is_val_ask {X} (e : E X) : ~ is_val (ask e). + Proof. + intro H. inversion H. + Qed. + + Lemma is_val_rcv {X} (e : E X) (x : X) : ~ is_val (rcv e x). Proof. intro H. inversion H. Qed. @@ -113,132 +135,211 @@ It can either: - stop at a sink (implemented as a [Stuck] node) by stepping from a [ret v] node, labelling the transition by the returned value. |*) - Inductive trans_ : label -> hrel S' S' := + Inductive transR : label -> hrel S S := - | Transbr {X} (c : B X) x k l t : - trans_ l (observe (k x)) t -> - trans_ l (BrF c k) t + | Transbr {X} (c : B X) x k l t t' u : + t ≅ Br c k -> + t' ≅ k x -> + transR l (Active t') u -> + transR l (Active t) u - | Transguard t t' l : - trans_ l (observe t) t' -> - trans_ l (GuardF t) t' + | Transguard t t' u l : + t ≅ Guard t' -> + transR l (Active t') u -> + transR l (Active t) u - | Transtau t u : - u ≅ t -> - trans_ τ (StepF t) (observe u) + | Transstep t t' u : + t ≅ Step t' -> + u ≅ t' -> + transR τ (Active t) (Active u) - | Transobs {X} (e : E X) k x t : - k x ≅ t -> - trans_ (obs e x) (VisF e k) (observe t) - - | Transval r : - trans_ (val r) (RetF r) StuckF. - Hint Constructors trans_ : core. - - Definition transR l : hrel S S := - fun u v => trans_ l (observe u) (observe v). - - Ltac FtoObs := - match goal with - |- trans_ _ _ ?t => - change t with (observe {| _observe := t |}) - end. - - #[local] Instance trans_equ_aux1 l t : - Proper (going (equ eq) ==> flip impl) (trans_ l t). - Proof. - intros u u' equ; intros TR. - inv equ; rename H into equ. - step in equ. - revert u equ. - dependent induction TR; intros; subst; eauto. - + inv equ. - * rewrite H2; eauto. - * FtoObs. - constructor. - rewrite <- H. - apply observing_sub_equ; eauto. - * FtoObs. - constructor. - rewrite <- H, REL. - apply observing_sub_equ; eauto. - * FtoObs. - constructor. - rewrite <- H, REL. - apply observing_sub_equ; eauto. - * FtoObs. - constructor. - rewrite <- H. - step; rewrite <- H2; constructor; intros. - auto. - * FtoObs. - constructor. - rewrite <- H. - step; rewrite <- H2; constructor; intros. - auto. - + FtoObs. - econstructor. - rewrite H; symmetry; step; auto. - + inv equ. eauto. - Qed. - - #[local] Instance trans_equ_aux2 l : - Proper (going (equ eq) ==> going (equ eq) ==> impl) (trans_ l). - Proof. - intros t t' eqt u u' equ TR. - rewrite <- equ; clear u' equ. - inv eqt; rename H into eqt. - revert t' eqt. - dependent induction TR; intros; auto. - + step in eqt; dependent induction eqt. - econstructor. - apply IHTR. - rewrite REL; reflexivity. - + step in eqt; dependent induction eqt. - econstructor. - apply IHTR. rewrite REL; reflexivity. - + step in eqt; dependent induction eqt. - econstructor. rewrite H,REL; auto. - + step in eqt; dependent induction eqt. - econstructor. - rewrite <- REL; eauto. - + step in eqt; dependent induction eqt. - econstructor. - Qed. - - #[global] Instance trans_equ_ l : - Proper (going (equ eq) ==> going (equ eq) ==> iff) (trans_ l). - Proof. - intros ? ? eqt ? ? equ; split; intros TR. - - eapply trans_equ_aux2; eauto. - - symmetry in equ; symmetry in eqt; eapply trans_equ_aux2; eauto. - Qed. + | Transask {X} (e : E X) t k : + t ≅ Vis e k -> + transR (ask e) (Active t) (Passive e k) + | Transrcv {X} (e : E X) (x : X) k t : + k x ≅ t -> + transR (rcv e x) (Passive e k) (Active t) + + | Transval r t u : + t ≅ Ret r -> + u ≅ Stuck -> + transR (val r) (Active t) (Active u). + Hint Constructors transR : core. + + (* Definition transR l : hrel S S := *) + (* fun u v => trans_ l (observe u) (observe v). *) + + (* Ltac FtoObs := *) + (* match goal with *) + (* |- trans_ _ _ ?t => *) + (* change t with (observe {| _observe := t |}) *) + (* end. *) + + (* #[local] Instance trans_equ_aux1 l t : *) + (* Proper (going (equ eq) ==> flip impl) (trans_ l t). *) + (* Proof. *) + (* intros u u' equ; intros TR. *) + (* inv equ; rename H into equ. *) + (* step in equ. *) + (* revert u equ. *) + (* dependent induction TR; intros; subst; eauto. *) + (* + inv equ. *) + (* * rewrite H2; eauto. *) + (* * FtoObs. *) + (* constructor. *) + (* rewrite <- H. *) + (* apply observing_sub_equ; eauto. *) + (* * FtoObs. *) + (* constructor. *) + (* rewrite <- H, REL. *) + (* apply observing_sub_equ; eauto. *) + (* * FtoObs. *) + (* constructor. *) + (* rewrite <- H, REL. *) + (* apply observing_sub_equ; eauto. *) + (* * FtoObs. *) + (* constructor. *) + (* rewrite <- H. *) + (* step; rewrite <- H2; constructor; intros. *) + (* auto. *) + (* * FtoObs. *) + (* constructor. *) + (* rewrite <- H. *) + (* step; rewrite <- H2; constructor; intros. *) + (* auto. *) + (* + FtoObs. *) + (* econstructor. *) + (* rewrite H; symmetry; step; auto. *) + (* + inv equ. eauto. *) + (* Qed. *) + + (* #[local] Instance trans_equ_aux2 l : *) + (* Proper (going (equ eq) ==> going (equ eq) ==> impl) (trans_ l). *) + (* Proof. *) + (* intros t t' eqt u u' equ TR. *) + (* rewrite <- equ; clear u' equ. *) + (* inv eqt; rename H into eqt. *) + (* revert t' eqt. *) + (* dependent induction TR; intros; auto. *) + (* + step in eqt; dependent induction eqt. *) + (* econstructor. *) + (* apply IHTR. *) + (* rewrite REL; reflexivity. *) + (* + step in eqt; dependent induction eqt. *) + (* econstructor. *) + (* apply IHTR. rewrite REL; reflexivity. *) + (* + step in eqt; dependent induction eqt. *) + (* econstructor. rewrite H,REL; auto. *) + (* + step in eqt; dependent induction eqt. *) + (* econstructor. *) + (* rewrite <- REL; eauto. *) + (* + step in eqt; dependent induction eqt. *) + (* econstructor. *) + (* Qed. *) + + (* #[global] Instance trans_equ_ l : *) + (* Proper (going (equ eq) ==> going (equ eq) ==> iff) (trans_ l). *) + (* Proof. *) + (* intros ? ? eqt ? ? equ; split; intros TR. *) + (* - eapply trans_equ_aux2; eauto. *) + (* - symmetry in equ; symmetry in eqt; eapply trans_equ_aux2; eauto. *) + (* Qed. *) + + #[global] Instance equ_Seq_active : Proper (equ eq ==> Seq) Active. + Proof. + now intros ?? EQ; constructor. + Qed. + + #[global] Instance equ_Seq_passive {X} (e : E X) : Proper (pointwise_relation X (equ eq) ==> Seq) (Passive e). + Proof. + now intros ?? EQ; constructor. + Qed. + + #[global] Instance transR_equ_ l : + Proper (Seq ==> Seq ==> iff) (transR l). + Proof. + intros ?? EQ1 ?? EQ2; split; intros TR. + - revert y y0 EQ1 EQ2; dependent induction TR; intros y y0 EQ1 EQ2. + + inv EQ1. + econstructor 1. + rewrite <- EQ, H; reflexivity. + apply H0. + apply IHTR; auto. + + inv EQ1. + econstructor 2. + rewrite <- EQ, H; reflexivity. + apply IHTR; auto. + + inv EQ1; inv EQ2. + econstructor 3. + rewrite <- EQ , H; reflexivity. + rewrite <- EQ0, H0; reflexivity. + + inv EQ1. dependent induction EQ2. + econstructor 4. + rewrite <- EQ0,H. + step; constructor. + apply EQ. + + dependent induction EQ1; inv EQ2. + econstructor 5. + specialize (EQ x); rewrite <- EQ, H; auto. + + inv EQ1; inv EQ2. + econstructor 6. + rewrite <- EQ, H; reflexivity. + rewrite <- EQ0, H0; reflexivity. + - revert x x0 EQ1 EQ2; dependent induction TR; intros y y0 EQ1 EQ2. + + inv EQ1. + econstructor 1. + rewrite EQ, H; reflexivity. + apply H0. + apply IHTR; auto. + + inv EQ1. + econstructor 2. + rewrite EQ, H; reflexivity. + apply IHTR; auto. + + inv EQ1; inv EQ2. + econstructor 3. + rewrite EQ , H; reflexivity. + rewrite EQ0, H0; reflexivity. + + inv EQ1. dependent induction EQ2. + econstructor 4. + rewrite EQ0,H. + step; constructor. + intros ?; symmetry; apply EQ. + + dependent induction EQ1; inv EQ2. + econstructor 5. + specialize (EQ x); rewrite EQ, H, EQ0; auto. + + inv EQ1; inv EQ2. + econstructor 6. + rewrite EQ, H; reflexivity. + rewrite EQ0, H0; reflexivity. + Qed. + (*| -[equ] is congruent for [trans], we can hence build a [srel] and build our +[equ] is congruent for [transR], we can hence build a [srel] and build our relations in this model to still exploit the automation from the [RelationAlgebra] library. |*) - #[global] Instance trans_equ l : - Proper (equ eq ==> equ eq ==> iff) (transR l). + #[global] Instance transR_equ l : + Proper (Seq ==> Seq ==> iff) (transR l). Proof. - intros ? ? eqt ? ? equ; unfold transR. - rewrite eqt, equ; reflexivity. + intros ? ? eqt ? ? equ. + inv eqt; inv equ. + all: now rewrite EQ, EQ0. Qed. Definition trans l : srel SS SS := {| hrel_of := transR l : hrel SS SS |}. - Lemma trans__trans : forall l t u, - trans_ l (observe t) (observe u) = trans l t u. - Proof. - reflexivity. - Qed. + (* Lemma trans__trans : forall l t u, *) + (* trans_ l (observe t) (observe u) = trans l t u. *) + (* Proof. *) + (* reflexivity. *) + (* Qed. *) - Lemma transR_trans : forall l (t t' : S), - transR l t t' = trans l t t'. - Proof. - reflexivity. - Qed. + (* Lemma transR_trans : forall l (t t' : S), *) + (* transR l t t' = trans l t t'. *) + (* Proof. *) + (* reflexivity. *) + (* Qed. *) (*| Extension of [trans] with its reflexive closure, labelled by [τ]. @@ -372,33 +473,38 @@ Elimination rules for [trans] eexists; apply wtrans_τ; eassumption. Qed. - End Trans. -Class Respects_val {E F} (L : rel (@label E) (@label F)) := - { respects_val: - forall l l', - L l l' -> - is_val l <-> is_val l' }. +#[global] Hint Constructors Seq : core. +#[global] Hint Constructors transR : core. + +(* Class Respects_val {E F} (L : rel (@label E) (@label F)) := *) +(* { respects_val: *) +(* forall l l', *) +(* L l l' -> *) +(* is_val l <-> is_val l' }. *) -Class Respects_τ {E F} (L : rel (@label E) (@label F)) := - { respects_τ: forall l l', - L l l' -> - l = τ <-> l' = τ }. +(* Class Respects_τ {E F} (L : rel (@label E) (@label F)) := *) +(* { respects_τ: forall l l', *) +(* L l l' -> *) +(* l = τ <-> l' = τ }. *) -Definition eq_obs {E} (L : relation (@label E)) : Prop := - forall X X' e e' (x : X) (x' : X'), - L (obs e x) (obs e' x') -> - obs e x = obs e' x'. +(* Definition eq_obs {E} (L : relation (@label E)) : Prop := *) +(* forall X X' e e' (x : X) (x' : X'), *) +(* L (obs e x) (obs e' x') -> *) +(* obs e x = obs e' x'. *) -#[global] Instance Respects_val_eq A: @Respects_val A A eq. -split; intros; subst; reflexivity. -Defined. +(* #[global] Instance Respects_val_eq A: @Respects_val A A eq. *) +(* split; intros; subst; reflexivity. *) +(* Defined. *) -#[global] Instance Respects_τ_eq A: @Respects_τ A A eq. -split; intros; subst; reflexivity. -Defined. +(* #[global] Instance Respects_τ_eq A: @Respects_τ A A eq. *) +(* split; intros; subst; reflexivity. *) +(* Defined. *) +Coercion Active : ctree >-> S. +Notation "'α' t" := (Active t) (at level 100). +Notation "'β' e" := (Passive e) (at level 0). (*| Backward reasoning for [trans] ------------------------------ @@ -412,59 +518,64 @@ Section backward. (*| Structural rules + +We essentially lift the constructors to the [trans] bundling, and +eliminate on the way the noise from closing up everything to [equ eq]. |*) Lemma trans_ret : forall (x : X), trans (E := E) (B := B) (val x) (Ret x) Stuck. Proof. - intros; constructor. + intros; constructor; auto. Qed. - Lemma trans_vis : forall {Y} (e : E Y) x (k : Y -> ctree E B X), - trans (obs e x) (Vis e k) (k x). + Lemma trans_ask : forall {Y} (e : E Y) (k : Y -> ctree E B X), + trans (ask e) (Vis e k) (β e k). Proof. intros; constructor; auto. Qed. - Lemma trans_br : forall {Y} l (t t' : ctree E B X) (c : B Y) k x, - trans l t t' -> - k x ≅ t -> - trans l (Br c k) t'. + Lemma trans_rcv : forall {Y} (e : E Y) (k : Y -> ctree E B X) y, + trans (rcv e y) (β e k) (k y). Proof. - intros * TR Eq. - apply Transbr with x. - rewrite Eq; auto. + intros; constructor; auto. Qed. - Lemma trans_brS : forall {Y} (c : B Y) (k : _ -> ctree E B X) x, - trans τ (BrS c k) (k x). + Lemma trans_br : forall {Y} l (c : B Y) (k : Y -> ctree E B X) u y, + trans l (k y) u -> + trans l (Br c k) u. Proof. - intros. - apply Transbr with x, Transtau. - reflexivity. + intros * TR. + eapply Transbr; [reflexivity| reflexivity |]. + apply TR. Qed. -(*| -Ad-hoc rules for pre-defined finite branching -|*) - - Variable (l : @label E) (t t' : ctree E B X). + Lemma trans_step : forall (t : ctree E B X), + trans τ (Step t) t. + Proof. + intros. + eapply Transstep; reflexivity. + Qed. - Lemma trans_step : - trans τ (Step t) t. + Lemma trans_guard : forall l (t : ctree E B X) u, + trans l t u -> + trans l (Guard t) u. Proof. - now econstructor. + intros * TR. + eapply Transguard; [reflexivity | auto]. Qed. - Lemma trans_guard : - trans l t t' -> - trans l (Guard t) t'. + Lemma trans_brS : forall {Y} (c : B Y) (k : _ -> ctree E B X) x, + trans τ (BrS c k) (k x). Proof. - now econstructor. + intros. + apply trans_br with x, trans_step. Qed. End backward. +#[global] Hint Resolve trans_br trans_guard trans_brS trans_step trans_ask trans_rcv trans_ret : core. + Section BackwardBounded. Context {E B : Type -> Type} {X : Type}. @@ -477,61 +588,48 @@ Section BackwardBounded. trans τ (brS2 t u) t. Proof. intros. - unfold brS2. - apply Transbr with true. - now constructor. + apply trans_br with true, trans_step. Qed. Lemma trans_brS22 : trans τ (brS2 t u) u. Proof. intros. - unfold brS2. - apply Transbr with false. - now constructor. + apply trans_br with false, trans_step. Qed. - Lemma trans_br21 : - trans l t t' -> - trans l (br2 t u) t'. + Lemma trans_br21 x : + trans l t x -> + trans l (br2 t u) x. Proof. intros * TR. - eapply trans_br with (x := true); eauto. + now apply trans_br with true. Qed. - Lemma trans_br22 : - trans l u u' -> - trans l (br2 t u) u'. + Lemma trans_br22 x : + trans l u x -> + trans l (br2 t u) x. Proof. intros * TR. - eapply trans_br with (x := false); eauto. + now apply trans_br with false. Qed. Lemma trans_brS31 : trans τ (brS3 t u v) t. Proof. - intros. - unfold brS3. - apply Transbr with t31. - now constructor. + now apply trans_br with t31. Qed. Lemma trans_brS32 : trans τ (brS3 t u v) u. Proof. - intros. - unfold brS3. - apply Transbr with t32. - now constructor. + now apply trans_br with t32. Qed. Lemma trans_brS33 : trans τ (brS3 t u v) v. Proof. - intros. - unfold brS3. - apply Transbr with t33. - now constructor. + now apply trans_br with t33. Qed. Lemma trans_br31 : @@ -539,7 +637,7 @@ Section BackwardBounded. trans l (br3 t u v) t'. Proof. intros * TR. - eapply trans_br with (x := t31); eauto. + now apply trans_br with t31. Qed. Lemma trans_br32 : @@ -547,7 +645,7 @@ Section BackwardBounded. trans l (br3 t u v) u'. Proof. intros * TR. - eapply trans_br with (x := t32); eauto. + now apply trans_br with t32. Qed. Lemma trans_br33 : @@ -555,43 +653,31 @@ Section BackwardBounded. trans l (br3 t u v) v'. Proof. intros * TR. - eapply trans_br with (x := t33); eauto. + now apply trans_br with t33. Qed. Lemma trans_brS41 : trans τ (brS4 t u v w) t. Proof. - intros. - unfold brS4. - apply Transbr with t41. - now constructor. + eapply trans_br with t41; eauto. Qed. Lemma trans_brS42 : trans τ (brS4 t u v w) u. Proof. - intros. - unfold brS4. - apply Transbr with t42. - now constructor. + eapply trans_br with t42; eauto. Qed. Lemma trans_brS43 : trans τ (brS4 t u v w) v. Proof. - intros. - unfold brS4. - apply Transbr with t43. - now constructor. + eapply trans_br with t43; eauto. Qed. Lemma trans_brS44 : trans τ (brS4 t u v w) w. Proof. - intros. - unfold brS4. - apply Transbr with t44. - now constructor. + eapply trans_br with t44; eauto. Qed. Lemma trans_br41 : @@ -599,7 +685,7 @@ Section BackwardBounded. trans l (br4 t u v w) t'. Proof. intros * TR. - eapply trans_br with (x := t41); eauto. + eapply trans_br with t41; eauto. Qed. Lemma trans_br42 : @@ -607,7 +693,7 @@ Section BackwardBounded. trans l (br4 t u v w) u'. Proof. intros * TR. - eapply trans_br with (x := t42); eauto. + eapply trans_br with t42; eauto. Qed. Lemma trans_br43 : @@ -615,7 +701,7 @@ Section BackwardBounded. trans l (br4 t u v w) v'. Proof. intros * TR. - eapply trans_br with (x := t43); eauto. + eapply trans_br with t43; eauto. Qed. Lemma trans_br44 : @@ -623,7 +709,7 @@ Section BackwardBounded. trans l (br4 t u v w) w'. Proof. intros * TR. - eapply trans_br with (x := t44); eauto. + eapply trans_br with t44; eauto. Qed. End BackwardBounded. @@ -651,52 +737,91 @@ Inverting equalities between labels now dependent induction EQ. Qed. - Lemma obs_eq_invT : forall X Y e1 e2 v1 v2, @obs E X e1 v1 = @obs E Y e2 v2 -> X = Y. - clear B. intros * EQ. - now dependent induction EQ. - Qed. + (* Lemma obs_eq_invT : forall X Y e1 e2 v1 v2, @obs E X e1 v1 = @obs E Y e2 v2 -> X = Y. *) + (* clear B. intros * EQ. *) + (* now dependent induction EQ. *) + (* Qed. *) - Lemma obs_eq_inv : forall X e1 e2 v1 v2, @obs E X e1 v1 = @obs E X e2 v2 -> e1 = e2 /\ v1 = v2. - clear B. intros * EQ. - now dependent induction EQ. - Qed. + (* Lemma obs_eq_inv : forall X e1 e2 v1 v2, @obs E X e1 v1 = @obs E X e2 v2 -> e1 = e2 /\ v1 = v2. *) + (* clear B. intros * EQ. *) + (* now dependent induction EQ. *) + (* Qed. *) (*| Structural rules |*) - Lemma trans_ret_inv : forall x l (t : ctree E B X), - trans l (Ret x) t -> - t ≅ Stuck /\ l = val x. + (* In the primed versions, [u] is left as an arbitrary S. + In the main version, we can only invert if we already know + that the resulting state is an active one. + (it is of course always one) + *) + Lemma trans_ret_inv' : forall x l u, + trans l (Ret x : ctree E B X) u -> + Seq u (α Stuck) /\ l = val x. Proof. - intros * TR; inv TR; intuition. - rewrite ctree_eta, <- H2; auto. + intros * TR; inv TR; inv_equ. + intuition. + Qed. + + Lemma trans_ret_inv : forall x l (u : ctree E B X), + trans l (Ret x) u -> + u ≅ Stuck /\ l = val x. + Proof. + intros * TR; inv TR; inv_equ. + intuition. Qed. - Lemma trans_vis_inv : forall {Y} (e : E Y) k l (u : ctree E B X), + Lemma trans_ask_inv' : forall {Y} (e : E Y) (k : _ -> ctree E B X) l u, trans l (Vis e k) u -> - exists x, u ≅ k x /\ l = obs e x. + Seq u (β e k) /\ l = ask e. Proof. intros * TR. - inv TR. - dependent induction H3; eexists; split; eauto. - rewrite ctree_eta, <- H4, <- ctree_eta; symmetry; auto. + inv TR; inv_equ. + split; auto. + constructor; intros ?; symmetry; eauto. Qed. - Lemma trans_br_inv : forall {Y} l (c : B Y) k (u : ctree E B X), + Lemma trans_ask_inv : forall {Y} (e : E Y) k l (u : ctree E B X), + trans l (Vis e k) u -> + Seq u (β e k) /\ l = ask e. + Proof. + intros * TR. + inv TR; inv_equ. + Qed. + + Lemma trans_rcv_inv' : forall {Y} (e : E Y) (k : Y -> ctree E B X) l u, + trans l (β e k) u -> + exists x, Seq u (α k x) /\ l = rcv e x. + Proof. + intros * TR. + cbn in TR; dependent induction TR. + eexists; split; eauto. + constructor; symmetry; eauto. + Qed. + + Lemma trans_rcv_inv : forall {Y} (e : E Y) (k : Y -> ctree E B X) l (u : ctree E B X), + trans l (β e k) u -> + exists x, u ≅ (k x) /\ l = rcv e x. + Proof. + intros * TR. + apply trans_rcv_inv' in TR as (? & ? & ?). + inv H; eauto. + Qed. + + Lemma trans_br_inv : forall {Y} l (c : B Y) (k : _ -> ctree E B X) u, trans l (Br c k) u -> exists n, trans l (k n) u. Proof. intros * TR. cbn in *. - unfold transR in *. - cbn in TR |- *. match goal with - | h: trans_ _ ?x ?y |- _ => + | h: transR _ ?x ?y |- _ => remember x as ox; remember y as oy end. revert c k u Heqox Heqoy. - induction TR; intros; inv Heqox; eauto. + inv TR; intros; subst; inv Heqox; inv_equ. + exists x; now rewrite H0, <- (EQ x) in H1. Qed. Lemma trans_guard_inv : forall l (t : ctree E B X) u, @@ -704,16 +829,36 @@ Structural rules trans l t u. Proof. intros * TR. - now inv TR. + inv TR; inv_equ. + now rewrite H0. Qed. - Lemma trans_step_inv : forall l (t : ctree E B X) u, + Lemma trans_step_inv' : forall l (t : ctree E B X) u, + trans l (Step t) u -> + Seq u t /\ l = τ. + Proof. + intros * TR. + inv TR; inv_equ; split; auto. + now rewrite H0,H2. + Qed. + + Lemma trans_step_inv : forall l (t u : ctree E B X), trans l (Step t) u -> u ≅ t /\ l = τ. Proof. intros * TR. - inv TR; split; auto. - rewrite <- H2. apply observe_equ_eq; auto. + apply trans_step_inv' in TR as [? ?]; split; auto. + now inv H. + Qed. + + Lemma trans_brS_inv' : forall {Y} l (c : B Y) (k : _ -> ctree E B X) u, + trans l (BrS c k) u -> + exists n, Seq u (α (k n)) /\ l = τ. + Proof. + intros * TR. + eapply trans_br_inv in TR as [n ?]. + apply trans_step_inv' in H as [? ?]. + eauto. Qed. Lemma trans_brS_inv : forall {Y} l (c : B Y) k (u : ctree E B X), @@ -721,18 +866,15 @@ Structural rules exists n, u ≅ k n /\ l = τ. Proof. intros * TR. - apply trans_br_inv in TR as [n ?]. - inv H. - exists n; split; auto. - rewrite <- H3. apply observe_equ_eq; auto. + apply trans_brS_inv' in TR as (? & H & ?); inv H; eauto. Qed. - Lemma trans_stuck_inv : forall l (u : ctree E B X), - trans l Stuck u -> + Lemma trans_stuck_inv : forall l u, + trans l (Stuck : ctree E B X) u -> False. Proof. intros * TR. - inv TR. + cbn in TR; dependent induction TR; inv_equ. Qed. (*| @@ -798,14 +940,16 @@ I'll skip them for now and introduce them if they turn out to be useful. |*) - Lemma trans__val_inv {Y} : - forall (T U : ctree' E B X) (x : Y), - trans_ (val x) T U -> - go U ≅ Stuck. + Lemma trans_val_inv' {Y} : + forall t u (x : Y), + trans (val x) t u -> + Seq u (α (Stuck : ctree E B X)). Proof. intros * TR. remember (val x) as ox. - rewrite ctree_eta; induction TR; intros; auto; try now inv Heqox. + revert x Heqox. + cbn in TR; induction TR; intros ? Heqox; try now inv Heqox. + all: eauto. Qed. Lemma trans_val_inv {Y} : @@ -813,8 +957,7 @@ useful. trans (val x) t u -> u ≅ Stuck. Proof. - intros * TR. cbn in TR. red in TR. - apply trans__val_inv in TR. rewrite ctree_eta. apply TR. + now intros * TR; apply trans_val_inv' in TR; inv TR. Qed. Lemma wtrans_val_inv : forall (x : X), @@ -825,7 +968,7 @@ useful. destruct TR as [t2 [t1 step1 step2] step3]. exists t1; split. apply wtrans_τ; auto. - erewrite <- trans_val_inv; eauto. + erewrite <- trans_val_inv'; eauto. Qed. End forward. @@ -835,11 +978,31 @@ End forward. --------------- |*) +Lemma etrans_case' {E B X} : forall l t u, + etrans l t u -> + (trans l t u \/ (l = τ /\ @Seq E B X t u)). +Proof. + intros [] * TR; cbn in *; intuition. +Qed. + Lemma etrans_case {E B X} : forall l (t u : ctree E B X), etrans l t u -> (trans l t u \/ (l = τ /\ t ≅ u)). Proof. intros [] * TR; cbn in *; intuition. + inv H; intuition. +Qed. + +Lemma etrans_ret_inv' {E B X} : forall x l t, + etrans l (Ret x) t -> + (l = τ /\ @Seq E B X t (α Ret x)) \/ (l = val x /\ Seq t (α Stuck)). +Proof. + intros ? [] ? step; cbn in step. + - intuition; try (eapply trans_ret in step; now apply step). + apply trans_ret_inv' in H; intuition. + - eapply trans_ret_inv' in step; intuition. + - eapply trans_ret_inv' in step; intuition. + - eapply trans_ret_inv' in step; intuition. Qed. Lemma etrans_ret_inv {E B X} : forall x l (t : ctree E B X), @@ -848,7 +1011,9 @@ Lemma etrans_ret_inv {E B X} : forall x l (t : ctree E B X), Proof. intros ? [] ? step; cbn in step. - intuition; try (eapply trans_ret in step; now apply step). - inv H. + apply trans_ret_inv in H; intuition. + inv H; intuition. + - eapply trans_ret_inv in step; intuition. - eapply trans_ret_inv in step; intuition. - eapply trans_ret_inv in step; intuition. Qed. @@ -876,6 +1041,16 @@ Section stuck. rewrite EQ in ABS; eapply ST; eauto. Qed. + Lemma etrans_is_stuck_inv' (v : ctree E B X) v' : + is_stuck v -> + etrans l v v' -> + l = τ /\ Seq v v'. + Proof. + intros * ST TR. + edestruct @etrans_case'; eauto. + apply ST in H; tauto. + Qed. + Lemma etrans_is_stuck_inv (v v' : ctree E B X) : is_stuck v -> etrans l v v' -> @@ -886,16 +1061,27 @@ Section stuck. apply ST in H; tauto. Qed. - Lemma transs_is_stuck_inv (v v' : ctree E B X) : + Lemma transs_is_stuck_inv' (v : ctree E B X) v' : is_stuck v -> (trans τ)^* v v' -> - v ≅ v'. + Seq v v'. Proof. intros * ST TR. - destruct TR as [[] TR]; intuition. + destruct TR as [[] TR]. + inv TR; eauto. destruct TR. apply ST in H; tauto. Qed. + + Lemma transs_is_stuck_inv (v v' : ctree E B X) : + is_stuck v -> + (trans τ)^* v v' -> + v ≅ v'. + Proof. + intros * ST TR. + eapply transs_is_stuck_inv' in TR; eauto. + now inv TR. + Qed. Lemma wtrans_is_stuck_inv : is_stuck t -> @@ -904,11 +1090,13 @@ Section stuck. Proof. intros * ST TR. destruct TR as [? [? ?] ?]. - apply transs_is_stuck_inv in H; auto. - rewrite H in ST; apply etrans_is_stuck_inv in H0 as [-> ?]; auto. - rewrite H0 in ST; apply transs_is_stuck_inv in H1; auto. + apply transs_is_stuck_inv' in H; auto. + inv H. + rewrite EQ in ST; apply etrans_is_stuck_inv' in H0 as [-> ?]; auto. + inv H. + rewrite EQ0 in ST; apply transs_is_stuck_inv in H1; auto. intuition. - rewrite H, H0; auto. + rewrite EQ, EQ0; auto. Qed. Lemma Stuck_is_stuck : @@ -920,51 +1108,52 @@ Section stuck. Lemma br_void_is_stuck (c : B void) (k : void -> _) : is_stuck (Br c k). Proof. - red. intros. intro. inv H; destruct x. + red. intros * ?. + apply trans_br_inv in H as [[] ?]. Qed. Lemma br_fin0_is_stuck (c : B (fin 0)) (k : fin 0 -> _) : is_stuck (Br c k). Proof. - red. intros. intro. inv H; now apply case0. + red. intros * ?. + apply trans_br_inv in H as [? ?]. + now apply case0. Qed. Lemma spinD_gen_is_stuck {Y} (x : B Y) : is_stuck (spin_gen x). Proof. red; intros * abs. - remember (spin_gen x) as v. - assert (EQ: v ≅ spin_gen x) by (subst; reflexivity); clear Heqv; revert EQ; rewrite ctree_eta. - induction abs; auto; try now (rewrite ctree_eta; intros abs; step in abs; inv abs). - - intros EQ; apply IHabs. - rewrite <- ctree_eta. - rewrite ctree_eta in EQ. - step in EQ; cbn in *. - dependent induction EQ; auto. - - intros EQ; apply IHabs. - rewrite <- ctree_eta. - rewrite ctree_eta in EQ. - step in EQ; cbn in *. - dependent induction EQ; auto. + remember (α spin_gen x) as v. + assert (EQ: Seq v (α spin_gen x)) by (subst; reflexivity); clear Heqv; revert EQ. + cbn in abs; induction abs. + 3-6: intros EQ; inv EQ; rewrite EQ0 in H; step in H; inv H. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite H0. + rewrite EQ0 in H; step in H; dependent induction H. + symmetry; apply REL. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite EQ0 in H; step in H; dependent induction H. Qed. Lemma spin_is_stuck : is_stuck spin. Proof. red; intros * abs. - remember spin as v. - assert (EQ: v ≅ spin) by (subst; reflexivity); clear Heqv; revert EQ; rewrite ctree_eta. - induction abs; auto; try now (rewrite unfold_spin; intros abs; step in abs; inv abs). - - intros EQ; apply IHabs. - rewrite <- ctree_eta. - rewrite unfold_spin in EQ. - step in EQ. - dependent induction EQ; auto. - - intros EQ; apply IHabs. - rewrite <- ctree_eta. - rewrite unfold_spin in EQ. - step in EQ. - dependent induction EQ; auto. + remember (α spin) as v. + assert (EQ: Seq v (α spin)) by (subst; reflexivity); clear Heqv; revert EQ. + cbn in abs; induction abs. + 3-6: intros EQ; inv EQ; rewrite EQ0 in H; step in H; inv H. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite H0. + rewrite EQ0 in H; step in H; dependent induction H. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite EQ0 in H; step in H; dependent induction H. + now rewrite <- REL. Qed. Lemma spinS_is_not_stuck : @@ -973,7 +1162,7 @@ Section stuck. red; intros * abs. apply (abs τ spinS). rewrite ctree_eta at 1; cbn. - constructor; auto. + apply trans_step. Qed. End stuck. @@ -993,7 +1182,16 @@ Section wtrans. Proof. intros * TR. eapply wcons; eauto. - apply trans_step. + Qed. + + Lemma trans_τ_str_ret_inv' : forall x t, + (trans τ)^* (Ret x) t -> + @Seq E B X t (α Ret x). + Proof. + intros * [[|] step]. + - cbn in *; now symmetry. + - destruct step. + apply trans_ret_inv' in H; intuition congruence. Qed. Lemma trans_τ_str_ret_inv : forall x (t : ctree E B X), @@ -1001,9 +1199,9 @@ Section wtrans. t ≅ Ret x. Proof. intros * [[|] step]. - - cbn in *; symmetry; eauto. + - inv step; now symmetry. - destruct step. - apply trans_ret_inv in H; intuition congruence. + apply trans_ret_inv' in H; intuition congruence. Qed. Lemma wtrans_ret_inv : forall x l (t : ctree E B X), @@ -1012,28 +1210,30 @@ Section wtrans. Proof. intros * step. destruct step as [? [? step1 step2] step3]. - apply trans_τ_str_ret_inv in step1. + apply trans_τ_str_ret_inv' in step1. rewrite step1 in step2; clear step1. - apply etrans_ret_inv in step2 as [[-> EQ] |[-> EQ]]. + apply etrans_ret_inv' in step2 as [[-> EQ] |[-> EQ]]. rewrite EQ in step3; apply trans_τ_str_ret_inv in step3; auto. rewrite EQ in step3. apply transs_is_stuck_inv in step3; [| apply Stuck_is_stuck]. intuition. Qed. - Lemma wtrans_val_inv' : forall (x : X) (t v : ctree E B X), - wtrans (val x) t v -> - exists u, wtrans τ t u /\ trans (val x) u v /\ v ≅ Stuck. + Lemma wtrans_val_inv' : forall (x : X) t u, + wtrans (val x) t u -> + exists t', @wtrans E B X τ t t' /\ @trans E B X (val x) t' u /\ Seq u Stuck. Proof. intros * TR. destruct TR as [t2 [t1 step1 step2] step3]. - pose proof trans_val_inv step2 as EQ. - rewrite EQ in step3, step2. - apply transs_is_stuck_inv in step3; auto using Stuck_is_stuck. - exists t1; repeat split. - apply wtrans_τ, step1. - rewrite <- step3; auto. - symmetry; auto. + exists t1; split. + apply wtrans_τ; auto. + clear step1. + pose proof trans_val_inv' step2. + rewrite H in step3. + apply transs_is_stuck_inv' in step3; auto using Stuck_is_stuck. + split; [| rewrite <- step3; auto]. + rewrite H in step2. rewrite <- step3. + auto. Qed. End wtrans. @@ -1045,6 +1245,23 @@ trans l (t >>= k) u -> (trans l t t' /\ u ≅ t' >>= k) \/ (trans (ret x) t stuc l <> val x -> trans l t u -> trans l (t >>= k) (u >>= k) trans (val x) t stuck -> trans l (k x) u -> trans l (bind t k) u. |*) + +(* CHECKPOINT: need to deal with the [ask] transition cleanly *) +Lemma trans_bind_inv {E B X Y} + (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : + trans l (t >>= k) u -> + (~ (is_val l) /\ exists t', trans l t t' /\ u ≅ t' >>= k) \/ + (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). +Proof. + intros TR. + eapply trans_bind_inv_aux. + apply TR. + rewrite <- ctree_eta; reflexivity. + rewrite <- ctree_eta; reflexivity. +Qed. + + + Lemma trans_bind_inv_aux {E B X Y} l T U : trans_ l T U -> forall (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y), From 4545e95c4928f4878c79aa1e9bff8dcf0d5185bc Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 23 Oct 2025 19:39:37 +0200 Subject: [PATCH 02/61] inversion of bind transitions ok --- theories/Eq/Trans.v | 286 ++++++++++++++++++++++---------------------- 1 file changed, 140 insertions(+), 146 deletions(-) diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index f2757db..70970ae 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -478,6 +478,15 @@ End Trans. #[global] Hint Constructors Seq : core. #[global] Hint Constructors transR : core. +Ltac rem_weak_ t s := + let tmp := fresh in + let name := fresh "EQ" in + remember t as s eqn:tmp; + assert (EQ: Seq s t) by (now subst); + clear tmp. + +Tactic Notation "rem_weak" constr(t) "as" ident(s) := rem_weak_ t s. + (* Class Respects_val {E F} (L : rel (@label E) (@label F)) := *) (* { respects_val: *) (* forall l l', *) @@ -1124,8 +1133,8 @@ Section stuck. is_stuck (spin_gen x). Proof. red; intros * abs. - remember (α spin_gen x) as v. - assert (EQ: Seq v (α spin_gen x)) by (subst; reflexivity); clear Heqv; revert EQ. + rem_weak (α (@spin_gen E B X _ x)) as v. + revert EQ. cbn in abs; induction abs. 3-6: intros EQ; inv EQ; rewrite EQ0 in H; step in H; inv H. - intros EQ; inv EQ. @@ -1142,8 +1151,7 @@ Section stuck. is_stuck spin. Proof. red; intros * abs. - remember (α spin) as v. - assert (EQ: Seq v (α spin)) by (subst; reflexivity); clear Heqv; revert EQ. + rem_weak (α @spin E B X) as v; revert EQ. cbn in abs; induction abs. 3-6: intros EQ; inv EQ; rewrite EQ0 in H; step in H; inv H. - intros EQ; inv EQ. @@ -1246,116 +1254,112 @@ l <> val x -> trans l t u -> trans l (t >>= k) (u >>= k) trans (val x) t stuck -> trans l (k x) u -> trans l (bind t k) u. |*) -(* CHECKPOINT: need to deal with the [ask] transition cleanly *) Lemma trans_bind_inv {E B X Y} - (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : + (t : ctree E B X) (k : X -> ctree E B Y) u l : trans l (t >>= k) u -> - (~ (is_val l) /\ exists t', trans l t t' /\ u ≅ t' >>= k) \/ - (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). + (l = τ /\ exists t', trans l t (α t') /\ Seq u (α t' >>= k)) \/ + (exists Z (e : E Z), l = ask e /\ + exists (g : Z -> ctree E B X), trans l t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). Proof. intros TR. - eapply trans_bind_inv_aux. - apply TR. - rewrite <- ctree_eta; reflexivity. - rewrite <- ctree_eta; reflexivity. -Qed. - - - -Lemma trans_bind_inv_aux {E B X Y} l T U : - trans_ l T U -> - forall (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y), - go T ≅ t >>= k -> - go U ≅ u -> - (~ (is_val l) /\ exists t', trans l t t' /\ u ≅ t' >>= k) \/ - (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). -Proof. - intros TR; induction TR; intros. - - - rewrite unfold_bind in H; setoid_rewrite (ctree_eta t0). - desobs t0. - + right. + rem_weak (α x <- t ;; k x) as ob. + revert t EQ. + induction TR. + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply br_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. exists r; split. - constructor. - rewrite <- H. - apply (Transbr _ x); auto. + rewrite EQ1; auto. + rewrite EQ2. + apply trans_br with x. rewrite <- H0; auto. - + step in H; inv H. - + step in H; dependent induction H. - + step in H; dependent induction H. - + step in H; dependent induction H. - + step in H; dependent induction H. - specialize (IHTR (k1 x) k0 u). - destruct IHTR as [(? & ? & ? & ?) | (? & ? & ?)]; auto. - rewrite <- ctree_eta, REL; reflexivity. - left; split; eauto. - exists x0; split; auto. - apply (Transbr _ x); auto. - right. - exists x0; split; auto. - apply (Transbr _ x); auto. - - - symmetry in H; apply guard_equ_bind in H. - destruct H as [(? & EQ & EQ') | (? & EQ & EQ')]. - + right. - exists x; split; [rewrite EQ; constructor |]. - rewrite EQ'; auto. - rewrite <- H0; constructor; auto. - + destruct (IHTR x k u). - rewrite EQ', <- ctree_eta; auto. - auto. - destruct H as (?& (? & ? & ?)); left; split; eauto. - eexists; split. - rewrite EQ; constructor; apply H1. - auto. - destruct H as (? & ? & ?). - right; eexists; split; eauto. - rewrite EQ; constructor. - apply H. - - symmetry in H0; apply step_equ_bind in H0. - destruct H0 as [(? & EQ & EQ') | (? & EQ & EQ')]. - + right. - exists x; split; [rewrite EQ; constructor |]. - rewrite EQ'; constructor. - rewrite <- ctree_eta in H1; rewrite <- H1; auto. - + left; split; [apply is_val_τ |]. - eexists; split; [rewrite EQ; constructor; reflexivity |]. - rewrite <- H1, <- ctree_eta, H, <-EQ'; auto. - - symmetry in H0; apply vis_equ_bind in H0. - destruct H0 as [(? & EQ & EQ') | (? & EQ & EQ')]. - + right. - exists x0; split; [rewrite EQ; constructor |]. - rewrite EQ'; constructor. - rewrite <- ctree_eta in H1; rewrite <- H1; auto. - + left; split; [apply is_val_obs |]. - eexists; split; [rewrite EQ; constructor; reflexivity |]. - rewrite <- H1, <- ctree_eta, <- H, <-EQ'; auto. - - symmetry in H; apply ret_equ_bind in H. - destruct H as (? & EQ & EQ'). - right. - exists x; split; [rewrite EQ; constructor |]. - rewrite EQ', <- H0; econstructor. -Qed. - -Lemma trans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : - trans l (t >>= k) u -> - (~ (is_val l) /\ exists t', trans l t t' /\ u ≅ t' >>= k) \/ - (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). -Proof. - intros TR. - eapply trans_bind_inv_aux. - apply TR. - rewrite <- ctree_eta; reflexivity. - rewrite <- ctree_eta; reflexivity. + + edestruct IHTR as [H | [H | H]]; [rewrite H0, EQ2; reflexivity |..]; clear IHTR. + * destruct H as (-> & u' & EQ1' & EQ2'). + left. split; auto. + eexists; split; [| eassumption]; rewrite EQ1; eauto. + * destruct H as (Z & e & -> & g & TR' & EQ). + right; left. + exists Z,e; split; auto; exists g; split; auto. + rewrite EQ1; eauto. + * destruct H as (y & TR' & TR''). + right; right. + exists y; split; auto. + rewrite EQ1; eauto. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply guard_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2; auto. + + edestruct IHTR as [H | [H | H]]; [rewrite <- EQ2; reflexivity | ..]; clear IHTR. + * destruct H as (-> & u' & EQ1' & EQ2'). + left. split; auto. + eexists; split; [| eassumption]; rewrite EQ1; auto. + * destruct H as (Z & e & -> & g & TR' & EQ). + right; left. + exists Z,e; split; auto; exists g; split; auto. + rewrite EQ1; auto. + * destruct H as (x & TR' & TR''). + right; right. + exists x; split; auto. + rewrite EQ1; auto. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply step_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2, H0; auto. + + left. + split; auto. + exists v; split. + rewrite EQ1; auto. + rewrite H0, <- EQ2; auto. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply vis_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2; auto. + + right; left. + exists X0, e; split; auto. + exists v; split. + rewrite EQ1; auto. + constructor. + intros ?. + rewrite EQ2; auto. + + - intros ? EQ. + inv EQ. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply ret_equ_bind in H as (r' & EQ1 & EQ2). + right; right. + exists r'; split. + rewrite EQ1; auto. + rewrite EQ2, H0; auto. Qed. - + Lemma trans_bind_inv_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : trans l (t >>= k) u -> exists l' t', trans l' t t'. Proof. intros TR. apply trans_bind_inv in TR. - destruct TR as [(? & ? & ? & ?) | (? & ? & ?)]; eauto. + destruct TR as [(? & ? & ? & ?) | [(? & ? & ? & ? & ? & ?) | (? & ? & ?)]]; eauto. Qed. Lemma trans_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l : @@ -1363,25 +1367,17 @@ Lemma trans_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree trans l t u -> trans l (t >>= k) (u >>= k). Proof. - cbn; unfold transR; intros NOV TR. + cbn; intros NOV TR. dependent induction TR; cbn in *. - - rewrite unfold_bind, <- x. - cbn. - econstructor. - now apply IHTR. - - rewrite unfold_bind, <- x; cbn. - constructor. + - rewrite H, bind_br. + apply trans_br with x. + specialize (IHTR t' k u NOV eq_refl eq_refl). + now rewrite H0 in IHTR. + - rewrite H, bind_guard. + apply trans_guard. apply IHTR; auto. - - rewrite unfold_bind. - rewrite <- x0; cbn. - econstructor. - now rewrite <- H, (ctree_eta u0), x, <- ctree_eta. - - rewrite unfold_bind. - rewrite <- x1; cbn. - econstructor. - rewrite H. - rewrite (ctree_eta t0),x,<- ctree_eta. - reflexivity. + - rewrite H, bind_step. + rewrite H0; apply trans_step. - exfalso; eapply NOV; constructor. Qed. @@ -1390,49 +1386,47 @@ Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree trans l (k x) u -> trans l (t >>= k) u. Proof. - cbn; unfold transR; intros TR1. - genobs t ot. - remember (observe Stuck) as oc. - remember (val x) as v. - revert t x Heqot Heqoc Heqv. - induction TR1; intros; try (inv Heqv; fail). - - subst. - rewrite (ctree_eta t0), <- Heqot; cbn; econstructor. - eapply IHTR1; eauto. - - rewrite (ctree_eta t0), <- Heqot; cbn; econstructor. + cbn; intros TR1. + dependent induction TR1; cbn in *. + - intros TR2; rewrite H, bind_br. + apply trans_br with x0. + rewrite <- H0; eapply IHTR1; eauto. + - intros TR2; rewrite H, bind_guard. + apply trans_guard. eapply IHTR1; eauto. - - dependent induction Heqv. - rewrite (ctree_eta t), <- Heqot, unfold_bind; cbn; auto. + - intros TR2; rewrite H, bind_ret_l; auto. Qed. -Lemma is_stuck_bind : forall {E B X Y} - (t : ctree E B X) (k : X -> ctree E B Y), +Lemma is_stuck_bind : forall {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y), is_stuck t -> is_stuck (bind t k). Proof. repeat intro. - apply trans_bind_inv in H0 as []. - - destruct H0 as (? & ? & ? & ?). - now apply H in H1. - - destruct H0 as (? & ? & ?). - now apply H in H0. + apply trans_bind_inv in H0 as [|[]]. + - destruct H0 as (? & ? & TR & ?). + now apply H in TR. + - destruct H0 as (? & ? & ? & ? & TR & ?). + now apply H in TR. + - destruct H0 as (? & TR & ?). + now apply H in TR. Qed. (*| Forward and backward rules for [wtrans] w.r.t. [bind] ----------------------------------------------------- |*) - -Lemma etrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : +(* CHECKPOINT: going good *) +Lemma etrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : etrans l (t >>= k) u -> - (~ (is_val l) /\ exists t', etrans l t t' /\ u ≅ t' >>= k) \/ - (exists (x : X), trans (val x) t Stuck /\ etrans l (k x) u). + (~ (is_val l) /\ exists t', etrans l t (α t') /\ Seq u (t' >>= k)) \/ + (exists (x : X), trans (val x) t Stuck /\ etrans l (k x) u). Proof. intros TR. - apply @etrans_case in TR as [ | (-> & ?)]. - - apply trans_bind_inv in H as [[? (? & ? & ?)]|( ? & ? & ?)]; eauto. - left; split; eauto. - eexists; split; eauto; apply trans_etrans; auto. - right; eexists; split; eauto; apply trans_etrans; auto. + apply @etrans_case' in TR as [ | (-> & ?)]. + - apply trans_bind_inv in H as [[? (? & ? & ?)]|[( ? & ? & ? & ? & ? & ?)|( ? & ? & ?)]]; eauto. + + subst; left; split; eauto using is_val_τ. + eexists; split; eauto; apply trans_etrans; auto. + + subst; right. + eexists; split; eauto. apply trans_etrans; auto. - left; split. intros abs; inv abs. exists t; split; auto using enil; symmetry; auto. From bd94505d071f0a2d1b3204c14ba1a467606d636b Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 23 Oct 2025 22:46:02 +0200 Subject: [PATCH 03/61] bunch of lemmas about weak reductions must be duplicated. Getting close --- theories/Eq/Trans.v | 359 ++++++++++++++++++++++++++------------------ 1 file changed, 209 insertions(+), 150 deletions(-) diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 70970ae..62c0ea2 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -126,7 +126,7 @@ least annoying solution. intro H. inversion H. Qed. - (*| +(*| The transition relation over [ctree]s. It can either: - recursively crawl through invisible [br] node; @@ -167,85 +167,6 @@ node, labelling the transition by the returned value. transR (val r) (Active t) (Active u). Hint Constructors transR : core. - (* Definition transR l : hrel S S := *) - (* fun u v => trans_ l (observe u) (observe v). *) - - (* Ltac FtoObs := *) - (* match goal with *) - (* |- trans_ _ _ ?t => *) - (* change t with (observe {| _observe := t |}) *) - (* end. *) - - (* #[local] Instance trans_equ_aux1 l t : *) - (* Proper (going (equ eq) ==> flip impl) (trans_ l t). *) - (* Proof. *) - (* intros u u' equ; intros TR. *) - (* inv equ; rename H into equ. *) - (* step in equ. *) - (* revert u equ. *) - (* dependent induction TR; intros; subst; eauto. *) - (* + inv equ. *) - (* * rewrite H2; eauto. *) - (* * FtoObs. *) - (* constructor. *) - (* rewrite <- H. *) - (* apply observing_sub_equ; eauto. *) - (* * FtoObs. *) - (* constructor. *) - (* rewrite <- H, REL. *) - (* apply observing_sub_equ; eauto. *) - (* * FtoObs. *) - (* constructor. *) - (* rewrite <- H, REL. *) - (* apply observing_sub_equ; eauto. *) - (* * FtoObs. *) - (* constructor. *) - (* rewrite <- H. *) - (* step; rewrite <- H2; constructor; intros. *) - (* auto. *) - (* * FtoObs. *) - (* constructor. *) - (* rewrite <- H. *) - (* step; rewrite <- H2; constructor; intros. *) - (* auto. *) - (* + FtoObs. *) - (* econstructor. *) - (* rewrite H; symmetry; step; auto. *) - (* + inv equ. eauto. *) - (* Qed. *) - - (* #[local] Instance trans_equ_aux2 l : *) - (* Proper (going (equ eq) ==> going (equ eq) ==> impl) (trans_ l). *) - (* Proof. *) - (* intros t t' eqt u u' equ TR. *) - (* rewrite <- equ; clear u' equ. *) - (* inv eqt; rename H into eqt. *) - (* revert t' eqt. *) - (* dependent induction TR; intros; auto. *) - (* + step in eqt; dependent induction eqt. *) - (* econstructor. *) - (* apply IHTR. *) - (* rewrite REL; reflexivity. *) - (* + step in eqt; dependent induction eqt. *) - (* econstructor. *) - (* apply IHTR. rewrite REL; reflexivity. *) - (* + step in eqt; dependent induction eqt. *) - (* econstructor. rewrite H,REL; auto. *) - (* + step in eqt; dependent induction eqt. *) - (* econstructor. *) - (* rewrite <- REL; eauto. *) - (* + step in eqt; dependent induction eqt. *) - (* econstructor. *) - (* Qed. *) - - (* #[global] Instance trans_equ_ l : *) - (* Proper (going (equ eq) ==> going (equ eq) ==> iff) (trans_ l). *) - (* Proof. *) - (* intros ? ? eqt ? ? equ; split; intros TR. *) - (* - eapply trans_equ_aux2; eauto. *) - (* - symmetry in equ; symmetry in eqt; eapply trans_equ_aux2; eauto. *) - (* Qed. *) - #[global] Instance equ_Seq_active : Proper (equ eq ==> Seq) Active. Proof. now intros ?? EQ; constructor. @@ -329,18 +250,6 @@ library. Definition trans l : srel SS SS := {| hrel_of := transR l : hrel SS SS |}. - (* Lemma trans__trans : forall l t u, *) - (* trans_ l (observe t) (observe u) = trans l t u. *) - (* Proof. *) - (* reflexivity. *) - (* Qed. *) - - (* Lemma transR_trans : forall l (t t' : S), *) - (* transR l t t' = trans l t t'. *) - (* Proof. *) - (* reflexivity. *) - (* Qed. *) - (*| Extension of [trans] with its reflexive closure, labelled by [τ]. |*) @@ -746,16 +655,6 @@ Inverting equalities between labels now dependent induction EQ. Qed. - (* Lemma obs_eq_invT : forall X Y e1 e2 v1 v2, @obs E X e1 v1 = @obs E Y e2 v2 -> X = Y. *) - (* clear B. intros * EQ. *) - (* now dependent induction EQ. *) - (* Qed. *) - - (* Lemma obs_eq_inv : forall X e1 e2 v1 v2, @obs E X e1 v1 = @obs E X e2 v2 -> e1 = e2 /\ v1 = v2. *) - (* clear B. intros * EQ. *) - (* now dependent induction EQ. *) - (* Qed. *) - (*| Structural rules |*) @@ -1362,23 +1261,38 @@ Proof. destruct TR as [(? & ? & ? & ?) | [(? & ? & ? & ? & ? & ?) | (? & ? & ?)]]; eauto. Qed. -Lemma trans_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l : - ~ (@is_val E l) -> - trans l t u -> - trans l (t >>= k) (u >>= k). +Lemma trans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + trans τ t u -> + trans τ (t >>= k) (u >>= k). Proof. - cbn; intros NOV TR. + cbn; intros TR. dependent induction TR; cbn in *. - rewrite H, bind_br. apply trans_br with x. - specialize (IHTR t' k u NOV eq_refl eq_refl). + specialize (IHTR t' k u eq_refl eq_refl eq_refl). now rewrite H0 in IHTR. - rewrite H, bind_guard. apply trans_guard. apply IHTR; auto. - rewrite H, bind_step. rewrite H0; apply trans_step. - - exfalso; eapply NOV; constructor. +Qed. + +Lemma trans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : + trans (ask e) t (β e g) -> + trans (ask e) (t >>= k) (β e (fun x => g x >>= k)). +Proof. + cbn; intros TR. + dependent induction TR; cbn in *. + - rewrite H, bind_br. + apply trans_br with x. + specialize (IHTR Z t' k e g eq_refl eq_refl eq_refl). + now rewrite H0 in IHTR. + - rewrite H, bind_guard. + apply trans_guard. + apply IHTR; auto. + - rewrite H, bind_vis. + apply trans_ask. Qed. Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l : @@ -1414,10 +1328,12 @@ Qed. Forward and backward rules for [wtrans] w.r.t. [bind] ----------------------------------------------------- |*) -(* CHECKPOINT: going good *) + Lemma etrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : etrans l (t >>= k) u -> - (~ (is_val l) /\ exists t', etrans l t (α t') /\ Seq u (t' >>= k)) \/ + (l = τ /\ exists t', etrans l t (α t') /\ Seq u (t' >>= k)) \/ + (exists Z (e : E Z), l = ask e /\ + exists (g : Z -> ctree E B X), trans l t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ (exists (x : X), trans (val x) t Stuck /\ etrans l (k x) u). Proof. intros TR. @@ -1425,17 +1341,17 @@ Proof. - apply trans_bind_inv in H as [[? (? & ? & ?)]|[( ? & ? & ? & ? & ? & ?)|( ? & ? & ?)]]; eauto. + subst; left; split; eauto using is_val_τ. eexists; split; eauto; apply trans_etrans; auto. - + subst; right. - eexists; split; eauto. apply trans_etrans; auto. - - left; split. - intros abs; inv abs. + + subst; right; left. + eexists; eexists; split; eauto. + + right; right; eexists; split; eauto. now apply trans_etrans. + - inv H; left; split; auto. exists t; split; auto using enil; symmetry; auto. Qed. -Lemma transs_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) : +Lemma transs_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u : (trans τ)^* (t >>= k) u -> - (exists t', (trans τ)^* t t' /\ u ≅ t' >>= k) \/ - (exists (x : X), wtrans (val x) t Stuck /\ (trans τ)^* (k x) u). + (exists t', (trans τ)^* t (α t') /\ Seq u (t' >>= k)) \/ + (exists (x : X), wtrans (val x) t Stuck /\ (trans τ)^* (k x) u). Proof. intros [n TR]. revert t k u TR. @@ -1445,7 +1361,7 @@ Proof. exists 0%nat; reflexivity. symmetry; auto. - destruct TR as [t1 TR1 TR2]. - apply trans_bind_inv in TR1 as [(_ & t2 & TR1 & EQ) | (x & TR1 & TR1')]. + apply trans_bind_inv in TR1 as [(_ & t2 & TR1 & EQ) | [(x & TR1 & abs & ?) | (x & TR1 & TR1')]]. + rewrite EQ in TR2; clear t1 EQ. apply IH in TR2 as [(t3 & TR2 & EQ')| (x & TR2 & TR3)]. * left; eexists; split; eauto. @@ -1453,12 +1369,48 @@ Proof. apply wtrans_τ; auto. * right; exists x; split; eauto. eapply wcons; eauto. + + inv abs. + right. exists x; split. apply trans_wtrans; auto. - exists (S n), t1; auto. + exists (Datatypes.S n), t1; auto. +Qed. + +Lemma passive_τ_trans {E B X Y} e (g : X -> ctree E B Y) u : + trans τ (β e g) u -> + False. +Proof. + intros TR; cbn in TR; dependent induction TR. Qed. +Lemma passive_τ_etrans {E B X Y} e (g : X -> ctree E B Y) u : + etrans τ (β e g) u -> + Seq u (β e g). +Proof. + intros [TR | EQ]. + - cbn in TR; dependent induction TR. + - symmetry; apply EQ. +Qed. + +Lemma passive_τ_wtrans {E B X Y} e (g : X -> ctree E B Y) u : + wtrans τ (β e g) u -> + Seq u (β e g). +Proof. + intros [? [? [n TR1] TR2] [m TR3]]. + destruct n. + - cbn in TR1. rewrite <- TR1 in TR2. + apply passive_τ_etrans in TR2. + destruct m. + * cbn in TR3. + now rewrite <- TR3, TR2. + * destruct TR3 as [? TR _]. + rewrite TR2 in TR. + exfalso; eapply passive_τ_trans; eauto. + - destruct TR1 as [? TR _]. + exfalso; eapply passive_τ_trans; eauto. +Qed. + + (*| Things are a bit ugly with [wtrans], we end up with three cases: - the reduction entirely takes place in the prefix @@ -1470,50 +1422,129 @@ in the prefix. This is a bit more annoying to express: we cannot necessarily just before the [Ret] some invisible br nodes. We therefore have to introduce the last visible state reached by [wtrans] and add a [trans (val _)] afterward. |*) -Lemma wtrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : +Lemma wtrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : wtrans l (t >>= k) u -> - (~ (is_val l) /\ exists t', wtrans l t t' /\ u ≅ t' >>= k) \/ - (exists (x : X), wtrans (val x) t Stuck /\ wtrans l (k x) u) \/ - (exists (x : X) s, wtrans l t s /\ trans (val x) s Stuck /\ wtrans τ (k x) u). + (l = τ /\ exists t', wtrans l t (α t') /\ Seq u (t' >>= k)) \/ + (exists Y (e : E Y), l = ask e /\ exists g, wtrans l t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (exists (x : X), wtrans (val x) t Stuck /\ wtrans l (k x) u) \/ + (exists (x : X) s, wtrans l t s /\ trans (val x) s Stuck /\ wtrans τ (k x) u). Proof. intros TR. destruct TR as [t2 [t1 step1 step2] step3]. apply transs_bind_inv in step1 as [(u1 & TR1 & EQ1)| (x & TR1 & TR1')]. - - rewrite EQ1 in step2; clear t1 EQ1. - apply etrans_bind_inv in step2 as [(H & u2 & TR2 & EQ2)| (x & TR2 & TR2')]. - + rewrite EQ2 in step3; clear t2 EQ2. + - rewrite EQ1 in step2. + apply etrans_bind_inv in step2 as [(H & u2 & TR2 & EQ2)| [(Z & e & EQ & g & TR2 & EQ2) | (x & TR2 & TR2')]]. + + rewrite EQ2 in step3. + subst. apply transs_bind_inv in step3 as [(u3 & TR3 & EQ3)| (x & TR3 & TR3')]. * left; split; auto. - eexists; split; eauto. - exists u2; auto; exists u1; auto. - * right; right. + eexists; split. 2:apply EQ3. + exists (α u2); [exists (α u1) |]; auto. + * right; right; right. apply wtrans_val_inv in TR3 as (u3 & TR2' & TR2''). exists x, u3. split; [|split]; auto. 2:apply wtrans_τ; auto. - exists u2; [exists u1; assumption | ]. + exists (α u2); [exists (α u1) |]; auto. apply wtrans_τ; apply wtrans_τ in TR1. eapply wconss; eauto. - + right; left. + + destruct t2 as [? | h]; [inv EQ2 |]. + dependent induction EQ2. + assert (Seq u (β (e) k0)). + { apply passive_τ_wtrans, wtrans_τ; auto. } + right; left. + exists Z, e; split; auto. + eexists; split. + 2:rewrite H; constructor; intros x; rewrite (EQ x); reflexivity. + exists (β (e) g); [exists (α u1) |]; auto. + apply wtrans_τ; apply wnil. + + right; right; left. exists x; split. eexists; [eexists |]; eauto; apply wtrans_τ, wnil. eexists; [eexists |]; eauto; apply wtrans_τ, wnil. - - right; left. + - right; right; left. exists x; split; eauto. eexists; [eexists |]; eauto. Qed. -Lemma etrans_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l : - ~ is_val l -> - etrans l t u -> - etrans l (t >>= k) (u >>= k). +Lemma etrans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + etrans τ t u -> + etrans τ (t >>= k) (u >>= k). +Proof. + cbn. + intros [|]. + left; apply trans_bind_l_τ; auto. + inv H; rewrite EQ; auto. +Qed. + +Lemma etrans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : + etrans (ask e) t (β e g) -> + etrans (ask e) (t >>= k) (β e (fun x => g x >>= k)). Proof. - destruct l; cbn; try apply trans_bind_l; auto. - intros NOV [|]. - left; apply trans_bind_l; auto. - right; rewrite H; auto. + cbn; intros TR. + apply trans_bind_l_ask; auto. Qed. +Lemma trans_τ_active {E B X} (t : ctree E B X) u : + trans τ (α t) u -> + exists u', Seq u (α u'). +Proof. + intros TR; cbn in TR; dependent induction TR. + - edestruct IHTR; auto. + inv H1; eauto. + - edestruct IHTR; eauto. + - eauto. +Qed. + +Lemma etrans_τ_active {E B X} (t : ctree E B X) u : + etrans τ (α t) u -> + exists u', Seq u (α u'). +Proof. + intros [TR | TR]. + - eapply trans_τ_active; eauto. + - cbn in *; exists t; rewrite TR; auto. +Qed. + +Lemma trans_ask_passive {E B X Y} (t : ctree E B X) (e : E Y) u : + trans (ask e) (α t) u -> + exists g, Seq u (β e g). +Proof. + intros TR; cbn in TR; dependent induction TR. + - edestruct IHTR; auto. + dependent induction H1; eauto. + - edestruct IHTR; eauto. + - eauto. +Qed. + +Lemma etrans_ask_active {E B X Y} (t : ctree E B X) (e : E Y) u : + etrans (ask e) (α t) u -> + exists g, Seq u (β e g). +Proof. + intros TR; eapply trans_ask_passive; eauto. +Qed. + +Lemma transs_τ_passive {E B X Y} e (g : X -> ctree E B Y) u : + (trans τ)^* (β e g) u -> + Seq u (β e g). +Proof. + intros TR. + eapply passive_τ_wtrans. + now apply wtrans_τ. +Qed. + +Lemma transs_τ_active {E B X} (t : ctree E B X) u : + (trans τ)^* (α t) u -> + exists u', Seq u (α u'). +Proof. + intros [n TR]. revert t TR. + induction n as [| n IH]; intros t TR. + - cbn in TR; exists t; symmetry; eauto. + - destruct TR as [? TR TRs]. + eapply trans_τ_active in TR as [u' EQ]. + rewrite EQ in TRs. + edestruct IH; eauto. +Qed. + Lemma transs_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : (trans τ)^* t u -> (trans τ)^* (t >>= k) (u >>= k). @@ -1521,26 +1552,54 @@ Proof. intros [n TR]. revert t u TR. induction n as [| n IH]. - - cbn; intros; exists 0%nat; cbn; rewrite TR; reflexivity. + - cbn; intros; exists 0%nat; cbn; inv TR; rewrite EQ; auto. - intros t u [v TR1 TR2]. + pose proof trans_τ_active TR1 as (v' & EQv). + rewrite EQv in TR1,TR2. apply IH in TR2. eapply wtrans_τ, wcons. - apply trans_bind_l; eauto; intros abs; inv abs. - apply wtrans_τ; eauto. + 2:apply wtrans_τ; eauto. + apply trans_bind_l_τ; eauto. Qed. -Lemma wtrans_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l : - ~ (@is_val E l) -> - wtrans l t u -> - wtrans l (t >>= k) (u >>= k). +Lemma wtrans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + wtrans τ t u -> + wtrans τ (t >>= k) (u >>= k). Proof. - intros NOV [t2 [t1 TR1 TR2] TR3]. + intros [t2 [t1 TR1 TR2] TR3]. + pose proof transs_τ_active TR1 as (x & EQx). + rewrite EQx in TR1,TR2. + pose proof etrans_τ_active TR2 as (y & EQy). + rewrite EQy in TR2,TR3. + pose proof transs_τ_active TR3 as (z & EQz). eexists; [eexists |]. apply transs_bind_l; eauto. - apply etrans_bind_l; eauto. + apply etrans_bind_l_τ; eauto. + apply transs_bind_l; eauto. +Qed. + +Lemma wtrans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : + wtrans (ask e) t (β e g) -> + wtrans (ask e) (t >>= k) (β e (fun x => g x >>= k)). +Proof. + intros [t2 [t1 TR1 TR2] TR3]. + pose proof transs_τ_active TR1 as (x & EQx). + rewrite EQx in TR1,TR2. + pose proof etrans_ask_active TR2 as (y & EQy). + rewrite EQy in TR2,TR3. + pose proof transs_τ_passive TR3 as EQz. + eexists; [eexists |]. apply transs_bind_l; eauto. + apply etrans_bind_l_ask; eauto. + apply wtrans_τ. + assert (Seq (β (e) (fun x0 : Z => x <- y x0;; k x)) (β (e) (fun x0 : Z => x <- g x0;; k x))). + { dependent induction EQz. + constructor; intros a. + now rewrite <- (EQ a). } + rewrite H. apply wnil. Qed. +(* CHECKPOINT *) Lemma wtrans_case {E B X} (t u : ctree E B X) l: wtrans l t u -> t ≅ u \/ (exists v, trans l t v /\ wtrans τ v u) \/ (exists v, trans τ t v /\ wtrans l v u). From f4a92048e3c935feece788e793a3665329c9f277 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 24 Oct 2025 17:15:52 +0200 Subject: [PATCH 04/61] Finished trans, without the ltac --- theories/Eq/Trans.v | 689 ++++++++++++++++++++++++++------------------ 1 file changed, 415 insertions(+), 274 deletions(-) diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 62c0ea2..d583df3 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -680,7 +680,7 @@ Structural rules intuition. Qed. - Lemma trans_ask_inv' : forall {Y} (e : E Y) (k : _ -> ctree E B X) l u, + Lemma trans_vis_inv' : forall {Y} (e : E Y) (k : _ -> ctree E B X) l u, trans l (Vis e k) u -> Seq u (β e k) /\ l = ask e. Proof. @@ -690,7 +690,7 @@ Structural rules constructor; intros ?; symmetry; eauto. Qed. - Lemma trans_ask_inv : forall {Y} (e : E Y) k l (u : ctree E B X), + Lemma trans_vis_inv : forall {Y} (e : E Y) k l (u : ctree E B X), trans l (Vis e k) u -> Seq u (β e k) /\ l = ask e. Proof. @@ -698,7 +698,7 @@ Structural rules inv TR; inv_equ. Qed. - Lemma trans_rcv_inv' : forall {Y} (e : E Y) (k : Y -> ctree E B X) l u, + Lemma trans_passive_inv' : forall {Y} (e : E Y) (k : Y -> ctree E B X) l u, trans l (β e k) u -> exists x, Seq u (α k x) /\ l = rcv e x. Proof. @@ -708,12 +708,12 @@ Structural rules constructor; symmetry; eauto. Qed. - Lemma trans_rcv_inv : forall {Y} (e : E Y) (k : Y -> ctree E B X) l (u : ctree E B X), + Lemma trans_passive_inv : forall {Y} (e : E Y) (k : Y -> ctree E B X) l (u : ctree E B X), trans l (β e k) u -> exists x, u ≅ (k x) /\ l = rcv e x. Proof. intros * TR. - apply trans_rcv_inv' in TR as (? & ? & ?). + apply trans_passive_inv' in TR as (? & ? & ?). inv H; eauto. Qed. @@ -1311,6 +1311,22 @@ Proof. - intros TR2; rewrite H, bind_ret_l; auto. Qed. +Lemma trans_bind_r_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B Y) x : + trans (val x) t Stuck -> + trans (ask e) (k x) (β e g) -> + trans (ask e) (t >>= k) (β e g). +Proof. + cbn; intros TR1. + dependent induction TR1; cbn in *. + - intros TR2; rewrite H, bind_br. + apply trans_br with x0. + rewrite <- H0; eapply IHTR1; eauto. + - intros TR2; rewrite H, bind_guard. + apply trans_guard. + eapply IHTR1; eauto. + - intros TR2; rewrite H, bind_ret_l; auto. +Qed. + Lemma is_stuck_bind : forall {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y), is_stuck t -> is_stuck (bind t k). Proof. @@ -1544,6 +1560,13 @@ Proof. rewrite EQ in TRs. edestruct IH; eauto. Qed. + +Lemma wtrans_τ_active {E B X} (t : ctree E B X) u : + wtrans τ (α t) u -> + exists u', Seq u (α u'). +Proof. + intros TR; apply wtrans_τ in TR; eapply transs_τ_active; eauto. +Qed. Lemma transs_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : (trans τ)^* t u -> @@ -1599,10 +1622,11 @@ Proof. rewrite H. apply wnil. Qed. -(* CHECKPOINT *) -Lemma wtrans_case {E B X} (t u : ctree E B X) l: +Lemma wtrans_case_active {E B X} (t u : ctree E B X) l: wtrans l t u -> - t ≅ u \/ (exists v, trans l t v /\ wtrans τ v u) \/ (exists v, trans τ t v /\ wtrans l v u). + (l = τ /\ t ≅ u) \/ + (exists v, trans l t v /\ wtrans τ v u) \/ + (exists v, trans τ t v /\ wtrans l v u). Proof. intros [t2 [t1 [n TR1] TR2] TR3]. destruct n as [| n]. @@ -1613,6 +1637,7 @@ Proof. cbn in H; rewrite <- H in TR3. apply wtrans_τ in TR3. destruct TR3 as [[| n] ?]; eauto. + cbn in H0; inv H0; eauto. destruct H0 as [? ? ?]; right; left; eexists; split; eauto. apply wtrans_τ; exists n; auto. - destruct TR1 as [? ? ?]. @@ -1622,44 +1647,95 @@ Proof. exists n; eauto. Qed. -Lemma wtrans_case' {E B X} (t u : ctree E B X) l: - wtrans l t u -> - match l with - | τ => (t ≅ u \/ exists v, trans τ t v /\ wtrans τ v u) - | _ => (exists v, trans l t v /\ wtrans τ v u) \/ - (exists v, trans τ t v /\ wtrans l v u) - end. +Lemma trans_rcv_inv {E B X Y} (e : E Y) (y : Y) u v : + trans (rcv e y) u v -> + exists (g : Y -> ctree E B X), Seq u (β e g) /\ Seq v (α g y). Proof. - intros [t2 [t1 [n TR1] TR2] TR3]. - destruct n as [| n]. - - apply wtrans_τ in TR3. - cbn in TR1; rewrite <- TR1 in TR2. - destruct l; eauto. - destruct TR2; eauto. - cbn in H; rewrite <- H in TR3. - apply wtrans_τ in TR3. - destruct TR3 as [[| n] ?]; eauto. - destruct H0 as [? ? ?]; right; eexists; split; eauto. - apply wtrans_τ; exists n; auto. - - destruct TR1 as [? ? ?]. - destruct l; right. - all:eexists; split; eauto. - all:exists t2; [exists t1|]; eauto. - all:exists n; eauto. + intros TR. + remember (rcv e y). + revert e y Heql. + induction TR; intros * EQl; subst; auto; inv_equ. + - edestruct IHTR as (g & abs & ?); [reflexivity |]. + inv abs. + - edestruct IHTR as (g & abs & ?); [reflexivity |]. + inv abs. + - inv EQl. + - dependent induction EQl. + exists k; split; auto. + now rewrite <- H. + - inv EQl. Qed. -Lemma wtrans_Stuck_inv {E B R} : +Lemma trans_rcv_active {E B X Y} (e : E Y) (y : Y) (u : ctree E B X) v : + trans (rcv e y) (α u) v -> + False. +Proof. + intros TR; pose proof trans_rcv_inv TR as (? & abs & ?); inv abs. +Qed. + +Lemma wtrans_stuck {E B X} l t : + wtrans l (Stuck : ctree E B X) t -> + l = τ /\ Seq t (Stuck : ctree E B X). +Proof. + intros WTR. + destruct l. + 1: split; auto. + 2-4:exfalso. + apply wtrans_τ in WTR as [[|n] WTR]. + now symmetry. + exfalso; destruct WTR as [? TR WTR]. + eapply trans_stuck_inv; eauto. + all: destruct WTR as [t2 [t1 TR1 TR2] TR3]. + all: destruct TR1 as [[|n] TR1]. + all: cbn in TR1; try (rewrite <- TR1 in TR2; eapply trans_stuck_inv; now eauto). + all: destruct TR1 as [? TR WTR]; eapply trans_stuck_inv; now apply TR. +Qed. + +Lemma wtrans_stuck' {E B R} : forall (t : ctree E B R) l, wtrans l Stuck t -> match l with | τ => t ≅ Stuck | _ => False end. Proof. intros * TR. - apply wtrans_case' in TR. - destruct l; break; cbn in *. - symmetry; auto. - all: exfalso; eapply Stuck_is_stuck; now apply H. + pose proof wtrans_stuck TR as [-> EQ]. + now inv EQ. Qed. +Lemma wtrans_case_passive {E B X Y} (t : ctree E B X) (e : E Y) (g : Y -> ctree E B X) l: + wtrans l t (β e g) -> + (l = ask e /\ exists v h, wtrans τ t (α v) /\ trans (ask e) v (β e h) /\ Seq (β e h) (β e g)). +Proof. + intros [t2 [t1 TR1 TR2] TR3]. + apply wtrans_τ in TR1. + pose proof wtrans_τ_active TR1 as [? EQ1]. + rewrite EQ1 in *. + destruct l. + - pose proof etrans_τ_active TR2 as [? EQ2]. + rewrite EQ2 in *. + apply wtrans_τ in TR3. + pose proof wtrans_τ_active TR3 as [? EQ3]. + inv EQ3. + - cbn in TR2. + pose proof trans_ask_passive TR2 as [h EQ]. + rewrite EQ in *; clear t2 EQ. + clear t1 EQ1. + apply wtrans_τ in TR3. + pose proof passive_τ_wtrans TR3 as EQ. + dependent induction EQ. + split; auto. + exists x, h; split; auto. + split; auto. + now constructor. + - exfalso. + eapply trans_rcv_active; eauto. + - exfalso. + apply trans_val_inv' in TR2. + rewrite TR2 in TR3. + apply wtrans_τ in TR3. + apply wtrans_stuck in TR3 as [_ EQ]. + inv EQ. +Qed. + Lemma pwtrans_case {E B X} (t u : ctree E B X) l: pwtrans l t u -> (exists v, trans l t v /\ wtrans τ v u) \/ (exists v, trans τ t v /\ wtrans l v u). @@ -1682,49 +1758,115 @@ It's a bit annoying that we need two cases in this lemma, but if by taking the [Ret] in the prefix, but we cannot process it to reach [u] in the bound computation. |*) -Lemma wtrans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l : + +Lemma wtrans_bind_r_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x : wtrans (val x) t Stuck -> - wtrans l (k x) u -> - (u ≅ k x \/ wtrans l (t >>= k) u). + wtrans τ (k x) u -> + (u ≅ k x \/ wtrans τ (t >>= k) u). Proof. intros TR1 TR2. apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). - eapply wtrans_bind_l in TR1; [| intros abs; inv abs]. - apply wtrans_case in TR2 as [? | [|]]. + pose proof wtrans_τ_active TR1 as (a & EQa). + rewrite EQa in TR1. + eapply wtrans_bind_l_τ in TR1. + apply wtrans_case_active in TR2 as [[? ?] | [|(v & TR & WTR)]]. - left; symmetry; assumption. - - right;eapply wconss; [apply TR1 | clear t TR1]. - destruct H as (? & ? & ?). - eapply trans_bind_r in TR1'; eauto. - eapply wsnocs; eauto. - apply trans_wtrans; auto. - - right;eapply wconss; [apply TR1 | clear t TR1]. + - right; eapply wconss; [apply TR1 | clear t TR1]. destruct H as (? & ? & ?). + rewrite EQa in TR1'; clear t' EQa. + pose proof trans_τ_active H as [? EQ]. + rewrite EQ in H,H0. + eapply trans_bind_r in H; [| eauto]. + eapply wcons; eauto. + - right; eapply wconss; [apply TR1 | clear t TR1]. + rewrite EQa in TR1'. + pose proof trans_τ_active TR as [? EQ]. + rewrite EQ in TR,WTR. eapply trans_bind_r in TR1'; eauto. eapply wconss; [|eauto]. apply trans_wtrans; auto. Qed. -Lemma wtrans_bind_r' {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l : +Lemma wtrans_bind_r_val {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) x (y : Y) : wtrans (val x) t Stuck -> - pwtrans l (k x) u -> - (wtrans l (t >>= k) u). + wtrans (val y) (k x) Stuck -> + wtrans (val y) (t >>= k) Stuck. Proof. intros TR1 TR2. apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). - eapply wtrans_bind_l in TR1; [| intros abs; inv abs]. - apply pwtrans_case in TR2 as [? | ]. - - eapply wconss; [apply TR1 | clear t TR1]. - destruct H as (? & ? & ?). - eapply trans_bind_r in TR1'; eauto. - eapply wsnocs; eauto. - apply trans_wtrans; auto. - - eapply wconss; [apply TR1 | clear t TR1]. - destruct H as (? & ? & ?). + pose proof wtrans_τ_active TR1 as (a & EQa). + rewrite EQa in TR1, TR1'; clear t' EQa. + eapply wconss. + eapply wtrans_bind_l_τ, TR1. + clear t TR1. + apply wtrans_case_active in TR2 as [[abs ?] | [(v & TR & WTR)|(v & TR & WTR)]]. + - inv abs. + - eapply wsnocs; eauto. + apply trans_wtrans. + pose proof trans_val_inv' TR as EQ; rewrite EQ in TR |-*. + eapply trans_bind_r; eauto. + - pose proof trans_τ_active TR as [? EQ]. + rewrite EQ in TR,WTR. eapply trans_bind_r in TR1'; eauto. eapply wconss; [|eauto]. apply trans_wtrans; auto. Qed. +Lemma wtrans_bind_r_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (u : Z -> ctree E B Y) x : + wtrans (val x) t Stuck -> + wtrans (ask e) (k x) (β e u) -> + wtrans (ask e) (t >>= k) (β e u). +Proof. + intros TR1 TR2. + apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). + apply wtrans_case_passive in TR2 as (_ & v & h & WTR & TR & EQ). + rewrite <- EQ. + clear u EQ. + pose proof wtrans_τ_active TR1 as [? EQ]. + rewrite EQ in *; clear t' EQ. + eapply wconss. + eapply wtrans_bind_l_τ, TR1. + clear t TR1. + apply wtrans_case_active in WTR as [[_ EQ] | [(?v & TRv & WTRv) | (?v & TRv & WTRv)]]. + - rewrite <- EQ in *. + clear v EQ. + apply trans_wtrans. + eapply trans_bind_r_ask; eauto. + - pose proof trans_τ_active TRv as [? EQ]. + rewrite EQ in *; clear v0 EQ. + eapply wcons. + eapply trans_bind_r; eauto. + eapply wconss; eauto. + now apply trans_wtrans. + - pose proof trans_τ_active TRv as [? EQ]. + rewrite EQ in *; clear v0 EQ. + eapply wcons. + eapply trans_bind_r; eauto. + eapply wconss; eauto. + now apply trans_wtrans. +Qed. + +(* Lemma wtrans_bind_r' {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l : *) +(* wtrans (val x) t Stuck -> *) +(* pwtrans l (k x) u -> *) +(* (wtrans l (t >>= k) u). *) +(* Proof. *) +(* intros TR1 TR2. *) +(* apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). *) +(* eapply wtrans_bind_l in TR1; [| intros abs; inv abs]. *) +(* apply pwtrans_case in TR2 as [? | ]. *) +(* - eapply wconss; [apply TR1 | clear t TR1]. *) +(* destruct H as (? & ? & ?). *) +(* eapply trans_bind_r in TR1'; eauto. *) +(* eapply wsnocs; eauto. *) +(* apply trans_wtrans; auto. *) +(* - eapply wconss; [apply TR1 | clear t TR1]. *) +(* destruct H as (? & ? & ?). *) +(* eapply trans_bind_r in TR1'; eauto. *) +(* eapply wconss; [|eauto]. *) +(* apply trans_wtrans; auto. *) +(* Qed. *) + Lemma trans_val_invT {E B R R'} : forall (t u : ctree E B R) (v : R'), trans (val v) t u -> @@ -1735,37 +1877,37 @@ Proof. induction TR; intros; auto; try now inv Heqov. Qed. -Lemma wtrans_bind_lr {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) (v : ctree E B Y) x l : - pwtrans l t u -> - wtrans (val x) u Stuck -> - pwtrans τ (k x) v -> - (wtrans l (t >>= k) v). -Proof. - intros [t2 [t1 TR1 TR1'] TR1''] TR2 TR3. - exists (x <- t2;; k x). - - assert (~ is_val l). - { - destruct l; try now intros abs; inv abs. - exfalso. - pose proof (trans_val_invT TR1'); subst. - apply trans_val_inv in TR1'. - rewrite TR1' in TR1''. - apply transs_is_stuck_inv in TR1''; [| apply Stuck_is_stuck]. - rewrite <- TR1'' in TR2. - apply wtrans_is_stuck_inv in TR2; [| apply Stuck_is_stuck]. - destruct TR2 as [abs _]; inv abs. - } - eexists. - 2:apply trans_etrans, trans_bind_l; eauto. - apply wtrans_τ; eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_τ; auto]. - - apply wtrans_τ. - eapply wconss. - eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_τ; eauto]. - eapply wtrans_bind_r'; eauto. -Qed. - -Lemma trans_trigger : forall {E B X Y} (e : E X) x (k : X -> ctree E B Y), - trans (obs e x) (trigger e >>= k) (k x). +(* Lemma wtrans_bind_lr {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) (v : ctree E B Y) x l : *) +(* pwtrans l t u -> *) +(* wtrans (val x) u Stuck -> *) +(* pwtrans τ (k x) v -> *) +(* (wtrans l (t >>= k) v). *) +(* Proof. *) +(* intros [t2 [t1 TR1 TR1'] TR1''] TR2 TR3. *) +(* exists (x <- t2;; k x). *) +(* - assert (~ is_val l). *) +(* { *) +(* destruct l; try now intros abs; inv abs. *) +(* exfalso. *) +(* pose proof (trans_val_invT TR1'); subst. *) +(* apply trans_val_inv in TR1'. *) +(* rewrite TR1' in TR1''. *) +(* apply transs_is_stuck_inv in TR1''; [| apply Stuck_is_stuck]. *) +(* rewrite <- TR1'' in TR2. *) +(* apply wtrans_is_stuck_inv in TR2; [| apply Stuck_is_stuck]. *) +(* destruct TR2 as [abs _]; inv abs. *) +(* } *) +(* eexists. *) +(* 2:apply trans_etrans, trans_bind_l; eauto. *) +(* apply wtrans_τ; eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_τ; auto]. *) +(* - apply wtrans_τ. *) +(* eapply wconss. *) +(* eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_τ; eauto]. *) +(* eapply wtrans_bind_r'; eauto. *) +(* Qed. *) + +Lemma trans_trigger : forall {E B X Y} (e : E X) (k : X -> ctree E B Y), + trans (ask e) (trigger e >>= k) (β e k). Proof. intros. unfold CTree.trigger. @@ -1774,8 +1916,8 @@ Proof. constructor; auto. Qed. -Lemma trans_trigger' : forall {E B X Y} (e : E X) x (t : ctree E B Y), - trans (obs e x) (trigger e;; t) t. +Lemma trans_trigger' : forall {E B X Y} (e : E X) (t : ctree E B Y), + trans (ask e) (trigger e;; t) (β e (fun _ => t)). Proof. intros. unfold CTree.trigger. @@ -1786,26 +1928,24 @@ Qed. Lemma trans_trigger_inv : forall {E B X Y} (e : E X) (k : X -> ctree E B Y) l u, trans l (trigger e >>= k) u -> - exists x, u ≅ k x /\ l = obs e x. + Seq u (β e k) /\ l = ask e. Proof. intros * TR. unfold trigger in TR. - apply trans_bind_inv in TR. - destruct TR as [(? & ? & TR & ?) |(? & TR & ?)]. - - apply trans_vis_inv in TR. - destruct TR as (? & ? & ->); eexists; split; eauto. - rewrite H0, H1, bind_ret_l; reflexivity. - - apply trans_vis_inv in TR. - destruct TR as (? & ? & abs); inv abs. + rewrite bind_vis in TR. + apply trans_vis_inv' in TR as [EQ ->]. + setoid_rewrite bind_ret_l in EQ. + split; auto. Qed. Lemma trans_branch : forall {E B : Type -> Type} {X : Type} {Y : Type} [l : label] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y), - trans l t t' -> k x ≅ t -> trans l (branch c >>= k) t'. + trans l (k x) t' -> + trans l (branch c >>= k) t'. Proof. intros. - setoid_rewrite bind_branch. + rewrite bind_branch. eapply trans_br; eauto. Qed. @@ -1842,185 +1982,185 @@ Proof. specialize (H0 X0 x eq_refl). subst. eauto. Qed. -(*| If the LTS has events of type [L +' R] then - it is possible to step it as either an [L] LTS - or [R] LTS ignoring the other. -*) -Section Coproduct. - Arguments label: clear implicits. - Context {L R C: Type -> Type} {X: Type}. - Notation S := (ctree (L +' R) C X). - Notation S' := (ctree' (L +' R) C X). - Notation SP := (SS -> label (L +' R) -> Prop). - - (* Skip an [R] event *) - Inductive srtrans_: rel S' S' := - | IgnoreR {X} (e : R X) k x t : - srtrans_ (observe (k x)) t -> - srtrans_ (VisF (inr1 e) k) t. - - (* Skip an [L] event *) - Inductive sltrans_: rel S' S' := - | IgnoreL {X} (e : L X) k x t : - sltrans_ (observe (k x)) t -> - sltrans_ (VisF (inl1 e) k) t. - - Hint Constructors srtrans_ sltrans_: core. - - (* Make those relations that respect equality [srel] *) - Program Definition srtrans : srel SS SS := - {| hrel_of := (fun (u v: SS) => srtrans_ (observe u) (observe v)) |}. - Next Obligation. split; induction 1; auto. Defined. - - Program Definition sltrans : srel SS SS := - {| hrel_of := (fun (u v: SS) => sltrans_ (observe u) (observe v)) |}. - Next Obligation. split; induction 1; auto. Defined. - - (*| Obs transition on the left, ignores right transitions and [τ] |*) - Definition ltrans {X}(l: L X)(x: X): srel SS SS := - (trans τ ⊔ srtrans)^* ⋅ trans (obs (inl1 l) x) ⋅ (trans τ ⊔ srtrans)^*. - - (*| Obs transition on the right, ignores left transitions and [τ] |*) - Definition rtrans {X}(r: R X)(x: X): srel SS SS := - (trans τ ⊔ sltrans)^* ⋅ trans (obs (inr1 r) x) ⋅ (trans τ ⊔ sltrans)^*. - -End Coproduct. +(* (*| If the LTS has events of type [L +' R] then *) +(* it is possible to step it as either an [L] LTS *) +(* or [R] LTS ignoring the other. *) +(* *) *) +(* Section Coproduct. *) +(* Arguments label: clear implicits. *) +(* Context {L R C: Type -> Type} {X: Type}. *) +(* Notation S := (ctree (L +' R) C X). *) +(* Notation S' := (ctree' (L +' R) C X). *) +(* Notation SP := (SS -> label (L +' R) -> Prop). *) + +(* (* Skip an [R] event *) *) +(* Inductive srtrans_: rel S' S' := *) +(* | IgnoreR {X} (e : R X) k x t : *) +(* srtrans_ (observe (k x)) t -> *) +(* srtrans_ (VisF (inr1 e) k) t. *) + +(* (* Skip an [L] event *) *) +(* Inductive sltrans_: rel S' S' := *) +(* | IgnoreL {X} (e : L X) k x t : *) +(* sltrans_ (observe (k x)) t -> *) +(* sltrans_ (VisF (inl1 e) k) t. *) + +(* Hint Constructors srtrans_ sltrans_: core. *) + +(* (* Make those relations that respect equality [srel] *) *) +(* Program Definition srtrans : srel SS SS := *) +(* {| hrel_of := (fun (u v: SS) => srtrans_ (observe u) (observe v)) |}. *) +(* Next Obligation. split; induction 1; auto. Defined. *) + +(* Program Definition sltrans : srel SS SS := *) +(* {| hrel_of := (fun (u v: SS) => sltrans_ (observe u) (observe v)) |}. *) +(* Next Obligation. split; induction 1; auto. Defined. *) + +(* (*| Obs transition on the left, ignores right transitions and [τ] |*) *) +(* Definition ltrans {X}(l: L X)(x: X): srel SS SS := *) +(* (trans τ ⊔ srtrans)^* ⋅ trans (obs (inl1 l) x) ⋅ (trans τ ⊔ srtrans)^*. *) + +(* (*| Obs transition on the right, ignores left transitions and [τ] |*) *) +(* Definition rtrans {X}(r: R X)(x: X): srel SS SS := *) +(* (trans τ ⊔ sltrans)^* ⋅ trans (obs (inr1 r) x) ⋅ (trans τ ⊔ sltrans)^*. *) + +(* End Coproduct. *) (*| [inv_trans] is an helper tactic to automatically invert hypotheses involving [trans]. |*) -#[local] Notation trans' l t u := (hrel_of (trans l) t u). - -Ltac inv_trans_one := - match goal with - - (* Ret *) - | h : trans' _ (Ret ?x) _ |- _ => - let EQl := fresh "EQl" in - apply trans_ret_inv in h as [?EQ EQl]; - match type of EQl with - | val _ = val _ => apply val_eq_inv in EQl; try (inversion EQl; fail) - | τ = val _ => now inv EQl - | obs _ _ = val _ => now inv EQl - | _ => idtac - end - - (* Vis *) - | h : trans' _ (Vis ?e ?k) _ |- _ => - let EQl := fresh "EQl" in - apply trans_vis_inv in h as (?x & ?EQ & EQl); - match type of EQl with - | @obs _ ?X _ _ = obs _ _ => - let EQt := fresh "EQt" in - let EQe := fresh "EQe" in - let EQv := fresh "EQv" in - apply obs_eq_invT in EQl as EQt; - subst_hyp_in EQt h; - apply obs_eq_inv in EQl as [EQe EQv]; - try (inversion EQv; inversion EQe; fail) - | val _ = obs _ _ => now inv EQl - | τ = obs _ _ => now inv EQl - | _ => idtac - end - - (* Step *) - | h : trans' _ (Step _) _ |- _ => - let EQl := fresh "EQl" in - apply trans_step_inv in h as (?EQ & EQl); - match type of EQl with - | τ = τ => clear EQl - | val _ = τ => now inv EQl - | obs _ _ = τ => now inv EQl - | _ => idtac - end - - (* BrS *) - | h : trans' _ (BrS ?n ?k) _ |- _ => - let x := fresh "x" in - let EQl := fresh "EQl" in - apply trans_brS_inv in h as (x & ?EQ & EQl); - match type of EQl with - | τ = τ => clear EQl - | val _ = τ => now inv EQl - | obs _ _ = τ => now inv EQl - | _ => idtac - end - - (* brS2 *) - | h : trans' _ (brS2 _ _) _ |- _ => - let EQl := fresh "EQl" in - apply trans_brS2_inv in h as (EQl & [?EQ | ?EQ]); - match type of EQl with - | τ = τ => clear EQl - | val _ = τ => now inv EQl - | obs _ _ = τ => now inv EQl - | _ => idtac - end - - (* brS3 *) - | h : trans' _ (brS3 _ _ _) _ |- _ => - let EQl := fresh "EQl" in - apply trans_brS3_inv in h as (EQl & [?EQ | [?EQ | ?EQ]]); - match type of EQl with - | τ = τ => clear EQl - | val _ = τ => now inv EQl - | obs _ _ = τ => now inv EQl - | _ => idtac - end - - (* brS4 *) - | h : trans' _ (brS4 _ _ _ _) _ |- _ => - let EQl := fresh "EQl" in - apply trans_brS4_inv in h as (EQl & [?EQ | [?EQ | [?EQ | ?EQ]]]); - match type of EQl with - | τ = τ => clear EQl - | val _ = τ => now inv EQl - | obs _ _ = τ => now inv EQl - | _ => idtac - end - - (* Guard *) - | h : trans' _ (Guard _) _ |- _ => - apply trans_guard_inv in h - - (* Br *) - | h : trans' _ (Br ?n ?k) _ |- _ => - let x := fresh "x" in - apply trans_br_inv in h as (x & ?TR) - - (* br2 *) - | h : trans' _ (br2 _ _) _ |- _ => - apply trans_br2_inv in h as [?TR | ?TR] - - (* br3 *) - | h : trans' _ (br3 _ _ _) _ |- _ => - apply trans_br3_inv in h as [?TR | [?TR | ?TR]] - - (* br4 *) - | h : trans' _ (br4 _ _ _ _) _ |- _ => - apply trans_br4_inv in h as [?TR | [?TR | [?TR | ?TR]]] - - (* Stuck *) - | h : trans' _ Stuck _ |- _ => - exfalso; eapply Stuck_is_stuck; now apply h - (* (* stuckS *) *) - (* | h : trans' _ stuckS _ |- _ => *) - (* exfalso; eapply stuckS_is_stuck; now apply h *) - - (* trigger *) - | h : trans' _ (CTree.bind (CTree.trigger ?e) ?t) _ |- _ => - apply trans_trigger_inv in h as (?x & ?EQ & ?EQl) - - end; try subs -. - -Ltac inv_trans := repeat inv_trans_one. +(* #[local] Notation trans' l t u := (hrel_of (trans l) t u). *) + +(* Ltac inv_trans_one := *) +(* match goal with *) + +(* (* Ret *) *) +(* | h : trans' _ (Ret ?x) _ |- _ => *) +(* let EQl := fresh "EQl" in *) +(* apply trans_ret_inv in h as [?EQ EQl]; *) +(* match type of EQl with *) +(* | val _ = val _ => apply val_eq_inv in EQl; try (inversion EQl; fail) *) +(* | τ = val _ => now inv EQl *) +(* | obs _ _ = val _ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* Vis *) *) +(* | h : trans' _ (Vis ?e ?k) _ |- _ => *) +(* let EQl := fresh "EQl" in *) +(* apply trans_vis_inv in h as (?x & ?EQ & EQl); *) +(* match type of EQl with *) +(* | @obs _ ?X _ _ = obs _ _ => *) +(* let EQt := fresh "EQt" in *) +(* let EQe := fresh "EQe" in *) +(* let EQv := fresh "EQv" in *) +(* apply obs_eq_invT in EQl as EQt; *) +(* subst_hyp_in EQt h; *) +(* apply obs_eq_inv in EQl as [EQe EQv]; *) +(* try (inversion EQv; inversion EQe; fail) *) +(* | val _ = obs _ _ => now inv EQl *) +(* | τ = obs _ _ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* Step *) *) +(* | h : trans' _ (Step _) _ |- _ => *) +(* let EQl := fresh "EQl" in *) +(* apply trans_step_inv in h as (?EQ & EQl); *) +(* match type of EQl with *) +(* | τ = τ => clear EQl *) +(* | val _ = τ => now inv EQl *) +(* | obs _ _ = τ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* BrS *) *) +(* | h : trans' _ (BrS ?n ?k) _ |- _ => *) +(* let x := fresh "x" in *) +(* let EQl := fresh "EQl" in *) +(* apply trans_brS_inv in h as (x & ?EQ & EQl); *) +(* match type of EQl with *) +(* | τ = τ => clear EQl *) +(* | val _ = τ => now inv EQl *) +(* | obs _ _ = τ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* brS2 *) *) +(* | h : trans' _ (brS2 _ _) _ |- _ => *) +(* let EQl := fresh "EQl" in *) +(* apply trans_brS2_inv in h as (EQl & [?EQ | ?EQ]); *) +(* match type of EQl with *) +(* | τ = τ => clear EQl *) +(* | val _ = τ => now inv EQl *) +(* | obs _ _ = τ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* brS3 *) *) +(* | h : trans' _ (brS3 _ _ _) _ |- _ => *) +(* let EQl := fresh "EQl" in *) +(* apply trans_brS3_inv in h as (EQl & [?EQ | [?EQ | ?EQ]]); *) +(* match type of EQl with *) +(* | τ = τ => clear EQl *) +(* | val _ = τ => now inv EQl *) +(* | obs _ _ = τ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* brS4 *) *) +(* | h : trans' _ (brS4 _ _ _ _) _ |- _ => *) +(* let EQl := fresh "EQl" in *) +(* apply trans_brS4_inv in h as (EQl & [?EQ | [?EQ | [?EQ | ?EQ]]]); *) +(* match type of EQl with *) +(* | τ = τ => clear EQl *) +(* | val _ = τ => now inv EQl *) +(* | obs _ _ = τ => now inv EQl *) +(* | _ => idtac *) +(* end *) + +(* (* Guard *) *) +(* | h : trans' _ (Guard _) _ |- _ => *) +(* apply trans_guard_inv in h *) + +(* (* Br *) *) +(* | h : trans' _ (Br ?n ?k) _ |- _ => *) +(* let x := fresh "x" in *) +(* apply trans_br_inv in h as (x & ?TR) *) + +(* (* br2 *) *) +(* | h : trans' _ (br2 _ _) _ |- _ => *) +(* apply trans_br2_inv in h as [?TR | ?TR] *) + +(* (* br3 *) *) +(* | h : trans' _ (br3 _ _ _) _ |- _ => *) +(* apply trans_br3_inv in h as [?TR | [?TR | ?TR]] *) + +(* (* br4 *) *) +(* | h : trans' _ (br4 _ _ _ _) _ |- _ => *) +(* apply trans_br4_inv in h as [?TR | [?TR | [?TR | ?TR]]] *) + +(* (* Stuck *) *) +(* | h : trans' _ Stuck _ |- _ => *) +(* exfalso; eapply Stuck_is_stuck; now apply h *) +(* (* (* stuckS *) *) *) +(* (* | h : trans' _ stuckS _ |- _ => *) *) +(* (* exfalso; eapply stuckS_is_stuck; now apply h *) *) + +(* (* trigger *) *) +(* | h : trans' _ (CTree.bind (CTree.trigger ?e) ?t) _ |- _ => *) +(* apply trans_trigger_inv in h as (?x & ?EQ & ?EQl) *) + +(* end; try subs *) +(* . *) + +(* Ltac inv_trans := repeat inv_trans_one. *) Create HintDb trans. #[global] Hint Resolve - trans_ret trans_vis trans_brS trans_br + trans_ret trans_ask trans_brS trans_br trans_guard trans_br21 trans_br22 trans_br31 trans_br32 trans_br33 @@ -2029,12 +2169,13 @@ Create HintDb trans. trans_brS21 trans_brS22 trans_brS31 trans_brS32 trans_brS33 trans_brS41 trans_brS42 trans_brS43 trans_brS44 - trans_trigger trans_bind_l trans_bind_r + trans_trigger trans_bind_l_τ trans_bind_l_ask trans_bind_r : trans. #[global] Hint Constructors is_val : trans. #[global] Hint Resolve - is_val_τ is_val_obs + is_val_τ + (* is_val_obs *) wf_val_val wf_val_nonval wf_val_trans : trans. Ltac etrans := eauto with trans. From 798b082a15f5ef4a2b650dd51a1747617dbc4e53 Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 27 Oct 2025 17:09:29 +0100 Subject: [PATCH 05/61] Fixed upto bind --- theories/Eq/SSim.v | 265 ++++++++++++++++++++++---------------------- theories/Eq/Trans.v | 64 ++++------- 2 files changed, 152 insertions(+), 177 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 289a129..cbd2286 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -38,7 +38,7 @@ Pous'16 in order to be able to exploit symmetry arguments in proofs |*) Program Definition ss {E F C D : Type -> Type} {X Y : Type} (L : rel (@label E) (@label F)) : - mon (ctree E C X -> ctree F D Y -> Prop) := + mon (@S E C X -> @S F D Y -> Prop) := {| body R t u := forall l t', trans l t t' -> exists l' u', trans l' u u' /\ R t' u' /\ L l l' |}. @@ -166,6 +166,22 @@ Section ssim_heterogenous_theory. rewrite <- Equu; auto. Qed. + #[global] Instance seq_clos_sst_goal {c: Chain (ss L)} : + Proper (Seq ==> Seq ==> flip impl) (`c). + Proof. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' EQt u u' EQu HS l v TR. + rewrite EQt in TR. + apply HS in TR as (l' & v' & ? & ? & ?). + exists l',v'; split; auto. + now rewrite EQu. + Qed. + #[global] Instance equ_clos_sst_goal {c: Chain (ss L)} : Proper (equ eq ==> equ eq ==> flip impl) `c. Proof. @@ -234,49 +250,54 @@ Section ssim_heterogenous_theory. End ssim_heterogenous_theory. -Definition Lequiv {E F} X Y (L L' : rel (@label E) (@label F)) := - forall l l', wf_val X l -> wf_val Y l' -> - L l l' <-> L' l l'. - -#[global] Instance weq_Lequiv : forall {E F} X Y, - subrelation weq (@Lequiv E F X Y). +#[global] Instance weq_ssim : forall {E F C D X Y}, + Proper (weq ==> weq) (@ssim E F C D X Y). Proof. - red. red. intros. apply H. + cbn -[ss weq]. intros. apply gfp_weq. now apply weq_ss. Qed. -#[global] Instance Equivalence_Lequiv : forall {E F} X Y, - Equivalence (@Lequiv E F X Y). -Proof. - split; cbn; intros. - - now apply weq_Lequiv. - - red. intros. red in H. rewrite H; auto. - - red. intros. - etransitivity. apply H; auto. apply H0; auto. -Qed. +Section LabelRelation. -#[global] Instance Lequiv_ss_goal : forall {E F C D X Y}, - Proper (Lequiv X Y ==> leq) (@ss E F C D X Y). -Proof. - cbn. intros. - apply H0 in H1 as ?. destruct H2 as (? & ? & ? & ? & ?). - exists x0, x1. split; auto. split; auto. apply H; etrans. -Qed. + Context {E F : Type -> Type} {X Y : Type}. -#[global] Instance Lequiv_ssim : forall {E F C D X Y}, - Proper (Lequiv X Y ==> leq) (@ssim E F C D X Y). -Proof. - cbn. intros. - - unfold ssim. - epose proof (gfp_leq (x := ss x) (y := ss y)). lapply H1. - + intro. red in H2. cbn in H2. apply H2. unfold ssim in H0. apply H0. - + now rewrite H. -Qed. + Variant build_rel + {RR: rel X Y} + {Rask: forall {X Y}, E X -> F Y -> Prop} + {Rrcv: forall {X Y} {e : E X} {f : F Y}, Rask e f -> X -> Y -> Prop} + : hrel (@label E) (@label F) := + | rel_τ : build_rel τ τ + | rel_ask {X Y} {e : E X} {f : F Y}: Rask e f -> build_rel (ask e) (ask f) + | rel_rcv {X Y} {e : E X} {f : F Y} x y + (Hrcv: forall (HR: Rask e f), Rrcv HR x y) : + build_rel (rcv e x) (rcv f y) + | rel_ret {x : X} {y : Y}: + RR x y -> build_rel (val x) (val y). + Arguments build_rel : clear implicits. + + Definition good_rel (L : hrel (@label E) (@label F)) RR Rask Rrcv := + L == build_rel RR Rask Rrcv. -#[global] Instance weq_ssim : forall {E F C D X Y}, - Proper (weq ==> weq) (@ssim E F C D X Y). -Proof. - cbn -[ss weq]. intros. apply gfp_weq. now apply weq_ss. -Qed. + Lemma build_rel_val RR Rask Rrcv x y : + build_rel RR Rask Rrcv (val x) (val y) -> RR x y. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_ask RR Rask Rrcv A B (e : E A) (f : F B) : + build_rel RR Rask Rrcv (ask e) (ask f) -> Rask _ _ e f. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_rcv RR Rask Rrcv A B (e : E A) (f : F B) a b HR : + build_rel RR Rask Rrcv (rcv e a) (rcv f b) -> Rrcv _ _ e f HR a b. + Proof. + intros H; dependent induction H. + apply Hrcv. + Qed. + +End LabelRelation. +#[global] Hint Constructors build_rel : trans. (*| Up-to [bind] context simulations @@ -285,129 +306,103 @@ We have proved in the module [Equ] that up-to bind context is a valid enhancement to prove [equ]. We now prove the same result, but for strong simulation. |*) - + Section bind. Arguments label: clear implicits. Obligation Tactic := idtac. Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : hrel (@label E) (@label F)) (R0 : rel X Y). - - (* Mix of R0 for val and L for tau/obs. *) - Variant update_val_rel : @label E -> @label F -> Prop := - | update_Val (v1 : X) (v2 : Y) : R0 v1 v2 -> update_val_rel (val v1) (val v2) - | update_NonVal l1 l2 : ~is_val l1 -> ~is_val l2 -> L l1 l2 -> update_val_rel l1 l2 + (L : hrel (@label E) (@label F)) + (RR: rel X' Y') + (Rask: forall X Y, E X -> F Y -> Prop) + (Rrcv: forall X Y {e : E X} {f : F Y}, Rask _ _ e f -> X -> Y -> Prop) + (SS: rel X Y) + (L' : hrel (@label E) (@label F)) + (HL : good_rel L RR Rask Rrcv) + (HL' : good_rel L' SS Rask Rrcv) . - Lemma update_val_rel_val : forall (v1 : X) (v2 : Y), - update_val_rel (val v1) (val v2) -> - R0 v1 v2. - Proof. - intros. remember (val v1) as l1. remember (val v2) as l2. - destruct H. - - apply val_eq_inv in Heql1, Heql2. now subst. - - subst. exfalso. now apply H. - Qed. - - Lemma update_val_rel_val_l : forall (v1 : X) l2, - update_val_rel (val v1) l2 -> - exists v2 : Y, l2 = val v2 /\ R0 v1 v2. - Proof. - intros. remember (val v1) as l1. destruct H. - - apply val_eq_inv in Heql1. subst. eauto. - - subst. exfalso. apply H. constructor. - Qed. - - Lemma update_val_rel_val_r : forall l1 (v2 : Y), - update_val_rel l1 (val v2) -> - exists v1 : X, l1 = val v1 /\ R0 v1 v2. - Proof. - intros. remember (val v2) as l2. destruct H. - - apply val_eq_inv in Heql2. subst. eauto. - - subst. exfalso. apply H0. constructor. - Qed. - - Lemma update_val_rel_nonval_l : forall l1 l2, - update_val_rel l1 l2 -> - ~is_val l1 -> - ~is_val l2 /\ L l1 l2. - Proof. - intros. destruct H. - - exfalso. apply H0. constructor. - - auto. - Qed. - - Lemma update_val_rel_nonval_r : forall l1 l2, - update_val_rel l1 l2 -> - ~is_val l2 -> - ~is_val l1 /\ L l1 l2. - Proof. - intros. destruct H. - - exfalso. apply H0. constructor. - - auto. - Qed. - - #[global] Instance Respects_val_update_val_rel : - Respects_val update_val_rel. - Proof. - constructor. intros. destruct H. - - split; etrans. - - tauto. - Qed. - - Definition is_update_val_rel (L0 : rel (@label E) (@label F)) : Prop := - Lequiv X Y update_val_rel L0. - - Lemma update_val_rel_correct : is_update_val_rel update_val_rel. - Proof. - red. red. reflexivity. - Qed. + Ltac refine_transition H := + match type of H with + | hrel_of (trans τ) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_τ_active H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + | hrel_of (trans (ask ?e)) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_ask_passive H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + end. (*| Specialization of [bind_ctx] to a function acting with [ssim] on the bound value, and with the argument (pointwise) on the continuation. |*) Lemma bind_chain_gen - (RR : rel (label E) (label F)) - (ISVR : is_update_val_rel RR) {R : Chain (@ss E F C D X' Y' L)} : - forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), - ssim RR t t' -> - (forall x x', R0 x x' -> elem R (k x) (k' x')) -> + forall (t : ctree E C X) (t' : ctree F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), + ssim L' t t' -> + (forall x y, SS x y -> elem R (k x) (k' y)) -> elem R (bind t k) (bind t' k'). Proof. apply tower. - intros ? INC ? ? ? ? tt' kk' ? ?. apply INC. apply H. apply tt'. intros x x' xx'. apply leq_infx in H. apply H. now apply kk'. - - intros ? ? ? ? ? ? tt' kk'. + - clear R. + intros R ? ? ? ? ? tt' kk'. step in tt'. cbn; intros * STEP. - apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | (v & STEPres & STEP)]. - + apply tt' in STEP as (? & ? & ? & ? & ?). + apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | [(Z & e & EQl & g & STEP & SEQ) | (v & STEPres & STEP)]]. + + subst l. + apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). + apply HL' in HRL; inv HRL. + refine_transition STEP'. do 2 eexists; split; [| split]. - apply trans_bind_l; eauto. - * intro Hl. destruct Hl. - apply ISVR in H3; etrans. - inversion H3; subst. apply H0. constructor. apply H5. constructor. + apply trans_bind_l_τ; eauto. * rewrite EQ. + apply H; auto. + intros. + now apply (b_chain R), kk'. + * apply HL; etrans. + + subst l. + apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). + apply HL' in HRL; dependent induction HRL. + refine_transition STEP'. + exists (ask f); eexists ; split; [| split]. + eapply trans_bind_l_ask; eauto. + * rewrite SEQ. + apply (b_chain R). + intros ? ? STEP''. + pose proof trans_passive_inv' STEP'' as (a & EQ & ->). + rewrite EQ in STEP''. + assert (TR: trans (rcv e a) (β e g) (g a)) by etrans. + step in HSIM; apply HSIM in TR as (l' & u' & TR' & HSIM' & HRL'). + pose proof trans_passive_inv' TR' as (b & EQ' & ->). + exists (rcv f b); eexists; split; eauto; split; cycle 1. + { apply HL. apply HL' in HRL'. constructor. dependent induction HRL'. auto. } + rewrite EQ. apply H. - apply H2. - intros * HR. - now apply (b_chain x), kk'. - * apply ISVR in H3; etrans. - destruct H3. exfalso. apply H0. constructor. eauto. - + apply tt' in STEPres as (u' & ? & STEPres & EQ' & ?). - apply ISVR in H0; etrans. - dependent destruction H0. - 2 : exfalso; apply H0; constructor. - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk' v v2 H0). - apply kk' in STEP as (u'' & ? & STEP & EQ'' & ?); cbn in *. - do 2 eexists; split. + rewrite EQ' in HSIM'; auto. + intros. + now apply (b_chain R), kk'. + * apply HL; etrans. + + apply tt' in STEPres as (? & ? & STEP' & HSIM & HRL). + apply HL' in HRL; dependent induction HRL. + apply (kk' v y) in STEP as (l' & u' & STEP'' & HSIM'' & HRL'). + exists l'; eexists; split; eauto. + 2:etrans. eapply trans_bind_r; eauto. - split; auto. + erewrite <- trans_val_inv'; eauto. Qed. End bind. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index d583df3..5dc0e48 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -384,6 +384,7 @@ Elimination rules for [trans] End Trans. +#[global] Infix "⩸" := Seq (at level 10). #[global] Hint Constructors Seq : core. #[global] Hint Constructors transR : core. @@ -396,29 +397,24 @@ Ltac rem_weak_ t s := Tactic Notation "rem_weak" constr(t) "as" ident(s) := rem_weak_ t s. -(* Class Respects_val {E F} (L : rel (@label E) (@label F)) := *) -(* { respects_val: *) -(* forall l l', *) -(* L l l' -> *) -(* is_val l <-> is_val l' }. *) +Class Respects_val {E F} (L : rel (@label E) (@label F)) := + { respects_val: + forall l l', + L l l' -> + is_val l <-> is_val l' }. -(* Class Respects_τ {E F} (L : rel (@label E) (@label F)) := *) -(* { respects_τ: forall l l', *) -(* L l l' -> *) -(* l = τ <-> l' = τ }. *) +Class Respects_τ {E F} (L : rel (@label E) (@label F)) := + { respects_τ: forall l l', + L l l' -> + l = τ <-> l' = τ }. -(* Definition eq_obs {E} (L : relation (@label E)) : Prop := *) -(* forall X X' e e' (x : X) (x' : X'), *) -(* L (obs e x) (obs e' x') -> *) -(* obs e x = obs e' x'. *) +#[global] Instance Respects_val_eq A: @Respects_val A A eq. +split; intros; subst; reflexivity. +Defined. -(* #[global] Instance Respects_val_eq A: @Respects_val A A eq. *) -(* split; intros; subst; reflexivity. *) -(* Defined. *) - -(* #[global] Instance Respects_τ_eq A: @Respects_τ A A eq. *) -(* split; intros; subst; reflexivity. *) -(* Defined. *) +#[global] Instance Respects_τ_eq A: @Respects_τ A A eq. +split; intros; subst; reflexivity. +Defined. Coercion Active : ctree >-> S. Notation "'α' t" := (Active t) (at level 100). @@ -1295,7 +1291,7 @@ Proof. apply trans_ask. Qed. -Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l : +Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u x l : trans (val x) t Stuck -> trans l (k x) u -> trans l (t >>= k) u. @@ -1311,22 +1307,6 @@ Proof. - intros TR2; rewrite H, bind_ret_l; auto. Qed. -Lemma trans_bind_r_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B Y) x : - trans (val x) t Stuck -> - trans (ask e) (k x) (β e g) -> - trans (ask e) (t >>= k) (β e g). -Proof. - cbn; intros TR1. - dependent induction TR1; cbn in *. - - intros TR2; rewrite H, bind_br. - apply trans_br with x0. - rewrite <- H0; eapply IHTR1; eauto. - - intros TR2; rewrite H, bind_guard. - apply trans_guard. - eapply IHTR1; eauto. - - intros TR2; rewrite H, bind_ret_l; auto. -Qed. - Lemma is_stuck_bind : forall {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y), is_stuck t -> is_stuck (bind t k). Proof. @@ -1831,7 +1811,7 @@ Proof. - rewrite <- EQ in *. clear v EQ. apply trans_wtrans. - eapply trans_bind_r_ask; eauto. + eapply trans_bind_r; eauto. - pose proof trans_τ_active TRv as [? EQ]. rewrite EQ in *; clear v0 EQ. eapply wcons. @@ -1868,8 +1848,8 @@ Qed. (* Qed. *) Lemma trans_val_invT {E B R R'} : - forall (t u : ctree E B R) (v : R'), - trans (val v) t u -> + forall t u (v : R'), + @trans E B R (val v) t u -> R = R'. Proof. intros * TR. @@ -1965,8 +1945,8 @@ Proof. red. intros. subst. exfalso. apply H. constructor. Qed. -Lemma wf_val_trans {E B X} (l : @label E) (t t' : ctree E B X) : - trans l t t' -> wf_val X l. +Lemma wf_val_trans {E B X} (l : @label E) t t' : + @trans E B X l t t' -> wf_val X l. Proof. red. intros. subst. now apply trans_val_invT in H. From 4dedeef61797c8282eaf8a02fe87834a1b5cc0a1 Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 29 Oct 2025 13:53:26 +0100 Subject: [PATCH 06/61] Iterating on the label relation interface --- theories/Core/Utils.v | 1 + theories/Eq/SSim.v | 273 +++++++++++++++++++++++++++--------------- theories/Eq/Trans.v | 6 +- 3 files changed, 181 insertions(+), 99 deletions(-) diff --git a/theories/Core/Utils.v b/theories/Core/Utils.v index 99a079e..c6a24a9 100644 --- a/theories/Core/Utils.v +++ b/theories/Core/Utils.v @@ -20,6 +20,7 @@ Polymorphic Class MonadStuck (M : Type -> Type) : Type := mstuck : forall X, M X. Notation rel X Y := (X -> Y -> Prop). +Notation rel1 E F := (forall X Y, E X -> E Y -> Prop). Ltac invert := match goal with diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index cbd2286..9d66cdb 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -37,7 +37,7 @@ Pous'16 in order to be able to exploit symmetry arguments in proofs (see [square_st] for an illustration). |*) Program Definition ss {E F C D : Type -> Type} {X Y : Type} - (L : rel (@label E) (@label F)) : + (L : rel (label E) (label F)) : mon (@S E C X -> @S F D Y -> Prop) := {| body R t u := forall l t', trans l t t' -> exists l' u', trans l' u u' /\ R t' u' /\ L l l' @@ -108,7 +108,7 @@ Tactic Notation "__coinduction_ssim" simple_intropattern(r) simple_intropattern( Section ssim_homogenous_theory. Context {E B: Type -> Type} {X: Type} - {L: relation (@label E)}. + {L: relation (label E)}. Notation ss := (@ss E E B B X X). @@ -140,7 +140,7 @@ Parametric theory of [ss] with heterogenous [L] Section ssim_heterogenous_theory. Arguments label: clear implicits. Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. + {L: rel (label E) (label F)}. Notation ss := (@ss E F C D X Y). Notation ssim := (@ssim E F C D X Y). @@ -256,49 +256,161 @@ Proof. cbn -[ss weq]. intros. apply gfp_weq. now apply weq_ss. Qed. -Section LabelRelation. - +Section build_rel. + Context {E F : Type -> Type} {X Y : Type}. Variant build_rel {RR: rel X Y} {Rask: forall {X Y}, E X -> F Y -> Prop} - {Rrcv: forall {X Y} {e : E X} {f : F Y}, Rask e f -> X -> Y -> Prop} - : hrel (@label E) (@label F) := + {Rrcv: forall {X Y} (e : E X) (f : F Y), X -> Y -> Prop} + : hrel (label E) (label F) := | rel_τ : build_rel τ τ - | rel_ask {X Y} {e : E X} {f : F Y}: Rask e f -> build_rel (ask e) (ask f) + | rel_ask {X Y} {e : E X} {f : F Y} + (HR : Rask e f) : + build_rel (ask e) (ask f) | rel_rcv {X Y} {e : E X} {f : F Y} x y - (Hrcv: forall (HR: Rask e f), Rrcv HR x y) : + (HR : Rrcv e f x y) : build_rel (rcv e x) (rcv f y) | rel_ret {x : X} {y : Y}: RR x y -> build_rel (val x) (val y). - Arguments build_rel : clear implicits. + Arguments build_rel : clear implicits. - Definition good_rel (L : hrel (@label E) (@label F)) RR Rask Rrcv := - L == build_rel RR Rask Rrcv. - Lemma build_rel_val RR Rask Rrcv x y : build_rel RR Rask Rrcv (val x) (val y) -> RR x y. Proof. now intros H; dependent induction H. Qed. - + Lemma build_rel_ask RR Rask Rrcv A B (e : E A) (f : F B) : build_rel RR Rask Rrcv (ask e) (ask f) -> Rask _ _ e f. Proof. now intros H; dependent induction H. Qed. - Lemma build_rel_rcv RR Rask Rrcv A B (e : E A) (f : F B) a b HR : - build_rel RR Rask Rrcv (rcv e a) (rcv f b) -> Rrcv _ _ e f HR a b. + Lemma build_rel_rcv RR Rask Rrcv A B (e : E A) (f : F B) a b : + build_rel RR Rask Rrcv (rcv e a) (rcv f b) -> Rrcv _ _ e f a b. Proof. - intros H; dependent induction H. - apply Hrcv. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_τ RR Rask Rrcv : + build_rel RR Rask Rrcv τ τ. + Proof. + constructor. Qed. -End LabelRelation. +End build_rel. + +Arguments build_rel {E F X Y} RR Rask Rrcv. #[global] Hint Constructors build_rel : trans. +Section good_rel. + + Context {E F : Type -> Type} {X Y : Type}. + + Definition good_rel {E F X Y} (L : hrel (label E) (label F)) RR Rask Rrcv := + L == @build_rel E F X Y RR Rask Rrcv. + + Context {L : rel (label E) (label F)}. + Context {RR : rel X Y} + {Rask: forall {X Y}, E X -> F Y -> Prop} + {Rrcv: forall {X Y} (e : E X) (f : F Y), X -> Y -> Prop}. + + Lemma good_rel_val x y : + good_rel L RR Rask Rrcv -> + RR x y <-> L (val x) (val y). + Proof. + intros HL; split; intros H. + apply HL; etrans. + apply HL in H; eapply build_rel_val; eauto. + Qed. + + Lemma good_rel_ask A B (e : E A) (f : F B) : + good_rel L RR Rask Rrcv -> + Rask e f <-> L (ask e) (ask f). + Proof. + intros HL; split; intros H. + apply HL; etrans. + apply HL in H; eapply build_rel_ask; eauto. + Qed. + + Lemma good_rel_rcv A B (e : E A) (f : F B) a b : + good_rel L RR Rask Rrcv -> + Rrcv e f a b <-> L (rcv e a) (rcv f b). + Proof. + intros HL; split; intros H. + apply HL; econstructor; intros; eauto. + apply HL in H; eapply build_rel_rcv; eauto. + Qed. + + Lemma good_rel_τ : + good_rel L RR Rask Rrcv -> + L τ τ. + Proof. + intros HL; apply HL; constructor. + Qed. + +End good_rel. + +Variant upd_rel {E F X Y} (L : rel (label E) (label F)) (RR : rel X Y): label E -> label F -> Prop := + | upd_val x y : RR x y -> upd_rel L RR (val x) (val y) + | upd_lab l1 l2 : ~is_val l1 -> ~is_val l2 -> L l1 l2 -> upd_rel L RR l1 l2 +. + +#[global] Hint Constructors upd_rel : trans. + +Lemma upd_good_rel {E F X Y X' Y'} + (L : rel (label E) (label F)) (RR : rel X Y) Rask Rrcv + (SS : rel X' Y') + (HL: good_rel L RR Rask Rrcv) : + good_rel (upd_rel L SS) SS Rask Rrcv. +Proof. + intros e f; split; intros H. + - inv H. + + etrans. + + apply HL in H2. + inv H2; etrans. + intuition. + - inv H; etrans. + all: constructor; etrans. + eapply good_rel_τ; eauto. + eapply good_rel_ask; eauto. + eapply good_rel_rcv; eauto. +Qed. + + +Variant eq1 {E} : forall [X Y : Type], rel (E X) (E Y) := + | Eq1 X (e : E X) : eq1 e e. +Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := + | Eq2 X (e : E X) x : eq2 e e x x. +Hint Resolve Eq1 : trans. +Hint Resolve Eq2 : trans. + +Definition Leq {E} (X : Type) : rel (label E) (label E) := @build_rel E E X X eq eq1 eq2. + +Definition Lvrel {E X Y} (RR : rel X Y) := @build_rel E E X Y RR eq1 eq2. + +Ltac refine_transition H := + match type of H with + | hrel_of (trans τ) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_τ_active H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + | hrel_of (trans (ask ?e)) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_ask_passive H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + end. + (*| Up-to [bind] context simulations ---------------------------------- @@ -312,36 +424,15 @@ Section bind. Obligation Tactic := idtac. Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : hrel (@label E) (@label F)) + (L : rel (label E) (label F)) (RR: rel X' Y') (Rask: forall X Y, E X -> F Y -> Prop) - (Rrcv: forall X Y {e : E X} {f : F Y}, Rask _ _ e f -> X -> Y -> Prop) + (Rrcv: forall X Y (e : E X) (f : F Y), X -> Y -> Prop) (SS: rel X Y) - (L' : hrel (@label E) (@label F)) + (L' : rel (label E) (label F)) (HL : good_rel L RR Rask Rrcv) (HL' : good_rel L' SS Rask Rrcv) . - - Ltac refine_transition H := - match type of H with - | hrel_of (trans τ) _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_τ_active H as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - | hrel_of (trans (ask ?e)) _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_ask_passive H as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - end. - (*| Specialization of [bind_ctx] to a function acting with [ssim] on the bound value, and with the argument (pointwise) on the continuation. @@ -407,19 +498,49 @@ and with the argument (pointwise) on the continuation. End bind. -Theorem update_val_rel_eq {E X} : Lequiv X X (@update_val_rel E E X X eq eq) eq. +(*| +Specializing the congruence principle for [≲] +|*) +Lemma ssim_clo_bind_gen E F C D X Y X' Y' L (RR : rel X' Y') Rask Rrcv (SS : rel X Y) L' + (HL : good_rel L RR Rask Rrcv) + (HL' : good_rel L' SS Rask Rrcv) + (t1 : ctree E C X) (t2: ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): + ssim L' t1 t2 -> + (forall x y, SS x y -> ssim L (k1 x) (k2 y)) -> + ssim L (t1 >>= k1) (t2 >>= k2). Proof. - split; intro. - - inv H1; reflexivity. - - subst. destruct l'. - + constructor; auto. - all: intro; inv H1. - + constructor; auto. - all: intro; inv H1. - + red in H. specialize (H X0 v eq_refl). subst. - constructor. reflexivity. + intros. + eapply bind_chain_gen; eauto. +Qed. + +Lemma ssim_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (label E) (label F)} + (R0 : rel X Y) + (t1 : ctree E C X) (t2: ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): + t1 (≲update_val_rel L R0) t2 -> + (forall x y, R0 x y -> k1 x (≲L) k2 y) -> + t1 >>= k1 (≲L) t2 >>= k2. +Proof. + intros. + eapply bind_chain_gen; eauto using update_val_rel_correct. Qed. +Lemma ssim_clo_bind_eq {E C D: Type -> Type} {X X': Type} + (t1 : ctree E C X) (t2: ctree E D X) + (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): + t1 ≲ t2 -> + (forall x, k1 x ≲ k2 x) -> + t1 >>= k1 ≲ t2 >>= k2. +Proof. + intros. + eapply bind_chain_gen; eauto. + - apply update_val_rel_eq. + - intros; subst. apply H0. +Qed. + + + #[global] Instance update_val_rel_Lequiv {E F X Y X' Y'} : Proper (Lequiv X' Y' ==> weq ==> Lequiv X Y) (@update_val_rel E F X Y). Proof. @@ -442,7 +563,7 @@ Proof. Qed. Theorem update_val_rel_update_val_rel {E F X0 X1 Y0 Y1} - (L : rel (@label E) (@label F)) (R0 : rel X0 Y0) (R1 : rel X1 Y1) : + (L : rel (label E) (label F)) (R0 : rel X0 Y0) (R1 : rel X1 Y1) : update_val_rel (update_val_rel L R0) R1 == update_val_rel L R1. Proof. split; intro. @@ -473,7 +594,7 @@ Proof. Qed. #[global] Instance Transitive_update_val_rel : - forall {E X} (L : relation (@label E)) (R0 : relation X), + forall {E X} (L : relation (label E)) (R0 : relation X), Transitive L -> Transitive R0 -> Transitive (update_val_rel L R0). @@ -487,48 +608,6 @@ Proof. Qed. Definition lift_val_rel {E X Y} := @update_val_rel E E X Y eq. - -(*| -Specializing the congruence principle for [≲] -|*) -Lemma ssim_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) L0 - (HL0 : is_update_val_rel L R0 L0) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - ssim L0 t1 t2 -> - (forall x y, R0 x y -> ssim L (k1 x) (k2 y)) -> - ssim L (t1 >>= k1) (t2 >>= k2). -Proof. - intros. - eapply bind_chain_gen; eauto. -Qed. - -Lemma ssim_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - t1 (≲update_val_rel L R0) t2 -> - (forall x y, R0 x y -> k1 x (≲L) k2 y) -> - t1 >>= k1 (≲L) t2 >>= k2. -Proof. - intros. - eapply bind_chain_gen; eauto using update_val_rel_correct. -Qed. - -Lemma ssim_clo_bind_eq {E C D: Type -> Type} {X X': Type} - (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): - t1 ≲ t2 -> - (forall x, k1 x ≲ k2 x) -> - t1 >>= k1 ≲ t2 >>= k2. -Proof. - intros. - eapply bind_chain_gen; eauto. - - apply update_val_rel_eq. - - intros; subst. apply H0. -Qed. - (*| And in particular, we can justify rewriting [≲] to the left of a [bind]. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 5dc0e48..e531aba 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -384,6 +384,7 @@ Elimination rules for [trans] End Trans. +Arguments label : clear implicits. #[global] Infix "⩸" := Seq (at level 10). #[global] Hint Constructors Seq : core. #[global] Hint Constructors transR : core. @@ -1920,7 +1921,7 @@ Qed. Lemma trans_branch : forall {E B : Type -> Type} {X : Type} {Y : Type} - [l : label] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y), + [l : label E] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y), trans l (k x) t' -> trans l (branch c >>= k) t'. Proof. @@ -2155,7 +2156,8 @@ Create HintDb trans. #[global] Hint Constructors is_val : trans. #[global] Hint Resolve is_val_τ - (* is_val_obs *) + is_val_ask + is_val_rcv wf_val_val wf_val_nonval wf_val_trans : trans. Ltac etrans := eauto with trans. From e6666e08d13f886f3ff9f01bf4ff36ccfa0c33ce Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 29 Oct 2025 16:49:42 +0100 Subject: [PATCH 07/61] Enforcing the shape of relations from the very definition of the simulation --- theories/Eq/SSim.v | 284 ++++++++++++++++++++++----------------------- 1 file changed, 136 insertions(+), 148 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 9d66cdb..30c1764 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -27,6 +27,124 @@ Set Implicit Arguments. (* TODO: Decide where to set this *) Arguments trans : simpl never. +Section build_rel. + + Context {E F : Type -> Type} {X Y : Type}. + + Record lrel := + { + RR: rel X Y ; + Rask: forall [X Y], E X -> F Y -> Prop ; + Rrcv: forall [X Y] (e : E X) (f : F Y), X -> Y -> Prop ; + }. + + Variant build_rel {RL : lrel} + : hrel (label E) (label F) := + | rel_τ : build_rel τ τ + | rel_ask {X Y} {e : E X} {f : F Y} + (HR : Rask RL e f) : + build_rel (ask e) (ask f) + | rel_rcv {X Y} {e : E X} {f : F Y} x y + (HR : Rrcv RL e f x y) : + build_rel (rcv e x) (rcv f y) + | rel_ret {x : X} {y : Y}: + RR RL x y -> build_rel (val x) (val y). + Arguments build_rel : clear implicits. + + Lemma build_rel_val RL x y : + build_rel RL (val x) (val y) -> RR RL x y. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_ask RL A B (e : E A) (f : F B) : + build_rel RL (ask e) (ask f) -> Rask RL e f. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_rcv RL A B (e : E A) (f : F B) a b : + build_rel RL (rcv e a) (rcv f b) -> Rrcv RL e f a b. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_τ RL : + build_rel RL τ τ. + Proof. + constructor. + Qed. + +End build_rel. + +Arguments lrel : clear implicits. +Arguments build_rel {E F X Y} RL. +#[global] Hint Constructors build_rel : trans. + +Definition upd_Lrel {E F X Y X' Y'} (RL : lrel E F X Y) (SS : rel X' Y') : lrel E F X' Y' := + {| + RR := SS ; + Rask := Rask RL ; + Rrcv := Rrcv RL + |}. + +Variant eq1 {E} : forall [X Y : Type], rel (E X) (E Y) := + | Eq1 X (e : E X) : eq1 e e. +Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := + | Eq2 X (e : E X) x : eq2 e e x x. +Hint Resolve Eq1 : trans. +Hint Resolve Eq2 : trans. + +Definition Leq {E} (X : Type) : lrel E E X X := + {| + RR := eq ; + Rask := eq1 ; + Rrcv := eq2 + |}. + +Definition Lvrel {E X Y} (RR : rel X Y) : lrel E E X Y := + {| + RR := RR ; + Rask := eq1 ; + Rrcv := eq2 + |}. + +Ltac ex := eexists. +Ltac ex2 := do 2 eexists. +Ltac ex3 := do 3 eexists. +Ltac split3 := split; [| split]. +Ltac edestruct3 H := edestruct H as (? & ? & ?). +Ltac edestruct4 H := edestruct H as (? & ? & ? & ?). +Ltac edestruct5 H := edestruct H as (? & ? & ? & ? & ?). + +Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := + fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. +#[global] Instance lequiv_equivalence {E F X Y} : Equivalence (@lequiv E F X Y). +Proof. + constructor. + - split3; auto. + - intros ?? [? []]; split3; symmetry; auto. + - intros ??? [? []] [? []]; split3; etransitivity; eauto. +Qed. + +#[global] Instance lequiv_build_rel {E F X Y} : Proper (lequiv ==> weq) (@build_rel E F X Y). +Proof. + cbn; intros L1 L2 [EQ1 [EQ2 EQ3]] l1 l2; split; intros H. + - inv H; etrans. + constructor; now apply EQ2. + constructor; now apply EQ3. + constructor; now apply EQ1. + - inv H; etrans. + constructor; now apply EQ2. + constructor; now apply EQ3. + constructor; now apply EQ1. +Qed. + +#[global] Instance lequiv_build_rel' {E F X Y} : Proper (lequiv ==> eq ==> eq ==> iff) (@build_rel E F X Y). +Proof. + now cbn; intros; subst; eapply lequiv_build_rel. +Qed. + Section StrongSim. (*| The function defining strong simulations: [trans] plays must be answered @@ -37,23 +155,28 @@ Pous'16 in order to be able to exploit symmetry arguments in proofs (see [square_st] for an illustration). |*) Program Definition ss {E F C D : Type -> Type} {X Y : Type} - (L : rel (label E) (label F)) : + (L : lrel E F X Y) : mon (@S E C X -> @S F D Y -> Prop) := {| body R t u := - forall l t', trans l t t' -> exists l' u', trans l' u u' /\ R t' u' /\ L l l' + forall l t', trans l t t' -> + exists l' u', trans l' u u' /\ + R t' u' /\ + build_rel L l l' |}. Next Obligation. - edestruct H0 as (u' & l' & ?); eauto. - eexists; eexists; intuition; eauto. + edestruct3 H0; eauto. + ex2; intuition; eauto. Qed. - #[global] Instance weq_ss : forall {E F C D X Y}, Proper (weq ==> weq) (@ss E F C D X Y). + #[global] Instance lequiv_ss : forall {E F C D X Y}, Proper (lequiv ==> weq) (@ss E F C D X Y). Proof. - cbn. intros. split. - - intros. apply H0 in H1 as (? & ? & ? & ? & ?). - exists x0, x1. intuition. now apply H. - - intros. apply H0 in H1 as (? & ? & ? & ? & ?). - exists x0, x1. intuition. now apply H. + cbn. intros * EQ *. split. + - intros. apply H in H0 as (? & ? & ? & ? & ?). + ex2; split3; eauto. + now rewrite <- EQ. + - intros. apply H in H0 as (? & ? & ? & ? & ?). + ex2; split3; eauto. + now rewrite EQ. Qed. End StrongSim. @@ -63,10 +186,10 @@ Definition ssim {E F C D X Y} L := Module SSimNotations. - Infix "≲" := (ssim eq) (at level 70). + Infix "≲" := (ssim Leq) (at level 70). Notation "t (≲ Q ) u" := (ssim Q t u) (at level 79). Notation "t '[≲' R ']' u" := (ss R (` _) t u) (at level 90, only printing). - Notation "t '[≲]' u" := (ss eq (` _) t u) (at level 90, only printing). + Notation "t '[≲]' u" := (ss Leq (` _) t u) (at level 90, only printing). End SSimNotations. @@ -108,7 +231,7 @@ Tactic Notation "__coinduction_ssim" simple_intropattern(r) simple_intropattern( Section ssim_homogenous_theory. Context {E B: Type -> Type} {X: Type} - {L: relation (label E)}. + {L: lrel E E X X}. Notation ss := (@ss E E B B X X). @@ -256,141 +379,6 @@ Proof. cbn -[ss weq]. intros. apply gfp_weq. now apply weq_ss. Qed. -Section build_rel. - - Context {E F : Type -> Type} {X Y : Type}. - - Variant build_rel - {RR: rel X Y} - {Rask: forall {X Y}, E X -> F Y -> Prop} - {Rrcv: forall {X Y} (e : E X) (f : F Y), X -> Y -> Prop} - : hrel (label E) (label F) := - | rel_τ : build_rel τ τ - | rel_ask {X Y} {e : E X} {f : F Y} - (HR : Rask e f) : - build_rel (ask e) (ask f) - | rel_rcv {X Y} {e : E X} {f : F Y} x y - (HR : Rrcv e f x y) : - build_rel (rcv e x) (rcv f y) - | rel_ret {x : X} {y : Y}: - RR x y -> build_rel (val x) (val y). - Arguments build_rel : clear implicits. - - Lemma build_rel_val RR Rask Rrcv x y : - build_rel RR Rask Rrcv (val x) (val y) -> RR x y. - Proof. - now intros H; dependent induction H. - Qed. - - Lemma build_rel_ask RR Rask Rrcv A B (e : E A) (f : F B) : - build_rel RR Rask Rrcv (ask e) (ask f) -> Rask _ _ e f. - Proof. - now intros H; dependent induction H. - Qed. - - Lemma build_rel_rcv RR Rask Rrcv A B (e : E A) (f : F B) a b : - build_rel RR Rask Rrcv (rcv e a) (rcv f b) -> Rrcv _ _ e f a b. - Proof. - now intros H; dependent induction H. - Qed. - - Lemma build_rel_τ RR Rask Rrcv : - build_rel RR Rask Rrcv τ τ. - Proof. - constructor. - Qed. - -End build_rel. - -Arguments build_rel {E F X Y} RR Rask Rrcv. -#[global] Hint Constructors build_rel : trans. - -Section good_rel. - - Context {E F : Type -> Type} {X Y : Type}. - - Definition good_rel {E F X Y} (L : hrel (label E) (label F)) RR Rask Rrcv := - L == @build_rel E F X Y RR Rask Rrcv. - - Context {L : rel (label E) (label F)}. - Context {RR : rel X Y} - {Rask: forall {X Y}, E X -> F Y -> Prop} - {Rrcv: forall {X Y} (e : E X) (f : F Y), X -> Y -> Prop}. - - Lemma good_rel_val x y : - good_rel L RR Rask Rrcv -> - RR x y <-> L (val x) (val y). - Proof. - intros HL; split; intros H. - apply HL; etrans. - apply HL in H; eapply build_rel_val; eauto. - Qed. - - Lemma good_rel_ask A B (e : E A) (f : F B) : - good_rel L RR Rask Rrcv -> - Rask e f <-> L (ask e) (ask f). - Proof. - intros HL; split; intros H. - apply HL; etrans. - apply HL in H; eapply build_rel_ask; eauto. - Qed. - - Lemma good_rel_rcv A B (e : E A) (f : F B) a b : - good_rel L RR Rask Rrcv -> - Rrcv e f a b <-> L (rcv e a) (rcv f b). - Proof. - intros HL; split; intros H. - apply HL; econstructor; intros; eauto. - apply HL in H; eapply build_rel_rcv; eauto. - Qed. - - Lemma good_rel_τ : - good_rel L RR Rask Rrcv -> - L τ τ. - Proof. - intros HL; apply HL; constructor. - Qed. - -End good_rel. - -Variant upd_rel {E F X Y} (L : rel (label E) (label F)) (RR : rel X Y): label E -> label F -> Prop := - | upd_val x y : RR x y -> upd_rel L RR (val x) (val y) - | upd_lab l1 l2 : ~is_val l1 -> ~is_val l2 -> L l1 l2 -> upd_rel L RR l1 l2 -. - -#[global] Hint Constructors upd_rel : trans. - -Lemma upd_good_rel {E F X Y X' Y'} - (L : rel (label E) (label F)) (RR : rel X Y) Rask Rrcv - (SS : rel X' Y') - (HL: good_rel L RR Rask Rrcv) : - good_rel (upd_rel L SS) SS Rask Rrcv. -Proof. - intros e f; split; intros H. - - inv H. - + etrans. - + apply HL in H2. - inv H2; etrans. - intuition. - - inv H; etrans. - all: constructor; etrans. - eapply good_rel_τ; eauto. - eapply good_rel_ask; eauto. - eapply good_rel_rcv; eauto. -Qed. - - -Variant eq1 {E} : forall [X Y : Type], rel (E X) (E Y) := - | Eq1 X (e : E X) : eq1 e e. -Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := - | Eq2 X (e : E X) x : eq2 e e x x. -Hint Resolve Eq1 : trans. -Hint Resolve Eq2 : trans. - -Definition Leq {E} (X : Type) : rel (label E) (label E) := @build_rel E E X X eq eq1 eq2. - -Definition Lvrel {E X Y} (RR : rel X Y) := @build_rel E E X Y RR eq1 eq2. - Ltac refine_transition H := match type of H with | hrel_of (trans τ) _ _ => From f2cdc1036e9afb3f1ba2a94e60cabfd6809928ea Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 29 Oct 2025 20:54:20 +0100 Subject: [PATCH 08/61] pushed back to upto bind with new setup --- theories/Eq/SSim.v | 86 +++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 46 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 30c1764..2bb6996 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -27,6 +27,26 @@ Set Implicit Arguments. (* TODO: Decide where to set this *) Arguments trans : simpl never. +Ltac refine_transition H := + match type of H with + | hrel_of (trans τ) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_τ_active H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + | hrel_of (trans (ask ?e)) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_ask_passive H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + end. + Section build_rel. Context {E F : Type -> Type} {X Y : Type}. @@ -80,6 +100,7 @@ End build_rel. Arguments lrel : clear implicits. Arguments build_rel {E F X Y} RL. #[global] Hint Constructors build_rel : trans. +Notation "↑ L" := (build_rel L) (at level 2). Definition upd_Lrel {E F X Y X' Y'} (RL : lrel E F X Y) (SS : rel X' Y') : lrel E F X' Y' := {| @@ -161,7 +182,7 @@ Pous'16 in order to be able to exploit symmetry arguments in proofs forall l t', trans l t t' -> exists l' u', trans l' u u' /\ R t' u' /\ - build_rel L l l' + ↑ L l l' |}. Next Obligation. edestruct3 H0; eauto. @@ -235,13 +256,13 @@ Section ssim_homogenous_theory. Notation ss := (@ss E E B B X X). - #[global] Instance refl_sst {LR: Reflexive L} {C: Chain (ss L)}: Reflexive `C. + #[global] Instance refl_sst {LR: Reflexive (↑ L)} {C: Chain (ss L)}: Reflexive `C. Proof. apply Reflexive_chain. cbn; eauto. Qed. - #[global] Instance square_sst {LT: Transitive L} {C: Chain (ss L)}: Transitive `C. + #[global] Instance square_sst {LT: Transitive (↑ L)} {C: Chain (ss L)}: Transitive `C. Proof. apply Transitive_chain. cbn. intros ????? xy yz. @@ -252,7 +273,7 @@ Section ssim_homogenous_theory. Qed. (*| PreOrder |*) - #[global] Instance PreOrder_sst {LPO: PreOrder L} {C: Chain (ss L)}: PreOrder `C. + #[global] Instance PreOrder_sst {LPO: PreOrder (↑ L)} {C: Chain (ss L)}: PreOrder `C. Proof. split; typeclasses eauto. Qed. End ssim_homogenous_theory. @@ -263,7 +284,7 @@ Parametric theory of [ss] with heterogenous [L] Section ssim_heterogenous_theory. Arguments label: clear implicits. Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (label E) (label F)}. + {L: lrel E F X Y}. Notation ss := (@ss E F C D X Y). Notation ssim := (@ssim E F C D X Y). @@ -374,31 +395,11 @@ Section ssim_heterogenous_theory. End ssim_heterogenous_theory. #[global] Instance weq_ssim : forall {E F C D X Y}, - Proper (weq ==> weq) (@ssim E F C D X Y). + Proper (lequiv ==> weq) (@ssim E F C D X Y). Proof. - cbn -[ss weq]. intros. apply gfp_weq. now apply weq_ss. + cbn -[ss weq]. intros. apply gfp_weq. now apply lequiv_ss. Qed. -Ltac refine_transition H := - match type of H with - | hrel_of (trans τ) _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_τ_active H as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - | hrel_of (trans (ask ?e)) _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_ask_passive H as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - end. - (*| Up-to [bind] context simulations ---------------------------------- @@ -412,15 +413,8 @@ Section bind. Obligation Tactic := idtac. Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : rel (label E) (label F)) - (RR: rel X' Y') - (Rask: forall X Y, E X -> F Y -> Prop) - (Rrcv: forall X Y (e : E X) (f : F Y), X -> Y -> Prop) - (SS: rel X Y) - (L' : rel (label E) (label F)) - (HL : good_rel L RR Rask Rrcv) - (HL' : good_rel L' SS Rask Rrcv) - . + (L : lrel E F X' Y') + (SS: rel X Y). (*| Specialization of [bind_ctx] to a function acting with [ssim] on the bound value, and with the argument (pointwise) on the continuation. @@ -429,7 +423,7 @@ and with the argument (pointwise) on the continuation. {R : Chain (@ss E F C D X' Y' L)} : forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), - ssim L' t t' -> + ssim (upd_Lrel L SS) t t' -> (forall x y, SS x y -> elem R (k x) (k' y)) -> elem R (bind t k) (bind t' k'). Proof. @@ -444,20 +438,20 @@ and with the argument (pointwise) on the continuation. apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | [(Z & e & EQl & g & STEP & SEQ) | (v & STEPres & STEP)]]. + subst l. apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). - apply HL' in HRL; inv HRL. + inv HRL. refine_transition STEP'. - do 2 eexists; split; [| split]. + ex2; split3. apply trans_bind_l_τ; eauto. * rewrite EQ. apply H; auto. intros. now apply (b_chain R), kk'. - * apply HL; etrans. + * etrans. + subst l. apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). - apply HL' in HRL; dependent induction HRL. + dependent induction HRL. refine_transition STEP'. - exists (ask f); eexists ; split; [| split]. + exists (ask f); ex; split3. eapply trans_bind_l_ask; eauto. * rewrite SEQ. apply (b_chain R). @@ -467,16 +461,16 @@ and with the argument (pointwise) on the continuation. assert (TR: trans (rcv e a) (β e g) (g a)) by etrans. step in HSIM; apply HSIM in TR as (l' & u' & TR' & HSIM' & HRL'). pose proof trans_passive_inv' TR' as (b & EQ' & ->). - exists (rcv f b); eexists; split; eauto; split; cycle 1. - { apply HL. apply HL' in HRL'. constructor. dependent induction HRL'. auto. } + exists (rcv f b); ex; split; eauto; split; cycle 1. + {dependent induction HRL'. etrans.} rewrite EQ. apply H. rewrite EQ' in HSIM'; auto. intros. now apply (b_chain R), kk'. - * apply HL; etrans. + * etrans. + apply tt' in STEPres as (? & ? & STEP' & HSIM & HRL). - apply HL' in HRL; dependent induction HRL. + dependent induction HRL. apply (kk' v y) in STEP as (l' & u' & STEP'' & HSIM'' & HRL'). exists l'; eexists; split; eauto. 2:etrans. From 850ca8846d6ded6c1c0fab63d8d59c945c04a9ef Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 30 Oct 2025 11:08:25 +0100 Subject: [PATCH 09/61] The family of bind lemmas. Need to think about the proper instance now that we have two kind of states --- theories/Eq/SSim.v | 195 ++++++++++++++++++--------------------------- 1 file changed, 77 insertions(+), 118 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 2bb6996..9c72d9b 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -116,7 +116,7 @@ Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := Hint Resolve Eq1 : trans. Hint Resolve Eq2 : trans. -Definition Leq {E} (X : Type) : lrel E E X X := +Definition Leq {E} {X : Type} : lrel E E X X := {| RR := eq ; Rask := eq1 ; @@ -140,6 +140,7 @@ Ltac edestruct5 H := edestruct H as (? & ? & ? & ? & ?). Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. + #[global] Instance lequiv_equivalence {E F X Y} : Equivalence (@lequiv E F X Y). Proof. constructor. @@ -208,10 +209,12 @@ Definition ssim {E F C D X Y} L := Module SSimNotations. Infix "≲" := (ssim Leq) (at level 70). + Notation "t (≲ [ Q ] ) u" := (ssim (Lvrel Q) t u) (at level 79). Notation "t (≲ Q ) u" := (ssim Q t u) (at level 79). - Notation "t '[≲' R ']' u" := (ss R (` _) t u) (at level 90, only printing). - Notation "t '[≲]' u" := (ss Leq (` _) t u) (at level 90, only printing). + Notation "t '[≲]' u" := (ss Leq (` _) t u) (at level 90, only printing). + Notation "t '[≲' [ R ] ']' u" := (ss (Lvrel R) (` _) t u) (at level 90, only printing). + Notation "t '[≲' R ']' u" := (ss R (` _) t u) (at level 90, only printing). End SSimNotations. Import SSimNotations. @@ -345,7 +348,7 @@ Section ssim_heterogenous_theory. Proof. intros t t' tt' u u' uu'; cbn; intros. rewrite tt' in H0. apply H in H0 as (l' & ? & ? & ? & ?). - do 2 eexists; eauto. rewrite uu'. eauto. + ex2; eauto. rewrite uu'. eauto. Qed. #[global] Instance equ_ss_closed_ctx {r} : @@ -353,7 +356,7 @@ Section ssim_heterogenous_theory. Proof. intros t t' tt' u u' uu'; cbn; intros. rewrite <- tt' in H0. apply H in H0 as (l' & ? & ? & ? & ?). - do 2 eexists; eauto. rewrite <- uu'. eauto. + ex2; eauto. rewrite <- uu'. eauto. Qed. (*| @@ -412,20 +415,20 @@ Section bind. Arguments label: clear implicits. Obligation Tactic := idtac. - Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : lrel E F X' Y') - (SS: rel X Y). (*| Specialization of [bind_ctx] to a function acting with [ssim] on the bound value, and with the argument (pointwise) on the continuation. |*) Lemma bind_chain_gen + {E F C D: Type -> Type} {X X' Y Y': Type} + (L : lrel E F X' Y') + (SS: rel X Y) {R : Chain (@ss E F C D X' Y' L)} : forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), ssim (upd_Lrel L SS) t t' -> - (forall x y, SS x y -> elem R (k x) (k' y)) -> - elem R (bind t k) (bind t' k'). + (forall x y, SS x y -> ` R (k x) (k' y)) -> + ` R (bind t k) (bind t' k'). Proof. apply tower. - intros ? INC ? ? ? ? tt' kk' ? ?. @@ -478,128 +481,84 @@ and with the argument (pointwise) on the continuation. erewrite <- trans_val_inv'; eauto. Qed. -End bind. - (*| -Specializing the congruence principle for [≲] +Specialization: equality on external calls, equality everywhere |*) -Lemma ssim_clo_bind_gen E F C D X Y X' Y' L (RR : rel X' Y') Rask Rrcv (SS : rel X Y) L' - (HL : good_rel L RR Rask Rrcv) - (HL' : good_rel L' SS Rask Rrcv) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - ssim L' t1 t2 -> - (forall x y, SS x y -> ssim L (k1 x) (k2 y)) -> - ssim L (t1 >>= k1) (t2 >>= k2). -Proof. - intros. - eapply bind_chain_gen; eauto. -Qed. - -Lemma ssim_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (label E) (label F)} - (R0 : rel X Y) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - t1 (≲update_val_rel L R0) t2 -> - (forall x y, R0 x y -> k1 x (≲L) k2 y) -> - t1 >>= k1 (≲L) t2 >>= k2. -Proof. - intros. - eapply bind_chain_gen; eauto using update_val_rel_correct. -Qed. - -Lemma ssim_clo_bind_eq {E C D: Type -> Type} {X X': Type} - (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): - t1 ≲ t2 -> - (forall x, k1 x ≲ k2 x) -> - t1 >>= k1 ≲ t2 >>= k2. -Proof. - intros. - eapply bind_chain_gen; eauto. - - apply update_val_rel_eq. - - intros; subst. apply H0. -Qed. - - - -#[global] Instance update_val_rel_Lequiv {E F X Y X' Y'} : - Proper (Lequiv X' Y' ==> weq ==> Lequiv X Y) (@update_val_rel E F X Y). -Proof. - cbn. red. intros. - red in H. split; intro. - - inv H3. - + left. apply H0. auto. - + right; auto. - apply H; auto; now apply wf_val_nonval. - - inv H3. - + left. apply H0. auto. - + right; auto. - apply H; auto; now apply wf_val_nonval. -Qed. + Lemma bind_chain E C D X Y X' Y' + (RR : rel X' Y') (SS : rel X Y) + {R : Chain (@ss E E C D X' Y' (Lvrel RR))} : + forall (t1 : ctree E C X) (t2: ctree E D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y'), + t1 (≲[SS]) t2 -> + (forall x y, SS x y -> `R (k1 x) (k2 y)) -> + `R (t1 >>= k1) (t2 >>= k2). + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. -#[global] Instance is_update_val_rel_Lequiv {E F X Y X' Y'} : - Proper (Lequiv X' Y' ==> weq ==> Lequiv X Y ==> flip impl) (@is_update_val_rel E F X Y). -Proof. - cbn -[weq]. red. intros. red in H2. subst. now rewrite H, H0, H1. -Qed. + Lemma bind_chain_eq E C X X' + {R : Chain (@ss E E C C X' X' Leq)} : + forall (t1 t2 : ctree E C X) + (k1 k2 : X -> ctree E C X'), + t1 ≲ t2 -> + (forall x, `R (k1 x) (k2 x)) -> + `R (t1 >>= k1) (t2 >>= k2). + Proof. + intros. + eapply bind_chain_gen; eauto. + intros ??<-; auto. + Qed. -Theorem update_val_rel_update_val_rel {E F X0 X1 Y0 Y1} - (L : rel (label E) (label F)) (R0 : rel X0 Y0) (R1 : rel X1 Y1) : - update_val_rel (update_val_rel L R0) R1 == update_val_rel L R1. -Proof. - split; intro. - - destruct H. - + now constructor. - + destruct H1. { exfalso. now apply H. } - constructor; auto. - - destruct H. - + now constructor. - + constructor; auto. - constructor; auto. -Qed. +(*| +Specializations to the gfp +|*) + Lemma ssim_bind_gen E F C D X Y X' Y' + L (SS : rel X Y) + (t1 : ctree E C X) (t2: ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): + t1 (≲ upd_Lrel L SS) t2 -> + (forall x y, SS x y -> k1 x (≲ L) k2 y) -> + t1 >>= k1 (≲ L) t2 >>= k2. + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. -Theorem is_update_val_rel_update_val_rel_eq {E X Y Z} : - forall (R : rel X Y), - @Lequiv E E Z Z (@update_val_rel E E Z Z (update_val_rel eq R) eq) eq. -Proof. - intros. rewrite update_val_rel_update_val_rel. - now rewrite update_val_rel_eq. -Qed. + Lemma ssim_bind E C D X Y X' Y' + (RR : rel X' Y') (SS : rel X Y) + (t1 : ctree E C X) (t2: ctree E D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y'): + t1 (≲ [SS]) t2 -> + (forall x y, SS x y -> k1 x (≲ [RR]) k2 y) -> + t1 >>= k1 (≲ [RR]) t2 >>= k2. + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. -#[global] Instance Symmetric_update_val_rel {E X} L R0 : - Symmetric L -> - Symmetric R0 -> - Symmetric (@update_val_rel E E X X L R0). -Proof. - cbn. intros. destruct H1; constructor; auto. -Qed. + Lemma ssim_bind_eq {E C D: Type -> Type} {X X': Type} + (t1 : ctree E C X) (t2: ctree E D X) + (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): + t1 ≲ t2 -> + (forall x, k1 x ≲ k2 x) -> + t1 >>= k1 ≲ t2 >>= k2. + Proof. + intros. + eapply ssim_bind; eauto. + intros ?? ->; auto. + Qed. -#[global] Instance Transitive_update_val_rel : - forall {E X} (L : relation (label E)) (R0 : relation X), - Transitive L -> - Transitive R0 -> - Transitive (update_val_rel L R0). -Proof. - red. intros. destruct y. - - inv H1. inv H2. constructor; auto. etransitivity; eassumption. - - inv H1. inv H2. constructor; auto. etransitivity; eassumption. - - inv H1; [| exfalso; etrans]. - inv H2; [| exfalso; etrans]. - invert. constructor. eauto. -Qed. +End bind. -Definition lift_val_rel {E X Y} := @update_val_rel E E X Y eq. (*| And in particular, we can justify rewriting [≲] to the left of a [bind]. NOTE: we shouldn't have to impose [eq] to the right. |*) #[global] Instance ssim_bind_chain {E C X Y} - {R : Chain (@ss E E C C Y Y eq)} : - Proper (ssim eq ==> - (pointwise_relation _ (elem R)) ==> - (elem R)) (@bind E C X Y). + {R : Chain (@ss E E C C Y Y Leq)} : + Proper (ssim Leq ==> (pointwise_relation _ (` R)) ==> ` R) (bind E C X Y). Proof. repeat intro; eapply bind_chain_gen; eauto. - apply update_val_rel_eq. From 2db8b972f8cfb912251baec31870042134cdfc7f Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 30 Oct 2025 18:12:42 +0100 Subject: [PATCH 10/61] Progress in reestablishing the metatheory, trying to simplify on the way and understanding how to expose a clean interface --- theories/Eq/SSim.v | 427 ++++++++++++++++++++++++++++----------------- 1 file changed, 270 insertions(+), 157 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 9c72d9b..4ade994 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -297,7 +297,7 @@ Section ssim_heterogenous_theory. ---------------------------------------- |*) - Lemma equ_clos_sst {c: Chain (ss L)}: + Lemma equ_clos_chain {c: Chain (ss L)}: forall x y, equ_clos `c x y -> `c x y. Proof. apply tower. @@ -313,7 +313,7 @@ Section ssim_heterogenous_theory. rewrite <- Equu; auto. Qed. - #[global] Instance seq_clos_sst_goal {c: Chain (ss L)} : + #[global] Instance seq_chain_goal {c: Chain (ss L)} : Proper (Seq ==> Seq ==> flip impl) (`c). Proof. apply tower. @@ -329,18 +329,19 @@ Section ssim_heterogenous_theory. now rewrite EQu. Qed. - #[global] Instance equ_clos_sst_goal {c: Chain (ss L)} : + #[global] Instance equ_chain_goal {c: Chain (ss L)} : Proper (equ eq ==> equ eq ==> flip impl) `c. Proof. cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sst; econstructor; [eauto | | symmetry; eauto]; assumption. + apply equ_clos_chain; econstructor; [eauto | | symmetry; eauto]; assumption. Qed. - #[global] Instance equ_clos_sst_ctx {c: Chain (ss L)} : - Proper (equ eq ==> equ eq ==> impl) `c. + #[global] Instance seq_ss_closed_goal {r} : + Proper (Seq ==> Seq ==> flip impl) (ss L r). Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sst; econstructor; [symmetry; eauto | | eauto]; assumption. + intros t t' tt' u u' uu'; cbn; intros. + rewrite tt' in H0. apply H in H0 as (l' & ? & ? & ? & ?). + ex2; eauto. rewrite uu'. eauto. Qed. #[global] Instance equ_ss_closed_goal {r} : @@ -351,6 +352,37 @@ Section ssim_heterogenous_theory. ex2; eauto. rewrite uu'. eauto. Qed. + #[global] Instance seq_chain_ctx {c: Chain (ss L)} : + Proper (Seq ==> Seq ==> impl) `c. + Proof. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' EQt u u' EQu HS l v TR. + rewrite <- EQt in TR. + apply HS in TR as (l' & v' & ? & ? & ?). + exists l',v'; split; auto. + now rewrite <- EQu. + Qed. + + #[global] Instance equ_chain_ctx {c: Chain (ss L)} : + Proper (equ eq ==> equ eq ==> impl) `c. + Proof. + cbn; intros ? ? eq1 ? ? eq2 H. + apply equ_clos_chain; econstructor; [symmetry; eauto | | eauto]; assumption. + Qed. + + #[global] Instance seq_ss_closed_ctx {r} : + Proper (Seq ==> Seq ==> impl) (ss L r). + Proof. + intros t t' tt' u u' uu'; cbn; intros. + rewrite <- tt' in H0. apply H in H0 as (l' & ? & ? & ? & ?). + ex2; eauto. rewrite <- uu'. eauto. + Qed. + #[global] Instance equ_ss_closed_ctx {r} : Proper (equ eq ==> equ eq ==> impl) (ss L r). Proof. @@ -448,7 +480,7 @@ and with the argument (pointwise) on the continuation. * rewrite EQ. apply H; auto. intros. - now apply (b_chain R), kk'. + now step; apply kk'. * etrans. + subst l. apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). @@ -457,7 +489,7 @@ and with the argument (pointwise) on the continuation. exists (ask f); ex; split3. eapply trans_bind_l_ask; eauto. * rewrite SEQ. - apply (b_chain R). + step. intros ? ? STEP''. pose proof trans_passive_inv' STEP'' as (a & EQ & ->). rewrite EQ in STEP''. @@ -470,7 +502,7 @@ and with the argument (pointwise) on the continuation. apply H. rewrite EQ' in HSIM'; auto. intros. - now apply (b_chain R), kk'. + now step; apply kk'. * etrans. + apply tt' in STEPres as (? & ? & STEP' & HSIM & HRL). dependent induction HRL. @@ -558,18 +590,18 @@ NOTE: we shouldn't have to impose [eq] to the right. |*) #[global] Instance ssim_bind_chain {E C X Y} {R : Chain (@ss E E C C Y Y Leq)} : - Proper (ssim Leq ==> (pointwise_relation _ (` R)) ==> ` R) (bind E C X Y). + Proper ((fun t u => ssim Leq (α t) (α u)) ==> + (pointwise_relation _ (fun t u => ` R (α t) (α u))) ==> ` R) (@bind E C X Y). Proof. repeat intro; eapply bind_chain_gen; eauto. - - apply update_val_rel_eq. - - intros. now subst. + intros ?? <-; auto. Qed. -#[global] Instance bind_ssim_cong_gen {E C X X'} : - Proper (ssim eq ==> pointwise_relation X (ssim eq) ==> ssim eq) (@CTree.bind E C X X'). -Proof. - cbn. intros. now apply ssim_clo_bind_eq. -Qed. +(* #[global] Instance bind_ssim_cong_gen {E C X X'} : *) +(* Proper (ssim eq ==> pointwise_relation X (ssim eq) ==> ssim eq) (@CTree.bind E C X X'). *) +(* Proof. *) +(* cbn. intros. now apply ssim_clo_bind_eq. *) +(* Qed. *) Ltac __play_ssim := step; cbn; intros ? ? ?TR. @@ -588,37 +620,236 @@ Ltac __eplay_ssim := #[local] Tactic Notation "play" "in" ident(H) := __play_ssim_in H. #[local] Tactic Notation "eplay" := __eplay_ssim. +(* Definition ss_ {E F C D X Y} (L : lrel E F X Y) *) +(* (R : rel S S) : rel (ctree E C X) (ctree F D Y) := *) +(* fun t u => ss L R (α t) (α u). *) + +(* Definition ssim_ {E F C D X Y} (L : lrel E F X Y): rel (ctree E C X) (ctree F D Y) := *) +(* fun t u => ssim L (α t) (α u). *) + +Lemma ask_invT : forall E X Y e1 e2, @ask E X e1 = @ask E Y e2 -> X = Y. + intros * EQ. + now dependent induction EQ. +Qed. + +Lemma ask_inv : forall E X e1 e2, @ask E X e1 = @ask E X e2 -> e1 = e2. + intros * EQ. + now dependent induction EQ. +Qed. + +Lemma rcv_invT : forall E X Y e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E Y e2 v2 -> X = Y. + intros * EQ. + now dependent induction EQ. +Qed. + +Lemma rcv_inv : forall E X e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E X e2 v2 -> e1 = e2 /\ v1 = v2. + intros * EQ. + now dependent induction EQ. +Qed. + +Ltac inv_label_eq EQl := + match type of EQl with + | τ = τ => + clear EQl + | val _ = val _ => + apply val_eq_inv in EQl; try (inversion EQl; fail) + | ask _ = ask _ => + let EQt := fresh "EQt" in + let EQe := fresh "EQe" in + apply ask_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply ask_inv in EQl as EQe; + try (inversion EQe; fail) + | rcv _ _ = rcv _ _ => + let EQt := fresh "EQt" in + let EQt := fresh "EQv" in + let EQe := fresh "EQe" in + apply rcv_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply rcv_inv in EQl as [EQe EQv]; + try (inversion EQe; inversion EQv; fail) + | _ => try now inv EQl + end. + +Ltac inv_trans_one := + match goal with + (* Ret *) + | h : hrel_of (trans _) (α Ret _) _ |- _ => + let EQl := fresh "EQl" in + (apply trans_ret_inv in h as [?EQ EQl] || apply trans_ret_inv' in h as [?EQ EQl]); + inv_label_eq EQl + + (* Step *) + | h : hrel_of (trans _) (α Step _) _ |- _ => + let EQl := fresh "EQl" in + apply trans_step_inv' in h as (?EQ & EQl); + inv_label_eq EQl + + (* Br *) + | h : hrel_of (trans _) (α Br _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br_inv in h as (?n & TR) + + (* Vis *) + | h : hrel_of (trans _) (α (Vis ?e ?k)) _ |- _ => + let EQl := fresh "EQl" in + apply trans_vis_inv' in h as (?EQ & EQl); + inv_label_eq EQl + + (* Passive *) + | h : hrel_of (trans _) (β ?e ?k) _ |- _ => + let EQl := fresh "EQl" in + apply trans_passive_inv' in h as (?x & ?EQ & EQl); + inv_label_eq EQl + + end. + +Ltac inv_trans := repeat inv_trans_one. + +Notation ssim_ L t u := (ssim L (α t) (α u)). +Notation ss_ L t u := (ss L _ (α t) (α u)). + Section Proof_Rules. - Arguments label: clear implicits. - Context {E C: Type -> Type} - {X : Type}. + Context {E F C D: Type -> Type} {X Y : Type}. + + (* Lemma step_ss_ret_gen {Y F D} (x : X) (y : Y) R (L : lrel E F X Y) : *) + (* R (α Stuck) (α Stuck) -> *) + (* (Proper (Seq ==> Seq ==> impl) R) -> *) + (* RR L x y -> *) + (* ss L R (Ret x : ctree E C X) (Ret y : ctree F D Y). *) + (* Proof. *) + (* intros Rstuck PROP Lval. *) + (* cbn; intros ? ? TR. *) + (* inv_trans. *) + (* subst. ex2; intuition. *) + (* now rewrite EQ. *) + (* Qed. *) + + Lemma ss_chain_stuck L {R : Chain (@ss E F C D X Y L)} : + `R Stuck Stuck. + Proof. + step. apply is_stuck_ss, Stuck_is_stuck. + Qed. + + Lemma ss_ret (x : X) (y : Y) L + {R : Chain (@ss E F C D X Y L)} : + RR L x y -> + ss L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros HR l u TR. + inv_trans. subst. + ex2; intuition. + rewrite EQ. + apply ss_chain_stuck. + Qed. - Lemma step_ss_ret_gen {Y F D}(x : X) (y : Y) (R L : rel _ _) : - R Stuck Stuck -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - L (val x) (val y) -> - ss L R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Lemma ssim_ret (x : X) (y : Y) L : + RR L x y -> + ssim L (Ret x : ctree E C X) (Ret y : ctree F D Y). Proof. - intros Rstuck PROP Lval. - cbn; intros ? ? TR; inv_trans; subst; - cbn; eexists; eexists; intuition; etrans; - now rewrite EQ. + intros. + step. now apply ss_ret. + Qed. + +(*| + The vis nodes are deterministic from the perspective of the labeled + transition system, stepping is hence symmetric and we can just recover + the itree-style rule. +|*) + Lemma step_ss_vis {Z Z'} (e : E Z) (f: F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} + (HRask : Rask L e f) + (HRrcv : forall x, exists y, `R (k x) (k' y) /\ Rrcv L e f x y) : + ss L ` R (Vis e k) (Vis f k'). + Proof. + intros ?? TR; inv_trans. + subst. + ex2; intuition. + rewrite EQ. + step. + intros l u TR. + inv_trans; subst. + destruct (HRrcv x) as (y & ? & ?). + ex2; intuition. + rewrite EQ0; eauto. + etrans. Qed. - Lemma step_ss_ret {Y F D} (x : X) (y : Y) (L : rel _ _) + Lemma ssim_vis {Z Z'} (e : E Z) (f: F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + (HRask : Rask L e f) + (HRrcv : forall x, exists y, ssim L (k x) (k' y) /\ Rrcv L e f x y) : + ssim L (Vis e k) (Vis f k'). + Proof. + intros. step. apply step_ss_vis; auto. + Qed. + +(*| + Same goes for visible tau nodes. +|*) + Lemma ss_step + (t: ctree E C X) (t': ctree F D Y) L {R : Chain (@ss E F C D X Y L)} : - L (val x) (val y) -> - ss L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). + ` R t t' -> + ss L ` R (Step t) (Step t'). + Proof. + intros HR ???; inv_trans; subst. + ex2; intuition. + now rewrite EQ. + Qed. + + Lemma ssim_step + (t: ctree E C X) (t': ctree F D Y) L : + ssim L t t' -> + ssim L (Step t) (Step t'). Proof. intros. - apply step_ss_ret_gen. - - apply (b_chain R). - apply is_stuck_ss; apply Stuck_is_stuck. - - typeclasses eauto. - - apply H. + step. apply ss_step; auto. + Qed. + +(*| + For invisible nodes, the situation is different: we may kill them, but that execution + cannot act as going under the guard. +|*) + (* Here we need a stronger lemma quantifying over arbitrary relations [R] and not just elements of the Chain in order to lift things to ssim as we don't unlock ssim in the structural subterm *) + Lemma ss_br_l_gen {Z} (c : C Z) + (k : Z -> ctree E C X) (t': ctree F D Y) R L: + (forall x, ss L R (k x) t') -> + ss L R (Br c k) t'. + Proof. + intros EQs. + intros ? ? TR; inv_trans; subst. + edestruct3 EQs; eauto. Qed. + Lemma ss_br_l {Z} (c : C Z) + (k : Z -> ctree E C X) (t: ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} : + (forall x, ss L `R (k x) t) -> + ss L `R (Br c k) t. + Proof. + intros. + intros ? ? TR. + inv_trans; subst. + edestruct3 H; eauto. + Qed. + + Lemma ssim_br_l {Z} (c : C Z) + (k : Z -> ctree E C X) (t: ctree F D Y) L : + (forall x, ssim L (k x) t) -> + ssim L (Br c k) t. + Proof. + intros. step. apply ss_br_l_gen. intros. + specialize (H x). step in H. apply H. + Qed. + + (* CHECKPOINT *) + + Lemma step_ss_ret_l_gen {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L R : rel _ _) : R Stuck Stuck -> (Proper (equ eq ==> equ eq ==> impl) R) -> @@ -645,51 +876,6 @@ Section Proof_Rules. - typeclasses eauto. Qed. - Lemma ssim_ret {Y F D} (x : X) (y : Y) (L : rel _ _) : - L (val x) (val y) -> - ssim L (Ret x : ctree E C X) (Ret y : ctree F D Y). - Proof. - intros. step. now apply step_ss_ret. - Qed. - -(*| - The vis nodes are deterministic from the perspective of the labeled - transition system, stepping is hence symmetric and we can just recover - the itree-style rule. -|*) - Lemma step_ss_vis_gen {Y Z Z' F D} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (R L: rel _ _) : - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, exists y, R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - ss L R (Vis e k) (Vis f k'). - Proof. - intros. - cbn; intros ? ? TR; inv_trans; subst; - destruct (H0 x) as (x' & RR & LL); - cbn; eexists; eexists; intuition. - - rewrite EQ; eauto. - - assumption. - Qed. - - Lemma step_ss_vis {Y Z Z' F D} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L : rel _ _) - {R : Chain (@ss E F C D X Y L)} : - (forall x, exists y, ` R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - ss L ` R (Vis e k) (Vis f k'). - Proof. - intros * EQ. - apply step_ss_vis_gen; auto. - typeclasses eauto. - Qed. - - Lemma ssim_vis {Y Z Z' F D} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L : rel _ _) : - (forall x, exists y, ssim L (k x) (k' y) /\ L (obs e x) (obs f y)) -> - ssim L (Vis e k) (Vis f k'). - Proof. - intros. step. apply step_ss_vis; auto. - Qed. - Lemma step_ss_vis_id_gen {Y Z F D} (e : E Z) (f: F Z) (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (R L: rel _ _) : (Proper (equ eq ==> equ eq ==> impl) R) -> @@ -719,79 +905,6 @@ Section Proof_Rules. intros. step. now apply step_ss_vis_id. Qed. -(*| - Same goes for visible tau nodes. -|*) - Lemma step_ss_step_gen {Y F D} - (t : ctree E C X) (t': ctree F D Y) (R L: rel _ _): - (Proper (equ eq ==> equ eq ==> impl) R) -> - L τ τ -> - (R t t') -> - ss L R (Step t) (Step t'). - Proof. - intros PR ? EQs. - intros ? ? TR; inv_trans; subst. - cbn; do 2 eexists; split; [etrans | split; [rewrite EQ; eauto|assumption]]. - Qed. - - Lemma step_ss_step {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L : rel _ _) - {R : Chain (@ss E F C D X Y L)} : - (` R t t') -> - L τ τ -> - ss L ` R (Step t) (Step t'). - Proof. - intros. - apply step_ss_step_gen; auto. - typeclasses eauto. - Qed. - - Lemma step_ssim_step {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L : rel _ _) : - (ssim L t t') -> - L τ τ -> - ssim L (Step t) (Step t'). - Proof. - intros. - step. apply step_ss_step; auto. - Qed. - -(*| - For invisible nodes, the situation is different: we may kill them, but that execution - cannot act as going under the guard. -|*) - Lemma step_ss_br_l_gen {Y F D Z} (c : C Z) - (k : Z -> ctree E C X) (t': ctree F D Y) (R L: rel _ _): - (forall x, ss L R (k x) t') -> - ss L R (Br c k) t'. - Proof. - intros EQs. - intros ? ? TR; inv_trans; subst. - apply EQs in TR; destruct TR as (u' & TR' & EQ'). - eauto. - Qed. - - Lemma step_ss_br_l {Y F D Z} (c : C Z) - (k : Z -> ctree E C X) (t: ctree F D Y) (L: rel _ _) - {R : Chain (@ss E F C D X Y L)} : - (forall x, ss L `R (k x) t) -> - ss L `R (Br c k) t. - Proof. - intros. - intros ? ? TR; inv_trans; subst. - apply H in TR as (? & ? & ?). - eauto. - Qed. - - Lemma ssim_br_l {Y F D Z} (c : C Z) - (k : Z -> ctree E C X) (t: ctree F D Y) (L: rel _ _): - (forall x, ssim L (k x) t) -> - ssim L (Br c k) t. - Proof. - intros. step. apply step_ss_br_l_gen. intros. - specialize (H x). step in H. apply H. - Qed. - Lemma step_ss_br_r_gen {Y F D Z} (c : D Z) x (k : Z -> ctree F D Y) (t: ctree E C X) (R L: rel _ _): ss L R t (k x) -> From 0de205c28a83f4600fa9a38a722c5e8b2679aaba Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 31 Oct 2025 11:49:54 +0100 Subject: [PATCH 11/61] Fixed all backward lemmas --- theories/Eq/SSim.v | 569 +++++++++++++++++++------------------------- theories/Eq/Trans.v | 5 +- 2 files changed, 253 insertions(+), 321 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 4ade994..55726a2 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -26,10 +26,11 @@ Set Implicit Arguments. (* TODO: Decide where to set this *) Arguments trans : simpl never. - +(* check *) +Notation htrans l u v := (hrel_of (trans l) u v) (only parsing). Ltac refine_transition H := match type of H with - | hrel_of (trans τ) _ _ => + | htrans τ _ _ => let u := fresh "u" in let EQ := fresh "EQ" in pose proof trans_τ_active H as [u EQ]; @@ -47,8 +48,11 @@ Ltac refine_transition H := end end. +(* Truc de ce genre c'est un Proper *) +(* forall X Y (R : X -> Y -> Prop), equiv R (ret x) (ret y) -> R x y. *) + Section build_rel. - + Context {E F : Type -> Type} {X Y : Type}. Record lrel := @@ -57,9 +61,8 @@ Section build_rel. Rask: forall [X Y], E X -> F Y -> Prop ; Rrcv: forall [X Y] (e : E X) (f : F Y), X -> Y -> Prop ; }. - - Variant build_rel {RL : lrel} - : hrel (label E) (label F) := + + Variant build_rel {RL : lrel} : hrel (label E) (label F) := | rel_τ : build_rel τ τ | rel_ask {X Y} {e : E X} {f : F Y} (HR : Rask RL e f) : @@ -69,7 +72,7 @@ Section build_rel. build_rel (rcv e x) (rcv f y) | rel_ret {x : X} {y : Y}: RR RL x y -> build_rel (val x) (val y). - Arguments build_rel : clear implicits. + Arguments build_rel : clear implicits. Lemma build_rel_val RL x y : build_rel RL (val x) (val y) -> RR RL x y. @@ -100,9 +103,11 @@ End build_rel. Arguments lrel : clear implicits. Arguments build_rel {E F X Y} RL. #[global] Hint Constructors build_rel : trans. -Notation "↑ L" := (build_rel L) (at level 2). +Coercion build_rel : lrel >-> hrel. -Definition upd_Lrel {E F X Y X' Y'} (RL : lrel E F X Y) (SS : rel X' Y') : lrel E F X' Y' := +Definition upd_Lrel {E F X Y X' Y'} + (RL : lrel E F X Y) + (SS : rel X' Y') : lrel E F X' Y' := {| RR := SS ; Rask := Rask RL ; @@ -183,7 +188,7 @@ Pous'16 in order to be able to exploit symmetry arguments in proofs forall l t', trans l t t' -> exists l' u', trans l' u u' /\ R t' u' /\ - ↑ L l l' + L l l' |}. Next Obligation. edestruct3 H0; eauto. @@ -259,13 +264,13 @@ Section ssim_homogenous_theory. Notation ss := (@ss E E B B X X). - #[global] Instance refl_sst {LR: Reflexive (↑ L)} {C: Chain (ss L)}: Reflexive `C. + #[global] Instance refl_sst {LR: Reflexive L} {C: Chain (ss L)}: Reflexive `C. Proof. apply Reflexive_chain. cbn; eauto. Qed. - #[global] Instance square_sst {LT: Transitive (↑ L)} {C: Chain (ss L)}: Transitive `C. + #[global] Instance square_sst {LT: Transitive L} {C: Chain (ss L)}: Transitive `C. Proof. apply Transitive_chain. cbn. intros ????? xy yz. @@ -276,7 +281,7 @@ Section ssim_homogenous_theory. Qed. (*| PreOrder |*) - #[global] Instance PreOrder_sst {LPO: PreOrder (↑ L)} {C: Chain (ss L)}: PreOrder `C. + #[global] Instance PreOrder_sst {LPO: PreOrder L} {C: Chain (ss L)}: PreOrder `C. Proof. split; typeclasses eauto. Qed. End ssim_homogenous_theory. @@ -391,42 +396,6 @@ Section ssim_heterogenous_theory. ex2; eauto. rewrite <- uu'. eauto. Qed. -(*| - stuck ctrees can be simulated by anything. -|*) - Lemma is_stuck_ss (R : rel _ _) (t : ctree E C X) (t': ctree F D Y): - is_stuck t -> ss L R t t'. - Proof. - repeat intro. now apply H in H0. - Qed. - - Lemma is_stuck_ssim (t: ctree E C X) (t': ctree F D Y): - is_stuck t -> ssim L t t'. - Proof. - intros. step. now apply is_stuck_ss. - Qed. - - Lemma Stuck_ss (R : rel _ _) (t : ctree F D Y) : ss L R Stuck t. - Proof. - repeat intro. now apply Stuck_is_stuck in H. - Qed. - - Lemma Stuck_ssim (t : ctree F D Y) : ssim L Stuck t. - Proof. - intros. step. apply Stuck_ss. - Qed. - - Lemma spin_ss (R : rel _ _) (t : ctree F D Y): ss L R spin t. - Proof. - repeat intro. now apply spin_is_stuck in H. - Qed. - - Lemma spin_ssim : forall (t' : ctree F D Y), - ssim L spin t'. - Proof. - intros. step. apply spin_ss. - Qed. - End ssim_heterogenous_theory. #[global] Instance weq_ssim : forall {E F C D X Y}, @@ -691,7 +660,11 @@ Ltac inv_trans_one := | h : hrel_of (trans _) (α Br _ _) _ |- _ => let TR := fresh "TR" in apply trans_br_inv in h as (?n & TR) - + + (* Guard *) + | h : hrel_of (trans _) (α Guard _) _ |- _ => + apply trans_guard_inv in h + (* Vis *) | h : hrel_of (trans _) (α (Vis ?e ?k)) _ |- _ => let EQl := fresh "EQl" in @@ -715,25 +688,50 @@ Section Proof_Rules. Context {E F C D: Type -> Type} {X Y : Type}. - (* Lemma step_ss_ret_gen {Y F D} (x : X) (y : Y) R (L : lrel E F X Y) : *) - (* R (α Stuck) (α Stuck) -> *) - (* (Proper (Seq ==> Seq ==> impl) R) -> *) - (* RR L x y -> *) - (* ss L R (Ret x : ctree E C X) (Ret y : ctree F D Y). *) - (* Proof. *) - (* intros Rstuck PROP Lval. *) - (* cbn; intros ? ? TR. *) - (* inv_trans. *) - (* subst. ex2; intuition. *) - (* now rewrite EQ. *) - (* Qed. *) - - Lemma ss_chain_stuck L {R : Chain (@ss E F C D X Y L)} : - `R Stuck Stuck. +(*| +Stuck ctrees can be simulated by anything. +|*) + Lemma ss_is_stuck L R (t : ctree E C X) (t': ctree F D Y): + is_stuck t -> + ss L R t t'. Proof. - step. apply is_stuck_ss, Stuck_is_stuck. + repeat intro. now apply H in H0. Qed. - + + Lemma ssim_is_stuck L (t: ctree E C X) (t': ctree F D Y): + is_stuck t -> + ssim L t t'. + Proof. + intros. step. now apply ss_is_stuck. + Qed. + + Lemma ss_stuck L R (t : ctree F D Y) : + @ss E F C D X Y L R Stuck t. + Proof. + repeat intro. now apply Stuck_is_stuck in H. + Qed. + + Lemma ssim_stuck L (t : ctree F D Y) : + @ssim E F C D X Y L Stuck t. + Proof. + intros. step. apply ss_stuck. + Qed. + + Lemma ss_spin L R (t : ctree F D Y) : + @ss E F C D X Y L R spin t. + Proof. + repeat intro. now apply spin_is_stuck in H. + Qed. + + Lemma ssim_spin L (t' : ctree F D Y) : + @ssim E F C D X Y L spin t'. + Proof. + intros. step. apply ss_spin. + Qed. + +(*| +Ret nodes +|*) Lemma ss_ret (x : X) (y : Y) L {R : Chain (@ss E F C D X Y L)} : RR L x y -> @@ -743,9 +741,9 @@ Section Proof_Rules. inv_trans. subst. ex2; intuition. rewrite EQ. - apply ss_chain_stuck. + step; apply ss_stuck. Qed. - + Lemma ssim_ret (x : X) (y : Y) L : RR L x y -> ssim L (Ret x : ctree E C X) (Ret y : ctree F D Y). @@ -759,7 +757,7 @@ Section Proof_Rules. transition system, stepping is hence symmetric and we can just recover the itree-style rule. |*) - Lemma step_ss_vis {Z Z'} (e : E Z) (f: F Z') + Lemma ss_vis {Z Z'} (e : E Z) (f: F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L {R : Chain (@ss E F C D X Y L)} (HRask : Rask L e f) @@ -785,35 +783,32 @@ Section Proof_Rules. (HRrcv : forall x, exists y, ssim L (k x) (k' y) /\ Rrcv L e f x y) : ssim L (Vis e k) (Vis f k'). Proof. - intros. step. apply step_ss_vis; auto. + intros. step. apply ss_vis; auto. Qed. -(*| - Same goes for visible tau nodes. -|*) - Lemma ss_step - (t: ctree E C X) (t': ctree F D Y) L - {R : Chain (@ss E F C D X Y L)} : - ` R t t' -> - ss L ` R (Step t) (Step t'). + (* Useful special case: over the same type return type, + we usually pick the identity *) + Lemma ss_vis_id {Z} (e : E Z) (f: F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} + (HRask : Rask L e f) + (HRrcv : forall z, ` R (k z) (k' z) /\ Rrcv L e f z z) : + ss L ` R (Vis e k) (Vis f k'). Proof. - intros HR ???; inv_trans; subst. - ex2; intuition. - now rewrite EQ. + eapply ss_vis; eauto. Qed. - - Lemma ssim_step - (t: ctree E C X) (t': ctree F D Y) L : - ssim L t t' -> - ssim L (Step t) (Step t'). + + Lemma ssim_vis_id {Z} (e : E Z) (f : F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + (HRask : Rask L e f) + (HRrcv : forall x, ssim L (k x) (k' x) /\ Rrcv L e f x x) : + ssim L (Vis e k) (Vis f k'). Proof. - intros. - step. apply ss_step; auto. + intros. step. now apply ss_vis_id. Qed. - + (*| - For invisible nodes, the situation is different: we may kill them, but that execution - cannot act as going under the guard. +Invisible nodes |*) (* Here we need a stronger lemma quantifying over arbitrary relations [R] and not just elements of the Chain in order to lift things to ssim as we don't unlock ssim in the structural subterm *) Lemma ss_br_l_gen {Z} (c : C Z) @@ -847,66 +842,8 @@ Section Proof_Rules. specialize (H x). step in H. apply H. Qed. - (* CHECKPOINT *) - - - Lemma step_ss_ret_l_gen {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L R : rel _ _) : - R Stuck Stuck -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - L (val x) (val y) -> - trans (val y) u u' -> - ss L R (Ret x : ctree E C X) u. - Proof. - intros. cbn. intros. - apply trans_val_inv in H2 as ?. - inv_trans. subst. setoid_rewrite EQ. - etrans. - Qed. - - Lemma step_ss_ret_l {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L : rel _ _) - {R : Chain (@ss E F C D X Y L)} : - L (val x) (val y) -> - trans (val y) u u' -> - ss L ` R (Ret x : ctree E C X) u. - Proof. - intros. - eapply step_ss_ret_l_gen; eauto. - - apply (b_chain R). - apply is_stuck_ss; apply Stuck_is_stuck. - - typeclasses eauto. - Qed. - - Lemma step_ss_vis_id_gen {Y Z F D} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (R L: rel _ _) : - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, R (k x) (k' x) /\ L (obs e x) (obs f x)) -> - ss L R (Vis e k) (Vis f k'). - Proof. - intros. apply step_ss_vis_gen. { typeclasses eauto. } - eauto. - Qed. - - Lemma step_ss_vis_id {Y Z F D} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (L : rel _ _) - {R : Chain (@ss E F C D X Y L)} : - (forall x, ` R (k x) (k' x) /\ L (obs e x) (obs f x)) -> - ss L ` R (Vis e k) (Vis f k'). - Proof. - intros * EQ. - apply step_ss_vis_id_gen; auto. - typeclasses eauto. - Qed. - - Lemma ssim_vis_id {Y Z F D} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (L : rel _ _) : - (forall x, ssim L (k x) (k' x) /\ L (obs e x) (obs f x)) -> - ssim L (Vis e k) (Vis f k'). - Proof. - intros. step. now apply step_ss_vis_id. - Qed. - - Lemma step_ss_br_r_gen {Y F D Z} (c : D Z) x - (k : Z -> ctree F D Y) (t: ctree E C X) (R L: rel _ _): + Lemma ss_br_r_gen {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: ctree E C X) R L: ss L R t (k x) -> ss L R t (Br c k). Proof. @@ -915,283 +852,275 @@ Section Proof_Rules. exists x0; etrans. Qed. - Lemma step_ss_br_r {Y F D Z} (c : D Z) x - (k : Z -> ctree F D Y) (t: ctree E C X) (L: rel _ _) + Lemma ss_br_r {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: ctree E C X) L {R : Chain (@ss E F C D X Y L)} : ss L `R t (k x) -> ss L `R t (Br c k). Proof. - apply step_ss_br_r_gen. + apply ss_br_r_gen. Qed. - Lemma ssim_br_r {Y F D Z} (c : D Z) x - (k : Z -> ctree F D Y) (t: ctree E C X) (L: rel _ _): + Lemma ssim_br_r {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: ctree E C X) L : ssim L t (k x) -> ssim L t (Br c k). Proof. - intros. step. apply step_ss_br_r_gen with (x := x). now step in H. + intros. step. apply ss_br_r_gen with (x := x). now step in H. Qed. - Lemma step_ss_br_gen {Y F D n m} (a: C n) (b: D m) - (k : n -> ctree E C X) (k' : m -> ctree F D Y) (R L : rel _ _) : + Lemma ss_br_gen {A B} (c: C A) (d: D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) R L : (forall x, exists y, ss L R (k x) (k' y)) -> - ss L R (Br a k) (Br b k'). + ss L R (Br c k) (Br d k'). Proof. intros EQs. - apply step_ss_br_l_gen. + apply ss_br_l_gen. intros. destruct (EQs x) as [x' ?]. - now apply step_ss_br_r_gen with (x:=x'). + now apply ss_br_r_gen with (x:=x'). Qed. - Lemma step_ss_br {Y F D n m} (cn: C n) (cm: D m) - (k : n -> ctree E C X) (k' : m -> ctree F D Y) (L : rel _ _) + Lemma ss_br {A B} (c: C A) (d: D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) L {R : Chain (@ss E F C D X Y L)} : (forall x, exists y, ss L `R (k x) (k' y)) -> - ss L `R (Br cn k) (Br cm k'). + ss L `R (Br c k) (Br d k'). Proof. - apply step_ss_br_gen. + apply ss_br_gen. Qed. - Lemma ssim_br {Y F D n m} (cn: C n) (cm: D m) - (k : n -> ctree E C X) (k' : m -> ctree F D Y) (L : rel _ _) : + Lemma ssim_br {A B} (c: C A) (d: D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) L : (forall x, exists y, ssim L (k x) (k' y)) -> - ssim L (Br cn k) (Br cm k'). + ssim L (Br c k) (Br d k'). Proof. - intros. step. apply step_ss_br_gen. + intros. step. apply ss_br_gen. intros. destruct (H x). step in H0. exists x0. apply H0. Qed. - Lemma step_ss_br_id_gen {Y F D n} (c: C n) (d: D n) - (k : n -> ctree E C X) (k' : n -> ctree F D Y) - (R L : rel _ _) : - (forall x, ss L R (k x) (k' x)) -> - ss L R (Br c k) (Br d k'). - Proof. - intros; apply step_ss_br_gen. - eauto. - Qed. - - Lemma step_ss_br_id {Y F D n} (c: C n) (d: D n) - (k : n -> ctree E C X) (k': n -> ctree F D Y) (L: rel _ _) + Lemma ss_br_id {A} (c: C A) (d: D A) + (k : A -> ctree E C X) (k': A -> ctree F D Y) L {R : Chain (@ss E F C D X Y L)} : (forall x, ss L `R (k x) (k' x)) -> ss L `R (Br c k) (Br d k'). Proof. - intros; apply step_ss_br; eauto. + intros; apply ss_br; eauto. Qed. - Lemma ssim_br_id {Y F D n} (c: C n) (d: D n) - (k : n -> ctree E C X) (k': n -> ctree F D Y) (L: rel _ _) : + Lemma ssim_br_id {A} (c: C A) (d: D A) + (k : A -> ctree E C X) (k': A -> ctree F D Y) L : (forall x, ssim L (k x) (k' x)) -> ssim L (Br c k) (Br d k'). Proof. intros. apply ssim_br. eauto. Qed. - Lemma step_ss_guard_gen {Y F D} - (t: ctree E C X) (t': ctree F D Y) (R L: rel _ _): - ss L R t t' -> - ss L R (Guard t) (Guard t'). - Proof. - intros EQ. - intros ? ? TR; inv_trans; subst. - apply EQ in TR; destruct TR as (u' & ? & TR' & ? & EQ'). - do 2 eexists; split. - constructor. apply TR'. - eauto. - Qed. - - Lemma step_ss_guard_l_gen {Y F D} - (t: ctree E C X) (t': ctree F D Y) (R L: rel _ _): + Lemma ss_guard_l_gen + (t: ctree E C X) (t': ctree F D Y) R L: ss L R t t' -> ss L R (Guard t) t'. Proof. intros EQ. intros ? ? TR; inv_trans; subst. - apply EQ in TR; destruct TR as (u' & ? & TR' & ? & EQ'). - eauto. + apply EQ in TR; edestruct5 TR; eauto. Qed. - Lemma step_ss_guard_r_gen {Y F D} - (t: ctree E C X) (t': ctree F D Y) (R L: rel _ _): - ss L R t t' -> - ss L R t (Guard t'). - Proof. - intros EQ. - intros ? ? TR; inv_trans; subst. - apply EQ in TR; destruct TR as (u' & ? & TR' & ? & EQ'). - do 2 eexists; split. - constructor. apply TR'. - eauto. - Qed. - - Lemma step_ss_guard_l {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _) + Lemma ss_guard_l + (t: ctree E C X) (t': ctree F D Y) L {R : Chain (@ss E F C D X Y L)} : ss L `R t t' -> ss L `R (Guard t) t'. Proof. - intros. - intros ? ? TR; inv_trans; subst. - apply H in TR as (? & ? & TR' & ?). - eauto. + intros; now apply ss_guard_l_gen. Qed. - Lemma step_ss_guard_r {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _) - {R : Chain (@ss E F C D X Y L)} : - ss L `R t t' -> - ss L `R t (Guard t'). + Lemma ssim_guard_l + (t: ctree E C X) (t': ctree F D Y) L: + ssim L t t' -> + ssim L (Guard t) t'. Proof. - intros. - intros ? ? TR; inv_trans; subst. - apply H in TR as (? & ? & TR' & ?). - do 2 eexists; split; [constructor; apply TR' |]; eauto. + intros; step; apply ss_guard_l; step in H; auto. Qed. - Lemma step_ss_guard {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _) - {R : Chain (@ss E F C D X Y L)} : - ss L `R t t' -> - ss L `R (Guard t) (Guard t'). + Lemma ss_guard_r_gen + (t: ctree E C X) (t': ctree F D Y) R L : + ss L R t t' -> + ss L R t (Guard t'). Proof. - intros. + intros EQ. intros ? ? TR; inv_trans; subst. - apply H in TR as (? & ? & TR' & ?). - do 2 eexists; split; [constructor; apply TR' |]; eauto. + apply EQ in TR; edestruct5 TR; eauto 7. Qed. - Lemma ssim_guard_l {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _): - ssim L t t' -> - ssim L (Guard t) t'. + Lemma ss_guard_r + (t: ctree E C X) (t': ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} : + ss L `R t t' -> + ss L `R t (Guard t'). Proof. - intros; step; apply step_ss_guard_l; step in H; auto. + now apply ss_guard_r_gen. Qed. - Lemma ssim_guard_r {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _): + Lemma ssim_guard_r + (t: ctree E C X) (t': ctree F D Y) L : ssim L t t' -> ssim L t (Guard t'). Proof. - intros; step; apply step_ss_guard_r; step in H; auto. + intros; step; apply ss_guard_r; step in H; auto. Qed. - Lemma ssim_guard {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _): + Lemma ssim_guard + (t: ctree E C X) (t': ctree F D Y) L : ssim L t t' -> ssim L (Guard t) (Guard t'). Proof. - intros; step; apply step_ss_guard; step in H; auto. + intros. + now apply ssim_guard_l, ssim_guard_r. Qed. (*| - When matching visible brs one against another, in general we need to explain how - we map the branches from the left to the branches to the right. - A useful special case is the one where the arity coincide and we simply use the identity - in both directions. We can in this case have [n] rather than [2n] obligations. +Internal transitions |*) - Lemma step_ss_brS_gen {Z Z' Y F D} (c : C Z) (d : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (R L: rel _ _) : - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, exists y, R (k x) (k' y)) -> - L τ τ -> - ss L R (BrS c k) (BrS d k'). + Lemma ss_step + (t: ctree E C X) (t': ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} : + ` R t t' -> + ss L ` R (Step t) (Step t'). Proof. - intros. - eapply step_ss_br_gen. - intros. - specialize (H0 x) as [y ?]. - exists y. - eapply step_ss_step_gen; auto. + intros HR ???; inv_trans; subst. + ex2; intuition. + now rewrite EQ. Qed. - Lemma step_ss_brS {Z Z' Y F D} (c : C Z) (c' : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L: rel _ _) - {R : Chain (@ss E F C D X Y L)} : - (forall x, exists y, (elem R) (k x) (k' y)) -> - L τ τ -> + Lemma ssim_step + (t: ctree E C X) (t': ctree F D Y) L : + ssim L t t' -> + ssim L (Step t) (Step t'). + Proof. + now intros; step; apply ss_step. + Qed. + + Lemma ss_brS {Z Z'} (c : C Z) (c' : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} : + (forall x, exists y, ` R (k x) (k' y)) -> ss L ` R (BrS c k) (BrS c' k'). Proof. intros. - eapply step_ss_br. + eapply ss_br. intros x; specialize (H x) as [y ?]. exists y. - eapply step_ss_step; auto. + eapply ss_step; auto. Qed. - Lemma ssim_brS {Z Z' Y F D} (c : C Z) (c' : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L: rel _ _) : + Lemma ssim_brS {Z Z'} (c : C Z) (c' : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L : (forall x, exists y, ssim L (k x) (k' y)) -> - L τ τ -> ssim L (BrS c k) (BrS c' k'). Proof. - intros. - apply ssim_br. - intros x; specialize (H x) as [y ?]; exists y. - apply step_ssim_step; auto. + now intros; step; apply ss_brS. Qed. - Lemma step_ss_brS_id_gen {Z Y D F} (c : C Z) (d: D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) (R L : rel _ _) : - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, R (k x) (k' x)) -> - L τ τ -> - ss L R (BrS c k) (BrS d k'). - Proof. - intros; apply step_ss_brS_gen; eauto. - Qed. - - Lemma step_ss_brS_id {Z Y D F} (c : C Z) (d : D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) (L : rel _ _) - {R : Chain (@ss E F C D X Y L)} : + Lemma ss_brS_id {Z} (c : C Z) (d : D Z) + (k: Z -> ctree E C X) (k': Z -> ctree F D Y) L + {R : Chain (@ss E F C D X Y L)} : (forall x, `R (k x) (k' x)) -> - L τ τ -> ss L ` R (BrS c k) (BrS d k'). Proof. - intros. - apply step_ss_brS; eauto. + intros; apply ss_brS; eauto. Qed. - Lemma ssim_brS_id {Z Y D F} (c : C Z) (d : D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) (L : rel _ _) : + Lemma ssim_brS_id {Z} (c : C Z) (d : D Z) + (k: Z -> ctree E C X) (k': Z -> ctree F D Y) L : (forall x, ssim L (k x) (k' x)) -> - L τ τ -> ssim L (BrS c k) (BrS d k'). Proof. - intros. - apply ssim_brS; eauto. + intros; apply ssim_brS; eauto. Qed. (*| - Note that with visible schedules, nary-spins are equivalent only - if neither are empty, or if both are empty: they match each other's - τ challenge infinitely often. - With invisible schedules, they are always equivalent: neither of them - produce any challenge for the other. + Note that with visible schedules, an nary-spins refines another only + if it is empty, or if neither are empty. |*) - Lemma spinS_gen_nonempty : forall {Z X Y D F} {L: rel (label E) (label F)} - (x: X) (y: Y) - (c: C X) (c': D Y), - L τ τ -> - ssim L (@spinS_gen E C Z X c) (@spinS_gen F D Z Y c'). + Lemma ssim_spinS_nonempty : + forall {Z Z'} L (x: Z) (y: Z') (c: C Z) (c': D Z'), + @ssim E F C D X Y L (spinS_gen c) (spinS_gen c'). Proof. intros until L; intros x y. - coinduction S CIH; simpl. intros ? ? ? ? ? TR; - rewrite ctree_eta in TR; cbn in TR. - apply trans_brS_inv in TR as (_ & EQ & ->). - eexists; eexists. - rewrite ctree_eta; cbn. - split; [econstructor|]. - + exact y. - + constructor. reflexivity. - + rewrite EQ; eauto. + coinduction S CIH. + intros * ?? TR. + rewrite ctree_eta in TR; cbn in TR. + inv_trans. + ex2; split3; subst; etrans. + rewrite ctree_eta; cbn; etrans. + now rewrite EQ. Qed. + Lemma ssim_spinS_empty : + forall Z L (c: C False) (c': D Z), + @ssim E F C D X Y L (spinS_gen c) (spinS_gen c'). + Proof. + intros. + eapply ssim_is_stuck. + intros ?? TR. + rewrite ctree_eta in TR; cbn in TR. + inv_trans. + Qed. + + + (* CHECKPOINT *) + + + (* Seems useless, but used in a fold lemma. To double check *) + (* Lemma step_ss_ret_l_gen {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L R : rel _ _) : *) + (* R Stuck Stuck -> *) + (* (Proper (equ eq ==> equ eq ==> impl) R) -> *) + (* L (val x) (val y) -> *) + (* trans (val y) u u' -> *) + (* ss L R (Ret x : ctree E C X) u. *) + (* Proof. *) + (* intros. cbn. intros. *) + (* apply trans_val_inv in H2 as ?. *) + (* inv_trans. subst. setoid_rewrite EQ. *) + (* etrans. *) + (* Qed. *) + + (* Lemma step_ss_ret_l {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L : rel _ _) *) + (* {R : Chain (@ss E F C D X Y L)} : *) + (* L (val x) (val y) -> *) + (* trans (val y) u u' -> *) + (* ss L ` R (Ret x : ctree E C X) u. *) + (* Proof. *) + (* intros. *) + (* eapply step_ss_ret_l_gen; eauto. *) + (* - apply (b_chain R). *) + (* apply is_stuck_ss; apply Stuck_is_stuck. *) + (* - typeclasses eauto. *) + (* Qed. *) + +(*| + When matching visible brs one against another, in general we need to explain how + we map the branches from the left to the branches to the right. + A useful special case is the one where the arity coincide and we simply use the identity + in both directions. We can in this case have [n] rather than [2n] obligations. +|*) (*| Inversion principles -------------------- |*) + + Lemma ssim_stuck_rev L (t : ctree E C X) (u : ctree F D Y) : + is_stuck u -> + @ssim E F C D X Y L t u -> + is_stuck t. + Proof. + intros IS SS l t' TR. + step in SS. + apply SS in TR. + edestruct5 TR. + eapply IS; eauto. + Qed. + Lemma ssim_ret_inv {F D Y} {L: rel (label E) (label F)} (r1 : X) (r2 : Y) : ssim L (Ret r1 : ctree E C X) (Ret r2 : ctree F D Y) -> L (val r1) (val r2). diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index e531aba..0d54e85 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -73,7 +73,9 @@ Section Trans. Context {E B : Type -> Type} {R : Type}. - Variant S := | Active (t : ctree E B R) | Passive {X} (e : E X) (k : X -> ctree E B R). + Variant S := + | Active (t : ctree E B R) + | Passive {X} (e : E X) (k : X -> ctree E B R). (* Notation S' := (ctree' E B R). *) (* Notation S := (ctree E B R). *) Variant Seq : S -> S -> Prop := @@ -419,6 +421,7 @@ Defined. Coercion Active : ctree >-> S. Notation "'α' t" := (Active t) (at level 100). +(* Out of curiosity: do coercion for β in rocq-elpi *) Notation "'β' e" := (Passive e) (at level 0). (*| Backward reasoning for [trans] From 90f8babd8b0ddb1c55569770d90ebecccf3935f6 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 31 Oct 2025 13:04:13 +0100 Subject: [PATCH 12/61] Some tidying --- theories/Core/Utils.v | 8 ++ theories/Eq/SSim.v | 135 +----------------------- theories/Eq/Trans.v | 240 ++++++++++++++++++++---------------------- 3 files changed, 124 insertions(+), 259 deletions(-) diff --git a/theories/Core/Utils.v b/theories/Core/Utils.v index c6a24a9..da6932c 100644 --- a/theories/Core/Utils.v +++ b/theories/Core/Utils.v @@ -110,3 +110,11 @@ Definition sum_rel {A1 A2 B1 B2} Ra Rb : rel (A1 + B1) (A2 + B2) := | inr b, inr b' => Rb b b' | _, _ => False end. + +Ltac ex := eexists. +Ltac ex2 := do 2 eexists. +Ltac ex3 := do 3 eexists. +Ltac split3 := split; [| split]. +Ltac edestruct3 H := edestruct H as (? & ? & ?). +Ltac edestruct4 H := edestruct H as (? & ? & ? & ?). +Ltac edestruct5 H := edestruct H as (? & ? & ? & ? & ?). diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 55726a2..7460cb0 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -24,30 +24,6 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. -(* TODO: Decide where to set this *) -Arguments trans : simpl never. -(* check *) -Notation htrans l u v := (hrel_of (trans l) u v) (only parsing). -Ltac refine_transition H := - match type of H with - | htrans τ _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_τ_active H as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - | hrel_of (trans (ask ?e)) _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_ask_passive H as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - end. - (* Truc de ce genre c'est un Proper *) (* forall X Y (R : X -> Y -> Prop), equiv R (ret x) (ret y) -> R x y. *) @@ -135,14 +111,6 @@ Definition Lvrel {E X Y} (RR : rel X Y) : lrel E E X Y := Rrcv := eq2 |}. -Ltac ex := eexists. -Ltac ex2 := do 2 eexists. -Ltac ex3 := do 3 eexists. -Ltac split3 := split; [| split]. -Ltac edestruct3 H := edestruct H as (? & ? & ?). -Ltac edestruct4 H := edestruct H as (? & ? & ? & ?). -Ltac edestruct5 H := edestruct H as (? & ? & ? & ? & ?). - Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. @@ -589,100 +557,8 @@ Ltac __eplay_ssim := #[local] Tactic Notation "play" "in" ident(H) := __play_ssim_in H. #[local] Tactic Notation "eplay" := __eplay_ssim. -(* Definition ss_ {E F C D X Y} (L : lrel E F X Y) *) -(* (R : rel S S) : rel (ctree E C X) (ctree F D Y) := *) -(* fun t u => ss L R (α t) (α u). *) - -(* Definition ssim_ {E F C D X Y} (L : lrel E F X Y): rel (ctree E C X) (ctree F D Y) := *) -(* fun t u => ssim L (α t) (α u). *) - -Lemma ask_invT : forall E X Y e1 e2, @ask E X e1 = @ask E Y e2 -> X = Y. - intros * EQ. - now dependent induction EQ. -Qed. - -Lemma ask_inv : forall E X e1 e2, @ask E X e1 = @ask E X e2 -> e1 = e2. - intros * EQ. - now dependent induction EQ. -Qed. - -Lemma rcv_invT : forall E X Y e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E Y e2 v2 -> X = Y. - intros * EQ. - now dependent induction EQ. -Qed. - -Lemma rcv_inv : forall E X e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E X e2 v2 -> e1 = e2 /\ v1 = v2. - intros * EQ. - now dependent induction EQ. -Qed. - -Ltac inv_label_eq EQl := - match type of EQl with - | τ = τ => - clear EQl - | val _ = val _ => - apply val_eq_inv in EQl; try (inversion EQl; fail) - | ask _ = ask _ => - let EQt := fresh "EQt" in - let EQe := fresh "EQe" in - apply ask_invT in EQl as EQt; - symmetry in EQt; - (* subst_hyp_in EQt h; *) - apply ask_inv in EQl as EQe; - try (inversion EQe; fail) - | rcv _ _ = rcv _ _ => - let EQt := fresh "EQt" in - let EQt := fresh "EQv" in - let EQe := fresh "EQe" in - apply rcv_invT in EQl as EQt; - symmetry in EQt; - (* subst_hyp_in EQt h; *) - apply rcv_inv in EQl as [EQe EQv]; - try (inversion EQe; inversion EQv; fail) - | _ => try now inv EQl - end. - -Ltac inv_trans_one := - match goal with - (* Ret *) - | h : hrel_of (trans _) (α Ret _) _ |- _ => - let EQl := fresh "EQl" in - (apply trans_ret_inv in h as [?EQ EQl] || apply trans_ret_inv' in h as [?EQ EQl]); - inv_label_eq EQl - - (* Step *) - | h : hrel_of (trans _) (α Step _) _ |- _ => - let EQl := fresh "EQl" in - apply trans_step_inv' in h as (?EQ & EQl); - inv_label_eq EQl - - (* Br *) - | h : hrel_of (trans _) (α Br _ _) _ |- _ => - let TR := fresh "TR" in - apply trans_br_inv in h as (?n & TR) - - (* Guard *) - | h : hrel_of (trans _) (α Guard _) _ |- _ => - apply trans_guard_inv in h - - (* Vis *) - | h : hrel_of (trans _) (α (Vis ?e ?k)) _ |- _ => - let EQl := fresh "EQl" in - apply trans_vis_inv' in h as (?EQ & EQl); - inv_label_eq EQl - - (* Passive *) - | h : hrel_of (trans _) (β ?e ?k) _ |- _ => - let EQl := fresh "EQl" in - apply trans_passive_inv' in h as (?x & ?EQ & EQl); - inv_label_eq EQl - - end. - -Ltac inv_trans := repeat inv_trans_one. - -Notation ssim_ L t u := (ssim L (α t) (α u)). -Notation ss_ L t u := (ss L _ (α t) (α u)). +(* Notation ssim_ L t u := (ssim L (α t) (α u)). *) +(* Notation ss_ L t u := (ss L _ (α t) (α u)). *) Section Proof_Rules. @@ -1067,7 +943,6 @@ Internal transitions inv_trans. Qed. - (* CHECKPOINT *) @@ -1098,12 +973,6 @@ Internal transitions (* - typeclasses eauto. *) (* Qed. *) -(*| - When matching visible brs one against another, in general we need to explain how - we map the branches from the left to the branches to the right. - A useful special case is the one where the arity coincide and we simply use the identity - in both directions. We can in this case have [n] rather than [2n] obligations. -|*) (*| Inversion principles -------------------- diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 0d54e85..7b002f5 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -655,6 +655,26 @@ Inverting equalities between labels now dependent induction EQ. Qed. + Lemma ask_invT : forall E X Y e1 e2, @ask E X e1 = @ask E Y e2 -> X = Y. + intros * EQ. + now dependent induction EQ. + Qed. + + Lemma ask_inv : forall E X e1 e2, @ask E X e1 = @ask E X e2 -> e1 = e2. + intros * EQ. + now dependent induction EQ. + Qed. + + Lemma rcv_invT : forall E X Y e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E Y e2 v2 -> X = Y. + intros * EQ. + now dependent induction EQ. + Qed. + + Lemma rcv_inv : forall E X e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E X e2 v2 -> e1 = e2 /\ v1 = v2. + intros * EQ. + now dependent induction EQ. + Qed. + (*| Structural rules |*) @@ -2010,138 +2030,104 @@ Qed. (* End Coproduct. *) +#[global] Notation htrans l u v := (hrel_of (trans l) u v) (only parsing). + +(*| +[refine_transition H]: given a transition whose concrete label is known, +derive information on the active/passive status of its destination state. + +Currently very partial +|*) +Ltac refine_transition H := + match type of H with + | htrans τ _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_τ_active H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + | htrans (ask ?e) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_ask_passive H as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + end. + (*| [inv_trans] is an helper tactic to automatically invert hypotheses involving [trans]. |*) -(* #[local] Notation trans' l t u := (hrel_of (trans l) t u). *) - -(* Ltac inv_trans_one := *) -(* match goal with *) - -(* (* Ret *) *) -(* | h : trans' _ (Ret ?x) _ |- _ => *) -(* let EQl := fresh "EQl" in *) -(* apply trans_ret_inv in h as [?EQ EQl]; *) -(* match type of EQl with *) -(* | val _ = val _ => apply val_eq_inv in EQl; try (inversion EQl; fail) *) -(* | τ = val _ => now inv EQl *) -(* | obs _ _ = val _ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* Vis *) *) -(* | h : trans' _ (Vis ?e ?k) _ |- _ => *) -(* let EQl := fresh "EQl" in *) -(* apply trans_vis_inv in h as (?x & ?EQ & EQl); *) -(* match type of EQl with *) -(* | @obs _ ?X _ _ = obs _ _ => *) -(* let EQt := fresh "EQt" in *) -(* let EQe := fresh "EQe" in *) -(* let EQv := fresh "EQv" in *) -(* apply obs_eq_invT in EQl as EQt; *) -(* subst_hyp_in EQt h; *) -(* apply obs_eq_inv in EQl as [EQe EQv]; *) -(* try (inversion EQv; inversion EQe; fail) *) -(* | val _ = obs _ _ => now inv EQl *) -(* | τ = obs _ _ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* Step *) *) -(* | h : trans' _ (Step _) _ |- _ => *) -(* let EQl := fresh "EQl" in *) -(* apply trans_step_inv in h as (?EQ & EQl); *) -(* match type of EQl with *) -(* | τ = τ => clear EQl *) -(* | val _ = τ => now inv EQl *) -(* | obs _ _ = τ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* BrS *) *) -(* | h : trans' _ (BrS ?n ?k) _ |- _ => *) -(* let x := fresh "x" in *) -(* let EQl := fresh "EQl" in *) -(* apply trans_brS_inv in h as (x & ?EQ & EQl); *) -(* match type of EQl with *) -(* | τ = τ => clear EQl *) -(* | val _ = τ => now inv EQl *) -(* | obs _ _ = τ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* brS2 *) *) -(* | h : trans' _ (brS2 _ _) _ |- _ => *) -(* let EQl := fresh "EQl" in *) -(* apply trans_brS2_inv in h as (EQl & [?EQ | ?EQ]); *) -(* match type of EQl with *) -(* | τ = τ => clear EQl *) -(* | val _ = τ => now inv EQl *) -(* | obs _ _ = τ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* brS3 *) *) -(* | h : trans' _ (brS3 _ _ _) _ |- _ => *) -(* let EQl := fresh "EQl" in *) -(* apply trans_brS3_inv in h as (EQl & [?EQ | [?EQ | ?EQ]]); *) -(* match type of EQl with *) -(* | τ = τ => clear EQl *) -(* | val _ = τ => now inv EQl *) -(* | obs _ _ = τ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* brS4 *) *) -(* | h : trans' _ (brS4 _ _ _ _) _ |- _ => *) -(* let EQl := fresh "EQl" in *) -(* apply trans_brS4_inv in h as (EQl & [?EQ | [?EQ | [?EQ | ?EQ]]]); *) -(* match type of EQl with *) -(* | τ = τ => clear EQl *) -(* | val _ = τ => now inv EQl *) -(* | obs _ _ = τ => now inv EQl *) -(* | _ => idtac *) -(* end *) - -(* (* Guard *) *) -(* | h : trans' _ (Guard _) _ |- _ => *) -(* apply trans_guard_inv in h *) - -(* (* Br *) *) -(* | h : trans' _ (Br ?n ?k) _ |- _ => *) -(* let x := fresh "x" in *) -(* apply trans_br_inv in h as (x & ?TR) *) - -(* (* br2 *) *) -(* | h : trans' _ (br2 _ _) _ |- _ => *) -(* apply trans_br2_inv in h as [?TR | ?TR] *) - -(* (* br3 *) *) -(* | h : trans' _ (br3 _ _ _) _ |- _ => *) -(* apply trans_br3_inv in h as [?TR | [?TR | ?TR]] *) - -(* (* br4 *) *) -(* | h : trans' _ (br4 _ _ _ _) _ |- _ => *) -(* apply trans_br4_inv in h as [?TR | [?TR | [?TR | ?TR]]] *) - -(* (* Stuck *) *) -(* | h : trans' _ Stuck _ |- _ => *) -(* exfalso; eapply Stuck_is_stuck; now apply h *) -(* (* (* stuckS *) *) *) -(* (* | h : trans' _ stuckS _ |- _ => *) *) -(* (* exfalso; eapply stuckS_is_stuck; now apply h *) *) - -(* (* trigger *) *) -(* | h : trans' _ (CTree.bind (CTree.trigger ?e) ?t) _ |- _ => *) -(* apply trans_trigger_inv in h as (?x & ?EQ & ?EQl) *) - -(* end; try subs *) -(* . *) - -(* Ltac inv_trans := repeat inv_trans_one. *) +Ltac inv_label_eq EQl := + match type of EQl with + | τ = τ => + clear EQl + | val _ = val _ => + apply val_eq_inv in EQl; try (inversion EQl; fail) + | ask _ = ask _ => + let EQt := fresh "EQt" in + let EQe := fresh "EQe" in + apply ask_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply ask_inv in EQl as EQe; + try (inversion EQe; fail) + | rcv _ _ = rcv _ _ => + let EQt := fresh "EQt" in + let EQt := fresh "EQv" in + let EQe := fresh "EQe" in + apply rcv_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply rcv_inv in EQl as [EQe EQv]; + try (inversion EQe; inversion EQv; fail) + | _ => try now inv EQl + end. + +Ltac inv_trans_one := + match goal with + (* Ret *) + | h : htrans _ (α Ret _) _ |- _ => + let EQl := fresh "EQl" in + (apply trans_ret_inv in h as [?EQ EQl] || apply trans_ret_inv' in h as [?EQ EQl]); + inv_label_eq EQl + + (* Step *) + | h : htrans _ (α Step _) _ |- _ => + let EQl := fresh "EQl" in + apply trans_step_inv' in h as (?EQ & EQl); + inv_label_eq EQl + + (* Br *) + | h : htrans _ (α Br _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br_inv in h as (?n & TR) + + (* Guard *) + | h : htrans _ (α Guard _) _ |- _ => + apply trans_guard_inv in h + + (* Vis *) + | h : htrans _ (α (Vis ?e ?k)) _ |- _ => + let EQl := fresh "EQl" in + apply trans_vis_inv' in h as (?EQ & EQl); + inv_label_eq EQl + + (* Passive *) + | h : htrans _ (β ?e ?k) _ |- _ => + let EQl := fresh "EQl" in + apply trans_passive_inv' in h as (?x & ?EQ & EQl); + inv_label_eq EQl + + end. +Ltac inv_trans := repeat inv_trans_one. + Create HintDb trans. #[global] Hint Resolve trans_ret trans_ask trans_brS trans_br @@ -2164,3 +2150,5 @@ Create HintDb trans. wf_val_val wf_val_nonval wf_val_trans : trans. Ltac etrans := eauto with trans. +#[global] Arguments trans : simpl never. + From 7a32335e75526e20e38efa36f4b112e598b22c75 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 31 Oct 2025 17:05:57 +0100 Subject: [PATCH 13/61] Finished strong simulation --- theories/Core/CTreeDefinitions.v | 5 +- theories/Core/Utils.v | 1 + theories/Eq/SSim.v | 301 +++++++++++-------------------- theories/Eq/Trans.v | 74 ++++---- 4 files changed, 155 insertions(+), 226 deletions(-) diff --git a/theories/Core/CTreeDefinitions.v b/theories/Core/CTreeDefinitions.v index f1fb5f4..39b4e79 100644 --- a/theories/Core/CTreeDefinitions.v +++ b/theories/Core/CTreeDefinitions.v @@ -25,8 +25,9 @@ br. From ITree Require Import Basics.Basics Core.Subevent Indexed.Sum. -From CTree Require Import - Core.Utils Core.Index. +From CTree Require Export + Core.Utils. +From CTree Require Import Core.Index. From ExtLib Require Import Structures.Functor diff --git a/theories/Core/Utils.v b/theories/Core/Utils.v index da6932c..21b1e3f 100644 --- a/theories/Core/Utils.v +++ b/theories/Core/Utils.v @@ -1,4 +1,5 @@ #[global] Set Warnings "-intuition-auto-with-star". +#[global] Set Warnings "-warn-library-file-stdlib-vector". From Stdlib Require Import Fin. From Stdlib Require Export Program.Equality. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 7460cb0..930b14d 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -24,9 +24,6 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. -(* Truc de ce genre c'est un Proper *) -(* forall X Y (R : X -> Y -> Prop), equiv R (ret x) (ret y) -> R x y. *) - Section build_rel. Context {E F : Type -> Type} {X Y : Type}. @@ -81,7 +78,7 @@ Arguments build_rel {E F X Y} RL. #[global] Hint Constructors build_rel : trans. Coercion build_rel : lrel >-> hrel. -Definition upd_Lrel {E F X Y X' Y'} +Definition upd_rel {E F X Y X' Y'} (RL : lrel E F X Y) (SS : rel X' Y') : lrel E F X' Y' := {| @@ -111,6 +108,12 @@ Definition Lvrel {E X Y} (RR : rel X Y) : lrel E E X Y := Rrcv := eq2 |}. +Ltac invL := + match goal with + h: build_rel _ _ _ |- _ => dependent induction h + | h: upd_rel _ _ _ _ |- _ => dependent induction h + end. + Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. @@ -395,7 +398,7 @@ and with the argument (pointwise) on the continuation. {R : Chain (@ss E F C D X' Y' L)} : forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), - ssim (upd_Lrel L SS) t t' -> + ssim (upd_rel L SS) t t' -> (forall x y, SS x y -> ` R (k x) (k' y)) -> ` R (bind t k) (bind t' k'). Proof. @@ -411,7 +414,7 @@ and with the argument (pointwise) on the continuation. + subst l. apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). inv HRL. - refine_transition STEP'. + refine_trans. ex2; split3. apply trans_bind_l_τ; eauto. * rewrite EQ. @@ -421,8 +424,8 @@ and with the argument (pointwise) on the continuation. * etrans. + subst l. apply tt' in STEP as (? & ? & STEP' & HSIM & HRL). - dependent induction HRL. - refine_transition STEP'. + invL. + refine_trans. exists (ask f); ex; split3. eapply trans_bind_l_ask; eauto. * rewrite SEQ. @@ -434,7 +437,7 @@ and with the argument (pointwise) on the continuation. step in HSIM; apply HSIM in TR as (l' & u' & TR' & HSIM' & HRL'). pose proof trans_passive_inv' TR' as (b & EQ' & ->). exists (rcv f b); ex; split; eauto; split; cycle 1. - {dependent induction HRL'. etrans.} + { invL; etrans. } rewrite EQ. apply H. rewrite EQ' in HSIM'; auto. @@ -442,7 +445,7 @@ and with the argument (pointwise) on the continuation. now step; apply kk'. * etrans. + apply tt' in STEPres as (? & ? & STEP' & HSIM & HRL). - dependent induction HRL. + invL. apply (kk' v y) in STEP as (l' & u' & STEP'' & HSIM'' & HRL'). exists l'; eexists; split; eauto. 2:etrans. @@ -486,7 +489,7 @@ Specializations to the gfp L (SS : rel X Y) (t1 : ctree E C X) (t2: ctree F D Y) (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - t1 (≲ upd_Lrel L SS) t2 -> + t1 (≲ upd_rel L SS) t2 -> (forall x y, SS x y -> k1 x (≲ L) k2 y) -> t1 >>= k1 (≲ L) t2 >>= k2. Proof. @@ -544,8 +547,8 @@ Ltac __play_ssim := step; cbn; intros ? ? ?TR. Ltac __play_ssim_in H := step in H; - cbn in H; edestruct H as (? & ? & ?TR & ?EQ & ?HL); - clear H; [etrans |]. + cbn in H; edestruct H as (? & ? & ?TR & ?SS & ?HL); + clear H; [etrans |]; fold_ssim. Ltac __eplay_ssim := match goal with @@ -940,12 +943,9 @@ Internal transitions eapply ssim_is_stuck. intros ?? TR. rewrite ctree_eta in TR; cbn in TR. - inv_trans. + now inv_trans. Qed. - (* CHECKPOINT *) - - (* Seems useless, but used in a fold lemma. To double check *) (* Lemma step_ss_ret_l_gen {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L R : rel _ _) : *) (* R Stuck Stuck -> *) @@ -976,230 +976,149 @@ Internal transitions (*| Inversion principles -------------------- +Question: are the principles useful over [ss] as well? |*) - - Lemma ssim_stuck_rev L (t : ctree E C X) (u : ctree F D Y) : - is_stuck u -> - @ssim E F C D X Y L t u -> + + Lemma ssim_stuck_inv L (t : ctree E C X) (u : ctree F D Y) + (IS : is_stuck u) + (SS :@ssim E F C D X Y L t u) : is_stuck t. Proof. - intros IS SS l t' TR. + intros l t' TR. step in SS. apply SS in TR. edestruct5 TR. eapply IS; eauto. Qed. - Lemma ssim_ret_inv {F D Y} {L: rel (label E) (label F)} (r1 : X) (r2 : Y) : - ssim L (Ret r1 : ctree E C X) (Ret r2 : ctree F D Y) -> - L (val r1) (val r2). + Lemma ssim_ret_l_inv L : + forall r (u : ctree F D Y) + (SS : @ssim E F C D X Y L (Ret r) u), + exists r' u', trans (val r') u u' /\ RR L r r'. Proof. - intro. - eplay. - inv_trans; subst; assumption. + intros. step in SS. + edestruct5 SS; etrans. + invL. + ex2; split; etrans. Qed. - - Lemma ss_ret_l_inv {F D Y L R} : - forall r (u : ctree F D Y), - ss L R (Ret r : ctree E C X) u -> - exists l' u', trans l' u u' /\ R Stuck u' /\ L (val r) l'. + + Lemma ssim_ret_inv L (r1 : X) (r2 : Y) + (SS : @ssim E F C D X Y L (Ret r1) (Ret r2)) : + L (val r1) (val r2). Proof. - intros. apply H; etrans. + eplay. + now inv_trans. Qed. - Lemma ssim_ret_l_inv {F D Y L} : - forall r (u : ctree F D Y), - ssim L (Ret r : ctree E C X) u -> - exists l' u', trans l' u u' /\ L (val r) l'. + Lemma ssim_vis_inv {X1 X2} L + (e : E X1) (f : F X2) + (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree F D Y) + (SS : ssim L (Vis e k1) (Vis f k2)) : + Rask L e f /\ + (forall x, exists y, Rrcv L e f x y /\ ssim L (k1 x) (k2 y)). Proof. - intros. step in H. - apply ss_ret_l_inv in H as (? & ? & ? & ? & ?). etrans. + eplay; inv_trans; invL. + split; auto. + intros x. + unshelve eplay; [exact x |]. + invL. + inv_trans. + dependent destruction EQl. + ex; split; eauto. Qed. - Lemma ssim_vis_inv_type {D Y X1 X2} - (e1 : E X1) (e2 : E X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree E D Y) (x1 : X1): - ssim eq (Vis e1 k1) (Vis e2 k2) -> - X1 = X2. + Lemma ssim_vis_l_inv {Z L} : + forall (e : E Z) (k : Z -> ctree E C X) u, + @ssim E F C D X Y L (Vis e k) u -> + exists Z' (f : F Z') k', + trans (ask f) u (β f k') /\ + Rask L e f /\ + forall x, exists y, ssim L (k x) (k' y) /\ Rrcv L e f x y. Proof. intros. - step in H; cbn in H. - edestruct H as (? & ? & ? & ? & ?). - etrans. - inv_trans; subst; auto. - eapply obs_eq_invT; eauto. - Unshelve. - exact x1. + eplay; invL; refine_trans. + ex3; split3; etrans. + intros z. + unshelve eplay; [eassumption |]; inv_trans; invL. + ex; split; etrans. Qed. - Lemma ssbt_vis_inv {F D Y X1 X2} {L: rel (label E) (label F)} - (e1 : E X1) (e2 : F X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree F D Y) (x : X1) - {R : Chain (@ss E F C D X Y L)} : - ss L (elem R) (Vis e1 k1) (Vis e2 k2) -> - (exists y, L (obs e1 x) (obs e2 y)) /\ (forall x, exists y, ` R (k1 x) (k2 y)). + Lemma ssim_guard_l_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + ssim L (Guard t1) t2 -> + ssim L t1 t2. Proof. - intros. - split; intros; edestruct H as (? & ? & ? & ? & ?); - etrans; subst; - inv_trans; subst; eexists; auto. - - now eapply H2. - - now apply H1. + intros SS; play; eplay. + ex2; split3; etrans. Qed. - Lemma ssim_vis_inv {F D Y X1 X2} {L: rel (label E) (label F)} - (e1 : E X1) (e2 : F X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree F D Y) (x : X1): - ssim L (Vis e1 k1) (Vis e2 k2) -> - (exists y, L (obs e1 x) (obs e2 y)) /\ (forall x, exists y, ssim L (k1 x) (k2 y)). + Lemma ssim_guard_r_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + ssim L t1 (Guard t2) -> + ssim L t1 t2. Proof. - intros. - split. - - eplay. - inv_trans; subst; exists x2; eauto. - - intros y. - step in H. - cbn in H. - edestruct H as (l' & u' & TR & IN & HL). - apply trans_vis with (x := y). - inv_trans. - eexists. - apply IN. + intros SS; play; eplay; inv_trans. + ex2; split3; etrans. Qed. - Lemma ss_vis_l_inv {F D Y Z L R} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - ss L R (Vis e k) u -> - exists l' u', trans l' u u' /\ R (k x) u' /\ L (obs e x) l'. + Lemma ssim_guard_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + ssim L (Guard t1) (Guard t2) -> + ssim L t1 t2. Proof. - intros. apply H; etrans. + intros. + now apply ssim_guard_r_inv, ssim_guard_l_inv. Qed. - Lemma ssim_vis_l_inv {F D Y Z L} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - ssim L (Vis e k) u -> - exists l' u', trans l' u u' /\ ssim L (k x) u' /\ L (obs e x) l'. + Lemma ssim_br_l_inv L Z + (c: C Z) (t : ctree F D Y) (k : Z -> ctree E C X): + ssim L (Br c k) t -> + forall x, ssim L (k x) t. Proof. - intros. step in H. - now simple apply ss_vis_l_inv with (x := x) in H. + intros; play; eplay; eauto. Qed. - Lemma ss_step_inv {F D Y} {L: rel (label E) (label F)} {R : Chain (@ss E F C D X Y L)} - (t1 : ctree E C X) (t2 : ctree F D Y) : - ss L (elem R) (Step t1) (Step t2) -> - (elem R t1 t2). + Lemma ssim_br_r_inv L Z + (d: D Z) (t : ctree E C X) (k : Z -> ctree F D Y): + ssim L t (Br d k) -> + forall l t', trans l t t' -> + exists x l' u', trans l' (k x) u' /\ + ssim L t' u' /\ + L l l'. Proof. - intros EQ. - edestruct EQ as (l & t & TR & REL & HL); etrans. - now inv_trans. + intros SS * TR. + eplay; inv_trans. + ex3; split3; eauto. Qed. - Lemma ssim_step_inv {F D Y} {L: rel (label E) (label F)} - (t1 : ctree E C X) (t2 : ctree F D Y) : + Lemma ssim_step_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : ssim L (Step t1) (Step t2) -> ssim L t1 t2. Proof. - intros EQ. step in EQ. now apply ss_step_inv. + intros; eplay; inv_trans; etrans. Qed. - Lemma ss_step_l_inv {F D Y L R} : - forall (t : ctree E C X) (u : ctree F D Y), - ss L R (Step t) u -> - exists l' u', trans l' u u' /\ R t u' /\ L τ l'. + Lemma ssim_step_l_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + ssim L (Step t1) t2 -> + exists t2', trans τ t2 t2' /\ ssim L t1 t2'. Proof. - etrans. - Qed. - - Lemma ssim_step_l_inv {F D Y L} : - forall (t : ctree E C X) (u : ctree F D Y), - Step t (≲L) u -> - exists l' u', trans l' u u' /\ t (≲L) u' /\ L τ l'. - Proof. - intros. step in H. etrans. + intros; eplay; invL; refine_trans. + ex; split; etrans. Qed. - Lemma ssbt_brS_inv {F D Y} {L: rel (label E) (label F)} {R : Chain (@ss E F C D X Y L)} - n m (cn: C n) (cm: D m) (k1 : n -> ctree E C X) (k2 : m -> ctree F D Y) : - ss L (elem R) (BrS cn k1) (BrS cm k2) -> - (forall i1, exists i2, elem R (k1 i1) (k2 i2)). + Lemma ssim_brS_inv L + A B (c: C A) (d: D B) (k1 : A -> ctree E C X) (k2 : B -> ctree F D Y) : + ssim L (BrS c k1) (BrS d k2) -> + forall i1, exists i2, ssim L (k1 i1) (k2 i2). Proof. intros EQ i1. - edestruct EQ as (l & t & TR & REL & HL); etrans. - inv_trans. subst. eauto. + eplay; invL; inv_trans; eauto. Qed. - Lemma ssim_brS_inv {F D Y} {L: rel (label E) (label F)} - n m (cn: C n) (cm: D m) (k1 : n -> ctree E C X) (k2 : m -> ctree F D Y) : - ssim L (BrS cn k1) (BrS cm k2) -> - (forall i1, exists i2, ssim L (k1 i1) (k2 i2)). + Lemma ssim_brS_l_inv L + A (c: C A) (k1 : A -> ctree E C X) (t2 : ctree F D Y) : + ssim L (BrS c k1) t2 -> + forall i, exists t2', trans τ t2 t2' /\ ssim L (k1 i) t2'. Proof. intros EQ i1. - eplay. - subst; inv_trans. - eexists; eauto. - Qed. - - Lemma ss_brS_l_inv {F D Y Z L R} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - ss L R (BrS c k) u -> - exists l' u', trans l' u u' /\ R (k x) u' /\ L τ l'. - Proof. - intros. apply H; etrans. - Qed. - - Lemma ssim_brS_l_inv {F D Y Z L} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - ssim L (BrS c k) u -> - exists l' u', trans l' u u' /\ ssim L (k x) u' /\ L τ l'. - Proof. - intros. step in H. - now simple apply ss_brS_l_inv with (x := x) in H. - Qed. - - Lemma ss_br_l_inv {F D Y} {L: rel (label E) (label F)} - n (c: C n) (t : ctree F D Y) (k : n -> ctree E C X) R: - ss L R (Br c k) t -> - forall x, ss L R (k x) t. - Proof. - cbn. intros. - eapply trans_br in H0; [| reflexivity]. - apply H in H0 as (? & ? & ? & ? & ?); subst. - eauto. - Qed. - - Lemma ssim_br_l_inv {F D Y} {L: rel (label E) (label F)} - n (c: C n) (t : ctree F D Y) (k : n -> ctree E C X): - ssim L (Br c k) t -> - forall x, ssim L (k x) t. - Proof. - intros. step. step in H. eapply ss_br_l_inv. apply H. - Qed. - - Lemma ss_guard_l_inv {F D Y} {L: rel (label E) (label F)} - (t : ctree E C X) (u : ctree F D Y) R: - ss L R (Guard t) u -> - ss L R t u. - Proof. - cbn. intros. - eapply trans_guard in H0. - apply H in H0 as (? & ? & ? & ? & ?); subst. - eauto. - Qed. - - Lemma ssim_guard_l_inv {F D Y} {L: rel (label E) (label F)} - (t : ctree E C X) (u : ctree F D Y): - ssim L (Guard t) u -> - ssim L t u. - Proof. - intros. step. step in H. eapply ss_guard_l_inv. apply H. - Qed. - - (* This one isn't very convenient... *) - Lemma ssim_br_r_inv {F D Y} {L: rel (label E) (label F)} - n (c: D n) (t : ctree E C X) (k : n -> ctree F D Y): - ssim L t (Br c k) -> - forall l t', trans l t t' -> - exists l' x t'' , trans l' (k x) t'' /\ L l l' /\ (ssim L t' t''). - Proof. - cbn. intros. step in H. apply H in H0 as (? & ? & ? & ? & ?); subst. inv_trans. - do 3 eexists; eauto. + eplay; invL; inv_trans; eauto. Qed. End Proof_Rules. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 7b002f5..2be126e 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -1505,8 +1505,8 @@ Proof. apply trans_bind_l_ask; auto. Qed. -Lemma trans_τ_active {E B X} (t : ctree E B X) u : - trans τ (α t) u -> +Lemma trans_τ_inv {E B X} t u : + @trans E B X τ t u -> exists u', Seq u (α u'). Proof. intros TR; cbn in TR; dependent induction TR. @@ -1516,17 +1516,17 @@ Proof. - eauto. Qed. -Lemma etrans_τ_active {E B X} (t : ctree E B X) u : +Lemma etrans_τ_inv {E B X} (t : ctree E B X) u : etrans τ (α t) u -> exists u', Seq u (α u'). Proof. intros [TR | TR]. - - eapply trans_τ_active; eauto. + - eapply trans_τ_inv; eauto. - cbn in *; exists t; rewrite TR; auto. Qed. -Lemma trans_ask_passive {E B X Y} (t : ctree E B X) (e : E Y) u : - trans (ask e) (α t) u -> +Lemma trans_ask_inv {E B X Y} t (e : E Y) u : + @trans E B X (ask e) t u -> exists g, Seq u (β e g). Proof. intros TR; cbn in TR; dependent induction TR. @@ -1536,11 +1536,11 @@ Proof. - eauto. Qed. -Lemma etrans_ask_active {E B X Y} (t : ctree E B X) (e : E Y) u : +Lemma etrans_ask_inv {E B X Y} (t : ctree E B X) (e : E Y) u : etrans (ask e) (α t) u -> exists g, Seq u (β e g). Proof. - intros TR; eapply trans_ask_passive; eauto. + intros TR; eapply trans_ask_inv; eauto. Qed. Lemma transs_τ_passive {E B X Y} e (g : X -> ctree E B Y) u : @@ -1560,7 +1560,7 @@ Proof. induction n as [| n IH]; intros t TR. - cbn in TR; exists t; symmetry; eauto. - destruct TR as [? TR TRs]. - eapply trans_τ_active in TR as [u' EQ]. + eapply trans_τ_inv in TR as [u' EQ]. rewrite EQ in TRs. edestruct IH; eauto. Qed. @@ -1581,7 +1581,7 @@ Proof. induction n as [| n IH]. - cbn; intros; exists 0%nat; cbn; inv TR; rewrite EQ; auto. - intros t u [v TR1 TR2]. - pose proof trans_τ_active TR1 as (v' & EQv). + pose proof trans_τ_inv TR1 as (v' & EQv). rewrite EQv in TR1,TR2. apply IH in TR2. eapply wtrans_τ, wcons. @@ -1596,7 +1596,7 @@ Proof. intros [t2 [t1 TR1 TR2] TR3]. pose proof transs_τ_active TR1 as (x & EQx). rewrite EQx in TR1,TR2. - pose proof etrans_τ_active TR2 as (y & EQy). + pose proof etrans_τ_inv TR2 as (y & EQy). rewrite EQy in TR2,TR3. pose proof transs_τ_active TR3 as (z & EQz). eexists; [eexists |]. @@ -1612,7 +1612,7 @@ Proof. intros [t2 [t1 TR1 TR2] TR3]. pose proof transs_τ_active TR1 as (x & EQx). rewrite EQx in TR1,TR2. - pose proof etrans_ask_active TR2 as (y & EQy). + pose proof etrans_ask_inv TR2 as (y & EQy). rewrite EQy in TR2,TR3. pose proof transs_τ_passive TR3 as EQz. eexists; [eexists |]. @@ -1670,7 +1670,7 @@ Proof. - inv EQl. Qed. -Lemma trans_rcv_active {E B X Y} (e : E Y) (y : Y) (u : ctree E B X) v : +Lemma trans_rcv_active_inv {E B X Y} (e : E Y) (y : Y) (u : ctree E B X) v : trans (rcv e y) (α u) v -> False. Proof. @@ -1714,13 +1714,13 @@ Proof. pose proof wtrans_τ_active TR1 as [? EQ1]. rewrite EQ1 in *. destruct l. - - pose proof etrans_τ_active TR2 as [? EQ2]. + - pose proof etrans_τ_inv TR2 as [? EQ2]. rewrite EQ2 in *. apply wtrans_τ in TR3. pose proof wtrans_τ_active TR3 as [? EQ3]. inv EQ3. - cbn in TR2. - pose proof trans_ask_passive TR2 as [h EQ]. + pose proof trans_ask_inv TR2 as [h EQ]. rewrite EQ in *; clear t2 EQ. clear t1 EQ1. apply wtrans_τ in TR3. @@ -1731,7 +1731,7 @@ Proof. split; auto. now constructor. - exfalso. - eapply trans_rcv_active; eauto. + eapply trans_rcv_active_inv; eauto. - exfalso. apply trans_val_inv' in TR2. rewrite TR2 in TR3. @@ -1778,13 +1778,13 @@ Proof. - right; eapply wconss; [apply TR1 | clear t TR1]. destruct H as (? & ? & ?). rewrite EQa in TR1'; clear t' EQa. - pose proof trans_τ_active H as [? EQ]. + pose proof trans_τ_inv H as [? EQ]. rewrite EQ in H,H0. eapply trans_bind_r in H; [| eauto]. eapply wcons; eauto. - right; eapply wconss; [apply TR1 | clear t TR1]. rewrite EQa in TR1'. - pose proof trans_τ_active TR as [? EQ]. + pose proof trans_τ_inv TR as [? EQ]. rewrite EQ in TR,WTR. eapply trans_bind_r in TR1'; eauto. eapply wconss; [|eauto]. @@ -1809,7 +1809,7 @@ Proof. apply trans_wtrans. pose proof trans_val_inv' TR as EQ; rewrite EQ in TR |-*. eapply trans_bind_r; eauto. - - pose proof trans_τ_active TR as [? EQ]. + - pose proof trans_τ_inv TR as [? EQ]. rewrite EQ in TR,WTR. eapply trans_bind_r in TR1'; eauto. eapply wconss; [|eauto]. @@ -1836,13 +1836,13 @@ Proof. clear v EQ. apply trans_wtrans. eapply trans_bind_r; eauto. - - pose proof trans_τ_active TRv as [? EQ]. + - pose proof trans_τ_inv TRv as [? EQ]. rewrite EQ in *; clear v0 EQ. eapply wcons. eapply trans_bind_r; eauto. eapply wconss; eauto. now apply trans_wtrans. - - pose proof trans_τ_active TRv as [? EQ]. + - pose proof trans_τ_inv TRv as [? EQ]. rewrite EQ in *; clear v0 EQ. eapply wcons. eapply trans_bind_r; eauto. @@ -2038,20 +2038,20 @@ derive information on the active/passive status of its destination state. Currently very partial |*) -Ltac refine_transition H := - match type of H with - | htrans τ _ _ => +Ltac refine_trans := + match goal with + | h : htrans τ _ _ |- _ => let u := fresh "u" in let EQ := fresh "EQ" in - pose proof trans_τ_active H as [u EQ]; + pose proof trans_τ_inv h as [u EQ]; rewrite EQ in *; match type of EQ with | Seq ?a _ => try clear a EQ end - | htrans (ask ?e) _ _ => + | h : htrans (ask ?e) _ _ |- _ => let u := fresh "u" in let EQ := fresh "EQ" in - pose proof trans_ask_passive H as [u EQ]; + pose proof trans_ask_inv h as [u EQ]; rewrite EQ in *; match type of EQ with | Seq ?a _ => try clear a EQ @@ -2086,7 +2086,7 @@ Ltac inv_label_eq EQl := (* subst_hyp_in EQt h; *) apply rcv_inv in EQl as [EQe EQv]; try (inversion EQe; inversion EQv; fail) - | _ => try now inv EQl + | _ => subst; try now inv EQl end. Ltac inv_trans_one := @@ -2094,13 +2094,17 @@ Ltac inv_trans_one := (* Ret *) | h : htrans _ (α Ret _) _ |- _ => let EQl := fresh "EQl" in - (apply trans_ret_inv in h as [?EQ EQl] || apply trans_ret_inv' in h as [?EQ EQl]); + let EQ := fresh "EQ" in + (apply trans_ret_inv in h as [EQ EQl] || apply trans_ret_inv' in h as [EQ EQl]); + try rewrite EQ in *; inv_label_eq EQl (* Step *) | h : htrans _ (α Step _) _ |- _ => let EQl := fresh "EQl" in - apply trans_step_inv' in h as (?EQ & EQl); + let EQ := fresh "EQ" in + apply trans_step_inv' in h as (EQ & EQl); + try rewrite EQ in *; inv_label_eq EQl (* Br *) @@ -2115,15 +2119,19 @@ Ltac inv_trans_one := (* Vis *) | h : htrans _ (α (Vis ?e ?k)) _ |- _ => let EQl := fresh "EQl" in - apply trans_vis_inv' in h as (?EQ & EQl); + let EQ := fresh "EQ" in + apply trans_vis_inv' in h as (EQ & EQl); + try rewrite EQ in *; inv_label_eq EQl (* Passive *) | h : htrans _ (β ?e ?k) _ |- _ => let EQl := fresh "EQl" in - apply trans_passive_inv' in h as (?x & ?EQ & EQl); + let EQ := fresh "EQ" in + apply trans_passive_inv' in h as (?x & EQ & EQl); + try rewrite EQ in *; inv_label_eq EQl - + end. Ltac inv_trans := repeat inv_trans_one. From 7b1ca0e01a22dd9f71e0fb53c0f57ae6cbc63178 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 31 Oct 2025 17:48:28 +0100 Subject: [PATCH 14/61] Adapting and pulling out the monotone condition from cssim --- theories/Core/Utils.v | 4 +- theories/Eq/CSSim.v | 69 ++++++++--------- theories/Eq/SSim.v | 171 ++++++++---------------------------------- theories/Eq/Trans.v | 137 +++++++++++++++++++++++++++++++++ 4 files changed, 206 insertions(+), 175 deletions(-) diff --git a/theories/Core/Utils.v b/theories/Core/Utils.v index 21b1e3f..b3fba81 100644 --- a/theories/Core/Utils.v +++ b/theories/Core/Utils.v @@ -1,5 +1,5 @@ -#[global] Set Warnings "-intuition-auto-with-star". -#[global] Set Warnings "-warn-library-file-stdlib-vector". +#[export] Set Warnings "-intuition-auto-with-star". +#[export] Set Warnings "-warn-library-file-stdlib-vector". From Stdlib Require Import Fin. From Stdlib Require Export Program.Equality. diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index c563bc7..6ec545b 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -25,16 +25,13 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. -(* TODO: Decide where to set this *) -Arguments trans : simpl never. - Section CompleteStrongSim. (*| Complete strong simulation [css]. |*) Program Definition css {E F C D : Type -> Type} {X Y : Type} - (L : rel (@label E) (@label F)) : mon (ctree E C X -> ctree F D Y -> Prop) := + (L : lrel E F X Y) : mon (@S E C X -> @S F D Y -> Prop) := {| body R t u := ss L R t u /\ (forall l u', trans l u u' -> exists l' t', trans l' t t') |}. @@ -95,25 +92,46 @@ Ltac __step_in_cssim H := Import CTreeNotations. Import EquNotations. +Ltac __play_cssim := step; cbn; split; [intros ? ? ?TR | etrans]. + +Ltac __play_cssim_in H := + step in H; + cbn in H; edestruct H as [(? & ? & ?TR & ?EQ & ?HL) ?PROG]; + clear H; [etrans |]. + +Ltac __eplay_cssim := + match goal with + | h : @cssim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ => + __play_cssim_in h + end. + +#[local] Tactic Notation "play" := __play_cssim. +#[local] Tactic Notation "play" "in" ident(H) := __play_cssim_in H. +#[local] Tactic Notation "eplay" := __eplay_cssim. + +Definition sub_lrel {E B X Y} (L L' : lrel E B X Y) : Prop := + RR L <= RR L' /\ Rask L <= Rask L' /\ Rrcv L <= Rrcv L'. + +Lemma cssim_subrelation {E F C D X Y} : + Proper (sub_lrel ==> leq) (@cssim E F C D X Y). +Proof. + step in CSS. + simpl; split; intros; cbn in H0; destruct H0 as [H0' H0'']. + - cbn in H0'; apply H0' in H1 as (? & ? & ? & ? & ?); + apply H in H2. exists x, x0. auto. + - apply H0'' in H1 as (? & ? & ?). + do 2 eexists; apply H0. +Qed. + + Section cssim_homogenous_theory. - Context {E B : Type -> Type} {X : Type} - {L: relation (@label E)}. + Context {E B : Type -> Type} {X : Type}. Notation css := (@css E E B B X X). Notation cssim := (@cssim E E B B X X). - Lemma cssim_subrelation : forall (t t' : ctree E B X) L', - subrelation L L' -> cssim L t t' -> cssim L' t t'. - Proof. - intros. revert t t' H0. coinduction R CH. - intros. step in H0. simpl; split; intros; cbn in H0; destruct H0 as [H0' H0'']. - - cbn in H0'; apply H0' in H1 as (? & ? & ? & ? & ?); - apply H in H2. exists x, x0. auto. - - apply H0'' in H1 as (? & ? & ?). - do 2 eexists; apply H0. - Qed. - + (*| Various results on reflexivity and transitivity. |*) @@ -398,23 +416,6 @@ Proof. apply H0. Qed. -Ltac __play_cssim := step; cbn; split; [intros ? ? ?TR | etrans]. - -Ltac __play_cssim_in H := - step in H; - cbn in H; edestruct H as [(? & ? & ?TR & ?EQ & ?HL) ?PROG]; - clear H; [etrans |]. - -Ltac __eplay_cssim := - match goal with - | h : @cssim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ => - __play_cssim_in h - end. - -#[local] Tactic Notation "play" := __play_cssim. -#[local] Tactic Notation "play" "in" ident(H) := __play_cssim_in H. -#[local] Tactic Notation "eplay" := __eplay_cssim. - Section Proof_Rules. Arguments label: clear implicits. Context {E C : Type -> Type} {X: Type}. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 930b14d..80a96df 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -24,125 +24,6 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. -Section build_rel. - - Context {E F : Type -> Type} {X Y : Type}. - - Record lrel := - { - RR: rel X Y ; - Rask: forall [X Y], E X -> F Y -> Prop ; - Rrcv: forall [X Y] (e : E X) (f : F Y), X -> Y -> Prop ; - }. - - Variant build_rel {RL : lrel} : hrel (label E) (label F) := - | rel_τ : build_rel τ τ - | rel_ask {X Y} {e : E X} {f : F Y} - (HR : Rask RL e f) : - build_rel (ask e) (ask f) - | rel_rcv {X Y} {e : E X} {f : F Y} x y - (HR : Rrcv RL e f x y) : - build_rel (rcv e x) (rcv f y) - | rel_ret {x : X} {y : Y}: - RR RL x y -> build_rel (val x) (val y). - Arguments build_rel : clear implicits. - - Lemma build_rel_val RL x y : - build_rel RL (val x) (val y) -> RR RL x y. - Proof. - now intros H; dependent induction H. - Qed. - - Lemma build_rel_ask RL A B (e : E A) (f : F B) : - build_rel RL (ask e) (ask f) -> Rask RL e f. - Proof. - now intros H; dependent induction H. - Qed. - - Lemma build_rel_rcv RL A B (e : E A) (f : F B) a b : - build_rel RL (rcv e a) (rcv f b) -> Rrcv RL e f a b. - Proof. - now intros H; dependent induction H. - Qed. - - Lemma build_rel_τ RL : - build_rel RL τ τ. - Proof. - constructor. - Qed. - -End build_rel. - -Arguments lrel : clear implicits. -Arguments build_rel {E F X Y} RL. -#[global] Hint Constructors build_rel : trans. -Coercion build_rel : lrel >-> hrel. - -Definition upd_rel {E F X Y X' Y'} - (RL : lrel E F X Y) - (SS : rel X' Y') : lrel E F X' Y' := - {| - RR := SS ; - Rask := Rask RL ; - Rrcv := Rrcv RL - |}. - -Variant eq1 {E} : forall [X Y : Type], rel (E X) (E Y) := - | Eq1 X (e : E X) : eq1 e e. -Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := - | Eq2 X (e : E X) x : eq2 e e x x. -Hint Resolve Eq1 : trans. -Hint Resolve Eq2 : trans. - -Definition Leq {E} {X : Type} : lrel E E X X := - {| - RR := eq ; - Rask := eq1 ; - Rrcv := eq2 - |}. - -Definition Lvrel {E X Y} (RR : rel X Y) : lrel E E X Y := - {| - RR := RR ; - Rask := eq1 ; - Rrcv := eq2 - |}. - -Ltac invL := - match goal with - h: build_rel _ _ _ |- _ => dependent induction h - | h: upd_rel _ _ _ _ |- _ => dependent induction h - end. - -Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := - fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. - -#[global] Instance lequiv_equivalence {E F X Y} : Equivalence (@lequiv E F X Y). -Proof. - constructor. - - split3; auto. - - intros ?? [? []]; split3; symmetry; auto. - - intros ??? [? []] [? []]; split3; etransitivity; eauto. -Qed. - -#[global] Instance lequiv_build_rel {E F X Y} : Proper (lequiv ==> weq) (@build_rel E F X Y). -Proof. - cbn; intros L1 L2 [EQ1 [EQ2 EQ3]] l1 l2; split; intros H. - - inv H; etrans. - constructor; now apply EQ2. - constructor; now apply EQ3. - constructor; now apply EQ1. - - inv H; etrans. - constructor; now apply EQ2. - constructor; now apply EQ3. - constructor; now apply EQ1. -Qed. - -#[global] Instance lequiv_build_rel' {E F X Y} : Proper (lequiv ==> eq ==> eq ==> iff) (@build_rel E F X Y). -Proof. - now cbn; intros; subst; eapply lequiv_build_rel. -Qed. - Section StrongSim. (*| The function defining strong simulations: [trans] plays must be answered @@ -229,6 +110,23 @@ Tactic Notation "__coinduction_ssim" simple_intropattern(r) simple_intropattern( first [unfold ssim at 4 | unfold ssim at 3 | unfold ssim at 2 | unfold ssim at 1]; coinduction r cih. #[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_ssim r cih || coinduction r cih. +Ltac __play_ssim := step; cbn; intros ? ? ?TR. + +Ltac __play_ssim_in H := + step in H; + cbn in H; edestruct H as (? & ? & ?TR & ?SS & ?HL); + clear H; [etrans |]; fold_ssim. + +Ltac __eplay_ssim := + match goal with + | h : @ssim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ => + __play_ssim_in h + end. + +#[local] Tactic Notation "play" := __play_ssim. +#[local] Tactic Notation "play" "in" ident(H) := __play_ssim_in H. +#[local] Tactic Notation "eplay" := __eplay_ssim. + Section ssim_homogenous_theory. Context {E B: Type -> Type} {X: Type} {L: lrel E E X X}. @@ -256,18 +154,30 @@ Section ssim_homogenous_theory. Proof. split; typeclasses eauto. Qed. End ssim_homogenous_theory. - + (*| Parametric theory of [ss] with heterogenous [L] |*) Section ssim_heterogenous_theory. Arguments label: clear implicits. - Context {E F C D: Type -> Type} {X Y: Type} - {L: lrel E F X Y}. + Context {E F C D: Type -> Type} {X Y: Type}. Notation ss := (@ss E F C D X Y). Notation ssim := (@ssim E F C D X Y). + Lemma ssim_subrelation : + Proper (sub_lrel ==> leq) ssim. + Proof. + cbn; intros * SUB. + coinduction R cih. + intros u v HSS l u' TR. + eplay. + ex2; split3; etrans. + eapply sub_lrel_subrel; eauto. + Qed. + + Context {L: lrel E F X Y}. + (*| Strong simulation up-to [equ] is valid ---------------------------------------- @@ -543,23 +453,6 @@ Qed. (* cbn. intros. now apply ssim_clo_bind_eq. *) (* Qed. *) -Ltac __play_ssim := step; cbn; intros ? ? ?TR. - -Ltac __play_ssim_in H := - step in H; - cbn in H; edestruct H as (? & ? & ?TR & ?SS & ?HL); - clear H; [etrans |]; fold_ssim. - -Ltac __eplay_ssim := - match goal with - | h : @ssim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ => - __play_ssim_in h - end. - -#[local] Tactic Notation "play" := __play_ssim. -#[local] Tactic Notation "play" "in" ident(H) := __play_ssim_in H. -#[local] Tactic Notation "eplay" := __eplay_ssim. - (* Notation ssim_ L t u := (ssim L (α t) (α u)). *) (* Notation ss_ L t u := (ss L _ (α t) (α u)). *) diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 2be126e..d248723 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -2160,3 +2160,140 @@ Create HintDb trans. Ltac etrans := eauto with trans. #[global] Arguments trans : simpl never. + +(*| +Structured relations on labels +|*) + +Section build_rel. + + Context {E F : Type -> Type} {X Y : Type}. + + Record lrel := + { + RR: rel X Y ; + Rask: forall [X Y], E X -> F Y -> Prop ; + Rrcv: forall [X Y] (e : E X) (f : F Y), X -> Y -> Prop ; + }. + + Variant build_rel {RL : lrel} : hrel (label E) (label F) := + | rel_τ : build_rel τ τ + | rel_ask {X Y} {e : E X} {f : F Y} + (HR : Rask RL e f) : + build_rel (ask e) (ask f) + | rel_rcv {X Y} {e : E X} {f : F Y} x y + (HR : Rrcv RL e f x y) : + build_rel (rcv e x) (rcv f y) + | rel_ret {x : X} {y : Y}: + RR RL x y -> build_rel (val x) (val y). + Arguments build_rel : clear implicits. + + Lemma build_rel_val RL x y : + build_rel RL (val x) (val y) -> RR RL x y. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_ask RL A B (e : E A) (f : F B) : + build_rel RL (ask e) (ask f) -> Rask RL e f. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_rcv RL A B (e : E A) (f : F B) a b : + build_rel RL (rcv e a) (rcv f b) -> Rrcv RL e f a b. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_τ RL : + build_rel RL τ τ. + Proof. + constructor. + Qed. + +End build_rel. + +Arguments lrel : clear implicits. +Arguments build_rel {E F X Y} RL. +#[global] Hint Constructors build_rel : trans. +Coercion build_rel : lrel >-> hrel. + +Definition upd_rel {E F X Y X' Y'} + (RL : lrel E F X Y) + (SS : rel X' Y') : lrel E F X' Y' := + {| + RR := SS ; + Rask := Rask RL ; + Rrcv := Rrcv RL + |}. + +Variant eq1 {E} : forall [X Y : Type], rel (E X) (E Y) := + | Eq1 X (e : E X) : eq1 e e. +Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := + | Eq2 X (e : E X) x : eq2 e e x x. +Hint Resolve Eq1 : trans. +Hint Resolve Eq2 : trans. + +Definition Leq {E} {X : Type} : lrel E E X X := + {| + RR := eq ; + Rask := eq1 ; + Rrcv := eq2 + |}. + +Definition Lvrel {E X Y} (RR : rel X Y) : lrel E E X Y := + {| + RR := RR ; + Rask := eq1 ; + Rrcv := eq2 + |}. + +Ltac invL := + match goal with + h: build_rel _ _ _ |- _ => dependent induction h + | h: upd_rel _ _ _ _ |- _ => dependent induction h + end. + +Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := + fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. + +#[global] Instance lequiv_equivalence {E F X Y} : Equivalence (@lequiv E F X Y). +Proof. + constructor. + - split3; auto. + - intros ?? [? []]; split3; symmetry; auto. + - intros ??? [? []] [? []]; split3; etransitivity; eauto. +Qed. + +#[global] Instance lequiv_build_rel {E F X Y} : Proper (lequiv ==> weq) (@build_rel E F X Y). +Proof. + cbn; intros L1 L2 [EQ1 [EQ2 EQ3]] l1 l2; split; intros H. + - inv H; etrans. + constructor; now apply EQ2. + constructor; now apply EQ3. + constructor; now apply EQ1. + - inv H; etrans. + constructor; now apply EQ2. + constructor; now apply EQ3. + constructor; now apply EQ1. +Qed. + +#[global] Instance lequiv_build_rel' {E F X Y} : Proper (lequiv ==> eq ==> eq ==> iff) (@build_rel E F X Y). +Proof. + now cbn; intros; subst; eapply lequiv_build_rel. +Qed. + +Definition sub_lrel {E F X Y} (L L' : lrel E F X Y) : Prop := + RR L <= RR L' /\ Rask L <= Rask L' /\ Rrcv L <= Rrcv L'. + +Lemma sub_lrel_subrel {E F X Y} : + Proper (sub_lrel ==> leq) (@build_rel E F X Y). +Proof. + intros L L' (SUB1 & SUB2 & SUB3) ?? HL. + inv HL; etrans. + now constructor; apply SUB2. + now constructor; apply SUB3. + now constructor; apply SUB1. +Qed. + From 6fe6f557147bae2818543f95cd9f7b5fdafa9a60 Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 3 Nov 2025 11:08:21 +0100 Subject: [PATCH 15/61] Pulled out not_stuck predicate, adapted complete simulation down to up-to bind --- theories/Core/Utils.v | 7 + theories/Eq/CSSim.v | 416 ++++++++++++++++++++++++++++-------------- theories/Eq/SSim.v | 13 +- theories/Eq/Trans.v | 216 +++++++++++++++------- 4 files changed, 449 insertions(+), 203 deletions(-) diff --git a/theories/Core/Utils.v b/theories/Core/Utils.v index b3fba81..55a5010 100644 --- a/theories/Core/Utils.v +++ b/theories/Core/Utils.v @@ -119,3 +119,10 @@ Ltac split3 := split; [| split]. Ltac edestruct3 H := edestruct H as (? & ? & ?). Ltac edestruct4 H := edestruct H as (? & ? & ? & ?). Ltac edestruct5 H := edestruct H as (? & ? & ? & ? & ?). + +(* Simple inhabited class in the sytle of stdpp. + Long term to do: use stdpp + *) +Class Inhabited (A : Type) : Type := populate { inhabitant : A }. +Global Hint Mode Inhabited ! : typeclass_instances. +Global Arguments populate {_} _ : assert. diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index 6ec545b..d2b863d 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -30,10 +30,11 @@ Section CompleteStrongSim. (*| Complete strong simulation [css]. |*) + Program Definition css {E F C D : Type -> Type} {X Y : Type} (L : lrel E F X Y) : mon (@S E C X -> @S F D Y -> Prop) := {| body R t u := - ss L R t u /\ (forall l u', trans l u u' -> exists l' t', trans l' t t') + ss L R t u /\ (forall l u', trans l u u' -> not_stuck t) |}. Next Obligation. split; eauto. intros. @@ -48,11 +49,15 @@ Definition cssim {E F C D X Y} L := Module CSSimNotations. (*| css (complete simulation) notation |*) - Notation "t (⪅ L ) u" := (cssim L t u) (at level 70). - Notation "t ⪅ u" := (cssim eq t u) (at level 70). - Notation "t [⪅ L ] u" := (css L _ t u) (at level 79). - Notation "t [⪅] u" := (css eq _ t u) (at level 79). - + + Infix "⪅" := (cssim Leq) (at level 70). + Notation "t (⪅ [ Q ] ) u" := (cssim (Lvrel Q) t u) (at level 79). + Notation "t (⪅ Q ) u" := (cssim Q t u) (at level 79). + + Notation "t '[⪅]' u" := (css Leq (` _) t u) (at level 90, only printing). + Notation "t '[⪅' [ R ] ']' u" := (css (Lvrel R) (` _) t u) (at level 90, only printing). + Notation "t '[⪅' R ']' u" := (css R (` _) t u) (at level 90, only printing). + End CSSimNotations. Import CSSimNotations. @@ -108,30 +113,15 @@ Ltac __eplay_cssim := #[local] Tactic Notation "play" := __play_cssim. #[local] Tactic Notation "play" "in" ident(H) := __play_cssim_in H. #[local] Tactic Notation "eplay" := __eplay_cssim. - -Definition sub_lrel {E B X Y} (L L' : lrel E B X Y) : Prop := - RR L <= RR L' /\ Rask L <= Rask L' /\ Rrcv L <= Rrcv L'. - -Lemma cssim_subrelation {E F C D X Y} : - Proper (sub_lrel ==> leq) (@cssim E F C D X Y). -Proof. - step in CSS. - simpl; split; intros; cbn in H0; destruct H0 as [H0' H0'']. - - cbn in H0'; apply H0' in H1 as (? & ? & ? & ? & ?); - apply H in H2. exists x, x0. auto. - - apply H0'' in H1 as (? & ? & ?). - do 2 eexists; apply H0. -Qed. - Section cssim_homogenous_theory. - Context {E B : Type -> Type} {X : Type}. + Context {E B : Type -> Type} {X : Type} + {L: lrel E E X X}. Notation css := (@css E E B B X X). Notation cssim := (@cssim E E B B X X). - (*| Various results on reflexivity and transitivity. |*) @@ -172,18 +162,33 @@ End cssim_homogenous_theory. Section cssim_heterogenous_theory. Arguments label: clear implicits. - Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. + Context {E F C D: Type -> Type} {X Y: Type}. Notation css := (@css E F C D X Y). Notation cssim := (@cssim E F C D X Y). + Lemma cssim_subrelation : + Proper (sub_lrel ==> leq) cssim. + Proof. + cbn; intros * SUB. + coinduction R cih. + intros u v CSS. + remember CSS as TMP; clear HeqTMP; + step in TMP; destruct TMP as [HSS HPROG]. + split; auto. + intros l u' TR. + eplay. + ex2; split3; etrans. + eapply sub_lrel_subrel; eauto. + Qed. + + Context {L: lrel E F X Y}. (*| Strong simulation up-to [equ] is valid ---------------------------------------- |*) - Lemma equ_clos_csst {c: Chain (css L)}: + Lemma equ_clos_chain {c: Chain (css L)}: forall x y, equ_clos `c x y -> `c x y. Proof. apply tower. @@ -203,76 +208,77 @@ Section cssim_heterogenous_theory. setoid_rewrite EQ'. eauto. Qed. - #[global] Instance equ_clos_csst_goal {c: Chain (css L)} : - Proper (equ eq ==> equ eq ==> flip impl) `c. - Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_csst; econstructor; [eauto | | symmetry; eauto]; assumption. - Qed. - - #[global] Instance equ_clos_csst_ctx {c: Chain (css L)} : - Proper (equ eq ==> equ eq ==> impl) `c. - Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_csst; econstructor; [symmetry; eauto | | eauto]; assumption. - Qed. - - #[global] Instance equ_css_closed_goal {r} : Proper (equ eq ==> equ eq ==> flip impl) (css L r). - Proof. - intros t t' tt' u u' uu'; cbn; intros [H H0]; split; intros l t0 TR. - - rewrite tt' in TR. destruct (H _ _ TR) as (? & ? & ? & ? & ?). - exists x, x0; auto; rewrite uu'; auto. - - rewrite uu' in TR. destruct (H0 _ _ TR) as (? & ? & ?). - exists x, x0; eauto; rewrite tt'; auto. - Qed. - - #[global] Instance equ_css_closed_ctx {r} : Proper (equ eq ==> equ eq ==> impl) (css L r). - Proof. - intros t t' tt' u u' uu'; cbn; intros [H H0]; split; intros l t0 TR. - - rewrite <- tt' in TR. destruct (H _ _ TR) as (? & ? & ? & ? & ?). - exists x, x0; auto; rewrite <- uu'; auto. - - rewrite <- uu' in TR. destruct (H0 _ _ TR) as (? & ? & ?). - exists x, x0; auto; rewrite <- tt'; auto. - Qed. - - Lemma is_stuck_css : forall (t: ctree E C X) (u: ctree F D Y) R, - css L R t u -> is_stuck t <-> is_stuck u. - Proof. - split; intros; intros ? ? ?. - - apply H in H1 as (? & ? & ?). now apply H0 in H1. - - apply H in H1 as (? & ? & ? & ? & ?). now apply H0 in H1. - Qed. - - Lemma is_stuck_cssim : forall (t: ctree E C X) (u: ctree F D Y), - t (⪅ L) u -> is_stuck t <-> is_stuck u. + #[global] Instance seq_chain_goal {c: Chain (css L)} : + Proper (Seq ==> Seq ==> flip impl) `c. Proof. - intros. step in H. eapply is_stuck_css; eauto. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' EQt u u' EQu [HS PROG]. + split. + now rewrite EQu, EQt. + intros l v TR. + rewrite EQu in TR. + edestruct PROG as (? & ? & ?); eauto. + ex2; rewrite EQt; eauto. Qed. - Lemma css_is_stuck : forall (t : ctree E C X) (u: ctree F D Y) R, - is_stuck t -> is_stuck u -> css L R t u. + #[global] Instance seq_css_goal {r} : + Proper (Seq ==> Seq ==> flip impl) (css L r). Proof. - split; intros. - - cbn. intros. now apply H in H1. - - now apply H0 in H1. + intros t t' tt' u u' uu'; cbn; intros [H1 H2]. + split; intros; auto. + - edestruct5 H1. + rewrite <- tt'; eauto. + ex2; split3; eauto. + now rewrite uu'. + - edestruct3 H2. + rewrite <- uu'; eauto. + ex2; rewrite tt'; eauto. Qed. - Lemma cssim_is_stuck : forall (t : ctree E C X) (u: ctree F D Y), - is_stuck t -> is_stuck u -> t (⪅ L) u. + #[global] Instance seq_chain_ctx {c: Chain (css L)} : + Proper (Seq ==> Seq ==> impl) `c. Proof. - intros. step. now apply css_is_stuck. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' EQt u u' EQu [HS PROG]; split. + now rewrite <- EQt, <- EQu. + intros l v TR. + rewrite <- EQu in TR. + edestruct PROG as (? & ? & ?); eauto. + ex2; rewrite <- EQt; eauto. Qed. - - Lemma cssim_ssim_subrelation_gen : forall x y, cssim L x y -> ssim L x y. + + #[global] Instance seq_css_ctx {r} : + Proper (Seq ==> Seq ==> impl) (css L r). Proof. - red. - coinduction r cih; intros * SB. - step in SB; destruct SB as [fwd _]. - intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. + intros t t' tt' u u' uu'; cbn; intros [H1 H2]. + split; intros; auto. + - edestruct5 H1. + rewrite tt'; eauto. + ex2; split3; eauto. + now rewrite <- uu'. + - edestruct3 H2. + rewrite uu'; eauto. + ex2; rewrite <- tt'; eauto. Qed. End cssim_heterogenous_theory. +#[global] Instance weq_ssim : forall {E F C D X Y}, + Proper (lequiv ==> weq) (@ssim E F C D X Y). +Proof. + cbn -[ss weq]. intros. apply gfp_weq. now apply lequiv_ss. +Qed. + (*| Up-to [bind] context simulations ---------------------------------- @@ -285,82 +291,186 @@ Section bind. Arguments label: clear implicits. Obligation Tactic := idtac. - Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : hrel (@label E) (@label F)) (R0 : rel X Y). - (*| Specialization of [bind_ctx] to a function acting with [cssim] on the bound value, and with the argument (pointwise) on the continuation. |*) Lemma bind_chain_gen - (RR : rel (label E) (label F)) - (ISVR : is_update_val_rel L R0 RR) - (HL: Respects_val RR) + {E F C D: Type -> Type} {X X' Y Y': Type} + (L : lrel E F X' Y') + (SS: rel X Y) {R : Chain (@css E F C D X' Y' L)} : - forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), - cssim RR t t' -> - (forall x x', R0 x x' -> (elem R (k x) (k' x') /\ exists l t', trans l (k x) t')) -> - elem R (bind t k) (bind t' k'). + forall (t : ctree E C X) (t' : ctree F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), + cssim (upd_rel L SS) t t' -> + (forall x y, SS x y -> ` R (k x) (k' y) /\ not_stuck (k x)) -> + ` R (bind t k) (bind t' k'). Proof. apply tower. + - intros ? INC ? ? ? ? tt' kk' ? ?. apply INC. apply H. apply tt'. intros x x' xx'. split. apply leq_infx in H. apply H. now apply kk'. edestruct kk'; eauto. + - intros ? ? ? ? ? ? tt' kk'. step in tt'. destruct tt' as [tt tt']. split. + + cbn; intros * STEP. - apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | (v & STEPres & STEP)]. - * apply tt in STEP as (? & ? & ? & ? & ?). - do 2 eexists; split; [| split]. - apply trans_bind_l; eauto. - ++ intro Hl. destruct Hl. - apply ISVR in H3; etrans. - inversion H3; subst. apply H0. constructor. apply H5. constructor. - ++ rewrite EQ. - apply H. - apply H2. - intros * HR. - split. - now apply (b_chain x), kk'. - apply (kk' _ _ HR). - ++ apply ISVR in H3; etrans. - destruct H3. exfalso. apply H0. constructor. eauto. - * apply tt in STEPres as (u' & ? & STEPres & EQ' & ?). - apply ISVR in H0; etrans. - dependent destruction H0. - 2 : exfalso; apply H0; constructor. - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk' v v2 H0). - apply kk' in STEP as (u'' & ? & STEP & EQ'' & ?); cbn in *. - do 2 eexists; split. + apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | [(Z & e & EQl & g & STEP & SEQ) | (v & STEPres & STEP)]]. + + * subst l. + apply tt in STEP as (? & ? & STEP' & HSIM & HRL). + invL. + refine_trans. + ex2; split3. + ++ apply trans_bind_l_τ; eauto. + ++ rewrite EQ; apply H; auto. + intros. + edestruct4 kk'; eauto. + split; eauto. + step; auto. + ++ etrans. + + * subst l. + apply tt in STEP as (? & ? & STEP' & HSIM & HRL). + invL. + refine_trans. + exists (ask f); ex; split3; etrans. + rewrite SEQ. + step. + split. + { intros ?? TR. + pose proof trans_passive_inv' TR as (a & EQ & ->). + rewrite EQ in TR. + assert (TR': trans (rcv e a) (β e g) (g a)) by etrans. + step in HSIM; apply HSIM in TR' as (l' & u' & TR' & HSIM' & HRL'). + pose proof trans_passive_inv' TR' as (b & EQ' & ->). + exists (rcv f b); ex; split; eauto; split; cycle 1. + { invL; etrans. } + rewrite EQ. + apply H. + rewrite EQ' in HSIM'; auto. + intros. + edestruct4 kk'; eauto. + split; eauto. + now step. + } + { + step in HSIM. + destruct HSIM as [HSIM' PROD]. + intros * TR. + pose proof trans_passive_inv' TR as (y & EQ & EQ'). + specialize (PROD (rcv f y) (u y)). + destruct PROD as (?l' & ?t' & ?TR'). + etrans. + pose proof trans_passive_inv' TR' as (z & EQz & EQz'). + exists (rcv e z). + ex. + etrans. + } + + * apply tt in STEPres as (? & ? & STEP' & HSIM & HRL). + invL. + destruct (kk' v y) as [HSIM' HBACK']; [etrans |]. + apply HSIM' in STEP as (l' & u' & STEP'' & HSIM'' & HRL'). + exists l'; eexists; split; eauto. eapply trans_bind_r; eauto. - split; auto. - + cbn; intros * STEP. + erewrite <- trans_val_inv'; eauto. + + + intros * STEP. apply trans_bind_inv_l in STEP as (l' & t2' & STEP). - apply tt' in STEP as (l'' & t1' & TR1). + apply tt' in STEP as (l'' & ? & STEP'). destruct l''. - do 2 eexists; apply trans_bind_l; eauto; intros abs; inv abs. - do 2 eexists; apply trans_bind_l; eauto; intros abs; inv abs. - apply trans_val_invT in TR1 as ?. subst X0. - apply trans_val_inv in TR1 as ?. rewrite H0 in TR1. - pose proof TR1 as tmp. + refine_trans; ex2; apply trans_bind_l_τ; etrans. + refine_trans; ex2; eapply trans_bind_l_ask; etrans. + exfalso; eapply trans_rcv_active_inv; eauto. + + apply trans_val_invT in STEP' as ?. subst X0. + apply trans_val_inv' in STEP' as ?. rewrite H0 in STEP'. + pose proof STEP' as tmp. apply tt in tmp as (? & ? & TR & ? & ?). - assert (is_val x0) by (eapply HL; eauto; constructor). - inv H3; pose proof trans_val_invT TR; subst X0. - specialize (kk' v x2). - destruct kk'. - apply ISVR in H2; etrans. - dependent destruction H2; auto. exfalso; apply H2; constructor. - edestruct H4 as (? & ? & ?); eauto. - eapply trans_bind_r in H5; eauto. + invL. + specialize (kk' v y). + destruct kk' as [HSIM' (l'' & ? & TR')]; auto. + ex2. + eapply trans_bind_r; etrans. + + Qed. + +(*| +Specialization: equality on external calls, equality everywhere +|*) + Lemma bind_chain E C D X Y X' Y' + (RR : rel X' Y') (SS : rel X Y) + {R : Chain (@css E E C D X' Y' (Lvrel RR))} : + forall (t1 : ctree E C X) (t2: ctree E D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y'), + t1 (⪅[SS]) t2 -> + (forall x y, SS x y -> `R (k1 x) (k2 y) /\ not_stuck (k1 x)) -> + `R (t1 >>= k1) (t2 >>= k2). + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. + + Lemma bind_chain_eq E C X X' + {R : Chain (@css E E C C X' X' Leq)} : + forall (t1 t2 : ctree E C X) + (k1 k2 : X -> ctree E C X'), + t1 ⪅ t2 -> + (forall x, `R (k1 x) (k2 x) /\ not_stuck (k1 x)) -> + `R (t1 >>= k1) (t2 >>= k2). + Proof. + intros. + eapply bind_chain_gen; eauto. + intros ??<-; auto. + Qed. + +(*| +Specializations to the gfp +|*) + Lemma ssim_bind_gen E F C D X Y X' Y' + L (SS : rel X Y) + (t1 : ctree E C X) (t2: ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): + t1 (⪅ upd_rel L SS) t2 -> + (forall x y, SS x y -> k1 x (⪅ L) k2 y /\ not_stuck (k1 x)) -> + t1 >>= k1 (⪅ L) t2 >>= k2. + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. + + Lemma ssim_bind E C D X Y X' Y' + (RR : rel X' Y') (SS : rel X Y) + (t1 : ctree E C X) (t2: ctree E D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y'): + t1 (⪅ [SS]) t2 -> + (forall x y, SS x y -> k1 x (⪅ [RR]) k2 y /\ not_stuck (k1 x)) -> + t1 >>= k1 (⪅ [RR]) t2 >>= k2. + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. + + Lemma ssim_bind_eq {E C D: Type -> Type} {X X': Type} + (t1 : ctree E C X) (t2: ctree E D X) + (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): + t1 ⪅ t2 -> + (forall x, k1 x ⪅ k2 x /\ not_stuck (k1 x)) -> + t1 >>= k1 ⪅ t2 >>= k2. + Proof. + intros. + eapply ssim_bind; eauto. + intros ?? ->; auto. Qed. End bind. + (*| Specializing the congruence principle for [⪅] |*) @@ -416,6 +526,44 @@ Proof. apply H0. Qed. + + Lemma is_stuck_css : forall (t: ctree E C X) (u: ctree F D Y) R, + css L R t u -> is_stuck t <-> is_stuck u. + Proof. + split; intros; intros ? ? ?. + - apply H in H1 as (? & ? & ?). now apply H0 in H1. + - apply H in H1 as (? & ? & ? & ? & ?). now apply H0 in H1. + Qed. + + Lemma is_stuck_cssim : forall (t: ctree E C X) (u: ctree F D Y), + t (⪅ L) u -> is_stuck t <-> is_stuck u. + Proof. + intros. step in H. eapply is_stuck_css; eauto. + Qed. + + Lemma css_is_stuck : forall (t : ctree E C X) (u: ctree F D Y) R, + is_stuck t -> is_stuck u -> css L R t u. + Proof. + split; intros. + - cbn. intros. now apply H in H1. + - now apply H0 in H1. + Qed. + + Lemma cssim_is_stuck : forall (t : ctree E C X) (u: ctree F D Y), + is_stuck t -> is_stuck u -> t (⪅ L) u. + Proof. + intros. step. now apply css_is_stuck. + Qed. + + Lemma cssim_ssim_subrelation_gen : forall x y, cssim L x y -> ssim L x y. + Proof. + red. + coinduction r cih; intros * SB. + step in SB; destruct SB as [fwd _]. + intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. + Qed. + + Section Proof_Rules. Arguments label: clear implicits. Context {E C : Type -> Type} {X: Type}. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 80a96df..a97efbe 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -72,6 +72,7 @@ Module SSimNotations. Notation "t '[≲]' u" := (ss Leq (` _) t u) (at level 90, only printing). Notation "t '[≲' [ R ] ']' u" := (ss (Lvrel R) (` _) t u) (at level 90, only printing). Notation "t '[≲' R ']' u" := (ss R (` _) t u) (at level 90, only printing). + End SSimNotations. Import SSimNotations. @@ -222,7 +223,7 @@ Section ssim_heterogenous_theory. apply equ_clos_chain; econstructor; [eauto | | symmetry; eauto]; assumption. Qed. - #[global] Instance seq_ss_closed_goal {r} : + #[global] Instance seq_ss_goal {r} : Proper (Seq ==> Seq ==> flip impl) (ss L r). Proof. intros t t' tt' u u' uu'; cbn; intros. @@ -230,7 +231,7 @@ Section ssim_heterogenous_theory. ex2; eauto. rewrite uu'. eauto. Qed. - #[global] Instance equ_ss_closed_goal {r} : + #[global] Instance equ_ss_goal {r} : Proper (equ eq ==> equ eq ==> flip impl) (ss L r). Proof. intros t t' tt' u u' uu'; cbn; intros. @@ -261,7 +262,7 @@ Section ssim_heterogenous_theory. apply equ_clos_chain; econstructor; [symmetry; eauto | | eauto]; assumption. Qed. - #[global] Instance seq_ss_closed_ctx {r} : + #[global] Instance seq_ss_ctx {r} : Proper (Seq ==> Seq ==> impl) (ss L r). Proof. intros t t' tt' u u' uu'; cbn; intros. @@ -269,7 +270,7 @@ Section ssim_heterogenous_theory. ex2; eauto. rewrite <- uu'. eauto. Qed. - #[global] Instance equ_ss_closed_ctx {r} : + #[global] Instance equ_ss_ctx {r} : Proper (equ eq ==> equ eq ==> impl) (ss L r). Proof. intros t t' tt' u u' uu'; cbn; intros. @@ -480,7 +481,7 @@ Stuck ctrees can be simulated by anything. Lemma ss_stuck L R (t : ctree F D Y) : @ss E F C D X Y L R Stuck t. Proof. - repeat intro. now apply Stuck_is_stuck in H. + repeat intro. now apply stuck_is_stuck in H. Qed. Lemma ssim_stuck L (t : ctree F D Y) : @@ -862,7 +863,7 @@ Internal transitions (* intros. *) (* eapply step_ss_ret_l_gen; eauto. *) (* - apply (b_chain R). *) - (* apply is_stuck_ss; apply Stuck_is_stuck. *) + (* apply is_stuck_ss; apply stuck_is_stuck. *) (* - typeclasses eauto. *) (* Qed. *) diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index d248723..7b2f706 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -946,6 +946,49 @@ Proof. - eapply trans_ret_inv in step; intuition. Qed. +Lemma passive_τ_trans {E B X Y} e (g : X -> ctree E B Y) u : + trans τ (β e g) u -> + False. +Proof. + intros TR; cbn in TR; dependent induction TR. +Qed. + +Lemma passive_τ_etrans {E B X Y} e (g : X -> ctree E B Y) u : + etrans τ (β e g) u -> + Seq u (β e g). +Proof. + intros [TR | EQ]. + - cbn in TR; dependent induction TR. + - symmetry; apply EQ. +Qed. + +Lemma passive_τ_wtrans {E B X Y} e (g : X -> ctree E B Y) u : + wtrans τ (β e g) u -> + Seq u (β e g). +Proof. + intros [? [? [n TR1] TR2] [m TR3]]. + destruct n. + - cbn in TR1. rewrite <- TR1 in TR2. + apply passive_τ_etrans in TR2. + destruct m. + * cbn in TR3. + now rewrite <- TR3, TR2. + * destruct TR3 as [? TR _]. + rewrite TR2 in TR. + exfalso; eapply passive_τ_trans; eauto. + - destruct TR1 as [? TR _]. + exfalso; eapply passive_τ_trans; eauto. +Qed. + +Lemma transs_τ_passive {E B X Y} e (g : X -> ctree E B Y) u : + (trans τ)^* (β e g) u -> + Seq u (β e g). +Proof. + intros TR. + eapply passive_τ_wtrans. + now apply wtrans_τ. +Qed. + (*| Stuck processes --------------- @@ -957,19 +1000,18 @@ is not. Section stuck. Context {E B : Type -> Type} {X : Type}. - Variable (l : @label E) (t u : ctree E B X). - Definition is_stuck : ctree E B X -> Prop := + Definition is_stuck : @S E B X -> Prop := fun t => forall l u, ~ (trans l t u). - #[global] Instance is_stuck_equ : Proper (equ eq ==> iff) is_stuck. + #[global] Instance Seq_is_stuck : Proper (Seq ==> iff) is_stuck. Proof. intros ? ? EQ; split; intros ST; red; intros * ABS. rewrite <- EQ in ABS; eapply ST; eauto. rewrite EQ in ABS; eapply ST; eauto. Qed. - Lemma etrans_is_stuck_inv' (v : ctree E B X) v' : + Lemma etrans_is_stuck_inv' v v' l : is_stuck v -> etrans l v v' -> l = τ /\ Seq v v'. @@ -979,7 +1021,7 @@ Section stuck. apply ST in H; tauto. Qed. - Lemma etrans_is_stuck_inv (v v' : ctree E B X) : + Lemma etrans_is_stuck_inv (v v' : ctree E B X) l : is_stuck v -> etrans l v v' -> (l = τ /\ v ≅ v'). @@ -989,7 +1031,7 @@ Section stuck. apply ST in H; tauto. Qed. - Lemma transs_is_stuck_inv' (v : ctree E B X) v' : + Lemma transs_is_stuck_inv' v v' : is_stuck v -> (trans τ)^* v v' -> Seq v v'. @@ -1011,23 +1053,30 @@ Section stuck. now inv TR. Qed. - Lemma wtrans_is_stuck_inv : + Lemma wtrans_is_stuck_inv t u l : is_stuck t -> wtrans l t u -> - (l = τ /\ t ≅ u). + (l = τ /\ Seq t u). Proof. intros * ST TR. destruct TR as [? [? ?] ?]. apply transs_is_stuck_inv' in H; auto. inv H. - rewrite EQ in ST; apply etrans_is_stuck_inv' in H0 as [-> ?]; auto. - inv H. - rewrite EQ0 in ST; apply transs_is_stuck_inv in H1; auto. - intuition. - rewrite EQ, EQ0; auto. + - rewrite EQ in ST; apply etrans_is_stuck_inv' in H0 as [-> ?]; auto. + inv H. + rewrite EQ0 in ST; apply transs_is_stuck_inv' in H1; auto. + intuition. + rewrite EQ, EQ0; auto. + - rewrite EQ in ST. + pose proof etrans_is_stuck_inv' _ _ ST H0 as [-> ?]; auto. + split; auto. + rewrite <-H in H1. + apply transs_τ_passive in H1. + rewrite H1. auto. Qed. - Lemma Stuck_is_stuck : + (* Constructions *) + Lemma stuck_is_stuck : is_stuck Stuck. Proof. repeat intro; eapply trans_stuck_inv; eauto. @@ -1048,7 +1097,7 @@ Section stuck. now apply case0. Qed. - Lemma spinD_gen_is_stuck {Y} (x : B Y) : + Lemma spin_gen_is_stuck {Y} (x : B Y) : is_stuck (spin_gen x). Proof. red; intros * abs. @@ -1092,8 +1141,92 @@ Section stuck. apply trans_step. Qed. + Lemma vis_is_not_stuck {Y} (e : E Y) (k : Y -> _) : + ~ is_stuck (Vis e k). + Proof. + red; intros * abs. + eapply (abs (ask e)). + apply trans_ask. + Qed. + + Lemma passive_is_not_stuck {Y} `{Inhabited Y} (e : E Y) (k : Y -> _) : + ~ is_stuck (β e k). + Proof. + red; intros * abs. + eapply (abs (rcv e inhabitant)). + apply trans_rcv. + Qed. + + Lemma passive_void_is_stuck (e : E void) (k : void -> _) : + is_stuck (β e k). + Proof. + red; intros * abs. + apply trans_passive_inv' in abs as ([] & _ & _). + Qed. + End stuck. +Section not_stuck. + + Context {E B : Type -> Type} {X : Type}. + + Definition not_stuck t := + exists l' t', @trans E B X l' t t'. + + #[global] Instance seq_not_stuck : Proper (Seq ==> iff) not_stuck. + Proof. + intros ? ? EQ; split; intros (l' & t' & TR). + rewrite EQ in TR; red; eauto. + rewrite <- EQ in TR; red; eauto. + Qed. + + (* Converse is classically true *) + Lemma not_stuck_is_stuck : + forall t, not_stuck t -> ~ is_stuck t. + Proof. + intros t (l' & t' & NS) IS; eapply IS; eauto. + Qed. + + Lemma ret_not_stuck x: + not_stuck (Ret x). + Proof. + red; eauto. + Qed. + + Lemma vis_not_stuck {Y} (e : E Y) k: + not_stuck (Vis e k). + Proof. + red; eauto. + Qed. + + Lemma passive_not_stuck {Y} `{Inhabited Y} (e : E Y) k: + not_stuck (β e k). + Proof. + red; eauto. + Unshelve. + exact inhabitant. + Qed. + + Lemma br_not_stuck {Y} (b : B Y) (k : Y -> ctree _ _ _): + (exists x, not_stuck (k x)) -> + not_stuck (Br b k). + Proof. + intros (y & l' & t' & TR). + red; eauto. + Qed. + + Lemma brS_not_stuck {Y} (b : B Y) (k : Y -> ctree _ _ _): + (exists x, not_stuck (k x)) -> + not_stuck (BrS b k). + Proof. + intros (y & l' & t' & TR). + red; eauto. + Unshelve. exact y. + Qed. + +End not_stuck. +#[global] Hint Unfold not_stuck : core. + (*| wtrans theory --------------- @@ -1142,7 +1275,7 @@ Section wtrans. apply etrans_ret_inv' in step2 as [[-> EQ] |[-> EQ]]. rewrite EQ in step3; apply trans_τ_str_ret_inv in step3; auto. rewrite EQ in step3. - apply transs_is_stuck_inv in step3; [| apply Stuck_is_stuck]. + apply transs_is_stuck_inv in step3; [| apply stuck_is_stuck]. intuition. Qed. @@ -1157,7 +1290,7 @@ Section wtrans. clear step1. pose proof trans_val_inv' step2. rewrite H in step3. - apply transs_is_stuck_inv' in step3; auto using Stuck_is_stuck. + apply transs_is_stuck_inv' in step3; auto using stuck_is_stuck. split; [| rewrite <- step3; auto]. rewrite H in step2. rewrite <- step3. auto. @@ -1272,7 +1405,7 @@ Proof. rewrite EQ2, H0; auto. Qed. -Lemma trans_bind_inv_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l : +Lemma trans_bind_inv_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : trans l (t >>= k) u -> exists l' t', trans l' t t'. Proof. @@ -1396,40 +1529,6 @@ Proof. exists (Datatypes.S n), t1; auto. Qed. -Lemma passive_τ_trans {E B X Y} e (g : X -> ctree E B Y) u : - trans τ (β e g) u -> - False. -Proof. - intros TR; cbn in TR; dependent induction TR. -Qed. - -Lemma passive_τ_etrans {E B X Y} e (g : X -> ctree E B Y) u : - etrans τ (β e g) u -> - Seq u (β e g). -Proof. - intros [TR | EQ]. - - cbn in TR; dependent induction TR. - - symmetry; apply EQ. -Qed. - -Lemma passive_τ_wtrans {E B X Y} e (g : X -> ctree E B Y) u : - wtrans τ (β e g) u -> - Seq u (β e g). -Proof. - intros [? [? [n TR1] TR2] [m TR3]]. - destruct n. - - cbn in TR1. rewrite <- TR1 in TR2. - apply passive_τ_etrans in TR2. - destruct m. - * cbn in TR3. - now rewrite <- TR3, TR2. - * destruct TR3 as [? TR _]. - rewrite TR2 in TR. - exfalso; eapply passive_τ_trans; eauto. - - destruct TR1 as [? TR _]. - exfalso; eapply passive_τ_trans; eauto. -Qed. - (*| Things are a bit ugly with [wtrans], we end up with three cases: @@ -1543,15 +1642,6 @@ Proof. intros TR; eapply trans_ask_inv; eauto. Qed. -Lemma transs_τ_passive {E B X Y} e (g : X -> ctree E B Y) u : - (trans τ)^* (β e g) u -> - Seq u (β e g). -Proof. - intros TR. - eapply passive_τ_wtrans. - now apply wtrans_τ. -Qed. - Lemma transs_τ_active {E B X} (t : ctree E B X) u : (trans τ)^* (α t) u -> exists u', Seq u (α u'). @@ -1896,9 +1986,9 @@ Qed. (* pose proof (trans_val_invT TR1'); subst. *) (* apply trans_val_inv in TR1'. *) (* rewrite TR1' in TR1''. *) -(* apply transs_is_stuck_inv in TR1''; [| apply Stuck_is_stuck]. *) +(* apply transs_is_stuck_inv in TR1''; [| apply stuck_is_stuck]. *) (* rewrite <- TR1'' in TR2. *) -(* apply wtrans_is_stuck_inv in TR2; [| apply Stuck_is_stuck]. *) +(* apply wtrans_is_stuck_inv in TR2; [| apply stuck_is_stuck]. *) (* destruct TR2 as [abs _]; inv abs. *) (* } *) (* eexists. *) From 15d3dfd1cdc5196783f931ad3714c3d734fb9d5b Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 3 Nov 2025 15:18:45 +0100 Subject: [PATCH 16/61] minor reformulation. Quite positive there's a stronger up-to bind valid, but failed to prove it --- theories/Eq/CSSim.v | 43 +++++++++++++++++++++---------------------- theories/Eq/Trans.v | 14 ++++++++++---- 2 files changed, 31 insertions(+), 26 deletions(-) diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index d2b863d..2fad92c 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -34,7 +34,7 @@ Complete strong simulation [css]. Program Definition css {E F C D : Type -> Type} {X Y : Type} (L : lrel E F X Y) : mon (@S E C X -> @S F D Y -> Prop) := {| body R t u := - ss L R t u /\ (forall l u', trans l u u' -> not_stuck t) + ss L R t u /\ (not_stuck u -> not_stuck t) |}. Next Obligation. split; eauto. intros. @@ -139,10 +139,9 @@ Section cssim_homogenous_theory. destruct (xy _ _ xx') as (l' & y' & yy' & ? & ?). destruct (yz _ _ yy') as (l'' & z' & zz' & ? & ?). eauto 8. - - intros ?? xx'. - destruct (yz' _ _ xx') as (l'' & z' & zz'). - destruct (xy' _ _ zz') as (l' & y' & yy'). - eauto 8. + - intros ns. + destruct (yz' ns) as (l'' & z' & zz'). + edestruct xy' as (l' & y' & yy'); eauto. Qed. (*| PreOrder |*) @@ -197,14 +196,16 @@ Section cssim_heterogenous_theory. econstructor; eauto. apply leq_infx in H. now apply H. - - intros a b ?? [x' y' x'' y'' EQ' [SIM COMP]]. - split; intros ?? tr. - + rewrite EQ' in tr. + - intros a b ?? [x' y' x'' y'' EQ' [SIM LIVE]]. + split. + + intros ?? tr. + rewrite EQ' in tr. edestruct SIM as (l' & ? & ? & ? & ?); eauto. exists l',x0; intuition. rewrite <- Equu; auto. - + rewrite <- Equu in tr. - edestruct COMP as (l' & ? & ?); eauto. + + intros ns. + rewrite <- Equu in ns. + edestruct LIVE as (l' & ? & ?); eauto. setoid_rewrite EQ'. eauto. Qed. @@ -220,8 +221,8 @@ Section cssim_heterogenous_theory. - intros ? INC t t' EQt u u' EQu [HS PROG]. split. now rewrite EQu, EQt. - intros l v TR. - rewrite EQu in TR. + intros ns. + rewrite EQu in ns. edestruct PROG as (? & ? & ?); eauto. ex2; rewrite EQt; eauto. Qed. @@ -251,12 +252,12 @@ Section cssim_heterogenous_theory. now apply HP'''. - intros ? INC t t' EQt u u' EQu [HS PROG]; split. now rewrite <- EQt, <- EQu. - intros l v TR. - rewrite <- EQu in TR. + intros ns. + rewrite <- EQu in ns. edestruct PROG as (? & ? & ?); eauto. ex2; rewrite <- EQt; eauto. Qed. - + #[global] Instance seq_css_ctx {r} : Proper (Seq ==> Seq ==> impl) (css L r). Proof. @@ -312,7 +313,7 @@ and with the argument (pointwise) on the continuation. apply INC. apply H. apply tt'. intros x x' xx'. split. apply leq_infx in H. apply H. now apply kk'. edestruct kk'; eauto. - + - intros ? ? ? ? ? ? tt' kk'. step in tt'. destruct tt' as [tt tt']. @@ -361,14 +362,12 @@ and with the argument (pointwise) on the continuation. { step in HSIM. destruct HSIM as [HSIM' PROD]. - intros * TR. + intros (? & ? & TR). pose proof trans_passive_inv' TR as (y & EQ & EQ'). - specialize (PROD (rcv f y) (u y)). destruct PROD as (?l' & ?t' & ?TR'). - etrans. + exists (rcv f y); eauto. pose proof trans_passive_inv' TR' as (z & EQz & EQz'). exists (rcv e z). - ex. etrans. } @@ -380,9 +379,9 @@ and with the argument (pointwise) on the continuation. eapply trans_bind_r; eauto. erewrite <- trans_val_inv'; eauto. - + intros * STEP. + + intros (? & ? & STEP). apply trans_bind_inv_l in STEP as (l' & t2' & STEP). - apply tt' in STEP as (l'' & ? & STEP'). + destruct tt' as (l'' & ? & STEP'); eauto. destruct l''. refine_trans; ex2; apply trans_bind_l_τ; etrans. refine_trans; ex2; eapply trans_bind_l_ask; etrans. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 7b2f706..defd53b 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -2128,9 +2128,9 @@ derive information on the active/passive status of its destination state. Currently very partial |*) -Ltac refine_trans := - match goal with - | h : htrans τ _ _ |- _ => +Ltac refine_trans_in h := + match type of h with + | htrans τ _ _ => let u := fresh "u" in let EQ := fresh "EQ" in pose proof trans_τ_inv h as [u EQ]; @@ -2138,7 +2138,7 @@ Ltac refine_trans := match type of EQ with | Seq ?a _ => try clear a EQ end - | h : htrans (ask ?e) _ _ |- _ => + | htrans (ask ?e) _ _ => let u := fresh "u" in let EQ := fresh "EQ" in pose proof trans_ask_inv h as [u EQ]; @@ -2148,6 +2148,12 @@ Ltac refine_trans := end end. +Tactic Notation "refine_trans" := + match goal with + | h : htrans _ _ _ |- _ => refine_trans_in h + end. +Tactic Notation "refine_trans" "in" ident(h) := refine_trans_in h. + (*| [inv_trans] is an helper tactic to automatically invert hypotheses involving [trans]. From df61b3fe7b3b895005c0c5c0879e674a6a5284fb Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 3 Nov 2025 18:42:27 +0100 Subject: [PATCH 17/61] checkpoint --- theories/Core/Utils.v | 2 +- theories/Eq/CSSim.v | 439 +++++++++++++++++++++++++++++++++++------- theories/Eq/SSim.v | 20 +- 3 files changed, 387 insertions(+), 74 deletions(-) diff --git a/theories/Core/Utils.v b/theories/Core/Utils.v index 55a5010..a114da7 100644 --- a/theories/Core/Utils.v +++ b/theories/Core/Utils.v @@ -102,7 +102,7 @@ Ltac do_det := clear RWTdet H' end. -#[global] Notation inhabited X := { x: X | True}. +(* #[global] Notation inhabited X := { x: X | True}. *) Definition sum_rel {A1 A2 B1 B2} Ra Rb : rel (A1 + B1) (A2 + B2) := fun ab ab' => diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index 2fad92c..662d3b5 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -148,6 +148,12 @@ Section cssim_homogenous_theory. #[global] Instance PreOrder_csst {LPO: PreOrder L} {C: Chain (css L)}: PreOrder `C. Proof. split; typeclasses eauto. Qed. + #[global] Instance css_ss_subrelation R : subrelation (css L R) (ss L R). + Proof. + red. + intros ?? [? ?]; auto. + Qed. + #[global] Instance cssim_ssim_subrelation : subrelation (cssim L) (ssim L). Proof. red. @@ -166,7 +172,7 @@ Section cssim_heterogenous_theory. Notation css := (@css E F C D X Y). Notation cssim := (@cssim E F C D X Y). - Lemma cssim_subrelation : + Lemma cssim_mono : Proper (sub_lrel ==> leq) cssim. Proof. cbn; intros * SUB. @@ -272,6 +278,14 @@ Section cssim_heterogenous_theory. ex2; rewrite <- tt'; eauto. Qed. + Lemma cssim_ssim_subrelation_gen : forall x y, cssim L x y -> ssim L x y. + Proof. + red. + coinduction r cih; intros * SB. + step in SB; destruct SB as [fwd _]. + intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. + Qed. + End cssim_heterogenous_theory. #[global] Instance weq_ssim : forall {E F C D X Y}, @@ -469,104 +483,391 @@ Specializations to the gfp End bind. - (*| -Specializing the congruence principle for [⪅] -|*) -Lemma cssim_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) L0 - (HL : is_update_val_rel L R0 L0) - (HLV : Respects_val L0) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - cssim L0 t1 t2 -> - (forall x y, R0 x y -> cssim L (k1 x) (k2 y)) -> - (forall x, exists l t', trans l (k1 x) t') -> - cssim L (t1 >>= k1) (t2 >>= k2). -Proof. - intros. - eapply bind_chain_gen; eauto. - split; eauto. - now apply H0. -Qed. +And in particular, we can justify rewriting [⪅] to the left of a [bind]. -Lemma cssim_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): - Respects_val L -> - t1 (⪅update_val_rel L R0) t2 -> - (forall x y, R0 x y -> k1 x (⪅L) k2 y) -> - (forall x, exists l t', trans l (k1 x) t') -> - t1 >>= k1 (⪅L) t2 >>= k2. +NOTE: we shouldn't have to impose [eq] to the right. +|*) +#[global] Instance cssim_bind_chain {E C X Y} + {R : Chain (@css E E C C Y Y Leq)} : + Proper ((fun t u => cssim Leq (α t) (α u)) ==> + (pointwise_relation _ (fun t u => ` R (α t) (α u) /\ not_stuck t)) ==> `R) (@bind E C X Y). Proof. - intros. - eapply bind_chain_gen. - 3:eauto. - eauto using update_val_rel_correct. - eauto using Respects_val_update_val_rel. - split; eauto. - now apply H1. + repeat intro; eapply bind_chain_gen; eauto. + intros ?? <-; auto. Qed. -Lemma cssim_clo_bind_eq {E C D: Type -> Type} {X X': Type} - (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): - t1 ⪅ t2 -> - (forall x, k1 x ⪅ k2 x) -> - (forall x, exists l t', trans l (k1 x) t') -> - t1 >>= k1 ⪅ t2 >>= k2. -Proof. - intros. - eapply bind_chain_gen; eauto. - - apply update_val_rel_eq. - - apply Respects_val_eq. - - split; subst; auto. - apply H0. -Qed. +Section Proof_Rules. + Context {E F C D: Type -> Type} {X Y : Type}. - Lemma is_stuck_css : forall (t: ctree E C X) (u: ctree F D Y) R, +(*| +Stuck ctrees can be simulated by anything. +|*) + + Lemma css_is_stuck L R : forall (t: @S E C X) (u: @S F D Y), css L R t u -> is_stuck t <-> is_stuck u. Proof. - split; intros; intros ? ? ?. - - apply H in H1 as (? & ? & ?). now apply H0 in H1. - - apply H in H1 as (? & ? & ? & ? & ?). now apply H0 in H1. + intros * [SIM LIVE]; split; intros IS ? ? TR. + - destruct LIVE as (? & ? & ?); eauto. now apply IS in H. + - apply SIM in TR as (? & ? & ? & ? & ?). now apply IS in H. Qed. - Lemma is_stuck_cssim : forall (t: ctree E C X) (u: ctree F D Y), + Lemma cssim_is_stuck L : forall (t: @S E C X) (u: @S F D Y), t (⪅ L) u -> is_stuck t <-> is_stuck u. Proof. - intros. step in H. eapply is_stuck_css; eauto. + intros. step in H. eapply css_is_stuck; eauto. Qed. - Lemma css_is_stuck : forall (t : ctree E C X) (u: ctree F D Y) R, + Lemma css_is_stuck' L R : forall (t : @S E C X) (u: @S F D Y), is_stuck t -> is_stuck u -> css L R t u. Proof. split; intros. - cbn. intros. now apply H in H1. - - now apply H0 in H1. + - edestruct3 H1. now apply H0 in H2. Qed. - Lemma cssim_is_stuck : forall (t : ctree E C X) (u: ctree F D Y), + Lemma cssim_is_stuck' L : forall (t : @S E C X) (u: @S F D Y), is_stuck t -> is_stuck u -> t (⪅ L) u. Proof. - intros. step. now apply css_is_stuck. + intros. step. now apply css_is_stuck'. + Qed. + +(*| +Ret nodes +|*) + Lemma css_ret (x : X) (y : Y) L + {R : Chain (@css E F C D X Y L)} : + RR L x y -> + css L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros HR; split. + - apply ss_ret_gen; auto. + step; eapply css_is_stuck'; apply stuck_is_stuck. + typeclasses eauto. + - eauto. + Qed. + + Lemma cssim_ret (x : X) (y : Y) L : + RR L x y -> + cssim L (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros. + step. now apply css_ret. Qed. - Lemma cssim_ssim_subrelation_gen : forall x y, cssim L x y -> ssim L x y. + +(*| + The vis nodes are deterministic from the perspective of the labeled + transition system, stepping is hence symmetric and we can just recover + the itree-style rule. +|*) + Lemma css_vis {Z Z'} `{Inhabited Z} (e : E Z) (f: F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + {R : Chain (@css E F C D X Y L)} + (HRask : Rask L e f) + (HRrcv : forall x, exists y, `R (k x) (k' y) /\ Rrcv L e f x y) : + css L ` R (Vis e k) (Vis f k'). Proof. - red. - coinduction r cih; intros * SB. - step in SB; destruct SB as [fwd _]. - intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. + split. + - intros ?? TR; inv_trans. + ex2; intuition. + rewrite EQ. + step. + split. + + intros l u TR. + inv_trans; subst. + destruct (HRrcv x) as (y & ? & ?). + ex2; intuition. + rewrite EQ0; eauto. + etrans. + + unshelve eauto. + exact inhabitant. + - eauto. + Qed. + + Lemma cssim_vis {Z Z'} `{Inhabited Z} (e : E Z) (f: F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + (HRask : Rask L e f) + (HRrcv : forall x, exists y, cssim L (k x) (k' y) /\ Rrcv L e f x y) : + cssim L (Vis e k) (Vis f k'). + Proof. + intros. step. apply css_vis; auto. Qed. + (* Useful special case: over the same type return type, + we usually pick the identity *) + Lemma css_vis_id {Z} `{Inhabited Z} (e : E Z) (f: F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + {R : Chain (@css E F C D X Y L)} + (HRask : Rask L e f) + (HRrcv : forall z, ` R (k z) (k' z) /\ Rrcv L e f z z) : + css L ` R (Vis e k) (Vis f k'). + Proof. + eapply css_vis; eauto. + Qed. + + Lemma cssim_vis_id {Z} `{Inhabited Z} (e : E Z) (f : F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + (HRask : Rask L e f) + (HRrcv : forall x, cssim L (k x) (k' x) /\ Rrcv L e f x x) : + cssim L (Vis e k) (Vis f k'). + Proof. + intros. step. now apply css_vis_id. + Qed. -Section Proof_Rules. - Arguments label: clear implicits. - Context {E C : Type -> Type} {X: Type}. +(*| +Invisible nodes +|*) + (* Here we need a stronger lemma quantifying over arbitrary relations [R] and not just elements of the Chain in order to lift things to cssim as we don't unlock cssim in the structural subterm *) + Lemma css_br_l_gen {Z} `{Inhabited Z} (c : C Z) + (k : Z -> ctree E C X) (t': ctree F D Y) R L: + (forall x, css L R (k x) t') -> + css L R (Br c k) t'. + Proof. + intros EQs. + split. + - apply ss_br_l_gen; intros z; destruct (EQs z); auto. + - intros NS. + destruct (EQs inhabitant) as [_ PROG]. + edestruct3 PROG; auto. + eauto. + Qed. + + Lemma css_br_l {Z} `{Inhabited Z} (c : C Z) + (k : Z -> ctree E C X) (t: ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + (forall x, css L `R (k x) t) -> + css L `R (Br c k) t. + Proof. + intros; now apply css_br_l_gen. + Qed. + + Lemma cssim_br_l {Z} `{Inhabited Z} (c : C Z) + (k : Z -> ctree E C X) (t: ctree F D Y) L : + (forall x, cssim L (k x) t) -> + cssim L (Br c k) t. + Proof. + intros SIM; step; eapply css_br_l. + now intros z; specialize (SIM z); step in SIM. + Qed. + + Lemma css_br_r_gen {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: ctree E C X) R L: + (not_stuck t \/ not_stuck (k x)) -> + css L R t (k x) -> + css L R t (Br c k). + Proof. + cbn. intros NS [SIM PROG]; split. + - intros; edestruct5 SIM; eauto 10. + - destruct NS; auto. + Qed. + + Lemma css_br_r {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: ctree E C X) L + {R : Chain (@css E F C D X Y L)} : + (not_stuck t \/ not_stuck (k x)) -> + css L `R t (k x) -> + css L `R t (Br c k). + Proof. + apply css_br_r_gen. + Qed. + + Lemma cssim_br_r {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: ctree E C X) L : + (not_stuck t \/ not_stuck (k x)) -> + cssim L t (k x) -> + cssim L t (Br c k). + Proof. + intros. step. apply css_br_r_gen with (x := x); auto. + now step in H0. + Qed. + + Lemma css_br_gen {A B} (c: C A) (d: D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) R L : + (exists x, not_stuck (k x)) -> + (forall x, exists y, css L R (k x) (k' y)) -> + css L R (Br c k) (Br d k'). + Proof. + intros [a NS] EQs. + split. + - apply ss_br_l_gen. + intros x. + destruct (EQs x) as [x' ?]. + destruct H. + eapply ss_br_r_gen; eauto. + - intros NS'. + destruct NS as (? & ? & TR'). + ex2; eauto. + Qed. + + Lemma css_br {A B} (c: C A) (d: D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + (exists x, not_stuck (k x)) -> + (forall x, exists y, css L `R (k x) (k' y)) -> + css L `R (Br c k) (Br d k'). + Proof. + apply css_br_gen. + Qed. + + Lemma cssim_br {A B} (c: C A) (d: D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) L : + (exists x, not_stuck (k x)) -> + (forall x, exists y, cssim L (k x) (k' y)) -> + cssim L (Br c k) (Br d k'). + Proof. + intros NS SIM. step. apply css_br_gen; auto. + intros. destruct (SIM x). step in H. eauto. + Qed. + + Lemma css_br_id {A} (c: C A) (d: D A) + (k : A -> ctree E C X) (k': A -> ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + (exists x, not_stuck (k x)) -> + (forall x, css L `R (k x) (k' x)) -> + css L `R (Br c k) (Br d k'). + Proof. + intros; apply css_br; eauto. + Qed. + + Lemma cssim_br_id {A} (c: C A) (d: D A) + (k : A -> ctree E C X) (k': A -> ctree F D Y) L : + (exists x, not_stuck (k x)) -> + (forall x, cssim L (k x) (k' x)) -> + cssim L (Br c k) (Br d k'). + Proof. + intros. apply cssim_br; eauto. + Qed. + + Lemma css_guard_l_gen + (t: ctree E C X) (t': ctree F D Y) R L: + css L R t t' -> + css L R (Guard t) t'. + Proof. + intros [SIM PROG]; split. + - apply ss_guard_l_gen; auto. + - intros NS; edestruct3 PROG; auto. + eauto. + Qed. + + Lemma css_guard_l + (t: ctree E C X) (t': ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + css L `R t t' -> + css L `R (Guard t) t'. + Proof. + intros; now apply css_guard_l_gen. + Qed. + + Lemma cssim_guard_l + (t: ctree E C X) (t': ctree F D Y) L: + cssim L t t' -> + cssim L (Guard t) t'. + Proof. + intros; step; apply css_guard_l; step in H; auto. + Qed. + + Lemma css_guard_r_gen + (t: ctree E C X) (t': ctree F D Y) R L : + css L R t t' -> + css L R t (Guard t'). + Proof. + intros [SIM PROG]; split. + - apply ss_guard_r_gen; auto. + - intros (? & ? & TR); inv_trans; destruct PROG; eauto. + Qed. + + Lemma css_guard_r + (t: ctree E C X) (t': ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + css L `R t t' -> + css L `R t (Guard t'). + Proof. + now apply css_guard_r_gen. + Qed. + + Lemma ssim_guard_r + (t: ctree E C X) (t': ctree F D Y) L : + ssim L t t' -> + ssim L t (Guard t'). + Proof. + intros; step; apply ss_guard_r; step in H; auto. + Qed. + + Lemma ssim_guard + (t: ctree E C X) (t': ctree F D Y) L : + ssim L t t' -> + ssim L (Guard t) (Guard t'). + Proof. + intros. + now apply ssim_guard_l, ssim_guard_r. + Qed. + + (* CHECK *) +(*| +Internal transitions +|*) + Lemma css_step + (t: ctree E C X) (t': ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + ` R t t' -> + css L ` R (Step t) (Step t'). + Proof. + intros HR ???; inv_trans; subst. + ex2; intuition. + now rewrite EQ. + Qed. + + Lemma cssim_step + (t: ctree E C X) (t': ctree F D Y) L : + cssim L t t' -> + cssim L (Step t) (Step t'). + Proof. + now intros; step; apply css_step. + Qed. + + Lemma css_brS {Z Z'} (c : C Z) (c' : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + (forall x, exists y, ` R (k x) (k' y)) -> + css L ` R (BrS c k) (BrS c' k'). + Proof. + intros. + eapply css_br. + intros x; specialize (H x) as [y ?]. + exists y. + eapply css_step; auto. + Qed. + + Lemma cssim_brS {Z Z'} (c : C Z) (c' : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L : + (forall x, exists y, cssim L (k x) (k' y)) -> + cssim L (BrS c k) (BrS c' k'). + Proof. + now intros; step; apply css_brS. + Qed. + + Lemma css_brS_id {Z} (c : C Z) (d : D Z) + (k: Z -> ctree E C X) (k': Z -> ctree F D Y) L + {R : Chain (@css E F C D X Y L)} : + (forall x, `R (k x) (k' x)) -> + css L ` R (BrS c k) (BrS d k'). + Proof. + intros; apply css_brS; eauto. + Qed. + + Lemma cssim_brS_id {Z} (c : C Z) (d : D Z) + (k: Z -> ctree E C X) (k': Z -> ctree F D Y) L : + (forall x, cssim L (k x) (k' x)) -> + cssim L (BrS c k) (BrS d k'). + Proof. + intros; apply cssim_brS; eauto. + Qed. + + + Lemma step_css_ret_gen {Y F D}(x : X) (y : Y) (R L : rel _ _) : R Stuck Stuck -> (Proper (equ eq ==> equ eq ==> impl) R) -> diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index a97efbe..52be79a 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -504,17 +504,29 @@ Stuck ctrees can be simulated by anything. (*| Ret nodes + +Note: the general formulation (over any well-behaved realtion rather than elements of the chain) is necessary for br nodes, but also useful to reuse in [css] (where the relation will be an element of the css chain). |*) + Lemma ss_ret_gen (x : X) (y : Y) L R : + R (α Stuck) (α Stuck) -> + (Proper (Seq ==> Seq ==> impl) R) -> + RR L x y -> + ss L R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros HS HP HR l u TR. + inv_trans. subst. + ex2; intuition. + now rewrite EQ. + Qed. + Lemma ss_ret (x : X) (y : Y) L {R : Chain (@ss E F C D X Y L)} : RR L x y -> ss L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). Proof. - intros HR l u TR. - inv_trans. subst. - ex2; intuition. - rewrite EQ. + apply ss_ret_gen. step; apply ss_stuck. + typeclasses eauto. Qed. Lemma ssim_ret (x : X) (y : Y) L : From 35da3c6bb755d2432a19c5eafbbb93d38c2f505e Mon Sep 17 00:00:00 2001 From: Yannick Date: Mon, 3 Nov 2025 21:53:37 +0100 Subject: [PATCH 18/61] Finished complete simulations, but mirrored a lot strong simulations, need to revisit the inversion lemmas in particular to see if we can be more precise --- theories/Eq/CSSim.v | 837 +++++++++----------------------------------- theories/Eq/SSim.v | 18 +- 2 files changed, 173 insertions(+), 682 deletions(-) diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index 662d3b5..d6ab6af 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -102,11 +102,11 @@ Ltac __play_cssim := step; cbn; split; [intros ? ? ?TR | etrans]. Ltac __play_cssim_in H := step in H; cbn in H; edestruct H as [(? & ? & ?TR & ?EQ & ?HL) ?PROG]; - clear H; [etrans |]. + clear H; [etrans |]; fold_cssim. Ltac __eplay_cssim := match goal with - | h : @cssim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ => + | h : @cssim ?E ?F ?C ?D ?X ?Y ?L ?u ?v |- _ => __play_cssim_in h end. @@ -445,7 +445,7 @@ Specialization: equality on external calls, equality everywhere (*| Specializations to the gfp |*) - Lemma ssim_bind_gen E F C D X Y X' Y' + Lemma cssim_bind_gen E F C D X Y X' Y' L (SS : rel X Y) (t1 : ctree E C X) (t2: ctree F D Y) (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): @@ -457,7 +457,7 @@ Specializations to the gfp eapply bind_chain_gen; eauto. Qed. - Lemma ssim_bind E C D X Y X' Y' + Lemma cssim_bind E C D X Y X' Y' (RR : rel X' Y') (SS : rel X Y) (t1 : ctree E C X) (t2: ctree E D Y) (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y'): @@ -469,7 +469,7 @@ Specializations to the gfp eapply bind_chain_gen; eauto. Qed. - Lemma ssim_bind_eq {E C D: Type -> Type} {X X': Type} + Lemma cssim_bind_eq {E C D: Type -> Type} {X X': Type} (t1 : ctree E C X) (t2: ctree E D X) (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): t1 ⪅ t2 -> @@ -477,7 +477,7 @@ Specializations to the gfp t1 >>= k1 ⪅ t2 >>= k2. Proof. intros. - eapply ssim_bind; eauto. + eapply cssim_bind; eauto. intros ?? ->; auto. Qed. @@ -788,24 +788,23 @@ Invisible nodes now apply css_guard_r_gen. Qed. - Lemma ssim_guard_r + Lemma cssim_guard_r (t: ctree E C X) (t': ctree F D Y) L : - ssim L t t' -> - ssim L t (Guard t'). + cssim L t t' -> + cssim L t (Guard t'). Proof. - intros; step; apply ss_guard_r; step in H; auto. + intros; step; apply css_guard_r; step in H; auto. Qed. - Lemma ssim_guard + Lemma cssim_guard (t: ctree E C X) (t': ctree F D Y) L : - ssim L t t' -> - ssim L (Guard t) (Guard t'). + cssim L t t' -> + cssim L (Guard t) (Guard t'). Proof. intros. - now apply ssim_guard_l, ssim_guard_r. + now apply cssim_guard_l, cssim_guard_r. Qed. - (* CHECK *) (*| Internal transitions |*) @@ -815,9 +814,10 @@ Internal transitions ` R t t' -> css L ` R (Step t) (Step t'). Proof. - intros HR ???; inv_trans; subst. - ex2; intuition. - now rewrite EQ. + intros HR; split. + - apply ss_step_gen; auto. + typeclasses eauto. + - eauto. Qed. Lemma cssim_step @@ -828,20 +828,21 @@ Internal transitions now intros; step; apply css_step. Qed. - Lemma css_brS {Z Z'} (c : C Z) (c' : D Z') + Lemma css_brS {Z Z'} `{Inhabited Z} (c : C Z) (c' : D Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L {R : Chain (@css E F C D X Y L)} : (forall x, exists y, ` R (k x) (k' y)) -> css L ` R (BrS c k) (BrS c' k'). Proof. - intros. + intros * SIM. eapply css_br. - intros x; specialize (H x) as [y ?]. + exists inhabitant; eauto. + intros x; specialize (SIM x) as [y ?]. exists y. eapply css_step; auto. Qed. - Lemma cssim_brS {Z Z'} (c : C Z) (c' : D Z') + Lemma cssim_brS {Z Z'} `{Inhabited Z} (c : C Z) (c' : D Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L : (forall x, exists y, cssim L (k x) (k' y)) -> cssim L (BrS c k) (BrS c' k'). @@ -849,7 +850,7 @@ Internal transitions now intros; step; apply css_brS. Qed. - Lemma css_brS_id {Z} (c : C Z) (d : D Z) + Lemma css_brS_id {Z} `{Inhabited Z} (c : C Z) (d : D Z) (k: Z -> ctree E C X) (k': Z -> ctree F D Y) L {R : Chain (@css E F C D X Y L)} : (forall x, `R (k x) (k' x)) -> @@ -858,7 +859,7 @@ Internal transitions intros; apply css_brS; eauto. Qed. - Lemma cssim_brS_id {Z} (c : C Z) (d : D Z) + Lemma cssim_brS_id {Z} `{Inhabited Z} (c : C Z) (d : D Z) (k: Z -> ctree E C X) (k': Z -> ctree F D Y) L : (forall x, cssim L (k x) (k' x)) -> cssim L (BrS c k) (BrS d k'). @@ -866,711 +867,191 @@ Internal transitions intros; apply cssim_brS; eauto. Qed. - - - Lemma step_css_ret_gen {Y F D}(x : X) (y : Y) (R L : rel _ _) : - R Stuck Stuck -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - L (val x) (val y) -> - css L R (Ret x : ctree E C X) (Ret y : ctree F D Y). - Proof. - intros Rstuck PROP Lval. - split. - cbn; intros ? ? TR; inv_trans; subst; - cbn; eexists; eexists; intuition; etrans; - now rewrite EQ. - intros; do 2 eexists; etrans. - Qed. - - Lemma step_css_ret {Y F D} (x : X) (y : Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - L (val x) (val y) -> - css L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). - Proof. - intros. - apply step_css_ret_gen. - - apply (b_chain R). - split. - apply is_stuck_ss; apply Stuck_is_stuck. - intros * abs; apply trans_stuck_inv in abs; easy. - - typeclasses eauto. - - apply H. - Qed. - - Lemma step_css_ret_l_gen {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L R : rel _ _) : - R Stuck Stuck -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - L (val x) (val y) -> - trans (val y) u u' -> - css L R (Ret x : ctree E C X) u. - Proof. - intros. - apply trans_val_inv in H2 as ?. - split. - - cbn. intros. - inv_trans. - subst; setoid_rewrite EQ. - etrans. - - intros. - do 2 eexists. - etrans. - Qed. - - Lemma step_css_ret_l {Y F D} (x : X) (y : Y) (u u' : ctree F D Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - L (val x) (val y) -> - trans (val y) u u' -> - css L ` R (Ret x : ctree E C X) u. - Proof. - intros. - eapply step_css_ret_l_gen; eauto. - - apply (b_chain R). - split. - apply is_stuck_ss; apply Stuck_is_stuck. - intros * abs; apply trans_stuck_inv in abs; easy. - - typeclasses eauto. - Qed. - - Lemma cssim_ret {Y F D} (x : X) (y : Y) (L : rel _ _) : - L (val x) (val y) -> - cssim L (Ret x : ctree E C X) (Ret y : ctree F D Y). - Proof. - intros. step. now apply step_css_ret. - Qed. - (*| - The vis nodes are deterministic from the perspective of the labeled - transition system, stepping is hence symmetric and we can just recover - the itree-style rule. + Note that with visible schedules, an nary-spins refines another only + if it is empty, or if neither are empty. |*) - Lemma step_css_vis_gen {Y Z Z' F D} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (R L: rel _ _) : - inhabited Z -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, exists y, R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - css L R (Vis e k) (Vis f k'). + Lemma cssim_spinS_nonempty : + forall {Z Z'} L (x: Z) (y: Z') (c: C Z) (c': D Z'), + @cssim E F C D X Y L (spinS_gen c) (spinS_gen c'). Proof. - intros. + intros until L; intros x y. + coinduction S CIH. split. - - apply step_ss_vis_gen; auto. - - intros * tr; inv_trans; subst. - do 2 eexists. etrans. - Unshelve. - apply X0. - Qed. - - Lemma step_css_vis {Y Z Z' F D} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - inhabited Z -> - (forall x, exists y, ` R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - css L ` R (Vis e k) (Vis f k'). - Proof. - intros * INH EQ. - apply step_css_vis_gen; auto. - typeclasses eauto. - Qed. - - Lemma cssim_vis {Y Z Z' F D} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L : rel _ _) : - inhabited Z -> - (forall x, exists y, cssim L (k x) (k' y) /\ L (obs e x) (obs f y)) -> - cssim L (Vis e k) (Vis f k'). - Proof. - intros. step. apply step_css_vis; auto. - Qed. - - Lemma step_css_vis_id_gen {Y Z F D} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (R L: rel _ _) : - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, R (k x) (k' x) /\ L (obs e x) (obs f x)) -> - css L R (Vis e k) (Vis f k'). - Proof. - intros. - split. - - apply step_ss_vis_id_gen; auto. - - intros * tr; inv_trans; subst. - do 2 eexists. etrans. - Unshelve. apply x. - Qed. - - Lemma step_css_vis_id {Y Z F D} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - (forall x, ` R (k x) (k' x) /\ L (obs e x) (obs f x)) -> - css L ` R (Vis e k) (Vis f k'). - Proof. - intros * EQ. - apply step_css_vis_id_gen; auto. - typeclasses eauto. - Qed. - - Lemma cssim_vis_id {Y Z F D} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) (L : rel _ _) : - (forall x, cssim L (k x) (k' x) /\ L (obs e x) (obs f x)) -> - cssim L (Vis e k) (Vis f k'). - Proof. - intros. step. now apply step_css_vis_id. - Qed. - -(*| - Same goes for visible tau nodes. -|*) - Lemma step_css_step_gen {Y F D} - (t : ctree E C X) (t': ctree F D Y) (R L: rel _ _): - (Proper (equ eq ==> equ eq ==> impl) R) -> - L τ τ -> - (R t t') -> - css L R (Step t) (Step t'). - Proof. - intros PR ? EQs. - split. - - apply step_ss_step_gen; auto. - - intros * TR; inv_trans; subst; etrans. - Qed. - - Lemma step_css_step {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - (` R t t') -> - L τ τ -> - css L ` R (Step t) (Step t'). - Proof. - intros. - apply step_css_step_gen; auto. - typeclasses eauto. - Qed. - - Lemma cssim_step {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L : rel _ _) : - (cssim L t t') -> - L τ τ -> - cssim L (Step t) (Step t'). - Proof. - intros. - step. apply step_css_step; auto. - Qed. - -(*| - For invisible nodes, the situation is different: we may kill them, but that execution - cannot act as going under the guard. -|*) - Lemma step_css_br_l_gen {Y F D Z} (c : C Z) - (k : Z -> ctree E C X) (t': ctree F D Y) (R L: rel _ _): - inhabited Z -> - (forall x, css L R (k x) t') -> - css L R (Br c k) t'. - Proof. - intros [? _] EQs. - split. - - apply step_ss_br_l_gen; auto. apply EQs. - - intros * TR. - unshelve edestruct EQs as [_ ?]; eauto. - apply H in TR. - destruct TR as (? & ? & ?). - etrans. - Qed. - - Lemma step_css_br_l {Y F D Z} (c : C Z) - (k : Z -> ctree E C X) (t: ctree F D Y) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - inhabited Z -> - (forall x, css L (elem R) (k x) t) -> - css L ` R (Br c k) t. - Proof. - intros [? _] EQs. - split. - - apply step_ss_br_l_gen; auto. apply EQs. - - intros * TR. - unshelve edestruct EQs as [_ ?]; eauto. - apply H in TR. - destruct TR as (? & ? & ?). - etrans. - Qed. - - Lemma cssim_br_l {Y F D Z} (c : C Z) - (k : Z -> ctree E C X) (t: ctree F D Y) (L: rel _ _): - inhabited Z -> - (forall x, cssim L (k x) t) -> - cssim L (Br c k) t. - Proof. - intros. step. apply step_css_br_l_gen; auto. intros. - specialize (H x). step in H. apply H. - Qed. - - (* This does not hold without assuming explicit progress on the left side. - Indeed, if [k x] is stuck, [t] would be stuck as well. - But then [Br c k] could be able to step, contradicting the completeness. - *) - Lemma step_css_br_r_gen {Y F D Z} (c : D Z) - (t : ctree E C X) (k : Z -> ctree F D Y) (R L: rel _ _) z : - (exists l t', trans l t t') -> - css L R t (k z) -> - css L R t (Br c k). - Proof. - intros TR [SIM COMP]. - split. - - eapply step_ss_br_r_gen; eauto. - - intros; auto. - Qed. - - Lemma step_css_br_r {Y F D Z} (c : D Z) x - (k : Z -> ctree F D Y) (t: ctree E C X) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - (exists l t', trans l t t') -> - css L (elem R) t (k x) -> - css L ` R t (Br c k). - Proof. - intros TR SIM. - split. - - eapply step_ss_br_r_gen; apply SIM. - - auto. - Qed. - - Lemma cssim_br_r {Y F D Z} (c : D Z) x - (k : Z -> ctree F D Y) (t: ctree E C X) (L: rel _ _): - (exists l t', trans l t t') -> - cssim L t (k x) -> - cssim L t (Br c k). - Proof. - intros. step. - apply (@step_css_br_r_gen Y F D Z c t k (cssim L) L x); auto. - step in H0; auto. - Qed. - - Lemma step_css_br_gen {Y F D n m} (a: C n) (b: D m) - (k : n -> ctree E C X) (k' : m -> ctree F D Y) (R L : rel _ _) : - (exists x l t', trans l (k x) t') -> - (forall x, exists y, css L R (k x) (k' y)) -> - css L R (Br a k) (Br b k'). - Proof. - intros [? PROG] EQs. - split. - - apply step_ss_br_gen; auto. intros y. destruct (EQs y). - exists x0; apply H. - - intros * TR. - destruct PROG as (? & ? & TR'). - do 2 eexists; econstructor; apply TR'. - Qed. - - Lemma step_css_br {Y F D n m} (cn: C n) (cm: D m) - (k : n -> ctree E C X) (k' : m -> ctree F D Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - (exists x l t', trans l (k x) t') -> - (forall x, exists y, css L (elem R) (k x) (k' y)) -> - css L `R (Br cn k) (Br cm k'). - Proof. - intros. - apply step_css_br_gen; auto. - Qed. - - Lemma cssim_br {Y F D n m} (cn: C n) (cm: D m) - (k : n -> ctree E C X) (k' : m -> ctree F D Y) (L : rel _ _) : - (exists x l t', trans l (k x) t') -> - (forall x, exists y, cssim L (k x) (k' y)) -> - cssim L (Br cn k) (Br cm k'). - Proof. - intros. step. apply step_css_br; auto. - intros. destruct (H0 x). step in H1. exists x0. apply H1. - Qed. - - Lemma step_css_br_id_gen {Y F D Z} (c: C Z) (d: D Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) - (R L : rel _ _) : - (forall x, css L R (k x) (k' x)) -> - css L R (Br c k) (Br d k'). - Proof. - intros EQs. - split. - - apply step_ss_br_id_gen; auto. intros y. destruct (EQs y). - apply H. - - intros * TR. - apply trans_br_inv in TR as [x TR]. - apply EQs in TR as (l' & t & TR). - do 2 eexists; econstructor; apply TR. - Qed. - - Lemma step_css_br_id {Y F D n} (c: C n) (d: D n) - (k : n -> ctree E C X) (k': n -> ctree F D Y) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - (forall x, css L (elem R) (k x) (k' x)) -> - css L ` R (Br c k) (Br d k'). - Proof. - intros. - apply step_css_br_id_gen; eauto. - Qed. - - Lemma cssim_br_id {Y F D n} (c: C n) (d: D n) - (k : n -> ctree E C X) (k': n -> ctree F D Y) (L: rel _ _) : - (forall x, cssim L (k x) (k' x)) -> - cssim L (Br c k) (Br d k'). - Proof. - intros. step. apply step_css_br_id; eauto. - intros. apply (gfp_pfp (css L)). apply H. - Qed. - - Lemma step_css_guard_gen {Y F D} - (t: ctree E C X) (t': ctree F D Y) (R L: rel _ _): - css L R t t' -> - css L R (Guard t) (Guard t'). - Proof. - intros EQ. - split. - - apply step_ss_guard_gen; apply EQ. - - intros. + - intros * ?? TR. + rewrite ctree_eta in TR; cbn in TR. inv_trans. - apply EQ in H as (? & ? & ?). - etrans. - Qed. - - Lemma step_css_guard_l {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - css L `R t t' -> - css L `R (Guard t) t'. - Proof. - intros EQ. - split. - - intros ? ? TR; inv_trans; subst. - apply EQ in TR as (? & ? & TR' & ?). - eauto. - - intros. - apply EQ in H as (? & ? & ?). - etrans. - Qed. - - Lemma step_css_guard_r {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - css L `R t t' -> - css L `R t (Guard t'). - Proof. - intros EQ. - split. - - intros ? ? TR; inv_trans; subst. - apply EQ in TR as (? & ? & TR' & ?). - do 2 eexists; split; eauto. - etrans. + ex2; split3; subst; etrans. + rewrite ctree_eta; cbn; etrans. + now rewrite EQ. - intros. - inv_trans. - apply EQ in H as (? & ? & ?). - etrans. - Qed. - - Lemma step_css_guard {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - css L `R t t' -> - css L `R (Guard t) (Guard t'). - Proof. - intros. - now apply step_css_guard_gen. - Qed. - - Lemma cssim_guard_l {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _): - cssim L t t' -> - cssim L (Guard t) t'. - Proof. - intros; step; apply step_css_guard_l; step in H; auto. - Qed. - - Lemma cssim_guard_r {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _): - cssim L t t' -> - cssim L t (Guard t'). - Proof. - intros; step; apply step_css_guard_r; step in H; auto. - Qed. - - Lemma cssim_guard {Y F D} - (t: ctree E C X) (t': ctree F D Y) (L: rel _ _): - cssim L t t' -> - cssim L (Guard t) (Guard t'). - Proof. - intros; step; apply step_css_guard; step in H; auto. + rewrite ctree_eta; cbn. + eauto. Qed. (*| - When matching visible brs one against another, in general we need to explain how - we map the branches from the left to the branches to the right. - A useful special case is the one where the arity coincide and we simply use the identity - in both directions. We can in this case have [n] rather than [2n] obligations. +Inversion principles +-------------------- +TODO: these principles are mirrored on ssim directly. We should be able to derive additional liveness information from them in some cases. |*) - Lemma step_css_brS_gen {Z Z' Y F D} (c : C Z) (d : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (R L: rel _ _) : - inhabited Z -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, exists y, R (k x) (k' y)) -> - L τ τ -> - css L R (BrS c k) (BrS d k'). - Proof. - intros INH HP REL HL. - eapply step_css_br_gen. - destruct INH as [z _]. - exists z; etrans. - intros. - specialize (REL x) as [y ?]. - exists y. - eapply step_css_step_gen; auto. - Qed. - - Lemma step_css_brS {Z Z' Y F D} (c : C Z) (c' : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L: rel _ _) - {R : Chain (@css E F C D X Y L)} : - inhabited Z -> - (forall x, exists y, `R (k x) (k' y)) -> - L τ τ -> - css L `R (BrS c k) (BrS c' k'). - Proof. - intros INH REL HL. - destruct INH as [z _]. - eapply step_css_br. - exists z; etrans. - intros x; specialize (REL x) as [y ?]. - exists y. - eapply step_css_step; auto. - Qed. - - Lemma cssim_brS {Z Z' Y F D} (c : C Z) (c' : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (L: rel _ _) : - inhabited Z -> - (forall x, exists y, cssim L (k x) (k' y)) -> - L τ τ -> - cssim L (BrS c k) (BrS c' k'). - Proof. - intros INH REL HL. - destruct INH as [z _]. - apply cssim_br. - exists z; etrans. - intros x; specialize (REL x) as [y ?]; exists y. - apply cssim_step; auto. - Qed. - - Lemma step_css_brS_id_gen {Z Y D F} (c : C Z) (d: D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) (R L : rel _ _) : - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, R (k x) (k' x)) -> - L τ τ -> - css L R (BrS c k) (BrS d k'). - Proof. - intros HP REL HL. - split; [apply step_ss_brS_id_gen; auto |]. - intros. inv_trans. etrans. - Unshelve. apply x0. - Qed. - - Lemma step_css_brS_id {Z Y D F} (c : C Z) (d : D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) (L : rel _ _) - {R : Chain (@css E F C D X Y L)} : - (forall x, `R (k x) (k' x)) -> - L τ τ -> - css L `R (BrS c k) (BrS d k'). - Proof. - intros REL HL. - apply step_css_brS_id_gen; auto. - typeclasses eauto. - Qed. - - Lemma cssim_brS_id {Z Y D F} (c : C Z) (d : D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) (L : rel _ _) : - (forall x, cssim L (k x) (k' x)) -> - L τ τ -> - cssim L (BrS c k) (BrS d k'). + + Lemma cssim_stuck_inv L (t : ctree E C X) (u : ctree F D Y) + (CSS :@cssim E F C D X Y L t u) : + is_stuck t <-> is_stuck u. Proof. - intros. step. apply step_css_brS_id; auto. + split. + - intros IS l u' TR. + step in CSS. + destruct CSS as [SS PROG]. + eapply not_stuck_is_stuck. + apply PROG. + eauto. + auto. + - intros IS l t' TR. + step in CSS. + apply CSS in TR. + edestruct5 TR. + eapply IS; eauto. Qed. -End Proof_Rules. - -Section WithParams. - - Context {E F C D : Type -> Type}. - Context (L : rel (@label E) (@label F)). - -(*| -Note that with visible schedules, nary-spins are equivalent only -if neither are empty, or if both are empty: they match each other's -tau challenge infinitely often. -With invisible schedules, they are always equivalent: neither of them -produce any challenge for the other. -|*) - Lemma spinS_gen_nonempty : forall {Z Z' X Y} (c: C X) (c': D Y) (x: X) (y: Y) (L : rel _ _), - L τ τ -> - cssim L (@spinS_gen E C Z X c) (@spinS_gen F D Z' Y c'). + Lemma cssim_ret_l_inv L : + forall r (u : ctree F D Y) + (CSS : @cssim E F C D X Y L (Ret r) u), + exists r' u', trans (val r') u u' /\ RR L r r'. Proof. - intros. - red. coinduction R CH. - simpl; split; intros l t' TR; rewrite ctree_eta in TR; cbn in TR; - apply trans_brS_inv in TR as (_ & EQ & ->); - do 2 eexists; - rewrite ctree_eta; cbn; intuition. - - econstructor; auto. - constructor; eauto. - - rewrite EQ; eauto. - - eapply H. - - econstructor; auto. - constructor; eauto. + intros. step in CSS. + destruct CSS as [SIM PROG]. + edestruct5 SIM; etrans. + invL. + ex2; split; etrans. Qed. - -(*| -Inversion principles --------------------- -|*) - Lemma cssim_ret_inv X Y (r1 : X) (r2 : Y) : - (Ret r1 : ctree E C X) (⪅L) (Ret r2 : ctree F D Y) -> + + Lemma cssim_ret_inv L (r1 : X) (r2 : Y) + (CSS : @cssim E F C D X Y L (Ret r1) (Ret r2)) : L (val r1) (val r2). Proof. - intros. eplay. - inv_trans. - now subst. + now inv_trans. Qed. - Lemma css_ret_l_inv {X Y R} : - forall r (u : ctree F D Y), - css L R (Ret r : ctree E C X) u -> - exists l' u', trans l' u u' /\ R Stuck u' /\ L (val r) l'. + Lemma cssim_vis_inv {X1 X2} L + (e : E X1) (f : F X2) + (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree F D Y) + (CSS : cssim L (Vis e k1) (Vis f k2)) : + Rask L e f /\ + (forall x, exists y, Rrcv L e f x y /\ cssim L (k1 x) (k2 y)). Proof. - intros. apply H; etrans. + eplay; inv_trans; invL. + split; auto. + intros x. + unshelve eplay. exact x. + invL. + inv_trans. + exists x1; split; eauto. + dependent induction EQl; eauto. Qed. - - Lemma cssim_ret_l_inv {X Y} : - forall r (u : ctree F D Y), - cssim L (Ret r : ctree E C X) u -> - exists l' u', trans l' u u' /\ L (val r) l'. + + Lemma cssim_vis_l_inv {Z L} : + forall (e : E Z) (k : Z -> ctree E C X) u, + @cssim E F C D X Y L (Vis e k) u -> + exists Z' (f : F Z') k', + trans (ask f) u (β f k') /\ + Rask L e f /\ + forall x, exists y, cssim L (k x) (k' y) /\ Rrcv L e f x y. Proof. - intros. step in H. - apply css_ret_l_inv in H as (? & ? & ? & ? & ?). etrans. + intros. + eplay; invL; refine_trans. + ex3; split3; etrans. + intros z. + unshelve eplay; [eassumption |]; inv_trans; invL. + ex; split; etrans. Qed. - Lemma cssim_vis_inv_type {X Y X1 X2} - (e1 : E X1) (e2 : E X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree E D Y) (x1 : X1): - cssim eq (Vis e1 k1) (Vis e2 k2) -> - X1 = X2. + Lemma cssim_guard_l_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + cssim L (Guard t1) t2 -> + cssim L t1 t2. Proof. - intros. - step in H; cbn in H; destruct H as [SIM COMP]. - edestruct SIM as (? & ? & ? & ? & ?). - etrans. - inv_trans; subst; auto. - eapply obs_eq_invT; eauto. - Unshelve. - exact x1. + intros CSS; play. + - eplay. + ex2; split3; etrans. + - intros NS. + step in CSS; destruct CSS as [_ PROG]; edestruct3 PROG; eauto. + inv_trans; eauto. Qed. - Lemma cssbt_vis_inv {X Y X1 X2} - (e1 : E X1) (e2 : F X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree F D Y) (x : X1) - {R : Chain (@css E F C D X Y L)} : - css L (elem R) (Vis e1 k1) (Vis e2 k2) -> - (exists y, L (obs e1 x) (obs e2 y)) /\ (forall x, exists y, ` R (k1 x) (k2 y)). + Lemma cssim_guard_r_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + cssim L t1 (Guard t2) -> + cssim L t1 t2. Proof. - intros. - destruct H as [SIM COMP]. - split; intros; edestruct SIM as (? & ? & ? & ? & ?); - etrans; subst; - inv_trans; subst; eexists; auto. - - now eapply H1. - - now apply H0. + intros CSS; play. + - eplay; inv_trans. + ex2; split3; etrans. + - intros (? & ? & ?). + step in CSS; destruct CSS as [_ PROG]; edestruct3 PROG; eauto. Qed. - Lemma ssim_vis_inv {X Y X1 X2} - (e1 : E X1) (e2 : F X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree F D Y) (x : X1): - cssim L (Vis e1 k1) (Vis e2 k2) -> - (exists y, L (obs e1 x) (obs e2 y)) /\ (forall x, exists y, cssim L (k1 x) (k2 y)). + Lemma cssim_guard_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + cssim L (Guard t1) (Guard t2) -> + cssim L t1 t2. Proof. intros. - split. - - eplay. - inv_trans; subst; exists x2; eauto. - - intros y. - step in H. - cbn in H. - edestruct H as [(l' & u' & TR & IN & HL) ?]. - apply trans_vis with (x := y). - inv_trans. - eexists. - apply IN. + now apply cssim_guard_r_inv, cssim_guard_l_inv. Qed. - Lemma css_vis_l_inv {X Y Z R} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - css L R (Vis e k) u -> - exists l' u', trans l' u u' /\ R (k x) u' /\ L (obs e x) l'. + Lemma cssim_br_l_inv L Z + (c: C Z) (t : ctree F D Y) (k : Z -> ctree E C X): + cssim L (Br c k) t -> + forall x, not_stuck (k x) -> cssim L (k x) t. Proof. - intros. apply H; etrans. + intros CSS ? NS; play. + eplay; eauto. Qed. - Lemma cssim_vis_l_inv {X Y Z} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - cssim L (Vis e k) u -> - exists l' u', trans l' u u' /\ cssim L (k x) u' /\ L (obs e x) l'. + Lemma cssim_br_r_inv L Z + (d: D Z) (t : ctree E C X) (k : Z -> ctree F D Y): + cssim L t (Br d k) -> + forall l t', trans l t t' -> + exists x l' u', trans l' (k x) u' /\ + cssim L t' u' /\ + L l l'. Proof. - intros. step in H. - now simple apply css_vis_l_inv with (x := x) in H. + intros CSS * TR. + eplay; inv_trans. + ex3; split3; eauto. Qed. - Lemma cssim_brS_inv {X Y} - n m (cn: C n) (cm: D m) (k1 : n -> ctree E C X) (k2 : m -> ctree F D Y) : - cssim L (BrS cn k1) (BrS cm k2) -> - (forall i1, exists i2, cssim L (k1 i1) (k2 i2)). + Lemma cssim_step_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + cssim L (Step t1) (Step t2) -> + cssim L t1 t2. Proof. - intros EQ i1. - eplay. - subst; inv_trans. - eexists; eauto. + intros; eplay; inv_trans; etrans. Qed. - Lemma css_brS_l_inv {X Y Z R} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - css L R (BrS c k) u -> - exists l' u', trans l' u u' /\ R (k x) u' /\ L τ l'. + Lemma cssim_step_l_inv L (t1 : ctree E C X) (t2 : ctree F D Y) : + cssim L (Step t1) t2 -> + exists t2', trans τ t2 t2' /\ cssim L t1 t2'. Proof. - intros. apply H; etrans. + intros; eplay; invL; refine_trans. + ex; split; etrans. Qed. - Lemma cssim_brS_l_inv {X Y Z} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, - cssim L (BrS c k) u -> - exists l' u', trans l' u u' /\ cssim L (k x) u' /\ L τ l'. + Lemma cssim_brS_inv L + A B (c: C A) (d: D B) (k1 : A -> ctree E C X) (k2 : B -> ctree F D Y) : + cssim L (BrS c k1) (BrS d k2) -> + forall i1, exists i2, cssim L (k1 i1) (k2 i2). Proof. - intros. step in H. - now simple apply css_brS_l_inv with (x := x) in H. + intros EQ i1. + eplay; invL; inv_trans; eauto. Qed. - Lemma css_br_l_inv {X Y} - n (c: C n) (t : ctree F D Y) (k : n -> ctree E C X) R: - css L R (Br c k) t -> - forall x, - (exists l' t', trans l' (k x) t') -> - css L R (k x) t. - Proof. - cbn. intros [? ?] * PROG; split; intros * TR. - - eapply trans_br in TR; [| reflexivity]. - apply H in TR as (? & ? & ? & ? & ?); subst. - eauto. - - apply PROG. - Qed. - - Lemma cssim_br_l_inv {X Y} - n (c: C n) (t : ctree F D Y) (k : n -> ctree E C X): - cssim L (Br c k) t -> - forall x, - (exists l' t', trans l' (k x) t') -> - cssim L (k x) t. + Lemma cssim_brS_l_inv L + A (c: C A) (k1 : A -> ctree E C X) (t2 : ctree F D Y) : + cssim L (BrS c k1) t2 -> + forall i, exists t2', trans τ t2 t2' /\ cssim L (k1 i) t2'. Proof. - intros. step. step in H. eapply css_br_l_inv; eauto. + intros EQ i1. + eplay; invL; inv_trans; eauto. Qed. - (* This one isn't very convenient... *) - Lemma cssim_br_r_inv {X Y} - n (c: D n) (t : ctree E C X) (k : n -> ctree F D Y): - cssim L t (Br c k) -> - forall l t', trans l t t' -> - exists l' x t'' , trans l' (k x) t'' /\ L l l' /\ (cssim L t' t''). - Proof. - cbn. intros. step in H. apply H in H0 as (? & ? & ? & ? & ?); subst. inv_trans. - do 3 eexists; eauto. - Qed. +End Proof_Rules. -End WithParams. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 52be79a..1492c54 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -120,7 +120,7 @@ Ltac __play_ssim_in H := Ltac __eplay_ssim := match goal with - | h : @ssim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ => + | h : @ssim ?E ?F ?C ?D ?X ?Y ?L ?u ?v |- _ => __play_ssim_in h end. @@ -766,15 +766,25 @@ Invisible nodes (*| Internal transitions |*) + Lemma ss_step_gen + (t: ctree E C X) (t': ctree F D Y) L R : + (Proper (Seq ==> Seq ==> impl) R) -> + R (α t) (α t') -> + ss L R (Step t) (Step t'). + Proof. + intros HP HR ???; inv_trans; subst. + ex2; intuition. + now rewrite EQ. + Qed. + Lemma ss_step (t: ctree E C X) (t': ctree F D Y) L {R : Chain (@ss E F C D X Y L)} : ` R t t' -> ss L ` R (Step t) (Step t'). Proof. - intros HR ???; inv_trans; subst. - ex2; intuition. - now rewrite EQ. + apply ss_step_gen. + typeclasses eauto. Qed. Lemma ssim_step From 40fc24825981838729c3307a06be70fc2ed58bad Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 5 Nov 2025 18:16:29 +0100 Subject: [PATCH 19/61] quick setup for symmetric --- theories/Eq/SBisim.v | 146 ++++++++++++++++++++++++++++--------------- theories/Eq/SSim.v | 9 +-- 2 files changed, 97 insertions(+), 58 deletions(-) diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim.v index 9665d34..8eb2466 100644 --- a/theories/Eq/SBisim.v +++ b/theories/Eq/SBisim.v @@ -70,9 +70,6 @@ Import CTree. Import CTreeNotations. Import EquNotations. -(* TODO: Decide where to set this *) -Arguments trans : simpl never. - (*| Strong Bisimulation ------------------- @@ -81,35 +78,73 @@ Relation relaxing [equ] to become insensitive to: - the particular branches taken during (any kind of) brs. |*) +Definition flipL {E F X Y} (L : lrel E F X Y) : lrel F E Y X := + {| RR := flip (RR L) ; + Rask := fun X Y => flip (@Rask _ _ _ _ L Y X) ; + Rrcv := fun X Y f e => flip (Rrcv L e f) |}. + +Lemma flipL_flip {E F X Y} (L : lrel E F X Y) : + build_rel (flipL L) == flip (build_rel L). +Proof. + intros f e; split; cbn; intros []; constructor; auto. +Qed. + +Lemma lequiv_flipL {E F X Y} (L L' : lrel E F X Y): + lequiv L L' -> + lequiv (flipL L) (flipL L'). +Proof. + intros (EQV & EQA & EQR). + split3. + cbn; intros; apply EQV. + cbn; intros; apply EQA. + cbn; intros; apply EQR. +Qed. + +Lemma equiv_flipL {E F X Y} (L L' : lrel E F X Y): + build_rel L == build_rel L' -> + build_rel (flipL L) == build_rel (flipL L'). +Proof. + intros EQ e f; specialize (EQ f e); cbn in *. + split. + - destruct EQ as [EQ _]. + intros FL; dependent induction FL; constructor. + cbn in *. + assert (HL: L (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + - destruct EQ as [_ EQ]. + intros FL; dependent induction FL; constructor. + cbn in *. + assert (HL: L' (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L' (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L' (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. +Qed. + Section StrongBisim. Context {E F C D : Type -> Type} {X Y : Type}. - Notation S := (ctree E C X). - Notation S' := (ctree F D Y). (*| In the heterogeneous case, the relation is not symmetric. |*) - Program Definition sb L : mon (S -> S' -> Prop) := - {| body R t u := ss L R t u /\ ss (flip L) (flip R) u t |}. + Program Definition sb L : mon (@S E C X -> @S F D Y -> Prop) := + {| body R t u := ss L R t u /\ ss (flipL L) (flip R) u t |}. Next Obligation. split; intros; [edestruct H0 as (? & ? & ?) | edestruct H1 as (? & ? & ?)]; eauto; eexists; eexists; intuition; eauto. Qed. - #[global] Instance Lequiv_sb_goal : - Proper (Lequiv X Y ==> leq) sb. + #[global] Instance lequiv_sb : + Proper (lequiv ==> weq) sb. Proof. - cbn -[sb]. split. - - destruct H0 as [? _]. eapply Lequiv_ss_goal. apply H. apply H0. - - destruct H0 as [_ ?]. eapply Lequiv_ss_goal with (x := flip x). - red. cbn. intros. now apply H. apply H0. - Qed. - - #[global] Instance weq_sb : - Proper (weq ==> weq) sb. - Proof. - cbn -[weq]. split; intro. - - eapply Lequiv_sb_goal. apply weq_Lequiv. apply H. auto. - - eapply Lequiv_sb_goal. apply weq_Lequiv. symmetry. apply H. auto. + cbn -[sb]. intros * EQ *; split. + - intros [For Bac]; split. + eapply lequiv_ss in EQ. + now apply EQ in For. + eapply lequiv_ss; [| eauto]. + now apply lequiv_flipL. + - intros [For Bac]; split. + eapply lequiv_ss; eauto. + eapply lequiv_ss; [| eauto]. + now apply lequiv_flipL. Qed. End StrongBisim. @@ -117,51 +152,58 @@ End StrongBisim. Definition sbisim {E F C D X Y} L := (gfp (@sb E F C D X Y L) : hrel _ _). -#[global] Instance Lequiv_sbisim : forall {E F C D X Y}, - Proper (Lequiv X Y ==> leq) (@sbisim E F C D X Y). -Proof. - cbn. intros. - - unfold sbisim. - epose proof (gfp_leq (x := sb x) (y := sb y)). lapply H1. - + intro. red in H2. cbn in H2. apply H2. apply H0. - + now rewrite H. -Qed. - -#[global] Instance weq_sbisim : forall {E F C D X Y}, - Proper (weq ==> weq) (@sbisim E F C D X Y). -Proof. - cbn -[ss weq]. intros. apply gfp_weq. now apply weq_sb. -Qed. - -(* This instance allows to use the symmetric tactic from coq-coinduction - for homogeneous bisimulations *) -#[global] Instance sbisim_sym {E C X L} : - Symmetric L -> - Symmetrical converse (@sb E E C C X X L) (@ss E E C C X X L). -Proof. - intros SYM. split; intro. - - destruct H. split. - + apply H. - + cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?). apply SYM in H3. eauto. - - destruct H. split. - + apply H. - + cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?). apply SYM in H3. eauto. -Qed. - Module SBisimNotations. (*| sb (bisimulation) notation |*) Notation "t ~ u" := (sbisim eq t u) (at level 70). + Notation "t (~ [ Q ] ) u" := (sbisim (Lvrel Q) t u) (at level 79). Notation "t (~ L ) u" := (sbisim L t u) (at level 70). Notation "t {{ ~ L }} u" := (sb L _ t u) (at level 79). + Notation "t '{{~' [ R ] '}}' u" := (sb (Lvrel R) (` _) t u) (at level 90, only printing). Notation "t {{~}} u" := (sb eq _ t u) (at level 79). End SBisimNotations. Import SBisimNotations. +#[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). +Proof. + intros l l' HL. + unfold Lvrel in *. + dependent induction HL; constructor; cbn in *. + dependent induction HR; constructor. + dependent induction HR; constructor. + now apply H. +Qed. + +(* This instance allows to use the symmetric tactic from coq-coinduction + for homogeneous bisimulations *) +#[global] Instance sbisim_sym {E C X L} : + Symmetric L -> + Symmetrical converse (@sb E E C C X X (Lvrel L)) (@ss E E C C X X (Lvrel L)). +Proof. + intros SYM. intros RR u v. split; intros HSIM. + - destruct HSIM as [F B]. split. + + apply F. + + cbn. intros l v' TR. + apply B in TR as (l' & u' & TR & HR & HR'). + ex2; split3; eauto. + symmetry. + pose proof flipL_flip (Lvrel L) l l' as G. + now apply G. + - destruct HSIM as [F B]. split. + + apply F. + + intros l v' TR. + apply B in TR as (l' & u' & TR & HR & HR'). + ex2; split3; eauto. + pose proof flipL_flip (Lvrel L) l l' as G. + apply G. + now symmetry. +Qed. + + Ltac fold_sbisim := repeat match goal with diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 1492c54..0b90081 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -36,11 +36,8 @@ Pous'16 in order to be able to exploit symmetry arguments in proofs Program Definition ss {E F C D : Type -> Type} {X Y : Type} (L : lrel E F X Y) : mon (@S E C X -> @S F D Y -> Prop) := - {| body R t u := - forall l t', trans l t t' -> - exists l' u', trans l' u u' /\ - R t' u' /\ - L l l' + {| body R t u := forall l t', trans l t t' -> + exists l' u', trans l' u u' /\ R t' u' /\ L l l' |}. Next Obligation. edestruct3 H0; eauto. @@ -166,7 +163,7 @@ Section ssim_heterogenous_theory. Notation ss := (@ss E F C D X Y). Notation ssim := (@ssim E F C D X Y). - Lemma ssim_subrelation : + Lemma ssim_mono : Proper (sub_lrel ==> leq) ssim. Proof. cbn; intros * SUB. From c878904fd451a6c6e4a2e210b758d5a24cdab771 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 7 Nov 2025 10:15:18 +0100 Subject: [PATCH 20/61] Better tactics, better instances --- theories/Eq/CSSim.v | 54 +++++++++++++++++++++++++++------------------ theories/Eq/SSim.v | 44 ++++++++++++++++++++++++------------ 2 files changed, 62 insertions(+), 36 deletions(-) diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index d6ab6af..b17632a 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -97,56 +97,66 @@ Ltac __step_in_cssim H := Import CTreeNotations. Import EquNotations. -Ltac __play_cssim := step; cbn; split; [intros ? ? ?TR | etrans]. +Ltac __play_cssim := (try step); cbn; split; [intros ? ? ?TR | etrans]. Ltac __play_cssim_in H := - step in H; + (try step in H); cbn in H; edestruct H as [(? & ? & ?TR & ?EQ & ?HL) ?PROG]; clear H; [etrans |]; fold_cssim. Ltac __eplay_cssim := match goal with - | h : @cssim ?E ?F ?C ?D ?X ?Y ?L ?u ?v |- _ => - __play_cssim_in h + | h : cssim ?L ?u ?v |- _ => __play_cssim_in h + | h : body (css ?L) ?R ?u ?v |- _ => __play_cssim_in h end. +Ltac __answer_cssim := ex2; split3; etrans. + #[local] Tactic Notation "play" := __play_cssim. #[local] Tactic Notation "play" "in" ident(H) := __play_cssim_in H. #[local] Tactic Notation "eplay" := __eplay_cssim. +#[local] Tactic Notation "answer" := __answer_cssim. Section cssim_homogenous_theory. Context {E B : Type -> Type} {X : Type} {L: lrel E E X X}. - Notation css := (@css E E B B X X). - Notation cssim := (@cssim E E B B X X). + Notation css := (@css E E B B X X). + Notation cssim := (@cssim E E B B X X). (*| Various results on reflexivity and transitivity. |*) - #[global] Instance refl_csst {LR: Reflexive L} {C: Chain (css L)}: Reflexive `C. + #[global] Instance reflexive_css {R} + (LR: Reflexive L) + (RR: Reflexive R): Reflexive (css L R). Proof. - apply Reflexive_chain; cbn; eauto 9. + cbn; eauto 10. Qed. - #[global] Instance square_csst {LT: Transitive L} {C: Chain (css L)}: Transitive `C. + #[global] Instance reflexive_chain {LR: Reflexive L} {C: Chain (css L)}: Reflexive `C. Proof. - apply Transitive_chain. - cbn. intros ????? [xy xy'] [yz yz']. - split. - - intros ?? xx'. - destruct (xy _ _ xx') as (l' & y' & yy' & ? & ?). - destruct (yz _ _ yy') as (l'' & z' & zz' & ? & ?). - eauto 8. - - intros ns. - destruct (yz' ns) as (l'' & z' & zz'). - edestruct xy' as (l' & y' & yy'); eauto. + apply Reflexive_chain; typeclasses eauto. Qed. - (*| PreOrder |*) - #[global] Instance PreOrder_csst {LPO: PreOrder L} {C: Chain (css L)}: PreOrder `C. - Proof. split; typeclasses eauto. Qed. + #[global] Instance transitive_css {R} + (LT: Transitive L) + (RT: Transitive R): Transitive (css L R). + Proof. + intros x y z SS1 SS2. + play. + - play in SS1. + play in SS2. + answer. + - intros ns. + now apply SS2,SS1 in ns. + Qed. + + #[global] Instance transitive_chain {LT: Transitive L} {C: Chain (css L)}: Transitive `C. + Proof. + apply Transitive_chain; typeclasses eauto. + Qed. #[global] Instance css_ss_subrelation R : subrelation (css L R) (ss L R). Proof. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 0b90081..94bb261 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -108,22 +108,25 @@ Tactic Notation "__coinduction_ssim" simple_intropattern(r) simple_intropattern( first [unfold ssim at 4 | unfold ssim at 3 | unfold ssim at 2 | unfold ssim at 1]; coinduction r cih. #[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_ssim r cih || coinduction r cih. -Ltac __play_ssim := step; cbn; intros ? ? ?TR. +Ltac __play_ssim := (try step); cbn; intros ? ? ?TR. Ltac __play_ssim_in H := - step in H; + (try step in H); cbn in H; edestruct H as (? & ? & ?TR & ?SS & ?HL); clear H; [etrans |]; fold_ssim. Ltac __eplay_ssim := match goal with - | h : @ssim ?E ?F ?C ?D ?X ?Y ?L ?u ?v |- _ => - __play_ssim_in h + | h : ssim ?L ?u ?v |- _ => __play_ssim_in h + | h : body (ss ?L) ?R ?u ?v |- _ => __play_ssim_in h end. +Ltac __answer_ssim := ex2; split3; etrans. + #[local] Tactic Notation "play" := __play_ssim. #[local] Tactic Notation "play" "in" ident(H) := __play_ssim_in H. #[local] Tactic Notation "eplay" := __eplay_ssim. +#[local] Tactic Notation "answer" := __answer_ssim. Section ssim_homogenous_theory. Context {E B: Type -> Type} {X: Type} @@ -131,24 +134,37 @@ Section ssim_homogenous_theory. Notation ss := (@ss E E B B X X). - #[global] Instance refl_sst {LR: Reflexive L} {C: Chain (ss L)}: Reflexive `C. + #[global] Instance reflexive_ss {R} + (LR: Reflexive L) + (RR: Reflexive R): Reflexive (ss L R). + Proof. + cbn; eauto 10. + Qed. + + #[global] Instance reflexive_chain {LR: Reflexive L} {C: Chain (ss L)}: Reflexive `C. Proof. - apply Reflexive_chain. - cbn; eauto. + apply Reflexive_chain; typeclasses eauto. Qed. - #[global] Instance square_sst {LT: Transitive L} {C: Chain (ss L)}: Transitive `C. + #[global] Instance transitive_ss {R} + (LT: Transitive L) + (RT: Transitive R): Transitive (ss L R). + Proof. + intros x y z SS1 SS2. + play. + play in SS1. + play in SS2. + answer. + Qed. + + #[global] Instance transitive_chain {LT: Transitive L} {C: Chain (ss L)}: Transitive `C. Proof. apply Transitive_chain. - cbn. intros ????? xy yz. - intros ?? xx'. - destruct (xy _ _ xx') as (l' & y' & yy' & ? & ?). - destruct (yz _ _ yy') as (l'' & z' & zz' & ? & ?). - eauto 8. + typeclasses eauto. Qed. (*| PreOrder |*) - #[global] Instance PreOrder_sst {LPO: PreOrder L} {C: Chain (ss L)}: PreOrder `C. + #[global] Instance PreOrder_chain {LPO: PreOrder L} {C: Chain (ss L)}: PreOrder `C. Proof. split; typeclasses eauto. Qed. End ssim_homogenous_theory. From 302f8c2cf3c2334e11e77fb5e099f87489abbaea Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 7 Nov 2025 10:28:47 +0100 Subject: [PATCH 21/61] equivalence upto for sb --- theories/Eq/SBisim.v | 341 +++++++++++++++++++++++++------------------ 1 file changed, 195 insertions(+), 146 deletions(-) diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim.v index 8eb2466..86308aa 100644 --- a/theories/Eq/SBisim.v +++ b/theories/Eq/SBisim.v @@ -100,6 +100,7 @@ Proof. cbn; intros; apply EQR. Qed. + Lemma equiv_flipL {E F X Y} (L L' : lrel E F X Y): build_rel L == build_rel L' -> build_rel (flipL L) == build_rel (flipL L'). @@ -120,6 +121,43 @@ Proof. assert (HL: L' (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. Qed. +#[global] Instance flipL_reflexive {E X} (L : lrel E E X X) {LR: Reflexive L} : Reflexive (flipL L). +Proof. + intros ?. + now apply flipL_flip. +Qed. + +#[global] Instance flipL_symmetric {E X} (L : lrel E E X X) {LR: Symmetric L} : Symmetric (flipL L). +Proof. + intros l l' HL. + apply flipL_flip. + apply (flipL_flip L) in HL. + now apply LR. +Qed. + +#[global] Instance flipL_transitive {E X} (L : lrel E E X X) {LR: Transitive L} : Transitive (flipL L). +Proof. + intros l1 l2 l3 HL1 HL2. + apply flipL_flip. + apply (flipL_flip L) in HL1,HL2. + etransitivity; eauto. +Qed. + +#[global] Instance flipL_equivalence {E X} (L : lrel E E X X) {LR: Equivalence L} : Equivalence (flipL L). +Proof. + split; typeclasses eauto. +Qed. + +#[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). +Proof. + intros l l' HL. + unfold Lvrel in *. + dependent induction HL; constructor; cbn in *. + dependent induction HR; constructor. + dependent induction HR; constructor. + now apply H. +Qed. + Section StrongBisim. Context {E F C D : Type -> Type} {X Y : Type}. @@ -168,16 +206,6 @@ End SBisimNotations. Import SBisimNotations. -#[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). -Proof. - intros l l' HL. - unfold Lvrel in *. - dependent induction HL; constructor; cbn in *. - dependent induction HR; constructor. - dependent induction HR; constructor. - now apply H. -Qed. - (* This instance allows to use the symmetric tactic from coq-coinduction for homogeneous bisimulations *) #[global] Instance sbisim_sym {E C X L} : @@ -203,7 +231,6 @@ Proof. now symmetry. Qed. - Ltac fold_sbisim := repeat match goal with @@ -234,6 +261,163 @@ Tactic Notation "__coinduction_sbisim" simple_intropattern(r) simple_intropatter #[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_sbisim r cih || __coinduction_cssim r cih || __coinduction_ssim r cih || coinduction r cih. +Ltac __play_sbisim := (try step); split; cbn; intros ? ? ?TR. + +Ltac __playL_sbisim H := + (try step in H); + let Hf := fresh "Hf" in + destruct H as [Hf _]; + cbn in Hf; edestruct Hf as (? & ? & ?TR & ?EQ & ?); + clear Hf; subst; [etrans |]. + +Ltac __eplayL_sbisim := + match goal with + | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => + __playL_sbisim h + | h : body (sb ?L) ?R _ _ |- _ => + __playL_sbisim h + end. + +Ltac __playR_sbisim H := + try (step in H); + let Hb := fresh "Hb" in + destruct H as [_ Hb]; + cbn in Hb; edestruct Hb as (? & ? & ?TR & ?EQ & ?); + clear Hb; subst; [etrans |]. + +Ltac __eplayR_sbisim := + match goal with + | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => + __playR_sbisim h + | h : body (sb ?L) ?R _ _ |- _ => + __playR_sbisim h + end. + +Ltac __answer_sbisim := ex2; split3; etrans. + +#[local] Tactic Notation "play" := __play_sbisim. +#[local] Tactic Notation "playL" "in" ident(H) := __playL_sbisim H. +#[local] Tactic Notation "playR" "in" ident(H) := __playR_sbisim H. +#[local] Tactic Notation "play" "in" ident(H) := first [playL in H; [] | playR in H; []]. +#[local] Tactic Notation "eplayL" := __eplayL_sbisim. +#[local] Tactic Notation "eplayR" := __eplayR_sbisim. +#[local] Tactic Notation "eplay" := first [eplayL; [] | eplayR; []]. +#[local] Tactic Notation "answer" := __answer_sbisim. + +Section sbisim_homogenous_theory. + Context {E B: Type -> Type} {X: Type} {L: lrel E E X X}. + + Notation sb := (@sb E E B B X X). + + #[global] Instance reflexive_sb {R} + (LR: Reflexive L) + (RR: Reflexive R): Reflexive (sb L R). + Proof. + split. reflexivity. + cbn; eauto 10. + Qed. + + #[global] Instance reflexive_chain {LR: Reflexive L} {C: Chain (sb L)}: Reflexive `C. + Proof. + apply Reflexive_chain; typeclasses eauto. + Qed. + + #[global] Instance symmetric_sb {R} + (LS : Symmetric L) + (RS : Symmetric R) : + Symmetric (sb L R). + Proof. + intros u v SB. + play; eplay. + answer; now apply flipL_flip. + answer; now apply flipL_flip. + Qed. + + #[global] Instance symmetric_chain {LR: Symmetric L} {C: Chain (sb L)}: Symmetric `C. + Proof. + apply Symmetric_chain; typeclasses eauto. + Qed. + + #[global] Instance transitive_sb {R} + (LT: Transitive L) + (RT: Transitive R): Transitive (sb L R). + Proof. + intros x y z SS1 SS2. + play. + - play in SS1; play in SS2; answer. + - play in SS2; play in SS1; answer. + apply (flipL_flip L) in H,H0; apply flipL_flip; cbn in *; eauto. + Qed. + + #[global] Instance transitive_chain {LT: Transitive L} {C: Chain (sb L)}: Transitive `C. + Proof. + apply Transitive_chain; typeclasses eauto. + Qed. + + (*| Equivalence |*) + #[global] Instance equivalence_sb {R} + (LE : Equivalence L) + (RE : Equivalence R) : Equivalence (sb L R). + Proof. split; typeclasses eauto. Qed. + + #[global] Instance equivalence_chain {LE: Equivalence L} {C: Chain (sb L)}: Equivalence `C. + Proof. split; typeclasses eauto. Qed. + +End sbisim_homogenous_theory. + + +Section Homogeneous. + + Context {E C: Type -> Type} {X: Type} + {L: rel (@label E) (@label E)}. + Notation ss := (@ss E E C C X X). + Notation ssim := (@ssim E E C C X X). + + #[global] Instance sbisim_clos_ssim_goal `{Symmetric _ L} `{Transitive _ L} : + Proper (sbisim L ==> sbisim L ==> flip impl) (ssim L). + Proof. + repeat intro. + transitivity y0. transitivity y. + - now apply sbisim_ssim_subrelation in H1. + - now exact H3. + - symmetry in H2; now apply sbisim_ssim_subrelation in H2. + Qed. + + #[global] Instance sbisim_clos_ssim_ctx `{Equivalence _ L}: + Proper (sbisim L ==> sbisim L ==> impl) (ssim L). + Proof. + repeat intro. symmetry in H0, H1. eapply sbisim_clos_ssim_goal; eauto. + Qed. + +End Homogeneous. + +(*| +Hence [equ eq] is a included in [sbisim] +|*) + #[global] Instance equ_sbisim_subrelation `{EqL: Equivalence _ L} : subrelation (equ eq) (sbisim L). + Proof. + red; intros. + rewrite H; reflexivity. + Qed. + + #[global] Instance is_stuck_sbisim : Proper (sbisim L ==> flip impl) is_stuck. + Proof. + cbn. intros ???????. + step in H. destruct H as [? _]. + apply H in H1 as (? & ? & ? & ? & ?). now apply H0 in H1. + Qed. + + #[global] Instance sbisim_cssim_subrelation : subrelation (sbisim L) (cssim L). + Proof. + red; apply sbisim_cssim_subrelation_gen. + Qed. + + #[global] Instance sbisim_ssim_subrelation : subrelation (sbisim L) (ssim L). + Proof. + red; apply sbisim_ssim_subrelation_gen. + Qed. + + (*| This section should describe lemmas proved for the heterogenous version of `css`, parametric on @@ -381,82 +565,6 @@ stuck ctrees can be simulated by anything. End sbisim_heterogenous_theory. -Section sbisim_homogenous_theory. - Context {E B: Type -> Type} {X: Type} (L: relation (@label E)). - - Notation sb := (@sb E E B B X X). - Notation sbisim := (@sbisim E E B B X X). - - #[global] Instance refl_sb {LR: Reflexive L} {C: Chain (sb L)}: Reflexive `C. - Proof. - apply Reflexive_chain. - cbn; intros; split; intros * TR; do 2 eexists; eauto. - Qed. - - #[global] Instance sb_sym {R} : - Symmetric L -> - Symmetric R -> - Symmetric (sb L R). - Proof. - intros SYM SYM'. split; cbn; intros. - - destruct H as [_ ?]. cbn in H. - apply H in H0 as (? & ? & ? & ? & ?). eauto 7. - - destruct H as [? _]. cbn in H. - apply H in H0 as (? & ? & ? & ? & ?). eauto 7. - Qed. - - #[global] Instance sym_sb {LT: Symmetric L} {C: Chain (sb L)}: Symmetric `C. - Proof. - apply Symmetric_chain. - cbn; intros * HS * [fwd bwd]; split; intros ?? TR. - - destruct (bwd _ _ TR) as (l' & y' & yy' & ? & ?); eauto 8. - - destruct (fwd _ _ TR) as (l' & y' & yy' & ? & ?); eauto 8. - Qed. - - #[global] Instance square_sb {LT: Transitive L} {C: Chain (sb L)}: Transitive `C. - Proof. - apply Transitive_chain. - cbn. intros ????? [xy xy'] [yz yz']; split; intros ?? xx'. - - destruct (xy _ _ xx') as (l' & y' & yy' & ? & ?). - destruct (yz _ _ yy') as (l'' & z' & zz' & ? & ?). - eauto 8. - - destruct (yz' _ _ xx') as (l' & y' & yy' & ? & ?). - destruct (xy' _ _ yy') as (l'' & z' & zz' & ? & ?). - eauto 8. - Qed. - -(*| PreOrder |*) - #[global] Instance Equivalence_sb {LPO: Equivalence L} {C: Chain (sb L)}: Equivalence `C. - Proof. split; typeclasses eauto. Qed. - -(*| -Hence [equ eq] is a included in [sbisim] -|*) - #[global] Instance equ_sbisim_subrelation `{EqL: Equivalence _ L} : subrelation (equ eq) (sbisim L). - Proof. - red; intros. - rewrite H; reflexivity. - Qed. - - #[global] Instance is_stuck_sbisim : Proper (sbisim L ==> flip impl) is_stuck. - Proof. - cbn. intros ???????. - step in H. destruct H as [? _]. - apply H in H1 as (? & ? & ? & ? & ?). now apply H0 in H1. - Qed. - - #[global] Instance sbisim_cssim_subrelation : subrelation (sbisim L) (cssim L). - Proof. - red; apply sbisim_cssim_subrelation_gen. - Qed. - - #[global] Instance sbisim_ssim_subrelation : subrelation (sbisim L) (ssim L). - Proof. - red; apply sbisim_ssim_subrelation_gen. - Qed. - -End sbisim_homogenous_theory. - (*| Up-to [bind] context bisimulations ---------------------------------- @@ -684,40 +792,6 @@ Proof. intros. eapply vis_chain_gen with (left := fun x => x) (right := fun x => x); auto. Qed. -Ltac __play_sbisim := step; split; cbn; intros ? ? ?TR. - -Ltac __playL_sbisim H := - step in H; - let Hf := fresh "Hf" in - destruct H as [Hf _]; - cbn in Hf; edestruct Hf as (? & ? & ?TR & ?EQ & ?); - clear Hf; subst; [etrans |]. - -Ltac __eplayL_sbisim := - match goal with - | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => - __playL_sbisim h - end. - -Ltac __playR_sbisim H := - step in H; - let Hb := fresh "Hb" in - destruct H as [_ Hb]; - cbn in Hb; edestruct Hb as (? & ? & ?TR & ?EQ & ?); - clear Hb; subst; [etrans |]. - -Ltac __eplayR_sbisim := - match goal with - | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => - __playR_sbisim h - end. - -#[local] Tactic Notation "play" := __play_sbisim. -#[local] Tactic Notation "playL" "in" ident(H) := __playL_sbisim H. -#[local] Tactic Notation "playR" "in" ident(H) := __playR_sbisim H. -#[local] Tactic Notation "eplayL" := __eplayL_sbisim. -#[local] Tactic Notation "eplayR" := __eplayR_sbisim. - (*| Proof rules for [~] @@ -1656,31 +1730,6 @@ Section StrongSimulations. End Heterogeneous. - Section Homogeneous. - - Context {E C: Type -> Type} {X: Type} - {L: rel (@label E) (@label E)}. - Notation ss := (@ss E E C C X X). - Notation ssim := (@ssim E E C C X X). - - #[global] Instance sbisim_clos_ssim_goal `{Symmetric _ L} `{Transitive _ L} : - Proper (sbisim L ==> sbisim L ==> flip impl) (ssim L). - Proof. - repeat intro. - transitivity y0. transitivity y. - - now apply sbisim_ssim_subrelation in H1. - - now exact H3. - - symmetry in H2; now apply sbisim_ssim_subrelation in H2. - Qed. - - #[global] Instance sbisim_clos_ssim_ctx `{Equivalence _ L}: - Proper (sbisim L ==> sbisim L ==> impl) (ssim L). - Proof. - repeat intro. symmetry in H0, H1. eapply sbisim_clos_ssim_goal; eauto. - Qed. - - End Homogeneous. - Section two_ss_is_not_sb. Lemma split_sb_eq : forall {E C X} RR From 0258802b270810abee16e81e20db6b9c28bc052e Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 14 Nov 2025 09:16:38 +0100 Subject: [PATCH 22/61] Parameterization of Seq by a value relation --- theories/Eq/SBisim.v | 145 +++++++------------------- theories/Eq/SSim.v | 6 +- theories/Eq/Trans.v | 241 ++++++++++++++++++++++++++++++------------- 3 files changed, 211 insertions(+), 181 deletions(-) diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim.v index 86308aa..640e953 100644 --- a/theories/Eq/SBisim.v +++ b/theories/Eq/SBisim.v @@ -78,86 +78,6 @@ Relation relaxing [equ] to become insensitive to: - the particular branches taken during (any kind of) brs. |*) -Definition flipL {E F X Y} (L : lrel E F X Y) : lrel F E Y X := - {| RR := flip (RR L) ; - Rask := fun X Y => flip (@Rask _ _ _ _ L Y X) ; - Rrcv := fun X Y f e => flip (Rrcv L e f) |}. - -Lemma flipL_flip {E F X Y} (L : lrel E F X Y) : - build_rel (flipL L) == flip (build_rel L). -Proof. - intros f e; split; cbn; intros []; constructor; auto. -Qed. - -Lemma lequiv_flipL {E F X Y} (L L' : lrel E F X Y): - lequiv L L' -> - lequiv (flipL L) (flipL L'). -Proof. - intros (EQV & EQA & EQR). - split3. - cbn; intros; apply EQV. - cbn; intros; apply EQA. - cbn; intros; apply EQR. -Qed. - - -Lemma equiv_flipL {E F X Y} (L L' : lrel E F X Y): - build_rel L == build_rel L' -> - build_rel (flipL L) == build_rel (flipL L'). -Proof. - intros EQ e f; specialize (EQ f e); cbn in *. - split. - - destruct EQ as [EQ _]. - intros FL; dependent induction FL; constructor. - cbn in *. - assert (HL: L (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. - assert (HL: L (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. - assert (HL: L (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. - - destruct EQ as [_ EQ]. - intros FL; dependent induction FL; constructor. - cbn in *. - assert (HL: L' (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. - assert (HL: L' (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. - assert (HL: L' (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. -Qed. - -#[global] Instance flipL_reflexive {E X} (L : lrel E E X X) {LR: Reflexive L} : Reflexive (flipL L). -Proof. - intros ?. - now apply flipL_flip. -Qed. - -#[global] Instance flipL_symmetric {E X} (L : lrel E E X X) {LR: Symmetric L} : Symmetric (flipL L). -Proof. - intros l l' HL. - apply flipL_flip. - apply (flipL_flip L) in HL. - now apply LR. -Qed. - -#[global] Instance flipL_transitive {E X} (L : lrel E E X X) {LR: Transitive L} : Transitive (flipL L). -Proof. - intros l1 l2 l3 HL1 HL2. - apply flipL_flip. - apply (flipL_flip L) in HL1,HL2. - etransitivity; eauto. -Qed. - -#[global] Instance flipL_equivalence {E X} (L : lrel E E X X) {LR: Equivalence L} : Equivalence (flipL L). -Proof. - split; typeclasses eauto. -Qed. - -#[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). -Proof. - intros l l' HL. - unfold Lvrel in *. - dependent induction HL; constructor; cbn in *. - dependent induction HR; constructor. - dependent induction HR; constructor. - now apply H. -Qed. - Section StrongBisim. Context {E F C D : Type -> Type} {X Y : Type}. @@ -365,36 +285,47 @@ Section sbisim_homogenous_theory. End sbisim_homogenous_theory. - -Section Homogeneous. - - Context {E C: Type -> Type} {X: Type} - {L: rel (@label E) (@label E)}. - Notation ss := (@ss E E C C X X). - Notation ssim := (@ssim E E C C X X). - - #[global] Instance sbisim_clos_ssim_goal `{Symmetric _ L} `{Transitive _ L} : - Proper (sbisim L ==> sbisim L ==> flip impl) (ssim L). - Proof. - repeat intro. - transitivity y0. transitivity y. - - now apply sbisim_ssim_subrelation in H1. - - now exact H3. - - symmetry in H2; now apply sbisim_ssim_subrelation in H2. - Qed. - - #[global] Instance sbisim_clos_ssim_ctx `{Equivalence _ L}: - Proper (sbisim L ==> sbisim L ==> impl) (ssim L). - Proof. - repeat intro. symmetry in H0, H1. eapply sbisim_clos_ssim_goal; eauto. - Qed. - -End Homogeneous. - +(* Section Homogeneous. *) + +(* Context {E C: Type -> Type} {X: Type} *) +(* {L: rel (@label E) (@label E)}. *) +(* Notation ss := (@ss E E C C X X). *) +(* Notation ssim := (@ssim E E C C X X). *) + +(* #[global] Instance sbisim_clos_ssim_goal `{Symmetric _ L} `{Transitive _ L} : *) +(* Proper (sbisim L ==> sbisim L ==> flip impl) (ssim L). *) +(* Proof. *) +(* repeat intro. *) +(* transitivity y0. transitivity y. *) +(* - now apply sbisim_ssim_subrelation in H1. *) +(* - now exact H3. *) +(* - symmetry in H2; now apply sbisim_ssim_subrelation in H2. *) +(* Qed. *) + +(* #[global] Instance sbisim_clos_ssim_ctx `{Equivalence _ L}: *) +(* Proper (sbisim L ==> sbisim L ==> impl) (ssim L). *) +(* Proof. *) +(* repeat intro. symmetry in H0, H1. eapply sbisim_clos_ssim_goal; eauto. *) +(* Qed. *) + +(* End Homogeneous. *) + +Section VRel. + Context {E B: Type -> Type} {X Y: Type} {RR: rel X Y}. (*| Hence [equ eq] is a included in [sbisim] |*) - #[global] Instance equ_sbisim_subrelation `{EqL: Equivalence _ L} : subrelation (equ eq) (sbisim L). + +(* TODO: Generalize SEQ to take a relation on values as argument *) +Lemma foo u v : + SeqR RR u v -> + @sbisim E E B B X Y (Lvrel RR) u v. +Proof. + intros SEQ. + dependent induction SEQ. + - rewrite EQ. + +#[global] Instance equ_sbisim_subrelation {X Y} (RR : rel X Y) : subrelation (SeqR RR) (sbisim (Lvrel RR)). Proof. red; intros. rewrite H; reflexivity. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 94bb261..52226bc 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -60,6 +60,7 @@ End StrongSim. Definition ssim {E F C D X Y} L := (gfp (@ss E F C D X Y L): hrel _ _). +(* TODO : TESTER LVREL COERCION *) Module SSimNotations. Infix "≲" := (ssim Leq) (at level 70). @@ -186,7 +187,7 @@ Section ssim_heterogenous_theory. coinduction R cih. intros u v HSS l u' TR. eplay. - ex2; split3; etrans. + answer. eapply sub_lrel_subrel; eauto. Qed. @@ -197,6 +198,7 @@ Section ssim_heterogenous_theory. ---------------------------------------- |*) + (* Can this be rewritten with a simpler proper? *) Lemma equ_clos_chain {c: Chain (ss L)}: forall x y, equ_clos `c x y -> `c x y. Proof. @@ -555,6 +557,8 @@ Note: the general formulation (over any well-behaved realtion rather than elemen transition system, stepping is hence symmetric and we can just recover the itree-style rule. |*) + (* TODO: specialization to Lvrel *) + Lemma ss_vis {Z Z'} (e : E Z) (f: F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L {R : Chain (@ss E F C D X Y L)} diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index defd53b..f689db1 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -69,30 +69,36 @@ Set Primitive Projections. .. coq:: |*) +Variant S E B R := + | Active (t : ctree E B R) + | Passive {X} (e : E X) (k : X -> ctree E B R). + +Variant SeqR {E B X Y} (RR : hrel X Y) : S E B X -> S E B Y -> Prop := + | ActAct t u (EQ: equ RR t u) : SeqR RR (Active t) (Active u) + | PasPas {A} e (k g : A -> _) (EQ: forall a, equ RR (k a) (g a)) : SeqR RR (Passive e k) (Passive e g) +. +Hint Constructors SeqR : core. +Definition Seq {E B X} := (@SeqR E B X X eq). +Hint Unfold Seq : core. + +#[global] Instance SeqR_equiv {E B R} {RR : rel R R} {RE: Equivalence RR}: Equivalence (@SeqR E B R R RR). +Proof. + constructor. + - intros []; auto. + - intros ? ? []; constructor; intros; now symmetry. + - intros ? ? ? EQ1 EQ2. + inv EQ1. + inv EQ2; constructor; intros; etransitivity; eauto. + dependent induction EQ2; constructor; intros; etransitivity; eauto. +Qed. +Arguments Active {E B R}. +Arguments Passive {E B R X} e k. + Section Trans. Context {E B : Type -> Type} {R : Type}. - - Variant S := - | Active (t : ctree E B R) - | Passive {X} (e : E X) (k : X -> ctree E B R). - (* Notation S' := (ctree' E B R). *) - (* Notation S := (ctree E B R). *) - Variant Seq : S -> S -> Prop := - | ActAct t u (EQ: equ eq t u) : Seq (Active t) (Active u) - | PasPas {X} e (k g : X -> _) (EQ: pointwise_relation _ (equ eq) k g) : Seq (Passive e k) (Passive e g) - . - Hint Constructors Seq : core. - #[global] Instance Seq_equiv : Equivalence Seq. - Proof. - constructor. - - intros []; auto. - - intros ? ? []; constructor; intros; now symmetry. - - intros ? ? ? EQ1 EQ2. - inv EQ1. - inv EQ2; constructor; intros; etransitivity; eauto. - dependent induction EQ2; constructor; intros; etransitivity; eauto. - Qed. + Notation S := (S E B R). + Notation Seq := (@Seq E B R). Definition SS : EqType := {| type_of := S ; Eq := Seq |}. @@ -168,7 +174,7 @@ node, labelling the transition by the returned value. u ≅ Stuck -> transR (val r) (Active t) (Active u). Hint Constructors transR : core. - + #[global] Instance equ_Seq_active : Proper (equ eq ==> Seq) Active. Proof. now intros ?? EQ; constructor. @@ -247,7 +253,19 @@ library. Proof. intros ? ? eqt ? ? equ. inv eqt; inv equ. - all: now rewrite EQ, EQ0. + now rewrite EQ,EQ0. + rewrite EQ. + all: try now rewrite EQ, EQ0. + assert (H: Seq (Passive e k) (Passive e g)) + by (apply equ_Seq_passive; red; apply EQ0); now rewrite H. + rewrite EQ0. + assert (H: Seq (Passive e k) (Passive e g)) + by (apply equ_Seq_passive; red; apply EQ); now rewrite H. + assert (H1: Seq (Passive e k) (Passive e g)) + by (apply equ_Seq_passive; red; apply EQ); + assert (H2: Seq (Passive e0 k0) (Passive e0 g0)) + by (apply equ_Seq_passive; red; apply EQ0); + now rewrite H1,H2. Qed. Definition trans l : srel SS SS := {| hrel_of := transR l : hrel SS SS |}. @@ -388,7 +406,6 @@ End Trans. Arguments label : clear implicits. #[global] Infix "⩸" := Seq (at level 10). -#[global] Hint Constructors Seq : core. #[global] Hint Constructors transR : core. Ltac rem_weak_ t s := @@ -400,24 +417,24 @@ Ltac rem_weak_ t s := Tactic Notation "rem_weak" constr(t) "as" ident(s) := rem_weak_ t s. -Class Respects_val {E F} (L : rel (@label E) (@label F)) := - { respects_val: - forall l l', - L l l' -> - is_val l <-> is_val l' }. +(* Class Respects_val {E F} (L : rel (@label E) (@label F)) := *) +(* { respects_val: *) +(* forall l l', *) +(* L l l' -> *) +(* is_val l <-> is_val l' }. *) -Class Respects_τ {E F} (L : rel (@label E) (@label F)) := - { respects_τ: forall l l', - L l l' -> - l = τ <-> l' = τ }. +(* Class Respects_τ {E F} (L : rel (@label E) (@label F)) := *) +(* { respects_τ: forall l l', *) +(* L l l' -> *) +(* l = τ <-> l' = τ }. *) -#[global] Instance Respects_val_eq A: @Respects_val A A eq. -split; intros; subst; reflexivity. -Defined. +(* #[global] Instance Respects_val_eq A: @Respects_val A A eq. *) +(* split; intros; subst; reflexivity. *) +(* Defined. *) -#[global] Instance Respects_τ_eq A: @Respects_τ A A eq. -split; intros; subst; reflexivity. -Defined. +(* #[global] Instance Respects_τ_eq A: @Respects_τ A A eq. *) +(* split; intros; subst; reflexivity. *) +(* Defined. *) Coercion Active : ctree >-> S. Notation "'α' t" := (Active t) (at level 100). @@ -712,7 +729,7 @@ Structural rules Lemma trans_vis_inv : forall {Y} (e : E Y) k l (u : ctree E B X), trans l (Vis e k) u -> - Seq u (β e k) /\ l = ask e. + False. Proof. intros * TR. inv TR; inv_equ. @@ -1061,14 +1078,14 @@ Section stuck. intros * ST TR. destruct TR as [? [? ?] ?]. apply transs_is_stuck_inv' in H; auto. + rewrite H in ST. inv H. - - rewrite EQ in ST; apply etrans_is_stuck_inv' in H0 as [-> ?]; auto. + - apply etrans_is_stuck_inv' in H0 as [-> ?]; auto. inv H. rewrite EQ0 in ST; apply transs_is_stuck_inv' in H1; auto. intuition. rewrite EQ, EQ0; auto. - - rewrite EQ in ST. - pose proof etrans_is_stuck_inv' _ _ ST H0 as [-> ?]; auto. + - pose proof etrans_is_stuck_inv' _ _ ST H0 as [-> ?]; auto. split; auto. rewrite <-H in H1. apply transs_τ_passive in H1. @@ -2043,38 +2060,38 @@ Proof. eapply trans_br; eauto. Qed. -(*| -[wf_val] states that a [label] is well-formed: -if it is a [val] it should be of the right type. -|*) -Definition wf_val {E} X l := forall Y (v : Y), l = @val E Y v -> X = Y. +(* (*| *) +(* [wf_val] states that a [label] is well-formed: *) +(* if it is a [val] it should be of the right type. *) +(* |*) *) +(* Definition wf_val {E} X l := forall Y (v : Y), l = @val E Y v -> X = Y. *) -Lemma wf_val_val {E} X (v : X) : wf_val X (@val E X v). -Proof. - red. intros. apply val_eq_invT in H. assumption. -Qed. +(* Lemma wf_val_val {E} X (v : X) : wf_val X (@val E X v). *) +(* Proof. *) +(* red. intros. apply val_eq_invT in H. assumption. *) +(* Qed. *) -Lemma wf_val_nonval {E} X (l : @label E) : ~is_val l -> wf_val X l. -Proof. - red. intros. subst. exfalso. apply H. constructor. -Qed. +(* Lemma wf_val_nonval {E} X (l : @label E) : ~is_val l -> wf_val X l. *) +(* Proof. *) +(* red. intros. subst. exfalso. apply H. constructor. *) +(* Qed. *) -Lemma wf_val_trans {E B X} (l : @label E) t t' : - @trans E B X l t t' -> wf_val X l. -Proof. - red. intros. subst. - now apply trans_val_invT in H. -Qed. +(* Lemma wf_val_trans {E B X} (l : @label E) t t' : *) +(* @trans E B X l t t' -> wf_val X l. *) +(* Proof. *) +(* red. intros. subst. *) +(* now apply trans_val_invT in H. *) +(* Qed. *) -Lemma wf_val_is_val_inv : forall {E} X (l : @label E), - is_val l -> - wf_val (E := E) X l -> - exists (x : X), l = val x. -Proof. - intros. - destruct H. red in H0. - specialize (H0 X0 x eq_refl). subst. eauto. -Qed. +(* Lemma wf_val_is_val_inv : forall {E} X (l : @label E), *) +(* is_val l -> *) +(* wf_val (E := E) X l -> *) +(* exists (x : X), l = val x. *) +(* Proof. *) +(* intros. *) +(* destruct H. red in H0. *) +(* specialize (H0 X0 x eq_refl). subst. eauto. *) +(* Qed. *) (* (*| If the LTS has events of type [L +' R] then *) (* it is possible to step it as either an [L] LTS *) @@ -2250,8 +2267,7 @@ Create HintDb trans. #[global] Hint Resolve is_val_τ is_val_ask - is_val_rcv - wf_val_val wf_val_nonval wf_val_trans : trans. + is_val_rcv : trans. Ltac etrans := eauto with trans. #[global] Arguments trans : simpl never. @@ -2393,3 +2409,82 @@ Proof. now constructor; apply SUB1. Qed. +Definition flipL {E F X Y} (L : lrel E F X Y) : lrel F E Y X := + {| RR := flip (RR L) ; + Rask := fun X Y => flip (@Rask _ _ _ _ L Y X) ; + Rrcv := fun X Y f e => flip (Rrcv L e f) |}. + +Lemma flipL_flip {E F X Y} (L : lrel E F X Y) : + build_rel (flipL L) == flip (build_rel L). +Proof. + intros f e; split; cbn; intros []; constructor; auto. +Qed. + +Lemma lequiv_flipL {E F X Y} (L L' : lrel E F X Y): + lequiv L L' -> + lequiv (flipL L) (flipL L'). +Proof. + intros (EQV & EQA & EQR). + split3. + cbn; intros; apply EQV. + cbn; intros; apply EQA. + cbn; intros; apply EQR. +Qed. + +Lemma equiv_flipL {E F X Y} (L L' : lrel E F X Y): + build_rel L == build_rel L' -> + build_rel (flipL L) == build_rel (flipL L'). +Proof. + intros EQ e f; specialize (EQ f e); cbn in *. + split. + - destruct EQ as [EQ _]. + intros FL; dependent induction FL; constructor. + cbn in *. + assert (HL: L (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + - destruct EQ as [_ EQ]. + intros FL; dependent induction FL; constructor. + cbn in *. + assert (HL: L' (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L' (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L' (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. +Qed. + +#[global] Instance flipL_reflexive {E X} (L : lrel E E X X) {LR: Reflexive L} : Reflexive (flipL L). +Proof. + intros ?. + now apply flipL_flip. +Qed. + +#[global] Instance flipL_symmetric {E X} (L : lrel E E X X) {LR: Symmetric L} : Symmetric (flipL L). +Proof. + intros l l' HL. + apply flipL_flip. + apply (flipL_flip L) in HL. + now apply LR. +Qed. + +#[global] Instance flipL_transitive {E X} (L : lrel E E X X) {LR: Transitive L} : Transitive (flipL L). +Proof. + intros l1 l2 l3 HL1 HL2. + apply flipL_flip. + apply (flipL_flip L) in HL1,HL2. + etransitivity; eauto. +Qed. + +#[global] Instance flipL_equivalence {E X} (L : lrel E E X X) {LR: Equivalence L} : Equivalence (flipL L). +Proof. + split; typeclasses eauto. +Qed. + +#[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). +Proof. + intros l l' HL. + unfold Lvrel in *. + dependent induction HL; constructor; cbn in *. + dependent induction HR; constructor. + dependent induction HR; constructor. + now apply H. +Qed. + From 827651761de6f4f8b1a34b8dbc11b80717de0b95 Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 15 Apr 2026 18:10:24 +0200 Subject: [PATCH 23/61] WIP --- theories/CTree.v | 4 +- theories/Core/CTreeDefinitions.v | 2 +- theories/Core/Index.v | 2 +- theories/Eq/CSSim.v | 165 +++- theories/Eq/Equ.v | 127 ++- theories/Eq/SBisim_draft.v | 1433 ++++++++++++++++++++++++++++ theories/Eq/SSim.v | 125 ++- theories/Eq/Trans.v | 125 ++- theories/{Core => Utils}/Utils.v | 5 +- theories/Utils/coinduction_addon.v | 34 + 10 files changed, 1875 insertions(+), 147 deletions(-) create mode 100644 theories/Eq/SBisim_draft.v rename theories/{Core => Utils}/Utils.v (97%) create mode 100644 theories/Utils/coinduction_addon.v diff --git a/theories/CTree.v b/theories/CTree.v index 5f02379..96ae8d7 100644 --- a/theories/CTree.v +++ b/theories/CTree.v @@ -5,8 +5,10 @@ From ITree Require Export Indexed.Function Indexed.Sum. +From CTree.Utils Require Export + Utils. + From CTree.Core Require Export - Utils Index CTreeDefinitions. diff --git a/theories/Core/CTreeDefinitions.v b/theories/Core/CTreeDefinitions.v index 39b4e79..0eb4005 100644 --- a/theories/Core/CTreeDefinitions.v +++ b/theories/Core/CTreeDefinitions.v @@ -26,7 +26,7 @@ br. From ITree Require Import Basics.Basics Core.Subevent Indexed.Sum. From CTree Require Export - Core.Utils. + Utils.Utils. From CTree Require Import Core.Index. From ExtLib Require Import diff --git a/theories/Core/Index.v b/theories/Core/Index.v index 25b6322..e367d00 100644 --- a/theories/Core/Index.v +++ b/theories/Core/Index.v @@ -1,5 +1,5 @@ From ITree Require Import Basics Indexed.Sum. -From CTree Require Import Core.Utils. +From CTree Require Import Utils.Utils. Section Index. diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index b17632a..edf5edc 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -25,10 +25,41 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. +(*| +Complete strong simulation +========================== + +[css L] refines [ss L] (from [Eq.SSim]) with a liveness-preservation +clause: the simulating side must itself be live whenever the simulated +side is: + + css L R t u ≜ ss L R t u ∧ (not_stuck u → not_stuck t) + +Its greatest fixed point is [cssim L], notated [t (⪅ L) u] (or [t ⪅ u] +with the default [Leq]). + +Because of the extra clause, [cssim] is strictly finer than [ssim]: +[cssim_ssim_subrelation] and [cssim_ssim_subrelation_gen] witness the +inclusion. Most structural rules mirror those of [ss]/[ssim] but acquire +a non-stuckness side-condition (typically [Inhabited] on a branching +type, [not_stuck] on a continuation, or a disjunction between the two +sides). Lemmas that would be false under completeness — e.g. "stuck is +simulated by anything" — are therefore absent; their sound analogues +require both sides stuck ([css_is_stuck']). + +File organisation mirrors [Eq.SSim]: definition + tactics; homogeneous +theory (Reflexive/Transitive + subrelation into [ss]/[ssim]); +heterogeneous theory with [cssim_mono], [equ_clos] up-to, and +[Seq]/[equ eq] [Proper] instances on both chain elements and [css L r]; +up-to bind; structural proof rules and inversion principles, using the +same [_gen] / [`R] / gfp naming convention as in [SSim.v]. +|*) + Section CompleteStrongSim. (*| -Complete strong simulation [css]. +[css L R t u]: both [ss L R t u] holds, and [t] is live whenever [u] is. +The second clause is what distinguishes [css] from [ss]. |*) Program Definition css {E F C D : Type -> Type} {X Y : Type} @@ -41,6 +72,21 @@ Complete strong simulation [css]. edestruct H0 as (? & ? & ? & ? & ?); repeat econstructor; eauto. Qed. + #[global] Instance lequiv_css : forall {E F C D X Y}, Proper (lequiv ==> weq) (@css E F C D X Y). + Proof. + cbn. intros * EQ *. split. + - intros [SIM PROG]; split; auto. + intros. + apply SIM in H as (? & ? & ? & ? & ?). + ex2; split3; eauto. + now rewrite <- EQ. + - intros [SIM PROG]; split; auto. + intros. + apply SIM in H as (? & ? & ? & ? & ?). + ex2; split3; eauto. + now rewrite EQ. + Qed. + End CompleteStrongSim. Definition cssim {E F C D X Y} L := @@ -117,6 +163,12 @@ Ltac __answer_cssim := ex2; split3; etrans. #[local] Tactic Notation "eplay" := __eplay_cssim. #[local] Tactic Notation "answer" := __answer_cssim. +(*| +Homogeneous theory: source and target share their signature. In addition +to reflexivity / transitivity (lifted to chain elements), we record +[css_ss_subrelation] and [cssim_ssim_subrelation], making [css]/[cssim] +usable wherever [ss]/[ssim] is expected. +|*) Section cssim_homogenous_theory. Context {E B : Type -> Type} {X : Type} @@ -203,26 +255,27 @@ Section cssim_heterogenous_theory. ---------------------------------------- |*) - Lemma equ_clos_chain {c: Chain (css L)}: - forall x y, equ_clos `c x y -> `c x y. + #[global] Instance equ_chain_goal {c: Chain (css L)} : + Proper (equ eq ==> equ eq ==> flip impl) `c. Proof. + unfold Proper, respectful,flip,impl. apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - intros a b ?? [x' y' x'' y'' EQ' [SIM LIVE]]. + - intros ? INC x y EQ x' y' EQ' ? ? ?; red. + cbn in INC. + eapply INC; eauto. + apply leq_infx in H0. + now apply H0. + - intros a b x y EQ x' y' EQ' [SIM LIVE]. split. + intros ?? tr. - rewrite EQ' in tr. + rewrite EQ in tr. edestruct SIM as (l' & ? & ? & ? & ?); eauto. exists l',x0; intuition. - rewrite <- Equu; auto. + rewrite EQ'; auto. + intros ns. - rewrite <- Equu in ns. + rewrite EQ' in ns. edestruct LIVE as (l' & ? & ?); eauto. - setoid_rewrite EQ'. eauto. + setoid_rewrite EQ. eauto. Qed. #[global] Instance seq_chain_goal {c: Chain (css L)} : @@ -257,6 +310,17 @@ Section cssim_heterogenous_theory. ex2; rewrite tt'; eauto. Qed. + #[global] Instance equ_css_goal {r} : + Proper (equ eq ==> equ eq ==> flip impl) (css L r). + Proof. + intros t t' tt' u u' uu'; cbn. + intros [? ?]; split. + - intros. + rewrite tt' in H1. apply H in H1 as (l' & ? & ? & ? & ?). + ex2; eauto. rewrite uu'. eauto. + - now rewrite tt',uu'. + Qed. + #[global] Instance seq_chain_ctx {c: Chain (css L)} : Proper (Seq ==> Seq ==> impl) `c. Proof. @@ -274,6 +338,29 @@ Section cssim_heterogenous_theory. ex2; rewrite <- EQt; eauto. Qed. + #[global] Instance equ_chain_ctx {c: Chain (css L)} : + Proper (equ eq ==> equ eq ==> impl) `c. + Proof. + unfold Proper, respectful,flip,impl. + apply tower. + - intros ? INC x y EQ x' y' EQ' ? ? ?; red. + cbn in INC. + eapply INC; eauto. + apply leq_infx in H0. + now apply H0. + - intros a b x y EQ x' y' EQ' [SIM LIVE]. + split. + + intros ?? tr. + rewrite <- EQ in tr. + edestruct SIM as (l' & ? & ? & ? & ?); eauto. + exists l',x0; intuition. + rewrite <- EQ'; auto. + + intros ns. + rewrite <- EQ' in ns. + edestruct LIVE as (l' & ? & ?); eauto. + setoid_rewrite <- EQ. eauto. + Qed. + #[global] Instance seq_css_ctx {r} : Proper (Seq ==> Seq ==> impl) (css L r). Proof. @@ -288,6 +375,15 @@ Section cssim_heterogenous_theory. ex2; rewrite <- tt'; eauto. Qed. + #[global] Instance equ_css_ctx {r} : + Proper (equ eq ==> equ eq ==> impl) (css L r). + Proof. + intros t t' tt' u u' uu'; cbn; intros [? ?]; split. + - intros; rewrite <- tt' in H1. apply H in H1 as (l' & ? & ? & ? & ?). + ex2; eauto. rewrite <- uu'. eauto. + - now rewrite <- tt', <-uu'. + Qed. + Lemma cssim_ssim_subrelation_gen : forall x y, cssim L x y -> ssim L x y. Proof. red. @@ -298,10 +394,10 @@ Section cssim_heterogenous_theory. End cssim_heterogenous_theory. -#[global] Instance weq_ssim : forall {E F C D X Y}, - Proper (lequiv ==> weq) (@ssim E F C D X Y). +#[global] Instance weq_cssim : forall {E F C D X Y}, + Proper (lequiv ==> weq) (@cssim E F C D X Y). Proof. - cbn -[ss weq]. intros. apply gfp_weq. now apply lequiv_ss. + cbn -[css weq]. intros. apply gfp_weq. now apply lequiv_css. Qed. (*| @@ -411,7 +507,6 @@ and with the argument (pointwise) on the continuation. refine_trans; ex2; eapply trans_bind_l_ask; etrans. exfalso; eapply trans_rcv_active_inv; eauto. - apply trans_val_invT in STEP' as ?. subst X0. apply trans_val_inv' in STEP' as ?. rewrite H0 in STEP'. pose proof STEP' as tmp. apply tt in tmp as (? & ? & TR & ? & ?). @@ -507,6 +602,16 @@ Proof. intros ?? <-; auto. Qed. +(*| +Structural proof rules +====================== +Same three-layer shape as in [SSim.v] ([css_*_gen] / [css_*] / [cssim_*]). +Compared to [ss]/[ssim] the rules typically carry an extra non-stuckness +side-condition: [Inhabited] on a [Br]'s index (to witness progress), +[not_stuck] on a branch, or a disjunction between the two sides. +Inversion principles ([cssim_*_inv]) additionally exploit the liveness +clause — e.g. [cssim_stuck_inv] is an *iff*, unlike its [ssim] analogue. +|*) Section Proof_Rules. Context {E F C D: Type -> Type} {X Y : Type}. @@ -546,6 +651,19 @@ Stuck ctrees can be simulated by anything. (*| Ret nodes |*) + Lemma css_ret_gen (x : X) (y : Y) L R : + R (α Stuck) (α Stuck) -> + (Proper (Seq ==> Seq ==> impl) R) -> + RR L x y -> + css L R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros HS HP HR; split; [intros l u TR |]. + - inv_trans. subst. + ex2; intuition. + now rewrite EQ. + - intros; auto using ret_not_stuck. + Qed. + Lemma css_ret (x : X) (y : Y) L {R : Chain (@css E F C D X Y L)} : RR L x y -> @@ -565,7 +683,6 @@ Ret nodes intros. step. now apply css_ret. Qed. - (*| The vis nodes are deterministic from the perspective of the labeled @@ -818,6 +935,18 @@ Invisible nodes (*| Internal transitions |*) + Lemma css_step_gen + (t: ctree E C X) (t': ctree F D Y) L R : + (Proper (Seq ==> Seq ==> impl) R) -> + R (α t) (α t') -> + css L R (Step t) (Step t'). + Proof. + intros HP HR; split; [intros ???; inv_trans; subst |]. + - ex2; intuition. + now rewrite EQ. + - intros; auto using step_not_stuck. + Qed. + Lemma css_step (t: ctree E C X) (t': ctree F D Y) L {R : Chain (@css E F C D X Y L)} : diff --git a/theories/Eq/Equ.v b/theories/Eq/Equ.v index c751531..1f6b61d 100644 --- a/theories/Eq/Equ.v +++ b/theories/Eq/Equ.v @@ -671,68 +671,99 @@ associated enhancing function. (*| Definition of the enhancing function |*) -Variant equ_clos_body {E F C D X1 X2} (R : rel (ctree E C X1) (ctree F D X2)) : (rel (ctree E C X1) (ctree F D X2)) := - | Equ_clos : forall t t' u' u - (Equt : t ≅ t') - (HR : R t' u') - (Equu : u' ≅ u), - equ_clos_body R t u. - -Program Definition equ_clos {E F C D X1 X2} : mon (rel (ctree E C X1) (ctree F D X2)) := - {| body := @equ_clos_body E F C D X1 X2 |}. -Next Obligation. - intros * ?? LE t u EQ; inv EQ. - econstructor; eauto. - apply LE; auto. -Qed. +(* Variant equ_clos_body {E F C D X1 X2} (R : rel (ctree E C X1) (ctree F D X2)) : (rel (ctree E C X1) (ctree F D X2)) := *) +(* | Equ_clos : forall t t' u' u *) +(* (Equt : t ≅ t') *) +(* (HR : R t' u') *) +(* (Equu : u' ≅ u), *) +(* equ_clos_body R t u. *) + +(* Program Definition equ_clos {E F C D X1 X2} : mon (rel (ctree E C X1) (ctree F D X2)) := *) +(* {| body := @equ_clos_body E F C D X1 X2 |}. *) +(* Next Obligation. *) +(* intros * ?? LE t u EQ; inv EQ. *) +(* econstructor; eauto. *) +(* apply LE; auto. *) +(* Qed. *) (*| Sufficient condition to prove compatibility only over the simulation |*) -Lemma equ_clos_sym {E C X} : compat converse (@equ_clos E E C C X X). -Proof. - intros R t u EQ; inv EQ. - apply Equ_clos with u' t'; intuition. -Qed. +(* Lemma equ_clos_sym {E C X} : compat converse (@equ_clos E E C C X X). *) +(* Proof. *) +(* intros R t u EQ; inv EQ. *) +(* apply Equ_clos with u' t'; intuition. *) +(* Qed. *) -Lemma equ_clos_equ {E C X L} {c: Chain (fequ L)}: - forall x y, @equ_clos E E C C X X (elem c) x y -> (elem c) x y. -Proof. - apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - clear; intros c IH ?? []. - step in Equt; step in Equu; cbn in *. - inv Equt; rewrite <- H in HR; clear H H0 t t'. - all:inv HR; rewrite <- H in Equu. - all:try now inv Equu; eauto. - inv Equu; constructor; apply IH; econstructor; eauto. - inv Equu; constructor; apply IH; econstructor; eauto. - dependent induction H1; dependent induction H2. inv Equu. - dependent induction H2; dependent induction H3. - econstructor; intros. apply IH; econstructor; eauto. - dependent induction H1; dependent induction H2. inv Equu. - dependent induction H2; dependent induction H3. - econstructor; intros. apply IH; econstructor; eauto. -Qed. +(* Lemma equ_clos_equ {E C X L} {c: Chain (fequ L)}: *) +(* forall x y, @equ_clos E E C C X X (elem c) x y -> (elem c) x y. *) +(* Proof. *) +(* apply tower. *) +(* - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. *) +(* apply INC; auto. *) +(* econstructor; eauto. *) +(* apply leq_infx in H. *) +(* now apply H. *) +(* - clear; intros c IH ?? []. *) +(* step in Equt; step in Equu; cbn in *. *) +(* inv Equt; rewrite <- H in HR; clear H H0 t t'. *) +(* all:inv HR; rewrite <- H in Equu. *) +(* all:try now inv Equu; eauto. *) +(* inv Equu; constructor; apply IH; econstructor; eauto. *) +(* inv Equu; constructor; apply IH; econstructor; eauto. *) +(* dependent induction H1; dependent induction H2. inv Equu. *) +(* dependent induction H2; dependent induction H3. *) +(* econstructor; intros. apply IH; econstructor; eauto. *) +(* dependent induction H1; dependent induction H2. inv Equu. *) +(* dependent induction H2; dependent induction H3. *) +(* econstructor; intros. apply IH; econstructor; eauto. *) +(* Qed. *) #[global] Instance equ_eq_equ_goal_gen {E C R L} (r : Chain (@fequ E C R R L)) : - Proper (equ eq ==> equ eq ==> flip impl) - (elem r). + Proper (equ eq ==> equ eq ==> flip impl) (elem r). Proof. - repeat intro. - apply equ_clos_equ; econstructor; eauto; now symmetry. + apply tower. + - intros ? INC x y EQ x' y' EQ' ???. red. + eapply INC; eauto. + apply leq_infx in H0. + now apply H0. + - clear; intros c IH ?? EQ ?? EQ' Equt. + step in EQ; step in EQ'; cbn in *. + inv EQ; rewrite <- H in Equt; clear H H0 x y. + all: inv Equt; rewrite <- H in EQ'. + all:try now inv EQ'; eauto. + inv EQ'; constructor; eapply IH; eauto. + inv EQ'; constructor; eapply IH; eauto. + dependent induction H1; dependent induction H2. inv EQ'. + dependent induction H3; dependent induction H4. + econstructor; intros. eapply IH; eauto. + dependent induction H1; dependent induction H2. inv EQ'. + dependent induction H3; dependent induction H4. + econstructor; intros. eapply IH; eauto. Qed. #[global] Instance equ_eq_equ_hyp_gen {E C R L} (r : Chain (@fequ E C R R L)) : Proper (equ eq ==> equ eq ==> impl) (elem r). Proof. - repeat intro. - apply equ_clos_equ; econstructor; [| eassumption |]; eauto; now symmetry. + apply tower. + - intros ? INC x y EQ x' y' EQ' ???. red. + eapply INC; eauto. + apply leq_infx in H0. + now apply H0. + - clear; intros c IH ?? EQ ?? EQ' Equt. + step in EQ; step in EQ'; cbn in *. + inv EQ; rewrite <- H0 in Equt; clear H H0 x y. + all: inv Equt; rewrite <- H in EQ'. + all:try now inv EQ'; eauto. + inv EQ'; constructor; eapply IH; eauto. + inv EQ'; constructor; eapply IH; eauto. + dependent induction H1; dependent induction H2. inv EQ'. + dependent induction H3; dependent induction H4. + econstructor; intros. eapply IH; eauto. + dependent induction H1; dependent induction H2. inv EQ'. + dependent induction H3; dependent induction H4. + econstructor; intros. eapply IH; eauto. Qed. Lemma equ_clo_bind_gen_eq (E B: Type -> Type) (X Y1 Y2 : Type) diff --git a/theories/Eq/SBisim_draft.v b/theories/Eq/SBisim_draft.v new file mode 100644 index 0000000..d3491fc --- /dev/null +++ b/theories/Eq/SBisim_draft.v @@ -0,0 +1,1433 @@ +(*| HS +Strong bisimilarity +=================== + +Companion to [Eq.SSim] / [Eq.CSSim]. [sb L] is the symmetric variant of +strong simulation: + + sb L R t u ≜ ss L R t u ∧ ss (flipL L) (flip R) u t + +Its greatest fixed point is [sbisim L], notated [t (σ L) u] (or [t ~ u] +with the default [eq] relation on labels). + +File organisation mirrors [Eq.SSim]: +- definition of [sb]/[sbisim], notations, folding/step/coinduction/play + tactics; +- homogeneous theory (Reflexive / Symmetric / Transitive / PreOrder / + Equivalence, both on [sb L R] and on chain elements); +- heterogeneous theory: [sbisim_mono], [equ_clos]/[sbisim_clos] up-to + principles, [Proper] instances for rewriting [Seq] and [equ eq] on + either side, subrelations to [ssim] and [cssim]; +- up-to bind; +- structural proof rules and inversion principles, using the same + [sb_*_gen] / [`R] / [sbisim_*] naming convention as [SSim.v]; +- sanity checks ([spinS], [br2], [brS2] laws) and incompatibility + lemmas; +- interaction with [ss]/[ssim] and [css]/[cssim]. + +All proofs are [Admitted.] in this draft. +|*) + +From Stdlib Require Import + Lia + Basics + Fin + RelationClasses + Program.Equality + Logic.Eqdep. + +From Coinduction Require Import all. + +From ITree Require Import Core.Subevent. + +From CTree Require Import + CTree + Utils + Eq.Equ + Eq.Shallow + Eq.Trans + Eq.SSim + Eq.CSSim. + +From RelationAlgebra Require Export + rel srel. + +Import CoindNotations. +Import CTree. +Set Implicit Arguments. + +(*| +Definition +---------- +|*) +Section StrongBisim. + Context {E F C D : Type -> Type} {X Y : Type}. + + Program Definition sb (L : lrel E F X Y) : + mon (@S E C X -> @S F D Y -> Prop) := + {| body R t u := ss L R t u /\ ss (flipL L) (flip R) u t |}. + Next Obligation. + split; intros; [edestruct H0 as (? & ? & ?) | edestruct H1 as (? & ? & ?)]; eauto; eexists; eexists; intuition; eauto. + Qed. + + #[global] Instance lequiv_sb : Proper (lequiv ==> weq) sb. + Proof. + cbn -[sb]. intros * EQ *; split. + - intros [For Bac]; split. + eapply lequiv_ss in EQ. + now apply EQ in For. + eapply lequiv_ss; [| eauto]. + now apply lequiv_flipL. + - intros [For Bac]; split. + eapply lequiv_ss; eauto. + eapply lequiv_ss; [| eauto]. + now apply lequiv_flipL. + Qed. + +End StrongBisim. + +Definition sbisim {E F C D X Y} L := + (gfp (@sb E F C D X Y L) : hrel _ _). + +Module SBisimNotations. + + Notation sbisimeq := (sbisim Leq). + Infix "≃" := (sbisim Leq) (at level 70). + Notation "t (≃ [ Q ] ) u" := (sbisim (Lvrel Q) t u) (at level 79). + Notation "t (≃ L ) u" := (sbisim L t u) (at level 79). + + Notation "t '[≃]' u" := (sb Leq (` _) t u) (at level 90, only printing). + Notation "t '[≃' [ R ] ']' u" := (sb (Lvrel R) (` _) t u) (at level 90, only printing). + Notation "t '[≃' R ']' u" := (sb R (` _) t u) (at level 90, only printing). + +End SBisimNotations. + +Import SBisimNotations. +Import CTreeNotations. +Import EquNotations. + +(*| +Hook letting [coq-coinduction]'s symmetric tactic fire on homogeneous +bisimulations. +|*) +#[global] Instance sbisim_sym {E C X L} : + Symmetric L -> + Symmetrical converse (@sb E E C C X X (Lvrel L)) (@ss E E C C X X (Lvrel L)). +Proof. + intros SYM. intros RR u v. split; intros HSIM. + - destruct HSIM as [F B]. split. + + apply F. + + cbn. intros l v' TR. + apply B in TR as (l' & u' & TR & HR & HR'). + ex2; split3; eauto. + symmetry. + pose proof flipL_flip (Lvrel L) l l' as G. + now apply G. + - destruct HSIM as [F B]. split. + + apply F. + + intros l v' TR. + apply B in TR as (l' & u' & TR & HR & HR'). + ex2; split3; eauto. + pose proof flipL_flip (Lvrel L) l l' as G. + apply G. + now symmetry. +Qed. + +(*| +Tactics +------- +|*) +Ltac fold_sbisim := + repeat + match goal with + | h: context[gfp (@sb ?E ?F ?C ?D ?X ?Y ?L)] |- _ => fold (@sbisim E F C D X Y L) in h + | |- context[gfp (@sb ?E ?F ?C ?D ?X ?Y ?L)] => fold (@sbisim E F C D X Y L) + end. + +Tactic Notation "__step_sbisim" := + match goal with + | |- context[@sbisim ?E ?F ?C ?D ?X ?Y ?LR] => + unfold sbisim; + step; + fold (@sbisim E F C D X Y L) + end. +#[local] Tactic Notation "step" := __step_sbisim || __step_cssim || __step_ssim || step. + +Ltac __step_in_sbisim H := + match type of H with + | context[@sbisim ?E ?F ?C ?D ?X ?Y ?LR] => + unfold sbisim in H; + step in H; + fold (@sbisim E F C D X Y L) in H + end. +#[local] Tactic Notation "step" "in" ident(H) := __step_in_sbisim H || step in H. + +Tactic Notation "__coinduction_sbisim" simple_intropattern(r) simple_intropattern(cih) := + first [unfold sbisim at 4 | unfold sbisim at 3 | unfold sbisim at 2 | unfold sbisim at 1]; coinduction r cih. +#[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := + __coinduction_sbisim r cih || __coinduction_cssim r cih || __coinduction_ssim r cih || coinduction r cih. + +Ltac __play_sbisim := (try step); split; cbn; intros ? ? ?TR. + +Ltac __playL_sbisim H := + (try step in H); + let Hf := fresh "Hf" in + destruct H as [Hf _]; + cbn in Hf; edestruct Hf as (? & ? & ?TR & ?EQ & ?); + clear Hf; [etrans |]. + +Ltac __playR_sbisim H := + (try step in H); + let Hb := fresh "Hb" in + destruct H as [_ Hb]; + cbn in Hb; edestruct Hb as (? & ? & ?TR & ?EQ & ?); + clear Hb; [etrans |]. + +Ltac __eplayL_sbisim := + match goal with + | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => __playL_sbisim h + | h : body (sb ?L) ?R _ _ |- _ => __playL_sbisim h + end. + +Ltac __eplayR_sbisim := + match goal with + | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => __playR_sbisim h + | h : body (sb ?L) ?R _ _ |- _ => __playR_sbisim h + end. + +Ltac __answer_sbisim := ex2; split3; etrans. + +#[local] Tactic Notation "play" := __play_sbisim. +#[local] Tactic Notation "playL" "in" ident(H) := __playL_sbisim H. +#[local] Tactic Notation "playR" "in" ident(H) := __playR_sbisim H. +#[local] Tactic Notation "play" "in" ident(H) := first [playL in H; [] | playR in H; []]. +#[local] Tactic Notation "eplayL" := __eplayL_sbisim. +#[local] Tactic Notation "eplayR" := __eplayR_sbisim. +#[local] Tactic Notation "eplay" := first [eplayL; [] | eplayR; []]. +#[local] Tactic Notation "answer" := __answer_sbisim. + +(*| +Homogeneous theory +------------------ +|*) +Section sbisim_homogenous_theory. + Context {E B : Type -> Type} {X : Type} + {L : lrel E E X X}. + + Notation sb := (@sb E E B B X X). + Notation sbisim := (@sbisim E E B B X X). + + #[global] Instance reflexive_sb {R} + (LR : Reflexive L) (RR : Reflexive R) : Reflexive (sb L R). + Proof. + split. reflexivity. + cbn; eauto 10. + Qed. + + #[global] Instance reflexive_chain {LR : Reflexive L} {C : Chain (sb L)} : Reflexive `C. + Proof. + apply Reflexive_chain; typeclasses eauto. + Qed. + + #[global] Instance symmetric_sb {R} + (LS : Symmetric L) (RS : Symmetric R) : Symmetric (sb L R). + Proof. + intros u v SB. + play; eplay. + answer; now apply flipL_flip. + answer; now apply flipL_flip. + Qed. + + #[global] Instance symmetric_chain {LS : Symmetric L} {C : Chain (sb L)} : Symmetric `C. + Proof. + apply Symmetric_chain; typeclasses eauto. + Qed. + + #[global] Instance transitive_sb {R} + (LT : Transitive L) (RT : Transitive R) : Transitive (sb L R). + Proof. + intros x y z SS1 SS2. + play. + - play in SS1; play in SS2; answer. + - play in SS2; play in SS1; answer. + apply (flipL_flip L) in H,H0; apply flipL_flip; cbn in *; eauto. + Qed. + + #[global] Instance transitive_chain {LT : Transitive L} {C : Chain (sb L)} : Transitive `C. + Proof. + apply Transitive_chain; typeclasses eauto. + Qed. + + #[global] Instance preOrder_sb {R} + (LE : PreOrder L) (RE : PreOrder R) : PreOrder (sb L R). + Proof. split; typeclasses eauto. Qed. + + #[global] Instance PreOrder_chain {LPO : PreOrder L} {C : Chain (sb L)} : PreOrder `C. + Proof. split; typeclasses eauto. Qed. + + #[global] Instance equivalence_sb {R} + (LE : Equivalence L) (RE : Equivalence R) : Equivalence (sb L R). + Proof. split; typeclasses eauto. Qed. + + #[global] Instance equivalence_chain {LE : Equivalence L} {C : Chain (sb L)} : Equivalence `C. + Proof. split; typeclasses eauto. Qed. + +End sbisim_homogenous_theory. + +Lemma Leq_eq {E X}: build_rel (@Leq E X) == eq. +Proof. + split; [| intros <-; reflexivity]. + intros []; auto. + dependent induction HR; auto. + dependent induction HR; auto. + cbn in H; subst; auto. +Qed. + +Lemma flipL_Leq {E X}: lequiv (flipL (@Leq E X)) Leq. +Proof. + cbv; intuition. + all: dependent induction H; constructor. +Qed. + +(*| +Heterogeneous theory +-------------------- +|*) +Section sbisim_heterogenous_theory. + Arguments label : clear implicits. + Context {E F C D : Type -> Type} {X Y : Type}. + + Notation sb := (@sb E F C D X Y). + Notation sbisim := (@sbisim E F C D X Y). + + Lemma sbisim_mono : Proper (sub_lrel ==> leq) sbisim. + Proof. + cbn; intros RR SS SUB. + coinduction R cih. + intros u v HSB; split. + - intros ? ? TR; eplay; answer. + eapply sub_lrel_subrel; eauto. + - intros ? ? TR; cbn. + eplay. answer. + apply lequiv_sub_lrel in SUB. + eapply sub_lrel_subrel; eauto. + Qed. + + Context {L : lrel E F X Y}. + + (*| Up-to [equ_clos]. |*) + (* Lemma equ_clos_chain {c : Chain (sb L)} : *) + (* forall x y, equ_clos `c x y -> `c x y. *) + (* Proof. *) + (* apply tower. *) + (* - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. *) + (* apply INC; auto. *) + (* econstructor; eauto. *) + (* apply leq_infx in H. *) + (* now apply H. *) + (* - clear. *) + (* intros c IH x y []; split. *) + (* + intros l z x'z. *) + (* rewrite Equt in x'z. *) + (* apply HR in x'z as (? & ? & ? & ? & ?). *) + (* do 2 eexists; intuition; eauto. *) + (* rewrite <- Equu; eauto. *) + (* + intros l z x'z. *) + (* rewrite <- Equu in x'z. *) + (* apply HR in x'z as (? & ? & ? & ? & ?). *) + (* do 2 eexists; intuition; eauto. *) + (* rewrite Equt; eauto. *) + (* Qed. *) + + #[global] Instance seq_chain_goal {c : Chain (sb L)} : + Proper (Seq ==> Seq ==> flip impl) `c. + Proof. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' EQt u u' EQu HBS; split; intros l v TR. + + rewrite EQt in TR. + eplay. + answer. + now rewrite EQu. + + rewrite EQu in TR. + eplay. + answer. + now rewrite EQt. + Qed. + + #[global] Instance equ_chain_goal {c : Chain (sb L)} : + Proper (equ eq ==> equ eq ==> flip impl) `c. + Proof. + repeat intro; eapply seq_chain_goal; [| |eauto]; eauto. + Qed. + + #[global] Instance seq_sb_goal {r} : + Proper (Seq ==> Seq ==> flip impl) (sb L r). + Proof. + intros t t' tt' u u' uu' HBS; split; intros ?? TR. + - rewrite tt' in TR. + eplay; answer. + now rewrite uu'. + - rewrite uu' in TR. + eplay; answer. + now rewrite tt'. + Qed. + + #[global] Instance equ_sb_goal {r} : + Proper (equ eq ==> equ eq ==> flip impl) (sb L r). + Proof. + repeat intro; eapply seq_sb_goal; [| | eauto]; eauto. + Qed. + + #[global] Instance sbisim_chain_goal {c : Chain (sb L)} : + Proper (sbisimeq ==> sbisimeq ==> flip impl) `c. + Proof. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' Sbisimt u u' Sbisimu [fwd bwd]; split; intros l v TR. + + step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis & EQl). + apply fwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). + step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). + do 2 eexists; repeat split; eauto. + eapply INC; eauto. + (* todo ltac *) + apply Leq_eq in EQl. + rewrite flipL_Leq in EQl'. + apply Leq_eq in EQl'. + subst; auto. + + step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis & EQl). + apply bwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). + step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). + do 2 eexists; repeat split; eauto. + eapply INC; eauto. + apply Leq_eq in EQl. + rewrite flipL_Leq in EQl'. + apply Leq_eq in EQl'. + subst; auto. + Qed. + + #[global] Instance seq_chain_ctx {c : Chain (sb L)} : + Proper (Seq ==> Seq ==> impl) `c. + Proof. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' EQt u u' EQu HBS; split; intros l v TR. + + rewrite <- EQt in TR. + eplay. + answer. + now rewrite <- EQu. + + rewrite <- EQu in TR. + eplay. + answer. + now rewrite <- EQt. + Qed. + + #[global] Instance equ_chain_ctx {c : Chain (sb L)} : + Proper (equ eq ==> equ eq ==> impl) `c. + Proof. + repeat intro; eapply seq_chain_ctx; [| | eauto]; eauto. + Qed. + + #[global] Instance seq_sb_ctx {r} : + Proper (Seq ==> Seq ==> impl) (sb L r). + Proof. + intros t t' tt' u u' uu' HBS; split; intros ?? TR. + - rewrite <- tt' in TR. + eplay; answer. + now rewrite <- uu'. + - rewrite <- uu' in TR. + eplay; answer. + now rewrite <- tt'. + Qed. + + #[global] Instance equ_sb_ctx {r} : + Proper (equ eq ==> equ eq ==> impl) (sb L r). + Proof. + repeat intro; eapply seq_sb_ctx; [| | eauto]; eauto. + Qed. + + #[global] Instance sbisim_chain_ctx {c : Chain (sb L)} : + Proper (sbisimeq ==> sbisimeq ==> impl) `c. + Proof. + apply tower. + - intros ? INC t t' HP' ? ? HP'' ?? HP'''. + red. + eapply INC; eauto. + apply leq_infx in HP'''. + now apply HP'''. + - intros ? INC t t' Sbisimt u u' Sbisimu [fwd bwd]; split; intros l v TR. + + step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis & EQl). + apply fwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). + step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). + do 2 eexists; repeat split; eauto. + eapply INC; eauto. + (* todo ltac *) + apply Leq_eq in EQl'. + rewrite flipL_Leq in EQl. + apply Leq_eq in EQl. + subst; auto. + + step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis & EQl). + apply bwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). + step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). + do 2 eexists; repeat split; eauto. + eapply INC; eauto. + apply Leq_eq in EQl'. + rewrite flipL_Leq in EQl. + apply Leq_eq in EQl. + subst; auto. + Qed. + + (*| Subrelations. |*) + + Lemma sbisim_cssim_subrelation_gen : + forall x y, sbisim L x y -> cssim L x y. + Proof. + red. + coinduction r cih; intros * SB. + step in SB; destruct SB as [fwd bwd]. + split. + - intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. + - intros (? & ? & TR). apply bwd in TR as (? & ? & ? & ? & ?); eauto 10. + Qed. + + Lemma sbisim_ssim_subrelation_gen : + forall x y, sbisim L x y -> ssim L x y. + Proof. + intros. now apply cssim_ssim_subrelation_gen, sbisim_cssim_subrelation_gen. + Qed. + +End sbisim_heterogenous_theory. + +(* TODO (?) : generalize +Lemma equ_sbisim_subrelation_gen {E B X Y} (RR : rel X Y) : + forall x y, SeqR RR x y -> @sbisim E E B B X Y (Lvrel RR) x y. + *) + +#[global] Instance equ_sbisim_subrelation {E B X} : + subrelation (@Seq E B X) sbisimeq. +Proof. + red; intros * EQ; now rewrite EQ. +Qed. + +#[global] Instance sbisim_cssim_subrelation {E C X L} : + subrelation (@sbisim E E C C X X L) (cssim L). +Proof. + red; apply sbisim_cssim_subrelation_gen. +Qed. + +#[global] Instance sbisim_ssim_subrelation {E C X L} : + subrelation (@sbisim E E C C X X L) (ssim L). +Proof. + red; apply sbisim_ssim_subrelation_gen. +Qed. + +#[global] Instance weq_sbisim : forall {E F C D X Y}, + Proper (lequiv ==> weq) (@sbisim E F C D X Y). +Proof. + cbn -[weq]. intros. apply gfp_weq. now apply lequiv_sb. +Qed. + +#[global] Instance is_stuck_sbisim_iff {E C X L} : + Proper (@sbisim E E C C X X L ==> iff) is_stuck. +Proof. + cbn; split; intros IS ?? TR. + all:step in H; destruct H as [fwd bwd]. + apply bwd in TR as (? & ? & ? & ? & ?); eapply IS; eauto. + apply fwd in TR as (? & ? & ? & ? & ?); eapply IS; eauto. +Qed. + +(*| +Up-to bind +---------- +|*) +Section bind. + Arguments label : clear implicits. + Obligation Tactic := idtac. + + Lemma bind_chain_gen + {E F C D : Type -> Type} {X X' Y Y' : Type} + (L : lrel E F X' Y') + (SS : rel X Y) + {R : Chain (@sb E F C D X' Y' L)} : + forall (t : ctree E C X) (t' : ctree F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), + sbisim (upd_rel L SS) t t' -> + (forall x y, SS x y -> `R (k x) (k' y)) -> + `R (bind t k) (bind t' k'). + Proof. + apply tower. + - intros ? INC ? ? ? ? tt' kk' ? ?. + apply INC. apply H. apply tt'. + intros x x' xx'. apply leq_infx in H. apply H. now apply kk'. + - intros ? ? ? ? ? ? tt' kk'. + step in tt'; destruct tt' as [fwd bwd]. + split; cbn; intros * STEP. + + apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | [(Z & e & EQl & g & STEP & SEQ) | (v & STEPres & STEP)]]. + * subst l. + apply fwd in STEP as (? & ? & STEP' & HSIM & HRL). + inv HRL. + refine_trans. + ex2; split3. + apply trans_bind_l_τ; eauto. + 2: etrans. + rewrite EQ. + apply H; auto. + intros. + now step; apply kk'. + * subst l. + apply fwd in STEP as (? & ? & STEP' & HSIM & HRL). + invL. + refine_trans. + exists (ask f); ex; split3. + eapply trans_bind_l_ask; eauto. + 2:etrans. + rewrite SEQ. + step; split. + all: intros ? ? STEP''. + all: pose proof trans_passive_inv' STEP'' as (a & EQ & ->). + all: rewrite EQ in STEP''. + assert (TR: trans (rcv e a) (β e g) (g a)) by etrans. + 2:assert (TR: trans (rcv f a) (β f u) (u a)) by etrans. + all:step in HSIM; apply HSIM in TR as (l' & u' & TR' & HSIM' & HRL'). + all:pose proof trans_passive_inv' TR' as (b & EQ' & ->). + exists (rcv f b); ex; split; eauto; split; cycle 1; [invL; etrans |]. + 2:exists (rcv e b); ex; split; eauto; split; cycle 1; [invL; etrans |]. + all:rewrite EQ. + all:apply H. + 1,3:rewrite EQ' in HSIM'; auto. + all:intros; now step; apply kk'. + * apply fwd in STEPres as (? & ? & STEP' & HSIM & HRL). + invL. + apply (kk' v y) in STEP as (l' & u' & STEP'' & HSIM'' & HRL'); etrans. + exists l'; eexists; split; eauto. + eapply trans_bind_r; eauto. + erewrite <- trans_val_inv'; eauto. + + apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | [(Z & e & EQl & g & STEP & SEQ) | (v & STEPres & STEP)]]. + * subst l. + apply bwd in STEP as (? & ? & STEP' & HSIM & HRL). + inv HRL. + refine_trans. + ex2; split3. + apply trans_bind_l_τ; eauto. + 2: etrans. + rewrite EQ. + apply H; auto. + intros. + now step; apply kk'. + * subst l. + apply bwd in STEP as (? & ? & STEP' & HSIM & HRL). + invL. + refine_trans. + exists (ask f); ex; split3. + eapply trans_bind_l_ask; eauto. + 2:etrans. + rewrite SEQ. + step; split. + all: intros ? ? STEP''. + all: pose proof trans_passive_inv' STEP'' as (a & EQ & ->). + all: rewrite EQ in STEP''. + assert (TR: trans (rcv f a) (β f u) (u a)) by etrans. + 2:assert (TR: trans (rcv e a) (β e g) (g a)) by etrans. + all:step in HSIM; apply HSIM in TR as (l' & u' & TR' & HSIM' & HRL'). + all:pose proof trans_passive_inv' TR' as (b & EQ' & ->). + exists (rcv e b); ex; split; eauto; split; cycle 1; [invL; etrans |]. + 2:exists (rcv f b); ex; split; eauto; split; cycle 1; [invL; etrans |]. + all:rewrite EQ. + all:apply H. + 1,3:rewrite EQ' in HSIM'; auto. + all:intros; now step; apply kk'. + * apply bwd in STEPres as (? & ? & STEP' & HSIM & HRL). + invL. + eapply (kk' _ _) in STEP as (l' & u' & STEP'' & HSIM'' & HRL'); etrans. + exists l'; eexists; split; eauto. + eapply trans_bind_r; eauto. + erewrite <- trans_val_inv'; eauto. + Qed. + + Lemma bind_chain {E C D X Y X' Y'} + (RR : rel X' Y') (SS : rel X Y) + {R : Chain (@sb E E C D X' Y' (Lvrel RR))} : + forall (t1 : ctree E C X) (t2 : ctree E D Y) (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y'), + t1 (≃[SS]) t2 -> + (forall x y, SS x y -> `R (k1 x) (k2 y)) -> + `R (t1 >>= k1) (t2 >>= k2). + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. + + Lemma bind_chain_eq {E C X X'} + {R : Chain (@sb E E C C X' X' Leq)} : + forall (t1 t2 : ctree E C X) + (k1 k2 : X -> ctree E C X'), + t1 ≃ t2 -> + (forall x, `R (k1 x) (k2 x)) -> + `R (t1 >>= k1) (t2 >>= k2). + Proof. + intros. + eapply bind_chain_gen; eauto. + intros ??<-; auto. + Qed. + + Lemma sbisim_bind_gen {E F C D X Y X' Y'} + L (SS : rel X Y) + (t1 : ctree E C X) (t2 : ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') : + t1 (≃ upd_rel L SS) t2 -> + (forall x y, SS x y -> k1 x (≃ L) k2 y) -> + t1 >>= k1 (≃ L) t2 >>= k2. + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. + + Lemma sbisim_bind {E C D X Y X' Y'} + (RR : rel X' Y') (SS : rel X Y) + (t1 : ctree E C X) (t2 : ctree E D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree E D Y') : + t1 (≃[SS]) t2 -> + (forall x y, SS x y -> k1 x (≃[RR]) k2 y) -> + t1 >>= k1 (≃[RR]) t2 >>= k2. + Proof. + intros. + eapply bind_chain_gen; eauto. + Qed. + + Lemma sbisim_bind_eq {E C D X X'} + (t1 : ctree E C X) (t2 : ctree E D X) + (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') : + t1 ≃ t2 -> + (forall x, k1 x ≃ k2 x) -> + t1 >>= k1 ≃ t2 >>= k2. + Proof. + intros. + eapply sbisim_bind; eauto. + intros ?? ->; auto. + Qed. + +End bind. + +#[global] Instance sbisim_bind_chain {E C X Y} + {R : Chain (@sb E E C C Y Y Leq)} : + Proper ((fun t u => sbisim Leq (α t) (α u)) ==> + (pointwise_relation _ (fun t u => `R (α t) (α u))) ==> `R) (@bind E C X Y). +Proof. + repeat intro; eapply bind_chain_gen; eauto. + intros ?? <-; auto. +Qed. + +(*| +Structural proof rules +====================== +Same three-layer shape as in [SSim.v] / [CSSim.v]: +- [sb_*_gen]: body-level, arbitrary [R], side-conditions explicit; +- [sb_*]: body-level, on a chain element [`R]; +- [sbisim_*]: gfp-level. +|*) +Section Proof_Rules. + + Context {E F C D : Type -> Type} {X Y : Type}. + + (*| + Stuck ctrees: under bisimilarity the meaningful statement is biconditional. + |*) + Lemma sb_is_stuck L R : + forall (t : ctree E C X) (u : ctree F D Y), + sb L R t u -> is_stuck t <-> is_stuck u. + Proof. + intros * SB; split; intros IS ?? TR; eplay; eapply IS; eauto. + Qed. + + Lemma sbisim_is_stuck L : + forall (t : ctree E C X) (u : ctree F D Y), + sbisim L t u -> is_stuck t <-> is_stuck u. + Proof. + intros * SB; step in SB; eauto using sb_is_stuck. + Qed. + + Lemma is_stuck_sb L R : + forall (t : ctree E C X) (u : ctree F D Y), + is_stuck t -> is_stuck u -> sb L R t u. + Proof. + split; repeat intro. + - now apply H in H1. + - now apply H0 in H1. + Qed. + + Lemma is_stuck_sbisim L : + forall (t : ctree E C X) (u : ctree F D Y), + is_stuck t -> is_stuck u -> sbisim L t u. + Proof. + intros; step; auto using is_stuck_sb. + Qed. + + Lemma Chain_Stuck L {R : Chain (@sb E F C D X Y L)} : + ` R Stuck Stuck. + Proof. + step. apply is_stuck_sb; auto using stuck_is_stuck. + Qed. + + (*| + Ret nodes + |*) + Lemma sb_ret_gen (x : X) (y : Y) L R : + R (α Stuck) (α Stuck) -> + (Proper (Seq ==> Seq ==> impl) R) -> + RR L x y -> + sb L R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros Rstuck ValRefl PROP. + split; apply ss_ret_gen; eauto. + typeclasses eauto. + Qed. + + Lemma sb_ret (x : X) (y : Y) L + {R : Chain (@sb E F C D X Y L)} : + RR L x y -> + sb L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros; apply sb_ret_gen; auto. + apply Chain_Stuck. + typeclasses eauto. + Qed. + + Lemma sbisim_ret (x : X) (y : Y) L : + RR L x y -> + sbisim L (Ret x : ctree E C X) (Ret y : ctree F D Y). + Proof. + intros; step; now apply sb_ret. + Qed. + + (*| + Vis nodes + |*) + + Lemma sb_vis_gen {Z Z'} (e : E Z) (f: F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (R: rel _ _) (L : lrel E F X Y) : + R (β (e) k) (β (f) k') -> + (Proper (Seq ==> Seq ==> impl) R) -> + L (ask e) (ask f) -> + sb L R (Vis e k) (Vis f k'). + Proof. + intros; split; apply ss_vis_gen; try typeclasses eauto; auto. + now apply flipL_flip. + Qed. + + Lemma sb_vis {Z Z'} (e : E Z) (f : F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} + (HRask : Rask L e f) + (HRfwd : forall x, exists y, `R (k x) (k' y) /\ Rrcv L e f x y) + (HRbwd : forall y, exists x, `R (k x) (k' y) /\ Rrcv L e f x y) : + sb L `R (Vis e k) (Vis f k'). + Proof. + apply sb_vis_gen; try typeclasses eauto. + 2: now constructor. + step; split. + all: intros l u TR; inv_trans; subst. + destruct (HRfwd x) as (y & ? & ?). + 2:destruct (HRbwd x) as (y & ? & ?). + all:ex2; intuition. + rewrite EQ; eauto. + etrans. + rewrite EQ; eauto. + apply flipL_flip; cbn; etrans. + Qed. + + Lemma sbisim_vis {Z Z'} (e : E Z) (f : F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + (HRask : Rask L e f) + (HRfwd : forall x, exists y, sbisim L (k x) (k' y) /\ Rrcv L e f x y) + (HRbwd : forall y, exists x, sbisim L (k x) (k' y) /\ Rrcv L e f x y) : + sbisim L (Vis e k) (Vis f k'). + Proof. + now step; apply sb_vis. + Qed. + + Lemma sb_vis_id {Z} (e : E Z) (f : F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} + (HRask : Rask L e f) + (HRrcv : forall z, `R (k z) (k' z) /\ Rrcv L e f z z) : + sb L `R (Vis e k) (Vis f k'). + Proof. + apply sb_vis; auto. + all: intros x; exists x; auto. + Qed. + + Lemma sbisim_vis_id {Z} (e : E Z) (f : F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + (HRask : Rask L e f) + (HRrcv : forall z, sbisim L (k z) (k' z) /\ Rrcv L e f z z) : + sbisim L (Vis e k) (Vis f k'). + Proof. + now step; apply sb_vis_id. + Qed. + + (*| + Invisible branching — [Br]. Unlike [ss], the [_l]/[_r] variants require + an explicit witness so that the reverse challenge has a branch to take. + |*) + + Lemma sb_br_gen {A B} (c : C A) (d : D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) R L : + (forall x, exists y, sb L R (k x) (k' y)) -> + (forall y, exists x, sb L R (k x) (k' y)) -> + sb L R (Br c k) (Br d k'). + Proof. + intros EQs1 EQs2. + split; apply ss_br_gen; intros. + - destruct (EQs1 x) as [z [FW _]]. eauto. + - destruct (EQs2 x) as [z [_ BA]]. eauto. + Qed. + + Lemma sb_br_id_gen {A} (c : C A) (d : D A) + (k : A -> ctree E C X) (k' : A -> ctree F D Y) R L : + (forall x, sb L R (k x) (k' x)) -> + sb L R (Br c k) (Br d k'). + Proof. + intros; apply sb_br_gen; intros x; exists x; auto. + Qed. + + Lemma sb_br_l_gen {Z} (c : C Z) (x : Z) + (k : Z -> ctree E C X) (t : ctree F D Y) R L : + (forall z, sb L R (k z) t) -> + sb L R (Br c k) t. + Proof. + intros EQs. + split. + - apply ss_br_l_gen; intros; apply EQs. + - intros ?? TR. + eapply ss_br_r_gen with (x := x); eauto. + apply EQs. + Qed. + + Lemma sb_br_r_gen {Z} (d : D Z) (y : Z) + (k : Z -> ctree F D Y) (t : ctree E C X) R L : + (forall z, sb L R t (k z)) -> + sb L R t (Br d k). + Proof. + intros EQs. + split. + - apply ss_br_r_gen with (x := y); intros; apply EQs. + - apply ss_br_l_gen; intros; apply EQs. + Qed. + + Lemma sb_br {A B} (c : C A) (d : D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + (forall x, exists y, sb L `R (k x) (k' y)) -> + (forall y, exists x, sb L `R (k x) (k' y)) -> + sb L `R (Br c k) (Br d k'). + Proof. + now intros; apply sb_br_gen. + Qed. + + Lemma sb_br_id {A} (c : C A) (d : D A) + (k : A -> ctree E C X) (k' : A -> ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + (forall x, sb L `R (k x) (k' x)) -> + sb L `R (Br c k) (Br d k'). + Proof. + now intros; apply sb_br_id_gen. + Qed. + + Lemma sb_br_l {Z} (c : C Z) (x : Z) + (k : Z -> ctree E C X) (t : ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + (forall z, sb L `R (k z) t) -> + sb L `R (Br c k) t. + Proof. + now intros; apply sb_br_l_gen. + Qed. + + Lemma sb_br_r {Z} (d : D Z) (y : Z) + (k : Z -> ctree F D Y) (t : ctree E C X) L + {R : Chain (@sb E F C D X Y L)} : + (forall z, sb L `R t (k z)) -> + sb L `R t (Br d k). + Proof. + now intros; apply sb_br_r_gen. + Qed. + + Lemma sbisim_br {A B} (c : C A) (d : D B) + (k : A -> ctree E C X) (k' : B -> ctree F D Y) L : + (forall x, exists y, sbisim L (k x) (k' y)) -> + (forall y, exists x, sbisim L (k x) (k' y)) -> + sbisim L (Br c k) (Br d k'). + Proof. + intros H1 H2; step; apply sb_br; eauto. + intros x; destruct (H1 x); eexists; step in H; eauto. + intros x; destruct (H2 x); eexists; step in H; eauto. + Qed. + + Lemma sbisim_br_id {A} (c : C A) (d : D A) + (k : A -> ctree E C X) (k' : A -> ctree F D Y) L : + (forall x, sbisim L (k x) (k' x)) -> + sbisim L (Br c k) (Br d k'). + Proof. + intros; step; apply sb_br_id; eauto. + intros x; specialize (H x); step in H; auto. + Qed. + + Lemma sbisim_br_l {Z} (c : C Z) (x : Z) + (k : Z -> ctree E C X) (t : ctree F D Y) L : + (forall z, sbisim L (k z) t) -> + sbisim L (Br c k) t. + Proof. + intros; step; apply sb_br_l; eauto. + intros y; specialize (H y); step in H; auto. + Qed. + + Lemma sbisim_br_r {Z} (d : D Z) (y : Z) + (k : Z -> ctree F D Y) (t : ctree E C X) L : + (forall z, sbisim L t (k z)) -> + sbisim L t (Br d k). + Proof. + intros; step; apply sb_br_r; eauto. + intros x; specialize (H x); step in H; auto. + Qed. + + (* CHECKPOINT *) + (*| + Guard — a silent wrapper; absorbed by [≃]. + |*) + Lemma sb_guard_l_gen (t : ctree E C X) (u : ctree F D Y) R L : + sb L R t u -> sb L R (Guard t) u. + Proof. + + + Lemma sb_guard_l (t : ctree E C X) (u : ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + sb L `R t u -> sb L `R (Guard t) u. + Admitted. + + Lemma sbisim_guard_l (t : ctree E C X) (u : ctree F D Y) L : + sbisim L t u -> sbisim L (Guard t) u. + Admitted. + + Lemma sb_guard_r_gen (t : ctree E C X) (u : ctree F D Y) R L : + sb L R t u -> sb L R t (Guard u). + Admitted. + + Lemma sb_guard_r (t : ctree E C X) (u : ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + sb L `R t u -> sb L `R t (Guard u). + Admitted. + + Lemma sbisim_guard_r (t : ctree E C X) (u : ctree F D Y) L : + sbisim L t u -> sbisim L t (Guard u). + Admitted. + + Lemma sbisim_guard (t : ctree E C X) (u : ctree F D Y) L : + sbisim L t u -> sbisim L (Guard t) (Guard u). + Admitted. + + (*| + Internal transitions — [Step]. + |*) + Lemma sb_step_gen (t : ctree E C X) (u : ctree F D Y) R L : + (Proper (Seq ==> Seq ==> impl) R) -> + L τ τ -> + R (α t) (α u) -> + sb L R (Step t) (Step u). + Admitted. + + Lemma sb_step (t : ctree E C X) (u : ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + L τ τ -> + `R t u -> + sb L `R (Step t) (Step u). + Admitted. + + Lemma sbisim_step (t : ctree E C X) (u : ctree F D Y) L : + L τ τ -> + sbisim L t u -> + sbisim L (Step t) (Step u). + Admitted. + + (*| + Visible branching — [BrS]. + |*) + Lemma sb_brS {Z Z'} (c : C Z) (d : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + L τ τ -> + (forall x, exists y, `R (k x) (k' y)) -> + (forall y, exists x, `R (k x) (k' y)) -> + sb L `R (BrS c k) (BrS d k'). + Admitted. + + Lemma sbisim_brS {Z Z'} (c : C Z) (d : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L : + L τ τ -> + (forall x, exists y, sbisim L (k x) (k' y)) -> + (forall y, exists x, sbisim L (k x) (k' y)) -> + sbisim L (BrS c k) (BrS d k'). + Admitted. + + Lemma sb_brS_id {Z} (c : C Z) (d : D Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + L τ τ -> + (forall x, `R (k x) (k' x)) -> + sb L `R (BrS c k) (BrS d k'). + Admitted. + + Lemma sbisim_brS_id {Z} (c : C Z) (d : D Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L : + L τ τ -> + (forall x, sbisim L (k x) (k' x)) -> + sbisim L (BrS c k) (BrS d k'). + Admitted. + + (*| + [spinS] laws. + |*) + Lemma sbisim_spinS_nonempty : + forall {Z Z'} L (x : Z) (y : Z') (c : C Z) (c' : D Z'), + L τ τ -> + @sbisim E F C D X Y L (spinS_gen c) (spinS_gen c'). + Admitted. + + Lemma sbisim_spinS_empty : + forall L (c : C False) (c' : D False), + @sbisim E F C D X Y L (spinS_gen c) (spinS_gen c'). + Admitted. + +(*| +Inversion principles +-------------------- +|*) + + Lemma sbisim_stuck_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L t u -> is_stuck t <-> is_stuck u. + Admitted. + + Lemma sbisim_ret_l_inv L : + forall r (u : ctree F D Y), + sbisim L (Ret r : ctree E C X) u -> + exists r' u', trans (val r') u u' /\ RR L r r'. + Admitted. + + Lemma sbisim_ret_r_inv L : + forall r' (t : ctree E C X), + sbisim L t (Ret r' : ctree F D Y) -> + exists r t', trans (val r) t t' /\ RR L r r'. + Admitted. + + Lemma sbisim_ret_inv L (r : X) (r' : Y) : + sbisim L (Ret r : ctree E C X) (Ret r' : ctree F D Y) -> + RR L r r'. + Admitted. + + Lemma sbisim_vis_l_inv {Z L} : + forall (e : E Z) (k : Z -> ctree E C X) u, + sbisim L (Vis e k) u -> + exists Z' (f : F Z') k', + trans (ask f) u (β f k') /\ + Rask L e f /\ + (forall x, exists y, sbisim L (k x) (k' y) /\ Rrcv L e f x y) /\ + (forall y, exists x, sbisim L (k x) (k' y) /\ Rrcv L e f x y). + Admitted. + + Lemma sbisim_vis_inv {Z Z'} L + (e : E Z) (f : F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + sbisim L (Vis e k) (Vis f k') -> + Rask L e f /\ + (forall x, exists y, Rrcv L e f x y /\ sbisim L (k x) (k' y)) /\ + (forall y, exists x, Rrcv L e f x y /\ sbisim L (k x) (k' y)). + Admitted. + + Lemma sbisim_vis_invT {Z Z'} L + (e : E Z) (f : F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (x : Z) : + sbisim L (Vis e k) (Vis f k') -> Rask L e f. + Admitted. + + Lemma sbisim_guard_l_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L (Guard t) u -> sbisim L t u. + Admitted. + + Lemma sbisim_guard_r_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L t (Guard u) -> sbisim L t u. + Admitted. + + Lemma sbisim_guard_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L (Guard t) (Guard u) -> sbisim L t u. + Admitted. + + Lemma sbisim_br_l_inv L Z + (c : C Z) (t : ctree F D Y) (k : Z -> ctree E C X) : + sbisim L (Br c k) t -> + forall x, sbisim L (k x) t. + Admitted. + + Lemma sbisim_br_r_inv L Z + (d : D Z) (t : ctree E C X) (k : Z -> ctree F D Y) : + sbisim L t (Br d k) -> + forall y, sbisim L t (k y). + Admitted. + + Lemma sbisim_step_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L (Step t) (Step u) -> sbisim L t u. + Admitted. + + Lemma sbisim_step_l_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L (Step t) u -> + exists u', trans τ u u' /\ sbisim L t u'. + Admitted. + + Lemma sbisim_step_r_inv L (t : ctree E C X) (u : ctree F D Y) : + sbisim L t (Step u) -> + exists t', trans τ t t' /\ sbisim L t' u. + Admitted. + + Lemma sbisim_brS_inv L + {A B} (c : C A) (d : D B) + (k1 : A -> ctree E C X) (k2 : B -> ctree F D Y) : + sbisim L (BrS c k1) (BrS d k2) -> + (forall a, exists b, sbisim L (k1 a) (k2 b)) /\ + (forall b, exists a, sbisim L (k1 a) (k2 b)). + Admitted. + + Lemma sbisim_brS_l_inv L + {A} (c : C A) (k1 : A -> ctree E C X) (u : ctree F D Y) : + sbisim L (BrS c k1) u -> + forall a, exists u', trans τ u u' /\ sbisim L (k1 a) u'. + Admitted. + +End Proof_Rules. + +(*| +Sanity checks and structural laws (homogeneous). +|*) +Section WithParams. + + Context {E C : Type -> Type}. + Context {HasC2 : B2 -< C}. + Context {HasC3 : B3 -< C}. + + Lemma spin_bisim : forall {Z1 Z2} (c : C Z1) (c' : C Z2), + @spin_gen E C Z1 Z1 c ≃ @spin_gen E C Z2 Z2 c'. + Admitted. + + Lemma br2_assoc {X} : forall (t u v : ctree E C X), + br2 (br2 t u) v ≃ br2 t (br2 u v). + Admitted. + + Lemma br2_commut {X} : forall (t u : ctree E C X), + br2 t u ≃ br2 u t. + Admitted. + + Lemma br2_idem {X} : forall (t : ctree E C X), + br2 t t ≃ t. + Admitted. + + Lemma br2_merge {X} : forall (t u v : ctree E C X), + br2 (br2 t u) v ≃ br3 t u v. + Admitted. + + Lemma br2_is_stuck {X} : forall (u v : ctree E C X), + is_stuck u -> br2 u v ≃ v. + Admitted. + + Lemma br2_stuck_l {X} : forall (t : ctree E C X), + br2 Stuck t ≃ t. + Admitted. + + Lemma br2_stuck_r {X} : forall (t : ctree E C X), + br2 t Stuck ≃ t. + Admitted. + + Lemma br2_spin_l {X} : forall (t : ctree E C X), + br2 spin t ≃ t. + Admitted. + + Lemma br2_spin_r {X} : forall (t : ctree E C X), + br2 t spin ≃ t. + Admitted. + + Lemma brS2_commut {X} : forall (t u : ctree E C X), + brS2 t u ≃ brS2 u t. + Admitted. + + Lemma brS2_idem {X} : forall (t : ctree E C X), + brS2 t t ≃ Step t. + Admitted. + + Lemma sb_unfold_forever {X} : forall (k : X -> ctree E C X) (i : X), + forever k i ≃ r <- k i ;; forever k r. + Admitted. + +End WithParams. + +(*| +Incompatibility lemmas — constructors of distinct kinds cannot be bisimilar +(with minor inhabitation side-conditions for stuck [Vis] cases). +|*) +Section Incompat. + + Context {E C : Type -> Type}. + + Definition are_bisim_incompat {X} (t u : ctree E C X) : Type := + match observe t, observe u with + | RetF _, RetF _ + | VisF _ _, VisF _ _ + | BrF _ _, _ + | _, BrF _ _ + | GuardF _, _ + | _, GuardF _ + | StepF _, StepF _ + | StuckF, StuckF => False + | @VisF _ _ _ _ Z _ _, StuckF + | StuckF, @VisF _ _ _ _ Z _ _ => inhabited Z + | _, _ => True + end. + + Lemma sbisim_absurd {X} (t u : ctree E C X) : + are_bisim_incompat t u -> t ≃ u -> False. + Admitted. + + Lemma sbisim_ret_vis_inv {X Y} (r : Y) (e : E X) (k : X -> ctree E C Y) : + (Ret r : ctree E C _) ≃ Vis e k -> False. + Admitted. + + Lemma sbisim_ret_BrS_inv {X Y} (r : Y) (c : C X) (k : X -> ctree E C Y) : + (Ret r : ctree E C _) ≃ BrS c k -> False. + Admitted. + + Lemma sbisim_vis_BrS_inv {X Y Z} + (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2 : Y -> ctree E C Z) (y : Y) : + Vis e k1 ≃ BrS c k2 -> False. + Admitted. + + Lemma sbisim_vis_BrS_inv' {X Y Z} + (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2 : Y -> ctree E C Z) (x : X) : + Vis e k1 ≃ BrS c k2 -> False. + Admitted. + +End Incompat. + +(*| +Interaction with (complete) strong simulation +============================================= +|*) +Section SBisim_vs_SSim. + + Context {E F C D : Type -> Type} {X Y : Type} + {L : lrel E F X Y}. + + Notation ss := (@ss E F C D X Y). + Notation ssim := (@ssim E F C D X Y). + + (*| + A two-sided [ss] gives an [sb]; the converse fails in general (see + [ssim_sbisim_nequiv] below). + |*) + Lemma ss_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : + ss L R t u -> + ss (flipL L) (flip R) u t -> + sb L R t u. + Admitted. + + Lemma sbisim_clos_ss {c : Chain (ss L)} : + forall x y, @sbisim_clos E F C D X Y Leq Leq `c x y -> `c x y. + Admitted. + + #[global] Instance sbisim_eq_clos_ss_goal {R : Chain (ss L)} : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) `R. + Admitted. + + #[global] Instance sbisim_eq_clos_ss_ctx {R : Chain (ss L)} : + Proper (sbisim Leq ==> sbisim Leq ==> impl) `R. + Admitted. + + #[global] Instance sbisim_eq_clos_ssim_goal : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (ssim L). + Admitted. + + #[global] Instance sbisim_eq_clos_ssim_ctx : + Proper (sbisim Leq ==> sbisim Leq ==> impl) (ssim L). + Admitted. + +End SBisim_vs_SSim. + +Section Two_ss_is_not_sb. + + (*| + Two [ssim]s do not always give an [sbisim] (witness below). + |*) + Lemma split_sb_eq {E C X} (RR : rel _ _) (t t' : ctree E C X) : + ss Leq RR t t' -> + ss Leq (flip RR) t' t -> + sb Leq RR t t'. + Admitted. + + Lemma split_sbisim_eq {E B X} (t u : ctree E B X) : + t ≃ u <-> ss Leq (sbisim Leq) t u /\ ss Leq (sbisim Leq) u t. + Admitted. + + (*| + A concrete counter-example: [Step (Ret tt)] and [brS2 (Ret tt) Stuck] + are mutually [ssim]-related but not [sbisim]-related. + |*) + Lemma ssim_sbisim_nequiv : + exists (t1 t2 : ctree void1 B2 unit), + ssim Leq t1 t2 /\ ssim Leq t2 t1 /\ ≃ sbisim Leq t1 t2. + Admitted. + +End Two_ss_is_not_sb. + +Section SBisim_vs_CSSim. + + Context {E F C D : Type -> Type} {X Y : Type} + {L : lrel E F X Y}. + + Notation css := (@css E F C D X Y). + Notation cssim := (@cssim E F C D X Y). + + Lemma sb_css (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : + sb L R t u -> css L R t u. + Admitted. + + Lemma css_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : + css L R t u -> + css (flipL L) (flip R) u t -> + sb L R t u. + Admitted. + + Lemma sbisim_clos_css {c : Chain (css L)} : + forall x y, @sbisim_clos E F C D X Y Leq Leq `c x y -> `c x y. + Admitted. + + #[global] Instance sbisim_eq_clos_css_goal {R : Chain (css L)} : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) `R. + Admitted. + + #[global] Instance sbisim_eq_clos_css_ctx {R : Chain (css L)} : + Proper (sbisim Leq ==> sbisim Leq ==> impl) `R. + Admitted. + + #[global] Instance sbisim_eq_clos_cssim_goal : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (cssim L). + Admitted. + + #[global] Instance sbisim_eq_clos_cssim_ctx : + Proper (sbisim Leq ==> sbisim Leq ==> impl) (cssim L). + Admitted. + +End SBisim_vs_CSSim. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 52226bc..9fd557f 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -24,14 +24,42 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. +(*| +Strong simulation +================= + +Parametric strong simulation [ss L] between ctrees over distinct signatures +(events [E]/[F], branching [C]/[D], return types [X]/[Y]), indexed by a +label relation [L : lrel E F X Y]. Its greatest fixed point is [ssim L], +notated [t (≲ L) u] (or [t ≲ u] with the default [Leq]). + +File organisation: +- [ss]/[ssim] definition, notations, folding tactics, custom [step], + [coinduction], [play]/[eplay]/[answer] tactics. +- Homogeneous theory ([E = F], [C = D], [X = Y]): Reflexive / Transitive / + PreOrder instances, both on [ss L R] and on any chain element [`C]. +- Heterogeneous theory: [ssim_mono] for [sub_lrel], the [equ_clos] up-to + principle, and [Proper] instances allowing rewriting [Seq] and [equ eq] + on either side, both on chain elements and on [ss L r]. +- Up-to bind: [bind_chain_gen] and its specialisations ([bind_chain], + [bind_chain_eq], [ssim_bind_gen/bind/bind_eq]). +- Structural proof rules and their inversion counterparts ([Proof_Rules] + section). Naming: + - [ss_foo]/[ssim_foo] = before/after stepping the gfp; + - [_gen] = quantified over an arbitrary well-behaved [R] (required to + rebuild [ssim] on a structural subterm or to reuse in [CSSim]); + - [_l], [_r], [_id] = unilateral / same-type variants; + - [_inv] = inversion principle from the shape of one side. + +The bisimulation counterpart [sb] lives in [Eq.SBisim] and is defined +symmetrically à la Pous'16 for better symmetry arguments; see [square_st] +there for an illustration. +|*) + Section StrongSim. (*| -The function defining strong simulations: [trans] plays must be answered -using [trans]. -The [ss] definition stands for [strong simulation]. The bisimulation [sb] -is obtained by expliciting the symmetric aspect of the definition following -Pous'16 in order to be able to exploit symmetry arguments in proofs -(see [square_st] for an illustration). +[ss L R t u]: every transition from [t] can be matched by [u] up to [L] +on labels, with the resulting continuations related by [R]. |*) Program Definition ss {E F C D : Type -> Type} {X Y : Type} (L : lrel E F X Y) : @@ -129,6 +157,11 @@ Ltac __answer_ssim := ex2; split3; etrans. #[local] Tactic Notation "eplay" := __eplay_ssim. #[local] Tactic Notation "answer" := __answer_ssim. +(*| +Homogeneous theory: when source and target share their signature, [L] +becomes a relation on a single label space and order-theoretic properties +(reflexivity, transitivity) can be stated and lifted to chain elements. +|*) Section ssim_homogenous_theory. Context {E B: Type -> Type} {X: Type} {L: lrel E E X X}. @@ -198,23 +231,6 @@ Section ssim_heterogenous_theory. ---------------------------------------- |*) - (* Can this be rewritten with a simpler proper? *) - Lemma equ_clos_chain {c: Chain (ss L)}: - forall x y, equ_clos `c x y -> `c x y. - Proof. - apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - intros a b ?? [x' y' x'' y'' EQ' EQ''] ? ? tr. - rewrite EQ' in tr. - edestruct EQ'' as (l' & ? & ? & ? & ?); [eauto |]. - exists l',x0; intuition. - rewrite <- Equu; auto. - Qed. - #[global] Instance seq_chain_goal {c: Chain (ss L)} : Proper (Seq ==> Seq ==> flip impl) (`c). Proof. @@ -234,8 +250,18 @@ Section ssim_heterogenous_theory. #[global] Instance equ_chain_goal {c: Chain (ss L)} : Proper (equ eq ==> equ eq ==> flip impl) `c. Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_chain; econstructor; [eauto | | symmetry; eauto]; assumption. + unfold Proper, respectful,flip,impl. + apply tower. + - intros ? INC x y EQ x' y' EQ' ? ? ?; red. + cbn in INC. + eapply INC; eauto. + apply leq_infx in H0. + now apply H0. + - intros a b x y EQ x' y' EQ' SS ?? tr. + rewrite EQ in tr. + edestruct SS as (l' & ? & ? & ? & ?); [eauto |]. + exists l',x0; intuition. + rewrite EQ'; auto. Qed. #[global] Instance seq_ss_goal {r} : @@ -273,10 +299,20 @@ Section ssim_heterogenous_theory. #[global] Instance equ_chain_ctx {c: Chain (ss L)} : Proper (equ eq ==> equ eq ==> impl) `c. Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_chain; econstructor; [symmetry; eauto | | eauto]; assumption. + unfold Proper, respectful,flip,impl. + apply tower. + - intros ? INC x y EQ x' y' EQ' ? ? ?; red. + cbn in INC. + eapply INC; eauto. + apply leq_infx in H0. + now apply H0. + - intros a b x y EQ x' y' EQ' SS ?? tr. + rewrite <- EQ in tr. + edestruct SS as (l' & ? & ? & ? & ?); [eauto |]. + exists l',x0; intuition. + rewrite <- EQ'; auto. Qed. - + #[global] Instance seq_ss_ctx {r} : Proper (Seq ==> Seq ==> impl) (ss L r). Proof. @@ -472,6 +508,17 @@ Qed. (* Notation ssim_ L t u := (ssim L (α t) (α u)). *) (* Notation ss_ L t u := (ss L _ (α t) (α u)). *) +(*| +Structural proof rules +====================== +For each ctree constructor, we provide up to three forms: +- [ss_*_gen]: low-level, parameterised by an arbitrary [R] with the + Proper/reflexivity side-conditions made explicit; +- [ss_*]: specialised to an element [`R] of the companion chain, using + typeclasses to discharge the side-conditions; +- [ssim_*]: the [step]-free form at the gfp level. +Inversion lemmas (named [ssim_*_inv]) invert the shape of one or both sides. +|*) Section Proof_Rules. Context {E F C D: Type -> Type} {X Y : Type}. @@ -558,6 +605,19 @@ Note: the general formulation (over any well-behaved realtion rather than elemen the itree-style rule. |*) (* TODO: specialization to Lvrel *) + + Lemma ss_vis_gen {Z Z'} (e : E Z) (f: F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (R: rel _ _) (L : lrel E F X Y) : + R (β (e) k) (β (f) k') -> + (Proper (Seq ==> Seq ==> impl) R) -> + L (ask e) (ask f) -> + ss L R (Vis e k) (Vis f k'). + Proof. + intros. + cbn; intros ? ? TR; inv_trans; subst. + ex2; split3; etrans. + now rewrite EQ. + Qed. Lemma ss_vis {Z Z'} (e : E Z) (f: F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L @@ -566,16 +626,15 @@ Note: the general formulation (over any well-behaved realtion rather than elemen (HRrcv : forall x, exists y, `R (k x) (k' y) /\ Rrcv L e f x y) : ss L ` R (Vis e k) (Vis f k'). Proof. - intros ?? TR; inv_trans. - subst. - ex2; intuition. - rewrite EQ. + eapply ss_vis_gen. + 2:typeclasses eauto. + 2: now constructor. step. intros l u TR. inv_trans; subst. destruct (HRrcv x) as (y & ? & ?). ex2; intuition. - rewrite EQ0; eauto. + rewrite EQ; eauto. etrans. Qed. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index f689db1..3634277 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -114,10 +114,10 @@ least annoying solution. | τ | ask {X : Type} (e : E X) | rcv {X : Type} (e : E X) (v : X) (* Note: I think we need to remember which request led to the response for the bisimilarity to be right, but I am not 100% sure, [e] might be spurious *) - | val {X : Type} (v : X). + | val (v : R). Variant is_val : label -> Prop := - | Is_val : forall X (x : X), is_val (val x). + | Is_val : forall x, is_val (val x). Lemma is_val_τ : ~ is_val τ. Proof. @@ -517,7 +517,7 @@ Section BackwardBounded. Context `{B2 -< B}. Context `{B3 -< B}. Context `{B4 -< B}. - Variable (l : @label E) (t t' u u' v v' w w' : ctree E B X). + Variable (l : @label E X) (t t' u u' v v' w w' : ctree E B X). Lemma trans_brS21 : trans τ (brS2 t u) t. @@ -662,32 +662,32 @@ Section forward. Inverting equalities between labels |*) - Lemma val_eq_invT : forall X Y x y, @val E X x = @val E Y y -> X = Y. - clear B. intros * EQ. - now dependent induction EQ. - Qed. + (* [val_eq_invT] no longer makes sense: [val] now has signature + [val : R -> label E R], so two [val x], [val y] can only be compared + when they share the return-type parameter; the type equality is + enforced by typing rather than proved. *) - Lemma val_eq_inv : forall X x y, @val E X x = val y -> x = y. + Lemma val_eq_inv : forall (x y : X), @val E X x = val y -> x = y. clear B. intros * EQ. - now dependent induction EQ. + now inversion EQ. Qed. - Lemma ask_invT : forall E X Y e1 e2, @ask E X e1 = @ask E Y e2 -> X = Y. + Lemma ask_invT : forall E Y Z e1 e2, @ask E X Y e1 = @ask E X Z e2 -> Y = Z. intros * EQ. now dependent induction EQ. Qed. - Lemma ask_inv : forall E X e1 e2, @ask E X e1 = @ask E X e2 -> e1 = e2. + Lemma ask_inv : forall E Y e1 e2, @ask E X Y e1 = @ask E X Y e2 -> e1 = e2. intros * EQ. now dependent induction EQ. Qed. - Lemma rcv_invT : forall E X Y e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E Y e2 v2 -> X = Y. + Lemma rcv_invT : forall E Y Z e1 e2 v1 v2, @rcv E X Y e1 v1 = @rcv E X Z e2 v2 -> Y = Z. intros * EQ. now dependent induction EQ. Qed. - Lemma rcv_inv : forall E X e1 e2 v1 v2, @rcv E X e1 v1 = @rcv E X e2 v2 -> e1 = e2 /\ v1 = v2. + Lemma rcv_inv : forall E Y e1 e2 v1 v2, @rcv E X Y e1 v1 = @rcv E X Y e2 v2 -> e1 = e2 /\ v1 = v2. intros * EQ. now dependent induction EQ. Qed. @@ -826,7 +826,7 @@ Structural rules Ad-hoc rules for pre-defined finite branching |*) - Variable (l : @label E) (t t' u v w : ctree E B X). + Variable (l : @label E X) (t t' u v w : ctree E B X). Context `{B2 -< B} `{B3 -< B} `{B4 -< B}. Lemma trans_br2_inv : @@ -885,8 +885,8 @@ I'll skip them for now and introduce them if they turn out to be useful. |*) - Lemma trans_val_inv' {Y} : - forall t u (x : Y), + Lemma trans_val_inv' : + forall t u (x : X), trans (val x) t u -> Seq u (α (Stuck : ctree E B X)). Proof. @@ -897,8 +897,8 @@ useful. all: eauto. Qed. - Lemma trans_val_inv {Y} : - forall (t u : ctree E B X) (x : Y), + Lemma trans_val_inv : + forall (t u : ctree E B X) (x : X), trans (val x) t u -> u ≅ Stuck. Proof. @@ -1197,6 +1197,13 @@ Section not_stuck. rewrite <- EQ in TR; red; eauto. Qed. + #[global] Instance equ_not_stuck : Proper (equ eq ==> iff) not_stuck. + Proof. + intros ? ? EQ; split; intros (l' & t' & TR). + rewrite EQ in TR; red; eauto. + rewrite <- EQ in TR; red; eauto. + Qed. + (* Converse is classically true *) Lemma not_stuck_is_stuck : forall t, not_stuck t -> ~ is_stuck t. @@ -1216,6 +1223,12 @@ Section not_stuck. red; eauto. Qed. + Lemma step_not_stuck t: + not_stuck (Step t). + Proof. + red; eauto. + Qed. + Lemma passive_not_stuck {Y} `{Inhabited Y} (e : E Y) k: not_stuck (β e k). Proof. @@ -1324,12 +1337,15 @@ trans (val x) t stuck -> trans l (k x) u -> trans l (bind t k) u. |*) Lemma trans_bind_inv {E B X Y} - (t : ctree E B X) (k : X -> ctree E B Y) u l : - trans l (t >>= k) u -> - (l = τ /\ exists t', trans l t (α t') /\ Seq u (α t' >>= k)) \/ - (exists Z (e : E Z), l = ask e /\ - exists (g : Z -> ctree E B X), trans l t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ - (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). + (t : ctree E B X) (k : X -> ctree E B Y) + u (l : label E Y) : + trans l (t >>= k) u -> + (l = τ /\ exists t', trans τ t (α t') /\ Seq u (α t' >>= k)) \/ + (exists Z (e : E Z), + l = ask e /\ + exists (g : Z -> ctree E B X), + trans (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (exists (x : X), trans (val x) t Stuck /\ trans l (k x) u). Proof. intros TR. rem_weak (α x <- t ;; k x) as ob. @@ -1357,7 +1373,7 @@ Proof. right; right. exists y; split; auto. rewrite EQ1; eauto. - + - intros ? EQ. inv EQ. rewrite EQ0 in H. @@ -1501,9 +1517,9 @@ Forward and backward rules for [wtrans] w.r.t. [bind] Lemma etrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : etrans l (t >>= k) u -> - (l = τ /\ exists t', etrans l t (α t') /\ Seq u (t' >>= k)) \/ + (l = τ /\ exists t', etrans τ t (α t') /\ Seq u (t' >>= k)) \/ (exists Z (e : E Z), l = ask e /\ - exists (g : Z -> ctree E B X), trans l t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + exists (g : Z -> ctree E B X), trans (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ (exists (x : X), trans (val x) t Stuck /\ etrans l (k x) u). Proof. intros TR. @@ -1560,10 +1576,11 @@ the last visible state reached by [wtrans] and add a [trans (val _)] afterward. |*) Lemma wtrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : wtrans l (t >>= k) u -> - (l = τ /\ exists t', wtrans l t (α t') /\ Seq u (t' >>= k)) \/ - (exists Y (e : E Y), l = ask e /\ exists g, wtrans l t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (l = τ /\ exists t', wtrans τ t (α t') /\ Seq u (t' >>= k)) \/ + (exists Y (e : E Y), l = ask e /\ exists g, wtrans (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ (exists (x : X), wtrans (val x) t Stuck /\ wtrans l (k x) u) \/ - (exists (x : X) s, wtrans l t s /\ trans (val x) s Stuck /\ wtrans τ (k x) u). + (exists (x : X) s, l = τ /\ wtrans τ t s /\ trans (val x) s Stuck /\ wtrans τ (k x) u) \/ + (exists Y (e : E Y) (x : X) s, l = ask e /\ wtrans (ask e) t s /\ trans (val x) s Stuck /\ wtrans τ (k x) u). Proof. intros TR. destruct TR as [t2 [t1 step1 step2] step3]. @@ -1576,10 +1593,10 @@ Proof. * left; split; auto. eexists; split. 2:apply EQ3. exists (α u2); [exists (α u1) |]; auto. - * right; right; right. + * right; right; right; left. apply wtrans_val_inv in TR3 as (u3 & TR2' & TR2''). exists x, u3. - split; [|split]; auto. + repeat split; auto. 2:apply wtrans_τ; auto. exists (α u2); [exists (α u1) |]; auto. apply wtrans_τ; apply wtrans_τ in TR1. @@ -1978,15 +1995,10 @@ Qed. (* apply trans_wtrans; auto. *) (* Qed. *) -Lemma trans_val_invT {E B R R'} : - forall t u (v : R'), - @trans E B R (val v) t u -> - R = R'. -Proof. - intros * TR. - remember (val v) as ov. - induction TR; intros; auto; try now inv Heqov. -Qed. +(* [trans_val_invT] is no longer needed: with [label] now indexed by + the return type [R], the equality [R = R'] it used to extract is + enforced by typing. Callers that relied on it can simply drop the + surrounding [apply trans_val_invT ... ; subst] step. *) (* Lemma wtrans_bind_lr {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) (v : ctree E B Y) x l : *) (* pwtrans l t u -> *) @@ -2051,7 +2063,7 @@ Qed. Lemma trans_branch : forall {E B : Type -> Type} {X : Type} {Y : Type} - [l : label E] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y), + [l : label E X] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y), trans l (k x) t' -> trans l (branch c >>= k) t'. Proof. @@ -2288,7 +2300,7 @@ Section build_rel. Rrcv: forall [X Y] (e : E X) (f : F Y), X -> Y -> Prop ; }. - Variant build_rel {RL : lrel} : hrel (label E) (label F) := + Variant build_rel {RL : lrel} : hrel (label E X) (label F Y) := | rel_τ : build_rel τ τ | rel_ask {X Y} {e : E X} {f : F Y} (HR : Rask RL e f) : @@ -2420,6 +2432,17 @@ Proof. intros f e; split; cbn; intros []; constructor; auto. Qed. +Lemma lequiv_sub_lrel {E F X Y} (L L' : lrel E F X Y): + sub_lrel L L' -> + sub_lrel (flipL L) (flipL L'). +Proof. + intros (EQV & EQA & EQR). + split3. + now cbn; intros; apply EQV. + now cbn; intros; apply EQA. + now cbn; intros; apply EQR. +Qed. + Lemma lequiv_flipL {E F X Y} (L L' : lrel E F X Y): lequiv L L' -> lequiv (flipL L) (flipL L'). @@ -2488,3 +2511,19 @@ Proof. now apply H. Qed. +#[global] Instance Leq_equiv {E X} : Equivalence (build_rel (@Leq E X)). +Proof. + split. + - intros []; try now constructor. + - intros ?? H. + inv H; try now constructor. + cbn in HR. + dependent induction HR; now constructor. + dependent induction HR; now constructor. + - intros ??? H1 H2. + dependent induction H1; dependent induction H2; try now constructor. + dependent induction HR; dependent induction HR0; now constructor. + dependent induction HR; dependent induction HR0; now constructor. + cbn in *; subst; now constructor. +Qed. + diff --git a/theories/Core/Utils.v b/theories/Utils/Utils.v similarity index 97% rename from theories/Core/Utils.v rename to theories/Utils/Utils.v index a114da7..2845961 100644 --- a/theories/Core/Utils.v +++ b/theories/Utils/Utils.v @@ -5,7 +5,8 @@ From Stdlib Require Import Fin. From Stdlib Require Export Program.Equality. From Coinduction Require Import all. From ITree Require Import Basics.Basics. - +From CTree Require Export coinduction_addon. + Notation fin := Fin.t. Polymorphic Class MonadTrigger (E : Type -> Type) (M : Type -> Type) : Type := @@ -21,7 +22,7 @@ Polymorphic Class MonadStuck (M : Type -> Type) : Type := mstuck : forall X, M X. Notation rel X Y := (X -> Y -> Prop). -Notation rel1 E F := (forall X Y, E X -> E Y -> Prop). +Notation rel1 E F := (forall X Y, E X -> F Y -> Prop). Ltac invert := match goal with diff --git a/theories/Utils/coinduction_addon.v b/theories/Utils/coinduction_addon.v new file mode 100644 index 0000000..1402c24 --- /dev/null +++ b/theories/Utils/coinduction_addon.v @@ -0,0 +1,34 @@ +(* +Convenience to step/unstep in relations built using the coinduction library. +Hopefully upstreamed eventually: https://github.com/damien-pous/coinduction/pull/22 + *) + +From Coinduction Require Import all. + +Lemma pfp_gfp {X : Type} {L : CompleteLattice X} (b : mon X) : b (gfp b) <= gfp b. +Proof. apply b_chain. Qed. + +Ltac step := +match goal with +| |- context [gfp ?b] => apply (pfp_gfp b) +| |- context [elem ?R] => apply (b_chain R) +end. + +Ltac step_in h := +match type of h with +| context [gfp ?b] => apply (gfp_pfp b) in h +end. + +Tactic Notation "step" "in" ident(h) := step_in h. + +Ltac unstep := +match goal with +| |- context [gfp ?b] => apply (gfp_pfp b) +end. + +Ltac unstep_in h := +match type of h with +| context [gfp ?b] => apply (pfp_gfp b) in h +end. + +Tactic Notation "unstep" "in" ident(h) := unstep_in h. From 84204223d862a76924dd4f6c83cc8022dc30e5f4 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 16 Apr 2026 11:44:21 +0200 Subject: [PATCH 24/61] Finished proof rules. Not the worst state, but some thought should sitll be put in automation and notations --- theories/Eq/SBisim_draft.v | 426 ++++++++++++++++++++++++++----------- theories/Utils/Utils.v | 1 + 2 files changed, 300 insertions(+), 127 deletions(-) diff --git a/theories/Eq/SBisim_draft.v b/theories/Eq/SBisim_draft.v index d3491fc..2e33797 100644 --- a/theories/Eq/SBisim_draft.v +++ b/theories/Eq/SBisim_draft.v @@ -736,7 +736,7 @@ Same three-layer shape as in [SSim.v] / [CSSim.v]: - [sb_*]: body-level, on a chain element [`R]; - [sbisim_*]: gfp-level. |*) -Section Proof_Rules. +Section Proof_rules. Context {E F C D : Type -> Type} {X Y : Type}. @@ -752,7 +752,7 @@ Section Proof_Rules. Lemma sbisim_is_stuck L : forall (t : ctree E C X) (u : ctree F D Y), - sbisim L t u -> is_stuck t <-> is_stuck u. + t (≃ L) u -> is_stuck t <-> is_stuck u. Proof. intros * SB; step in SB; eauto using sb_is_stuck. Qed. @@ -768,7 +768,7 @@ Section Proof_Rules. Lemma is_stuck_sbisim L : forall (t : ctree E C X) (u : ctree F D Y), - is_stuck t -> is_stuck u -> sbisim L t u. + is_stuck t -> is_stuck u -> t (≃ L) u. Proof. intros; step; auto using is_stuck_sb. Qed. @@ -805,7 +805,7 @@ Section Proof_Rules. Lemma sbisim_ret (x : X) (y : Y) L : RR L x y -> - sbisim L (Ret x : ctree E C X) (Ret y : ctree F D Y). + (Ret x : ctree E C X) (≃ L) (Ret y : ctree F D Y). Proof. intros; step; now apply sb_ret. Qed. @@ -849,9 +849,9 @@ Section Proof_Rules. Lemma sbisim_vis {Z Z'} (e : E Z) (f : F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L (HRask : Rask L e f) - (HRfwd : forall x, exists y, sbisim L (k x) (k' y) /\ Rrcv L e f x y) - (HRbwd : forall y, exists x, sbisim L (k x) (k' y) /\ Rrcv L e f x y) : - sbisim L (Vis e k) (Vis f k'). + (HRfwd : forall x, exists y, (k x) (≃ L) (k' y) /\ Rrcv L e f x y) + (HRbwd : forall y, exists x, (k x) (≃ L) (k' y) /\ Rrcv L e f x y) : + (Vis e k) (≃ L) (Vis f k'). Proof. now step; apply sb_vis. Qed. @@ -870,8 +870,8 @@ Section Proof_Rules. Lemma sbisim_vis_id {Z} (e : E Z) (f : F Z) (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L (HRask : Rask L e f) - (HRrcv : forall z, sbisim L (k z) (k' z) /\ Rrcv L e f z z) : - sbisim L (Vis e k) (Vis f k'). + (HRrcv : forall z, (k z) (≃ L) (k' z) /\ Rrcv L e f z z) : + (Vis e k) (≃ L) (Vis f k'). Proof. now step; apply sb_vis_id. Qed. @@ -964,9 +964,9 @@ Section Proof_Rules. Lemma sbisim_br {A B} (c : C A) (d : D B) (k : A -> ctree E C X) (k' : B -> ctree F D Y) L : - (forall x, exists y, sbisim L (k x) (k' y)) -> - (forall y, exists x, sbisim L (k x) (k' y)) -> - sbisim L (Br c k) (Br d k'). + (forall x, exists y, (k x) (≃ L) (k' y)) -> + (forall y, exists x, (k x) (≃ L) (k' y)) -> + (Br c k) (≃ L) (Br d k'). Proof. intros H1 H2; step; apply sb_br; eauto. intros x; destruct (H1 x); eexists; step in H; eauto. @@ -975,8 +975,8 @@ Section Proof_Rules. Lemma sbisim_br_id {A} (c : C A) (d : D A) (k : A -> ctree E C X) (k' : A -> ctree F D Y) L : - (forall x, sbisim L (k x) (k' x)) -> - sbisim L (Br c k) (Br d k'). + (forall x, (k x) (≃ L) (k' x)) -> + (Br c k) (≃ L) (Br d k'). Proof. intros; step; apply sb_br_id; eauto. intros x; specialize (H x); step in H; auto. @@ -984,8 +984,8 @@ Section Proof_Rules. Lemma sbisim_br_l {Z} (c : C Z) (x : Z) (k : Z -> ctree E C X) (t : ctree F D Y) L : - (forall z, sbisim L (k z) t) -> - sbisim L (Br c k) t. + (forall z, (k z) (≃ L) t) -> + (Br c k) (≃ L) t. Proof. intros; step; apply sb_br_l; eauto. intros y; specialize (H y); step in H; auto. @@ -993,119 +993,204 @@ Section Proof_Rules. Lemma sbisim_br_r {Z} (d : D Z) (y : Z) (k : Z -> ctree F D Y) (t : ctree E C X) L : - (forall z, sbisim L t (k z)) -> - sbisim L t (Br d k). + (forall z, t (≃ L) (k z)) -> + t (≃ L) (Br d k). Proof. intros; step; apply sb_br_r; eauto. intros x; specialize (H x); step in H; auto. Qed. - (* CHECKPOINT *) (*| Guard — a silent wrapper; absorbed by [≃]. |*) Lemma sb_guard_l_gen (t : ctree E C X) (u : ctree F D Y) R L : sb L R t u -> sb L R (Guard t) u. Proof. - + intros EQ. + play; inv_trans; eplay; answer. + Qed. Lemma sb_guard_l (t : ctree E C X) (u : ctree F D Y) L {R : Chain (@sb E F C D X Y L)} : sb L `R t u -> sb L `R (Guard t) u. - Admitted. - + Proof. + apply sb_guard_l_gen. + Qed. + Lemma sbisim_guard_l (t : ctree E C X) (u : ctree F D Y) L : - sbisim L t u -> sbisim L (Guard t) u. - Admitted. - + t (≃ L) u -> (Guard t) (≃ L) u. + Proof. + intros H; step in H; step; apply sb_guard_l_gen; auto. + Qed. + Lemma sb_guard_r_gen (t : ctree E C X) (u : ctree F D Y) R L : sb L R t u -> sb L R t (Guard u). - Admitted. + Proof. + intros EQ. + play; inv_trans; eplay; answer. + Qed. Lemma sb_guard_r (t : ctree E C X) (u : ctree F D Y) L {R : Chain (@sb E F C D X Y L)} : sb L `R t u -> sb L `R t (Guard u). - Admitted. - + Proof. + apply sb_guard_r_gen. + Qed. + Lemma sbisim_guard_r (t : ctree E C X) (u : ctree F D Y) L : - sbisim L t u -> sbisim L t (Guard u). - Admitted. + t (≃ L) u -> t (≃ L) (Guard u). + Proof. + intros H; step in H; step; apply sb_guard_r_gen; auto. + Qed. + + Lemma sb_gguard_gen (t : ctree E C X) (u : ctree F D Y) R L : + sb L R t u -> sb L R (Guard t) (Guard u). + Proof. + intros EQ. + play; inv_trans; eplay; answer. + Qed. - Lemma sbisim_guard (t : ctree E C X) (u : ctree F D Y) L : - sbisim L t u -> sbisim L (Guard t) (Guard u). - Admitted. + Lemma sb_gguard (t : ctree E C X) (u : ctree F D Y) L + {R : Chain (@sb E F C D X Y L)} : + sb L `R t u -> sb L `R (Guard t) (Guard u). + Proof. + apply sb_gguard_gen. + Qed. + + Lemma sbisim_gguard (t : ctree E C X) (u : ctree F D Y) L : + t (≃ L) u -> (Guard t) (≃ L) (Guard u). + Proof. + intros H; step in H; step; apply sb_gguard_gen; auto. + Qed. (*| Internal transitions — [Step]. |*) Lemma sb_step_gen (t : ctree E C X) (u : ctree F D Y) R L : - (Proper (Seq ==> Seq ==> impl) R) -> - L τ τ -> + Proper (Seq ==> Seq ==> impl) R -> + Proper (Seq ==> Seq ==> flip impl) R -> R (α t) (α u) -> sb L R (Step t) (Step u). - Admitted. + Proof. + split; apply ss_step_gen; eauto; typeclasses eauto. + Qed. Lemma sb_step (t : ctree E C X) (u : ctree F D Y) L {R : Chain (@sb E F C D X Y L)} : - L τ τ -> `R t u -> sb L `R (Step t) (Step u). - Admitted. + Proof. + intros. + apply sb_step_gen; eauto; typeclasses eauto. + Qed. Lemma sbisim_step (t : ctree E C X) (u : ctree F D Y) L : - L τ τ -> - sbisim L t u -> - sbisim L (Step t) (Step u). - Admitted. + t (≃ L) u -> + (Step t) (≃ L) (Step u). + Proof. + intros. step. apply sb_step; auto. + Qed. (*| Visible branching — [BrS]. |*) + Lemma sb_brS_gen {Z Z'} (c : C Z) (d : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) R L : + Proper (Seq ==> Seq ==> impl) R -> + Proper (Seq ==> Seq ==> flip impl) R -> + (forall x, exists y, R (α (k x)) (α (k' y))) -> + (forall y, exists x, R (k x) (k' y)) -> + sb L R (BrS c k) (BrS d k'). + Proof. + intros ? ? EQs1 EQs2. + apply sb_br_gen; intros x. + - destruct (EQs1 x) as [z ?]; exists z. + apply sb_step_gen; auto. + - destruct (EQs2 x) as [z ?]. exists z. + apply sb_step_gen; eauto. + Qed. + + Lemma sb_brS_id_gen {X'} (c : C X') (d: D X') + (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) (R : rel _ _) L: + Proper (Seq ==> Seq ==> impl) R -> + Proper (Seq ==> Seq ==> flip impl) R -> + (forall x, R (k x) (k' x)) -> + sb L R (BrS c k) (BrS d k'). + Proof. + intros ?? EQs. + split; apply sb_br_id_gen; intros; apply sb_step_gen; auto. + Qed. + Lemma sb_brS {Z Z'} (c : C Z) (d : D Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L {R : Chain (@sb E F C D X Y L)} : - L τ τ -> (forall x, exists y, `R (k x) (k' y)) -> (forall y, exists x, `R (k x) (k' y)) -> sb L `R (BrS c k) (BrS d k'). - Admitted. - - Lemma sbisim_brS {Z Z'} (c : C Z) (d : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L : - L τ τ -> - (forall x, exists y, sbisim L (k x) (k' y)) -> - (forall y, exists x, sbisim L (k x) (k' y)) -> - sbisim L (BrS c k) (BrS d k'). - Admitted. - + Proof. + intros; apply sb_brS_gen; auto; typeclasses eauto. + Qed. + Lemma sb_brS_id {Z} (c : C Z) (d : D Z) (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L {R : Chain (@sb E F C D X Y L)} : - L τ τ -> (forall x, `R (k x) (k' x)) -> sb L `R (BrS c k) (BrS d k'). - Admitted. + Proof. + intros; apply sb_brS_id_gen; auto; typeclasses eauto. + Qed. + Lemma sbisim_brS {Z Z'} (c : C Z) (d : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) L : + (forall x, exists y, (k x) (≃ L) (k' y)) -> + (forall y, exists x, (k x) (≃ L) (k' y)) -> + (BrS c k) (≃ L) (BrS d k'). + Proof. + intros; step; apply sb_brS; auto. + Qed. + Lemma sbisim_brS_id {Z} (c : C Z) (d : D Z) (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) L : - L τ τ -> - (forall x, sbisim L (k x) (k' x)) -> - sbisim L (BrS c k) (BrS d k'). - Admitted. - + (forall x, (k x) (≃ L) (k' x)) -> + BrS c k (≃ L ) BrS d k'. + Proof. + intros; step; apply sb_brS_id; auto. + Qed. + (*| [spinS] laws. |*) - Lemma sbisim_spinS_nonempty : - forall {Z Z'} L (x : Z) (y : Z') (c : C Z) (c' : D Z'), - L τ τ -> - @sbisim E F C D X Y L (spinS_gen c) (spinS_gen c'). - Admitted. + Lemma spinS_gen_nonempty : + forall (L : lrel E F X Y) {Z Z'} (c: C Z) (c': D Z') (z: Z) (z': Z'), + @spinS_gen E C X Z c (≃ L ) @spinS_gen F D Y Z' c'. + Proof. + intros * ??. + coinduction S CIH. + rewrite (ctree_eta (spinS_gen c)), (ctree_eta (spinS_gen c')); cbn. + apply sb_brS; intros _; eauto. + Qed. Lemma sbisim_spinS_empty : forall L (c : C False) (c' : D False), @sbisim E F C D X Y L (spinS_gen c) (spinS_gen c'). - Admitted. + Proof. + intros. + eapply is_stuck_sbisim. + intros ?? TR; rewrite ctree_eta in TR; cbn in TR; now inv_trans. + intros ?? TR; rewrite ctree_eta in TR; cbn in TR; now inv_trans. + Qed. + +End Proof_rules. + +Lemma sbisim_guard {E C X} (t : ctree E C X) : + Guard t ≃ t. +Proof. + now apply sbisim_guard_l. +Qed. + +Section Inversion_rules. + + Context {E F C D : Type -> Type} {X Y : Type}. (*| Inversion principles @@ -1113,104 +1198,191 @@ Inversion principles |*) Lemma sbisim_stuck_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L t u -> is_stuck t <-> is_stuck u. - Admitted. - + t (≃ L) u -> is_stuck t <-> is_stuck u. + Proof. + intros SB; split; intros IS ?? tr; eplay; eapply IS; eauto. + Qed. + Lemma sbisim_ret_l_inv L : forall r (u : ctree F D Y), - sbisim L (Ret r : ctree E C X) u -> + (Ret r : ctree E C X) (≃ L) u -> exists r' u', trans (val r') u u' /\ RR L r r'. - Admitted. + Proof. + intros. + eplayL. + invL. + etrans. + Qed. Lemma sbisim_ret_r_inv L : forall r' (t : ctree E C X), - sbisim L t (Ret r' : ctree F D Y) -> + t (≃ L) (Ret r' : ctree F D Y) -> exists r t', trans (val r) t t' /\ RR L r r'. - Admitted. + Proof. + intros. + eplayR. + invL. + etrans. + Qed. Lemma sbisim_ret_inv L (r : X) (r' : Y) : - sbisim L (Ret r : ctree E C X) (Ret r' : ctree F D Y) -> + (Ret r : ctree E C X) (≃ L) (Ret r' : ctree F D Y) -> RR L r r'. - Admitted. + Proof. + intro. + eplayL. + invL. + inv_trans. + now subst. + Qed. Lemma sbisim_vis_l_inv {Z L} : - forall (e : E Z) (k : Z -> ctree E C X) u, - sbisim L (Vis e k) u -> + forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y), + (Vis e k) (≃ L) u -> exists Z' (f : F Z') k', trans (ask f) u (β f k') /\ Rask L e f /\ - (forall x, exists y, sbisim L (k x) (k' y) /\ Rrcv L e f x y) /\ - (forall y, exists x, sbisim L (k x) (k' y) /\ Rrcv L e f x y). - Admitted. + (forall x, exists y, (k x) (≃ L) (k' y) /\ Rrcv L e f x y) /\ + (forall y, exists x, (k x) (≃ L) (k' y) /\ Rrcv L e f x y). + Proof. + intros. + eplayL; invL. + refine_trans in TR. + ex3; split4; eauto. + - intros x. + step in EQ. + edestruct EQ as [(? & ? & ? & ? & ?) _]; unshelve etrans; eauto. + inv_trans; invL; eauto. + - intros x. + step in EQ. + edestruct EQ as [_ (? & ? & ? & ? & ?)]; unshelve etrans; eauto. + inv_trans; invL; eauto. + Qed. + + Lemma sbisim_vis_r_inv {Z L} : + forall (t : ctree E C X) (f : F Z) (k' : Z -> ctree F D Y), + t (≃ L) (Vis f k') -> + exists Z' (e : E Z') k, + trans (ask e) t (β e k) /\ + Rask L e f /\ + (forall x, exists y, (k x) (≃ L) (k' y) /\ Rrcv L e f x y) /\ + (forall y, exists x, (k x) (≃ L) (k' y) /\ Rrcv L e f x y). + Proof. + intros. + eplayR; invL. + refine_trans in TR. + ex3; split4; eauto. + - intros x. + step in EQ. + edestruct EQ as [(? & ? & ? & ? & ?) _]; unshelve etrans; eauto. + inv_trans; invL; eauto. + - intros x. + step in EQ. + edestruct EQ as [_ (? & ? & ? & ? & ?)]; unshelve etrans; eauto. + inv_trans; invL; eauto. + Qed. Lemma sbisim_vis_inv {Z Z'} L (e : E Z) (f : F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : - sbisim L (Vis e k) (Vis f k') -> + (Vis e k) (≃ L) (Vis f k') -> Rask L e f /\ - (forall x, exists y, Rrcv L e f x y /\ sbisim L (k x) (k' y)) /\ - (forall y, exists x, Rrcv L e f x y /\ sbisim L (k x) (k' y)). - Admitted. - - Lemma sbisim_vis_invT {Z Z'} L - (e : E Z) (f : F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) (x : Z) : - sbisim L (Vis e k) (Vis f k') -> Rask L e f. - Admitted. + (forall x, exists y, Rrcv L e f x y /\ (k x) (≃ L) (k' y)) /\ + (forall y, exists x, Rrcv L e f x y /\ (k x) (≃ L) (k' y)). + Proof. + intros. + eplayL; invL. + inv_trans. + dependent destruction EQl. + split3; auto. + - intros x. + step in EQ. + edestruct EQ as [(? & ? & ? & ? & ?) _]; unshelve etrans; eauto. + inv_trans; invL; eauto. + - intros x. + step in EQ. + edestruct EQ as [_ (? & ? & ? & ? & ?)]; unshelve etrans; eauto. + inv_trans; invL; eauto. + Qed. Lemma sbisim_guard_l_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L (Guard t) u -> sbisim L t u. - Admitted. - + (Guard t) (≃ L) u -> t (≃ L) u. + Proof. + intros. + now rewrite sbisim_guard in H. + Qed. + Lemma sbisim_guard_r_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L t (Guard u) -> sbisim L t u. - Admitted. + t (≃ L) (Guard u) -> t (≃ L) u. + Proof. + intros. + now rewrite sbisim_guard in H. + Qed. Lemma sbisim_guard_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L (Guard t) (Guard u) -> sbisim L t u. - Admitted. - - Lemma sbisim_br_l_inv L Z - (c : C Z) (t : ctree F D Y) (k : Z -> ctree E C X) : - sbisim L (Br c k) t -> - forall x, sbisim L (k x) t. - Admitted. - - Lemma sbisim_br_r_inv L Z - (d : D Z) (t : ctree E C X) (k : Z -> ctree F D Y) : - sbisim L t (Br d k) -> - forall y, sbisim L t (k y). - Admitted. + (Guard t) (≃ L) (Guard u) -> t (≃ L) u. + Proof. + intros. + now rewrite !sbisim_guard in H. + Qed. Lemma sbisim_step_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L (Step t) (Step u) -> sbisim L t u. - Admitted. - + (Step t) (≃ L) (Step u) -> t (≃ L) u. + Proof. + intros. + now eplay; inv_trans; invL. + Qed. + Lemma sbisim_step_l_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L (Step t) u -> - exists u', trans τ u u' /\ sbisim L t u'. - Admitted. + (Step t) (≃ L) u -> + exists u', trans τ u u' /\ t (≃ L) u'. + Proof. + intros. + eplayL. invL. + eexists; split; eauto. + Qed. Lemma sbisim_step_r_inv L (t : ctree E C X) (u : ctree F D Y) : - sbisim L t (Step u) -> - exists t', trans τ t t' /\ sbisim L t' u. - Admitted. + t (≃ L) (Step u) -> + exists t', trans τ t t' /\ t' (≃ L) u. + Proof. + intros. + eplayR. invL. + eexists; split; eauto. + Qed. Lemma sbisim_brS_inv L {A B} (c : C A) (d : D B) (k1 : A -> ctree E C X) (k2 : B -> ctree F D Y) : - sbisim L (BrS c k1) (BrS d k2) -> - (forall a, exists b, sbisim L (k1 a) (k2 b)) /\ - (forall b, exists a, sbisim L (k1 a) (k2 b)). - Admitted. - + (BrS c k1) (≃ L) (BrS d k2) -> + (forall a, exists b, (k1 a) (≃ L) (k2 b)) /\ + (forall b, exists a, (k1 a) (≃ L) (k2 b)). + Proof. + intros. + split; intros. + - unshelve eplayL; auto; inv_trans; invL; eauto. + - unshelve eplayR; auto; inv_trans; invL; eauto. + Qed. + Lemma sbisim_brS_l_inv L {A} (c : C A) (k1 : A -> ctree E C X) (u : ctree F D Y) : - sbisim L (BrS c k1) u -> - forall a, exists u', trans τ u u' /\ sbisim L (k1 a) u'. - Admitted. + (BrS c k1) (≃ L) u -> + forall a, exists u', trans τ u u' /\ (k1 a) (≃ L) u'. + Proof. + intros. + unshelve eplayL; auto; inv_trans; invL; eauto. + Qed. + + Lemma sbisim_brS_r_inv L + {B} (d : D B) (k2 : B -> ctree F D Y) (t : ctree E C X) : + t (≃ L) (BrS d k2) -> + forall b, exists t', trans τ t t' /\ t' (≃ L) (k2 b). + Proof. + intros. + unshelve eplayR; auto; inv_trans; invL; eauto. + Qed. -End Proof_Rules. +End Inversion_rules. (*| Sanity checks and structural laws (homogeneous). diff --git a/theories/Utils/Utils.v b/theories/Utils/Utils.v index 2845961..28d0a41 100644 --- a/theories/Utils/Utils.v +++ b/theories/Utils/Utils.v @@ -117,6 +117,7 @@ Ltac ex := eexists. Ltac ex2 := do 2 eexists. Ltac ex3 := do 3 eexists. Ltac split3 := split; [| split]. +Ltac split4 := split; [| split; [| split]]. Ltac edestruct3 H := edestruct H as (? & ? & ?). Ltac edestruct4 H := edestruct H as (? & ? & ? & ?). Ltac edestruct5 H := edestruct H as (? & ? & ? & ? & ?). From 01729d3d54b7e4442ccb07fbd7e606d316af45cf Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 16 Apr 2026 13:12:25 +0200 Subject: [PATCH 25/61] elementary laws --- theories/Eq/SBisim_draft.v | 81 ++++++++++++++++++++++++++++-------- theories/Eq/Trans.v | 84 ++++++++++++++++++++++++-------------- 2 files changed, 117 insertions(+), 48 deletions(-) diff --git a/theories/Eq/SBisim_draft.v b/theories/Eq/SBisim_draft.v index 2e33797..815439c 100644 --- a/theories/Eq/SBisim_draft.v +++ b/theories/Eq/SBisim_draft.v @@ -1393,57 +1393,102 @@ Section WithParams. Context {HasC2 : B2 -< C}. Context {HasC3 : B3 -< C}. - Lemma spin_bisim : forall {Z1 Z2} (c : C Z1) (c' : C Z2), - @spin_gen E C Z1 Z1 c ≃ @spin_gen E C Z2 Z2 c'. - Admitted. - + Lemma spin_bisim : forall {D R X Y} (c : C X) (c' : D Y), + @spin_gen E C R X c ≃ @spin_gen E D R Y c'. + Proof. + intros. + play; exfalso; eapply spin_gen_is_stuck; eauto. + Qed. + Lemma br2_assoc {X} : forall (t u v : ctree E C X), br2 (br2 t u) v ≃ br2 t (br2 u v). - Admitted. + Proof. + intros; play; inv_trans; answer. + Qed. Lemma br2_commut {X} : forall (t u : ctree E C X), br2 t u ≃ br2 u t. - Admitted. + Proof. + intros; play; inv_trans; answer. + Qed. Lemma br2_idem {X} : forall (t : ctree E C X), br2 t t ≃ t. - Admitted. + Proof. + intros; play; inv_trans; answer. + Qed. Lemma br2_merge {X} : forall (t u v : ctree E C X), br2 (br2 t u) v ≃ br3 t u v. - Admitted. + Proof. + intros; play; inv_trans; answer. + Qed. Lemma br2_is_stuck {X} : forall (u v : ctree E C X), is_stuck u -> br2 u v ≃ v. - Admitted. - + Proof. + intros; play; inv_trans; answer. + (* todo: have inv_trans support stuck stepping *) + exfalso; eapply H; eauto. + Qed. + Lemma br2_stuck_l {X} : forall (t : ctree E C X), br2 Stuck t ≃ t. - Admitted. + Proof. + intros; play; inv_trans; answer. + (* todo: have inv_trans support stuck stepping *) + exfalso; eapply trans_stuck_inv; eauto. + Qed. Lemma br2_stuck_r {X} : forall (t : ctree E C X), br2 t Stuck ≃ t. - Admitted. + Proof. + intros; play; inv_trans; answer. + (* todo: have inv_trans support stuck stepping *) + exfalso; eapply trans_stuck_inv; eauto. + Qed. Lemma br2_spin_l {X} : forall (t : ctree E C X), br2 spin t ≃ t. - Admitted. + Proof. + intros; play; inv_trans; answer. + (* todo: have inv_trans support stuck stepping *) + exfalso; eapply spin_is_stuck; eauto. + Qed. Lemma br2_spin_r {X} : forall (t : ctree E C X), br2 t spin ≃ t. - Admitted. + Proof. + intros; play; inv_trans; answer. + (* todo: have inv_trans support stuck stepping *) + exfalso; eapply spin_is_stuck; eauto. + Qed. Lemma brS2_commut {X} : forall (t u : ctree E C X), brS2 t u ≃ brS2 u t. - Admitted. + Proof. + intros; play; + apply trans_brS2_inv' in TR as (-> & [EQ | EQ]); setoid_rewrite EQ; + (ex2; split3; [| eauto |]; etrans). + Qed. Lemma brS2_idem {X} : forall (t : ctree E C X), brS2 t t ≃ Step t. - Admitted. - + Proof. + intros; play. + - apply trans_brS2_inv' in TR as (-> & [EQ | EQ]); setoid_rewrite EQ; + ( ex2; split3; [| eauto |]; etrans). + - inv_trans; setoid_rewrite EQ; answer. + Qed. + Lemma sb_unfold_forever {X} : forall (k : X -> ctree E C X) (i : X), forever k i ≃ r <- k i ;; forever k r. - Admitted. + Proof. + intros. + rewrite unfold_forever. + apply sbisim_bind_eq; auto. + intros; now rewrite sbisim_guard. + Qed. End WithParams. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 3634277..004def5 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -567,25 +567,25 @@ Section BackwardBounded. now apply trans_br with t33. Qed. - Lemma trans_br31 : - trans l t t' -> - trans l (br3 t u v) t'. + Lemma trans_br31 x : + trans l t x -> + trans l (br3 t u v) x. Proof. intros * TR. now apply trans_br with t31. Qed. - Lemma trans_br32 : - trans l u u' -> - trans l (br3 t u v) u'. + Lemma trans_br32 x : + trans l u x -> + trans l (br3 t u v) x. Proof. intros * TR. now apply trans_br with t32. Qed. - Lemma trans_br33 : - trans l v v' -> - trans l (br3 t u v) v'. + Lemma trans_br33 x : + trans l v x -> + trans l (br3 t u v) x. Proof. intros * TR. now apply trans_br with t33. @@ -615,33 +615,33 @@ Section BackwardBounded. eapply trans_br with t44; eauto. Qed. - Lemma trans_br41 : - trans l t t' -> - trans l (br4 t u v w) t'. + Lemma trans_br41 x : + trans l t x -> + trans l (br4 t u v w) x. Proof. intros * TR. eapply trans_br with t41; eauto. Qed. - Lemma trans_br42 : - trans l u u' -> - trans l (br4 t u v w) u'. + Lemma trans_br42 x : + trans l u x -> + trans l (br4 t u v w) x. Proof. intros * TR. eapply trans_br with t42; eauto. Qed. - Lemma trans_br43 : - trans l v v' -> - trans l (br4 t u v w) v'. + Lemma trans_br43 x : + trans l v x -> + trans l (br4 t u v w) x. Proof. intros * TR. eapply trans_br with t43; eauto. Qed. - Lemma trans_br44 : - trans l w w' -> - trans l (br4 t u v w) w'. + Lemma trans_br44 x : + trans l w x -> + trans l (br4 t u v w) x. Proof. intros * TR. eapply trans_br with t44; eauto. @@ -826,17 +826,17 @@ Structural rules Ad-hoc rules for pre-defined finite branching |*) - Variable (l : @label E X) (t t' u v w : ctree E B X). + Variable (l : @label E X) (t u v w : ctree E B X). Context `{B2 -< B} `{B3 -< B} `{B4 -< B}. - Lemma trans_br2_inv : + Lemma trans_br2_inv t' : trans l (br2 t u) t' -> (trans l t t' \/ trans l u t'). Proof. intros * TR; apply trans_br_inv in TR as [[] TR]; auto. Qed. - Lemma trans_br3_inv : + Lemma trans_br3_inv t' : trans l (br3 t u v) t' -> (trans l t t' \/ trans l u t' \/ trans l v t'). Proof. @@ -844,7 +844,7 @@ Ad-hoc rules for pre-defined finite branching destruct n; auto. Qed. - Lemma trans_br4_inv : + Lemma trans_br4_inv t' : trans l (br4 t u v w) t' -> (trans l t t' \/ trans l u t' \/ trans l v t' \/ trans l w t'). Proof. @@ -852,7 +852,7 @@ Ad-hoc rules for pre-defined finite branching destruct n; auto. Qed. - Lemma trans_brS2_inv : + Lemma trans_brS2_inv (t': ctree _ _ _) : trans l (brS2 t u) t' -> (l = τ /\ (t' ≅ t \/ t' ≅ u)). Proof. @@ -860,7 +860,15 @@ Ad-hoc rules for pre-defined finite branching destruct x; auto. Qed. - Lemma trans_brS3_inv : + Lemma trans_brS2_inv' t' : + trans l (brS2 t u) t' -> + (l = τ /\ (Seq t' t \/ Seq t' u)). + Proof. + intros * TR; apply trans_brS_inv' in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. + + Lemma trans_brS3_inv (t': ctree _ _ _) : trans l (brS3 t u v) t' -> (l = τ /\ (t' ≅ t \/ t' ≅ u \/ t' ≅ v)). Proof. @@ -868,11 +876,19 @@ Ad-hoc rules for pre-defined finite branching destruct x; auto. Qed. - Lemma trans_brS4_inv : + Lemma trans_brS3_inv' t' : + trans l (brS3 t u v) t' -> + (l = τ /\ (Seq t' t \/ Seq t' u \/ Seq t' v)). + Proof. + intros * TR; apply trans_brS_inv' in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. + + Lemma trans_brS4_inv' t' : trans l (brS4 t u v w) t' -> - (l = τ /\ (t' ≅ t \/ t' ≅ u \/ t' ≅ v \/ t' ≅ w)). + (l = τ /\ (Seq t' t \/ Seq t' u \/ Seq t' v \/ Seq t' w)). Proof. - intros * TR; apply trans_brS_inv in TR as (? & TR & ->); split; auto. + intros * TR; apply trans_brS_inv' in TR as (? & TR & ->); split; auto. destruct x; auto. Qed. @@ -2236,6 +2252,14 @@ Ltac inv_trans_one := | h : htrans _ (α Br _ _) _ |- _ => let TR := fresh "TR" in apply trans_br_inv in h as (?n & TR) + + | h : htrans _ (α br2 _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br2_inv in h as [TR | TR] + + | h : htrans _ (α br3 _ _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br3_inv in h as [TR | [TR | TR]] (* Guard *) | h : htrans _ (α Guard _) _ |- _ => From 2f25152542c0bda8a51befc4c4e41cc078e795a6 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 16 Apr 2026 16:21:32 +0200 Subject: [PATCH 26/61] Incompatibility lemmas and a painful fix to tactics --- theories/Eq/SBisim_draft.v | 44 ++-- theories/Eq/Trans.v | 402 +++++++++++++++++++------------------ 2 files changed, 235 insertions(+), 211 deletions(-) diff --git a/theories/Eq/SBisim_draft.v b/theories/Eq/SBisim_draft.v index 815439c..757e333 100644 --- a/theories/Eq/SBisim_draft.v +++ b/theories/Eq/SBisim_draft.v @@ -96,9 +96,9 @@ Module SBisimNotations. Notation "t (≃ [ Q ] ) u" := (sbisim (Lvrel Q) t u) (at level 79). Notation "t (≃ L ) u" := (sbisim L t u) (at level 79). - Notation "t '[≃]' u" := (sb Leq (` _) t u) (at level 90, only printing). - Notation "t '[≃' [ R ] ']' u" := (sb (Lvrel R) (` _) t u) (at level 90, only printing). - Notation "t '[≃' R ']' u" := (sb R (` _) t u) (at level 90, only printing). + Notation "t '[≃]' u" := (sb Leq _ t u) (at level 90, only printing). + Notation "t '[≃' [ R ] ']' u" := (sb (Lvrel R) _ t u) (at level 90, only printing). + Notation "t '[≃' R ']' u" := (sb R _ t u) (at level 90, only printing). End SBisimNotations. @@ -146,7 +146,7 @@ Ltac fold_sbisim := Tactic Notation "__step_sbisim" := match goal with - | |- context[@sbisim ?E ?F ?C ?D ?X ?Y ?LR] => + | |- context[@sbisim ?E ?F ?C ?D ?X ?Y ?L] => unfold sbisim; step; fold (@sbisim E F C D X Y L) @@ -155,7 +155,7 @@ Tactic Notation "__step_sbisim" := Ltac __step_in_sbisim H := match type of H with - | context[@sbisim ?E ?F ?C ?D ?X ?Y ?LR] => + | context[@sbisim ?E ?F ?C ?D ?X ?Y ?L] => unfold sbisim in H; step in H; fold (@sbisim E F C D X Y L) in H @@ -1436,16 +1436,12 @@ Section WithParams. br2 Stuck t ≃ t. Proof. intros; play; inv_trans; answer. - (* todo: have inv_trans support stuck stepping *) - exfalso; eapply trans_stuck_inv; eauto. Qed. Lemma br2_stuck_r {X} : forall (t : ctree E C X), br2 t Stuck ≃ t. Proof. intros; play; inv_trans; answer. - (* todo: have inv_trans support stuck stepping *) - exfalso; eapply trans_stuck_inv; eauto. Qed. Lemma br2_spin_l {X} : forall (t : ctree E C X), @@ -1517,25 +1513,45 @@ Section Incompat. Lemma sbisim_absurd {X} (t u : ctree E C X) : are_bisim_incompat t u -> t ≃ u -> False. - Admitted. + Proof. + intros * IC EQ. + unfold are_bisim_incompat in IC. + setoid_rewrite ctree_eta in EQ. + genobs t ot. genobs u ou. + destruct ot, ou. + all: inv IC. + all: try now unshelve (playR in EQ; inv_trans); auto. + all: try now unshelve (playL in EQ; inv_trans); auto. + Qed. + + Ltac sb_abs h := + eapply sbisim_absurd; [| eassumption]; cbn; try reflexivity. Lemma sbisim_ret_vis_inv {X Y} (r : Y) (e : E X) (k : X -> ctree E C Y) : (Ret r : ctree E C _) ≃ Vis e k -> False. - Admitted. + Proof. + intros * abs. sb_abs abs. + Qed. Lemma sbisim_ret_BrS_inv {X Y} (r : Y) (c : C X) (k : X -> ctree E C Y) : (Ret r : ctree E C _) ≃ BrS c k -> False. - Admitted. + Proof. + intros EQ; playL in EQ; inv_trans; invL. + Qed. Lemma sbisim_vis_BrS_inv {X Y Z} (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2 : Y -> ctree E C Z) (y : Y) : Vis e k1 ≃ BrS c k2 -> False. - Admitted. + Proof. + unshelve (intros EQ; playR in EQ; inv_trans); auto; invL. + Qed. Lemma sbisim_vis_BrS_inv' {X Y Z} (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2 : Y -> ctree E C Z) (x : X) : Vis e k1 ≃ BrS c k2 -> False. - Admitted. + Proof. + unshelve (intros EQ; playL in EQ; inv_trans); auto; invL. + Qed. End Incompat. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 004def5..379fc95 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -2088,203 +2088,6 @@ Proof. eapply trans_br; eauto. Qed. -(* (*| *) -(* [wf_val] states that a [label] is well-formed: *) -(* if it is a [val] it should be of the right type. *) -(* |*) *) -(* Definition wf_val {E} X l := forall Y (v : Y), l = @val E Y v -> X = Y. *) - -(* Lemma wf_val_val {E} X (v : X) : wf_val X (@val E X v). *) -(* Proof. *) -(* red. intros. apply val_eq_invT in H. assumption. *) -(* Qed. *) - -(* Lemma wf_val_nonval {E} X (l : @label E) : ~is_val l -> wf_val X l. *) -(* Proof. *) -(* red. intros. subst. exfalso. apply H. constructor. *) -(* Qed. *) - -(* Lemma wf_val_trans {E B X} (l : @label E) t t' : *) -(* @trans E B X l t t' -> wf_val X l. *) -(* Proof. *) -(* red. intros. subst. *) -(* now apply trans_val_invT in H. *) -(* Qed. *) - -(* Lemma wf_val_is_val_inv : forall {E} X (l : @label E), *) -(* is_val l -> *) -(* wf_val (E := E) X l -> *) -(* exists (x : X), l = val x. *) -(* Proof. *) -(* intros. *) -(* destruct H. red in H0. *) -(* specialize (H0 X0 x eq_refl). subst. eauto. *) -(* Qed. *) - -(* (*| If the LTS has events of type [L +' R] then *) -(* it is possible to step it as either an [L] LTS *) -(* or [R] LTS ignoring the other. *) -(* *) *) -(* Section Coproduct. *) -(* Arguments label: clear implicits. *) -(* Context {L R C: Type -> Type} {X: Type}. *) -(* Notation S := (ctree (L +' R) C X). *) -(* Notation S' := (ctree' (L +' R) C X). *) -(* Notation SP := (SS -> label (L +' R) -> Prop). *) - -(* (* Skip an [R] event *) *) -(* Inductive srtrans_: rel S' S' := *) -(* | IgnoreR {X} (e : R X) k x t : *) -(* srtrans_ (observe (k x)) t -> *) -(* srtrans_ (VisF (inr1 e) k) t. *) - -(* (* Skip an [L] event *) *) -(* Inductive sltrans_: rel S' S' := *) -(* | IgnoreL {X} (e : L X) k x t : *) -(* sltrans_ (observe (k x)) t -> *) -(* sltrans_ (VisF (inl1 e) k) t. *) - -(* Hint Constructors srtrans_ sltrans_: core. *) - -(* (* Make those relations that respect equality [srel] *) *) -(* Program Definition srtrans : srel SS SS := *) -(* {| hrel_of := (fun (u v: SS) => srtrans_ (observe u) (observe v)) |}. *) -(* Next Obligation. split; induction 1; auto. Defined. *) - -(* Program Definition sltrans : srel SS SS := *) -(* {| hrel_of := (fun (u v: SS) => sltrans_ (observe u) (observe v)) |}. *) -(* Next Obligation. split; induction 1; auto. Defined. *) - -(* (*| Obs transition on the left, ignores right transitions and [τ] |*) *) -(* Definition ltrans {X}(l: L X)(x: X): srel SS SS := *) -(* (trans τ ⊔ srtrans)^* ⋅ trans (obs (inl1 l) x) ⋅ (trans τ ⊔ srtrans)^*. *) - -(* (*| Obs transition on the right, ignores left transitions and [τ] |*) *) -(* Definition rtrans {X}(r: R X)(x: X): srel SS SS := *) -(* (trans τ ⊔ sltrans)^* ⋅ trans (obs (inr1 r) x) ⋅ (trans τ ⊔ sltrans)^*. *) - -(* End Coproduct. *) - -#[global] Notation htrans l u v := (hrel_of (trans l) u v) (only parsing). - -(*| -[refine_transition H]: given a transition whose concrete label is known, -derive information on the active/passive status of its destination state. - -Currently very partial -|*) -Ltac refine_trans_in h := - match type of h with - | htrans τ _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_τ_inv h as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - | htrans (ask ?e) _ _ => - let u := fresh "u" in - let EQ := fresh "EQ" in - pose proof trans_ask_inv h as [u EQ]; - rewrite EQ in *; - match type of EQ with - | Seq ?a _ => try clear a EQ - end - end. - -Tactic Notation "refine_trans" := - match goal with - | h : htrans _ _ _ |- _ => refine_trans_in h - end. -Tactic Notation "refine_trans" "in" ident(h) := refine_trans_in h. - -(*| -[inv_trans] is an helper tactic to automatically -invert hypotheses involving [trans]. -|*) - -Ltac inv_label_eq EQl := - match type of EQl with - | τ = τ => - clear EQl - | val _ = val _ => - apply val_eq_inv in EQl; try (inversion EQl; fail) - | ask _ = ask _ => - let EQt := fresh "EQt" in - let EQe := fresh "EQe" in - apply ask_invT in EQl as EQt; - symmetry in EQt; - (* subst_hyp_in EQt h; *) - apply ask_inv in EQl as EQe; - try (inversion EQe; fail) - | rcv _ _ = rcv _ _ => - let EQt := fresh "EQt" in - let EQt := fresh "EQv" in - let EQe := fresh "EQe" in - apply rcv_invT in EQl as EQt; - symmetry in EQt; - (* subst_hyp_in EQt h; *) - apply rcv_inv in EQl as [EQe EQv]; - try (inversion EQe; inversion EQv; fail) - | _ => subst; try now inv EQl - end. - -Ltac inv_trans_one := - match goal with - (* Ret *) - | h : htrans _ (α Ret _) _ |- _ => - let EQl := fresh "EQl" in - let EQ := fresh "EQ" in - (apply trans_ret_inv in h as [EQ EQl] || apply trans_ret_inv' in h as [EQ EQl]); - try rewrite EQ in *; - inv_label_eq EQl - - (* Step *) - | h : htrans _ (α Step _) _ |- _ => - let EQl := fresh "EQl" in - let EQ := fresh "EQ" in - apply trans_step_inv' in h as (EQ & EQl); - try rewrite EQ in *; - inv_label_eq EQl - - (* Br *) - | h : htrans _ (α Br _ _) _ |- _ => - let TR := fresh "TR" in - apply trans_br_inv in h as (?n & TR) - - | h : htrans _ (α br2 _ _) _ |- _ => - let TR := fresh "TR" in - apply trans_br2_inv in h as [TR | TR] - - | h : htrans _ (α br3 _ _ _) _ |- _ => - let TR := fresh "TR" in - apply trans_br3_inv in h as [TR | [TR | TR]] - - (* Guard *) - | h : htrans _ (α Guard _) _ |- _ => - apply trans_guard_inv in h - - (* Vis *) - | h : htrans _ (α (Vis ?e ?k)) _ |- _ => - let EQl := fresh "EQl" in - let EQ := fresh "EQ" in - apply trans_vis_inv' in h as (EQ & EQl); - try rewrite EQ in *; - inv_label_eq EQl - - (* Passive *) - | h : htrans _ (β ?e ?k) _ |- _ => - let EQl := fresh "EQl" in - let EQ := fresh "EQ" in - apply trans_passive_inv' in h as (?x & EQ & EQl); - try rewrite EQ in *; - inv_label_eq EQl - - end. - -Ltac inv_trans := repeat inv_trans_one. - Create HintDb trans. #[global] Hint Resolve trans_ret trans_ask trans_brS trans_br @@ -2551,3 +2354,208 @@ Proof. cbn in *; subst; now constructor. Qed. +(* (*| *) +(* [wf_val] states that a [label] is well-formed: *) +(* if it is a [val] it should be of the right type. *) +(* |*) *) +(* Definition wf_val {E} X l := forall Y (v : Y), l = @val E Y v -> X = Y. *) + +(* Lemma wf_val_val {E} X (v : X) : wf_val X (@val E X v). *) +(* Proof. *) +(* red. intros. apply val_eq_invT in H. assumption. *) +(* Qed. *) + +(* Lemma wf_val_nonval {E} X (l : @label E) : ~is_val l -> wf_val X l. *) +(* Proof. *) +(* red. intros. subst. exfalso. apply H. constructor. *) +(* Qed. *) + +(* Lemma wf_val_trans {E B X} (l : @label E) t t' : *) +(* @trans E B X l t t' -> wf_val X l. *) +(* Proof. *) +(* red. intros. subst. *) +(* now apply trans_val_invT in H. *) +(* Qed. *) + +(* Lemma wf_val_is_val_inv : forall {E} X (l : @label E), *) +(* is_val l -> *) +(* wf_val (E := E) X l -> *) +(* exists (x : X), l = val x. *) +(* Proof. *) +(* intros. *) +(* destruct H. red in H0. *) +(* specialize (H0 X0 x eq_refl). subst. eauto. *) +(* Qed. *) + +(* (*| If the LTS has events of type [L +' R] then *) +(* it is possible to step it as either an [L] LTS *) +(* or [R] LTS ignoring the other. *) +(* *) *) +(* Section Coproduct. *) +(* Arguments label: clear implicits. *) +(* Context {L R C: Type -> Type} {X: Type}. *) +(* Notation S := (ctree (L +' R) C X). *) +(* Notation S' := (ctree' (L +' R) C X). *) +(* Notation SP := (SS -> label (L +' R) -> Prop). *) + +(* (* Skip an [R] event *) *) +(* Inductive srtrans_: rel S' S' := *) +(* | IgnoreR {X} (e : R X) k x t : *) +(* srtrans_ (observe (k x)) t -> *) +(* srtrans_ (VisF (inr1 e) k) t. *) + +(* (* Skip an [L] event *) *) +(* Inductive sltrans_: rel S' S' := *) +(* | IgnoreL {X} (e : L X) k x t : *) +(* sltrans_ (observe (k x)) t -> *) +(* sltrans_ (VisF (inl1 e) k) t. *) + +(* Hint Constructors srtrans_ sltrans_: core. *) + +(* (* Make those relations that respect equality [srel] *) *) +(* Program Definition srtrans : srel SS SS := *) +(* {| hrel_of := (fun (u v: SS) => srtrans_ (observe u) (observe v)) |}. *) +(* Next Obligation. split; induction 1; auto. Defined. *) + +(* Program Definition sltrans : srel SS SS := *) +(* {| hrel_of := (fun (u v: SS) => sltrans_ (observe u) (observe v)) |}. *) +(* Next Obligation. split; induction 1; auto. Defined. *) + +(* (*| Obs transition on the left, ignores right transitions and [τ] |*) *) +(* Definition ltrans {X}(l: L X)(x: X): srel SS SS := *) +(* (trans τ ⊔ srtrans)^* ⋅ trans (obs (inl1 l) x) ⋅ (trans τ ⊔ srtrans)^*. *) + +(* (*| Obs transition on the right, ignores left transitions and [τ] |*) *) +(* Definition rtrans {X}(r: R X)(x: X): srel SS SS := *) +(* (trans τ ⊔ sltrans)^* ⋅ trans (obs (inr1 r) x) ⋅ (trans τ ⊔ sltrans)^*. *) + +(* End Coproduct. *) + +#[global] Notation htrans l u v := (hrel_of (trans l) u v) (only parsing). + +(*| +[refine_transition H]: given a transition whose concrete label is known, +derive information on the active/passive status of its destination state. + +Currently very partial +|*) +Ltac refine_trans_in h := + match type of h with + | htrans τ _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_τ_inv h as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + | htrans (ask ?e) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_ask_inv h as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + end. + +Tactic Notation "refine_trans" := + match goal with + | h : htrans _ _ _ |- _ => refine_trans_in h + end. +Tactic Notation "refine_trans" "in" ident(h) := refine_trans_in h. + +(*| +[inv_trans] is an helper tactic to automatically +invert hypotheses involving [trans]. +|*) + +Ltac inv_label_eq EQl := + match type of EQl with + | τ = τ => + clear EQl + | val _ = val _ => + apply val_eq_inv in EQl; try (inversion EQl; fail) + | ask _ = ask _ => + let EQt := fresh "EQt" in + let EQe := fresh "EQe" in + apply ask_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply ask_inv in EQl as EQe; + try (inversion EQe; fail) + | rcv _ _ = rcv _ _ => + let EQt := fresh "EQt" in + let EQt := fresh "EQv" in + let EQe := fresh "EQe" in + apply rcv_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply rcv_inv in EQl as [EQe EQv]; + try (inversion EQe; inversion EQv; fail) + | _ => subst; try now inv EQl + end. + +Ltac inv_trans_one := + match goal with + (* Ret *) + | h : htrans _ (α Ret _) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + (apply trans_ret_inv in h as [EQ EQl] || apply trans_ret_inv' in h as [EQ EQl]); + try rewrite EQ in *; + inv_label_eq EQl + + (* Step *) + | h : htrans _ (α Step _) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + apply trans_step_inv' in h as (EQ & EQl); + try rewrite EQ in *; + inv_label_eq EQl + + (* Br *) + | h : htrans _ (α Br _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br_inv in h as (?n & TR) + + | h : htrans _ (α br2 _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br2_inv in h as [TR | TR] + + | h : htrans _ (α br3 _ _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br3_inv in h as [TR | [TR | TR]] + + | h : htrans _ (α br4 _ _ _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br4_inv in h as [TR | [TR | [TR | TR]]] + + (* Guard *) + | h : htrans _ (α Guard _) _ |- _ => + apply trans_guard_inv in h + + (* Vis *) + | h : htrans _ (α (Vis ?e ?k)) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + apply trans_vis_inv' in h as (EQ & EQl); + try rewrite EQ in *; + inv_label_eq EQl + + (* Stuck *) + | h : htrans _ (α Stuck) _ |- _ => + exfalso; eapply trans_stuck_inv; now apply h + + (* Passive *) + | h : htrans _ (β ?e ?k) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + apply trans_passive_inv' in h as (?x & EQ & EQl); + try rewrite EQ in *; + inv_label_eq EQl + + end. + +Ltac inv_trans := repeat (inv_trans_one). + From 87ed644453bdf3517d9a830eb789f545d2ced587 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 17 Apr 2026 09:47:07 +0200 Subject: [PATCH 27/61] Finished sbisim --- theories/Eq/SBisim_draft.v | 330 +++++++++++++++++++++++++++---------- theories/Eq/Trans.v | 35 +++- 2 files changed, 279 insertions(+), 86 deletions(-) diff --git a/theories/Eq/SBisim_draft.v b/theories/Eq/SBisim_draft.v index 757e333..dece9e7 100644 --- a/theories/Eq/SBisim_draft.v +++ b/theories/Eq/SBisim_draft.v @@ -274,21 +274,6 @@ Section sbisim_homogenous_theory. End sbisim_homogenous_theory. -Lemma Leq_eq {E X}: build_rel (@Leq E X) == eq. -Proof. - split; [| intros <-; reflexivity]. - intros []; auto. - dependent induction HR; auto. - dependent induction HR; auto. - cbn in H; subst; auto. -Qed. - -Lemma flipL_Leq {E X}: lequiv (flipL (@Leq E X)) Leq. -Proof. - cbv; intuition. - all: dependent induction H; constructor. -Qed. - (*| Heterogeneous theory -------------------- @@ -1561,41 +1546,99 @@ Interaction with (complete) strong simulation |*) Section SBisim_vs_SSim. - Context {E F C D : Type -> Type} {X Y : Type} - {L : lrel E F X Y}. - - Notation ss := (@ss E F C D X Y). - Notation ssim := (@ssim E F C D X Y). - - (*| - A two-sided [ss] gives an [sb]; the converse fails in general (see - [ssim_sbisim_nequiv] below). - |*) - Lemma ss_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : - ss L R t u -> - ss (flipL L) (flip R) u t -> - sb L R t u. - Admitted. - - Lemma sbisim_clos_ss {c : Chain (ss L)} : - forall x y, @sbisim_clos E F C D X Y Leq Leq `c x y -> `c x y. - Admitted. - - #[global] Instance sbisim_eq_clos_ss_goal {R : Chain (ss L)} : - Proper (sbisim Leq ==> sbisim Leq ==> flip impl) `R. - Admitted. - - #[global] Instance sbisim_eq_clos_ss_ctx {R : Chain (ss L)} : - Proper (sbisim Leq ==> sbisim Leq ==> impl) `R. - Admitted. + Section withParam. + + Context {E F C D : Type -> Type} {X Y : Type} + {L : lrel E F X Y}. - #[global] Instance sbisim_eq_clos_ssim_goal : - Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (ssim L). - Admitted. + Notation ss := (@ss E F C D X Y). + Notation ssim := (@ssim E F C D X Y). - #[global] Instance sbisim_eq_clos_ssim_ctx : - Proper (sbisim Leq ==> sbisim Leq ==> impl) (ssim L). - Admitted. + #[global] Instance sbisim_ss_chain_goal {c : Chain (ss L)} : + Proper (sbisimeq ==> sbisimeq ==> flip impl) `c. + Proof. + apply tower. + - intros ? INC x y EQ x' y' EQ' ?? HP; red. + eapply INC; eauto. + eapply leq_infx in HP. + now apply HP. + - clear. + intros c IH x y EQ x' y' EQ' SS ?? TR. + playL in EQ. + apply SS in TR0; destruct TR0 as (? & ? & TR0 & Sbis' & HL). + playR in EQ'. + ex2; split3; eauto. + eapply IH; eauto. + rewrite flipL_Leq in H0. + apply Leq_eq in H,H0; subst; auto. + Qed. + + #[global] Instance sbisim_ss_chain_ctx {c : Chain (ss L)} : + Proper (sbisimeq ==> sbisimeq ==> impl) `c. + Proof. + apply tower. + - intros ? INC x y EQ x' y' EQ' ?? HP; red. + eapply INC; eauto. + eapply leq_infx in HP. + now apply HP. + - clear. + intros c IH x y EQ x' y' EQ' SS ?? TR. + playR in EQ. + apply SS in TR0; destruct TR0 as (? & ? & TR0 & Sbis' & HL). + playL in EQ'. + ex2; split3; eauto. + eapply IH; eauto. + rewrite flipL_Leq in H. + apply Leq_eq in H,H0; subst; auto. + Qed. + + #[global] Instance sbisim_ssim_goal : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (ssim L). + Proof. + repeat intro; eapply sbisim_ss_chain_goal; eauto. + Qed. + + #[global] Instance sbisim_ssim_ctx : + Proper (sbisim Leq ==> sbisim Leq ==> impl) (ssim L). + Proof. + repeat intro; eapply sbisim_ss_chain_ctx; eauto. + Qed. + + (*| + "Co-similarity" does not entail bisimilarity as per [ssim_sbisim_nequiv], + but we can get something weaker: + |*) + Lemma ss_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : + ss L R t u -> + SSim.ss (flipL L) (flip R) u t -> + sb L R t u. + Proof. + split; cbn; intros. + - apply H in H1 as (? & ? & ? & ? & ?); eauto. + - apply H0 in H1 as (? & ? & ? & ? & ?); eauto. + Qed. + + End withParam. + + (* Bisimilarity entails co-similarity. *) + Lemma ssim_sbisim {E C X} (t u : ctree E C X) : + t ≃ u -> + ssim Leq t u /\ ssim Leq u t. + Proof. + intros SB. + split. + - coinduction r cih. + intros ?? TR. + playL in SB. + answer. + now rewrite EQ. + - coinduction r cih. + intros ?? TR. + playR in SB. + answer. + now rewrite EQ. + now simpL. + Qed. End SBisim_vs_SSim. @@ -1608,11 +1651,28 @@ Section Two_ss_is_not_sb. ss Leq RR t t' -> ss Leq (flip RR) t' t -> sb Leq RR t t'. - Admitted. + Proof. + intros * fwd bwd. + play. + apply fwd in TR as (? & ? & ? & ? & ?); answer. + apply bwd in TR as (? & ? & ? & ? & ?); answer. + now rewrite flipL_Leq. + Qed. Lemma split_sbisim_eq {E B X} (t u : ctree E B X) : t ≃ u <-> ss Leq (sbisim Leq) t u /\ ss Leq (sbisim Leq) u t. - Admitted. + Proof. + split; intro. + - step in H. split; [apply H |]. + symmetry in H. apply H. + - step. split; [apply H |]. + destruct H as [_ ?]. + (* todo: this should be nicer *) + eapply lequiv_ss; [apply flipL_Leq |]. + cbn; intros. + apply H in H0 as (? & ? & ? & ? & ?); answer. + symmetry; auto. + Qed. (*| A concrete counter-example: [Step (Ret tt)] and [brS2 (Ret tt) Stuck] @@ -1620,47 +1680,147 @@ Section Two_ss_is_not_sb. |*) Lemma ssim_sbisim_nequiv : exists (t1 t2 : ctree void1 B2 unit), - ssim Leq t1 t2 /\ ssim Leq t2 t1 /\ ≃ sbisim Leq t1 t2. - Admitted. + ssim Leq t1 t2 /\ ssim Leq t2 t1 /\ ~ sbisimeq t1 t2. + Proof. + exists (Step (Ret tt)), (brS2 (Ret tt) (Stuck)). + intuition. + - unfold brS2. + step. + intros ?? TR. + inv_trans; subst. + exists τ, (α (Ret tt)); split3. + apply trans_br with true; etrans. + now rewrite EQ. + eauto. + - step; intros ?? TR. + inv_trans. + exists τ, (α (Ret tt)); intuition; now rewrite EQ. + exists τ, (α (Ret tt)). intuition. + rewrite EQ; apply ssim_stuck. + - step in H. cbn in H. destruct H as [_ ?]. + specialize (H τ Stuck). lapply H; [| etrans]. + intros. destruct H0 as (? & ? & ? & ? & ?). + inv_trans. step in H1. cbn in H1. destruct H1 as [? _]. + specialize (H0 (val tt) Stuck). lapply H0. + 2: subst; etrans. + intro; destruct H1 as (? & ? & ? & ? & ?). + inv_trans. + Qed. End Two_ss_is_not_sb. Section SBisim_vs_CSSim. - Context {E F C D : Type -> Type} {X Y : Type} - {L : lrel E F X Y}. - - Notation css := (@css E F C D X Y). - Notation cssim := (@cssim E F C D X Y). - - Lemma sb_css (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : - sb L R t u -> css L R t u. - Admitted. - - Lemma css_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : - css L R t u -> - css (flipL L) (flip R) u t -> - sb L R t u. - Admitted. - - Lemma sbisim_clos_css {c : Chain (css L)} : - forall x y, @sbisim_clos E F C D X Y Leq Leq `c x y -> `c x y. - Admitted. - - #[global] Instance sbisim_eq_clos_css_goal {R : Chain (css L)} : - Proper (sbisim Leq ==> sbisim Leq ==> flip impl) `R. - Admitted. - - #[global] Instance sbisim_eq_clos_css_ctx {R : Chain (css L)} : - Proper (sbisim Leq ==> sbisim Leq ==> impl) `R. - Admitted. + Section withParam. + + Context {E F C D : Type -> Type} {X Y : Type} + {L : lrel E F X Y}. - #[global] Instance sbisim_eq_clos_cssim_goal : - Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (cssim L). - Admitted. + Notation css := (@css E F C D X Y). + Notation cssim := (@cssim E F C D X Y). - #[global] Instance sbisim_eq_clos_cssim_ctx : - Proper (sbisim Leq ==> sbisim Leq ==> impl) (cssim L). - Admitted. + Tactic Notation "dec3" ident(h) "as" + simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) + := destruct h as (a & b & c). + + #[global] Instance sbisim_css_chain_goal {c : Chain (css L)} : + Proper (sbisimeq ==> sbisimeq ==> flip impl) `c. + Proof. + apply tower. + - intros ? INC x y EQ x' y' EQ' ?? HP; red. + eapply INC; eauto. + eapply leq_infx in HP. + now apply HP. + - clear. + intros c IH x y EQ x' y' EQ'; split. + + intros ?? TR. + playL in EQ. + play in H. + playR in EQ'. + answer. + eapply IH; eauto. + now simpL. + + intros (? & ? & TR). + playL in EQ'. + destruct H as [_ LIV]. + dec3 LIV as ? ? TR'; eauto. + playR in EQ. + eauto. + Qed. + + #[global] Instance sbisim_css_chain_ctx {c : Chain (css L)} : + Proper (sbisimeq ==> sbisimeq ==> impl) `c. + Proof. + apply tower. + - intros ? INC x y EQ x' y' EQ' ?? HP; red. + eapply INC; eauto. + eapply leq_infx in HP. + now apply HP. + - clear. + intros c IH x y EQ x' y' EQ'; split. + + intros ?? TR. + playR in EQ. + play in H. + playL in EQ'. + answer. + eapply IH; eauto. + now simpL. + + intros (? & ? & TR). + playR in EQ'. + destruct H as [_ LIV]. + dec3 LIV as ? ? TR'; eauto. + playL in EQ. + eauto. + Qed. + + #[global] Instance sbisim_cssim_goal : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (cssim L). + Proof. + repeat intro; eapply sbisim_css_chain_goal; eauto. + Qed. + + #[global] Instance sbisim_cssim_ctx : + Proper (sbisim Leq ==> sbisim Leq ==> impl) (cssim L). + Proof. + repeat intro; eapply sbisim_css_chain_ctx; eauto. + Qed. + + Lemma css_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : + css L R t u -> + CSSim.css (flipL L) (flip R) u t -> + sb L R t u. + Proof. + split; cbn; intros. + - apply H in H1 as (? & ? & ? & ? & ?); eauto. + - apply H0 in H1 as (? & ? & ? & ? & ?); eauto. + Qed. + + End withParam. + + (* Bisimilarity entails co-similarity. *) + Lemma sbisim_cssim {E C X} (t u : ctree E C X) : + t ≃ u -> + cssim Leq t u /\ cssim Leq u t. + Proof. + intros SB. + split. + - coinduction r cih. + split. + + intros ?? TR. + playL in SB. + answer. + now rewrite EQ. + + intros (? & ? & TR). + playR in SB; eauto. + - coinduction r cih. + split. + + intros ?? TR. + playR in SB. + simpL. + answer. + now rewrite EQ. + + intros (? & ? & TR). + playL in SB; eauto. + Qed. End SBisim_vs_CSSim. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 379fc95..95224eb 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -2354,6 +2354,27 @@ Proof. cbn in *; subst; now constructor. Qed. +Lemma Leq_eq {E X}: build_rel (@Leq E X) == eq. +Proof. + split; [| intros <-; reflexivity]. + intros []; auto. + dependent induction HR; auto. + dependent induction HR; auto. + cbn in H; subst; auto. +Qed. + +Lemma flipL_Leq {E X}: lequiv (flipL (@Leq E X)) Leq. +Proof. + cbv; intuition. + all: dependent induction H; constructor. +Qed. + +Ltac simpL := + repeat match goal with + | h : build_rel (flipL _) _ _ |- _ => rewrite flipL_Leq in h + | h : build_rel Leq _ _ |- _ => apply Leq_eq in h + end; subst. + (* (*| *) (* [wf_val] states that a [label] is well-formed: *) (* if it is a [val] it should be of the right type. *) @@ -2531,6 +2552,18 @@ Ltac inv_trans_one := let TR := fresh "TR" in apply trans_br4_inv in h as [TR | [TR | [TR | TR]]] + | h : htrans _ (α brS2 _ _) _ |- _ => + let EQ := fresh "EQ" in + apply trans_brS2_inv' in h as (-> & [EQ | EQ]) + + | h : htrans _ (α brS3 _ _ _) _ |- _ => + let EQ := fresh "EQ" in + apply trans_brS3_inv' in h as (-> & [EQ | [EQ | EQ]]) + + | h : htrans _ (α brS4 _ _ _ _) _ |- _ => + let EQ := fresh "EQ" in + apply trans_brS4_inv' in h as (-> & [EQ | [EQ | [EQ | EQ]]]) + (* Guard *) | h : htrans _ (α Guard _) _ |- _ => apply trans_guard_inv in h @@ -2558,4 +2591,4 @@ Ltac inv_trans_one := end. Ltac inv_trans := repeat (inv_trans_one). - + From 7d5ee4d7f082014ece3bbdaf329941473367bba2 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 17 Apr 2026 09:48:07 +0200 Subject: [PATCH 28/61] Promoting the draft to main, keeping the old one for review of changes --- theories/Eq/{SBisim.v => SBisim_old.v} | 0 theories/Eq/{SBisim_draft.v => Sbisim.v} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename theories/Eq/{SBisim.v => SBisim_old.v} (100%) rename theories/Eq/{SBisim_draft.v => Sbisim.v} (100%) diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim_old.v similarity index 100% rename from theories/Eq/SBisim.v rename to theories/Eq/SBisim_old.v diff --git a/theories/Eq/SBisim_draft.v b/theories/Eq/Sbisim.v similarity index 100% rename from theories/Eq/SBisim_draft.v rename to theories/Eq/Sbisim.v From 46a45239847a461fdc2f224e5c64f71f6588d511 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 17 Apr 2026 13:51:09 +0200 Subject: [PATCH 29/61] Automate working with labels --- theories/Eq/Sbisim.v | 31 +++++++------------------------ theories/Eq/Trans.v | 14 ++++++++++++++ 2 files changed, 21 insertions(+), 24 deletions(-) diff --git a/theories/Eq/Sbisim.v b/theories/Eq/Sbisim.v index dece9e7..5eb4c58 100644 --- a/theories/Eq/Sbisim.v +++ b/theories/Eq/Sbisim.v @@ -383,20 +383,13 @@ Section sbisim_heterogenous_theory. step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). do 2 eexists; repeat split; eauto. eapply INC; eauto. - (* todo ltac *) - apply Leq_eq in EQl. - rewrite flipL_Leq in EQl'. - apply Leq_eq in EQl'. - subst; auto. + now simpL. + step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis & EQl). apply bwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). do 2 eexists; repeat split; eauto. eapply INC; eauto. - apply Leq_eq in EQl. - rewrite flipL_Leq in EQl'. - apply Leq_eq in EQl'. - subst; auto. + now simpL. Qed. #[global] Instance seq_chain_ctx {c : Chain (sb L)} : @@ -458,20 +451,13 @@ Section sbisim_heterogenous_theory. step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). do 2 eexists; repeat split; eauto. eapply INC; eauto. - (* todo ltac *) - apply Leq_eq in EQl'. - rewrite flipL_Leq in EQl. - apply Leq_eq in EQl. - subst; auto. + now simpL. + step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis & EQl). apply bwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis'' & EQl'). do 2 eexists; repeat split; eauto. eapply INC; eauto. - apply Leq_eq in EQl'. - rewrite flipL_Leq in EQl. - apply Leq_eq in EQl. - subst; auto. + now simpL. Qed. (*| Subrelations. |*) @@ -1569,8 +1555,7 @@ Section SBisim_vs_SSim. playR in EQ'. ex2; split3; eauto. eapply IH; eauto. - rewrite flipL_Leq in H0. - apply Leq_eq in H,H0; subst; auto. + now simpL. Qed. #[global] Instance sbisim_ss_chain_ctx {c : Chain (ss L)} : @@ -1588,8 +1573,7 @@ Section SBisim_vs_SSim. playL in EQ'. ex2; split3; eauto. eapply IH; eauto. - rewrite flipL_Leq in H. - apply Leq_eq in H,H0; subst; auto. + now simpL. Qed. #[global] Instance sbisim_ssim_goal : @@ -1667,8 +1651,7 @@ Section Two_ss_is_not_sb. symmetry in H. apply H. - step. split; [apply H |]. destruct H as [_ ?]. - (* todo: this should be nicer *) - eapply lequiv_ss; [apply flipL_Leq |]. + simpL. cbn; intros. apply H in H0 as (? & ? & ? & ? & ?); answer. symmetry; auto. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index 95224eb..bc34efe 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -2369,10 +2369,24 @@ Proof. all: dependent induction H; constructor. Qed. +(* This one is a bit ugly: we will have proper instance to + lift [lequiv] arguments of (bi)simulations to [weq] result. + This instance does the last bit to allow the rewriting by [lequiv] + directly. + *) +#[global] Instance weq_body {E B X}: + Proper (Coinduction.lattice.weq ==> eq ==> eq ==> eq ==> iff) + (@body (rel (S E B X) (S E B X)) _). +Proof. + cbn; intros R L EQ ?? <- ?? <- ?? <-; split; intros H. + all:apply EQ; auto. +Qed. + Ltac simpL := repeat match goal with | h : build_rel (flipL _) _ _ |- _ => rewrite flipL_Leq in h | h : build_rel Leq _ _ |- _ => apply Leq_eq in h + | |- context[flipL Leq] => rewrite flipL_Leq end; subst. (* (*| *) From 2bb6f9ecaab860d3995fc59c2c88e0fee966f8cd Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 17 Apr 2026 13:55:01 +0200 Subject: [PATCH 30/61] Capitalization --- theories/Eq/{Sbisim.v => SBisim.v} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename theories/Eq/{Sbisim.v => SBisim.v} (100%) diff --git a/theories/Eq/Sbisim.v b/theories/Eq/SBisim.v similarity index 100% rename from theories/Eq/Sbisim.v rename to theories/Eq/SBisim.v From b0f721f0994cfd8064231baefb58335ca629c4e1 Mon Sep 17 00:00:00 2001 From: Yannick Date: Fri, 17 Apr 2026 16:30:55 +0200 Subject: [PATCH 31/61] Epsilon, might be necessary to revisit it to prettify things a bit.. --- theories/Eq.v | 36 +++++------ theories/Eq/Epsilon.v | 141 +++++++++++++++++++---------------------- theories/Utils/Utils.v | 1 + 3 files changed, 84 insertions(+), 94 deletions(-) diff --git a/theories/Eq.v b/theories/Eq.v index 5442bc9..75b78c4 100644 --- a/theories/Eq.v +++ b/theories/Eq.v @@ -67,23 +67,23 @@ The upto [Vis] context principle for [sbisim] |*) (* #[global] Tactic Notation "upto_vis" := __upto_vis_sbisim. *) -(*| -The upto [bind] context principle for [equ] and [sbisim] --- -the same tactic covers both cases, whether in front of a [gfp], [t _] or [bt _]. -The three variants are: -- [upto_bind]: leave you with both proof obligations, introducing an evar for the intermediate relation in the case of [equ] -- [upto_bind_eq]: meant to be use when the prefixes of the computations -are identical: assumes [reflexivity] will solve the first goal, and proceed to substitute the equality -- [upto_bind with SS]: for [equ], provides explicitly the intermediate relation -|*) -#[global] Tactic Notation "upto_bind" := - __eupto_bind_equ || __eupto_bind_sbisim. - -#[global] Tactic Notation "upto_bind_eq" := - __upto_bind_equ_eq || __upto_bind_sbisim_eq. - -#[global] Tactic Notation "upto_bind" "with" uconstr(SS) := - __upto_bind_equ SS || __upto_bind_sbisim SS. +(* (*| *) +(* The upto [bind] context principle for [equ] and [sbisim] --- *) +(* the same tactic covers both cases, whether in front of a [gfp], [t _] or [bt _]. *) +(* The three variants are: *) +(* - [upto_bind]: leave you with both proof obligations, introducing an evar for the intermediate relation in the case of [equ] *) +(* - [upto_bind_eq]: meant to be use when the prefixes of the computations *) +(* are identical: assumes [reflexivity] will solve the first goal, and proceed to substitute the equality *) +(* - [upto_bind with SS]: for [equ], provides explicitly the intermediate relation *) +(* |*) *) +(* #[global] Tactic Notation "upto_bind" := *) +(* __eupto_bind_equ || __eupto_bind_sbisim. *) + +(* #[global] Tactic Notation "upto_bind_eq" := *) +(* __upto_bind_equ_eq || __upto_bind_sbisim_eq. *) + +(* #[global] Tactic Notation "upto_bind" "with" uconstr(SS) := *) +(* __upto_bind_equ SS || __upto_bind_sbisim SS. *) (*| Weakens equalities into respectively [equ] and [sbisim] equations --- @@ -96,7 +96,7 @@ Ltac eq2equ H := Ltac eq2sb H := match type of H with - | ?u = ?t => let eq := fresh "EQ" in assert (eq : u ~ t) by (rewrite H; reflexivity); clear H + | ?u = ?t => let eq := fresh "EQ" in assert (eq : u ≃ t) by (rewrite H; reflexivity); clear H end. #[global] Opaque wtrans. diff --git a/theories/Eq/Epsilon.v b/theories/Eq/Epsilon.v index 476d0fa..54ddf3e 100644 --- a/theories/Eq/Epsilon.v +++ b/theories/Eq/Epsilon.v @@ -38,6 +38,7 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat | epsilon_guard : forall t u, epsilon_ (observe u) t -> epsilon_ (GuardF u) t. Definition epsilon {E C X} (t t' : ctree E C X) := epsilon_ (observe t) (observe t'). + Hint Constructors epsilon_det productive epsilon_ : core. Section epsilon_det_theory. @@ -111,11 +112,11 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat Qed. Lemma sbisim_epsilon_det {E C X}: - forall (t t' : ctree E C X), epsilon_det t t' -> t ~ t'. + forall (t t' : ctree E C X), epsilon_det t t' -> t ≃ t'. Proof. intros. induction H. - now rewrite H. - - rewrite H0. rewrite sb_guard. apply IHepsilon_det. + - rewrite H0. rewrite sbisim_guard. apply IHepsilon_det. Qed. End epsilon_det_theory. @@ -261,8 +262,8 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'. induction H. - rewrite H. apply H0. - - apply IHepsilon_ in H0. eapply trans_br in H0. apply H0. rewrite <- ctree_eta. reflexivity. - - apply IHepsilon_ in H0; etrans. + - apply IHepsilon_ in H0. rewrite <- ctree_eta in H0. eapply trans_br in H0. apply H0. + - apply IHepsilon_ in H0; rewrite <- ctree_eta in H0; etrans. Qed. Lemma epsilon_fwd : forall {E C X Y} (t : ctree E C X) k x (c : C Y), @@ -289,35 +290,29 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat - intros; subst; eapply epsilon_guard, IHepsilon_; reflexivity. Qed. - Lemma trans_epsilon {E C X} l (t t'' : ctree E C X) : trans l t t'' -> exists t', + Lemma trans_epsilon {E C X} l (t : ctree E C X) t'' : trans l t t'' -> exists t', epsilon t t' /\ productive t' /\ trans l t' t''. Proof. - intros. do 3 red in H. - setoid_rewrite (ctree_eta t). setoid_rewrite (ctree_eta t''). - genobs t ot. genobs t'' ot''. clear t Heqot t'' Heqot''. - induction H; intros. - - destruct IHtrans_ as (? & ? & ? & ?). - rewrite <- ctree_eta in H0. eapply epsilon_br in H0. - exists x0. etrans. - - destruct IHtrans_ as (? & ? & ? & ?). - rewrite <- ctree_eta in H0. eapply epsilon_guard in H0. - eexists; etrans. - - eexists. split; [| split ]. - + constructor 1. reflexivity. - + eapply prod_step. reflexivity. - + rewrite <- H, <- ctree_eta. etrans. - - eexists. split; [| split ]. - + constructor 1. reflexivity. - + eapply prod_vis. reflexivity. - + rewrite <- H, <- ctree_eta. etrans. - - eexists. split; [| split ]. - + constructor 1. reflexivity. - + eapply prod_ret. reflexivity. - + etrans. - Qed. - - Lemma trans_val_epsilon {E C X} : forall x (t t' : ctree E C X), - trans (val x) t t' -> epsilon t (Ret x) /\ t' ≅ Stuck. + intros H. cbv in H. + dependent induction H. + - edestruct4 IHtransR; eauto. + setoid_rewrite H; rewrite H0 in H2. + cbv; eauto. + - edestruct4 IHtransR; eauto. + setoid_rewrite H. + cbv; eauto. + - setoid_rewrite H. + setoid_rewrite H0. + exists (Step t'); split3; eauto. + - setoid_rewrite H. + eauto 5. + - setoid_rewrite H. + setoid_rewrite H0. + exists (Ret r); split3; eauto. + Qed. + + Lemma trans_val_epsilon {E C X} : forall x (t : ctree E C X) t', + trans (val x) t t' -> epsilon t (Ret x). Proof. intros. apply trans_epsilon in H as (? & ? & ? & ?). inv H0. @@ -333,17 +328,24 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat inv H0. - rewrite EQ in H1. inv_trans. - rewrite EQ in H1. inv_trans. - - rewrite EQ in H1. inv_trans. - eauto. + - rewrite EQ in H1,H. + clear x EQ. + inv_trans. + inv EQ. + eauto. Qed. - Lemma trans_obs_epsilon {E C X Y} : forall (t t' : ctree E C X) e (x : Y), - trans (obs e x) t t' -> exists k, epsilon t (Vis e k) /\ t' ≅ k x. + Lemma trans_ask_epsilon {E C X Y} : forall (t : ctree E C X) t' (e : E Y), + trans (ask e) t t' -> exists k, epsilon t (Vis e k) /\ Seq t' (β e k). Proof. intros. apply trans_epsilon in H as (? & ? & ? & ?). inv H0. - rewrite EQ in H1. inv_trans. - - rewrite EQ in H1. inv_trans. subst. etrans. + - rewrite EQ in H1. inv_trans. + rewrite EQ in H. + pose proof ask_invT EQl; subst. + pose proof ask_inv EQl; subst. + eauto. - rewrite EQ in H1. inv_trans. Qed. @@ -501,68 +503,55 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat step in H0. step. eapply ss_epsilon_r in H0; eauto. Qed. + Notation "l ⊢ x → y" := (hrel_of (trans l) x y) (at level 10, x at next level, y at next level, only printing). + Notation "x" := (α x) (at level 9, only printing). + Lemma ssim_ret_epsilon {E F C D X Y L} : forall r (u : ctree F D Y), - Respects_val L -> (Ret r : ctree E C X) (≲L) u -> exists r', epsilon u (Ret r') /\ L (val r) (val r'). Proof. - intros * RV SIM *. - step in SIM. specialize (SIM (val r) Stuck (trans_ret _)). - destruct SIM as (l' & u' & TR & _ & EQ). - apply RV in EQ as ?. destruct H as [? _]. specialize (H (Is_val _)). inv H. - apply trans_val_invT in TR as ?. subst. - apply trans_val_epsilon in TR as []. eauto. + intros * SIM *. + play in SIM. + invL. + apply trans_val_epsilon in TR. + etrans. Qed. Lemma ssim_vis_epsilon {E F C D X Y Z L} : forall e (k : Z -> ctree E C X) (u : ctree F D Y), - Respects_val L -> - Respects_τ L -> Vis e k (≲L) u -> - forall x, exists Z' (e' : F Z') k' y, epsilon u (Vis e' k') /\ k x (≲L) k' y /\ L (obs e x) (obs e' y). - Proof. - intros * RV RT SIM *. - step in SIM. cbn in SIM. specialize (SIM (obs e x) (k x) (trans_vis _ _ _)). - destruct SIM as (l' & u'' & TR & SIM & EQ). + forall x, exists Z' (e' : F Z') k' y, + epsilon u (Vis e' k') /\ + k x (≲L) k' y /\ + L (ask e) (ask e') /\ + L (rcv e x) (rcv e' y). + Proof. + intros * SIM *. + apply ssim_vis_l_inv in SIM as (? & ? & ? & TR & ? & SIM). apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR). - destruct PROD. - 1: { - subs. inv_trans. subst. - apply RV in EQ. destruct EQ as [_ ?]. specialize (H (Is_val _)). inv H. - } - 2: { - subs. inv_trans. subst. - apply RT in EQ. destruct EQ as [_ ?]. specialize (H eq_refl). inv H. - } - subs. inv_trans. subst. - eexists _, _, _, _. etrans. + destruct PROD; subs; inv_trans. + dependent induction EQ. + pose proof ask_invT EQl; subst. + pose proof ask_inv EQl; subst. + destruct (SIM x) as (? & ? & ?). + rewrite EQ in H2. + ex4; split4; eauto; etrans. Qed. Lemma ssim_brS_epsilon {E F C D X Y Z L} : forall c (k : Z -> ctree E C X) (u : ctree F D Y), - Respects_τ L -> - L τ τ -> BrS c k (≲L) u -> forall x, (exists v, epsilon u (Step v) /\ k x (≲L) v). Proof. - intros * RT HL SIM *. + intros * SIM *. step in SIM. cbn in SIM. specialize (SIM τ (k x) (trans_brS _ _ _)). destruct SIM as (l' & u'' & TR & SIM & EQ). apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR). - destruct PROD. - 1: { - subs. inv_trans. subst. - apply RT in EQ. destruct EQ as [? _]. specialize (H eq_refl). inv H. - } - 1: { - subs. inv_trans. subst. - apply RT in EQ. destruct EQ as [? _]. specialize (H eq_refl). inv H. - } - subs. - inv_trans. subst. - eexists _. etrans. + destruct PROD; subs; inv_trans; etrans. + invL. + invL. Qed. End epsilon_theory. diff --git a/theories/Utils/Utils.v b/theories/Utils/Utils.v index 28d0a41..76e60aa 100644 --- a/theories/Utils/Utils.v +++ b/theories/Utils/Utils.v @@ -116,6 +116,7 @@ Definition sum_rel {A1 A2 B1 B2} Ra Rb : rel (A1 + B1) (A2 + B2) := Ltac ex := eexists. Ltac ex2 := do 2 eexists. Ltac ex3 := do 3 eexists. +Ltac ex4 := do 4 eexists. Ltac split3 := split; [| split]. Ltac split4 := split; [| split; [| split]]. Ltac edestruct3 H := edestruct H as (? & ? & ?). From 9d1cf9b5bcc0cbcc1892b961c277816d6d70921c Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 18 Jun 2026 13:08:29 +0200 Subject: [PATCH 32/61] A note --- rocq-ctree.opam | 52 +++++++++++++++++++++++++++++++++++++++++++++ theories/Eq/Trans.v | 4 ++++ 2 files changed, 56 insertions(+) create mode 100644 rocq-ctree.opam diff --git a/rocq-ctree.opam b/rocq-ctree.opam new file mode 100644 index 0000000..24695f6 --- /dev/null +++ b/rocq-ctree.opam @@ -0,0 +1,52 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "2.0-dev" +synopsis: + "Library for representing recursive, non-deterministic and impure programs with equational reasoning" +maintainer: ["Yannick Zakowski"] +authors: [ + "Nicolas Chappe" + "Paul He" + "Ludovic Henrio" + "Yannick Zakowski" + "Steve Zdancewic" +] +license: "MIT" +tags: [ + "category:CS/Semantics and Compilation/Semantics" + "category:CS/Concurrency/Theory of concurrent systems" + "keyword:simulation" + "keyword:bisimilarity" + "keyword:coinduction up-to" + "keyword:process algebra" + "keyword:cooperative multithreading" + "logpath:CTree" +] +homepage: "https://github.com/vellvm/ctrees" +bug-reports: "https://github.com/vellvm/ctrees/issues" +depends: [ + "dune" {>= "3.8"} + "rocq-core" {>= "9.0"} + "rocq-stdlib" {>= "9.0"} + "coq-ext-lib" {>= "0.11.3"} + "rocq-coinduction" {>= "1.21"} + "rocq-relation-algebra" {>= "1.8.0"} + "rocq-equations" {>= "1.3.1"} + "coq-itree" {>= "5.0"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/vellvm/ctrees.git" diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index bc34efe..a8a4b3d 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -17,6 +17,10 @@ observable node. At this point, it steps following the simple rules: label of [v] - [Vis e k] can step to any [k x] by emitting an event label tagged with both [e] and [x] + + +(* TODO remove, note: this above will change with the vis fix *) + - [BrS k] can step to any [k x] by emitting a tau label This transition system will define a notion of strong bisimulation From 730b96e1489c740c2ea5418c89ba643f30a0e347 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 25 Jun 2026 13:49:54 +0200 Subject: [PATCH 33/61] Changed trans_alt, ssimalt, updated most lemmas in those files --- .gitignore | 1 + theories/Eq/SSimAlt.v | 729 ++++++----- theories/Eq/Trace.v | 33 +- theories/Eq/TransAlt.v | 2735 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 3181 insertions(+), 317 deletions(-) create mode 100644 theories/Eq/TransAlt.v diff --git a/.gitignore b/.gitignore index e5e779f..7baadb6 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ _build *~ .lia.cache .aux +rocq-ctree.opam diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 43c7edb..a301ac4 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -13,57 +13,74 @@ From ITree Require Import Core.Subevent. From CTree Require Import CTree Utils - Eq + Eq.Equ + Eq.TransAlt Eq.Epsilon. From RelationAlgebra Require Export - rel srel. + monoid kat kat_tac rel srel. Import CoindNotations. Import CTree. Set Implicit Arguments. (* TODO: Decide where to set this *) -Arguments trans : simpl never. +Arguments trans_alt : simpl never. Ltac ssplit := split; [| split]. Section StrongSimAlt. - Definition ss'_gen {E F C D : Type -> Type} {X Y : Type} - (L : rel (@label E) (@label F)) - (R Reps : rel (ctree E C X) (ctree F D Y)) + (* finition ss'_gen {E F C D : Type -> Type} {X : Type} + (L : rel (@label E X) (@label F X)) + (R Reps : rel (ctree E C X) (ctree F D X)) (t : ctree E C X) (u : ctree F D Y) := + (productive t -> - forall l t', trans l t t' -> + (* t and u step together under labels related by L, assuming + t is "productive"; that is, not a Br *) + forall l t', trans l t t' -> exists l' u', trans l' u u' /\ R t' u' /\ L l l') + (* if t branches, u ϵ-steps to u' *) /\ (forall Z (c : C Z) k, t ≅ Br c k -> forall x, exists u', epsilon u u' /\ Reps (k x) u') /\ (forall t', t ≅ Guard t' -> exists u', epsilon u u' /\ Reps t' u'). - - #[global] Instance weq_ss'_gen {E F C D X Y} : - Proper (weq ==> weq) (@ss'_gen E F C D X Y). + *) +Locate dot. + Definition ss'_gen {E F B : Type -> Type} {X : Type} + (L : rel (@label E X) (@label F X)) + (R Reps : rel SS SS) + (t : SS) (u : SS) := + + (forall t' l, l <> ε -> trans_alt (B:=B) l t t' + -> exists l' u', ((trans_alt (B:=B) ε)^* ⋅ (trans_alt l')) u u' /\ R t' u' /\ L l l') + /\ + (forall t', trans_alt (B:=B) ε t t' -> exists u', (trans_alt (B:=B) ε)^* u u' /\ Reps t' u'). + + #[global] Instance weq_ss'_gen {E F B X} : + Proper (weq ==> eq ==> weq) (@ss'_gen E F B X). Proof. - cbn. intros; split; (split; [| split]); intros. - all: try now (eapply H0 in H1 as (? & ? & ?); eauto). - all: apply H0 in H2 as (? & ? & ? & ? & ?); auto; edestruct H; eauto 6 with trans. + cbn. intros L L' HL R ? <- x y; split; intros (HA & HB); split; intros. + - destruct (HA _ _ H H0) as (l'' & u'' & Htrans & HR & HL'). + do 2 esplit; split; [eassumption | split; [eassumption |]]; now apply HL. + - now apply HB in H. + - destruct (HA _ _ H H0) as (l'' & u'' & Htrans & HR & HL'). + do 2 esplit; split; [eassumption | split; [eassumption |]]; now apply HL. + - now apply HB in H. Qed. - #[global] Instance ss'_gen_mon {E F C D : Type -> Type} {X Y : Type} - (L : rel (@label E) (@label F)) : - Proper (leq ==> leq ==> leq) (@ss'_gen E F C D X Y L). + #[global] Instance ss'_gen_mon {E F B X} + (L : rel (@label E X) (@label F X)) : + Proper (Coinduction.lattice.leq ==> Coinduction.lattice.leq ==> Coinduction.lattice.leq) + (@ss'_gen E F B X L). Proof. - cbn. intros. - destruct H1 as (? & ? & ?). - split; [| split]. - - intros. - edestruct H1 as (? & ? & ? & ?); eauto. - eexists _, x2; intuition; eauto. - - intros. edestruct H2 as (? & ? & ?); eauto. - - intros. edestruct H3 as (? & ? & ?); eauto. + cbn. intros R R' HR Reps1 Reps2 HReps s1 s2 [Hl Hep]; split; intros. + - destruct (Hl _ _ H H0) as (l'' & u'' & Htrans & HRtu & HL'). + do 2 esplit; split; [eassumption | split; [now apply HR | assumption]]. + - apply Hep in H as (u' & Htrans & HRtu). exists u'; split; [assumption | now apply HReps]. Qed. (*| @@ -71,103 +88,121 @@ An alternative definition [ss'] of strong simulation. The simulation challenge does not involve an inductive transition relation, thus simplifying proofs. |*) - Program Definition ss' {E F C D : Type -> Type} {X Y : Type} - (L : rel (@label E) (@label F)) : - mon (ctree E C X -> ctree F D Y -> Prop) := + Program Definition ss' {E F B : Type -> Type} {X : Type} + (L : rel (@label E X) (@label F X)) : + mon (SS -> SS -> Prop) := {| body R t u := - ss'_gen L R R t u + @ss'_gen E F B X L R R t u |}. - Next Obligation. - epose proof (@ss'_gen_mon E F C D X Y). eapply H1. + Next Obligation. + epose proof (@ss'_gen_mon E F B X). eapply H1. 3: apply H0. all: auto. Qed. + End StrongSimAlt. -Definition ssim' {E F C D X Y} L := - (gfp (@ss' E F C D X Y L): hrel _ _). +Definition ssim' {E F B X} L := + (gfp (@ss' E F B X L): hrel _ _). + +Variant Seq_clos_body {E F B X} (R : rel (@S E B X) (@S F B X)) : rel (@S E B X) (@S F B X) := + | Seq_clos_intro : forall t t' u' u + (Seqt : t ⩸ t') + (HR : R t' u') + (Sequ : u' ⩸ u), + Seq_clos_body R t u. + +Program Definition Seq_clos {E F B X} : mon (rel (@S E B X) (@S F B X)) := + {| body := @Seq_clos_body E F B X |}. +Next Obligation. + match goal with h : Seq_clos_body _ _ _ |- _ => inv h end. + econstructor; eauto. +Qed. Section ssim'_theory. Arguments label: clear implicits. - Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. + Context {E F B: Type -> Type} {X : Type} + {L: rel (@label E X) (@label F X)}. (*| Strong simulation up-to [equ] is valid ---------------------------------------- |*) - #[global] Instance equ_ss'_gen_goal {R Reps} : - Proper (equ eq ==> equ eq ==> flip impl) (@ss'_gen E F C D X Y L R Reps). + #[global] Instance Seq_ss'_gen_goal {R Reps} : + Proper (Seq ==> Seq ==> flip impl) (@ss'_gen E F B X L R Reps). Proof. - split; [| split]; intros; subs; destruct H1 as (HA & HB & HC). - - apply HA in H3; auto. - destruct H3 as (? & ? & ? & ? & ?). eexists _, _. subs. etrans. - - symmetry in H. eapply HB in H. destruct H as (? & ? & ?). - eexists. subs. etrans. - - symmetry in H. eapply HC in H. destruct H as (? & ? & ?). - eexists. subs. etrans. - Qed. + intros t t' EQt u u' EQu (HA & HB); split. + - intros t'' l Hl TR. rewrite EQt in TR. + apply HA in TR as (l' & u'' & STEP & HRtu & HL); auto. + exists l', u''; split; [| split; assumption]. + now rewrite EQu. + - intros t'' TR. rewrite EQt in TR. + apply HB in TR as (u'' & STEP & HRtu). + exists u''; split; [| assumption]. + now rewrite EQu. + Qed. - #[global] Instance equ_ss'_gen_ctx {R Reps} : - Proper (equ eq ==> equ eq ==> impl) (@ss'_gen E F C D X Y L R Reps). + #[global] Instance Seq_ss'_gen_ctx {R Reps} : + Proper (Seq ==> Seq ==> impl) (@ss'_gen E F B X L R Reps). Proof. - do 4 red. intros. now rewrite <- H, <- H0. + intros t t' EQt u u' EQu H. now rewrite <- EQt, <- EQu. Qed. - Lemma equ_clos_sst' {c: Chain (ss' L)}: - forall x y, @equ_clos E F C D X Y `c x y -> `c x y. + Lemma Seq_clos_sst' {c: Chain (@ss' E F B X L)}: + forall x y, Seq_clos `c x y -> `c x y. Proof. apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. + - intros ? INC x y [t t' u' u EQt HR EQu] ??. red. apply INC; auto. econstructor; eauto. apply leq_infx in H. now apply H. - - intros R IH x y [x' y' x'' y'' EQ' EQ'']. - now subs. + - intros R IH x y [t t' u' u EQt HR EQu]. + eapply Seq_ss'_gen_goal; [ exact EQt | symmetry; exact EQu | exact HR ]. Qed. - #[global] Instance equ_clos_sst_goal {c: Chain (@ss' E F C D X Y L)} : - Proper (equ eq ==> equ eq ==> flip impl) `c. + #[global] Instance Seq_clos_sst_goal {c: Chain (@ss' E F B X L)} : + Proper (Seq ==> Seq ==> flip impl) `c. Proof. cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sst'; econstructor; [eauto | | symmetry; eauto]; assumption. + apply Seq_clos_sst'; econstructor; [eauto | | symmetry; eauto]; assumption. Qed. - #[global] Instance equ_clos_sst'_ctx {c: Chain (@ss' E F C D X Y L)} : - Proper (equ eq ==> equ eq ==> impl) `c. + #[global] Instance Seq_clos_sst'_ctx {c: Chain (@ss' E F B X L)} : + Proper (Seq ==> Seq ==> impl) `c. Proof. cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sst'; econstructor; [symmetry; eauto | | eauto]; assumption. + apply Seq_clos_sst'; econstructor; [symmetry; eauto | | eauto]; assumption. Qed. - #[global] Instance equ_clos_ssim'_goal : Proper (equ eq ==> equ eq ==> flip impl) (@ssim' E F C D X Y L). + #[global] Instance Seq_clos_ssim'_goal : Proper (Seq ==> Seq ==> flip impl) (@ssim' E F B X L). Proof. cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sst'; econstructor; eauto; now symmetry. + apply Seq_clos_sst'; econstructor; eauto; now symmetry. Qed. - #[global] Instance equ_clos_ssim'_ctx : Proper (equ eq ==> equ eq ==> impl) (@ssim' E F C D X Y L). + #[global] Instance Seq_clos_ssim'_ctx : Proper (Seq ==> Seq ==> impl) (@ssim' E F B X L). Proof. cbn; intros ? ? eq1 ? ? eq2 H. now rewrite <- eq1, <- eq2. Qed. - Lemma ss'_gen_br : forall {Z} (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y) - (R Reps : rel _ _), - ss'_gen L R Reps (Br c k) u -> - forall x, exists u', epsilon u u' /\ Reps (k x) u'. + Lemma ss'_gen_epsilon_star {R : rel (@S E B X) (@S F B X)} : + forall (t t' : @S E B X) (u : @S F B X), + ss'_gen L R R t u -> + trans_alt ε t t' -> + exists u', (trans_alt ε)^* u u' /\ R t' u'. Proof. - intros. destruct H as (_ & H & _); eapply H; reflexivity. + intros * (_ & H); apply H. Qed. - Lemma ss'_gen_guard : forall (t : ctree E C X) (u : ctree F D Y) - (R Reps : rel _ _), - ss'_gen L R Reps (Guard t) u -> - exists u', epsilon u u' /\ Reps t u'. + Lemma trans_alt_estar_l {G : Type -> Type} : + forall (t t' : @S G B X) l, + trans_alt l t t' -> + ((trans_alt ε)^* ⋅ trans_alt l) t t'. Proof. - intros. destruct H as (_ & _ & H); eapply H; reflexivity. + intros. use_steps O. assumption. Qed. End ssim'_theory. @@ -175,28 +210,28 @@ End ssim'_theory. Ltac fold_ssim' := repeat match goal with - | h: context[gfp (@ss' ?E ?F ?C ?D ?X ?Y ?L)] |- _ => - fold (@ssim' E F C D X Y L) in h - | |- context[gfp (@ss' ?E ?F ?C ?D ?X ?Y ?L)] => - fold (@ssim' E F C D X Y L) + | h: context[gfp (@ss' ?E ?F ?B ?X ?L)] |- _ => + fold (@ssim' E F B X L) in h + | |- context[gfp (@ss' ?E ?F ?B ?X ?L)] => + fold (@ssim' E F B X L) end. Tactic Notation "__step_ssim'" := match goal with - | |- context[@ssim' ?E ?F ?C ?D ?X ?Y ?LR] => + | |- context[@ssim' ?E ?F ?B ?X ?L] => unfold ssim'; step; - fold (@ssim' E F C D X Y L) + fold (@ssim' E F B X L) end. Tactic Notation "step" := __step_ssim' || step. Ltac __step_in_ssim' H := match type of H with - | context[@ssim' ?E ?F ?C ?D ?X ?Y ?LR] => + | context[@ssim' ?E ?F ?B ?X ?L] => unfold ssim' in H; step in H; - fold (@ssim' E F C D X Y L) in H + fold (@ssim' E F B X L) in H end. Tactic Notation "step" "in" ident(H) := __step_in_ssim' H || step in H. @@ -209,29 +244,30 @@ Import CTreeNotations. Import EquNotations. Section ssim'_homogenous_theory. Context {E B: Type -> Type} {X: Type} - {L: relation (@label E)}. + {L: relation (@label E X)}. + + Notation ss' := (@ss' E E B X). + Notation ssim' := (@ssim' E E B X). - Notation ss' := (@ss' E E B B X X). - Notation ssim' := (@ssim' E E B B X X). #[global] Instance Reflexive_ss' R Reps - `{Reflexive _ R} `{Reflexive _ Reps} `{Reflexive _ L}: - Reflexive (@ss'_gen E E B B X X L R Reps). + `{Reflexive _ R} `{Reflexive _ L} `{Reflexive _ Reps}: + Reflexive (@ss'_gen E E B X L R Reps). Proof. - split; [| split]; intros; eauto. - exists (k x0). subs. split; auto. now eapply epsilon_br. + split; intros. + exists l, t'. split; auto. + use_steps O. assumption. exists t'; split; eauto. - rewrite H2; now apply epsilon_guard. + use_steps (1 : nat). econstructor; eauto. Qed. #[global] Instance refl_ss' {LR: Reflexive L} {C: Chain (ss' L)}: Reflexive `C. Proof. apply Reflexive_chain. - split; [| split]; cbn; intros; eauto. - - exists (k x0); split; auto. - rewrite H0; eapply epsilon_br, epsilon_id; reflexivity. + split; intros. + - do 2 eexists. split. use_steps O. apply H1. now split. - exists t'; split; auto. - rewrite H0; eapply epsilon_guard, epsilon_id; reflexivity. + use_steps (1 : nat). econstructor; eauto. Qed. End ssim'_homogenous_theory. @@ -241,24 +277,23 @@ Parametric theory of [ss] with heterogenous [L] |*) Section ssim'_heterogenous_theory. Arguments label: clear implicits. - Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. + Context {E F B: Type -> Type} {X: Type} + {L: rel (@label E X) (@label F X)}. - Notation ss' := (@ss' E F C D X Y). - Notation ssim' := (@ssim' E F C D X Y). + Notation ss' := (@ss' E F B X). + Notation ssim' := (@ssim' E F B X). (*| stuck ctrees can be simulated by anything. |*) Lemma ss'_stuck R Reps : - forall (u : ctree F D Y), - ss'_gen (E := E) (C := C) (X := X) L R Reps Stuck u. + forall (u : @S F B X), + ss'_gen L R Reps (Stuck : ctree E B X) u. Proof. - split; [| split]; intros; inv_equ. - inv_trans. + split; intros; exfalso; eapply trans_stuck_inv; eassumption. Qed. - Lemma ssim'_stuck (t : ctree F D Y) : ssim' L Stuck t. + Lemma ssim'_stuck (t : @S F B X) : ssim' L (Stuck : ctree E B X) t. Proof. intros. step. apply ss'_stuck. Qed. @@ -274,7 +309,7 @@ Ltac __play_ssim'_in H := Ltac __eplay_ssim' := match goal with - | h : @ssim' ?E ?F ?C ?D ?X ?Y ?L _ _ |- _ => + | h : @ssim' ?E ?F ?B ?X ?L _ _ |- _ => __play_ssim'_in h end. @@ -285,41 +320,47 @@ Ltac __eplay_ssim' := Section Proof_Rules. Arguments label: clear implicits. - Context {E F C D : Type -> Type} - {X Y : Type} - {L : rel (@label E) (@label F)} - {R Reps : rel (ctree E C X) (ctree F D Y)} - {HR : (Proper (equ eq ==> equ eq ==> impl) R)} - {HReps : (Proper (equ eq ==> equ eq ==> impl) Reps)}. + Context {E F B : Type -> Type} + {X : Type} + {L : rel (@label E X) (@label F X)} + {R Reps : rel (@S E B X) (@S F B X)} + {HR : (Proper (Seq ==> Seq ==> impl) R)} + {HReps : (Proper (Seq ==> Seq ==> impl) Reps)}. Lemma step_ss'_stuck : - ss'_gen L R Reps Stuck Stuck. + ss'_gen L R Reps (Stuck : ctree E B X) (Stuck : ctree F B X). Proof. - ssplit; intros; inv_equ. - exfalso; eapply productive_stuck; eauto. + split; intros; exfalso; eapply trans_stuck_inv; eassumption. Qed. - Lemma step_ss'_ret (x : X) (y : Y) : + Lemma step_ss'_ret (x : X) (y : X) : R Stuck Stuck -> L (val x) (val y) -> - ss'_gen L R Reps (Ret x : ctree E C X) (Ret y : ctree F D Y). + ss'_gen L R Reps (Ret x : ctree E B X) (Ret y : ctree F B X). Proof. - intros Rstuck Lval. split; [| split]; intros. - 2,3: inv_equ. - inv_trans; subst. - do 3 eexists; intuition; etrans. now subs. + intros Rstuck Lval. split. + - intros t' l Hl TR. apply trans_ret_inv' in TR as (EQ & ->). + exists (val y), (Active Stuck). split; [| split]. + + apply trans_alt_estar_l, trans_ret. + + rewrite EQ. apply Rstuck. + + assumption. + - intros t' TR. apply trans_ret_inv' in TR as (_ & abs). discriminate. Qed. - Lemma step_ss'_ret_l (x : X) (y : Y) (u u' : ctree F D Y) : + Lemma step_ss'_ret_l (x : X) (y : X) (u u' : @S F B X) : R Stuck Stuck -> L (val x) (val y) -> - trans (val y) u u' -> - ss'_gen L R Reps (Ret x : ctree E C X) u. + trans_alt (val y) u u' -> + ss'_gen L R Reps (Ret x : ctree E B X) u. Proof. - intros. cbn. intros. - apply trans_val_inv in H1 as ?. subs. - split; [| split]; intros; inv_equ. - inv_trans. subst. rewrite <- EQ in H. etrans. + intros Rstuck Lval TR. split. + - intros t' l Hl TRl. apply trans_ret_inv' in TRl as (EQ & ->). + pose proof (trans_val_inv' TR) as EQ'. + exists (val y), u'. split; [| split]. + + apply trans_alt_estar_l, TR. + + rewrite EQ, EQ'. apply Rstuck. + + assumption. + - intros t' TRl. apply trans_ret_inv' in TRl as (_ & abs). discriminate. Qed. (*| @@ -328,82 +369,153 @@ Section Proof_Rules. the itree-style rule. |*) Lemma step_ss'_vis {Z Z'} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : - (forall x, exists y, R (k x) (k' y) /\ L (obs e x) (obs f y)) -> + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : + R (Passive e k) (Passive f k') -> + L (ask e) (ask f) -> ss'_gen L R Reps (Vis e k) (Vis f k'). Proof. - intros. split; [| split]; intros; inv_equ. - cbn; inv_trans; subst; - destruct (H x) as (x' & RR & LL); - cbn; do 3 eexists; intuition. - - rewrite EQ; eauto. - - assumption. + intros HRpas Lask. split. + - intros t' l Hl TR. apply trans_vis_inv' in TR as (EQ & ->). + exists (ask f), (Passive f k'). split; [| split]. + + apply trans_alt_estar_l, trans_ask. + + rewrite EQ. apply HRpas. + + assumption. + - intros t' TR. apply trans_vis_inv' in TR as (_ & abs). discriminate. Qed. Lemma step_ss'_vis_id {Z} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : - (forall x, R (k x) (k' x) /\ L (obs e x) (obs f x)) -> + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : + R (Passive e k) (Passive f k') -> + L (ask e) (ask f) -> ss'_gen L R Reps (Vis e k) (Vis f k'). Proof. - intros. apply step_ss'_vis. - eauto. + intros; apply step_ss'_vis; auto. Qed. Lemma step_ss'_vis_l {Z} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y), - (forall x, exists l' u', trans l' u u' /\ R (k x) u' /\ L (obs e x) l') -> + forall (e : E Z) (k : Z -> ctree E B X) (u : @S F B X), + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R (Passive e k) u' /\ L (ask e) l') -> ss'_gen L R Reps (Vis e k) u. Proof. - intros. split; [| split]; intros; inv_equ. - inv_trans. subst. destruct (H x) as (? & ? & ? & ? & ?). - eexists _, _. rewrite <- EQ in H2. etrans. + intros e k u (l' & u' & STEP & HRu & Lask). split. + - intros t' l Hl TR. apply trans_vis_inv' in TR as (EQ & ->). + exists l', u'. split; [| split]. + + assumption. + + rewrite EQ. assumption. + + assumption. + - intros t' TR. apply trans_vis_inv' in TR as (_ & abs). discriminate. Qed. (*| With this definition [ss'] of simulation, delayed nodes allow to perform a coinductive step. |*) - Lemma step_ss'_br_l {Z} (c : C Z) - (k : Z -> ctree E C X) (t': ctree F D Y): - (forall x, Reps (k x) t') -> - ss'_gen L R Reps (Br c k) t'. + Lemma trans_alt_br_inv {G : Type -> Type} {Z} (c : B Z) (k : Z -> ctree G B X) l u : + trans_alt l (Br c k) u -> l = ε /\ exists x, u ⩸ (Active (k x)). Proof. - ssplit; intros. - now apply productive_br in H0. - inv_equ. exists t'; split; eauto; rewrite <- EQ; auto. - inv_equ. + intros TR; unfold trans_alt in TR; cbn in TR. + dependent induction TR; inv_equ. + split; auto. + eexists; constructor. + rewrite H0; first [ now apply EQ | now symmetry; apply EQ + | now rewrite EQ | now rewrite <- EQ ]. Qed. - Lemma step_ss'_br_r {Z} (c : D Z) x - (k : Z -> ctree F D Y) (t: ctree E C X): + Lemma trans_alt_guard_inv {G : Type -> Type} (t : ctree G B X) l u : + trans_alt l (Guard t) u -> l = ε /\ u ⩸ (Active t). + Proof. + intros TR; unfold trans_alt in TR; cbn in TR. + dependent induction TR; inv_equ. + split; auto. + constructor. + first [ now rewrite H0, <- H | now rewrite H0, H + | now (rewrite H0; symmetry) ]. + Qed. + + Lemma step_ss'_br_l {Z} (c : B Z) + (k : Z -> ctree E B X) (u : @S F B X): + (forall x, Reps (Active (k x)) u) -> + ss'_gen L R Reps (Br c k) u. + Proof. + intros HReps'. split. + - intros t' l Hl TR. apply trans_alt_br_inv in TR as (-> & _). easy. + - intros t' TR. apply trans_alt_br_inv in TR as (_ & x & EQ). + exists u; split. + + apply (str_refl (trans_alt ε)); cbn; reflexivity. + + rewrite EQ. apply HReps'. + Qed. + + Lemma estar_trans {G : Type -> Type} (a b c : @S G B X) : + (trans_alt ε)^* a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. + Proof. + intros S1 S2. + assert (H : (@trans_alt G B X ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + apply H; eexists; eassumption. + Qed. + + Lemma estar_cons0 {G : Type -> Type} (a b c : @S G B X) : + trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. + Proof. + intros S1 S2. + assert (H : @trans_alt G B X ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + apply H; eexists; eassumption. + Qed. + + Lemma estar_single {G : Type -> Type} (a b : @S G B X) : + trans_alt ε a b -> (trans_alt ε)^* a b. + Proof. + intro S; eapply estar_cons0; [ exact S | apply trans_star_self ]. + Qed. + + Lemma estar_cons {G : Type -> Type} (a b c : @S G B X) l : + trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> + ((trans_alt ε)^* ⋅ trans_alt l) a c. + Proof. + intros S1 S2. + assert (H : @trans_alt G B X ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + ≦ (trans_alt ε)^* ⋅ trans_alt l) by ka. + apply H; eexists; eassumption. + Qed. + + Lemma estar_app {G : Type -> Type} (a b c : @S G B X) l : + (trans_alt ε)^* a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> + ((trans_alt ε)^* ⋅ trans_alt l) a c. + Proof. + intros S1 S2. + assert (H : (@trans_alt G B X ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + ≦ (trans_alt ε)^* ⋅ trans_alt l) by ka. + apply H; eexists; eassumption. + Qed. + + Lemma step_ss'_br_r {Z} (c : B Z) x + (k : Z -> ctree F B X) (t: @S E B X): ss'_gen L R Reps t (k x) -> ss'_gen L R Reps t (Br c k). Proof. - intros (HA & HB & HC); ssplit; intros. - - apply HA in H0 as (? & ? & ? & ? & ?). - exists x0, x1; etrans. auto. - - eapply HB in H as (? & ? & ?). eapply epsilon_br in H. etrans. - - eapply HC in H as (? & ? & ?). - eexists; split; [| eauto]. - eapply epsilon_br, H. + intros (HA & HB); split. + - intros t' l Hl TR. apply HA in TR as (l' & u' & STEP & HRtu & HL); auto. + exists l', u'; split; [| split; assumption]. + eapply estar_cons; [ apply trans_br | exact STEP ]. + - intros t' TR. apply HB in TR as (u' & STEP & HRep). + exists u'; split; [| assumption]. + eapply estar_cons0; [ apply trans_br | exact STEP ]. Qed. - Lemma step_ss'_br {Z Z'} (a: C Z) (b: D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + Lemma step_ss'_br {Z Z'} (a: B Z) (b: B Z') + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : (forall x, exists y, Reps (k x) (k' y)) -> ss'_gen L R Reps (Br a k) (Br b k'). Proof. - ssplit; intros. { now apply productive_br in H0. } - 2: inv_equ. - inv_equ. - setoid_rewrite EQ in H. destruct (H x). - eexists. split; [| eassumption]. - econstructor 2. - econstructor. - reflexivity. + intros HRep; split. + - intros t' l Hl TR. apply trans_alt_br_inv in TR as (-> & _); easy. + - intros t' TR. apply trans_alt_br_inv in TR as (_ & x & EQ). + destruct (HRep x) as (y & HR'). + exists (Active (k' y)); split. + + apply estar_single, trans_br. + + rewrite EQ. apply HR'. Qed. - Lemma step_ss'_br_id {Z} (c: C Z) (d: D Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : + Lemma step_ss'_br_id {Z} (c: B Z) (d: B Z) + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : (forall x, Reps (k x) (k' x)) -> ss'_gen L R Reps (Br c k) (Br d k'). Proof. @@ -411,103 +523,105 @@ Section Proof_Rules. Qed. Lemma step_ss'_guard_l - (t: ctree E C X) (t': ctree F D Y) : - Reps t t' -> - ss'_gen L R Reps (Guard t) t'. + (t: ctree E B X) (u: @S F B X) : + Reps t u -> + ss'_gen L R Reps (Guard t) u. Proof. - ssplit; intros. - now apply productive_guard in H0. - inv_equ. - inv_equ. - eexists t'; split. - reflexivity. - rewrite <- H0; auto. + intros HRep; split. + - intros t' l Hl TR. apply trans_alt_guard_inv in TR as (-> & _); easy. + - intros t' TR. apply trans_alt_guard_inv in TR as (_ & EQ). + exists u; split; [ apply trans_star_self | rewrite EQ; apply HRep ]. Qed. Lemma step_ss'_guard_r - (t: ctree E C X) (t': ctree F D Y) : + (t: @S E B X) (t': ctree F B X) : ss'_gen L R Reps t t' -> ss'_gen L R Reps t (Guard t'). Proof. - intros (HA & HB & HC); ssplit; intros. - - apply HA in H0 as (? & ? & ? & ? & ?). - do 2 eexists; etrans. - auto. - - eapply HB in H as (? & ? & ?). - eexists; split; [| eauto]. - eapply epsilon_guard, H. - - eapply HC in H as (? & ? & ?). - eexists; split; [| eauto]. - eapply epsilon_guard, H. + intros (HA & HB); split. + - intros s l Hl TR. apply HA in TR as (l' & u' & STEP & HRtu & HL); auto. + exists l', u'; split; [| split; assumption]. + eapply estar_cons; [ apply trans_guard | exact STEP ]. + - intros s TR. apply HB in TR as (u' & STEP & HRep). + exists u'; split; [| assumption]. + eapply estar_cons0; [ apply trans_guard | exact STEP ]. Qed. Lemma step_ss'_guard - (t: ctree E C X) (t': ctree F D Y) : + (t: ctree E B X) (t': ctree F B X) : Reps t t' -> ss'_gen L R Reps (Guard t) (Guard t'). Proof. - ssplit; intros. { now apply productive_guard in H0. } - inv_equ. - inv_equ. - setoid_rewrite H0 in H. - eexists. split; [| eassumption]. - now econstructor 3. + intros HRep; split. + - intros s l Hl TR. apply trans_alt_guard_inv in TR as (-> & _); easy. + - intros s TR. apply trans_alt_guard_inv in TR as (_ & EQ). + exists (Active t'); split. + + apply estar_single, trans_guard. + + rewrite EQ. apply HRep. Qed. Lemma step_ss'_epsilon_r : - forall (t : ctree E C X) (u u' : ctree F D Y), - ss'_gen L R Reps t u' -> epsilon u u' -> ss'_gen L R Reps t u. + forall (t : @S E B X) (u u' : @S F B X), + ss'_gen L R Reps t u' -> (trans_alt ε)^* u u' -> ss'_gen L R Reps t u. Proof. - intros. red in H0. rewrite (ctree_eta u). rewrite (ctree_eta u') in H. - genobs u ou. genobs u' ou'. clear u Heqou u' Heqou'. - revert t H. induction H0; intros. - - now subs. - - eapply step_ss'_br_r, IHepsilon_; eauto. - - eapply step_ss'_guard_r, IHepsilon_; eauto. + intros t u u' (HA & HB) STAR; split. + - intros s l Hl TR. apply HA in TR as (l' & u'' & STEP & HRtu & HL); auto. + exists l', u''; split; [| split; assumption]. + eapply estar_app; eassumption. + - intros s TR. apply HB in TR as (u'' & STEP & HRep). + exists u''; split; [| assumption]. + eapply estar_trans; eassumption. Qed. Lemma ss'_gen_epsilon_l : - forall (t t' : ctree E C X) (u : ctree F D Y), + forall (t t' : @S E B X) (u : @S F B X), Reps <= ss'_gen L R Reps -> ss'_gen L R Reps t u -> - epsilon t t' -> + (trans_alt ε)^* t t' -> ss'_gen L R Reps t' u. Proof. - intros. red in H1. rewrite (ctree_eta t'). rewrite (ctree_eta t) in H0. - genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'. - revert u H0. induction H1; intros. - - now subs. - - apply IHepsilon_. rewrite <- ctree_eta. - eapply ss'_gen_br in H0 as (? & ? & ?). - apply H in H2. eapply step_ss'_epsilon_r in H2; eauto. - - apply IHepsilon_. rewrite <- ctree_eta. - eapply ss'_gen_guard in H0 as (? & ? & ?). - apply H in H2. eapply step_ss'_epsilon_r in H2; eauto. - Qed. - + intros t t' u HRle HSS STAR. + destruct STAR as [n STAR]. revert t t' u HRle HSS STAR. + induction n; intros t t' u HRle HSS STAR. + - cbn in STAR. now rewrite STAR in HSS. + - destruct STAR as [m STEP REST]. + destruct HSS as (HA & HB). + apply HB in STEP as (u' & STARu & HRep). + apply HRle in HRep. + eapply step_ss'_epsilon_r in HRep; [| exact STARu]. + eapply IHn; [ exact HRle | exact HRep | exact REST ]. + Qed. (*| Same goes for visible τ nodes. |*) Lemma step_ss'_step - (t : ctree E C X) (t': ctree F D Y) : + (t : ctree E B X) (t': ctree F B X) : L τ τ -> R t t' -> ss'_gen L R Reps (Step t) (Step t'). Proof. - split; [| split]; intros; inv_equ. - inv_trans; subst. - cbn; do 3 eexists; intuition; subs; eauto. + intros Ltau HRtt; split. + - intros s l Hl TR. apply trans_step_inv' in TR as (EQ & ->). + exists τ, (Active t'). split; [| split]. + + apply trans_alt_estar_l, trans_step. + + rewrite EQ. apply HRtt. + + assumption. + - intros s TR. apply trans_step_inv' in TR as (_ & abs). discriminate. Qed. Lemma step_ss'_step_l : - forall (t : ctree E C X) (u : ctree F D Y), - (exists l' u', trans l' u u' /\ R t u' /\ L τ l') -> + forall (t : ctree E B X) (u : @S F B X), + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R t u' /\ L τ l') -> ss'_gen L R Reps (Step t) u. Proof. - intros. ssplit; intros; inv_equ. - inv_trans. subst. destruct H as (? & ? & ? & ? & ?). - eexists _, _. rewrite <- EQ in H1. etrans. + intros t u (l' & u' & STEP & HRtu & Ltau). split. + - intros s l Hl TR. apply trans_step_inv' in TR as (EQ & ->). + exists l', u'. split; [| split]. + + assumption. + + rewrite EQ. assumption. + + assumption. + - intros s TR. apply trans_step_inv' in TR as (_ & abs). discriminate. Qed. (*| @@ -521,34 +635,34 @@ End Proof_Rules. (* Specialized proof rules *) -Lemma ssim'_stuck' {E F C D X Y} +Lemma ssim'_stuck' {E F B X} (L : rel _ _) : - ssim' L (Stuck : ctree E C X) (Stuck : ctree F D Y). + ssim' L (Stuck : ctree E B X) (Stuck : ctree F B X). Proof. step. apply step_ss'_stuck. Qed. -Lemma step_ssbt'_ret {E F C D X Y} - (x : X) (y : Y) (L : rel _ _) - {R : Chain (@ss' E F C D X Y L)} : +Lemma step_ssbt'_ret {E F B X} + (x : X) (y : X) (L : rel _ _) + {R : Chain (@ss' E F B X L)} : L (val x) (val y) -> - ss' L `R (Ret x : ctree E C X) (Ret y : ctree F D Y). + ss' L `R (Ret x : ctree E B X) (Ret y : ctree F B X). Proof. intros. unshelve eapply step_ss'_ret; eauto. apply (b_chain R). apply ss'_stuck. Qed. -Lemma ssim'_ret {E F C D X Y} - (x : X) (y : Y) (L : rel _ _) : +Lemma ssim'_ret {E F B X} + (x : X) (y : X) (L : rel _ _) : L (val x) (val y) -> - ssim' L (Ret x : ctree E C X) (Ret y : ctree F D Y). + ssim' L (Ret x : ctree E B X) (Ret y : ctree F B X). Proof. now intros; step; apply step_ssbt'_ret. Qed. -Lemma ssim'_step {E F C D X Y} - (t : ctree E C X) (u : ctree F D Y) (L : rel _ _) : +Lemma ssim'_step {E F B X} + (t : ctree E B X) (u : ctree F B X) (L : rel _ _) : L τ τ -> ssim' L t u -> ssim' L (Step t) (Step u). @@ -556,36 +670,36 @@ Proof. now intros; step; apply step_ss'_step. Qed. -Lemma ssim'_guard {E F C D X Y} - (t : ctree E C X) (u : ctree F D Y) (L : rel _ _) : +Lemma ssim'_guard {E F B X} + (t : ctree E B X) (u : ctree F B X) (L : rel _ _) : ssim' L t u -> ssim' L (Guard t) (Guard u). Proof. now intros; step; apply step_ss'_guard. Qed. -Lemma ssim'_br {E F C D X Y Z Z'} {L} - (c: C Z) (d: D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : +Lemma ssim'_br {E F B X Z Z'} {L} + (c: B Z) (d: B Z') + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : (forall x, exists y, ssim' L (k x) (k' y)) -> ssim' L (Br c k) (Br d k'). Proof. now intros; step; apply step_ss'_br. Qed. -Lemma ssim'_br_id {E F C D X Y Z} {L} - (c: C Z) (d: D Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : +Lemma ssim'_br_id {E F B X Z} {L} + (c: B Z) (d: B Z) + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : (forall x, ssim' L (k x) (k' x)) -> ssim' L (Br c k) (Br d k'). Proof. now intros; step; apply step_ss'_br_id. Qed. -Lemma step_ssbt'_brS {E F C D X Y Z Z'} {L} - {R : Chain (@ss' E F C D X Y L)} - (c: C Z) (d: D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : +Lemma step_ssbt'_brS {E F B X Z Z'} {L} + {R : Chain (@ss' E F B X L)} + (c: B Z) (d: B Z') + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : L τ τ -> (forall x, exists y, `R (k x) (k' y)) -> ss' L `R (BrS c k) (BrS d k'). @@ -596,9 +710,9 @@ Proof. apply (b_chain R), step_ss'_step; auto. Qed. -Lemma ssim'_brS {E F C D X Y Z Z'} {L} - (c: C Z) (d: D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : +Lemma ssim'_brS {E F B X Z Z'} {L} + (c: B Z) (d: B Z') + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : L τ τ -> (forall x, exists y, ssim' L (k x) (k' y)) -> ssim' L (BrS c k) (BrS d k'). @@ -606,10 +720,10 @@ Proof. now intros; step; apply step_ssbt'_brS. Qed. -Lemma step_ssbt'_brS_id {E F C D X Y Z} {L} - {R : Chain (@ss' E F C D X Y L)} - (c: C Z) (d: D Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : +Lemma step_ssbt'_brS_id {E F B X Z} {L} + {R : Chain (@ss' E F B X L)} + (c: B Z) (d: B Z) + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : L τ τ -> (forall x, ` R (k x) (k' x)) -> ss' L `R (BrS c k) (BrS d k'). @@ -619,9 +733,9 @@ Proof. intros; apply (b_chain R), step_ss'_step; auto. Qed. -Lemma ssim'_brS_id {E F C D X Y Z} {L} - (c: C Z) (d: D Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : +Lemma ssim'_brS_id {E F B X Z} {L} + (c: B Z) (d: B Z) + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : L τ τ -> (forall x, ssim' L (k x) (k' x)) -> ssim' L (BrS c k) (BrS d k'). @@ -630,39 +744,41 @@ Proof. Qed. Lemma ssim'_vis - {E F C D X Y Z Z'} {L} + {E F B X Z Z'} {L} (e: E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : - (forall x, exists y, ssim' L (k x) (k' y) /\ L (obs e x) (obs f y)) -> + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : + ssim' L (Passive e k) (Passive f k') -> + L (ask e) (ask f) -> ssim' L (Vis e k) (Vis f k'). Proof. - now intros; step; apply step_ss'_vis. + intros Hpas Hask; step; apply step_ss'_vis; [exact Hpas | exact Hask]. Qed. Lemma ssim'_vis_id - {E F C D X Y Z} {L} + {E F B X Z} {L} (e: E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : - (forall x, ssim' L (k x) (k' x) /\ L (obs e x) (obs f x)) -> + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : + ssim' L (Passive e k) (Passive f k') -> + L (ask e) (ask f) -> ssim' L (Vis e k) (Vis f k'). Proof. - now intros; step; apply step_ss'_vis_id. + intros Hpas Hask; step; apply step_ss'_vis_id; [exact Hpas | exact Hask]. Qed. Lemma ssim'_vis_l - {E F C D X Y Z} {L} + {E F B X Z} {L} (e: E Z) - (k : Z -> ctree E C X) (u : ctree F D Y) : - (forall x, exists l' u', trans l' u u' /\ ssim' L (k x) u' /\ L (obs e x) l') -> + (k : Z -> ctree E B X) (u : @S F B X) : + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ ssim' L (Passive e k) u' /\ L (ask e) l') -> ssim' L (Vis e k) u. Proof. - now intros; step; apply step_ss'_vis_l. + intros H; step; apply step_ss'_vis_l; exact H. Qed. -Lemma ssim'_epsilon_l {E F C D X Y} {L} : - forall (t t' : ctree E C X) (u : ctree F D Y), +Lemma ssim'_epsilon_l {E F B X} {L} : + forall (t t' : @S E B X) (u : @S F B X), ssim' L t u -> - epsilon t t' -> + (trans_alt ε)^* t t' -> ssim' L t' u. Proof. intros. step. eapply ss'_gen_epsilon_l. @@ -673,36 +789,37 @@ Qed. Section Inversion_Rules. - Context {E F C D : Type -> Type} - {X Y : Type} - {L : rel (@label E) (@label F)} - {R Reps : rel (ctree E C X) (ctree F D Y)}. + Context {E F B : Type -> Type} + {X : Type} + {L : rel (@label E X) (@label F X)} + {R Reps : rel (@S E B X) (@S F B X)}. Lemma ss'_vis_l_inv {Z} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, + forall (e : E Z) (k : Z -> ctree E B X) (u : @S F B X), ss'_gen L R Reps (Vis e k) u -> - exists l' u', trans l' u u' /\ R (k x) u' /\ L (obs e x) l'. + exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R (Passive e k) u' /\ L (ask e) l'. Proof. - intros. apply H; etrans. + intros e k u (HA & _). + apply (HA (Passive e k) (ask e)); [ discriminate | apply trans_ask ]. Qed. Lemma ss'_step_l_inv : - forall (t : ctree E C X) (u : ctree F D Y), + forall (t : ctree E B X) (u : @S F B X), ss'_gen L R Reps (Step t) u -> - exists l' u', trans l' u u' /\ R t u' /\ L τ l'. + exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R t u' /\ L τ l'. Proof. - intros * (HA & HB & HC). - apply HA; etrans. + intros t u (HA & _). + apply (HA (Active t) τ); [ discriminate | apply trans_step ]. Qed. End Inversion_Rules. -Definition epsilon_ctx {E C X} (R : ctree E C X -> Prop) - (t : ctree E C X) := +Definition epsilon_ctx {E B X} (R : ctree E B X -> Prop) + (t : ctree E B X) := exists t', epsilon t t' /\ R t'. -Definition epsilon_det_ctx {E C X} (R : ctree E C X -> Prop) - (t : ctree E C X) := +Definition epsilon_det_ctx {E B X} (R : ctree E B X -> Prop) + (t : ctree E B X) := exists t', epsilon_det t t' /\ R t'. Section upto. @@ -712,7 +829,7 @@ Section upto. (* Up-to epsilon *) - Program Definition epsilon_ctx_r : mon (rel (ctree E C X) (ctree F D Y)) + Program Definition epsilon_ctx_r : mon (rel (ctree E B X) (ctree F B X)) := {| body R t u := epsilon_ctx (fun u => R t u) u |}. Next Obligation. destruct H0 as (? & ? & ?). red. eauto. @@ -785,7 +902,7 @@ Section upto. End upto. -Arguments ss_sst' {E F C D X Y} L. +Arguments ss_sst' {E F B X} L. (*| Up-to [bind] context simulations @@ -809,7 +926,7 @@ Section bind. Lemma bind_chain_gen L0 (ISVR : is_update_val_rel L R0 L0) {R : Chain (@ss' E F C D X' Y' L)} : - forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), + forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : Y -> ctree F B X'), ssim L0 t t' -> (forall x x', R0 x x' -> elem R (k x) (k' x')) -> ` R (bind t k) (bind t' k'). @@ -897,8 +1014,8 @@ Expliciting the reasoning rule provided by the up-to principles. Lemma ss'_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} (R0 : rel X Y) L0 (HL0 : is_update_val_rel L R0 L0) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): + (t1 : ctree E B X) (t2: ctree F B X) + (k1 : X -> ctree E B X') (k2 : Y -> ctree F B X'): ssim L0 t1 t2 -> (forall x y, R0 x y -> ssim' L (k1 x) (k2 y)) -> ssim' L (t1 >>= k1) (t2 >>= k2). @@ -910,7 +1027,7 @@ Qed. Lemma ss'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} (R0 : rel X Y) {R : Chain (@ss' E F C D X' Y' L)} : - forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), + forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : Y -> ctree F B X'), t (≲update_val_rel L R0) t' -> (forall x x', R0 x x' -> elem R (k x) (k' x')) -> ` R (bind t k) (bind t' k'). @@ -921,8 +1038,8 @@ Qed. Lemma ssim'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} (R0 : rel X Y) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y'): + (t1 : ctree E B X) (t2: ctree F B X) + (k1 : X -> ctree E B X') (k2 : Y -> ctree F B X'): t1 (≲update_val_rel L R0) t2 -> (forall x y, R0 x y -> ssim' L (k1 x) (k2 y)) -> ssim' L (t1 >>= k1) (t2 >>= k2). @@ -932,7 +1049,7 @@ Qed. Lemma ss'_clo_bind_eq {E C D: Type -> Type} {X X': Type} {R : Chain (@ss' E E C D X' X' eq)} : - forall (t : ctree E C X) (t' : ctree E D X) (k : X -> ctree E C X') (k' : X -> ctree E D X'), + forall (t : ctree E B X) (t' : ctree E D X) (k : X -> ctree E B X') (k' : X -> ctree E D X'), t ≲ t' -> (forall x, elem R (k x) (k' x)) -> ` R (bind t k) (bind t' k'). @@ -944,8 +1061,8 @@ Proof. Qed. Lemma ssim'_clo_bind_eq {E C D: Type -> Type} {X X': Type} - (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X'): + (t1 : ctree E B X) (t2: ctree E D X) + (k1 : X -> ctree E B X') (k2 : X -> ctree E D X'): t1 ≲ t2 -> (forall x, ssim' eq (k1 x) (k2 x)) -> ssim' eq (t1 >>= k1) (t2 >>= k2). @@ -953,8 +1070,8 @@ Proof. apply ss'_clo_bind_eq. Qed. -Lemma ss_ss'_chain {E F C D X Y L} {R : Chain (ss' L)} : - forall (t : ctree E C X) (u : ctree F D Y), +Lemma ss_ss'_chain {E F B X L} {R : Chain (ss' L)} : + forall (t : ctree E B X) (u : ctree F B X), ss L `R t u -> ss' L `R t u. Proof. @@ -968,8 +1085,8 @@ Proof. Qed. (* This alternative notion of simulation is equivalent to [ssim] *) -Theorem ssim_ssim' {E F C D X Y} : - forall L (t : ctree E C X) (t' : ctree F D Y), ssim L t t' <-> ssim' L t t'. +Theorem ssim_ssim' {E F B X} : + forall L (t : ctree E B X) (t' : ctree F B X), ssim L t t' <-> ssim' L t t'. Proof. split; intros. - red. revert t t' H. coinduction R CH. intros. diff --git a/theories/Eq/Trace.v b/theories/Eq/Trace.v index d2e9342..9fb2dff 100644 --- a/theories/Eq/Trace.v +++ b/theories/Eq/Trace.v @@ -14,15 +14,16 @@ From CTree Require Import Base coinductive definitions for execution traces and trace equivalence. |*) -CoInductive trace {E} := -| Cons (l : @label E) (s : trace) +CoInductive trace {E R} := +| Cons (l : @label E R) (s : trace) | Nil. Program Definition htr {E C X} : - mon (@trace E -> ctree E C X -> Prop) := + mon (@trace E X -> ctree E C X -> Prop) := {| body R s t := match s with - | Cons l s' => exists t', trans l t t' /\ R s' t' + (* TODO : Active or passive? *) + | Cons l s' => exists t', trans l t (Active t') /\ R s' t' | Nil => True end |}. @@ -32,12 +33,12 @@ Defined. Definition has_trace {E C X} := gfp (@htr E C X). -Definition tracincl {E C D X Y} - (t : ctree E C X) (t' : ctree E D Y) := +Definition tracincl {E C D X} + (t : ctree E C X) (t' : ctree E D X) := forall s, has_trace s t -> has_trace s t'. -Definition traceq {E C D X Y} - (t : ctree E C X) (t' : ctree E D Y) := +Definition traceq {E C D X} + (t : ctree E C X) (t' : ctree E D X) := tracincl t t' /\ tracincl t' t. (*| @@ -68,18 +69,28 @@ Tactic Notation "__trace_play" "in" hyp(H) := rewrite ctree_eta in TR; cbn in TR; inv_trans; subst. +(* Lemma ss_proper_trans : *) + (*| Trace inclusion is weaker than similarity, and trace equivalence is weaker than bisimilarity. |*) Lemma ssim_tracincl : forall {E C X} (t t' : ctree E C X), - ssim eq t t' -> tracincl t t'. +ssim Leq t t' -> tracincl t t'. Proof. - red. red. intros. revert t t' H s H0. coinduction R CH. intros. + red. red. intros. + revert t t' H s H0. coinduction R CH. intros. simpl. destruct s; auto. + (* Unset Printing Notations. *) step in H0. cbn in H0. destruct H0 as (? & ? & ?). step in H. apply H in H0. destruct H0 as (? & ? & ? & ? & ?). subst. - exists x1. split. apply H0. eapply CH. apply H2. red. apply H1. + inv H0; try easy. + exists x. split. + 2: eapply CH; eauto. + (* Print transR. *) + unfold Leq in H3. assert (eq l x0). + erewrite (ActAct) with (t:=x). + rewrite H2. apply H0. eapply CH. apply H2. red. apply H1. Qed. Lemma sbisim_traceq : forall {E C X} (t t' : ctree E C X), diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v new file mode 100644 index 0000000..3063c84 --- /dev/null +++ b/theories/Eq/TransAlt.v @@ -0,0 +1,2735 @@ +(*| +========================================== +Transition relations over concurrent trees +========================================== + +Trees represent the dynamics of non-deterministic procesess. +In order to capture their behavioral equivalence, we follow the +process-algebra tradition and define bisimulation atop of labelled +transition systems. + +A node is said to be _observable_ if it is a visible event, a return +node, or an internal br tagged as visible. +The first transition relation we introduce is [trans_alt]: a tree can +finitely descend through unobservable brs until it reaches an +observable node. At this point, it steps following the simple rules: +- [Ret v] steps to a silently blocked state by emitting a value +label of [v] +- [Vis e k] can step to any [k x] by emitting an event label tagged +with both [e] and [x] + + +(* TODO remove, note: this above will change with the vis fix *) + +- [BrS k] can step to any [k x] by emitting a tau label + +This transition system will define a notion of strong bisimulation +in the process algebra tradition. +It also leads to a weak bisimulation by defining [wtrans] as a +sequence of tau steps, and allowing a challenge to be answered by +[wtrans . trans_alt . wtrans]. +Once [trans_alt] is defined over our structure, we can reuse the constructions +used by Pous in [Coinduction All the Way Up] to build these weak relations +-- with the exception that we need to work in Kleene Algebras w.r.t. to model +closed under [equ] rather than [eq]. + +.. coq:: none +|*) + +From Stdlib Require Import Fin. + +From Coinduction Require Import all. + +From ITree Require Import + Core.Subevent + Indexed.Sum. + +From CTree Require Import + CTree Eq.Shallow Eq.Equ Eq.Epsilon. + +From RelationAlgebra Require Import + monoid + kat + kat_tac + prop + rel + srel + comparisons + rewriting + normalisation. + +Import CTree. +Import CTreeNotations. +Import EquNotations. +Open Scope ctree. + +Set Implicit Arguments. +Set Primitive Projections. + +#[local] Tactic Notation "step" := __step_equ. +#[local] Tactic Notation "step" "in" ident(H) := __step_in_equ H. + +(*| +.. coq:: +|*) + +Variant S E B R := + | Active (t : ctree E B R) + | Passive {X} (e : E X) (k : X -> ctree E B R). + +Variant SeqR {E B X Y} (RR : hrel X Y) : S E B X -> S E B Y -> Prop := + | ActAct t u (EQ: equ RR t u) : SeqR RR (Active t) (Active u) + | PasPas {A} e (k g : A -> _) (EQ: forall a, equ RR (k a) (g a)) : SeqR RR (Passive e k) (Passive e g) +. +Hint Constructors SeqR : core. +Definition Seq {E B X} := (@SeqR E B X X eq). +Hint Unfold Seq : core. + +#[global] Instance SeqR_equiv {E B R} {RR : rel R R} {RE: Equivalence RR}: Equivalence (@SeqR E B R R RR). +Proof. + constructor. + - intros []; auto. + - intros ? ? []; constructor; intros; now symmetry. + - intros ? ? ? EQ1 EQ2. + inv EQ1. + inv EQ2; constructor; intros; etransitivity; eauto. + dependent induction EQ2; constructor; intros; etransitivity; eauto. +Qed. +Arguments Active {E B R}. +Arguments Passive {E B R X} e k. + +Section Trans. + + Context {E B : Type -> Type} {R : Type}. + Notation S := (S E B R). + Notation Seq := (@Seq E B R). + + Definition SS : EqType := + {| type_of := S ; Eq := Seq |}. + + + + (* HERE *) +(* Step one: new LTS. Therefore step zero is new labels. *) + +(*| +The domain of labels of the LTS. +Note that it could be typed more strongly: [val] labels can only +be of type [R]. However typing it statically makes lemmas about +[bind] particularly awkward to state, so this seems to be the +least annoying solution. +|*) + Variant label : Type := + | τ + | ε (* \upepsilon or \varepsilon depending on your extension *) + | ask {X : Type} (e : E X) + | rcv {X : Type} (e : E X) (v : X) (* Note: I think we need to remember which request led to the response for the bisimilarity to be right, but I am not 100% sure, [e] might be spurious *) + | val (v : R). + + Variant is_val : label -> Prop := + | Is_val : forall x, is_val (val x). + + Lemma is_val_τ : ~ is_val τ. + Proof. + intro H. inversion H. + Qed. + + Lemma is_val_ask {X} (e : E X) : ~ is_val (ask e). + Proof. + intro H. inversion H. + Qed. + + Lemma is_val_rcv {X} (e : E X) (x : X) : ~ is_val (rcv e x). + Proof. + intro H. inversion H. + Qed. + +(*| +The transition relation over [ctree]s. +It can either: +- recursively crawl through invisible [br] node; +- stop at a successor of a [Step] node, labelling the transition [tau]; +- stop at a successor of a [Vis] node, labelling the transition by the event and branch taken; +- stop at a sink (implemented as a [Stuck] node) by stepping from a [ret v] +node, labelling the transition by the returned value. +|*) + + + (* Definition ss'_gen {E F C D : Type -> Type} {X Y : Type} + (L : rel (@label E) (@label F)) + (R Reps : rel (ctree E C X) (ctree F D Y)) + (t : ctree E C X) (u : ctree F D Y) := + + (productive t -> + (* t and u step together under labels related by L, assuming + t is "productive"; that is, not a Br *) + forall l t', trans_alt l t t' -> + exists l' u', trans_alt l' u u' /\ R t' u' /\ L l l') + (* if t branches, u ε-steps to u' *) + /\ (forall Z (c : C Z) k, + t ≅ Br c k -> + forall x, exists u', epsilon u u' /\ Reps (k x) u') + /\ (forall t', + t ≅ Guard t' -> + exists u', epsilon u u' /\ Reps t' u'). *) + + + +Definition sss {R1 R2} RR := @SeqR E B _ _ (@equ E B R1 R2 RR). + +(* epsilon lifted through S *) + + Inductive epsilon_S : TransAlt.S E B R -> TransAlt.S E B R -> Prop := + | epsilon_id_AA t t' : epsilon t t' -> epsilon_S (Active t) (Active t') + | epsilon_id_AP {X} t e k : forall x, epsilon t (k x) -> epsilon_S (Active t) (@Passive E B R X e k) + | epsilon_id_PA {X} t e k : forall x, epsilon (k x) t -> epsilon_S (@Passive E B R X e k) (Active t) + | epsilon_id_PP {X} e k1 k2 : forall x y, epsilon (k1 x) (k2 y) -> epsilon_S (@Passive E B R X e k1) (@Passive E B R X e k2) + . + +(* question: equ constraints as before or direct constructors? *) + Variant transR : label -> hrel S S := + + | Transbr {X} (c : B X) t k u : + (* u reachable from (Br c k) *) + t ≅ Br c k -> + forall x, u ≅ k x -> + (* forall x, epsilon_S (Active (k x)) u -> *) + transR ε (Active t) (Active u) + + | Transguard t t' u : + t ≅ Guard t' -> + u ≅ t' -> + (* epsilon_S (Active t') u -> *) + transR ε (Active t) (Active u) + + | Transstep t t' u : + t ≅ Step t' -> + u ≅ t' -> + transR τ (Active t) (Active u) + + | Transask {X} (e : E X) t k : + t ≅ Vis e k -> + transR (ask e) (Active t) (Passive e k) + + | Transrcv {X} (e : E X) (x : X) k t : + k x ≅ t -> + transR (rcv e x) (Passive e k) (Active t) + + | Transval t r u : + t ≅ Ret r -> + u ≅ Stuck -> + transR (val r) (Active t) (Active u) + + . + Hint Constructors transR : core. + + #[global] Instance equ_Seq_active : Proper (equ eq ==> Seq) Active. + Proof. + now intros ?? EQ; constructor. + Qed. + + #[global] Instance equ_Seq_passive {X} (e : E X) : Proper (pointwise_relation X (equ eq) ==> Seq) (Passive e). + Proof. + now intros ?? EQ; constructor. + Qed. + +Ltac epsilon_congr := + repeat match goal with | [HE : epsilon_S (Active _) (Active _) |- _] => inv HE + | [HE : epsilon_S _ (Passive _ _) |- _] => dependent destruction HE + | [HE : epsilon_S (Passive _ _ ) _ |- _] => dependent destruction HE + | [|- epsilon_S _ _] => econstructor + end; + match goal with + H: epsilon ?t1 ?t2 |- epsilon ?t3 ?t4 => + try match goal with [EQ13 : t1 ≅ t3 |- _] => rewrite <- EQ13; eauto end; + try match goal with [EQ31 : t3 ≅ t1 |- _] => rewrite EQ31; eauto end; + try match goal with [EQ24 : t2 ≅ t4 |- _] => rewrite <- EQ24; eauto end; + try match goal with [EQ42 : t4 ≅ t2 |- _] => rewrite EQ42; eauto end; + try match goal with [EQ : forall a, (?k a) ≅ ?g a |- epsilon _ (?g _)] => rewrite <- EQ; eauto end; + try match goal with [EQ : forall a, (?k a) ≅ ?g a |- epsilon _ (?k _)] => rewrite EQ; eauto end + end. + + + #[global] Instance transR_equ_ l : + Proper (Seq ==> Seq ==> iff) (transR l). + Proof. + intros ?? EQ1 ?? EQ2; split; intros TR. + - revert y y0 EQ1 EQ2; dependent induction TR; intros y y0 EQ1 EQ2. + + inv EQ1; inv EQ2. + * econstructor 1. + rewrite <- EQ, H; reflexivity. + rewrite <- EQ0. eassumption. + + inv EQ1; inv EQ2. + econstructor 2. + rewrite <- EQ, H; reflexivity. + now rewrite <- EQ0. + + inv EQ1; inv EQ2. + econstructor 3. + rewrite <- EQ , H; reflexivity. + rewrite <- EQ0, H0; reflexivity. + + inv EQ1. dependent induction EQ2. + econstructor 4. + rewrite <- EQ0,H. + step; constructor. + apply EQ. + + dependent induction EQ1; inv EQ2. + econstructor 5. + specialize (EQ x); rewrite <- EQ, H; auto. + + inv EQ1; inv EQ2. + econstructor 6. + rewrite <- EQ, H; reflexivity. + rewrite <- EQ0, H0; reflexivity. + - revert x x0 EQ1 EQ2; dependent induction TR; intros y y0 EQ1 EQ2. + + inv EQ1; inv EQ2. + econstructor 1. + rewrite EQ, H; reflexivity. + rewrite EQ0. eauto. + + inv EQ1; inv EQ2. + econstructor 2. + rewrite EQ, H; reflexivity. + now rewrite EQ0. + + inv EQ1; inv EQ2. + econstructor 3. + rewrite EQ , H; reflexivity. + rewrite EQ0, H0; reflexivity. + + inv EQ1. dependent induction EQ2. + econstructor 4. + rewrite EQ0,H. + step; constructor. + intros ?; symmetry; apply EQ. + + dependent induction EQ1; inv EQ2. + econstructor 5. + specialize (EQ x); rewrite EQ, H, EQ0; auto. + + inv EQ1; inv EQ2. + econstructor 6. + rewrite EQ, H; reflexivity. + rewrite EQ0, H0; reflexivity. + Qed. + +(*| +[equ] is congruent for [transR], we can hence build a [srel] and build our +relations in this model to still exploit the automation from the [RelationAlgebra] +library. +|*) + #[global] Instance transR_equ l : + Proper (Seq ==> Seq ==> iff) (transR l). + Proof. + intros ? ? eqt ? ? equ. + inv eqt; inv equ. + now rewrite EQ,EQ0. + rewrite EQ. + all: try now rewrite EQ, EQ0. + assert (H: Seq (Passive e k) (Passive e g)) + by (apply equ_Seq_passive; red; apply EQ0); now rewrite H. + rewrite EQ0. + assert (H: Seq (Passive e k) (Passive e g)) + by (apply equ_Seq_passive; red; apply EQ); now rewrite H. + assert (H1: Seq (Passive e k) (Passive e g)) + by (apply equ_Seq_passive; red; apply EQ); + assert (H2: Seq (Passive e0 k0) (Passive e0 g0)) + by (apply equ_Seq_passive; red; apply EQ0); + now rewrite H1,H2. + Qed. + + Definition trans_alt l : srel SS SS := {| hrel_of := transR l : hrel SS SS |}. + +(*| +Extension of [trans_alt] with its reflexive closure, labelled by [τ]. +|*) + Definition etrans (l : label) : srel SS SS := + match l with + | τ => (cup (trans_alt l) 1) + | _ => trans_alt l + end. + +(*| +The transition for the weak bisimulation: a sequence of +internal steps, a labelled step, and a new sequence of internal ones +|*) + + Definition wtrans l : srel SS SS := + (trans_alt τ)^* ⋅ etrans l ⋅ (trans_alt τ)^*. + + Definition pwtrans l : srel SS SS := + (trans_alt τ)^* ⋅ trans_alt l ⋅ (trans_alt τ)^*. + + Definition τtrans : srel SS SS := + (trans_alt τ)^+. + + (*| +---------------------------------------------- +Elementary theory for the transition relations +---------------------------------------------- + +Inclusion relation between the three relations: +[trans_alt l ≤ etrans l ≤ wtrans l] + +[etrans] is reflexive, and hence so is [wtrans] +[etrans τ p p] + +[wtrans] can be built by consing or snocing [trans_alt τ] +[trans_alt τ p p' -> wtrans l p' p'' -> wtrans l p p''] +[wtrans l p p' -> trans_alt τ p' p'' -> wtrans l p p''] + +Introduction rules for [trans_alt] +[trans_alt (val v) (ret v) stuck] +[trans_alt (obs e v) (Vis e k) (k v)] +[trans_alt l (k x) u -> trans_alt l (BrD n k) u] +[trans_alt τ (Step t) t] +[trans_alt τ (BrS n k) (k x)] +[trans_alt l t u -> trans_alt l (Guard t) u] + +Elimination rules for [trans_alt] +[trans_alt l (Ret x) u -> l = val x /\ t ≅ stuck] +[trans_alt l (Vis e k) u -> exists v, l = obs e v /\ t ≅ k v] +[trans_alt l (Step t) u -> t ≅ u /\ l = τ] +[trans_alt l (Br n k) u -> exists x, trans_alt l (k x) u] +[trans_alt l (BrS n k) u -> exists x, t' ≅ k x /\ l = τ] +[trans_alt l (Guard t) u -> trans_alt l t u] + +|*) + Lemma trans_etrans l: trans_alt l ≦ etrans l. + Proof. + unfold etrans; case l; ka. + Qed. + Lemma etrans_wtrans l: etrans l ≦ wtrans l. + Proof. + unfold wtrans; ka. + Qed. + Lemma trans_wtrans l: trans_alt l ≦ wtrans l. + Proof. rewrite trans_etrans. apply etrans_wtrans. Qed. + Lemma τtrans_wtrans : τtrans ≦ wtrans τ. + Proof. + unfold τtrans, wtrans, etrans; ka. + Qed. + Lemma pwtrans_wtrans l : pwtrans l ≦ wtrans l. + Proof. + unfold pwtrans, wtrans, etrans; case l; ka. + Qed. + + Lemma trans_etrans_ l: forall p p', trans_alt l p p' -> etrans l p p'. + Proof. apply trans_etrans. Qed. + Lemma trans_wtrans_ l: forall p p', trans_alt l p p' -> wtrans l p p'. + Proof. apply trans_wtrans. Qed. + Lemma etrans_wtrans_ l: forall p p', etrans l p p' -> wtrans l p p'. + Proof. apply etrans_wtrans. Qed. + Lemma τtrans_wtrans_ : forall p p', τtrans p p' -> wtrans τ p p'. + Proof. apply τtrans_wtrans. Qed. + Lemma pwtrans_wtrans_ l : forall p p', pwtrans l p p' -> wtrans l p p'. + Proof. apply pwtrans_wtrans. Qed. + + Lemma enil p: etrans τ p p. + Proof. cbn. now right. Qed. + Lemma wnil p: wtrans τ p p. + Proof. apply etrans_wtrans, enil. Qed. + + Lemma wcons l: forall p p' p'', trans_alt τ p p' -> wtrans l p' p'' -> wtrans l p p''. + Proof. + assert ((trans_alt τ: srel SS SS) ⋅ wtrans l ≦ wtrans l) as H + by (unfold wtrans; ka). + intros. apply H. eexists; eassumption. + Qed. + Lemma wsnoc l: forall p p' p'', wtrans l p p' -> trans_alt τ p' p'' -> wtrans l p p''. + Proof. + assert (wtrans l ⋅ trans_alt τ ≦ wtrans l) as H + by (unfold wtrans; ka). + intros. apply H. eexists; eassumption. + Qed. + + Lemma wconss l: forall p p' p'', wtrans τ p p' -> wtrans l p' p'' -> wtrans l p p''. + Proof. + assert (wtrans τ ⋅ wtrans l ≦ wtrans l) as H by (unfold wtrans, etrans; ka). + intros. apply H. eexists; eassumption. + Qed. + Lemma wsnocs l: forall p p' p'', wtrans l p p' -> wtrans τ p' p'' -> wtrans l p p''. + Proof. + assert (wtrans l ⋅ wtrans τ ≦ wtrans l) as H by (unfold wtrans, etrans; ka). + intros. apply H. eexists; eassumption. + Qed. + + Lemma wtrans_τ: wtrans τ ≡ (trans_alt τ)^*. + Proof. + unfold wtrans, etrans. ka. + Qed. + + Lemma pwtrans_τ: pwtrans τ ≡ (trans_alt τ)^+. + Proof. + unfold pwtrans, etrans. ka. + Qed. + + #[global] Instance PreOrder_wtrans_τ: PreOrder (wtrans τ). + Proof. + split. + intro. apply wtrans_τ. + now (apply (str_refl (trans_alt τ)); cbn). + intros ?????. apply wtrans_τ. apply (str_trans (trans_alt τ)). + eexists; apply wtrans_τ; eassumption. + Qed. + +End Trans. + +Arguments label : clear implicits. +#[global] Infix "⩸" := Seq (at level 10). +#[global] Hint Constructors transR : core. + +Ltac rem_weak_ t s := + let tmp := fresh in + let name := fresh "EQ" in + remember t as s eqn:tmp; + assert (EQ: Seq s t) by (now subst); + clear tmp. + +Tactic Notation "rem_weak" constr(t) "as" ident(s) := rem_weak_ t s. + +(* Class Respects_val {E F} (L : rel (@label E) (@label F)) := *) +(* { respects_val: *) +(* forall l l', *) +(* L l l' -> *) +(* is_val l <-> is_val l' }. *) + +(* Class Respects_τ {E F} (L : rel (@label E) (@label F)) := *) +(* { respects_τ: forall l l', *) +(* L l l' -> *) +(* l = τ <-> l' = τ }. *) + +(* #[global] Instance Respects_val_eq A: @Respects_val A A eq. *) +(* split; intros; subst; reflexivity. *) +(* Defined. *) + +(* #[global] Instance Respects_τ_eq A: @Respects_τ A A eq. *) +(* split; intros; subst; reflexivity. *) +(* Defined. *) + +Coercion Active : ctree >-> S. +Notation "'α' t" := (Active t) (at level 100). +(* Out of curiosity: do coercion for β in rocq-elpi *) +Notation "'β' e" := (Passive e) (at level 0). +(*| +Backward reasoning for [trans_alt] +------------------------------ +Note: we need to be a bit careful to define these proof rules +explicitly over [ctree]s and not [rel_of SS] as gets coerced +in the section above so that [eauto with trans_alt] works smoothly. +|*) +Section backward. + + Context {E B : Type -> Type} {X : Type}. + +(*| +Structural rules + +We essentially lift the constructors to the [trans_alt] bundling, and +eliminate on the way the noise from closing up everything to [equ eq]. +|*) + + Lemma trans_ret : forall (x : X), + trans_alt (E := E) (B := B) (val x) (Ret x) Stuck. + Proof. + intros; constructor; auto. + Qed. + + Lemma trans_ask : forall {Y} (e : E Y) (k : Y -> ctree E B X), + trans_alt (ask e) (Vis e k) (β e k). + Proof. + intros; constructor; auto. + Qed. + + Lemma trans_rcv : forall {Y} (e : E Y) (k : Y -> ctree E B X) y, + trans_alt (rcv e y) (β e k) (k y). + Proof. + intros; constructor; auto. + Qed. + + (* no longer true: only for epsilon labels *) + Lemma trans_br : forall {Y} (c : B Y) x (k : Y -> ctree E B X), + trans_alt ε (Br c k) (k x). + Proof. + intros *. + eapply Transbr; [reflexivity|]. + reflexivity. + Qed. + + Lemma trans_step : forall (t : ctree E B X), + trans_alt τ (Step t) t. + Proof. + intros. + eapply Transstep; reflexivity. + Qed. + + Lemma trans_guard : forall (t : ctree E B X), + trans_alt ε (Guard t) t. + Proof. + intros. + eapply Transguard; [reflexivity | auto]. + Qed. + + (* Inductive trans_clo {R} (rel : label E R -> srel SS SS) : label E R -> srel SS SS := + | tc_base l t1 t2 : rel l t1 t2 -> trans_clo rel l t1 t2 + | tc_trans l1 l2 s1 s2 s3 : trans_clo l1 s1 s2 -> trans_clo l2 s2 s3 -> trans_alt *) + + (* fixes: τ → ε *) + (* this is no longer true with just (k x): + broadly, for these and all below, we need the transitive closure of + trans_alt. + + *) + +Ltac epop := unshelve (instantiate (1:=_)). +Ltac epop2 := unshelve (instantiate (2:=_)). + +Ltac use e := unshelve (instantiate (1:=e)). + + + (* Lemma trans_brS : forall {Y} (c : B Y) (k : _ -> ctree E B X) x, + trans_alt ε (BrS c k) (k x). + Proof. + intros. + econstructor. + Qed. *) + + (* Lemma trans_brS : forall {Y} (c : B Y) (k : _ -> ctree E B X) x, + wtrans ε (BrS c k) (k x). + Proof. + (* has to be a better way to do this... *) + intros. + econstructor. + use (Step (k x)). + econstructor. econstructor. + use (α (BrS c k)). + use O. + econstructor. reflexivity. + econstructor. reflexivity. econstructor. econstructor. reflexivity. + econstructor. use (1 : nat). + econstructor. econstructor. reflexivity. reflexivity. + econstructor. reflexivity. + Qed. *) + +End backward. + +#[global] Hint Resolve trans_br trans_guard trans_step trans_ask trans_rcv trans_ret : core. + +Section BackwardBounded. + + Context {E B : Type -> Type} {X : Type}. + Context `{B2 -< B}. + Context `{B3 -< B}. + Context `{B4 -< B}. + Variable (l : @label E X) (t t' u u' v v' w w' : ctree E B X). + + (* Lemma trans_brS21 : + trans_alt ε (brS2 t u) t. + Proof. + intros. + unfold brS2. + eapply trans_br. + trans_step. + Qed. + + Lemma trans_brS22 : + trans_alt τ (brS2 t u) u. + Proof. + intros. + apply trans_br with false, trans_step. + Qed. *) + + Lemma trans_br21 : + trans_alt ε (br2 t u) t. + Proof. + intros *. + apply trans_br with (x:=true). + Qed. + + Lemma trans_br22 : + trans_alt ε (br2 t u) u. + Proof. + intros *. + apply trans_br with (x:=false). + Qed. + + (* Lemma trans_brS31 : + trans_alt τ (brS3 t u v) t. + Proof. + now apply trans_br with t31. + Qed. + + Lemma trans_brS32 : + trans_alt τ (brS3 t u v) u. + Proof. + now apply trans_br with t32. + Qed. + + Lemma trans_brS33 : + trans_alt τ (brS3 t u v) v. + Proof. + now apply trans_br with t33. + Qed. + + Lemma trans_br31 x : + trans_alt l t x -> + trans_alt l (br3 t u v) x. + Proof. + intros * TR. + now apply trans_br with t31. + Qed. + + Lemma trans_br32 x : + trans_alt l u x -> + trans_alt l (br3 t u v) x. + Proof. + intros * TR. + now apply trans_br with t32. + Qed. + + Lemma trans_br33 x : + trans_alt l v x -> + trans_alt l (br3 t u v) x. + Proof. + intros * TR. + now apply trans_br with t33. + Qed. + + Lemma trans_brS41 : + trans_alt τ (brS4 t u v w) t. + Proof. + eapply trans_br with t41; eauto. + Qed. + + Lemma trans_brS42 : + trans_alt τ (brS4 t u v w) u. + Proof. + eapply trans_br with t42; eauto. + Qed. + + Lemma trans_brS43 : + trans_alt τ (brS4 t u v w) v. + Proof. + eapply trans_br with t43; eauto. + Qed. + + Lemma trans_brS44 : + trans_alt τ (brS4 t u v w) w. + Proof. + eapply trans_br with t44; eauto. + Qed. + + Lemma trans_br41 x : + trans_alt l t x -> + trans_alt l (br4 t u v w) x. + Proof. + intros * TR. + eapply trans_br with t41; eauto. + Qed. + + Lemma trans_br42 x : + trans_alt l u x -> + trans_alt l (br4 t u v w) x. + Proof. + intros * TR. + eapply trans_br with t42; eauto. + Qed. + + Lemma trans_br43 x : + trans_alt l v x -> + trans_alt l (br4 t u v w) x. + Proof. + intros * TR. + eapply trans_br with t43; eauto. + Qed. + + Lemma trans_br44 x : + trans_alt l w x -> + trans_alt l (br4 t u v w) x. + Proof. + intros * TR. + eapply trans_br with t44; eauto. + Qed. *) + +End BackwardBounded. + +(*| +Forward reasoning for [trans_alt] +------------------------------ +|*) + +Section forward. + + Context {E B : Type -> Type} {X : Type}. + +(*| +Inverting equalities between labels +|*) + + (* [val_eq_invT] no longer makes sense: [val] now has signature + [val : R -> label E R], so two [val x], [val y] can only be compared + when they share the return-type parameter; the type equality is + enforced by typing rather than proved. *) + + Lemma val_eq_inv : forall (x y : X), @val E X x = val y -> x = y. + clear B. intros * EQ. + now inversion EQ. + Qed. + + Lemma ask_invT : forall E Y Z e1 e2, @ask E X Y e1 = @ask E X Z e2 -> Y = Z. + intros * EQ. + now dependent induction EQ. + Qed. + + Lemma ask_inv : forall E Y e1 e2, @ask E X Y e1 = @ask E X Y e2 -> e1 = e2. + intros * EQ. + now dependent induction EQ. + Qed. + + Lemma rcv_invT : forall E Y Z e1 e2 v1 v2, @rcv E X Y e1 v1 = @rcv E X Z e2 v2 -> Y = Z. + intros * EQ. + now dependent induction EQ. + Qed. + + Lemma rcv_inv : forall E Y e1 e2 v1 v2, @rcv E X Y e1 v1 = @rcv E X Y e2 v2 -> e1 = e2 /\ v1 = v2. + intros * EQ. + now dependent induction EQ. + Qed. + +(*| +Structural rules +|*) + + (* In the primed versions, [u] is left as an arbitrary S. + In the main version, we can only invert if we already know + that the resulting state is an active one. + (it is of course always one) + *) + Lemma trans_ret_inv' : forall x l u, + trans_alt l (Ret x : ctree E B X) u -> + Seq u (α Stuck) /\ l = val x. + Proof. + intros * TR; inv TR; inv_equ. + intuition. + Qed. + + Lemma trans_ret_inv : forall x l (u : ctree E B X), + trans_alt l (Ret x) u -> + u ≅ Stuck /\ l = val x. + Proof. + intros * TR; inv TR; inv_equ. + intuition. + Qed. + + Lemma trans_vis_inv' : forall {Y} (e : E Y) (k : _ -> ctree E B X) l u, + trans_alt l (Vis e k) u -> + Seq u (β e k) /\ l = ask e. + Proof. + intros * TR. + inv TR; inv_equ. + split; auto. + constructor; intros ?; symmetry; eauto. + Qed. + + Lemma trans_vis_inv : forall {Y} (e : E Y) k l (u : ctree E B X), + trans_alt l (Vis e k) u -> + False. + Proof. + intros * TR. + inv TR; inv_equ. + Qed. + + Lemma trans_passive_inv' : forall {Y} (e : E Y) (k : Y -> ctree E B X) l u, + trans_alt l (β e k) u -> + exists x, Seq u (α k x) /\ l = rcv e x. + Proof. + intros * TR. + cbn in TR; dependent induction TR. + eexists; split; eauto. + constructor; symmetry; eauto. + Qed. + + Lemma trans_passive_inv : forall {Y} (e : E Y) (k : Y -> ctree E B X) l (u : ctree E B X), + trans_alt l (β e k) u -> + exists x, u ≅ (k x) /\ l = rcv e x. + Proof. + intros * TR. + apply trans_passive_inv' in TR as (? & ? & ?). + inv H; eauto. + Qed. + + (* Lemma trans_br_inv : forall {Y} l (c : B Y) (k : _ -> ctree E B X) u, + trans_alt l (Br c k) u -> + exists n, trans_alt l (k n) u. + Proof. + intros * TR. + cbn in *. + match goal with + | h: transR _ ?x ?y |- _ => + remember x as ox; remember y as oy + end. + revert c k u Heqox Heqoy. + inv TR; intros; subst; inv Heqox; inv_equ. + exists x; now rewrite H0, <- (EQ x) in H1. + Qed. *) + + (* Lemma trans_guard_inv : forall l (t : ctree E B X) u, + trans_alt l (Guard t) u -> + trans_alt l t u. + Proof. + intros * TR. + inv TR; inv_equ. + now rewrite H0. + Qed. *) + + Lemma trans_step_inv' : forall l (t : ctree E B X) u, + trans_alt l (Step t) u -> + Seq u t /\ l = τ. + Proof. + intros * TR. + inv TR; inv_equ; split; auto. + now rewrite H0,H2. + Qed. + + Lemma trans_step_inv : forall l (t u : ctree E B X), + trans_alt l (Step t) u -> + u ≅ t /\ l = τ. + Proof. + intros * TR. + apply trans_step_inv' in TR as [? ?]; split; auto. + now inv H. + Qed. +(* + Lemma trans_brS_inv' : forall {Y} l (c : B Y) (k : _ -> ctree E B X) u, + trans_alt l (BrS c k) u -> + exists n, Seq u (α (k n)) /\ l = τ. + Proof. + intros * TR. + eapply trans_br_inv in TR as [n ?]. + apply trans_step_inv' in H as [? ?]. + eauto. + Qed. + + Lemma trans_brS_inv : forall {Y} l (c : B Y) k (u : ctree E B X), + trans_alt l (BrS c k) u -> + exists n, u ≅ k n /\ l = τ. + Proof. + intros * TR. + apply trans_brS_inv' in TR as (? & H & ?); inv H; eauto. + Qed. + *) + Lemma trans_stuck_inv : forall l u, + trans_alt l (Stuck : ctree E B X) u -> + False. + Proof. + intros * TR. + cbn in TR; dependent induction TR; inv_equ. + Qed. + +(*| +Ad-hoc rules for pre-defined finite branching +|*) + + Variable (l : @label E X) (t u v w : ctree E B X). + Context `{B2 -< B} `{B3 -< B} `{B4 -< B}. + + (* Lemma trans_br2_inv t' : + trans_alt l (br2 t u) t' -> + (trans_alt l t t' \/ trans_alt l u t'). + Proof. + intros * TR; apply trans_br_inv in TR as [[] TR]; auto. + Qed. + + Lemma trans_br3_inv t' : + trans_alt l (br3 t u v) t' -> + (trans_alt l t t' \/ trans_alt l u t' \/ trans_alt l v t'). + Proof. + intros * TR; apply trans_br_inv in TR as [n TR]. + destruct n; auto. + Qed. + + Lemma trans_br4_inv t' : + trans_alt l (br4 t u v w) t' -> + (trans_alt l t t' \/ trans_alt l u t' \/ trans_alt l v t' \/ trans_alt l w t'). + Proof. + intros * TR; apply trans_br_inv in TR as [n TR]. + destruct n; auto. + Qed. + + Lemma trans_brS2_inv (t': ctree _ _ _) : + trans_alt l (brS2 t u) t' -> + (l = τ /\ (t' ≅ t \/ t' ≅ u)). + Proof. + intros * TR; apply trans_brS_inv in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. + + Lemma trans_brS2_inv' t' : + trans_alt l (brS2 t u) t' -> + (l = τ /\ (Seq t' t \/ Seq t' u)). + Proof. + intros * TR; apply trans_brS_inv' in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. + + Lemma trans_brS3_inv (t': ctree _ _ _) : + trans_alt l (brS3 t u v) t' -> + (l = τ /\ (t' ≅ t \/ t' ≅ u \/ t' ≅ v)). + Proof. + intros * TR; apply trans_brS_inv in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. + + Lemma trans_brS3_inv' t' : + trans_alt l (brS3 t u v) t' -> + (l = τ /\ (Seq t' t \/ Seq t' u \/ Seq t' v)). + Proof. + intros * TR; apply trans_brS_inv' in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. + + Lemma trans_brS4_inv' t' : + trans_alt l (brS4 t u v w) t' -> + (l = τ /\ (Seq t' t \/ Seq t' u \/ Seq t' v \/ Seq t' w)). + Proof. + intros * TR; apply trans_brS_inv' in TR as (? & TR & ->); split; auto. + destruct x; auto. + Qed. *) + +(*| +Inversion rules for [trans_alt] based on the value of the label +----------------------------------------------------------- +In general, these would require to introduce the relation that +only steps through the non-observable internal br. +I'll skip them for now and introduce them if they turn out to be +useful. +|*) + + Lemma trans_val_inv' : + forall t u (x : X), + trans_alt (val x) t u -> + Seq u (α (Stuck : ctree E B X)). + Proof. + intros * TR. + remember (val x) as ox. + revert x Heqox. + cbn in TR; induction TR; intros ? Heqox; try now inv Heqox. + all: eauto. + Qed. + + Lemma trans_val_inv : + forall (t u : ctree E B X) (x : X), + trans_alt (val x) t u -> + u ≅ Stuck. + Proof. + now intros * TR; apply trans_val_inv' in TR; inv TR. + Qed. + + Lemma wtrans_val_inv : forall (x : X), + wtrans (val x) u Stuck -> + exists t, wtrans τ u t /\ trans_alt (val x) t Stuck. + Proof. + intros * TR. + destruct TR as [t2 [t1 step1 step2] step3]. + exists t1; split. + apply wtrans_τ; auto. + erewrite <- trans_val_inv'; eauto. + Qed. + +End forward. + +(*| +[etrans] theory +--------------- +|*) + +Lemma etrans_case' {E B X} : forall l t u, + etrans l t u -> + (trans_alt l t u \/ (l = τ /\ @Seq E B X t u)). +Proof. + intros [] * TR; cbn in *; intuition. +Qed. + +Lemma etrans_case {E B X} : forall l (t u : ctree E B X), + etrans l t u -> + (trans_alt l t u \/ (l = τ /\ t ≅ u)). +Proof. + intros [] * TR; cbn in *; intuition. + inv H; intuition. +Qed. + +Lemma etrans_ret_inv' {E B X} : forall x l t, + etrans l (Ret x) t -> + (l = τ /\ @Seq E B X t (α Ret x)) \/ (l = val x /\ Seq t (α Stuck)). +Proof. + intros ? [] ? step; cbn in step. + - intuition; try (eapply trans_ret in step; now apply step). + apply trans_ret_inv' in H; intuition. + - eapply trans_ret_inv' in step; intuition. + - eapply trans_ret_inv' in step; intuition. + - eapply trans_ret_inv' in step; intuition. + - eapply trans_ret_inv' in step; intuition. +Qed. + +Lemma etrans_ret_inv {E B X} : forall x l (t : ctree E B X), + etrans l (Ret x) t -> + (l = τ /\ t ≅ Ret x) \/ (l = val x /\ t ≅ Stuck). +Proof. + intros ? [] ? step; cbn in step. + - intuition; try (eapply trans_ret in step; now apply step). + apply trans_ret_inv in H; intuition. + inv H; intuition. + - eapply trans_ret_inv in step; intuition. + - eapply trans_ret_inv in step; intuition. + - eapply trans_ret_inv in step; intuition. + - eapply trans_ret_inv in step; intuition. +Qed. + +Lemma passive_τ_trans {E B X Y} e (g : X -> ctree E B Y) u : + trans_alt τ (β e g) u -> + False. +Proof. + intros TR; cbn in TR; dependent induction TR. +Qed. + +Lemma passive_τ_etrans {E B X Y} e (g : X -> ctree E B Y) u : + etrans τ (β e g) u -> + Seq u (β e g). +Proof. + intros [TR | EQ]. + - cbn in TR; dependent induction TR. + - symmetry; apply EQ. +Qed. + +Lemma passive_τ_wtrans {E B X Y} e (g : X -> ctree E B Y) u : + wtrans τ (β e g) u -> + Seq u (β e g). +Proof. + intros [? [? [n TR1] TR2] [m TR3]]. + destruct n. + - cbn in TR1. rewrite <- TR1 in TR2. + apply passive_τ_etrans in TR2. + destruct m. + * cbn in TR3. + now rewrite <- TR3, TR2. + * destruct TR3 as [? TR _]. + rewrite TR2 in TR. + exfalso; eapply passive_τ_trans; eauto. + - destruct TR1 as [? TR _]. + exfalso; eapply passive_τ_trans; eauto. +Qed. + +Lemma transs_τ_passive {E B X Y} e (g : X -> ctree E B Y) u : + (trans_alt τ)^* (β e g) u -> + Seq u (β e g). +Proof. + intros TR. + eapply passive_τ_wtrans. + now apply wtrans_τ. +Qed. + +(*| +Stuck processes +--------------- +A process is said to be stuck if it cannot step. The [stuck] process used +to reduce pure computations is of course stuck, but so is [spinI], while [spinV] +is not. +|*) + +Section stuck. + + Context {E B : Type -> Type} {X : Type}. + + Definition is_stuck : @S E B X -> Prop := + fun t => forall l u, ~ (trans_alt l t u). + + #[global] Instance Seq_is_stuck : Proper (Seq ==> iff) is_stuck. + Proof. + intros ? ? EQ; split; intros ST; red; intros * ABS. + rewrite <- EQ in ABS; eapply ST; eauto. + rewrite EQ in ABS; eapply ST; eauto. + Qed. + + Lemma etrans_is_stuck_inv' v v' l : + is_stuck v -> + etrans l v v' -> + l = τ /\ Seq v v'. + Proof. + intros * ST TR. + edestruct @etrans_case'; eauto. + apply ST in H; tauto. + Qed. + + Lemma etrans_is_stuck_inv (v v' : ctree E B X) l : + is_stuck v -> + etrans l v v' -> + (l = τ /\ v ≅ v'). + Proof. + intros * ST TR. + edestruct @etrans_case; eauto. + apply ST in H; tauto. + Qed. + + Lemma transs_is_stuck_inv' v v' : + is_stuck v -> + (trans_alt τ)^* v v' -> + Seq v v'. + Proof. + intros * ST TR. + destruct TR as [[] TR]. + inv TR; eauto. + destruct TR. + apply ST in H; tauto. + Qed. + + Lemma transs_is_stuck_inv (v v' : ctree E B X) : + is_stuck v -> + (trans_alt τ)^* v v' -> + v ≅ v'. + Proof. + intros * ST TR. + eapply transs_is_stuck_inv' in TR; eauto. + now inv TR. + Qed. + + Lemma wtrans_is_stuck_inv t u l : + is_stuck t -> + wtrans l t u -> + (l = τ /\ Seq t u). + Proof. + intros * ST TR. + destruct TR as [? [? ?] ?]. + apply transs_is_stuck_inv' in H; auto. + rewrite H in ST. + inv H. + - apply etrans_is_stuck_inv' in H0 as [-> ?]; auto. + inv H. + rewrite EQ0 in ST; apply transs_is_stuck_inv' in H1; auto. + intuition. + rewrite EQ, EQ0; auto. + - pose proof etrans_is_stuck_inv' _ _ ST H0 as [-> ?]; auto. + split; auto. + rewrite <-H in H1. + apply transs_τ_passive in H1. + rewrite H1. auto. + Qed. + + (* Constructions *) + Lemma stuck_is_stuck : + is_stuck Stuck. + Proof. + repeat intro; eapply trans_stuck_inv; eauto. + Qed. + + (* Lemma br_void_is_stuck (c : B void) (k : void -> _) : + is_stuck (Br c k). + Proof. + red. intros * ?. + apply trans_br_inv in H as [[] ?]. + Qed. *) + + (* Lemma br_fin0_is_stuck (c : B (fin 0)) (k : fin 0 -> _) : + is_stuck (Br c k). + Proof. + red. intros * ?. + apply trans_br_inv in H as [? ?]. + now apply case0. + Qed. *) + + (* Lemma spin_gen_is_stuck {Y} (x : B Y) : + is_stuck (spin_gen x). + Proof. + red; intros * abs. + rem_weak (α (@spin_gen E B X _ x)) as v. + revert EQ. + cbn in abs; induction abs. + 3-6: intros EQ; inv EQ; rewrite EQ0 in H; step in H; inv H. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite H0. + rewrite EQ0 in H; step in H; dependent induction H. + symmetry; apply REL. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite EQ0 in H; step in H; dependent induction H. + Qed. *) + + (* Lemma spin_is_stuck : + is_stuck spin. + Proof. + red; intros * abs. + rem_weak (α @spin E B X) as v; revert EQ. + cbn in abs; induction abs. + 3-6: intros EQ; inv EQ; rewrite EQ0 in H; step in H; inv H. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite H0. + rewrite EQ0 in H; step in H; dependent induction H. + - intros EQ; inv EQ. + apply IHabs; constructor. + rewrite EQ0 in H; step in H; dependent induction H. + now rewrite <- REL. + Qed. *) + + Lemma spinS_is_not_stuck : + ~ (is_stuck spinS). + Proof. + red; intros * abs. + apply (abs τ spinS). + rewrite ctree_eta at 1; cbn. + apply trans_step. + Qed. + + Lemma vis_is_not_stuck {Y} (e : E Y) (k : Y -> _) : + ~ is_stuck (Vis e k). + Proof. + red; intros * abs. + eapply (abs (ask e)). + apply trans_ask. + Qed. + + Lemma passive_is_not_stuck {Y} `{Inhabited Y} (e : E Y) (k : Y -> _) : + ~ is_stuck (β e k). + Proof. + red; intros * abs. + eapply (abs (rcv e inhabitant)). + apply trans_rcv. + Qed. + + Lemma passive_void_is_stuck (e : E void) (k : void -> _) : + is_stuck (β e k). + Proof. + red; intros * abs. + apply trans_passive_inv' in abs as ([] & _ & _). + Qed. + +End stuck. + +Section not_stuck. + + Context {E B : Type -> Type} {X : Type}. + + Definition not_stuck t := + exists l' t', @trans_alt E B X l' t t'. + + #[global] Instance seq_not_stuck : Proper (Seq ==> iff) not_stuck. + Proof. + intros ? ? EQ; split; intros (l' & t' & TR). + rewrite EQ in TR; red; eauto. + rewrite <- EQ in TR; red; eauto. + Qed. + + #[global] Instance equ_not_stuck : Proper (equ eq ==> iff) not_stuck. + Proof. + intros ? ? EQ; split; intros (l' & t' & TR). + rewrite EQ in TR; red; eauto. + rewrite <- EQ in TR; red; eauto. + Qed. + + (* Converse is classically true *) + Lemma not_stuck_is_stuck : + forall t, not_stuck t -> ~ is_stuck t. + Proof. + intros t (l' & t' & NS) IS; eapply IS; eauto. + Qed. + + Lemma ret_not_stuck x: + not_stuck (Ret x). + Proof. + red; eauto. + Qed. + + Lemma vis_not_stuck {Y} (e : E Y) k: + not_stuck (Vis e k). + Proof. + red; eauto. + Qed. + + Lemma step_not_stuck t: + not_stuck (Step t). + Proof. + red; eauto. + Qed. + + Lemma passive_not_stuck {Y} `{Inhabited Y} (e : E Y) k: + not_stuck (β e k). + Proof. + red; eauto. + Unshelve. + exact inhabitant. + Qed. + + Lemma br_not_stuck {Y} (b : B Y) (k : Y -> ctree _ _ _): + (exists x, not_stuck (k x)) -> + not_stuck (Br b k). + Proof. + intros (y & l' & t' & TR). + red; eauto. + exists ε, (α k y). + now econstructor. + Qed. + + (* Lemma brS_not_stuck {Y} (b : B Y) (k : Y -> ctree _ _ _): + (exists x, not_stuck (k x)) -> + not_stuck (BrS b k). + Proof. + intros (y & l' & t' & TR). + red. + exists ε, (α k y). + Qed. *) + +End not_stuck. +#[global] Hint Unfold not_stuck : core. + +(*| +wtrans theory +--------------- +|*) + +Section wtrans. + + Context {E B : Type -> Type} {X : Type}. + + Lemma wtrans_step : forall l (t t' : ctree E B X), + wtrans l t t' -> + wtrans l (Step t) t'. + Proof. + intros * TR. + eapply wcons; eauto. + Qed. + + Lemma trans_τ_str_ret_inv' : forall x t, + (trans_alt τ)^* (Ret x) t -> + @Seq E B X t (α Ret x). + Proof. + intros * [[|] step]. + - cbn in *; now symmetry. + - destruct step. + apply trans_ret_inv' in H; intuition congruence. + Qed. + + Lemma trans_τ_str_ret_inv : forall x (t : ctree E B X), + (trans_alt τ)^* (Ret x) t -> + t ≅ Ret x. + Proof. + intros * [[|] step]. + - inv step; now symmetry. + - destruct step. + apply trans_ret_inv' in H; intuition congruence. + Qed. + + Lemma wtrans_ret_inv : forall x l (t : ctree E B X), + wtrans l (Ret x) t -> + (l = τ /\ t ≅ Ret x) \/ (l = val x /\ t ≅ Stuck). + Proof. + intros * step. + destruct step as [? [? step1 step2] step3]. + apply trans_τ_str_ret_inv' in step1. + rewrite step1 in step2; clear step1. + apply etrans_ret_inv' in step2 as [[-> EQ] |[-> EQ]]. + rewrite EQ in step3; apply trans_τ_str_ret_inv in step3; auto. + rewrite EQ in step3. + apply transs_is_stuck_inv in step3; [| apply stuck_is_stuck]. + intuition. + Qed. + + Lemma wtrans_val_inv' : forall (x : X) t u, + wtrans (val x) t u -> + exists t', @wtrans E B X τ t t' /\ @trans_alt E B X (val x) t' u /\ Seq u Stuck. + Proof. + intros * TR. + destruct TR as [t2 [t1 step1 step2] step3]. + exists t1; split. + apply wtrans_τ; auto. + clear step1. + pose proof trans_val_inv' step2. + rewrite H in step3. + apply transs_is_stuck_inv' in step3; auto using stuck_is_stuck. + split; [| rewrite <- step3; auto]. + rewrite H in step2. rewrite <- step3. + auto. + Qed. + +End wtrans. + +(*| +Forward and backward rules for [trans_alt] w.r.t. [bind] +---------------------------------------------------- +trans_alt l (t >>= k) u -> (trans_alt l t t' /\ u ≅ t' >>= k) \/ (trans_alt (ret x) t stuck /\ trans_alt l (k x) u) +l <> val x -> trans_alt l t u -> trans_alt l (t >>= k) (u >>= k) +trans_alt (val x) t stuck -> trans_alt l (k x) u -> trans_alt l (bind t k) u. +|*) + +(* Lemma trans_bind_inv {E B X Y} + (t : ctree E B X) (k : X -> ctree E B Y) + u (l : label E Y) : + trans_alt l (t >>= k) u -> + (l = τ /\ exists t', trans_alt τ t (α t') /\ Seq u (α t' >>= k)) \/ + (exists Z (e : E Z), + l = ask e /\ + exists (g : Z -> ctree E B X), + trans_alt (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (exists (x : X), trans_alt (val x) t Stuck /\ trans_alt l (k x) u). +Proof. + intros TR. + rem_weak (α x <- t ;; k x) as ob. + revert t EQ. + induction TR. + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply br_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2. + rewrite H0. now econstructor. + + edestruct IHTR as [H | [H | H]]; [rewrite H0, EQ2; reflexivity |..]; clear IHTR. + * destruct H as (-> & u' & EQ1' & EQ2'). + left. split; auto. + eexists; split; [| eassumption]; rewrite EQ1; eauto. + * destruct H as (Z & e & -> & g & TR' & EQ). + right; left. + exists Z,e; split; auto; exists g; split; auto. + rewrite EQ1; eauto. + * destruct H as (y & TR' & TR''). + right; right. + exists y; split; auto. + rewrite EQ1; eauto. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply guard_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2; auto. + + edestruct IHTR as [H | [H | H]]; [rewrite <- EQ2; reflexivity | ..]; clear IHTR. + * destruct H as (-> & u' & EQ1' & EQ2'). + left. split; auto. + eexists; split; [| eassumption]; rewrite EQ1; auto. + * destruct H as (Z & e & -> & g & TR' & EQ). + right; left. + exists Z,e; split; auto; exists g; split; auto. + rewrite EQ1; auto. + * destruct H as (x & TR' & TR''). + right; right. + exists x; split; auto. + rewrite EQ1; auto. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply step_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2, H0; auto. + + left. + split; auto. + exists v; split. + rewrite EQ1; auto. + rewrite H0, <- EQ2; auto. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply vis_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. + + right; right. + exists r; split. + rewrite EQ1; auto. + rewrite EQ2; auto. + + right; left. + exists X0, e; split; auto. + exists v; split. + rewrite EQ1; auto. + constructor. + intros ?. + rewrite EQ2; auto. + + - intros ? EQ. + inv EQ. + + - intros ? EQ. + inv EQ. + rewrite EQ0 in H. + apply ret_equ_bind in H as (r' & EQ1 & EQ2). + right; right. + exists r'; split. + rewrite EQ1; auto. + rewrite EQ2, H0; auto. +Qed. *) + +(* Lemma trans_bind_inv_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : + trans_alt l (t >>= k) u -> + exists l' t', trans_alt l' t t'. +Proof. + intros TR. + apply trans_bind_inv in TR. + destruct TR as [(? & ? & ? & ?) | [(? & ? & ? & ? & ? & ?) | (? & ? & ?)]]; eauto. +Qed. *) + +(* Lemma trans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + trans_alt τ t u -> + trans_alt τ (t >>= k) (u >>= k). +Proof. + cbn; intros TR. + dependent induction TR; cbn in *. + - rewrite H, bind_br. + apply trans_br with x. + specialize (IHTR t' k u eq_refl eq_refl eq_refl). + now rewrite H0 in IHTR. + - rewrite H, bind_guard. + apply trans_guard. + apply IHTR; auto. + - rewrite H, bind_step. + rewrite H0; apply trans_step. +Qed. *) + +(* Lemma trans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : + trans_alt (ask e) t (β e g) -> + trans_alt (ask e) (t >>= k) (β e (fun x => g x >>= k)). +Proof. + cbn; intros TR. + dependent induction TR; cbn in *. + - rewrite H, bind_br. + apply trans_br with x. + specialize (IHTR Z t' k e g eq_refl eq_refl eq_refl). + now rewrite H0 in IHTR. + - rewrite H, bind_guard. + apply trans_guard. + apply IHTR; auto. + - rewrite H, bind_vis. + apply trans_ask. +Qed. *) + +(* Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u x l : + trans_alt (val x) t Stuck -> + trans_alt l (k x) u -> + trans_alt l (t >>= k) u. +Proof. + cbn; intros TR1. + dependent induction TR1; cbn in *. + - intros TR2; rewrite H, bind_br. + apply trans_br with x0. + rewrite <- H0; eapply IHTR1; eauto. + - intros TR2; rewrite H, bind_guard. + apply trans_guard. + eapply IHTR1; eauto. + - intros TR2; rewrite H, bind_ret_l; auto. +Qed. *) + +(* Lemma is_stuck_bind : forall {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y), + is_stuck t -> is_stuck (bind t k). +Proof. + repeat intro. + apply trans_bind_inv in H0 as [|[]]. + - destruct H0 as (? & ? & TR & ?). + now apply H in TR. + - destruct H0 as (? & ? & ? & ? & TR & ?). + now apply H in TR. + - destruct H0 as (? & TR & ?). + now apply H in TR. +Qed. *) + +(*| +Forward and backward rules for [wtrans] w.r.t. [bind] +----------------------------------------------------- +|*) + +(* Lemma etrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : + etrans l (t >>= k) u -> + (l = τ /\ exists t', etrans τ t (α t') /\ Seq u (t' >>= k)) \/ + (exists Z (e : E Z), l = ask e /\ + exists (g : Z -> ctree E B X), trans_alt (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (exists (x : X), trans_alt (val x) t Stuck /\ etrans l (k x) u). +Proof. + intros TR. + apply @etrans_case' in TR as [ | (-> & ?)]. + - apply trans_bind_inv in H as [[? (? & ? & ?)]|[( ? & ? & ? & ? & ? & ?)|( ? & ? & ?)]]; eauto. + + subst; left; split; eauto using is_val_τ. + eexists; split; eauto; apply trans_etrans; auto. + + subst; right; left. + eexists; eexists; split; eauto. + + right; right; eexists; split; eauto. now apply trans_etrans. + - inv H; left; split; auto. + exists t; split; auto using enil; symmetry; auto. +Qed. + +Lemma transs_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u : + (trans_alt τ)^* (t >>= k) u -> + (exists t', (trans_alt τ)^* t (α t') /\ Seq u (t' >>= k)) \/ + (exists (x : X), wtrans (val x) t Stuck /\ (trans_alt τ)^* (k x) u). +Proof. + intros [n TR]. + revert t k u TR. + induction n as [| n IH]; intros; subst. + - cbn in TR. + left; exists t; split. + exists 0%nat; reflexivity. + symmetry; auto. + - destruct TR as [t1 TR1 TR2]. + apply trans_bind_inv in TR1 as [(_ & t2 & TR1 & EQ) | [(x & TR1 & abs & ?) | (x & TR1 & TR1')]]. + + rewrite EQ in TR2; clear t1 EQ. + apply IH in TR2 as [(t3 & TR2 & EQ')| (x & TR2 & TR3)]. + * left; eexists; split; eauto. + apply wtrans_τ; eapply wcons; eauto. + apply wtrans_τ; auto. + * right; exists x; split; eauto. + eapply wcons; eauto. + + inv abs. + + right. + exists x; split. + apply trans_wtrans; auto. + exists (Datatypes.S n), t1; auto. +Qed. *) + + +(*| +Things are a bit ugly with [wtrans], we end up with three cases: +- the reduction entirely takes place in the prefix +- the computation spills over the continuation, with the label taking place +in the continuation +- the computation splills over the continuation, with the label taking place +in the prefix. This is a bit more annoying to express: we cannot necessarily +[wtrans l] all the way to a [Ret] as the end of the computation might contain +just before the [Ret] some invisible br nodes. We therefore have to introduce +the last visible state reached by [wtrans] and add a [trans_alt (val _)] afterward. +|*) +(* Lemma wtrans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : + wtrans l (t >>= k) u -> + (l = τ /\ exists t', wtrans τ t (α t') /\ Seq u (t' >>= k)) \/ + (exists Y (e : E Y), l = ask e /\ exists g, wtrans (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ + (exists (x : X), wtrans (val x) t Stuck /\ wtrans l (k x) u) \/ + (exists (x : X) s, l = τ /\ wtrans τ t s /\ trans_alt (val x) s Stuck /\ wtrans τ (k x) u) \/ + (exists Y (e : E Y) (x : X) s, l = ask e /\ wtrans (ask e) t s /\ trans_alt (val x) s Stuck /\ wtrans τ (k x) u). +Proof. + intros TR. + destruct TR as [t2 [t1 step1 step2] step3]. + apply transs_bind_inv in step1 as [(u1 & TR1 & EQ1)| (x & TR1 & TR1')]. + - rewrite EQ1 in step2. + apply etrans_bind_inv in step2 as [(H & u2 & TR2 & EQ2)| [(Z & e & EQ & g & TR2 & EQ2) | (x & TR2 & TR2')]]. + + rewrite EQ2 in step3. + subst. + apply transs_bind_inv in step3 as [(u3 & TR3 & EQ3)| (x & TR3 & TR3')]. + * left; split; auto. + eexists; split. 2:apply EQ3. + exists (α u2); [exists (α u1) |]; auto. + * right; right; right; left. + apply wtrans_val_inv in TR3 as (u3 & TR2' & TR2''). + exists x, u3. + repeat split; auto. + 2:apply wtrans_τ; auto. + exists (α u2); [exists (α u1) |]; auto. + apply wtrans_τ; apply wtrans_τ in TR1. + eapply wconss; eauto. + + destruct t2 as [? | h]; [inv EQ2 |]. + dependent induction EQ2. + assert (Seq u (β (e) k0)). + { apply passive_τ_wtrans, wtrans_τ; auto. } + right; left. + exists Z, e; split; auto. + eexists; split. + 2:rewrite H; constructor; intros x; rewrite (EQ x); reflexivity. + exists (β (e) g); [exists (α u1) |]; auto. + apply wtrans_τ; apply wnil. + + right; right; left. + exists x; split. + eexists; [eexists |]; eauto; apply wtrans_τ, wnil. + eexists; [eexists |]; eauto; apply wtrans_τ, wnil. + - right; right; left. + exists x; split; eauto. + eexists; [eexists |]; eauto. +Qed. + +Lemma etrans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + etrans τ t u -> + etrans τ (t >>= k) (u >>= k). +Proof. + cbn. + intros [|]. + left; apply trans_bind_l_τ; auto. + inv H; rewrite EQ; auto. +Qed. + +Lemma etrans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : + etrans (ask e) t (β e g) -> + etrans (ask e) (t >>= k) (β e (fun x => g x >>= k)). +Proof. + cbn; intros TR. + apply trans_bind_l_ask; auto. +Qed. + +Lemma trans_τ_inv {E B X} t u : + @trans_alt E B X τ t u -> + exists u', Seq u (α u'). +Proof. + intros TR; cbn in TR; dependent induction TR. + - edestruct IHTR; auto. + inv H1; eauto. + - edestruct IHTR; eauto. + - eauto. +Qed. + +Lemma etrans_τ_inv {E B X} (t : ctree E B X) u : + etrans τ (α t) u -> + exists u', Seq u (α u'). +Proof. + intros [TR | TR]. + - eapply trans_τ_inv; eauto. + - cbn in *; exists t; rewrite TR; auto. +Qed. + +Lemma trans_ask_inv {E B X Y} t (e : E Y) u : + @trans_alt E B X (ask e) t u -> + exists g, Seq u (β e g). +Proof. + intros TR; cbn in TR; dependent induction TR. + - edestruct IHTR; auto. + dependent induction H1; eauto. + - edestruct IHTR; eauto. + - eauto. +Qed. + +Lemma etrans_ask_inv {E B X Y} (t : ctree E B X) (e : E Y) u : + etrans (ask e) (α t) u -> + exists g, Seq u (β e g). +Proof. + intros TR; eapply trans_ask_inv; eauto. +Qed. + +Lemma transs_τ_active {E B X} (t : ctree E B X) u : + (trans_alt τ)^* (α t) u -> + exists u', Seq u (α u'). +Proof. + intros [n TR]. revert t TR. + induction n as [| n IH]; intros t TR. + - cbn in TR; exists t; symmetry; eauto. + - destruct TR as [? TR TRs]. + eapply trans_τ_inv in TR as [u' EQ]. + rewrite EQ in TRs. + edestruct IH; eauto. +Qed. + +Lemma wtrans_τ_active {E B X} (t : ctree E B X) u : + wtrans τ (α t) u -> + exists u', Seq u (α u'). +Proof. + intros TR; apply wtrans_τ in TR; eapply transs_τ_active; eauto. +Qed. + +Lemma transs_bind_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + (trans_alt τ)^* t u -> + (trans_alt τ)^* (t >>= k) (u >>= k). +Proof. + intros [n TR]. + revert t u TR. + induction n as [| n IH]. + - cbn; intros; exists 0%nat; cbn; inv TR; rewrite EQ; auto. + - intros t u [v TR1 TR2]. + pose proof trans_τ_inv TR1 as (v' & EQv). + rewrite EQv in TR1,TR2. + apply IH in TR2. + eapply wtrans_τ, wcons. + 2:apply wtrans_τ; eauto. + apply trans_bind_l_τ; eauto. +Qed. + +Lemma wtrans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + wtrans τ t u -> + wtrans τ (t >>= k) (u >>= k). +Proof. + intros [t2 [t1 TR1 TR2] TR3]. + pose proof transs_τ_active TR1 as (x & EQx). + rewrite EQx in TR1,TR2. + pose proof etrans_τ_inv TR2 as (y & EQy). + rewrite EQy in TR2,TR3. + pose proof transs_τ_active TR3 as (z & EQz). + eexists; [eexists |]. + apply transs_bind_l; eauto. + apply etrans_bind_l_τ; eauto. + apply transs_bind_l; eauto. +Qed. + +Lemma wtrans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : + wtrans (ask e) t (β e g) -> + wtrans (ask e) (t >>= k) (β e (fun x => g x >>= k)). +Proof. + intros [t2 [t1 TR1 TR2] TR3]. + pose proof transs_τ_active TR1 as (x & EQx). + rewrite EQx in TR1,TR2. + pose proof etrans_ask_inv TR2 as (y & EQy). + rewrite EQy in TR2,TR3. + pose proof transs_τ_passive TR3 as EQz. + eexists; [eexists |]. + apply transs_bind_l; eauto. + apply etrans_bind_l_ask; eauto. + apply wtrans_τ. + assert (Seq (β (e) (fun x0 : Z => x <- y x0;; k x)) (β (e) (fun x0 : Z => x <- g x0;; k x))). + { dependent induction EQz. + constructor; intros a. + now rewrite <- (EQ a). } + rewrite H. apply wnil. +Qed. + +Lemma wtrans_case_active {E B X} (t u : ctree E B X) l: + wtrans l t u -> + (l = τ /\ t ≅ u) \/ + (exists v, trans_alt l t v /\ wtrans τ v u) \/ + (exists v, trans_alt τ t v /\ wtrans l v u). +Proof. + intros [t2 [t1 [n TR1] TR2] TR3]. + destruct n as [| n]. + - apply wtrans_τ in TR3. + cbn in TR1; rewrite <- TR1 in TR2. + destruct l; eauto. + destruct TR2; eauto. + cbn in H; rewrite <- H in TR3. + apply wtrans_τ in TR3. + destruct TR3 as [[| n] ?]; eauto. + cbn in H0; inv H0; eauto. + destruct H0 as [? ? ?]; right; left; eexists; split; eauto. + apply wtrans_τ; exists n; auto. + - destruct TR1 as [? ? ?]. + right; right. + eexists; split; eauto. + exists t2; [exists t1|]; eauto. + exists n; eauto. +Qed. + +Lemma trans_rcv_inv {E B X Y} (e : E Y) (y : Y) u v : + trans_alt (rcv e y) u v -> + exists (g : Y -> ctree E B X), Seq u (β e g) /\ Seq v (α g y). +Proof. + intros TR. + remember (rcv e y). + revert e y Heql. + induction TR; intros * EQl; subst; auto; inv_equ. + - edestruct IHTR as (g & abs & ?); [reflexivity |]. + inv abs. + - edestruct IHTR as (g & abs & ?); [reflexivity |]. + inv abs. + - inv EQl. + - dependent induction EQl. + exists k; split; auto. + now rewrite <- H. + - inv EQl. +Qed. + +Lemma trans_rcv_active_inv {E B X Y} (e : E Y) (y : Y) (u : ctree E B X) v : + trans_alt (rcv e y) (α u) v -> + False. +Proof. + intros TR; pose proof trans_rcv_inv TR as (? & abs & ?); inv abs. +Qed. + +Lemma wtrans_stuck {E B X} l t : + wtrans l (Stuck : ctree E B X) t -> + l = τ /\ Seq t (Stuck : ctree E B X). +Proof. + intros WTR. + destruct l. + 1: split; auto. + 2-4:exfalso. + apply wtrans_τ in WTR as [[|n] WTR]. + now symmetry. + exfalso; destruct WTR as [? TR WTR]. + eapply trans_stuck_inv; eauto. + all: destruct WTR as [t2 [t1 TR1 TR2] TR3]. + all: destruct TR1 as [[|n] TR1]. + all: cbn in TR1; try (rewrite <- TR1 in TR2; eapply trans_stuck_inv; now eauto). + all: destruct TR1 as [? TR WTR]; eapply trans_stuck_inv; now apply TR. +Qed. + +Lemma wtrans_stuck' {E B R} : + forall (t : ctree E B R) l, + wtrans l Stuck t -> + match l with | τ => t ≅ Stuck | _ => False end. +Proof. + intros * TR. + pose proof wtrans_stuck TR as [-> EQ]. + now inv EQ. +Qed. + +Lemma wtrans_case_passive {E B X Y} (t : ctree E B X) (e : E Y) (g : Y -> ctree E B X) l: + wtrans l t (β e g) -> + (l = ask e /\ exists v h, wtrans τ t (α v) /\ trans_alt (ask e) v (β e h) /\ Seq (β e h) (β e g)). +Proof. + intros [t2 [t1 TR1 TR2] TR3]. + apply wtrans_τ in TR1. + pose proof wtrans_τ_active TR1 as [? EQ1]. + rewrite EQ1 in *. + destruct l. + - pose proof etrans_τ_inv TR2 as [? EQ2]. + rewrite EQ2 in *. + apply wtrans_τ in TR3. + pose proof wtrans_τ_active TR3 as [? EQ3]. + inv EQ3. + - cbn in TR2. + pose proof trans_ask_inv TR2 as [h EQ]. + rewrite EQ in *; clear t2 EQ. + clear t1 EQ1. + apply wtrans_τ in TR3. + pose proof passive_τ_wtrans TR3 as EQ. + dependent induction EQ. + split; auto. + exists x, h; split; auto. + split; auto. + now constructor. + - exfalso. + eapply trans_rcv_active_inv; eauto. + - exfalso. + apply trans_val_inv' in TR2. + rewrite TR2 in TR3. + apply wtrans_τ in TR3. + apply wtrans_stuck in TR3 as [_ EQ]. + inv EQ. +Qed. + +Lemma pwtrans_case {E B X} (t u : ctree E B X) l: + pwtrans l t u -> + (exists v, trans_alt l t v /\ wtrans τ v u) \/ (exists v, trans_alt τ t v /\ wtrans l v u). +Proof. + intros [t2 [t1 [n TR1] TR2] TR3]. + destruct n as [| n]. + - apply wtrans_τ in TR3. + cbn in TR1; rewrite <- TR1 in TR2. eauto. + - destruct TR1 as [? ? ?]. + right. + eexists; split; eauto. + exists t2; [exists t1|]; eauto. + exists n; eauto. + apply trans_etrans; auto. +Qed. *) + +(*| +It's a bit annoying that we need two cases in this lemma, but if +[t = Guard (Ret x)] and [u = k x], we can process the [Guard] node +by taking the [Ret] in the prefix, but we cannot process it to +reach [u] in the bound computation. +|*) + +(* Lemma wtrans_bind_r_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x : + wtrans (val x) t Stuck -> + wtrans τ (k x) u -> + (u ≅ k x \/ wtrans τ (t >>= k) u). +Proof. + intros TR1 TR2. + apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). + pose proof wtrans_τ_active TR1 as (a & EQa). + rewrite EQa in TR1. + eapply wtrans_bind_l_τ in TR1. + apply wtrans_case_active in TR2 as [[? ?] | [|(v & TR & WTR)]]. + - left; symmetry; assumption. + - right; eapply wconss; [apply TR1 | clear t TR1]. + destruct H as (? & ? & ?). + rewrite EQa in TR1'; clear t' EQa. + pose proof trans_τ_inv H as [? EQ]. + rewrite EQ in H,H0. + eapply trans_bind_r in H; [| eauto]. + eapply wcons; eauto. + - right; eapply wconss; [apply TR1 | clear t TR1]. + rewrite EQa in TR1'. + pose proof trans_τ_inv TR as [? EQ]. + rewrite EQ in TR,WTR. + eapply trans_bind_r in TR1'; eauto. + eapply wconss; [|eauto]. + apply trans_wtrans; auto. +Qed. + +Lemma wtrans_bind_r_val {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) x (y : Y) : + wtrans (val x) t Stuck -> + wtrans (val y) (k x) Stuck -> + wtrans (val y) (t >>= k) Stuck. +Proof. + intros TR1 TR2. + apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). + pose proof wtrans_τ_active TR1 as (a & EQa). + rewrite EQa in TR1, TR1'; clear t' EQa. + eapply wconss. + eapply wtrans_bind_l_τ, TR1. + clear t TR1. + apply wtrans_case_active in TR2 as [[abs ?] | [(v & TR & WTR)|(v & TR & WTR)]]. + - inv abs. + - eapply wsnocs; eauto. + apply trans_wtrans. + pose proof trans_val_inv' TR as EQ; rewrite EQ in TR |-*. + eapply trans_bind_r; eauto. + - pose proof trans_τ_inv TR as [? EQ]. + rewrite EQ in TR,WTR. + eapply trans_bind_r in TR1'; eauto. + eapply wconss; [|eauto]. + apply trans_wtrans; auto. +Qed. + +Lemma wtrans_bind_r_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (u : Z -> ctree E B Y) x : + wtrans (val x) t Stuck -> + wtrans (ask e) (k x) (β e u) -> + wtrans (ask e) (t >>= k) (β e u). +Proof. + intros TR1 TR2. + apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). + apply wtrans_case_passive in TR2 as (_ & v & h & WTR & TR & EQ). + rewrite <- EQ. + clear u EQ. + pose proof wtrans_τ_active TR1 as [? EQ]. + rewrite EQ in *; clear t' EQ. + eapply wconss. + eapply wtrans_bind_l_τ, TR1. + clear t TR1. + apply wtrans_case_active in WTR as [[_ EQ] | [(?v & TRv & WTRv) | (?v & TRv & WTRv)]]. + - rewrite <- EQ in *. + clear v EQ. + apply trans_wtrans. + eapply trans_bind_r; eauto. + - pose proof trans_τ_inv TRv as [? EQ]. + rewrite EQ in *; clear v0 EQ. + eapply wcons. + eapply trans_bind_r; eauto. + eapply wconss; eauto. + now apply trans_wtrans. + - pose proof trans_τ_inv TRv as [? EQ]. + rewrite EQ in *; clear v0 EQ. + eapply wcons. + eapply trans_bind_r; eauto. + eapply wconss; eauto. + now apply trans_wtrans. +Qed. *) + +(* Lemma wtrans_bind_r' {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l : *) +(* wtrans (val x) t Stuck -> *) +(* pwtrans l (k x) u -> *) +(* (wtrans l (t >>= k) u). *) +(* Proof. *) +(* intros TR1 TR2. *) +(* apply wtrans_val_inv in TR1 as (t' & TR1 & TR1'). *) +(* eapply wtrans_bind_l in TR1; [| intros abs; inv abs]. *) +(* apply pwtrans_case in TR2 as [? | ]. *) +(* - eapply wconss; [apply TR1 | clear t TR1]. *) +(* destruct H as (? & ? & ?). *) +(* eapply trans_bind_r in TR1'; eauto. *) +(* eapply wsnocs; eauto. *) +(* apply trans_wtrans; auto. *) +(* - eapply wconss; [apply TR1 | clear t TR1]. *) +(* destruct H as (? & ? & ?). *) +(* eapply trans_bind_r in TR1'; eauto. *) +(* eapply wconss; [|eauto]. *) +(* apply trans_wtrans; auto. *) +(* Qed. *) + +(* [trans_val_invT] is no longer needed: with [label] now indexed by + the return type [R], the equality [R = R'] it used to extract is + enforced by typing. Callers that relied on it can simply drop the + surrounding [apply trans_val_invT ... ; subst] step. *) + +(* Lemma wtrans_bind_lr {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) (v : ctree E B Y) x l : *) +(* pwtrans l t u -> *) +(* wtrans (val x) u Stuck -> *) +(* pwtrans τ (k x) v -> *) +(* (wtrans l (t >>= k) v). *) +(* Proof. *) +(* intros [t2 [t1 TR1 TR1'] TR1''] TR2 TR3. *) +(* exists (x <- t2;; k x). *) +(* - assert (~ is_val l). *) +(* { *) +(* destruct l; try now intros abs; inv abs. *) +(* exfalso. *) +(* pose proof (trans_val_invT TR1'); subst. *) +(* apply trans_val_inv in TR1'. *) +(* rewrite TR1' in TR1''. *) +(* apply transs_is_stuck_inv in TR1''; [| apply stuck_is_stuck]. *) +(* rewrite <- TR1'' in TR2. *) +(* apply wtrans_is_stuck_inv in TR2; [| apply stuck_is_stuck]. *) +(* destruct TR2 as [abs _]; inv abs. *) +(* } *) +(* eexists. *) +(* 2:apply trans_etrans, trans_bind_l; eauto. *) +(* apply wtrans_τ; eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_τ; auto]. *) +(* - apply wtrans_τ. *) +(* eapply wconss. *) +(* eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_τ; eauto]. *) +(* eapply wtrans_bind_r'; eauto. *) +(* Qed. *) + +Lemma trans_trigger : forall {E B X Y} (e : E X) (k : X -> ctree E B Y), + trans_alt (ask e) (trigger e >>= k) (β e k). +Proof. + intros. + unfold CTree.trigger. + rewrite unfold_bind; cbn. + setoid_rewrite bind_ret_l. + constructor; auto. +Qed. + +Lemma trans_trigger' : forall {E B X Y} (e : E X) (t : ctree E B Y), + trans_alt (ask e) (trigger e;; t) (β e (fun _ => t)). +Proof. + intros. + unfold CTree.trigger. + rewrite unfold_bind; cbn. + setoid_rewrite bind_ret_l. + constructor; auto. +Qed. + +Lemma trans_trigger_inv : forall {E B X Y} (e : E X) (k : X -> ctree E B Y) l u, + trans_alt l (trigger e >>= k) u -> + Seq u (β e k) /\ l = ask e. +Proof. + intros * TR. + unfold trigger in TR. + rewrite bind_vis in TR. + apply trans_vis_inv' in TR as [EQ ->]. + setoid_rewrite bind_ret_l in EQ. + split; auto. +Qed. + +(* Lemma trans_branch : + forall {E B : Type -> Type} {X : Type} {Y : Type} + [l : label E X] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y), + trans_alt l (k x) t' -> + trans_alt l (branch c >>= k) t'. +Proof. + intros. + rewrite bind_branch. + eapply trans_br; eauto. +Qed. *) + +Create HintDb trans_alt. +(* #[global] Hint Resolve + trans_ret trans_ask trans_brS trans_br + trans_guard + trans_br21 trans_br22 + trans_br31 trans_br32 trans_br33 + trans_br41 trans_br42 trans_br43 trans_br44 + trans_step + trans_brS21 trans_brS22 + trans_brS31 trans_brS32 trans_brS33 + trans_brS41 trans_brS42 trans_brS43 trans_brS44 + trans_trigger trans_bind_l_τ trans_bind_l_ask trans_bind_r + : trans_alt. *) + +#[global] Hint Constructors is_val : trans_alt. +#[global] Hint Resolve + is_val_τ + is_val_ask + is_val_rcv : trans_alt. + +Ltac etrans := eauto with trans_alt. +#[global] Arguments trans_alt : simpl never. + + +(*| +Structured relations on labels +|*) + +Section build_rel. + + Context {E F : Type -> Type} {X Y : Type}. + + Record lrel := + { + RR: rel X Y ; + Rask: forall [X Y], E X -> F Y -> Prop ; + Rrcv: forall [X Y] (e : E X) (f : F Y), X -> Y -> Prop ; + }. + + Variant build_rel {RL : lrel} : hrel (label E X) (label F Y) := + | rel_τ : build_rel τ τ + | rel_ask {X Y} {e : E X} {f : F Y} + (HR : Rask RL e f) : + build_rel (ask e) (ask f) + | rel_rcv {X Y} {e : E X} {f : F Y} x y + (HR : Rrcv RL e f x y) : + build_rel (rcv e x) (rcv f y) + | rel_ret {x : X} {y : Y}: + RR RL x y -> build_rel (val x) (val y). + Arguments build_rel : clear implicits. + + Lemma build_rel_val RL x y : + build_rel RL (val x) (val y) -> RR RL x y. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_ask RL A B (e : E A) (f : F B) : + build_rel RL (ask e) (ask f) -> Rask RL e f. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_rcv RL A B (e : E A) (f : F B) a b : + build_rel RL (rcv e a) (rcv f b) -> Rrcv RL e f a b. + Proof. + now intros H; dependent induction H. + Qed. + + Lemma build_rel_τ RL : + build_rel RL τ τ. + Proof. + constructor. + Qed. + +End build_rel. + +Arguments lrel : clear implicits. +Arguments build_rel {E F X Y} RL. +#[global] Hint Constructors build_rel : trans_alt. +Coercion build_rel : lrel >-> hrel. + +Definition upd_rel {E F X Y X' Y'} + (RL : lrel E F X Y) + (SS : rel X' Y') : lrel E F X' Y' := + {| + RR := SS ; + Rask := Rask RL ; + Rrcv := Rrcv RL + |}. + +Variant eq1 {E} : forall [X Y : Type], rel (E X) (E Y) := + | Eq1 X (e : E X) : eq1 e e. +Variant eq2 {E} : forall [X Y : Type], E X -> E Y -> rel X Y := + | Eq2 X (e : E X) x : eq2 e e x x. +Hint Resolve Eq1 : trans_alt. +Hint Resolve Eq2 : trans_alt. + +Definition Leq {E} {X : Type} : lrel E E X X := + {| + RR := eq ; + Rask := eq1 ; + Rrcv := eq2 + |}. + +Definition Lvrel {E X Y} (RR : rel X Y) : lrel E E X Y := + {| + RR := RR ; + Rask := eq1 ; + Rrcv := eq2 + |}. + +Ltac invL := + match goal with + h: build_rel _ _ _ |- _ => dependent induction h + | h: upd_rel _ _ _ _ |- _ => dependent induction h + end. + +Definition lequiv {E F X Y} : rel (lrel E F X Y) (lrel E F X Y) := + fun L1 L2 => RR L1 == RR L2 /\ Rask L1 == Rask L2 /\ Rrcv L1 == Rrcv L2. + +#[global] Instance lequiv_equivalence {E F X Y} : Equivalence (@lequiv E F X Y). +Proof. + constructor. + - split3; auto. + - intros ?? [? []]; split3; symmetry; auto. + - intros ??? [? []] [? []]; split3; etransitivity; eauto. +Qed. + +#[global] Instance lequiv_build_rel {E F X Y} : Proper (lequiv ==> weq) (@build_rel E F X Y). +Proof. + cbn; intros L1 L2 [EQ1 [EQ2 EQ3]] l1 l2; split; intros H. + - inv H; etrans. + constructor; now apply EQ2. + constructor; now apply EQ3. + constructor; now apply EQ1. + - inv H; etrans. + constructor; now apply EQ2. + constructor; now apply EQ3. + constructor; now apply EQ1. +Qed. + +#[global] Instance lequiv_build_rel' {E F X Y} : Proper (lequiv ==> eq ==> eq ==> iff) (@build_rel E F X Y). +Proof. + now cbn; intros; subst; eapply lequiv_build_rel. +Qed. + +Definition sub_lrel {E F X Y} (L L' : lrel E F X Y) : Prop := + RR L <= RR L' /\ Rask L <= Rask L' /\ Rrcv L <= Rrcv L'. + +Lemma sub_lrel_subrel {E F X Y} : + Proper (sub_lrel ==> leq) (@build_rel E F X Y). +Proof. + intros L L' (SUB1 & SUB2 & SUB3) ?? HL. + inv HL; etrans. + now constructor; apply SUB2. + now constructor; apply SUB3. + now constructor; apply SUB1. +Qed. + +Definition flipL {E F X Y} (L : lrel E F X Y) : lrel F E Y X := + {| RR := flip (RR L) ; + Rask := fun X Y => flip (@Rask _ _ _ _ L Y X) ; + Rrcv := fun X Y f e => flip (Rrcv L e f) |}. + +Lemma flipL_flip {E F X Y} (L : lrel E F X Y) : + build_rel (flipL L) == flip (build_rel L). +Proof. + intros f e; split; cbn; intros []; constructor; auto. +Qed. + +Lemma lequiv_sub_lrel {E F X Y} (L L' : lrel E F X Y): + sub_lrel L L' -> + sub_lrel (flipL L) (flipL L'). +Proof. + intros (EQV & EQA & EQR). + split3. + now cbn; intros; apply EQV. + now cbn; intros; apply EQA. + now cbn; intros; apply EQR. +Qed. + +Lemma lequiv_flipL {E F X Y} (L L' : lrel E F X Y): + lequiv L L' -> + lequiv (flipL L) (flipL L'). +Proof. + intros (EQV & EQA & EQR). + split3. + cbn; intros; apply EQV. + cbn; intros; apply EQA. + cbn; intros; apply EQR. +Qed. + +Lemma equiv_flipL {E F X Y} (L L' : lrel E F X Y): + build_rel L == build_rel L' -> + build_rel (flipL L) == build_rel (flipL L'). +Proof. + intros EQ e f; specialize (EQ f e); cbn in *. + split. + - destruct EQ as [EQ _]. + intros FL; dependent induction FL; constructor. + cbn in *. + assert (HL: L (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + - destruct EQ as [_ EQ]. + intros FL; dependent induction FL; constructor. + cbn in *. + assert (HL: L' (ask f) (ask e)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L' (rcv f y) (rcv e x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. + assert (HL: L' (val y) (val x)) by (now constructor); apply EQ in HL; dependent induction HL; auto. +Qed. + +#[global] Instance flipL_reflexive {E X} (L : lrel E E X X) {LR: Reflexive L} : Reflexive (flipL L). +Proof. + intros ?. + now apply flipL_flip. +Qed. + +#[global] Instance flipL_symmetric {E X} (L : lrel E E X X) {LR: Symmetric L} : Symmetric (flipL L). +Proof. + intros l l' HL. + apply flipL_flip. + apply (flipL_flip L) in HL. + now apply LR. +Qed. + +#[global] Instance flipL_transitive {E X} (L : lrel E E X X) {LR: Transitive L} : Transitive (flipL L). +Proof. + intros l1 l2 l3 HL1 HL2. + apply flipL_flip. + apply (flipL_flip L) in HL1,HL2. + etransitivity; eauto. +Qed. + +#[global] Instance flipL_equivalence {E X} (L : lrel E E X X) {LR: Equivalence L} : Equivalence (flipL L). +Proof. + split; typeclasses eauto. +Qed. + +#[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). +Proof. + intros l l' HL. + unfold Lvrel in *. + dependent induction HL; constructor; cbn in *. + dependent induction HR; constructor. + dependent induction HR; constructor. + now apply H. +Qed. + +(* #[global] Instance Leq_equiv {E X} : Equivalence (build_rel (@Leq E X)). +Proof. + split. + - intros []; try now constructor. + - intros ?? H. + inv H; try now constructor. + cbn in HR. + dependent induction HR; now constructor. + dependent induction HR; now constructor. + - intros ??? H1 H2. + dependent induction H1; dependent induction H2; try now constructor. + dependent induction HR; dependent induction HR0; now constructor. + dependent induction HR; dependent induction HR0; now constructor. + cbn in *; subst; now constructor. +Qed. *) + +(* Lemma Leq_eq {E X}: build_rel (@Leq E X) == eq. +Proof. + split; [| intros <-; reflexivity]. + intros []; auto. + dependent induction HR; auto. + dependent induction HR; auto. + cbn in H; subst; auto. +Qed. *) + +Lemma flipL_Leq {E X}: lequiv (flipL (@Leq E X)) Leq. +Proof. + cbv; intuition. + all: dependent induction H; constructor. +Qed. + +(* This one is a bit ugly: we will have proper instance to + lift [lequiv] arguments of (bi)simulations to [weq] result. + This instance does the last bit to allow the rewriting by [lequiv] + directly. + *) +#[global] Instance weq_body {E B X}: + Proper (Coinduction.lattice.weq ==> eq ==> eq ==> eq ==> iff) + (@body (rel (S E B X) (S E B X)) _). +Proof. + cbn; intros R L EQ ?? <- ?? <- ?? <-; split; intros H. + all:apply EQ; auto. +Qed. + +(* Ltac simpL := + repeat match goal with + | h : build_rel (flipL _) _ _ |- _ => rewrite flipL_Leq in h + | h : build_rel Leq _ _ |- _ => apply Leq_eq in h + | |- context[flipL Leq] => rewrite flipL_Leq + end; subst. *) + +(* (*| *) +(* [wf_val] states that a [label] is well-formed: *) +(* if it is a [val] it should be of the right type. *) +(* |*) *) +(* Definition wf_val {E} X l := forall Y (v : Y), l = @val E Y v -> X = Y. *) + +(* Lemma wf_val_val {E} X (v : X) : wf_val X (@val E X v). *) +(* Proof. *) +(* red. intros. apply val_eq_invT in H. assumption. *) +(* Qed. *) + +(* Lemma wf_val_nonval {E} X (l : @label E) : ~is_val l -> wf_val X l. *) +(* Proof. *) +(* red. intros. subst. exfalso. apply H. constructor. *) +(* Qed. *) + +(* Lemma wf_val_trans {E B X} (l : @label E) t t' : *) +(* @trans_alt E B X l t t' -> wf_val X l. *) +(* Proof. *) +(* red. intros. subst. *) +(* now apply trans_val_invT in H. *) +(* Qed. *) + +(* Lemma wf_val_is_val_inv : forall {E} X (l : @label E), *) +(* is_val l -> *) +(* wf_val (E := E) X l -> *) +(* exists (x : X), l = val x. *) +(* Proof. *) +(* intros. *) +(* destruct H. red in H0. *) +(* specialize (H0 X0 x eq_refl). subst. eauto. *) +(* Qed. *) + +(* (*| If the LTS has events of type [L +' R] then *) +(* it is possible to step it as either an [L] LTS *) +(* or [R] LTS ignoring the other. *) +(* *) *) +(* Section Coproduct. *) +(* Arguments label: clear implicits. *) +(* Context {L R C: Type -> Type} {X: Type}. *) +(* Notation S := (ctree (L +' R) C X). *) +(* Notation S' := (ctree' (L +' R) C X). *) +(* Notation SP := (SS -> label (L +' R) -> Prop). *) + +(* (* Skip an [R] event *) *) +(* Inductive srtrans_: rel S' S' := *) +(* | IgnoreR {X} (e : R X) k x t : *) +(* srtrans_ (observe (k x)) t -> *) +(* srtrans_ (VisF (inr1 e) k) t. *) + +(* (* Skip an [L] event *) *) +(* Inductive sltrans_: rel S' S' := *) +(* | IgnoreL {X} (e : L X) k x t : *) +(* sltrans_ (observe (k x)) t -> *) +(* sltrans_ (VisF (inl1 e) k) t. *) + +(* Hint Constructors srtrans_ sltrans_: core. *) + +(* (* Make those relations that respect equality [srel] *) *) +(* Program Definition srtrans : srel SS SS := *) +(* {| hrel_of := (fun (u v: SS) => srtrans_ (observe u) (observe v)) |}. *) +(* Next Obligation. split; induction 1; auto. Defined. *) + +(* Program Definition sltrans : srel SS SS := *) +(* {| hrel_of := (fun (u v: SS) => sltrans_ (observe u) (observe v)) |}. *) +(* Next Obligation. split; induction 1; auto. Defined. *) + +(* (*| Obs transition on the left, ignores right transitions and [τ] |*) *) +(* Definition ltrans {X}(l: L X)(x: X): srel SS SS := *) +(* (trans_alt τ ⊔ srtrans)^* ⋅ trans_alt (obs (inl1 l) x) ⋅ (trans_alt τ ⊔ srtrans)^*. *) + +(* (*| Obs transition on the right, ignores left transitions and [τ] |*) *) +(* Definition rtrans {X}(r: R X)(x: X): srel SS SS := *) +(* (trans_alt τ ⊔ sltrans)^* ⋅ trans_alt (obs (inr1 r) x) ⋅ (trans_alt τ ⊔ sltrans)^*. *) + +(* End Coproduct. *) + +#[global] Notation htrans l u v := (hrel_of (trans_alt l) u v) (only parsing). + +(*| +[refine_transition H]: given a transition whose concrete label is known, +derive information on the active/passive status of its destination state. + +Currently very partial +|*) +(* Ltac refine_trans_in h := + match type of h with + | htrans τ _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_τ_inv h as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + | htrans (ask ?e) _ _ => + let u := fresh "u" in + let EQ := fresh "EQ" in + pose proof trans_ask_inv h as [u EQ]; + rewrite EQ in *; + match type of EQ with + | Seq ?a _ => try clear a EQ + end + end. *) + +(* Tactic Notation "refine_trans" := + match goal with + | h : htrans _ _ _ |- _ => refine_trans_in h + end. +Tactic Notation "refine_trans" "in" ident(h) := refine_trans_in h. *) + +(*| +[inv_trans] is an helper tactic to automatically +invert hypotheses involving [trans_alt]. +|*) + +Ltac inv_label_eq EQl := + match type of EQl with + | τ = τ => + clear EQl + | val _ = val _ => + apply val_eq_inv in EQl; try (inversion EQl; fail) + | ask _ = ask _ => + let EQt := fresh "EQt" in + let EQe := fresh "EQe" in + apply ask_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply ask_inv in EQl as EQe; + try (inversion EQe; fail) + | rcv _ _ = rcv _ _ => + let EQt := fresh "EQt" in + let EQt := fresh "EQv" in + let EQe := fresh "EQe" in + apply rcv_invT in EQl as EQt; + symmetry in EQt; + (* subst_hyp_in EQt h; *) + apply rcv_inv in EQl as [EQe EQv]; + try (inversion EQe; inversion EQv; fail) + | _ => subst; try now inv EQl + end. + +(* Ltac inv_trans_one := + match goal with + (* Ret *) + | h : htrans _ (α Ret _) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + (apply trans_ret_inv in h as [EQ EQl] || apply trans_ret_inv' in h as [EQ EQl]); + try rewrite EQ in *; + inv_label_eq EQl + + (* Step *) + | h : htrans _ (α Step _) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + apply trans_step_inv' in h as (EQ & EQl); + try rewrite EQ in *; + inv_label_eq EQl + + (* Br *) + | h : htrans _ (α Br _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br_inv in h as (?n & TR) + + | h : htrans _ (α br2 _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br2_inv in h as [TR | TR] + + | h : htrans _ (α br3 _ _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br3_inv in h as [TR | [TR | TR]] + + | h : htrans _ (α br4 _ _ _ _) _ |- _ => + let TR := fresh "TR" in + apply trans_br4_inv in h as [TR | [TR | [TR | TR]]] + + | h : htrans _ (α brS2 _ _) _ |- _ => + let EQ := fresh "EQ" in + apply trans_brS2_inv' in h as (-> & [EQ | EQ]) + + | h : htrans _ (α brS3 _ _ _) _ |- _ => + let EQ := fresh "EQ" in + apply trans_brS3_inv' in h as (-> & [EQ | [EQ | EQ]]) + + | h : htrans _ (α brS4 _ _ _ _) _ |- _ => + let EQ := fresh "EQ" in + apply trans_brS4_inv' in h as (-> & [EQ | [EQ | [EQ | EQ]]]) + + (* Guard *) + | h : htrans _ (α Guard _) _ |- _ => + apply trans_guard_inv in h + + (* Vis *) + | h : htrans _ (α (Vis ?e ?k)) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + apply trans_vis_inv' in h as (EQ & EQl); + try rewrite EQ in *; + inv_label_eq EQl + + (* Stuck *) + | h : htrans _ (α Stuck) _ |- _ => + exfalso; eapply trans_stuck_inv; now apply h + + (* Passive *) + | h : htrans _ (β ?e ?k) _ |- _ => + let EQl := fresh "EQl" in + let EQ := fresh "EQ" in + apply trans_passive_inv' in h as (?x & EQ & EQl); + try rewrite EQ in *; + inv_label_eq EQl + + end. + +Ltac inv_trans := repeat (inv_trans_one). *) + +Ltac use_steps n := +lazymatch goal with +|- context [(str _)] => + repeat red; + + repeat match goal with + + (* ^* case *) + | |- exists2 _, _ & _ => eexists; repeat red + (* base case: just ^* *) + | |- exists n : nat, _ => + exists (n : nat); + cbn; try solve [reflexivity] end + end. + + (* break iter *) + (* Unset Printing Notations. *) +Lemma trans_star_self {E B R} (x : SS) l: (@trans_alt E B R l)^* x x. +Proof. use_steps O. Qed. + +Lemma trans_star_l {E B R} (x y : SS) l1 l2 : +trans_alt l2 x y -> +((@trans_alt E B R l1)^* ⋅ trans_alt l2) x y. +Proof. intros. use_steps O. assumption. Qed. + +Tactic Notation "use" ident(n) "steps" := use_steps n. + \ No newline at end of file From 701681c2ce534aed2083f3479f61d7ac97d1bccc Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Mon, 6 Jul 2026 14:47:03 +0200 Subject: [PATCH 34/61] Equivalence between old and new trans. --- theories/Eq/AltEquiv.v | 286 +++++++++++++++++++++++++++++++++++++++++ theories/Eq/TransAlt.v | 249 +++++++++++++---------------------- 2 files changed, 373 insertions(+), 162 deletions(-) create mode 100644 theories/Eq/AltEquiv.v diff --git a/theories/Eq/AltEquiv.v b/theories/Eq/AltEquiv.v new file mode 100644 index 0000000..68934e6 --- /dev/null +++ b/theories/Eq/AltEquiv.v @@ -0,0 +1,286 @@ +From Stdlib Require Import Fin Program.Equality. + +From Coinduction Require Import all. + +From ITree Require Import + Core.Subevent + Indexed.Sum. + +From CTree Require Import + CTree Eq.Shallow Eq.Equ Eq.Epsilon. + +From CTree Require Eq.Trans Eq.SSim. + +From CTree Require Import Eq.TransAlt Eq.SSimAlt. + +From RelationAlgebra Require Import + monoid kat kat_tac prop rel srel comparisons rewriting normalisation. + +Import CTree. +Import CTreeNotations. +Import EquNotations. +Import CoindNotations. +Open Scope ctree. + +Set Implicit Arguments. + +(* label and S conversion *) +(* convention: "o" is old, "n" is new. *) + +Definition o2n_S {E B X} (s : Trans.S E B X) : TransAlt.S E B X := + match s with + | Trans.Active t => TransAlt.Active t + | Trans.Passive e k => TransAlt.Passive e k + end. + +Definition n2o_S {E B X} (s : TransAlt.S E B X) : Trans.S E B X := + match s with + | TransAlt.Active t => Trans.Active t + | TransAlt.Passive e k => Trans.Passive e k + end. + +Definition o2n_label {E X} (l : Trans.label E X) : TransAlt.label E X := + match l with + | Trans.τ => TransAlt.τ + | Trans.ask e => TransAlt.ask e + | Trans.rcv e v => TransAlt.rcv e v + | Trans.val v => TransAlt.val v + end. + +Lemma n2o_o2n_S {E B X} (s : Trans.S E B X) : n2o_S (o2n_S s) = s. +Proof. now destruct s. Qed. + +Lemma o2n_n2o_S {E B X} (s : TransAlt.S E B X) : o2n_S (n2o_S s) = s. +Proof. now destruct s. Qed. + +(* add an epsilon *) +Lemma estar_cons {E B X} (a b c : TransAlt.S E B X) : + trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. +Proof. + intros H1 H2. + assert (HH : (trans_alt (E:=E) (B:=B) (R:=X) ε ⋅ (trans_alt ε)^*) ≦ (trans_alt ε)^*) by ka. + apply HH. exists b; assumption. +Qed. + +Lemma transR_o2n {E B X} (l : Trans.label E X) (a a' : Trans.S E B X) : + Trans.transR l a a' -> + ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) (o2n_S a) (o2n_S a'). +Proof. + intros TR; induction TR. + - destruct IHTR as [m STAR STEP]. + exists m; [| apply STEP]. + eapply estar_cons; [ | apply STAR ]. + eapply TransAlt.Transbr; [ apply H | apply H0 ]. + - destruct IHTR as [m STAR STEP]. + exists m; [| apply STEP]. + eapply estar_cons; [ | apply STAR ]. + eapply TransAlt.Transguard; [ apply H | reflexivity ]. + - apply trans_star_l. eapply TransAlt.Transstep; [ apply H | apply H0 ]. + - apply trans_star_l. eapply TransAlt.Transask; apply H. + - apply trans_star_l. eapply TransAlt.Transrcv; apply H. + - apply trans_star_l. eapply TransAlt.Transval; [ apply H | apply H0 ]. +Qed. + +Lemma n2o_S_Seq {E B X} (a b : TransAlt.S E B X) : + TransAlt.Seq a b -> Trans.Seq (n2o_S a) (n2o_S b). +Proof. intros H; inv H; cbn [n2o_S]; constructor; assumption. Qed. + +Lemma trans_alt_eps_inv {E B X} (a mid : TransAlt.S E B X) : + trans_alt ε a mid -> + (exists Z (c : B Z) (k : Z -> ctree E B X) t u x, + a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Br c k /\ u ≅ k x) + \/ (exists t t' u, + a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Guard t' /\ u ≅ t'). +Proof. + intros TR; unfold trans_alt in TR; cbn in TR. + inversion TR; subst. + - left. eauto 12. + - right. eauto 12. +Qed. + +Lemma eps_absorb1 {E B X} (l : Trans.label E X) (a mid c : TransAlt.S E B X) : + trans_alt ε a mid -> + Trans.transR l (n2o_S mid) (n2o_S c) -> + Trans.transR l (n2o_S a) (n2o_S c). +Proof. + intros TR Hold. + apply trans_alt_eps_inv in TR as + [ (Z & cc & k & t & u & x & -> & -> & Hbr & Hu) + | (t & t' & u & -> & -> & Hg & Hu) ]; + cbn [n2o_S] in *. + - assert (S1 : Trans.Seq (Trans.Active t) (Trans.Active (Br cc k))) + by (constructor; apply Hbr). + rewrite S1. + eapply Trans.trans_br with (y := x). + assert (S2 : Trans.Seq (Trans.Active (k x)) (Trans.Active u)) + by (constructor; symmetry; apply Hu). + rewrite S2. apply Hold. + - assert (S1 : Trans.Seq (Trans.Active t) (Trans.Active (Guard t'))) + by (constructor; apply Hg). + rewrite S1. + eapply Trans.trans_guard. + assert (S2 : Trans.Seq (Trans.Active t') (Trans.Active u)) + by (constructor; symmetry; apply Hu). + rewrite S2. apply Hold. +Qed. + +Lemma estar_absorb {E B X} (l : Trans.label E X) (a m : TransAlt.S E B X) : + (trans_alt ε)^* a m -> + forall c, Trans.transR l (n2o_S m) (n2o_S c) -> Trans.transR l (n2o_S a) (n2o_S c). +Proof. + intros [n STAR]. revert a m STAR. + induction n; intros a m STAR c Hold. + - cbn in STAR. apply n2o_S_Seq in STAR. rewrite STAR. apply Hold. + - destruct STAR as [mid STEP REST]. + eapply eps_absorb1; [ apply STEP | ]. + eapply IHn; [ apply REST | apply Hold ]. +Qed. + +Lemma transR_label_base {E B X} (l : Trans.label E X) (m b : TransAlt.S E B X) : + trans_alt (o2n_label l) m b -> Trans.transR l (n2o_S m) (n2o_S b). +Proof. + destruct l; cbn [o2n_label]; intros TR; unfold trans_alt in TR; cbn in TR. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transstep; eassumption. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transask; eassumption. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transrcv; eassumption. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transval; eassumption. +Qed. + +Lemma transR_n2o {E B X} (l : Trans.label E X) (a b : TransAlt.S E B X) : + ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) a b -> + Trans.transR l (n2o_S a) (n2o_S b). +Proof. + intros [m STAR STEP]. + eapply estar_absorb; [ apply STAR | ]. + apply transR_label_base; apply STEP. +Qed. + +Definition lift_L {E F X} (L : Trans.lrel E F X X) + : rel (TransAlt.label E X) (TransAlt.label F X) := + fun a b => exists la lb, a = o2n_label la /\ b = o2n_label lb /\ Trans.build_rel L la lb. + +Lemma label_non_eps_image {E X} (l : TransAlt.label E X) : + l <> ε -> exists lo, l = o2n_label lo. +Proof. + destruct l; intro Hne. + - exists Trans.τ; reflexivity. + - easy. + - exists (Trans.ask e); reflexivity. + - exists (Trans.rcv e v); reflexivity. + - exists (Trans.val v); reflexivity. +Qed. + +Lemma o2n_label_inj {E X} (l l' : Trans.label E X) : + o2n_label l = o2n_label l' -> l = l'. +Proof. + destruct l, l'; cbn; intro H; try easy; + dependent destruction H; reflexivity. +Qed. + +Lemma o_ssim_br_step {E F B X} (L : Trans.lrel E F X X) + Z (c : B Z) (k : Z -> ctree E B X) (t u : ctree E B X) (b : Trans.S F B X) x : + SSim.ssim L (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> + SSim.ssim L (Trans.Active u) b. +Proof. + intros H Hbr Hu. + unfold SSim.ssim in H |- *. + apply (gfp_pfp (SSim.ss L)) in H. + apply (b_chain (chain_gfp (SSim.ss L))). + intros l t' TR. + apply (H l t'). + eapply Trans.Transbr. + - apply Hbr. + - apply Hu. + - apply TR. +Qed. + +Lemma o_ssim_guard_step {E F B X} (L : Trans.lrel E F X X) + (t tg u : ctree E B X) (b : Trans.S F B X) : + SSim.ssim L (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> + SSim.ssim L (Trans.Active u) b. +Proof. + intros H Hg Hu. + unfold SSim.ssim in H |- *. + apply (gfp_pfp (SSim.ss L)) in H. + apply (b_chain (chain_gfp (SSim.ss L))). + intros l t' TR. + apply (H l t'). + assert (Htu : t ≅ Guard u) by (rewrite Hu; apply Hg). + eapply Trans.Transguard; [ apply Htu | apply TR ]. +Qed. + +(* main result *) +Lemma o_ssim_to_ssim' {E F B X} (L : Trans.lrel E F X X) : + forall (a : Trans.S E B X) (b : Trans.S F B X), + SSim.ssim L a b -> SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b). +Proof. + unfold SSimAlt.ssim'. + coinduction c cih. + intros a b H. + split. + - intros x l Hne TR. + apply label_non_eps_image in Hne as [lo ->]. + step in H. + assert (oTR : Trans.transR lo a (n2o_S x)). + { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } + repeat red in H. + destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). + exists (o2n_label lo'), (o2n_S bo'). + split; [| split]. + + apply transR_o2n. apply TRb. + + specialize (cih (n2o_S x) bo' Hrel). + rewrite o2n_n2o_S in cih. apply cih. + + red. exists lo, lo'. tauto. + - intros x TR. + exists (o2n_S b). split. + + apply trans_star_self. + + apply trans_alt_eps_inv in TR as + [ (Z & c' & k & t & u & x0 & Ha & Hx & Hbr & Hu) + | (t & tg & u & Ha & Hx & Hg & Hu) ]. + (* t is a branch, *) + * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. + inv Ha. + apply (cih (Trans.Active u) b). + eapply o_ssim_br_step; eauto. + (* t is a guard, one epsilon step and coinduction *) + * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. + inv Ha. + apply (cih (Trans.Active u) b). + eapply o_ssim_guard_step; eauto. +Qed. + +Lemma ssim'_to_o_ssim {E F B X} (L : Trans.lrel E F X X) : + forall (a : Trans.S E B X) (b : Trans.S F B X), + SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b) -> SSim.ssim L a b. +Proof. + unfold SSim.ssim. + coinduction R cih. + intros a b H. + intros l ao' oTR. + apply transR_o2n in oTR. + destruct oTR as [m STAR STEP]. + eapply SSimAlt.ssim'_epsilon_l in H. 2: apply STAR. + apply (gfp_pfp (SSimAlt.ss' (lift_L L))) in H. + destruct H as (Hchal & _). + destruct (Hchal (o2n_S ao') (o2n_label l)) as (nl' & u' & RESP & Hgfp & HL). + { destruct l; cbn [o2n_label]; easy. } + { apply STEP. } + destruct HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hla; subst la. + subst nl'. + exists lb, (n2o_S u'). + split; [| split]. + - rewrite <- (n2o_o2n_S b). apply transR_n2o. apply RESP. + - apply cih. rewrite o2n_n2o_S. apply Hgfp. + - apply HLab. +Qed. + +Theorem ssim_ssim' {E F B X} (L : Trans.lrel E F X X) + (t : ctree E B X) (t' : ctree F B X) : + SSim.ssim L (Trans.Active t) (Trans.Active t') <-> + SSimAlt.ssim' (lift_L L) (TransAlt.Active t) (TransAlt.Active t'). +Proof. + split; intro H. + - apply o_ssim_to_ssim' in H. apply H. + - apply ssim'_to_o_ssim. apply H. +Qed. diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v index 3063c84..7ca4248 100644 --- a/theories/Eq/TransAlt.v +++ b/theories/Eq/TransAlt.v @@ -1453,178 +1453,103 @@ l <> val x -> trans_alt l t u -> trans_alt l (t >>= k) (u >>= k) trans_alt (val x) t stuck -> trans_alt l (k x) u -> trans_alt l (bind t k) u. |*) -(* Lemma trans_bind_inv {E B X Y} - (t : ctree E B X) (k : X -> ctree E B Y) - u (l : label E Y) : - trans_alt l (t >>= k) u -> - (l = τ /\ exists t', trans_alt τ t (α t') /\ Seq u (α t' >>= k)) \/ - (exists Z (e : E Z), - l = ask e /\ - exists (g : Z -> ctree E B X), - trans_alt (ask e) t (β e g) /\ Seq u (β e (fun x => g x >>= k))) \/ - (exists (x : X), trans_alt (val x) t Stuck /\ trans_alt l (k x) u). +Lemma trans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + trans_alt τ (Active t) (Active u) -> + trans_alt τ (Active (x <- t;; k x)) (Active (x <- u;; k x)). Proof. - intros TR. - rem_weak (α x <- t ;; k x) as ob. - revert t EQ. - induction TR. - - intros ? EQ. - inv EQ. - rewrite EQ0 in H. - apply br_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. - + right; right. - exists r; split. - rewrite EQ1; auto. - rewrite EQ2. - rewrite H0. now econstructor. - + edestruct IHTR as [H | [H | H]]; [rewrite H0, EQ2; reflexivity |..]; clear IHTR. - * destruct H as (-> & u' & EQ1' & EQ2'). - left. split; auto. - eexists; split; [| eassumption]; rewrite EQ1; eauto. - * destruct H as (Z & e & -> & g & TR' & EQ). - right; left. - exists Z,e; split; auto; exists g; split; auto. - rewrite EQ1; eauto. - * destruct H as (y & TR' & TR''). - right; right. - exists y; split; auto. - rewrite EQ1; eauto. - - - intros ? EQ. - inv EQ. - rewrite EQ0 in H. - apply guard_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. - + right; right. - exists r; split. - rewrite EQ1; auto. - rewrite EQ2; auto. - + edestruct IHTR as [H | [H | H]]; [rewrite <- EQ2; reflexivity | ..]; clear IHTR. - * destruct H as (-> & u' & EQ1' & EQ2'). - left. split; auto. - eexists; split; [| eassumption]; rewrite EQ1; auto. - * destruct H as (Z & e & -> & g & TR' & EQ). - right; left. - exists Z,e; split; auto; exists g; split; auto. - rewrite EQ1; auto. - * destruct H as (x & TR' & TR''). - right; right. - exists x; split; auto. - rewrite EQ1; auto. - - - intros ? EQ. - inv EQ. - rewrite EQ0 in H. - apply step_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. - + right; right. - exists r; split. - rewrite EQ1; auto. - rewrite EQ2, H0; auto. - + left. - split; auto. - exists v; split. - rewrite EQ1; auto. - rewrite H0, <- EQ2; auto. - - - intros ? EQ. - inv EQ. - rewrite EQ0 in H. - apply vis_equ_bind in H as [(r & EQ1 & EQ2) | (v & EQ1 & EQ2)]. - + right; right. - exists r; split. - rewrite EQ1; auto. - rewrite EQ2; auto. - + right; left. - exists X0, e; split; auto. - exists v; split. - rewrite EQ1; auto. - constructor. - intros ?. - rewrite EQ2; auto. - - - intros ? EQ. - inv EQ. - - - intros ? EQ. - inv EQ. - rewrite EQ0 in H. - apply ret_equ_bind in H as (r' & EQ1 & EQ2). - right; right. - exists r'; split. - rewrite EQ1; auto. - rewrite EQ2, H0; auto. -Qed. *) - -(* Lemma trans_bind_inv_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u l : - trans_alt l (t >>= k) u -> - exists l' t', trans_alt l' t t'. + intros TR; unfold trans_alt in TR; cbn in TR; dependent destruction TR. + eapply Transstep. + - rewrite H, bind_step; reflexivity. + - rewrite H0; reflexivity. +Qed. + +Lemma trans_bind_l_ε {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : + trans_alt ε (Active t) (Active u) -> + trans_alt ε (Active (x <- t;; k x)) (Active (x <- u;; k x)). Proof. - intros TR. - apply trans_bind_inv in TR. - destruct TR as [(? & ? & ? & ?) | [(? & ? & ? & ? & ? & ?) | (? & ? & ?)]]; eauto. -Qed. *) + intros TR; unfold trans_alt in TR; cbn in TR; dependent destruction TR. + - eapply Transbr. + + rewrite H, bind_br; reflexivity. + + rewrite H0; reflexivity. + - eapply Transguard. + + rewrite H, bind_guard; reflexivity. + + rewrite H0; reflexivity. +Qed. -(* Lemma trans_bind_l_τ {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) : - trans_alt τ t u -> - trans_alt τ (t >>= k) (u >>= k). +Lemma trans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) + (e : E Z) (g : Z -> ctree E B X) : + trans_alt (ask e) (Active t) (Passive e g) -> + trans_alt (ask e) (Active (x <- t;; k x)) (Passive e (fun z => x <- g z;; k x)). Proof. - cbn; intros TR. - dependent induction TR; cbn in *. - - rewrite H, bind_br. - apply trans_br with x. - specialize (IHTR t' k u eq_refl eq_refl eq_refl). - now rewrite H0 in IHTR. - - rewrite H, bind_guard. - apply trans_guard. - apply IHTR; auto. - - rewrite H, bind_step. - rewrite H0; apply trans_step. -Qed. *) + intros TR; unfold trans_alt in TR; cbn in TR; dependent destruction TR. + econstructor. + rewrite H, bind_vis; reflexivity. +Qed. -(* Lemma trans_bind_l_ask {E B X Y Z} (t : ctree E B X) (k : X -> ctree E B Y) (e : E Z) (g : Z -> ctree E B X) : - trans_alt (ask e) t (β e g) -> - trans_alt (ask e) (t >>= k) (β e (fun x => g x >>= k)). +Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) + (u : @S E B Y) (x : X) (l : @label E Y) : + trans_alt (val x) (Active t) (Active (Stuck : ctree E B X)) -> + trans_alt l (Active (k x)) u -> + trans_alt l (Active (y <- t;; k y)) u. Proof. - cbn; intros TR. - dependent induction TR; cbn in *. - - rewrite H, bind_br. - apply trans_br with x. - specialize (IHTR Z t' k e g eq_refl eq_refl eq_refl). - now rewrite H0 in IHTR. - - rewrite H, bind_guard. - apply trans_guard. - apply IHTR; auto. - - rewrite H, bind_vis. - apply trans_ask. -Qed. *) + intros TR1 TR2; unfold trans_alt in *; cbn in *; dependent destruction TR1. + assert (SQ : Seq (Active (y <- t;; k y)) (Active (k x))) by + (constructor; now rewrite H, bind_ret_l). + rewrite SQ. exact TR2. +Qed. -(* Lemma trans_bind_r {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) u x l : - trans_alt (val x) t Stuck -> - trans_alt l (k x) u -> - trans_alt l (t >>= k) u. +Lemma trans_bind_inv {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) + (u : @S E B Y) (l : @label E Y) : + trans_alt l (Active (x <- t;; k x)) u -> + (exists x, t ≅ Ret x /\ trans_alt l (Active (k x)) u) + \/ (l = τ /\ exists t', trans_alt τ (Active t) (Active t') + /\ u ⩸ (Active (x <- t';; k x))) + \/ (l = ε /\ exists t', trans_alt ε (Active t) (Active t') + /\ u ⩸ (Active (x <- t';; k x))) + \/ (exists Z (e : E Z) (g : Z -> ctree E B X), + l = ask e /\ trans_alt (ask e) (Active t) (Passive e g) + /\ u ⩸ (Passive e (fun z => x <- g z;; k x))). Proof. - cbn; intros TR1. - dependent induction TR1; cbn in *. - - intros TR2; rewrite H, bind_br. - apply trans_br with x0. - rewrite <- H0; eapply IHTR1; eauto. - - intros TR2; rewrite H, bind_guard. - apply trans_guard. - eapply IHTR1; eauto. - - intros TR2; rewrite H, bind_ret_l; auto. -Qed. *) + intros TR; unfold trans_alt in TR; cbn in TR; dependent destruction TR. + - apply br_equ_bind in H as [(r & EQ1 & EQ2) | (k1 & EQ1 & EQ2)]. + + left; exists r; split; auto; eapply Transbr; eauto. + + right; right; left; split; auto; exists (k1 x); split. + * eapply Transbr; eauto; reflexivity. + * constructor; rewrite H0; apply EQ2. + - apply guard_equ_bind in H as [(r & EQ1 & EQ2) | (t1 & EQ1 & EQ2)]. + + left; exists r; split; auto; eapply Transguard; eauto. + + right; right; left; split; auto; exists t1; split. + * eapply Transguard; eauto; reflexivity. + * constructor; rewrite H0, <- EQ2; reflexivity. + - apply step_equ_bind in H as [(r & EQ1 & EQ2) | (t1 & EQ1 & EQ2)]. + + left; exists r; split; auto; eapply Transstep; eauto. + + right; left; split; auto; exists t1; split. + * eapply Transstep; eauto; reflexivity. + * constructor; rewrite H0, <- EQ2; reflexivity. + - apply vis_equ_bind in H as [(r & EQ1 & EQ2) | (k1 & EQ1 & EQ2)]. + + left; exists r; split; auto; econstructor; eauto. + + right; right; right; exists X0, e, k1; split; auto; split. + * econstructor; eauto. + * constructor; intros a; apply EQ2. + - apply ret_equ_bind in H as (r1 & EQ1 & EQ2). + left; exists r1; split; auto; eapply Transval; eauto. +Qed. -(* Lemma is_stuck_bind : forall {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y), - is_stuck t -> is_stuck (bind t k). +Lemma trans_bind_inv_l {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) + (u : @S E B Y) (l : @label E Y) : + trans_alt l (Active (x <- t;; k x)) u -> + exists (l' : @label E X) (t' : @S E B X), trans_alt l' (Active t) t'. Proof. - repeat intro. - apply trans_bind_inv in H0 as [|[]]. - - destruct H0 as (? & ? & TR & ?). - now apply H in TR. - - destruct H0 as (? & ? & ? & ? & TR & ?). - now apply H in TR. - - destruct H0 as (? & TR & ?). - now apply H in TR. -Qed. *) + intros TR; apply trans_bind_inv in TR as [(y & EQ & _) | [(_ & t' & TR' & _) | [(_ & t' & TR' & _) | (Z & e & g & _ & TR' & _)]]]; eauto. + exists (val y), (Active (Stuck : ctree E B X)); eapply Transval; eauto; reflexivity. +Qed. + +Lemma is_stuck_bind {E B X Y} (t : ctree E B X) (k : X -> ctree E B Y) : + is_stuck (Active t) -> is_stuck (Active (x <- t;; k x)). +Proof. + intros ST l u TR; apply trans_bind_inv in TR as [(y & EQ & _) | [(_ & t' & TR' & _) | [(_ & t' & TR' & _) | (Z & e & g & _ & TR' & _)]]]; try (eapply ST; eauto; fail). + eapply (ST (val y) (Active (Stuck : ctree E B X))); eapply Transval; eauto; reflexivity. +Qed. (*| Forward and backward rules for [wtrans] w.r.t. [bind] From b9cec7599aa8b6c72271fd5e07885190c2be058e Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 10 Jul 2026 11:43:26 +0200 Subject: [PATCH 35/61] Fixed and finished SSimAlt --- theories/Eq/SSimAlt.v | 655 +++++++++++++++++++++++++++--------------- 1 file changed, 421 insertions(+), 234 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index a301ac4..10eaa55 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -49,6 +49,7 @@ Section StrongSimAlt. t ≅ Guard t' -> exists u', epsilon u u' /\ Reps t' u'). *) + Locate dot. Definition ss'_gen {E F B : Type -> Type} {X : Type} (L : rel (@label E X) (@label F X)) @@ -61,9 +62,9 @@ Locate dot. (forall t', trans_alt (B:=B) ε t t' -> exists u', (trans_alt (B:=B) ε)^* u u' /\ Reps t' u'). #[global] Instance weq_ss'_gen {E F B X} : - Proper (weq ==> eq ==> weq) (@ss'_gen E F B X). + Proper (weq ==> weq) (@ss'_gen E F B X). Proof. - cbn. intros L L' HL R ? <- x y; split; intros (HA & HB); split; intros. + cbn. intros L L' HL R x y; split; intros (HA & HB); split; intros. - destruct (HA _ _ H H0) as (l'' & u'' & Htrans & HR & HL'). do 2 esplit; split; [eassumption | split; [eassumption |]]; now apply HL. - now apply HB in H. @@ -106,6 +107,24 @@ End StrongSimAlt. Definition ssim' {E F B X} L := (gfp (@ss' E F B X L): hrel _ _). +Program Definition ss {E F B : Type -> Type} {X : Type} + (L : rel (@label E X) (@label F X)) : + mon (@SS E B X -> @SS F B X -> Prop) := + {| body R t u := + forall t' l, l <> ε -> ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t' -> + exists l' u', ((trans_alt (B:=B) ε)^* ⋅ trans_alt l') u u' /\ R t' u' /\ L l l' + |}. +Next Obligation. + destruct (H0 _ _ H1 H2) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + - assumption. + - now apply H. + - assumption. +Qed. + +Definition ssim {E F B X} L := (gfp (@ss E F B X L) : hrel _ _). + + (* todo: remove this and rewrite using simple proper instances *) Variant Seq_clos_body {E F B X} (R : rel (@S E B X) (@S F B X)) : rel (@S E B X) (@S F B X) := | Seq_clos_intro : forall t t' u' u (Seqt : t ⩸ t') @@ -233,7 +252,22 @@ Ltac __step_in_ssim' H := step in H; fold (@ssim' E F B X L) in H end. +(* goal: elem x y wtp b x y + +step: + +gfp b <= b (elem) <= elem + +H: gfp b x y +goal: +b (elem) x y +elem <- b elem <- gfp b <-> b (gfp b) + +unstep: +b gfp -> gfp + +*) Tactic Notation "step" "in" ident(H) := __step_in_ssim' H || step in H. Tactic Notation "__coinduction_ssim'" simple_intropattern(r) simple_intropattern(cih) := @@ -460,12 +494,20 @@ Section Proof_Rules. apply H; eexists; eassumption. Qed. + Lemma estar_single' {G : Type -> Type} : + (@trans_alt G B X ε) ≦ (trans_alt ε)^*. + Proof. + ka. + Qed. + Lemma estar_single {G : Type -> Type} (a b : @S G B X) : trans_alt ε a b -> (trans_alt ε)^* a b. Proof. - intro S; eapply estar_cons0; [ exact S | apply trans_star_self ]. + apply estar_single'. Qed. + + Lemma estar_cons {G : Type -> Type} (a b c : @S G B X) l : trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> ((trans_alt ε)^* ⋅ trans_alt l) a c. @@ -782,7 +824,8 @@ Lemma ssim'_epsilon_l {E F B X} {L} : ssim' L t' u. Proof. intros. step. eapply ss'_gen_epsilon_l. - - apply (gfp_pfp (ss' L)). + (* blessed postfixpoint *) + - exact (gfp_pfp (ss' L)). - step in H. apply H. - apply H0. Qed. @@ -824,18 +867,20 @@ Definition epsilon_det_ctx {E B X} (R : ctree E B X -> Prop) Section upto. - Context {E F C D: Type -> Type} {X Y: Type} - (L : hrel (@label E) (@label F)). + Context {E F B : Type -> Type} {X : Type} + (L : rel (@label E X) (@label F X)). (* Up-to epsilon *) - Program Definition epsilon_ctx_r : mon (rel (ctree E B X) (ctree F B X)) - := {| body R t u := epsilon_ctx (fun u => R t u) u |}. + #[local] Obligation Tactic := idtac. + Program Definition epsilon_ctx_r : mon (rel (@S E B X) (@S F B X)) + := {| body R t u := exists u', (trans_alt ε)^* u u' /\ R t u' |}. Next Obligation. - destruct H0 as (? & ? & ?). red. eauto. + intros R R' HR t u (u' & STAR & HRtu). + exists u'; split; [ exact STAR | now apply HR ]. Qed. - Lemma epsilon_ctx_r_sst' {c: Chain (ss' L)}: + Lemma epsilon_ctx_r_sst' {c: Chain (@ss' E F B X L)}: forall x y, epsilon_ctx_r `c x y -> `c x y. Proof. apply tower. @@ -845,269 +890,411 @@ Section upto. apply leq_infx in H1. now apply H1. - clear. - intros R IH t u (u' & Heps & (HA & HB & HC)). - ssplit. - + intros HP l t' TR. - eapply HA in TR as (l'' & u'' & TR' & ? & ?); auto. - do 2 eexists; ssplit. - eapply epsilon_trans; eauto. - all: auto. - + intros * EQ ?. - eapply HB in EQ as (? & ? & ?). - eexists; split; [| eauto]. - etransitivity; eauto. - + intros * EQ. - eapply HC in EQ as (? & ? & ?). - eexists; split; [| eauto]. - etransitivity; eauto. + intros R IH t u (u' & STAR & HSS). + eapply step_ss'_epsilon_r; [ exact HSS | exact STAR ]. Qed. - (* Up-to ss. *) - (* This principle holds because an ss step always corresponds - to one or more ss' steps. *) - Lemma ss_sst' {c : Chain (ss' L)} : - forall x y, @ss E F C D X Y L ` c x y -> `c x y. + Lemma ss_sst' {c : Chain (@ss' E F B X L)} : + forall x y, ss L `c x y -> `c x y. Proof. apply tower. - - intros ? INC x y HSS ??; red. + - intros ? INC x y HSS ? ?; red. apply INC; auto. - intros ?? TR; apply HSS in TR as (?& ?& ? &? &?). - do 2 eexists; ssplit; eauto. - apply leq_infx in H. - now apply H. - - clear. - intros R IH t u HSS. - ssplit. - + intros HP l t' TR. - apply HSS in TR as (l'' & u'' & TR' & ? & ?). - do 2 eexists; ssplit; eauto. - now apply (b_chain R). - + intros * EQ ?. - eexists; split; eauto. - apply IH. - intros ?? TR. - edestruct HSS as (l'' & u'' & TR' & ? & ?). - rewrite EQ; econstructor; apply TR. - do 2 eexists; ssplit; eauto. - now apply (b_chain R). - + intros * EQ. - eexists; split; eauto. - apply IH. - intros ?? TR. - edestruct HSS as (l'' & u'' & TR' & ? & ?). - rewrite EQ; econstructor; apply TR. - do 2 eexists; ssplit; eauto. - now apply (b_chain R). + intros t' l Hne TR. + destruct (HSS _ _ Hne TR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + + assumption. + + apply leq_infx in H; now apply H. + + assumption. + - clear; intros R IH t u HSS; split. + + intros t' l Hne TR. + assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t') + by (apply trans_star_l; exact TR). + destruct (HSS _ _ Hne cTR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + * assumption. + * now apply (b_chain R). + * assumption. + + intros t' TR. + exists u; split. + * apply trans_star_self. + * apply IH; intros t'' l Hne cTR. + assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') + by (eapply estar_cons; [exact TR | exact cTR]). + destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + -- assumption. + -- now apply (b_chain R). + -- assumption. Qed. End upto. + Arguments ss_sst' {E F B X} L. -(*| -Up-to [bind] context simulations ----------------------------------- -We have proved in the module [Equ] that up-to bind context is -a valid enhancement to prove [equ]. -We now prove the same result, but for strong simulation. -|*) +Lemma ss_ss'_chain {E F B X} {L : rel (@label E X) (@label F X)} + {R : Chain (@ss' E F B X L)} : + forall (t : @SS E B X) (u : @SS F B X), + ss L `R t u -> ss' L `R t u. +Proof. + intros t u HSS; split. + - intros t' l Hne TR. + assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t') + by (apply trans_star_l; exact TR). + destruct (HSS _ _ Hne cTR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit; assumption. + - intros t' TR. + exists u; split. + + apply trans_star_self. + + apply ss_sst'; intros t'' l Hne cTR. + assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') + by (eapply estar_cons; [exact TR | exact cTR]). + destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit; assumption. +Qed. -Section bind. - Arguments label: clear implicits. - Obligation Tactic := idtac. +Theorem ssim_ssim' {E F B X} (L : rel (@label E X) (@label F X)) : + forall (t : @SS E B X) (u : @SS F B X), ssim L t u <-> ssim' L t u. +Proof. + split; intro H. + - revert t u H; unfold ssim'; coinduction R CH; intros t u H. + apply ss_ss'_chain. + intros t' l Hne TR. + step in H. + destruct (H _ _ Hne TR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + + assumption. + + apply CH, HR. + + assumption. + - revert t u H; unfold ssim; coinduction R CH; intros t u H. + intros t' l Hne TR. + destruct TR as [m STAR STEP]. + eapply ssim'_epsilon_l in H; [| exact STAR]. + step in H. + destruct H as (Hchal & _). + destruct (Hchal _ _ Hne STEP) as (l' & u' & RESP & Hgfp & HL). + exists l', u'; ssplit. + + assumption. + + apply CH, Hgfp. + + assumption. +Qed. + +#[local] Example ssim'_spin {E F B X} (L : rel (@label E X) (@label F X)) : + forall (u : @SS F B X), ssim' L (Active (@spin E B X)) u. +Proof. + unfold ssim'; coinduction R CH; intros u. + assert (SQ : (Active (@spin E B X) : @SS E B X) ⩸ (Active (Guard spin))) + by (constructor; apply unfold_spin). + split. + - intros t' l Hne TR. + rewrite SQ in TR. + eapply trans_alt_guard_inv in TR as (-> & _); easy. + Unshelve. exact E. exact F. all: auto. + - intros t' TR. + rewrite SQ in TR. + eapply trans_alt_guard_inv in TR as (_ & EQ). + exists u; split. + + apply trans_star_self. + + rewrite EQ; apply CH. + Unshelve. exact E. exact F. all: auto. +Qed. - Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : hrel (@label E) (@label F)) (R0 : rel X Y). +Variant update_val_rel {E F X X'} + (L : rel (@label E X') (@label F X')) (R0 : rel X X) + : rel (@label E X) (@label F X) := +| uvr_τ : + L τ τ -> + update_val_rel L R0 τ τ +| uvr_ask {Z Z'} (e : E Z) (f : F Z') : + L (ask e) (ask f) -> + update_val_rel L R0 (ask e) (ask f) +| uvr_rcv {Z Z'} (e : E Z) (v : Z) (f : F Z') (w : Z') : + L (rcv e v) (rcv f w) -> + update_val_rel L R0 (rcv e v) (rcv f w) +| uvr_val (v w : X) : + R0 v w -> + update_val_rel L R0 (val v) (val w). + +Section uvr_inv. + + Context {E F : Type -> Type} {X X' : Type} + {L : rel (@label E X') (@label F X')} {R0 : rel X X}. + + Lemma update_val_rel_val_l (v : X) (l2 : @label F X) : + update_val_rel L R0 (val v) l2 -> + exists w, l2 = val w /\ R0 v w. + Proof. + intros H; dependent destruction H; eauto. + Qed. -(*| - The resulting enhancing function gives a valid up-to technique -|*) + Lemma update_val_rel_τ_l (l2 : @label F X) : + update_val_rel L R0 τ l2 -> + l2 = τ /\ L τ τ. + Proof. + intros H; dependent destruction H; eauto. + Qed. - Lemma bind_chain_gen L0 - (ISVR : is_update_val_rel L R0 L0) - {R : Chain (@ss' E F C D X' Y' L)} : - forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : Y -> ctree F B X'), - ssim L0 t t' -> - (forall x x', R0 x x' -> elem R (k x) (k' x')) -> - ` R (bind t k) (bind t' k'). + Lemma update_val_rel_ask_l {Z} (e : E Z) (l2 : @label F X) : + update_val_rel L R0 (ask e) l2 -> + exists Z' (f : F Z'), l2 = ask f /\ L (ask e) (ask f). Proof. - apply tower. - - intros ? INC ? ? ? ? tt' kk' ? ?. - apply INC. apply H. apply tt'. - intros x x' xx'. apply leq_infx in H. apply H. now apply kk'. - - clear R; intros R IH ? ? ? ? tt kk. - step in tt. ssplit. - + simpl; intros PROD l u STEP. - apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | (v & STEPres & STEP)]. - apply tt in STEP as (l' & u' & STEP & EQ' & ?). - do 2 eexists. ssplit. - apply trans_bind_l; eauto. - * intro Hl. destruct Hl. - apply ISVR in H0; etrans. - inversion H0; subst. apply H. constructor. apply H2. - constructor. - * rewrite EQ; apply IH. - eauto. - intros. - apply (b_chain R); auto. - * apply ISVR in H0; etrans. - destruct H0. exfalso. apply H. constructor. apply H2. - * assert (t ≅ Ret v). - { apply productive_bind in PROD. apply trans_val_epsilon in STEPres as [? _]. - now apply productive_epsilon. } subs. - apply tt in STEPres as (l' & u' & STEPres & EQ' & ?). - apply ISVR in H; etrans. - dependent destruction H. 2: { exfalso. apply H. constructor. } - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk v v2 H). - rewrite bind_ret_l in PROD. - apply kk in STEP as (? & u''' & STEP & EQ'' & ?); auto. - do 2 eexists; split. - eapply trans_bind_r; eauto. - split; auto. - + intros * EQ ?. - apply br_equ_bind in EQ as EQ'. - destruct EQ' as [(v & EQ' & EQ'') | (?k0 & EQ' & EQ'')]. - * subs. - edestruct tt as (l & t'' & STEPres & _ & ?). etrans. - apply ISVR in H; etrans. - apply update_val_rel_val_l in H as (v' & -> & EQ'). - rewrite bind_ret_l in EQ. - specialize (kk v v' EQ'). - apply kk with (x := x) in EQ. destruct EQ as (u' & EPS & EQ). - exists u'. - apply trans_val_epsilon in STEPres as [? _]. split; eauto. - eapply epsilon_bind; eassumption. - * subs. eexists. split; [now constructor |]. - rewrite EQ''. - apply IH. - eapply ssim_br_l_inv. step. apply tt. - intros. - apply (b_chain R); eauto. - + intros * EQ. - apply guard_equ_bind in EQ as EQ'. - destruct EQ' as [(v & EQ' & EQ'') | (?k0 & EQ' & EQ'')]. - * subs. - edestruct tt as (l & t'' & STEPres & _ & ?). etrans. - apply ISVR in H; etrans. - apply update_val_rel_val_l in H as (v' & -> & EQ'). - rewrite bind_ret_l in EQ. - specialize (kk v v' EQ'). - apply kk in EQ. destruct EQ as (u' & EPS & EQ). - exists u'. - apply trans_val_epsilon in STEPres as [? _]. split; eauto. - eapply epsilon_bind; eassumption. - * subs. eexists. split; [now constructor |]. - rewrite <- EQ''. - apply IH. - eapply ssim_guard_l_inv. step. apply tt. - intros. - apply (b_chain R); eauto. + intros H; dependent destruction H; eauto. + Qed. + + Lemma update_val_rel_rcv_l {Z} (e : E Z) (v : Z) (l2 : @label F X) : + update_val_rel L R0 (rcv e v) l2 -> + exists Z' (f : F Z') (w : Z'), l2 = rcv f w /\ L (rcv e v) (rcv f w). + Proof. + intros H; dependent destruction H; eauto. Qed. -End bind. +End uvr_inv. -(*| -Expliciting the reasoning rule provided by the up-to principles. -|*) -Lemma ss'_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) L0 - (HL0 : is_update_val_rel L R0 L0) - (t1 : ctree E B X) (t2: ctree F B X) - (k1 : X -> ctree E B X') (k2 : Y -> ctree F B X'): - ssim L0 t1 t2 -> - (forall x y, R0 x y -> ssim' L (k1 x) (k2 y)) -> - ssim' L (t1 >>= k1) (t2 >>= k2). +Lemma estar_seq {E B X} (a b : @SS E B X) : + a ⩸ b -> (trans_alt ε)^* a b. Proof. - intros. - eapply bind_chain_gen; eauto. + intros H; exists O; exact H. Qed. -Lemma ss'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) - {R : Chain (@ss' E F C D X' Y' L)} : - forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : Y -> ctree F B X'), - t (≲update_val_rel L R0) t' -> - (forall x x', R0 x x' -> elem R (k x) (k' x')) -> - ` R (bind t k) (bind t' k'). +Lemma estar_passive {E B X Z} (e : E Z) (g : Z -> ctree E B X) (m : @SS E B X) : + (trans_alt ε)^* (Passive e g) m -> + (Passive e g : @SS E B X) ⩸ m. Proof. - intros. - eapply bind_chain_gen; eauto using update_val_rel_correct. + intros [n STAR]; destruct n. + - exact STAR. + - destruct STAR as [mid STEP _]. + apply trans_passive_inv' in STEP as (z & _ & Habs); easy. Qed. -Lemma ssim'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) - (t1 : ctree E B X) (t2: ctree F B X) - (k1 : X -> ctree E B X') (k2 : Y -> ctree F B X'): - t1 (≲update_val_rel L R0) t2 -> - (forall x y, R0 x y -> ssim' L (k1 x) (k2 y)) -> - ssim' L (t1 >>= k1) (t2 >>= k2). +Lemma estar_bind {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) : + (trans_alt ε)^* (Active t) (Active u) -> + (trans_alt ε)^* (Active (x <- t;; k x)) (Active (x <- u;; k x)). Proof. - intros. eapply ss'_clo_bind; eauto. + intros [n STAR]; revert t STAR; induction n; intros t STAR. + - cbn in STAR; dependent destruction STAR. + apply estar_seq; constructor. + now rewrite EQ. + - destruct STAR as [mid STEP REST]. + unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. + + eapply estar_cons0. + * apply trans_bind_l_ε; eapply Transbr; eauto. + * apply IHn; exact REST. + + eapply estar_cons0. + * apply trans_bind_l_ε; eapply Transguard; eauto. + * apply IHn; exact REST. Qed. -Lemma ss'_clo_bind_eq {E C D: Type -> Type} {X X': Type} - {R : Chain (@ss' E E C D X' X' eq)} : - forall (t : ctree E B X) (t' : ctree E D X) (k : X -> ctree E B X') (k' : X -> ctree E D X'), - t ≲ t' -> - (forall x, elem R (k x) (k' x)) -> - ` R (bind t k) (bind t' k'). +Lemma ssim_eps_l {E F B X} (L : rel (@label E X) (@label F X)) + (t t1 : @SS E B X) (u : @SS F B X) : + ssim L t u -> trans_alt ε t t1 -> ssim L t1 u. Proof. - intros. - eapply bind_chain_gen; eauto. - - apply update_val_rel_eq. - - intros; subst. apply H0. + intros H TR. + unfold ssim in *. + step in H. + apply (b_chain (chain_gfp (ss L))). + intros t' l Hne cTR. + destruct cTR as [m STAR STEP]. + assert (cTR2 : ((trans_alt ε)^* ⋅ trans_alt l) t t'). + { exists m. + - eapply estar_cons0; [exact TR | exact STAR]. + - exact STEP. } + destruct (H _ _ Hne cTR2) as (l' & u' & RESP & HR & HL). + exists l', u'; ssplit; assumption. Qed. -Lemma ssim'_clo_bind_eq {E C D: Type -> Type} {X X': Type} - (t1 : ctree E B X) (t2: ctree E D X) - (k1 : X -> ctree E B X') (k2 : X -> ctree E D X'): - t1 ≲ t2 -> - (forall x, ssim' eq (k1 x) (k2 x)) -> - ssim' eq (t1 >>= k1) (t2 >>= k2). +Section bind_restore. + + Context {E F B : Type -> Type} {X X' : Type} + (L : rel (@label E X') (@label F X')) + (R0 : rel X X). + + Notation uvr := (update_val_rel L R0). + + Lemma bind_chain_gen {R : Chain (@ss' E F B X' L)} : + forall (t : ctree E B X) (t' : ctree F B X) + (k : X -> ctree E B X') (k' : X -> ctree F B X'), + ssim uvr (Active t) (Active t') -> + (forall x x', R0 x x' -> ssim' L (Active (k x)) (Active (k' x'))) -> + ` R (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + Proof. + apply tower. + - intros ? INC t t' k k' tt kk ? ?; red. + apply INC; auto. + - clear; intros R IH t t' k k' tt kk. + split. + + intros s l Hne TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (Heps & _) + | (Z & e & g & -> & TRt & SQ) ]]]. + * assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val x)) + (Active t) (Active (Stuck : ctree E B X))). + { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } + step in tt. + assert (HneV : (val x : @label E X) <> ε) by discriminate. + destruct (tt _ _ HneV cV) as (l2 & n & RESP & _ & HL2). + apply update_val_rel_val_l in HL2 as (x' & -> & Hx). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. + specialize (kk x x' Hx). + step in kk; destruct kk as (kkA & _). + destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hgfp & HL'). + exists l', u'; ssplit. + -- destruct RESP2 as [m2 STAR2 STEP2]. + exists m2; [| exact STEP2]. + eapply estar_trans. + ++ apply estar_bind; exact STAR. + ++ eapply estar_trans; [| exact STAR2]. + apply estar_seq; constructor. + rewrite H, bind_ret_l; reflexivity. + -- apply (gfp_chain R); exact Hgfp. + -- exact HL'. + * assert (cT : ((trans_alt ε)^* ⋅ trans_alt τ) (Active t) (Active t1)) + by (apply trans_star_l; exact TRt). + step in tt. + assert (Hneτ : (τ : @label E X) <> ε) by discriminate. + destruct (tt _ _ Hneτ cT) as (l2 & n & RESP & Htt' & HL2). + apply update_val_rel_τ_l in HL2 as (-> & HLττ). + destruct RESP as [m STAR STEPτ]. + unfold trans_alt in STEPτ; cbn in STEPτ; dependent destruction STEPτ. + exists τ, (Active (x <- u;; k' x)); ssplit. + -- exists (Active (x <- t0;; k' x)). + ++ apply estar_bind; exact STAR. + ++ apply trans_bind_l_τ; eapply Transstep; eauto. + -- rewrite SQ; apply IH; [exact Htt' | exact kk]. + -- exact HLττ. + * easy. + (* a short trip is needed: active -> passive -> active + via ask/rcv. not hard but a bit tedious. if this + logic appears again it should be factored out into a lemma. *) + * assert (cA : ((trans_alt ε)^* ⋅ trans_alt (ask e)) + (Active t) (Passive e g)) + by (apply trans_star_l; exact TRt). + step in tt. + assert (HneA : (ask e : @label E X) <> ε) by discriminate. + destruct (tt _ _ HneA cA) as (l2 & n & RESP & Htt' & HL2). + apply update_val_rel_ask_l in HL2 as (Z' & f & -> & HLaa). + destruct RESP as [m STAR STEPa]. + unfold trans_alt in STEPa; cbn in STEPa; dependent destruction STEPa. + exists (ask f), (Passive f (fun z => x <- k0 z;; k' x)); ssplit. + -- exists (Active (x <- t0;; k' x)). + ++ apply estar_bind; exact STAR. + ++ apply trans_bind_l_ask; econstructor; exact H. + -- rewrite SQ; apply (b_chain R); split. + ++ intros s2 l2 Hne2 TR2. + apply trans_passive_inv' in TR2 as (z & SQ2 & ->). + step in Htt'. + assert (cR : ((trans_alt ε)^* ⋅ trans_alt (rcv e z)) + (Passive e g) (Active (g z))). + { apply trans_star_l; econstructor; reflexivity. } + assert (HneR : (rcv e z : @label E X) <> ε) by discriminate. + destruct (Htt' _ _ HneR cR) as (l3 & n3 & RESP3 & Htt2 & HL3). + apply update_val_rel_rcv_l in HL3 as (Z2 & f2 & w & -> & HLrr). + destruct RESP3 as [m3 STAR3 STEP3]. + apply estar_passive in STAR3. + dependent destruction STAR3. + apply trans_passive_inv' in STEP3 as (w' & SQ3 & Heq). + dependent destruction Heq. + dependent destruction SQ3. + exists (rcv f w'), (Active (x <- k0 w';; k' x)); ssplit. + ** apply trans_star_l; econstructor; reflexivity. + ** rewrite SQ2. + assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') + ⩸ (Active (x <- k0 w';; k' x))). + { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } + rewrite <- SQ5; apply IH; [exact Htt2 | exact kk]. + ** exact HLrr. + ++ intros s2 TR2. + apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. + -- exact HLaa. + + intros s TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & e & g & Habs & _) ]]]. + * assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val x)) + (Active t) (Active (Stuck : ctree E B X))). + { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } + step in tt. + assert (HneV : (val x : @label E X) <> ε) by discriminate. + destruct (tt _ _ HneV cV) as (l2 & n & RESP & _ & HL2). + apply update_val_rel_val_l in HL2 as (x' & -> & Hx). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. + specialize (kk x x' Hx). + step in kk; destruct kk as (_ & kkB). + destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). + exists u2; split. + -- eapply estar_trans. + ++ apply estar_bind; exact STAR. + ++ eapply estar_trans; [| exact STARu]. + apply estar_seq; constructor. + rewrite H, bind_ret_l; reflexivity. + -- apply (gfp_chain R); exact Hgfp2. + * easy. + * exists (Active (x <- t';; k' x)); split. + -- apply trans_star_self. + -- rewrite SQ; apply IH; [| exact kk]. + eapply ssim_eps_l; [exact tt | exact TRt]. + * easy. + Qed. + + Lemma ssim'_clo_bind : + forall (t : ctree E B X) (t' : ctree F B X) + (k : X -> ctree E B X') (k' : X -> ctree F B X'), + ssim uvr (Active t) (Active t') -> + (forall x x', R0 x x' -> ssim' L (Active (k x)) (Active (k' x'))) -> + ssim' L (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + Proof. + intros t t' k k' tt kk. + apply (@bind_chain_gen (chain_gfp (ss' L))); assumption. + Qed. + +End bind_restore. + +Lemma update_val_rel_eq_refl {E X X'} : + forall (l : @label E X), + l <> ε -> @update_val_rel E E X X' eq eq l l. Proof. - apply ss'_clo_bind_eq. + destruct l; intro Hne. + all: easy || now constructor. Qed. -Lemma ss_ss'_chain {E F B X L} {R : Chain (ss' L)} : - forall (t : ctree E B X) (u : ctree F B X), - ss L `R t u -> - ss' L `R t u. +Lemma ssim_update_val_rel_eq {E B X X'} : + forall (t u : @SS E B X), + ssim eq t u -> ssim (@update_val_rel E E X X' eq eq) t u. Proof. - - intros. - ssplit; intros. - + apply H in H1 as (? & ? & ? & ? & ?). eauto 6. - + subs. apply ss_br_l_inv with (x := x) in H. - apply ss_sst' in H. eauto. - + subs. apply ss_guard_l_inv in H. apply ss_sst' in H. - eauto. + unfold ssim at 2; coinduction R CH; intros t u H. + intros t' l Hne TR. + step in H. + destruct (H _ _ Hne TR) as (l' & u' & RESP & HR & HL). + exists l', u'; ssplit. + - assumption. + - apply CH, HR. + - subst l'; apply update_val_rel_eq_refl; assumption. Qed. -(* This alternative notion of simulation is equivalent to [ssim] *) -Theorem ssim_ssim' {E F B X} : - forall L (t : ctree E B X) (t' : ctree F B X), ssim L t t' <-> ssim' L t t'. +Lemma ss'_clo_bind_eq {E B X X'} {R : Chain (@ss' E E B X' eq)} : + forall (t t' : ctree E B X) (k k' : X -> ctree E B X'), + ssim eq (Active t) (Active t') -> + (forall x, ssim' eq (Active (k x)) (Active (k' x))) -> + ` R (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. - split; intros. - - red. revert t t' H. coinduction R CH. intros. - ssplit; intros. - + step in H. apply H in H1 as (? & ? & ? & ? & ?). eauto 6. - + subs. apply ssim_br_l_inv with (x := x) in H. eauto. - + subs. apply ssim_guard_l_inv in H. eauto. - - revert t t' H. coinduction R CH. - intros * HSS ?? TR. - apply trans_epsilon in TR as (? & ? & ? & ?). - apply ssim'_epsilon_l with (t' := x) in HSS; auto. - step in HSS. apply (proj1 HSS) in H1 as (? & ? & ? & ? & ?); auto. - eauto 6. + intros t t' k k' tt kk. + apply bind_chain_gen with (R0 := eq). + - apply ssim_update_val_rel_eq; exact tt. + - intros x x' ->; apply kk. Qed. -#[local] Example ssim'_spin {E B X} : forall (t : ctree E B X), (spin : ctree E B X) ≲ t. +Lemma ssim'_clo_bind_eq {E B X X'} : + forall (t t' : ctree E B X) (k k' : X -> ctree E B X'), + ssim eq (Active t) (Active t') -> + (forall x, ssim' eq (Active (k x)) (Active (k' x))) -> + ssim' eq (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. - intros. - apply ssim_ssim'. - coinduction R CH. - rewrite unfold_spin. - apply step_ss'_guard_l. - apply CH. + intros t t' k k' tt kk. + apply (@ss'_clo_bind_eq E B X X' (chain_gfp (ss' eq))); assumption. Qed. From 9fb0cf6ed8f310ed5edf4b1d212efbd426e5ca64 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 10 Jul 2026 11:43:43 +0200 Subject: [PATCH 36/61] Fixed Pure.v --- theories/Misc/Pure.v | 100 +++++++++++++++++++++++++++++-------------- 1 file changed, 68 insertions(+), 32 deletions(-) diff --git a/theories/Misc/Pure.v b/theories/Misc/Pure.v index 8bcee8b..fafa08e 100644 --- a/theories/Misc/Pure.v +++ b/theories/Misc/Pure.v @@ -84,23 +84,28 @@ Section pure. - apply IHepsilon_. rewrite <- ctree_eta. eapply pure_guard_inv. apply H. Qed. - Lemma trans_pure_is_val (t t' : ctree E C X) l : + (* issue: active/passive makes this annoying, though it is a logical non-issue *) + Lemma trans_pure_is_val (t : ctree E C X) (st : @Trans.S E C X) l : pure t -> - trans l t t' -> + trans l t st -> is_val l. - Proof. - intros. do 3 red in H0. genobs t ot. genobs t' ot'. - assert (t ≅ go ot). { now rewrite Heqot, <- ctree_eta. } clear Heqot. - revert t H H1. induction H0; intros; subst. - - apply IHtrans_ with (t := k x); auto. 2: apply ctree_eta. - rewrite H1 in H. step in H. inversion H; inv_equ. - rewrite EQ0. apply REC. - - apply IHtrans_ with t; eauto. 2: apply ctree_eta. - rewrite H1 in H; step in H; inversion H; inv_equ. - rewrite EQ. apply REC. - - rewrite H1 in H0. step in H0. inversion H0; inv_equ. - - rewrite H1 in H0. step in H0. inversion H0; inv_equ. - - constructor. + Proof. + intros Hp TR. repeat red in TR. + remember (Active t). + generalize dependent t. + induction TR; intros t0 Hp Heqs; inv Heqs. + (* just these 2 cases need to 'thread the purity argument' *) + - eapply IHTR. + all: try reflexivity. + rewrite H in Hp. step in Hp. inversion Hp; inv_equ. rewrite H0, EQ0. + apply REC. + - eapply IHTR. + all: try reflexivity. + rewrite H in Hp. step in Hp. inversion Hp; inv_equ. rewrite EQ. + apply REC. + - rewrite H in Hp. step in Hp; inv Hp; inv_equ. + - rewrite H in Hp. step in Hp; inv Hp; inv_equ. + - constructor. Qed. Lemma trans_bind_pure {Y} (t : ctree E C X) k (u : ctree E C Y) l : @@ -110,7 +115,9 @@ Section pure. Proof. intros. apply trans_bind_inv in H0 as [(? & ? & ? & ?) |]. - now apply trans_pure_is_val in H1. - - apply H0. + - destruct H0 as [[Z [e (Hl & g & Htrans & Hsym)]] | H0]. + + inv Hsym. + + apply H0. Qed. End pure. @@ -232,20 +239,27 @@ Lemma is_stuck_pure : forall {E B X Y} t (k : X -> ctree E B Y), is_stuck (CTree.bind t k). Proof. red. intros. intro. - apply trans_bind_inv in H1 as []. - - destruct H1 as (? & ? & ? & ?). subs. - apply H1. eapply trans_pure_is_val; eauto. - - destruct H1 as (? & ? & ?). now apply H0 in H2. + apply trans_bind_inv in H1 as + [ (-> & t' & TR & _) + | [ (Z & e & -> & g & TR & _) + | (v & TRv & TRk) ]]. + (* discriminate labels; they should be val since t is pure *) + - apply trans_pure_is_val in TR; [inv TR | exact H]. + - apply trans_pure_is_val in TR; [inv TR | exact H]. + - eapply H0; exact TRk. Qed. (*| + A computation [is_simple] all its transitions are either: - directly returning - or reducing in one step to something of the shape [Guard* (Ret r)] |*) Class is_simple {E C X} (t : ctree E C X) := is_simple' : (forall l t', trans l t t' -> is_val l) \/ - (forall l t', trans l t t' -> exists r, epsilon_det t' (Ret r)). + (forall l t', trans l t t' -> + exists Z (e : E Z) (k : Z -> ctree E C X), + t' ⩸ (β (e) k) /\ forall z, exists r, epsilon_det (k z) (Ret r)). Section is_simple_theory. @@ -281,16 +295,35 @@ Section is_simple_theory. Proof. intros. destruct H. - left. intros. - unfold CTree.map in H0. apply trans_bind_inv in H0 as ?. - destruct H1 as [(? & ? & ? & ?) | (? & ? & ?)]. - + now apply H in H2. - + apply trans_ret_inv in H2 as []. now subst. + unfold CTree.map in H0. + apply trans_bind_inv in H0 as + [ (-> & t1 & TR & _) + | [ (Z & e & -> & g & TR & _) + | (v & TRv & TRk) ]]. + + now apply H in TR. + + now apply H in TR. + + apply trans_ret_inv' in TRk as [? ->]. constructor. - right. intros. - apply trans_bind_inv in H0 as ?. - destruct H1 as [(? & ? & ? & ?) | (? & ? & ?)]. - + apply H in H2 as []. exists (f x0). subs. - eapply Epsilon.epsilon_det_bind_ret_l. apply H2. reflexivity. - + apply H in H1 as []. inv H1; inv_equ. + unfold CTree.map in H0. + apply trans_bind_inv in H0 as + [ (-> & t1 & TR & SQ) + | [ (Z & e & -> & g & TR & SQ) + | (v & TRv & TRk) ]]. + + apply H in TR as (Z0 & e0 & k0 & SQ0 & _). + inv SQ0. + + apply H in TR as (Z0 & e0 & k0 & SQ0 & DET). + dependent destruction SQ0. + exists Z0, e0, (fun z => CTree.map f (g z)); split. + * exact SQ. + * intros z. + destruct (DET z) as (r & Hdet). + exists (f r). + rewrite (EQ z). + eapply Epsilon.epsilon_det_bind_ret_l. + -- apply Hdet. + -- reflexivity. + + apply H in TRv as (Z0 & e0 & k0 & SQ0 & _). + inv SQ0. Qed. #[global] Instance is_simple_liftState {St} : @@ -305,8 +338,11 @@ Section is_simple_theory. is_simple (CTree.trigger e : ctree E C X). Proof. right. intros. - unfold CTree.trigger in H. inv_trans. subst. - exists x. now left. + unfold CTree.trigger in H. + apply trans_vis_inv' in H as [SQ ->]. + exists X, e, (fun x => Ret x); split. + - exact SQ. + - intros z. exists z. now left. Qed. Lemma is_simple_br_inv : forall {Y} (c: C X) (k : X -> ctree E C Y) x, From 7b8ff8083a3ca3b8dd0657e1e2fd33683e244811 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 10 Jul 2026 11:43:50 +0200 Subject: [PATCH 37/61] Added monauto for experiements --- theories/Utils/coinduction_addon.v | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/theories/Utils/coinduction_addon.v b/theories/Utils/coinduction_addon.v index 1402c24..583bda1 100644 --- a/theories/Utils/coinduction_addon.v +++ b/theories/Utils/coinduction_addon.v @@ -32,3 +32,26 @@ match type of h with end. Tactic Notation "unstep" "in" ident(h) := unstep_in h. + +Ltac apply_leq := match goal with + | [H : _ <= _ |- _]=> intros; apply H + | [H : leq _ _ |- _]=> intros; apply H +end. + +(* nonlinear pattern works here *) +Ltac induct_on_premise := match goal with +| H: context [?rel _] |- context [?rel ] => induction H +end. + + +Ltac monauto := (solve [ +(* break `Proper`, introduce names and premises` *) +cbv; +intros; +(* find hypothesis matching goal and proceed by cases *) +solve [induct_on_premise; +(* break down each case as necessary. `solve` will backtrack in a helpful way. *) +try econstructor; +(* use monotonicity fact itself: [sim] <= [sim'] *) +try apply_leq; +eauto]] || fail "`monauto` could not solve this goal."). From a7a1232309b26eab8355892a6b69430ffed15511 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 10 Jul 2026 14:11:34 +0200 Subject: [PATCH 38/61] Moved some items, added tower induction --- theories/Eq/SSimAlt.v | 3 --- theories/Utils/coinduction_addon.v | 22 ++++++++++++++++++++++ 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 10eaa55..36708a6 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -24,9 +24,6 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. -(* TODO: Decide where to set this *) -Arguments trans_alt : simpl never. - Ltac ssplit := split; [| split]. Section StrongSimAlt. diff --git a/theories/Utils/coinduction_addon.v b/theories/Utils/coinduction_addon.v index 583bda1..657629e 100644 --- a/theories/Utils/coinduction_addon.v +++ b/theories/Utils/coinduction_addon.v @@ -55,3 +55,25 @@ try econstructor; (* use monotonicity fact itself: [sim] <= [sim'] *) try apply_leq; eauto]] || fail "`monauto` could not solve this goal."). + + +(* inf_closed automation *) +Ltac inf_closed_forall_auto := + repeat (apply inf_closed_all; intro). + +Ltac inf_closed_impl_auto := + repeat (apply inf_closed_impl; [repeat intro; apply_leq; firstorder|]). + +Ltac inf_closed_final_auto := + solve [repeat intro; try solve [firstorder]; try apply_leq ; firstorder]. + +Ltac inf_closed_auto := + repeat (inf_closed_forall_auto || inf_closed_impl_auto || inf_closed_final_auto). + +(* tower induction always leaves the goal with the form `forall _ : Chain, ...` ; + match on this type and clear the old Chain *) +Ltac clear_old_chain := match goal with + | c : ?T |- forall _ : ?T, _ => clear c; intro c end. + +Ltac tower_induction := apply tower; [inf_closed_auto|clear_old_chain]. +Tactic Notation "tower" "induction" := tower_induction. From f0ad07e3a24c52e739b0033d6d1ed652bbb32a15 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 10 Jul 2026 14:11:43 +0200 Subject: [PATCH 39/61] SBisimAlt for review. --- theories/Eq/SBisimAlt.v | 2145 +++++++++++++++++++++++---------------- 1 file changed, 1272 insertions(+), 873 deletions(-) diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 363a253..e545a7e 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -13,7 +13,8 @@ From ITree Require Import Core.Subevent. From CTree Require Import CTree Utils - Eq + Eq.Equ + Eq.TransAlt Eq.Epsilon Eq.SSimAlt Misc.Pure. @@ -25,25 +26,23 @@ Import CoindNotations. Import CTree. Set Implicit Arguments. -(* TODO: Decide where to set this *) -Arguments trans : simpl never. - Section StrongBisimAlt. (*| An alternative definition [sb'] of strong bisimulation. The simulation challenge does not involve an inductive transition relation, thus simplifying proofs. |*) - Program Definition sb' {E F C D : Type -> Type} {X Y : Type} - (L : rel (@label E) (@label F)) : - mon (bool -> ctree E C X -> ctree F D Y -> Prop) := + Program Definition sb' {E F B : Type -> Type} {X : Type} + (L : rel (@label E X) (@label F X)) + : mon (bool -> SS -> SS -> Prop) + := {| body R side t u := - (side = true -> ss'_gen L (fun t u => forall side, R side t u) (R true) t u) /\ + (side = true -> @ss'_gen E F B X L (fun t u => forall side, R side t u) (R true) t u) /\ (side = false -> ss'_gen (flip L) (fun u t => forall side, R side t u) (flip (R false)) u t) |}. Next Obligation. - split; intro; subst; [specialize (H0 eq_refl); clear H1 | specialize (H1 eq_refl); clear H0]. - all: eapply ss'_gen_mon; try eassumption; eauto. + split; intro; subst; [specialize (H0 eq_refl); clear H1 | specialize (H1 eq_refl); clear H0]. + all: eapply ss'_gen_mon; try eassumption; eauto. all: cbn; intuition. Qed. @@ -51,10 +50,10 @@ End StrongBisimAlt. Section Symmetry. - Program Definition sb'l {E F C D X Y} L : - mon (bool -> rel (ctree E C X) (ctree F D Y)) := - {| body R side t u := side = true -> sb' L R side t u |}. - Next Obligation. + Program Definition sb'l {E F B X} L : + mon (bool -> rel SS SS) := + {| body R side t u := side = true -> @sb' E F B X L R side t u |}. + Next Obligation. eapply (Hbody (sb' L)). 2: { specialize (H0 eq_refl). apply H0. } cbn. apply H. @@ -71,7 +70,7 @@ Section Symmetry. #[global] Instance sbisim'_sym {E C X L} : `{Symmetric L} -> - Symmetrical converse_neg (@sb' E E C C X X L) (sb'l L). + Symmetrical converse_neg (@sb' E E C X L) (sb'l L). Proof. intros SYM. assert (HL: L == flip L). { cbn. intuition. } @@ -83,7 +82,7 @@ Section Symmetry. destruct H as [_ ?]. specialize (H eq_refl). apply HL in H. - split; intros; subst; try discriminate. + split; intros; subst; try easy. eapply ss'_gen_mon. 3: now apply H. * cbn. intros. apply H1. * cbn. intros. apply H1. @@ -100,9 +99,9 @@ Section Symmetry. End Symmetry. -Lemma sb'_flip {E F C D X Y L} - side (t: ctree E C X) (u: ctree F D Y) R : - sb' (flip L) (fun b => flip (R (negb b))) (negb side) u t -> +Lemma sb'_flip {E F B X} {L : rel (label E X) (label F X)} + side (t: SS) (u: SS) R : + @sb' F E B X (flip L) (fun b => flip (R (negb b))) (negb side) u t -> sb' L R side t u. Proof. split; intros; subst; destruct H; cbn in H. @@ -120,8 +119,8 @@ Proof. apply H. Qed. -Definition sbisim' {E F C D X Y} L t u := - forall side, gfp (@sb' E F C D X Y L) side t u. +Definition sbisim' {E F B X} L t u := + forall side, gfp (@sb' E F B X L) side t u. Program Definition lift_rel3 {A B} : mon (rel A B) -> mon (bool -> rel A B) := fun f => {| body R side := f (R side) |}. @@ -143,72 +142,66 @@ Qed. Section sbisim'_theory. Arguments label: clear implicits. - Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. + Context {E F B: Type -> Type} {X : Type} + {L: rel (@label E X) (@label F X)}. (*| - Strong bisimulation up-to [equ] is valid + Strong bisimulation up-to [Seq] is valid ---------------------------------------- |*) - #[global] Instance equ_clos3_equ (R : bool -> rel (ctree E C X) (ctree F D Y)) : - Proper (eq ==> equ eq ==> equ eq ==> impl) (lift_rel3 equ_clos R). - Proof. - cbn. intros. destruct H2. - (* Can this be faster? *) - econstructor; subs. 2: subst; eassumption. - now rewrite H0. assumption. - Qed. - - Lemma equ_clos_sb' {c: Chain (@sb' E F C D X Y L)}: - forall b x y, lift_rel3 equ_clos `c b x y -> `c b x y. + Lemma Seq_clos_sb' {c: Chain (@sb' E F B X L)}: + forall b x y, lift_rel3 Seq_clos `c b x y -> `c b x y. Proof. apply tower. - - intros ? INC side x y [x' y' x'' y'' EQ' EQ''] ??. red. + - intros ? INC side x y [t t' u' u EQt HR EQu] ??. red. apply INC; auto. econstructor; eauto. apply leq_infx in H. now apply H. - clear. - intros R IH side x y [x' y' x'' y'' EQ' EQ'']. - split; [destruct EQ'' as [EQ'' _] | destruct EQ'' as [_ EQ'']]; - intros; subst; specialize (EQ'' eq_refl); subs. - + eapply ss'_gen_mon. 3: apply EQ''. - all: auto. - + eapply ss'_gen_mon. 3: apply EQ''. - all: eauto. + intros R IH side x y [t t' u' u EQt HR EQu]. + split; intro; subst. + + destruct HR as [HR _]; specialize (HR eq_refl). + rewrite EQt, <- EQu; exact HR. + + destruct HR as [_ HR]; specialize (HR eq_refl). + rewrite EQt, <- EQu; exact HR. Qed. - #[global] Instance equ_clos_gfp_sb'_goal : forall side, Proper (equ eq ==> equ eq ==> flip impl) (gfp (@sb' E F C D X Y L) side). + #[global] Instance Seq_clos_sb'_chain {c: Chain (@sb' E F B X L)} : + forall side, Proper (Seq ==> Seq ==> iff) (`c side). Proof. - cbn; intros ? ? ? eq1 ? ? eq2 H. - apply equ_clos_sb'; econstructor; eauto. - now symmetry. + split; intros. + - symmetry in H. + apply Seq_clos_sb'; econstructor; eauto. + - symmetry in H0. apply Seq_clos_sb'; econstructor; eauto. Qed. - #[global] Instance equ_clos_gfp_sb'_ctx : forall side, Proper (equ eq ==> equ eq ==> impl) (gfp (@sb' E F C D X Y L) side). + #[global] Instance Seq_clos_st'_ctx4 {c: Chain (@sb' E F B X L)} : + Proper (eq ==> Seq ==> Seq ==> impl) `c. Proof. - cbn; intros ? ? ? eq1 ? ? eq2 H. now subs. + intros ? side -> ? ? eq1 ? ? eq2 H. + now rewrite <- eq1, <- eq2. Qed. - #[global] Instance equ_clos_sbisim'_goal : Proper (equ eq ==> equ eq ==> flip impl) (@sbisim' E F C D X Y L). + #[global] Instance Seq_clos_sb'_gfp : forall side, Proper (Seq ==> Seq ==> iff) (gfp (@sb' E F B X L) side). Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - intro. now subs. + exact (@Seq_clos_sb'_chain (chain_gfp (sb' L))). Qed. - #[global] Instance equ_clos_sbisim'_ctx : Proper (equ eq ==> equ eq ==> impl) (@sbisim' E F C D X Y L). + #[global] Instance Seq_clos_sbisim' : Proper (Seq ==> Seq ==> iff) (@sbisim' E F B X L). Proof. - cbn; intros ? ? eq1 ? ? eq2 H. now subs. + unfold sbisim'. repeat red; split; intros. + - now rewrite <- H, <- H0. + - now rewrite H, H0. Qed. End sbisim'_theory. -(* TODO check *) Ltac fold_sbisim' := repeat match goal with - | h: context[gfp (@sb' ?E ?F ?C ?D ?X ?Y ?L)] |- _ => try fold (@sbisim' E F C D X Y L) in h - | |- context[gfp (@sb' ?E ?F ?C ?D ?X ?Y ?L)] => try fold (@sbisim' E F C D X Y L) + | h: context[gfp (@sb' ?E ?F ?B ?X ?L)] |- _ => try fold (@sbisim' E F B X L) in h + | |- context[gfp (@sb' ?E ?F ?B ?X ?L)] => try fold (@sbisim' E F B X L) end. Tactic Notation "__coinduction_sbisim'" simple_intropattern(r) simple_intropattern(cih) := @@ -216,7 +209,7 @@ Tactic Notation "__coinduction_sbisim'" simple_intropattern(r) simple_intropatte Tactic Notation "__step_sbisim'" := match goal with - | |- context[@sbisim' ?E ?F ?C ?D ?X ?Y ?LR] => + | |- context[@sbisim' ?E ?F ?B ?X ?LR] => unfold sbisim'; intro; step end. @@ -228,15 +221,15 @@ Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) := Ltac __step_in_sbisim' H := match type of H with - | context[@sbisim' ?E ?F ?C ?D ?X ?Y ?LR] => + | context[@sbisim' ?E ?F ?B ?X ?LR] => unfold sbisim' in H; let Hl := fresh H "l" in let Hr := fresh H "r" in - pose proof (Hl : H true); - pose proof (Hr : H false); + pose proof (H true) as Hl; + pose proof (H false) as Hr; step in Hl; step in Hr; - try fold (@sbisim' E F C D X Y L) in Hl; - try fold (@sbisim' E F C D X Y L) in Hr + try fold (@sbisim' E F B X LR) in Hl; + try fold (@sbisim' E F B X LR) in Hr end. Tactic Notation "step" "in" ident(H) := __step_in_sbisim' H || step in H. @@ -245,21 +238,36 @@ Import CTreeNotations. Import EquNotations. Section sbisim'_homogenous_theory. Context {E B: Type -> Type} {X: Type} - {L: relation (@label E)}. + {L: relation (@label E X)}. - Notation sb' := (@sb' E E B B X X). - Notation sbisim' := (@sbisim' E E B B X X). + Notation sb' := (@sb' E E B X). + Notation sbisim' := (@sbisim' E E B X). #[global] Instance refl_sb' {LR: Reflexive L} {C: Chain (sb' L)} : forall side, Reflexive (`C side). Proof. apply tower. - cbv. firstorder. - - intros R IH ? x. - split; (intros; subst; split; [| split]; intros). - 1,4: eexists _, _; eauto. - 1,3:eexists; split; subs; [| reflexivity]; eapply epsilon_br; eauto. - all:eexists; split; subs; [| reflexivity]; eapply epsilon_guard; eauto. + - intros R IH side x. + split; intros _; split. + + intros t' l Hne TR. + exists l, t'; ssplit. + * apply trans_alt_estar_l; exact TR. + * intro; apply IH. + * apply LR. + + intros t' TR. + exists t'; split. + * apply estar_single; exact TR. + * apply IH. + + intros t' l Hne TR. + exists l, t'; ssplit. + * apply trans_alt_estar_l; exact TR. + * intro; apply IH. + * apply LR. + + intros t' TR. + exists t'; split. + * apply estar_single; exact TR. + * apply IH. Qed. #[global] Instance refl_bsb' {LR: Reflexive L} {C: Chain (sb' L)} @@ -337,61 +345,51 @@ Qed. Section sbisim'_heterogenous_theory. Arguments label: clear implicits. - Context {E F B D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. + Context {E F B: Type -> Type} {X: Type} + {L: rel (@label E X) (@label F X)}. - Notation sb' := (@sb' E F B D X Y). - Notation sbisim' := (@sbisim' E F B D X Y). + Notation sb' := (@sb' E F B X). + Notation sbisim' := (@sbisim' E F B X). - #[global] Instance equ_sb'_goal {RR} : - forall b, Proper (equ eq ==> equ eq ==> flip impl) (sb' L RR b). + #[global] Instance Seq_sb'_goal {RR} : + forall b, Proper (Seq ==> Seq ==> flip impl) (sb' L RR b). Proof. - intros. split; intros; subst. - - subs. now apply H1. - - subs. now apply H1. + intros b x x' eq1 y y' eq2 H. + split; intro; subst. + - destruct H as [H _]; specialize (H eq_refl). + now rewrite eq1, eq2. + - destruct H as [_ H]; specialize (H eq_refl). + now rewrite eq1, eq2. Qed. - #[global] Instance equ_sb'_ctx {RR} : - Proper (eq ==> equ eq ==> equ eq ==> impl) (sb' L RR). + #[global] Instance Seq_sb'_ctx {RR} : + Proper (eq ==> Seq ==> Seq ==> impl) (sb' L RR). Proof. - do 6 red. intros. subst. now rewrite <- H0, <- H1. - Qed. - - #[global] Instance equ_clos_st'_goal {RR} {C : Chain (sb' RR)}: - Proper (eq ==> equ eq ==> equ eq ==> flip impl) `C. - Proof. - cbn; intros ? ? ? ? ? eq1 ? ? eq2 H. subst. - apply equ_clos_sb'; econstructor; [eauto | | symmetry; eauto]; assumption. - Qed. - - #[global] Instance equ_clos_st'_ctx {RR} {C : Chain (sb' RR)}: - Proper (eq ==> equ eq ==> equ eq ==> impl) `C. - Proof. - cbn; intros ? ? ? ? ? eq1 ? ? eq2 H. subst. + intros ? b -> ? ? eq1 ? ? eq2 H. now rewrite <- eq1, <- eq2. Qed. Lemma sb'_true_ss' R : - forall (t : ctree E B X) (u : ctree F D Y), + forall (t : @SS E B X) (u : @SS F B X), sb' L R true t u <-> ss'_gen L (fun t u => forall side, R side t u) (R true) t u. Proof. split; intros. - now apply H. - - split; intros; try discriminate. apply H. + - split; intros; easy. Qed. Lemma sb'_false_ss' R : - forall (t : ctree E B X) (u : ctree F D Y), + forall (t : @SS E B X) (u : @SS F B X), sb' L R false t u <-> ss'_gen (flip L) (fun u t => forall side, R side t u) (flip (R false)) u t. Proof. split; intros. - now apply H. - - split; intros; try discriminate. apply H. + - split; intros; try easy. Qed. Lemma sb'_true_stuck R : - forall (u : ctree F D Y), - sb' L R true Stuck u. + forall (u : @SS F B X), + sb' L R true (Stuck : ctree E B X) u. Proof. intros. apply sb'_true_ss'. apply ss'_stuck. @@ -399,160 +397,200 @@ Section sbisim'_heterogenous_theory. End sbisim'_heterogenous_theory. -Lemma sb'_stuck {E F C D X Y L} R : +Lemma sb'_stuck {E F B X L} R : forall side, - sb' L R side (Stuck : ctree E C X) (Stuck : ctree F D Y). + sb' L R side (Stuck : ctree E B X) (Stuck : ctree F B X). Proof. intros. destruct side. - apply sb'_true_stuck. - apply sb'_flip. cbn -[sb']. apply sb'_true_stuck. Qed. +(*| + The [step_ss'_*] rules from SSimAlt require [Seq]-Properness of the + relations sitting in the answer positions of [ss'_gen]. For [sb'] these + positions are instantiated with [fun t u => forall side, R side t u], + [R true] and [flip (R false)]; the following instances discharge + those side-conditions from a single Properness assumption on [R]. +|*) +#[global] Instance Proper_forall_R {E F B X} + {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} : + Proper (Seq ==> Seq ==> impl) (fun t u => forall side, R side t u). +Proof. + intros ? ? eq1 ? ? eq2 H side; eapply HR; eauto. +Qed. + +#[global] Instance Proper_forall_R_flip {E F B X} + {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} : + Proper (Seq ==> Seq ==> impl) (fun u t => forall side, R side t u). +Proof. + intros ? ? eq1 ? ? eq2 H side; eapply HR; eauto. +Qed. + +#[global] Instance Proper_R_side {E F B X} + {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} side : + Proper (Seq ==> Seq ==> impl) (R side). +Proof. + intros ? ? eq1 ? ? eq2 H; eapply HR; eauto. +Qed. + +#[global] Instance Proper_R_side_flip {E F B X} + {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} side : + Proper (Seq ==> Seq ==> impl) (flip (R side)). +Proof. + intros ? ? eq1 ? ? eq2 H; unfold flip in *; eapply HR; eauto. +Qed. + Section Proof_Rules. Arguments label: clear implicits. - Context {E F C D: Type -> Type} - {X Y: Type} - {L : rel (@label E) (@label F)}. - - Lemma step_sb'_ret : - forall {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} - x y, - L (val x) (val y) -> - (forall side, R side Stuck Stuck) -> - forall side, sb' L R side (Ret x : ctree E C X) (Ret y : ctree F D Y). + Context {E F B: Type -> Type} + {X: Type} + {L : rel (@label E X) (@label F X)}. + + Lemma step_sb'_ret {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + (x : X) (y : X) : + L (val x) (val y) -> + (forall side, R side Stuck Stuck) -> + forall side, sb' L R side (Ret x : ctree E B X) (Ret y : ctree F B X). Proof. - intros R HR x y Rstuck PROP Lval. split; intros; subst. - - unshelve eapply step_ss'_ret; auto. - cbn. intros. rewrite <- H. specialize (H1 side). now subs. - - unshelve eapply step_ss'_ret; auto. - cbn. intros. specialize (H1 side). now subs. + intros Lval Rstuck side; split; intro; subst. + - apply step_ss'_ret; [apply Rstuck | exact Lval]. + - apply step_ss'_ret; [apply Rstuck | exact Lval]. Qed. - Lemma step_sbt'_ret x y {R : Chain (sb' L)} : + Lemma step_sbt'_ret (x y : X) {R : Chain (sb' L)} : L (val x) (val y) -> - forall side, `R side (Ret x : ctree E C X) (Ret y : ctree F D Y). + forall side, `R side (Ret x : ctree E B X) (Ret y : ctree F B X). Proof. - intros. step; apply step_sb'_ret. - - exact H. - - intros. step; apply sb'_stuck. + intros HL side. + apply (b_chain R), step_sb'_ret. + - exact HL. + - intro side'; apply (b_chain R), sb'_stuck. Qed. (*| The vis nodes are deterministic from the perspective of the labeled - transition system, stepping is hence symmetric and we can just recover - the itree-style rule. + transition system: both sides step to the corresponding passive states. |*) - Lemma step_sb'_vis - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} + Lemma step_sb'_vis {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} {Z Z'} (e : E Z) (f: F Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : - (forall x, exists y, (forall side, R side (k x) (k' y)) /\ L (obs e x) (obs f y)) -> - (forall y, exists x, (forall side, R side (k x) (k' y)) /\ L (obs e x) (obs f y)) -> + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : + (forall side, R side (Passive e k) (Passive f k')) -> + L (ask e) (ask f) -> forall side, sb' L R side (Vis e k) (Vis f k'). Proof. - intros. split; intro; subst; unshelve eapply step_ss'_vis; auto. - - cbn. intros. specialize (H3 side). now subs. - - cbn. intros. specialize (H3 side). now subs. + intros HRpas Lask side; split; intro; subst. + - apply step_ss'_vis; [apply HRpas | exact Lask]. + - apply step_ss'_vis; [apply HRpas | exact Lask]. Qed. - Lemma step_sb'_vis_id - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} + Lemma step_sb'_vis_id {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} {Z} (e : E Z) (f: F Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : - (forall x, (forall side, R side (k x) (k' x)) /\ L (obs e x) (obs f x)) -> + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : + (forall side, R side (Passive e k) (Passive f k')) -> + L (ask e) (ask f) -> forall side, sb' L R side (Vis e k) (Vis f k'). Proof. - intros. apply step_sb'_vis; eauto. + intros; now apply step_sb'_vis. Qed. - Lemma step_sb'_vis_l - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} {Z} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y), - (forall x, exists l' u', trans l' u u' /\ (forall side, R side (k x) u') /\ L (obs e x) l') -> + Lemma step_sb'_vis_l {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} {Z} : + forall (e : E Z) (k : Z -> ctree E B X) (u : @SS F B X), + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' + /\ (forall side, R side (Passive e k) u') /\ L (ask e) l') -> sb' L R true (Vis e k) u. Proof. - split; intros; subst; try discriminate. - unshelve eapply step_ss'_vis_l. - - cbn. intros. specialize (H3 side). now subs. - - apply H. + intros e k u (l' & u' & STEP & HRu & Hask). + split; intro; [| easy]. + apply step_ss'_vis_l. + exists l', u'; ssplit. + - exact STEP. + - exact HRu. + - exact Hask. Qed. (*| With this definition [sb'] of bisimulation, delayed nodes allow to perform a coinductive step. |*) - Lemma step_sb'_guard - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} - (t: ctree E C X) (t': ctree F D Y) side : + Lemma step_sb'_guard {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + (t: ctree E B X) (t': ctree F B X) side : R side t t' -> sb' L R side (Guard t) (Guard t'). Proof. - split; intros; subst; apply step_ss'_guard; auto. + intros HRtt'; split; intro; subst; apply step_ss'_guard; exact HRtt'. Qed. Lemma step_sb'_true_guard_l {R : Chain (sb' L)} - (t: ctree E C X) (t': ctree F D Y) : + (t: ctree E B X) (t': @SS F B X) : ` R true t t' -> sb' L `R true (Guard t) t'. Proof. - intros. - split; intros; subst; try discriminate. - now apply step_ss'_guard_l. + intros H; split; intro; [| easy]. + apply step_ss'_guard_l; exact H. Qed. Lemma step_sb'_guard_l {R : Chain (sb' L)} - (t: ctree E C X) (t': ctree F D Y) side : + (t: ctree E B X) (t': @SS F B X) side : sb' L (` R) side t t' -> sb' L `R side (Guard t) t'. Proof. - intros. - split; intros; subst. - - apply step_ss'_guard_l; now step. + intros H; split; intro; subst. + - apply step_ss'_guard_l. + apply (b_chain R); exact H. - apply step_ss'_guard_r; now apply H. Qed. Lemma step_sb'_false_guard_r {R : Chain (sb' L)} - (t: ctree E C X) (t': ctree F D Y) : + (t: @SS E B X) (t': ctree F B X) : ` R false t t' -> sb' L `R false t (Guard t'). Proof. - intros. - split; intros; subst; try discriminate. - now apply step_ss'_guard_l. + intros H; split; intro; [easy |]. + apply step_ss'_guard_l; exact H. Qed. Lemma step_sb'_guard_r {R : Chain (sb' L)} - (t: ctree E C X) (t': ctree F D Y) side : + (t: @SS E B X) (t': ctree F B X) side : sb' L (` R) side t t' -> sb' L `R side t (Guard t'). Proof. - intros. - split; intros; subst. - - apply step_ss'_guard_r; auto. now apply H. - - apply step_ss'_guard_l; red; now step. + intros H; split; intro; subst. + - apply step_ss'_guard_r; now apply H. + - apply step_ss'_guard_l. + apply (b_chain R); exact H. Qed. - Lemma step_sb'_br - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} - {Z Z'} (a: C Z) (b: D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) side : + Lemma step_sb'_br {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + {Z Z'} (a: B Z) (b: B Z') + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) side : (forall x, exists y, R side (k x) (k' y)) -> (forall y, exists x, R side (k x) (k' y)) -> sb' L R side (Br a k) (Br b k'). Proof. - split; intros; subst; apply step_ss'_br. - - intros. destruct (H x). eauto. - - intros. destruct (H0 x). cbn. eauto. + intros H1 H2; split; intro; subst; apply step_ss'_br. + - intro x; destruct (H1 x) as (y & ?); eauto. + - intro y; destruct (H2 y) as (x & ?); eauto. Qed. - Lemma step_sb'_br_id - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} - {Z} (c: C Z) (d: D Z) - (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) side : + Lemma step_sb'_br_id {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + {Z} (c: B Z) (d: B Z) + (k : Z -> ctree E B X) (k' : Z -> ctree F B X) side : (forall x, R side (k x) (k' x)) -> sb' L R side (Br c k) (Br d k'). Proof. @@ -560,51 +598,40 @@ Section Proof_Rules. Qed. Lemma step_sb'_true_br_l {R : Chain (sb' L)} {Z} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y), + forall (c : B Z) (k : Z -> ctree E B X) (u : @SS F B X), (forall x, `R true (k x) u) -> sb' L `R true (Br c k) u. Proof. - intros; split; intros; subst; try discriminate. - now apply step_ss'_br_l. + intros c k u H; split; intro; [| easy]. + apply step_ss'_br_l. + intro x; apply H. Qed. Lemma step_sb'_br_l {R : Chain (sb' L)} {Z} : - forall (c : C Z) (z : Z) (k : Z -> ctree E C X) (u : ctree F D Y) side, + forall (c : B Z) (z : Z) (k : Z -> ctree E B X) (u : @SS F B X) side, (forall x, sb' L `R side (k x) u) -> sb' L `R side (Br c k) u. Proof. - intros; split; intros; subst. - - apply step_ss'_br_l; intros; now step. - - apply step_ss'_br_r with z; now apply H. + intros c z k u side H; split; intro; subst. + - apply step_ss'_br_l. + intro x; apply (b_chain R), H. + - apply step_ss'_br_r with (x := z); now apply H. Qed. (*| Step |*) - Lemma step_sb'_step - {R : _ -> rel _ _} {HR: Proper (eq ==> equ eq ==> equ eq ==> impl) R} - (t : ctree E C X) (t': ctree F D Y) : + Lemma step_sb'_step {R : bool -> rel (@SS E B X) (@SS F B X)} + {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + (t : ctree E B X) (t': ctree F B X) : L τ τ -> (forall side, R side t t') -> forall side, sb' L R side (Step t) (Step t'). Proof. - split; intros. - unshelve eapply step_ss'_step; eauto. - repeat intro; eapply HR; eauto. - unshelve eapply step_ss'_step; eauto. - repeat intro; eapply HR; eauto. - Qed. - - (* Lemma step_sb'_brS_l *) - (* {R : Chain (sb' L)} : *) - (* forall (t : ctree E C X) (u : ctree F D Y), *) - (* (exists l' u', trans l' u u' /\ (forall side, `R side t u') /\ L τ l') -> *) - (* `R true (Step t) u. *) - (* Proof. *) - (* intros. *) - (* step; split; intros. *) - (* - eapply step_ss'_step_l. apply step_ss'_gen_step_l. *) - (* apply step_sb'_br_l; intros. *) + intros Hτ HRtt' side; split; intro; subst. + - apply step_ss'_step; [exact Hτ | apply HRtt']. + - apply step_ss'_step; [exact Hτ | apply HRtt']. + Qed. End Proof_Rules. @@ -614,699 +641,991 @@ End Proof_Rules. A useful special case is the one where the arity coincide and we simply use the identity in both directions. We can in this case have [n] rather than [2n] obligations. |*) -Lemma step_sb'_brS {E F C D X Y L} +Lemma step_sb'_brS {E F B X L} {R : Chain (sb' L)} - {Z Z'} (c : C Z) (d : D Z') - (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + {Z Z'} (c : B Z) (d : B Z') + (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : (forall x, exists y, forall side, `R side (k x) (k' y)) -> (forall y, exists x, forall side, `R side (k x) (k' y)) -> L τ τ -> forall side, sb' L `R side (BrS c k) (BrS d k'). Proof. - intros. - eapply step_sb'_br; auto. - intros x; destruct (H x) as [z ?]; exists z. - step. apply step_sb'_step; auto. - intros x; destruct (H0 x) as [z ?]; exists z. - step. apply step_sb'_step; auto. + intros H1 H2 Hτ side. + apply step_sb'_br. + - intro x; destruct (H1 x) as (y & ?); exists y. + step. now apply step_sb'_step. + - intro y; destruct (H2 y) as (x & ?); exists x. + step. now apply step_sb'_step. Qed. -Lemma step_sb'_brS_id {E F C D X Y L} +Lemma step_sb'_brS_id {E F B X L} {R : Chain (sb' L)} - {Z} (c : C Z) (d: D Z) - (k: Z -> ctree E C X) (k': Z -> ctree F D Y) : + {Z} (c : B Z) (d: B Z) + (k: Z -> ctree E B X) (k': Z -> ctree F B X) : L τ τ -> (forall x side, `R side (k x) (k' x)) -> forall side, sb' L `R side (BrS c k) (BrS d k'). Proof. - intros; apply step_sb'_br_id; eauto. - intros; step; apply step_sb'_step; auto. + intros Hτ H side. + apply step_sb'_br_id. + intro x; apply (b_chain R), step_sb'_step; auto. Qed. -Lemma step_sb'_true_step_l {E F C D X Y L} +Lemma step_sb'_true_step_l {E F B X L} {R : Chain (sb' L)} : - forall (t : ctree E C X) (u : ctree F D Y), - (exists l' u', trans l' u u' /\ (forall side, `R side t u') /\ L τ l') -> + forall (t : ctree E B X) (u : @SS F B X), + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' + /\ (forall side, `R side t u') /\ L τ l') -> sb' L `R true (Step t) u. Proof. - intros. - split; intros; try congruence. - - unshelve eapply step_ss'_step_l; eauto. - repeat intro; eauto. - now rewrite <-H1,<-H2. + intros t u (l' & u' & STEP & HR' & Hτ). + split; intro; [| easy]. + apply step_ss'_step_l. + exists l', u'; ssplit. + - exact STEP. + - exact HR'. + - exact Hτ. Qed. -Lemma step_sb'_true_brS_l {E F C D X Y L} +Lemma step_sb'_true_brS_l {E F B X L} {R : Chain (sb' L)} {Z} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y), - (forall x, exists l' u', trans l' u u' /\ (forall side, `R side (k x) u') /\ L τ l') -> + forall (c : B Z) (k : Z -> ctree E B X) (u : @SS F B X), + (forall x, exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' + /\ (forall side, `R side (k x) u') /\ L τ l') -> sb' L `R true (BrS c k) u. Proof. - intros. - apply step_sb'_true_br_l; intros. - step. apply step_sb'_true_step_l; intros. - eauto. + intros c k u H. + apply step_sb'_true_br_l; intro x. + apply (b_chain R), step_sb'_true_step_l. + apply H. Qed. Section Inversion_Rules. - Context {E F C D: Type -> Type} - {X Y: Type}. - Variable (L : rel (@label E) (@label F)). + Context {E F B: Type -> Type} + {X: Type}. + Variable (L : rel (@label E X) (@label F X)). (* Lemmas to exploit sb' and sbisim' hypotheses *) - (* TODO incomplete *) - Lemma sb'_true_vis_inv {Z Z' R} : - forall (e : E Z) (f : F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y), - (Proper (eq ==> equ eq ==> equ eq ==> impl) R) -> - sb' L R true (Vis e k) (Vis f k') -> - forall x, exists y, (forall side, R side (k x) (k' y)) /\ L (obs e x) (obs f y). + Lemma estar_vis_inv {G : Type -> Type} {Z} (e : G Z) (k : Z -> ctree G B X) (m : @SS G B X) : + (trans_alt ε)^* (Active (Vis e k)) m -> + (Active (Vis e k) : @SS G B X) ⩸ m. Proof. - intros. - pose proof (trans_vis e x k). - apply H0 in H1; etrans. - destruct H1 as (? & ? & ? & ? & ?). inv_trans. subst. - setoid_rewrite EQ in H2. etrans. + intros [n STAR]; destruct n. + - exact STAR. + - destruct STAR as [mid STEP _]. + apply trans_vis_inv' in STEP as (_ & Habs); easy. Qed. Lemma sb'_true_vis_l_inv {Z R} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, + forall (e : E Z) (k : Z -> ctree E B X) (u : @SS F B X), sb' L R true (Vis e k) u -> - exists l' u', trans l' u u' /\ (forall side, R side (k x) u') /\ L (obs e x) l'. + exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' + /\ (forall side, R side (Passive e k) u') /\ L (ask e) l'. Proof. intros. apply sb'_true_ss' in H. - now apply ss'_vis_l_inv with (x := x) in H. - Qed. - - (* Lemma sbt'_true_brS_inv {R : Chain (sb' L)} *) - (* {Z Z'} : *) - (* forall (c : C Z) (c' : D Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y), *) - (* ` R true (BrS c k) (BrS c' k') -> *) - (* forall x, exists y, forall side, `R side (k x) (k' y). *) - (* Proof. *) - (* intros. *) - (* pose proof (trans_brS c k x). *) - (* destruct H0 as [SB _]; specialize (SB eq_refl). *) - (* destruct SB as (SBA & SBB & SBC). *) - (* unshelve edestruct SBB as (u' & EPS & HR); try reflexivity; [exact x |]. *) - (* cbn in HR. *) - (* inv EPS. *) - (* apply SBB in H1; etrans. *) - (* destruct H1 as (? & ? & ? & ? & ?). inv_trans. subst. *) - (* setoid_rewrite EQ in H2. etrans. *) - (* Qed. *) - - (* Lemma sb'_true_brS_l_inv {Z R} : *) - (* forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y) x, *) - (* sb' L R true (BrS c k) u -> *) - (* exists l' u', trans l' u u' /\ (forall side, R side (k x) u') /\ L τ l'. *) - (* Proof. *) - (* intros. apply sb'_true_ss' in H. *) - (* now apply ss'_brS_l_inv with (x := x) in H. *) - (* Qed. *) - - Lemma sb'_eq_vis_invT {Z Z' R} : - forall side (e : E Z) (f : E Z') (k : Z -> ctree E C X) (k' : Z' -> ctree E D Y), - sb' eq R side (Vis e k) (Vis f k') -> - forall (x : Z) (x' : Z'), Z = Z'. - Proof. - intros. destruct side. - + pose proof (trans_vis e x k). - apply H in H0; etrans. - destruct H0 as (? & ? & ? & ? & ?). inv_trans. subst. - now apply obs_eq_invT in H2 as ?. - + pose proof (trans_vis f x' k'). - apply H in H0; etrans. - destruct H0 as (? & ? & ? & ? & ?). inv_trans. subst. - now apply obs_eq_invT in H2 as ?. - Qed. - - Lemma sb'_eq_vis_inv {Z R} : - forall side (e f : E Z) (k : Z -> ctree E C X) (k' : Z -> ctree E D Y), - (Proper (eq ==> equ eq ==> equ eq ==> impl) R) -> - sb' eq R side (Vis e k) (Vis f k') -> - forall x, e = f /\ forall side, R side (k x) (k' x). - Proof. - intros. destruct side. - + pose proof (trans_vis e x k). - apply H0 in H1; etrans. - destruct H1 as (? & ? & ? & ? & ?). inv_trans. subst. - setoid_rewrite EQ in H2. apply obs_eq_inv in H3 as [<- <-]. auto. - + pose proof (trans_vis f x k'). - apply H0 in H1; etrans. - destruct H1 as (? & ? & ? & ? & ?). inv_trans. subst. - setoid_rewrite EQ in H2. apply obs_eq_inv in H3 as [<- <-]. auto. - Qed. - - Lemma sb'_true_vis_l_inv' {Z R} : - forall (e : E Z) (k : Z -> ctree E C X) (u : ctree F D Y), - Respects_val L -> - Respects_τ L -> - (Proper (eq ==> equ eq ==> equ eq ==> impl) R) -> - sb' L R true (Vis e k) u -> - forall x, exists Z' (f : F Z') k' x', - epsilon u (Vis f k') /\ - L (obs e x) (obs f x') /\ - forall side, R side (k x) (k' x'). + now apply ss'_vis_l_inv in H. + Qed. + + Lemma sb'_true_vis_inv {Z Z' R} : + forall (e : E Z) (f : F Z') (k : Z -> ctree E B X) (k' : Z' -> ctree F B X), + (Proper (eq ==> Seq ==> Seq ==> impl) R) -> + sb' L R true (Vis e k) (Vis f k') -> + (forall side, R side (Passive e k) (Passive f k')) /\ L (ask e) (ask f). Proof. - intros * RV RT ? SIM x. - pose proof (TR := trans_vis e x k). - apply SIM in TR; etrans. - destruct TR as (l' & u' & TR & ? & ?). - destruct l'. - - apply RT in H1; intuition; discriminate. - - apply trans_obs_epsilon in TR as (k' & EPS & EQ). - setoid_rewrite EQ in H0. - eauto 7 with trans. - - apply RV in H1 as [_ ?]. - pose proof (H1 (Is_val _)). inversion H2. + intros * HP H. + apply sb'_true_vis_l_inv in H as (l' & u' & STEP & HR & HL). + destruct STEP as [m STAR STEPa]. + apply estar_vis_inv in STAR. + rewrite <- STAR in STEPa. + apply trans_vis_inv' in STEPa as (EQ & ->). + split. + - intro side; rewrite <- EQ; apply HR. + - exact HL. Qed. Lemma sb'_true_br_l_inv {Z R} : - forall (c : C Z) (k : Z -> ctree E C X) (u : ctree F D Y), + forall (c : B Z) (k : Z -> ctree E B X) (u : @SS F B X), sb' L R true (Br c k) u -> - forall x, exists u', epsilon u u' /\ R true (k x) u'. + forall x, exists u', (trans_alt ε)^* u u' /\ R true (k x) u'. Proof. - intros. - pose proof (proj1 H eq_refl). - destruct H0 as [_ [? _]]. - etrans. + intros * H x. + destruct H as [H _]; specialize (H eq_refl); destruct H as [_ HB]. + destruct (HB _ (trans_br c x k)) as (u' & STAR & HR). + exists u'; split; [exact STAR | exact HR]. Qed. Lemma sb'_false_br_l_inv {Z R} : - forall (t : ctree E C X) (c : D Z) (k : Z -> ctree F D Y), + forall (t : @SS E B X) (c : B Z) (k : Z -> ctree F B X), sb' L R false t (Br c k) -> - forall x, exists t', epsilon t t' /\ R false t' (k x). + forall x, exists t', (trans_alt ε)^* t t' /\ R false t' (k x). Proof. - intros. - pose proof (proj2 H eq_refl). - destruct H0 as [_ [? _]]. etrans. + intros * H x. + destruct H as [_ H]; specialize (H eq_refl); destruct H as [_ HB]. + destruct (HB _ (trans_br c x k)) as (t' & STAR & HR). + exists t'; split; [exact STAR | exact HR]. Qed. Lemma sb'_true_guard_l_inv {R} : - forall (t : ctree E C X) (u : ctree F D Y), + forall (t : ctree E B X) (u : @SS F B X), sb' L R true (Guard t) u -> - exists u', epsilon u u' /\ R true t u'. + exists u', (trans_alt ε)^* u u' /\ R true t u'. Proof. - intros. - pose proof (proj1 H eq_refl). - destruct H0 as [_ [_ ?]]. - etrans. + intros * H. + destruct H as [H _]; specialize (H eq_refl); destruct H as [_ HB]. + destruct (HB _ (trans_guard t)) as (u' & STAR & HR). + exists u'; split; [exact STAR | exact HR]. Qed. Lemma sb'_false_guard_l_inv {R} : - forall (t : ctree E C X) (u : ctree F D Y), + forall (t : @SS E B X) (u : ctree F B X), sb' L R false t (Guard u) -> - exists t', epsilon t t' /\ R false t' u. + exists t', (trans_alt ε)^* t t' /\ R false t' u. Proof. - intros. - pose proof (proj2 H eq_refl). - destruct H0 as [_ [_ ?]]. etrans. + intros * H. + destruct H as [_ H]; specialize (H eq_refl); destruct H as [_ HB]. + destruct (HB _ (trans_guard u)) as (t' & STAR & HR). + exists t'; split; [exact STAR | exact HR]. Qed. - Lemma sbisim'_br_l_inv {Z} c x (k : Z -> ctree E C X) (t' : ctree F D Y) : + Lemma sbisim'_br_l_inv {Z} c x (k : Z -> ctree E B X) (t' : @SS F B X) : gfp (sb' L) true (Br c k) t' -> gfp (sb' L) true (k x) t'. Proof. - intros. step in H. - eapply sb'_true_br_l_inv with (x := x) in H as (? & ? & ?). - step. split; intros; try discriminate. - eapply step_ss'_epsilon_r; [| apply H]. - step in H0. now apply H0. + intros H. step in H. + eapply sb'_true_br_l_inv with (x := x) in H as (u' & STAR & HR). + step. split; intro; [| easy]. + eapply step_ss'_epsilon_r; [| exact STAR]. + step in HR. now apply HR. Qed. - Lemma sbisim'_br_r_inv {Z} c x (k : Z -> ctree F D Y) (t : ctree E C X) : + Lemma sbisim'_br_r_inv {Z} c x (k : Z -> ctree F B X) (t : @SS E B X) : gfp (sb' L) false t (Br c k) -> gfp (sb' L) false t (k x). Proof. - intros. step in H. - eapply sb'_false_br_l_inv with (x := x) in H as (? & ? & ?). - step. split; intros; try discriminate. - eapply step_ss'_epsilon_r; [| apply H]. - step in H0. now apply H0. + intros H. step in H. + eapply sb'_false_br_l_inv with (x := x) in H as (t0 & STAR & HR). + step. split; intro; [easy |]. + eapply step_ss'_epsilon_r; [| exact STAR]. + step in HR. now apply HR. Qed. - Lemma sbisim'_guard_l_inv (t : ctree E C X) (t' : ctree F D Y) : + Lemma sbisim'_guard_l_inv (t : ctree E B X) (t' : @SS F B X) : gfp (sb' L) true (Guard t) t' -> gfp (sb' L) true t t'. Proof. - intros. step in H. - eapply sb'_true_guard_l_inv in H as (? & ? & ?). - step. split; intros; try discriminate. - eapply step_ss'_epsilon_r; [| apply H]. - step in H0. now apply H0. + intros H. step in H. + apply sb'_true_guard_l_inv in H as (u' & STAR & HR). + step. split; intro; [| easy]. + eapply step_ss'_epsilon_r; [| exact STAR]. + step in HR. now apply HR. Qed. - Lemma sbisim'_guard_r_inv (t : ctree E C X) (t' : ctree F D Y) : + Lemma sbisim'_guard_r_inv (t : @SS E B X) (t' : ctree F B X) : gfp (sb' L) false t (Guard t') -> gfp (sb' L) false t t'. Proof. - intros. step in H. - eapply sb'_false_guard_l_inv in H as (? & ? & ?). - step. split; intros; try discriminate. - eapply step_ss'_epsilon_r; [| apply H]. - step in H0. now apply H0. + intros H. step in H. + apply sb'_false_guard_l_inv in H as (t0 & STAR & HR). + step. split; intro; [easy |]. + eapply step_ss'_epsilon_r; [| exact STAR]. + step in HR. now apply HR. Qed. End Inversion_Rules. -Definition guard_ctx {E C X} (R : ctree E C X -> Prop) - (t : ctree E C X) := - exists t', t ≅ Guard t' /\ R t'. +(*| +[eq]-specialized inversions, stated outside the section so [L] can be +instantiated with [eq]. +|*) +Lemma sb'_eq_vis_invT {E B X Z Z' R} : + forall side (e : E Z) (f : E Z') (k : Z -> ctree E B X) (k' : Z' -> ctree E B X), + sb' eq R side (Vis e k) (Vis f k') -> + Z = Z'. +Proof. + intros side e f k k' H. + destruct side. + - apply sb'_true_vis_l_inv in H as (l' & u' & STEP & _ & HL). + subst l'. + destruct STEP as [m STAR STEPa]. + apply estar_vis_inv in STAR; rewrite <- STAR in STEPa. + apply trans_vis_inv' in STEPa as (_ & Heq). + now apply ask_invT in Heq. + - apply sb'_false_ss' in H. + apply ss'_vis_l_inv in H as (l' & u' & STEP & _ & HL). + unfold flip in HL; subst l'. + destruct STEP as [m STAR STEPa]. + apply estar_vis_inv in STAR; rewrite <- STAR in STEPa. + apply trans_vis_inv' in STEPa as (_ & Heq). + apply ask_invT in Heq. + now symmetry. +Qed. + +Lemma sb'_eq_vis_inv {E B X Z R} : + forall side (e f : E Z) (k k' : Z -> ctree E B X), + (Proper (eq ==> Seq ==> Seq ==> impl) R) -> + sb' eq R side (Vis e k) (Vis f k') -> + e = f /\ (forall side, R side (Passive e k) (Passive f k')). +Proof. + intros side e f k k' HP H. + destruct side. + - apply sb'_true_vis_inv in H as (HR & Heq); [| exact HP]. + apply ask_inv in Heq; subst f. + auto. + - apply sb'_false_ss' in H. + apply ss'_vis_l_inv in H as (l' & u' & STEP & HR & HL). + unfold flip in HL; subst l'. + destruct STEP as [m STAR STEPa]. + apply estar_vis_inv in STAR; rewrite <- STAR in STEPa. + apply trans_vis_inv' in STEPa as (EQ & Heq). + apply ask_inv in Heq; subst f. + split; [reflexivity |]. + intro side'; rewrite <- EQ; apply HR. +Qed. + +Definition guard_ctx {E B X} (R : @SS E B X -> Prop) + (t : @SS E B X) := + exists t', t ⩸ (Active (Guard t')) /\ R (Active t'). + +Lemma epsilon_det_estar {E B X} (t t' : ctree E B X) : + epsilon_det t t' -> (trans_alt ε)^* (Active t) (Active t'). +Proof. + induction 1. + - apply estar_seq; constructor; exact H. + - eapply estar_cons0. + + eapply Transguard; [exact H0 | reflexivity]. + + exact IHepsilon_det. +Qed. Section upto. - Context {E F C D: Type -> Type} {X Y: Type} - (L : hrel (@label E) (@label F)). + Context {E F B: Type -> Type} {X: Type} + (L : rel (@label E X) (@label F X)). + + #[local] Obligation Tactic := idtac. - Program Definition ss_ctx3_l : mon (bool -> rel (ctree E C X) (ctree F D Y)) + Program Definition ss_ctx3_l : mon (bool -> rel (@SS E B X) (@SS F B X)) := {| body R b t u := b = true /\ ss L (fun t u => forall side, R side t u) t u |}. Next Obligation. - split; auto. intros. apply H1 in H0 as (? & ? & ? & ? & ?). eauto 6. + intros R R' HRR' b t u (-> & Hss); split; auto. + intros t' l Hne TR. + destruct (Hss _ _ Hne TR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit; auto. + intro side; apply HRR', HR. Qed. Lemma ss_st'_l (r : Chain (sb' L)) : forall side x y, ss_ctx3_l `r side x y -> `r side x y. Proof. apply tower. - - intros ? INC side x y [-> Hss] ??. red. + - intros ? INC side x y [-> Hss] ? ?. red. apply INC; auto. - econstructor; eauto. - intros ???. - edestruct Hss as (?&?&?&?&?); eauto. - do 2 eexists; ssplit; eauto. - intros ?. - apply leq_infx in H. - now apply H. + split; auto. + intros t' l Hne TR. + destruct (Hss _ _ Hne TR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + + assumption. + + intro side'; apply leq_infx in H; apply H, HR. + + assumption. - clear. intros R IH side x y [-> Hss]. - apply sb'_true_ss'. ssplit; intros. - + apply Hss in H0 as (? & ? & ? & ? & ?). - do 2 eexists. ssplit; eauto. - intros. - step; auto. - + rewrite H in Hss. - eapply ss_br_l_inv with (x := x0) in Hss. - exists y; split; auto. - apply IH. - constructor; auto. - eapply (Hbody (ss L)); [| apply Hss]. - intros ????; now step. - + rewrite H in Hss. - eapply ss_guard_l_inv in Hss. - exists y; split; auto. - apply IH. - constructor; auto. - eapply (Hbody (ss L)); [| apply Hss]. - intros ????; now step. + split; intro; [| easy]. + split. + + intros t' l Hne TR. + assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) x t') + by (apply trans_star_l; exact TR). + destruct (Hss _ _ Hne cTR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + * assumption. + * intro side'; apply (b_chain R), HR. + * assumption. + + intros t' TR. + exists y; split. + * apply trans_star_self. + * apply IH. + split; auto. + intros t'' l Hne cTR. + assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) x t'') + by (eapply estar_cons; [exact TR | exact cTR]). + destruct (Hss _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + -- assumption. + -- intro side'; apply (b_chain R), HR. + -- assumption. Qed. (* Up-to guard *) - Program Definition guard_ctx3_l : mon (bool -> rel (ctree E C X) (ctree F D Y)) + Program Definition guard_ctx3_l : mon (bool -> rel (@SS E B X) (@SS F B X)) := {| body R b t u := guard_ctx (fun t => R b t u) t |}. Next Obligation. - destruct H0 as (? & ? & ?). red. eauto. + intros R R' HRR' b t u (t0 & EQ & HR). + exists t0; split; [exact EQ | apply HRR', HR]. Qed. - Program Definition guard_ctx3_r : mon (bool -> rel (ctree E C X) (ctree F D Y)) + Program Definition guard_ctx3_r : mon (bool -> rel (@SS E B X) (@SS F B X)) := {| body R b t u := guard_ctx (fun u => R b t u) u |}. Next Obligation. - destruct H0 as (? & ? & ?). red. eauto. + intros R R' HRR' b t u (u0 & EQ & HR). + exists u0; split; [exact EQ | apply HRR', HR]. Qed. Lemma guard_ctx3_l_sbisim' (r : Chain (sb' L)) : forall side x y, guard_ctx3_l `r side x y -> `r side x y. Proof. apply tower. - - intros ? INC side x y (? & EQ & ?) ??; red. + - intros ? INC side x y (t0 & EQ & HR) ? ?; red. apply INC; auto. - econstructor; split; eauto. - apply leq_infx in H0. - now apply H0. + exists t0; split; [exact EQ |]. + apply leq_infx in H. + apply H, HR. - clear. - intros R IH side x y (? & EQ & HR). - split; intros; subst; subs. - + apply step_ss'_guard_l. - now step. - + apply step_ss'_guard_r. - eapply ss'_gen_mon. 3: apply HR; auto. - all: auto. + intros R IH side x y (t0 & EQ & HR). + split; intro; subst. + + rewrite EQ. + apply step_ss'_guard_l. + apply (b_chain R); exact HR. + + rewrite EQ. + apply step_ss'_guard_r. + now apply HR. Qed. Lemma guard_ctx3_r_sbisim' (r : Chain (sb' L)) : forall side x y, guard_ctx3_r `r side x y -> `r side x y. Proof. apply tower. - - intros ? INC side x y (? & EQ & ?) ??; red. + - intros ? INC side x y (u0 & EQ & HR) ? ?; red. apply INC; auto. - econstructor; split; eauto. - apply leq_infx in H0. - now apply H0. + exists u0; split; [exact EQ |]. + apply leq_infx in H. + apply H, HR. - clear. - intros R IH side x y (? & EQ & HR). - split; intros; subst; subs. - + apply step_ss'_guard_r. - eapply ss'_gen_mon. 3: apply HR; auto. - all: auto. - + apply step_ss'_guard_l. - now step. + intros R IH side x y (u0 & EQ & HR). + split; intro; subst. + + rewrite EQ. + apply step_ss'_guard_r. + now apply HR. + + rewrite EQ. + apply step_ss'_guard_l. + apply (b_chain R); exact HR. Qed. (* Up-to epsilon *) - Program Definition epsilon_det_ctx3_l : mon (bool -> rel (ctree E C X) (ctree F D Y)) - := {| body R b t u := b = true /\ epsilon_det_ctx (fun t => R b t u) t |}. + Program Definition epsilon_det_ctx3_l : mon (bool -> rel (@SS E B X) (@SS F B X)) + := {| body R b t u := + b = true /\ exists t0 t1, t ⩸ (Active t0) /\ epsilon_det t0 t1 + /\ R b (Active t1) u |}. Next Obligation. - destruct H1 as (? & ? & ?). split; auto. red. eauto. - Qed. - - Definition pure_bind_ctx {E C X X0} (P : X0 -> Prop) (R : ctree E C X -> Prop) - (t : ctree E C X) := - exists (t0 : ctree E C X0) k0, - t ≅ CTree.bind t0 k0 /\ - (forall l t', trans l t0 t' -> exists v, l = val v /\ P v) /\ - forall x, P x -> R (k0 x). - - Program Definition pure_bind_ctx3_l {X0} (P : X0 -> Prop) : mon (bool -> rel (ctree E C X) (ctree F D Y)) + intros R R' HRR' b t u (-> & t0 & t1 & EQ & DET & HR). + split; auto. + exists t0, t1; ssplit. + - exact EQ. + - exact DET. + - apply HRR', HR. + Qed. + + Definition pure_bind_ctx {X0} (P : X0 -> Prop) (R : @SS E B X -> Prop) + (t : @SS E B X) := + exists (t0 : ctree E B X0) k0, + t ⩸ (Active (CTree.bind t0 k0)) /\ + (forall l t', l <> ε -> ((trans_alt ε)^* ⋅ trans_alt l) (Active t0) t' -> + exists v, l = val v /\ P v) /\ + forall x, P x -> R (Active (k0 x)). + + Program Definition pure_bind_ctx3_l {X0} (P : X0 -> Prop) : mon (bool -> rel (@SS E B X) (@SS F B X)) := {| body R b t u := b = true /\ pure_bind_ctx P (fun t => R b t u) t |}. Next Obligation. - split; auto. destruct H1 as (? & ? & ? & ? & ?). - red. eauto 7. + intros X0 P R R' HRR' b t u (-> & t0 & k0 & EQ & HTR & HB). + split; auto. + exists t0, k0; ssplit. + - exact EQ. + - exact HTR. + - intros v Pv; apply HRR', HB, Pv. Qed. - Program Definition epsilon_ctx3_r : mon (bool -> rel (ctree E C X) (ctree F D Y)) - := {| body R b t u := b = true /\ epsilon_ctx (fun u => R b t u) u |}. + Program Definition epsilon_ctx3_r : mon (bool -> rel (@SS E B X) (@SS F B X)) + := {| body R b t u := b = true /\ exists u', (trans_alt ε)^* u u' /\ R b t u' |}. Next Obligation. - destruct H1 as (? & ? & ?). split; auto. red. eauto. + intros R R' HRR' b t u (-> & u' & STAR & HR). + split; auto. + exists u'; split; [exact STAR | apply HRR', HR]. Qed. Lemma epsilon_det_ctx3_l_sbisim' (r : Chain (sb' L)) : forall side x y, epsilon_det_ctx3_l `r side x y -> `r side x y. Proof. apply tower. - - intros ? INC side x y (? & EQ & ? & ?) ??; red. + - intros ? INC side x y (-> & t0 & t1 & EQ & DET & HR) ? ?; red. apply INC; auto. split; auto. - eexists; split; eauto. - apply leq_infx in H2. - now apply H2. + exists t0, t1; ssplit. + + exact EQ. + + exact DET. + + apply leq_infx in H. + apply H, HR. - clear. - intros R IH side x y (-> & ? & EQ & HR). - split; intros; try discriminate. - clear H. - induction EQ. - + apply sb'_true_ss' in HR. subs. - eapply ss'_gen_mon. 3: apply HR. - all: auto. - + subs. apply step_ss'_guard_l. - step. apply sb'_true_ss'. now apply IHEQ. + intros R IH side x y (-> & t0 & t1 & EQ & DET & HR). + split; intro; [| easy]. + rewrite EQ; clear x EQ. + revert HR; induction DET as [ta tb EQ01 | ta tb tc DET' IHDET EQg]; intro HR. + + assert (SQ : (Active ta : @SS E B X) ⩸ (Active tb)) + by (constructor; exact EQ01). + rewrite SQ. + now apply HR. + + assert (SQ : (Active tc : @SS E B X) ⩸ (Active (Guard ta))) + by (constructor; exact EQg). + rewrite SQ. + apply step_ss'_guard_l. + apply IH. + split; auto. + exists ta, tb; ssplit. + * reflexivity. + * exact DET'. + * apply (b_chain R); exact HR. Qed. Lemma pure_bind_ctx3_l_sbisim' {X0} (P : X0 -> Prop) (r : Chain (sb' L)) : forall side x y, pure_bind_ctx3_l P `r side x y -> `r side x y. Proof. apply tower. - - intros ? INC side x y (-> & EQ & ? & (? & ? & ?)) ??; red. + - intros ? INC side x y (-> & t0 & k0 & EQ & HTR & HB) ? ?; red. apply INC; auto. split; auto. - do 2 eexists; ssplit. - eauto. - intros * TR; apply H0 in TR as (? & ? & ?). - exists x1; auto. - apply leq_infx in H2. - intros; apply H2; auto. + exists t0, k0; ssplit. + + exact EQ. + + exact HTR. + + intros v Pv. + apply leq_infx in H. + apply H, HB, Pv. - clear. - intros R IH side x y (-> & ? & (? & EQ & HTR & HB)). - apply sb'_true_ss'. - subs. - ssplit. - + intros PROD l t' TR. - apply trans_bind_inv in TR as [(VAL & t'0 & TR0 & EQ) | (v & TR0 & TRk)]. - * apply HTR in TR0 as (v & -> & _). exfalso; etrans. - * apply HTR in TR0 as ?. destruct H as (? & ? & Hv). apply val_eq_inv in H as <-. - apply HB in TRk as (l' & u' & TRu & SIM & EQl); auto. - 2: { - apply trans_val_epsilon in TR0 as [? _]. - apply productive_epsilon in H1; [| now apply productive_bind in PROD]. - now rewrite H1, bind_ret_l in PROD. - } - eauto. - + intros Z c k0 EQ z. - apply br_equ_bind in EQ as ?. destruct H as [(v & EQt0 & _) | (k1 & EQt0 & EQk0)]. - * rewrite EQt0, bind_ret_l in EQ. - specialize (HB v). rewrite EQ in HB. - setoid_rewrite EQt0 in HTR. clear x0 EQt0. - destruct (HTR _ _ (trans_ret v)) as (? & ? & Hv). apply val_eq_inv in H as <-. - specialize (HB Hv). - apply sb'_true_br_l_inv with (x := z) in HB as (u' & EPS & SIM). - eauto. - * exists y. split; auto. - eapply IH; split; auto. - do 2 eexists; ssplit. - apply EQk0. - { - intros ?? TR. eapply trans_br in TR; [| reflexivity]. - rewrite <- EQt0 in TR. now apply HTR in TR. - } - intros. now step; apply HB. - + intros ? EQ. - apply guard_equ_bind in EQ as ?. destruct H as [(v & EQt0 & _) | (k1 & EQt0 & EQk0)]. - * rewrite EQt0, bind_ret_l in EQ. - specialize (HB v). rewrite EQ in HB. - setoid_rewrite EQt0 in HTR. clear x0 EQt0. - destruct (HTR _ _ (trans_ret v)) as (? & ? & Hv). apply val_eq_inv in H as <-. - specialize (HB Hv). - apply sb'_true_guard_l_inv in HB as (u' & EPS & SIM). - eauto. - * exists y. split; auto. rewrite <- EQk0 in EQ. - eapply IH; split; auto. - do 2 eexists; ssplit. - symmetry; eauto. - { - intros ?? TR. eapply trans_guard in TR. - rewrite <- EQt0 in TR. now apply HTR in TR. - } - intros. now step; apply HB. + intros R IH side x y (-> & t0 & k0 & EQ & HTR & HB). + split; intro; [| easy]. + rewrite EQ. + split. + + intros s l Hne TR. + apply trans_bind_inv in TR as + [ (v & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (-> & _) + | (Z & e & g & -> & TRt & SQ) ]]]. + * assert (HneV : (val v : @label E X0) <> ε) by easy. + assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val v)) + (Active t0) (Active (Stuck : ctree E B X0))). + { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } + destruct (HTR _ _ HneV cV) as (w & Hvw & Pw). + apply val_eq_inv in Hvw; subst w. + specialize (HB v Pw). + destruct HB as [HB _]; specialize (HB eq_refl). + destruct HB as [HBA _]. + destruct (HBA _ _ Hne TRk) as (l' & u' & RESP & HR & HL). + exists l', u'; ssplit. + -- exact RESP. + -- exact HR. + -- exact HL. + * assert (Hneτ : (τ : @label E X0) <> ε) by easy. + assert (cT : ((trans_alt ε)^* ⋅ trans_alt τ) (Active t0) (Active t1)) + by (apply trans_star_l; exact TRt). + destruct (HTR _ _ Hneτ cT) as (w & Habs & _); easy. + * easy. + * assert (HneA : (ask e : @label E X0) <> ε) by easy. + assert (cA : ((trans_alt ε)^* ⋅ trans_alt (ask e)) + (Active t0) (Passive e g)) + by (apply trans_star_l; exact TRt). + destruct (HTR _ _ HneA cA) as (w & Habs & _); easy. + + intros s TR. + apply trans_bind_inv in TR as + [ (v & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & e & g & Habs & _) ]]]. + * assert (HneV : (val v : @label E X0) <> ε) by easy. + assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val v)) + (Active t0) (Active (Stuck : ctree E B X0))). + { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } + destruct (HTR _ _ HneV cV) as (w & Hvw & Pw). + apply val_eq_inv in Hvw; subst w. + specialize (HB v Pw). + destruct HB as [HB _]; specialize (HB eq_refl). + destruct HB as [_ HBB]. + destruct (HBB _ TRk) as (u' & STAR & HR). + exists u'; split; [exact STAR | exact HR]. + * easy. + * exists y; split. + -- apply trans_star_self. + -- rewrite SQ. + apply IH. + split; auto. + exists t1, k0; ssplit. + ++ reflexivity. + ++ intros l t' Hne cTR. + eapply (HTR l t'); [exact Hne |]. + eapply estar_cons; [exact TRt | exact cTR]. + ++ intros v Pv; apply (b_chain R), HB, Pv. + * easy. Qed. Lemma epsilon_ctx3_r_sbisim' (r : Chain (sb' L)) : - forall side x y, epsilon_ctx3_r `r side x y <= `r side x y. + forall side x y, epsilon_ctx3_r `r side x y -> `r side x y. Proof. apply tower. - - intros ? INC side x y (? & ? & ? & ?) ??; red. + - intros ? INC side x y (-> & u' & STAR & HR) ? ?; red. apply INC; auto. split; auto. - eexists; split; eauto. - apply leq_infx in H2. - apply H2; auto. + exists u'; split; [exact STAR |]. + apply leq_infx in H. + apply H, HR. - clear. - intros c IH * (? & ? & ? & ?). subst. - split; intros; try discriminate. - eapply step_ss'_epsilon_r; [| eassumption]. - destruct H1 as [? _]. specialize (H1 eq_refl). - eapply ss'_gen_mon. 3: apply H1; auto. - all:eauto. + intros R IH side x y (-> & u' & STAR & HR). + split; intro; [| easy]. + eapply step_ss'_epsilon_r; [| exact STAR]. + now apply HR. Qed. - #[global] Instance epsilon_det_st' : forall (R : Chain (@sb' E F C D X Y L)), - Proper (epsilon_det ==> epsilon_det ==> flip impl) (` R true). + #[global] Instance epsilon_det_st' : forall (R : Chain (@sb' E F B X L)), + Proper (epsilon_det ==> epsilon_det ==> flip impl) + (fun (t : ctree E B X) (u : ctree F B X) => ` R true t u). Proof. - cbn. intros. + intros R t t' DETt u u' DETu H. apply epsilon_det_ctx3_l_sbisim'. - split; auto. exists y. split; auto. - apply epsilon_ctx3_r_sbisim'. - split; auto. exists y0. split; auto. now apply epsilon_det_epsilon. + split; auto. + exists t, t'; ssplit. + - reflexivity. + - exact DETt. + - apply epsilon_ctx3_r_sbisim'. + split; auto. + exists (Active u'); split. + + apply epsilon_det_estar; exact DETu. + + exact H. + Qed. + +End upto. + +(*| +Epsilon-absorption for the [sb'] game: the left player of the [true] side +(resp. the right player of the [false] side) may be advanced by ε-steps. +|*) +Lemma sbisim'_epsilon_l {E F B X} L : + forall (t t' : @SS E B X) (u : @SS F B X), + gfp (@sb' E F B X L) true t u -> + (trans_alt ε)^* t t' -> + gfp (sb' L) true t' u. +Proof. + intros t t' u H STAR. step. split; intro; [| easy]. + eapply ss'_gen_epsilon_l. + - cbn. intros ? ? H'. step in H'. now apply H'. + - step in H. now apply H. + - exact STAR. +Qed. + +Lemma sbisim'_epsilon_r {E F B X} L : + forall (t : @SS E B X) (u u' : @SS F B X), + gfp (@sb' E F B X L) false t u -> + (trans_alt ε)^* u u' -> + gfp (sb' L) false t u'. +Proof. + intros t u u' H STAR. step. split; intro; [easy |]. + eapply ss'_gen_epsilon_l. + - cbn. intros ? ? H'. step in H'. now apply H'. + - step in H. now apply H. + - exact STAR. +Qed. + +(*| +Right-hand inversions for [update_val_rel], complementing the left-hand +ones provided by SSimAlt. Needed for the [false] side of the bind lemma. +|*) +Section uvr_inv_r. + + Context {E F : Type -> Type} {X X' : Type} + {L : rel (@label E X') (@label F X')} {R0 : rel X X}. + + Lemma update_val_rel_val_r (w : X) (l1 : @label E X) : + update_val_rel L R0 l1 (val w) -> + exists v, l1 = val v /\ R0 v w. + Proof. + intros H; dependent destruction H; eauto. Qed. - #[global] Instance epsilon_det_sbt' : forall (R : Chain (@sb' E F C D X Y L)), - Proper (epsilon_det ==> epsilon_det ==> flip impl) (sb' L ` R true). + Lemma update_val_rel_τ_r (l1 : @label E X) : + update_val_rel L R0 l1 τ -> + l1 = τ /\ L τ τ. Proof. - intros ????????. - eapply epsilon_det_st'; eauto. + intros H; dependent destruction H; eauto. Qed. -End upto. + Lemma update_val_rel_ask_r {Z'} (f : F Z') (l1 : @label E X) : + update_val_rel L R0 l1 (ask f) -> + exists Z (e : E Z), l1 = ask e /\ L (ask e) (ask f). + Proof. + intros H; dependent destruction H; eauto. + Qed. + + Lemma update_val_rel_rcv_r {Z'} (f : F Z') (w : Z') (l1 : @label E X) : + update_val_rel L R0 l1 (rcv f w) -> + exists Z (e : E Z) (v : Z), l1 = rcv e v /\ L (rcv e v) (rcv f w). + Proof. + intros H; dependent destruction H; eauto. + Qed. + +End uvr_inv_r. Section bind. Arguments label: clear implicits. - Obligation Tactic := idtac. - - Context {E F C D: Type -> Type} {X X' Y Y': Type} - (L : hrel (@label E) (@label F)) (R0 : rel X X'). - - Lemma bind_chain_gen L0 - (ISVR : is_update_val_rel L R0 L0) - (R : Chain (@sb' E F C D Y Y' L)) : - forall (t : ctree E C X) (t' : ctree F D X') (k : X -> ctree E C Y) (k' : X' -> ctree F D Y'), - forall side, - gfp (sb' L0) side t t' -> - (forall side' x x', R0 x x' -> `R side' (k x) (k' x')) -> - ` R side (bind t k) (bind t' k'). - Proof. - apply (@tower _ _ _ (fun (P : bool -> rel (ctree E C Y) (ctree F D Y')) => - forall (t : ctree E C X) (t' : ctree F D X') (k : X -> ctree E C Y) (k' : X' -> ctree F D Y') side, - gfp (sb' L0) side t t' -> - (forall side x x', R0 x x' -> P side (k x) (k' x')) -> - P side (x <- t;; k x) (x <- t';; k' x))). - - intros ? INC ???? ? ????; red. - apply INC; auto. - eapply leq_infx in H1. - intros; apply H1; auto. - - clear -ISVR. - intros c IH * tt kk. - split; intros; subst; ssplit. - - + simpl; intros PROD l u STEP. - apply trans_bind_inv in STEP as [(H & u' & STEP & EQ) | (v & STEPres & STEP)]. - step in tt. - apply tt in STEP as (l' & u'' & STEP & EQ' & ?); auto. - 2: { now apply productive_bind in PROD. } - do 2 eexists. split; [| split]. - apply trans_bind_l; eauto. - * intro Hl. destruct Hl. - apply ISVR in H0; etrans. - inversion H0; subst. apply H. constructor. apply H2. constructor. - * intro; eapply equ_clos_st'_goal. - reflexivity. - apply EQ. - reflexivity. - apply IH; auto. - intros. step. now apply kk. - * apply ISVR in H0; etrans. - destruct H0. exfalso. apply H. constructor. apply H2. - * assert (t ≅ Ret v). - { apply productive_bind in PROD. apply trans_val_epsilon in STEPres as [? _]. - now apply productive_epsilon. } subs. - step in tt. - apply tt in STEPres as (l' & u' & STEPres & EQ' & ?); auto. - 2: now eapply prod_ret. - apply ISVR in H; etrans. - dependent destruction H. 2: { exfalso. apply H. constructor. } - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk true v v2 H). - rewrite bind_ret_l in PROD. - apply kk in STEP as (? & u''' & STEP & EQ'' & ?); auto. - do 2 eexists; split. - eapply trans_bind_r; eauto. - split; auto. - + intros Z ?c ?k EQ z. - apply br_equ_bind in EQ as EQ'. destruct EQ' as [(v & EQ' & EQ'') | (?k0 & EQ' & EQ'')]. - * subs. step in tt. destruct tt as [tt _]. specialize (tt eq_refl). destruct tt as [tt _]. - edestruct tt as (l & t'' & STEPres & _ & ?); etrans. - apply ISVR in H; etrans. - apply update_val_rel_val_l in H as (v' & -> & EQ'). - rewrite bind_ret_l in EQ. - specialize (kk true v v' EQ'). - apply kk with (x := z) in EQ; auto. destruct EQ as (u' & EPS & EQ). - exists u'. - apply trans_val_epsilon in STEPres as [? _]. split; eauto. - eapply epsilon_bind; eassumption. - * subs. setoid_rewrite EQ''. - (* clear k EQ EQ''. *) - eexists. split. reflexivity. - apply IH. - step. split; [| intros; discriminate]. - intros _. simple apply sbisim'_br_l_inv with (x := z) in tt. - step in tt. now apply tt. - intros. step; eauto. - - - + intros ? EQ. - apply guard_equ_bind in EQ as EQ'. destruct EQ' as [(v & EQ' & EQ'') | (?k0 & EQ' & EQ'')]. - * subs. step in tt. destruct tt as [tt _]. specialize (tt eq_refl). destruct tt as [tt _]. - edestruct tt as (l & t'' & STEPres & _ & ?); etrans. - apply ISVR in H; etrans. - apply update_val_rel_val_l in H as (v' & -> & EQ'). - rewrite bind_ret_l in EQ. - specialize (kk true v v' EQ'). - apply kk in EQ; auto. destruct EQ as (u' & EPS & EQ). - exists u'. - apply trans_val_epsilon in STEPres as [? _]. split; eauto. - eapply epsilon_bind; eassumption. - * subs. setoid_rewrite <- EQ''. - (* clear k EQ EQ''. *) - eexists. split. reflexivity. - apply IH. - step. split; [| intros; discriminate]. - intros _. simple apply sbisim'_guard_l_inv in tt. - step in tt. now apply tt. - intros. step; eauto. - - + simpl; intros PROD l u STEP. - apply trans_bind_inv in STEP as [(H & ?t' & STEP & EQ) | (v & STEPres & STEP)]. - step in tt. - apply tt in STEP as (l' & u' & STEP & EQ' & ?); auto. - 2: { now apply productive_bind in PROD. } - do 2 eexists. split; [| split]. - apply trans_bind_l; eauto. - * intro Hl. destruct Hl. - apply ISVR in H0; etrans. - inversion H0; subst. apply H. constructor. apply H1. constructor. - * intros; rewrite EQ. - apply IH; auto. - intros ? ? ? ?; step; now apply kk. - * apply ISVR in H0; etrans. - destruct H0. exfalso. apply H. constructor. apply H2. - * assert (t' ≅ Ret v). - { apply productive_bind in PROD. apply trans_val_epsilon in STEPres as [? _]. - now apply productive_epsilon. } subs. - step in tt. - apply tt in STEPres as (l' & u' & STEPres & EQ' & ?); auto. - 2: now eapply prod_ret. - apply ISVR in H; etrans. - dependent destruction H. 2: { exfalso. apply H0. constructor. } - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk false v1 v H). - rewrite bind_ret_l in PROD. - apply kk in STEP as (? & u''' & STEP & EQ'' & ?); auto. - do 2 eexists; split. - eapply trans_bind_r; eauto. - split; auto. + Context {E F B : Type -> Type} {X X' : Type} + (L : rel (@label E X') (@label F X')) + (R0 : rel X X). + + Notation uvr := (update_val_rel L R0). - + intros Z ?c ?k EQ z. - apply br_equ_bind in EQ as EQ'. destruct EQ' as [(v & EQ' & EQ'') | (?k0 & EQ' & EQ'')]. - * subs. step in tt. destruct tt as [_ tt]. specialize (tt eq_refl). destruct tt as [tt _]. - edestruct tt as (l & t'' & STEPres & _ & ?); etrans. - apply ISVR in H; etrans. - apply update_val_rel_val_r in H as (v' & -> & EQ'). - rewrite bind_ret_l in EQ. - specialize (kk false v' v EQ'). - apply kk with (x := z) in EQ; auto. destruct EQ as (u' & EPS & EQ). - exists u'. - apply trans_val_epsilon in STEPres as [? _]. split; eauto. - eapply epsilon_bind; eassumption. - * subs. setoid_rewrite EQ''. - eexists. split. reflexivity. - apply IH. - step. split; [intros; discriminate |]. - intros _. apply sbisim'_br_r_inv with (x := z) in tt. - step in tt. now apply tt. - intros. step. now apply kk. - - + intros ? EQ. - apply guard_equ_bind in EQ as EQ'. destruct EQ' as [(v & EQ' & EQ'') | (?k0 & EQ' & EQ'')]. - * subs. step in tt. destruct tt as [_ tt]. specialize (tt eq_refl). destruct tt as [tt _]. - edestruct tt as (l & t'' & STEPres & _ & ?); etrans. - apply ISVR in H; etrans. - apply update_val_rel_val_r in H as (v' & -> & EQ'). - rewrite bind_ret_l in EQ. - specialize (kk false v' v EQ'). - apply kk in EQ; auto. destruct EQ as (u' & EPS & EQ). - exists u'. - apply trans_val_epsilon in STEPres as [? _]. split; eauto. - eapply epsilon_bind; eassumption. - * subs. setoid_rewrite <- EQ''. - eexists. split. reflexivity. - apply IH. - step. split; [intros; discriminate |]. - intros _. apply sbisim'_guard_r_inv in tt. - step in tt. now apply tt. - intros. step. now apply kk. +(*| +Up-to-bind for [sb']. As in SSimAlt, the continuations must be related at +the [gfp] level (they need to be stepped for the ε-conjunct), while the +prefixes are related by the [gfp] of [sb' uvr] at the same side. +|*) + Lemma bind_chain_gen {R : Chain (@sb' E F B X' L)} : + forall (t : ctree E B X) (t' : ctree F B X) + (k : X -> ctree E B X') (k' : X -> ctree F B X') side, + gfp (sb' uvr) side (Active t) (Active t') -> + (forall side x x', R0 x x' -> gfp (sb' L) side (Active (k x)) (Active (k' x'))) -> + ` R side (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + Proof. + apply (@tower _ _ _ (fun (P : bool -> rel (@SS E B X') (@SS F B X')) => + forall (t : ctree E B X) (t' : ctree F B X) + (k : X -> ctree E B X') (k' : X -> ctree F B X') side, + gfp (sb' uvr) side (Active t) (Active t') -> + (forall side x x', R0 x x' -> gfp (sb' L) side (Active (k x)) (Active (k' x'))) -> + P side (Active (x <- t;; k x)) (Active (x <- t';; k' x)))). + - intros ? INC t t' k k' side tt kk ? ?; red. + apply INC; auto. + - clear; intros R IH t t' k k' side tt kk. + split; intro; subst. + + (* side = true *) + split. + * (* non-ε challenge on x <- t;; k x *) + intros s l Hne TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (-> & _) + | (Z & e & g & -> & TRt & SQ) ]]]. + -- (* the prefix returns; the step happens in k *) + step in tt. + destruct tt as [tt _]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (HneV : (val x : @label E X) <> ε) by easy. + assert (TRv : trans_alt (val x) (Active t) (Active (Stuck : ctree E B X))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). + apply update_val_rel_val_l in HL2 as (x' & -> & Hx). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. + pose proof (kkT := kk true x x' Hx). + step in kkT. + destruct kkT as [kkT _]; specialize (kkT eq_refl). + destruct kkT as [kkA _]. + destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). + exists l', u'; ssplit. + ++ destruct RESP2 as [m2 STAR2 STEP2]. + exists m2; [| exact STEP2]. + eapply estar_trans. + ** apply estar_bind; exact STAR. + ** eapply estar_trans; [| exact STAR2]. + apply estar_seq; constructor. + rewrite H, bind_ret_l; reflexivity. + ++ intro side'; apply (gfp_chain R), Hall. + ++ exact HL'. + -- (* τ step in the prefix *) + step in tt. + destruct tt as [tt _]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (Hneτ : (τ : @label E X) <> ε) by easy. + destruct (ttA _ _ Hneτ TRt) as (l2 & n & RESP & Htt' & HL2). + apply update_val_rel_τ_l in HL2 as (-> & HLττ). + destruct RESP as [m STAR STEPτ]. + unfold trans_alt in STEPτ; cbn in STEPτ; dependent destruction STEPτ. + exists τ, (Active (x <- u;; k' x)); ssplit. + ++ exists (Active (x <- t0;; k' x)). + ** apply estar_bind; exact STAR. + ** apply trans_bind_l_τ; eapply Transstep; eauto. + ++ intro side'; rewrite SQ. + apply IH; [apply Htt' | exact kk]. + ++ exact HLττ. + -- easy. + -- (* ask step in the prefix: the short trip through passives *) + step in tt. + destruct tt as [tt _]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (HneA : (ask e : @label E X) <> ε) by easy. + destruct (ttA _ _ HneA TRt) as (l2 & n & RESP & Htt' & HL2). + apply update_val_rel_ask_l in HL2 as (Z' & f & -> & HLaa). + destruct RESP as [m STAR STEPa]. + unfold trans_alt in STEPa; cbn in STEPa; dependent destruction STEPa. + exists (ask f), (Passive f (fun z => x <- k0 z;; k' x)); ssplit. + ++ exists (Active (x <- t0;; k' x)). + ** apply estar_bind; exact STAR. + ** apply trans_bind_l_ask; econstructor; exact H. + ++ intro side'; rewrite SQ. + apply (b_chain R). + split; intro; subst. + ** (* challenges of the E-side passive *) + split. + --- intros s2 l2 Hne2 TR2. + apply trans_passive_inv' in TR2 as (z & SQ2 & ->). + pose proof (HttT := Htt' true). + step in HttT. + destruct HttT as [HttT _]; specialize (HttT eq_refl). + destruct HttT as [HttA _]. + assert (HneR : (rcv e z : @label E X) <> ε) by easy. + assert (TRr : trans_alt (rcv e z) (Passive e g) (Active (g z))) + by (econstructor; reflexivity). + destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). + apply update_val_rel_rcv_l in HL3 as (Z2 & f2 & w & -> & HLrr). + destruct RESP3 as [m3 STAR3 STEP3]. + apply estar_passive in STAR3. + dependent destruction STAR3. + apply trans_passive_inv' in STEP3 as (w' & SQ3 & Heq). + dependent destruction Heq. + dependent destruction SQ3. + exists (rcv f w'), (Active (x <- k0 w';; k' x)); ssplit. + +++ apply trans_star_l; econstructor; reflexivity. + +++ intro side''; rewrite SQ2. + assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') + ⩸ (Active (x <- k0 w';; k' x))). + { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } + rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + +++ exact HLrr. + --- intros s2 TR2. + apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. + ** (* challenges of the F-side passive *) + split. + --- intros s2 l2 Hne2 TR2. + apply trans_passive_inv' in TR2 as (w & SQ2 & ->). + pose proof (HttF := Htt' false). + step in HttF. + destruct HttF as [_ HttF]; specialize (HttF eq_refl). + destruct HttF as [HttA _]. + assert (HneR : (rcv f w : @label F X) <> ε) by easy. + assert (TRr : trans_alt (rcv f w) (Passive f k0) (Active (k0 w))) + by (econstructor; reflexivity). + destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). + apply update_val_rel_rcv_r in HL3 as (Z2 & e2 & v & -> & HLrr). + destruct RESP3 as [m3 STAR3 STEP3]. + apply estar_passive in STAR3. + dependent destruction STAR3. + apply trans_passive_inv' in STEP3 as (v' & SQ3 & Heq). + dependent destruction Heq. + dependent destruction SQ3. + exists (rcv e v'), (Active (x <- g v';; k x)); ssplit. + +++ apply trans_star_l; econstructor; reflexivity. + +++ intro side''; rewrite SQ2. + assert (SQ5 : (Active (x <- t1;; k x) : @SS E B X') + ⩸ (Active (x <- g v';; k x))). + { constructor; rewrite EQ0, <- (EQ v'); reflexivity. } + rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + +++ exact HLrr. + --- intros s2 TR2. + apply trans_passive_inv' in TR2 as (w & _ & Habs); easy. + ++ exact HLaa. + * (* ε challenge on x <- t;; k x *) + intros s TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & e & g & Habs & _) ]]]. + -- step in tt. + destruct tt as [tt _]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (HneV : (val x : @label E X) <> ε) by easy. + assert (TRv : trans_alt (val x) (Active t) (Active (Stuck : ctree E B X))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). + apply update_val_rel_val_l in HL2 as (x' & -> & Hx). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. + pose proof (kkT := kk true x x' Hx). + step in kkT. + destruct kkT as [kkT _]; specialize (kkT eq_refl). + destruct kkT as [_ kkB]. + destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). + exists u2; split. + ++ eapply estar_trans. + ** apply estar_bind; exact STAR. + ** eapply estar_trans; [| exact STARu]. + apply estar_seq; constructor. + rewrite H, bind_ret_l; reflexivity. + ++ apply (gfp_chain R); exact Hgfp2. + -- easy. + -- exists (Active (x <- t';; k' x)); split. + ++ apply trans_star_self. + ++ rewrite SQ; apply IH; [| exact kk]. + eapply sbisim'_epsilon_l; [exact tt | apply estar_single; exact TRt]. + -- easy. + + (* side = false *) + split. + * (* non-ε challenge on x <- t';; k' x *) + intros s l Hne TR. + apply trans_bind_inv in TR as + [ (x' & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (-> & _) + | (Z & f & g & -> & TRt & SQ) ]]]. + -- (* the prefix returns; the step happens in k' *) + step in tt. + destruct tt as [_ tt]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (HneV : (val x' : @label F X) <> ε) by easy. + assert (TRv : trans_alt (val x') (Active t') (Active (Stuck : ctree F B X))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). + apply update_val_rel_val_r in HL2 as (x & -> & Hx). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. + pose proof (kkF := kk false x x' Hx). + step in kkF. + destruct kkF as [_ kkF]; specialize (kkF eq_refl). + destruct kkF as [kkA _]. + destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). + exists l', u'; ssplit. + ++ destruct RESP2 as [m2 STAR2 STEP2]. + exists m2; [| exact STEP2]. + eapply estar_trans. + ** apply estar_bind; exact STAR. + ** eapply estar_trans; [| exact STAR2]. + apply estar_seq; constructor. + rewrite H, bind_ret_l; reflexivity. + ++ intro side'; apply (gfp_chain R), Hall. + ++ exact HL'. + -- (* τ step in the prefix *) + step in tt. + destruct tt as [_ tt]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (Hneτ : (τ : @label F X) <> ε) by easy. + destruct (ttA _ _ Hneτ TRt) as (l2 & n & RESP & Htt' & HL2). + apply update_val_rel_τ_r in HL2 as (-> & HLττ). + destruct RESP as [m STAR STEPτ]. + unfold trans_alt in STEPτ; cbn in STEPτ; dependent destruction STEPτ. + exists τ, (Active (x <- u;; k x)); ssplit. + ++ exists (Active (x <- t0;; k x)). + ** apply estar_bind; exact STAR. + ** apply trans_bind_l_τ; eapply Transstep; eauto. + ++ intro side'; rewrite SQ. + apply IH; [apply Htt' | exact kk]. + ++ exact HLττ. + -- easy. + -- (* ask step in the prefix: the short trip, mirrored *) + step in tt. + destruct tt as [_ tt]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (HneA : (ask f : @label F X) <> ε) by easy. + destruct (ttA _ _ HneA TRt) as (l2 & n & RESP & Htt' & HL2). + apply update_val_rel_ask_r in HL2 as (Z' & e & -> & HLaa). + destruct RESP as [m STAR STEPa]. + unfold trans_alt in STEPa; cbn in STEPa; dependent destruction STEPa. + exists (ask e), (Passive e (fun z => x <- k0 z;; k x)); ssplit. + ++ exists (Active (x <- t0;; k x)). + ** apply estar_bind; exact STAR. + ** apply trans_bind_l_ask; econstructor; exact H. + ++ intro side'; rewrite SQ. + apply (b_chain R). + split; intro; subst. + ** (* challenges of the E-side passive *) + split. + --- intros s2 l2 Hne2 TR2. + apply trans_passive_inv' in TR2 as (z & SQ2 & ->). + pose proof (HttT := Htt' true). + step in HttT. + destruct HttT as [HttT _]; specialize (HttT eq_refl). + destruct HttT as [HttA _]. + assert (HneR : (rcv e z : @label E X) <> ε) by easy. + assert (TRr : trans_alt (rcv e z) (Passive e k0) (Active (k0 z))) + by (econstructor; reflexivity). + destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). + apply update_val_rel_rcv_l in HL3 as (Z2 & f2 & w & -> & HLrr). + destruct RESP3 as [m3 STAR3 STEP3]. + apply estar_passive in STAR3. + dependent destruction STAR3. + apply trans_passive_inv' in STEP3 as (w' & SQ3 & Heq). + dependent destruction Heq. + dependent destruction SQ3. + exists (rcv f w'), (Active (x <- g w';; k' x)); ssplit. + +++ apply trans_star_l; econstructor; reflexivity. + +++ intro side''; rewrite SQ2. + assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') + ⩸ (Active (x <- g w';; k' x))). + { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } + rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + +++ exact HLrr. + --- intros s2 TR2. + apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. + ** (* challenges of the F-side passive *) + split. + --- intros s2 l2 Hne2 TR2. + apply trans_passive_inv' in TR2 as (w & SQ2 & ->). + pose proof (HttF := Htt' false). + step in HttF. + destruct HttF as [_ HttF]; specialize (HttF eq_refl). + destruct HttF as [HttA _]. + assert (HneR : (rcv f w : @label F X) <> ε) by easy. + assert (TRr : trans_alt (rcv f w) (Passive f g) (Active (g w))) + by (econstructor; reflexivity). + destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). + apply update_val_rel_rcv_r in HL3 as (Z2 & e2 & v & -> & HLrr). + destruct RESP3 as [m3 STAR3 STEP3]. + apply estar_passive in STAR3. + dependent destruction STAR3. + apply trans_passive_inv' in STEP3 as (v' & SQ3 & Heq). + dependent destruction Heq. + dependent destruction SQ3. + exists (rcv e v'), (Active (x <- k0 v';; k x)); ssplit. + +++ apply trans_star_l; econstructor; reflexivity. + +++ intro side''; rewrite SQ2. + assert (SQ5 : (Active (x <- t1;; k x) : @SS E B X') + ⩸ (Active (x <- k0 v';; k x))). + { constructor; rewrite EQ0, <- (EQ v'); reflexivity. } + rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + +++ exact HLrr. + --- intros s2 TR2. + apply trans_passive_inv' in TR2 as (w & _ & Habs); easy. + ++ exact HLaa. + * (* ε challenge on x <- t';; k' x *) + intros s TR. + apply trans_bind_inv in TR as + [ (x' & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & f & g & Habs & _) ]]]. + -- step in tt. + destruct tt as [_ tt]; specialize (tt eq_refl). + destruct tt as [ttA _]. + assert (HneV : (val x' : @label F X) <> ε) by easy. + assert (TRv : trans_alt (val x') (Active t') (Active (Stuck : ctree F B X))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). + apply update_val_rel_val_r in HL2 as (x & -> & Hx). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. + pose proof (kkF := kk false x x' Hx). + step in kkF. + destruct kkF as [_ kkF]; specialize (kkF eq_refl). + destruct kkF as [_ kkB]. + destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). + exists u2; split. + ++ eapply estar_trans. + ** apply estar_bind; exact STAR. + ** eapply estar_trans; [| exact STARu]. + apply estar_seq; constructor. + rewrite H, bind_ret_l; reflexivity. + ++ apply (gfp_chain R); exact Hgfp2. + -- easy. + -- exists (Active (x <- t;; k x)); split. + ++ apply trans_star_self. + ++ rewrite SQ; apply IH; [| exact kk]. + eapply sbisim'_epsilon_r; [exact tt | apply estar_single; exact TRt]. + -- easy. Qed. End bind. @@ -1315,207 +1634,287 @@ End bind. Expliciting the reasoning rule provided by the up-to principles. |*) -Lemma st'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) + +(* Note: In this section, I changed the relation between t1 and t2 to + be at the gfp. *) + +Lemma st'_clo_bind {E F B: Type -> Type} {X X': Type} {L : rel (@label E X') (@label F X')} + (R0 : rel X X) side - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') - (R : Chain (sb' L)) : - gfp (sb' (update_val_rel L R0)) side t1 t2 -> - (forall x y, R0 x y -> forall b, `R b (k1 x) (k2 y)) -> - `R side (t1 >>= k1) (t2 >>= k2). + (t1 : ctree E B X) (t2: ctree F B X) + (k1 : X -> ctree E B X') (k2 : X -> ctree F B X') + (R : Chain (@sb' E F B X' L)) : + gfp (sb' (update_val_rel L R0)) side (Active t1) (Active t2) -> + (forall x y, R0 x y -> forall b, gfp (sb' L) b (Active (k1 x)) (Active (k2 y))) -> + `R side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. - intros ? ?. - eapply bind_chain_gen; eauto. - apply update_val_rel_correct. + intros H1 H2. + eapply bind_chain_gen; [exact H1 |]. + intros b x x' Hxx'; apply H2, Hxx'. Qed. -Lemma st'_clo_bind_eq {E C D: Type -> Type} {X X': Type} - side (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') - (R : Chain (sb' eq)) : - gfp (sb' eq) side t1 t2 -> - (forall x b, `R b (k1 x) (k2 x)) -> - ` R side (t1 >>= k1) (t2 >>= k2). +Lemma sbisim'_clo_bind {E F B: Type -> Type} {X X': Type} {L : rel (@label E X') (@label F X')} + (R0 : rel X X) + side + (t1 : ctree E B X) (t2: ctree F B X) + (k1 : X -> ctree E B X') (k2 : X -> ctree F B X') : + gfp (sb' (update_val_rel L R0)) side (Active t1) (Active t2) -> + (forall x y, R0 x y -> forall b, gfp (sb' L) b (Active (k1 x)) (Active (k2 y))) -> + gfp (sb' L) side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. - intros ? ?. - eapply bind_chain_gen; eauto. - - apply update_val_rel_eq. - - intros. now subst. + intros H1 H2. + apply (@st'_clo_bind E F B X X' L R0 side t1 t2 k1 k2 (chain_gfp (sb' L))); assumption. Qed. -Lemma sbt'_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - R0 L0 b - (HL0 : is_update_val_rel L R0 L0) - (t1 : ctree E C X) (t2: ctree F D X') - (k1 : X -> ctree E C Y) (k2 : X' -> ctree F D Y') - (R : Chain (sb' L)) : - gfp (sb' L0) b t1 t2 -> - (forall x y, R0 x y -> forall b, sb' L `R b (k1 x) (k2 y)) -> - sb' L `R b (t1 >>= k1) (t2 >>= k2). +(*| +[eq] as label relation is preserved by [update_val_rel]. +|*) +Lemma sbisim_update_val_rel_eq {E B X X'} : + forall side (t u : @SS E B X), + gfp (@sb' E E B X eq) side t u -> + gfp (sb' (@update_val_rel E E X X' eq eq)) side t u. Proof. - intros ? ?. - eapply bind_chain_gen; eauto. - intros; now apply H0. + apply (@tower _ _ _ (fun (P : bool -> rel (@SS E B X) (@SS E B X)) => + forall side t u, gfp (@sb' E E B X eq) side t u -> P side t u)). + - intros ? INC side t u H ? ?; red. + apply INC; auto. + - clear; intros R IH side t u H. + step in H. + split; intro; subst. + + destruct H as [H _]; specialize (H eq_refl); destruct H as [HA HB]. + split. + * intros s l Hne TR. + destruct (HA _ _ Hne TR) as (l' & u' & RESP & Hall & HL). + subst l'. + exists l, u'; ssplit. + -- exact RESP. + -- intro side'; apply IH, Hall. + -- apply update_val_rel_eq_refl; exact Hne. + * intros s TR. + destruct (HB _ TR) as (u' & STAR & Hrep). + exists u'; split; [exact STAR | apply IH, Hrep]. + + destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA HB]. + split. + * intros s l Hne TR. + destruct (HA _ _ Hne TR) as (l' & u' & RESP & Hall & HL). + unfold flip in HL; subst l'. + exists l, u'; ssplit. + -- exact RESP. + -- intro side'; apply IH, Hall. + -- apply update_val_rel_eq_refl; exact Hne. + * intros s TR. + destruct (HB _ TR) as (u' & STAR & Hrep). + exists u'; split; [exact STAR | apply IH, Hrep]. Qed. -Lemma sbt'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) b - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') - (R : Chain (sb' L)) : - gfp (sb' (update_val_rel L R0)) b t1 t2 -> - (forall x y, R0 x y -> forall b, sb' L `R b (k1 x) (k2 y)) -> - sb' L `R b (t1 >>= k1) (t2 >>= k2). +Lemma st'_clo_bind_eq {E B: Type -> Type} {X X': Type} + side (t1 t2 : ctree E B X) + (k1 k2 : X -> ctree E B X') + (R : Chain (@sb' E E B X' eq)) : + gfp (sb' eq) side (Active t1) (Active t2) -> + (forall x b, gfp (@sb' E E B X' eq) b (Active (k1 x)) (Active (k2 x))) -> + ` R side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. - intros ? ?. - eapply sbt'_clo_bind_gen; eauto. apply update_val_rel_correct. + intros H1 H2. + eapply bind_chain_gen with (R0 := eq). + - apply sbisim_update_val_rel_eq; exact H1. + - intros b x x' ->; apply H2. Qed. -Lemma sbt'_clo_bind_eq {E C D: Type -> Type} {X X': Type} - b (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') - (R : Chain (sb' eq)) : - gfp (sb' eq) b t1 t2 -> - (forall x b, sb' eq `R b (k1 x) (k2 x)) -> - sb' eq `R b (t1 >>= k1) (t2 >>= k2). +Lemma sbisim'_clo_bind_eq {E B: Type -> Type} {X X': Type} : + forall side (t1 t2 : ctree E B X) (k1 k2 : X -> ctree E B X'), + gfp (@sb' E E B X eq) side (Active t1) (Active t2) -> + (forall x b, gfp (@sb' E E B X' eq) b (Active (k1 x)) (Active (k2 x))) -> + gfp (sb' eq) side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. - intros ? ?. - eapply sbt'_clo_bind_gen. - - apply update_val_rel_eq. - - apply H. - - intros. now subst. + intros. + apply (@st'_clo_bind_eq E B X X' side t1 t2 k1 k2 (chain_gfp (sb' eq))); assumption. Qed. -Lemma step_sb'_guard_l' {E F C D X Y L} - (t: ctree E C X) (t': ctree F D Y) - (R : Chain (sb' L)) : +Lemma step_sb'_guard_l' {E F B X L} + (t: ctree E B X) (t': @SS F B X) + (R : Chain (@sb' E F B X L)) : (forall side, `R side t t') -> forall side, `R side (Guard t) t'. Proof. - intros. + intros H side. apply guard_ctx3_l_sbisim'. - eexists; eauto. + exists t; split; [reflexivity | apply H]. Qed. -Lemma step_sb'_guard_r' {E F C D X Y L} - (t: ctree E C X) (t': ctree F D Y) (R : Chain (sb' L)) : +Lemma step_sb'_guard_r' {E F B X L} + (t: @SS E B X) (t': ctree F B X) (R : Chain (@sb' E F B X L)) : (forall side, `R side t t') -> forall side, `R side t (Guard t'). Proof. - intros. - apply (guard_ctx3_r_sbisim' R). - eexists; eauto. + intros H side. + apply guard_ctx3_r_sbisim'. + exists t'; split; [reflexivity | apply H]. Qed. -Lemma sbisim'_epsilon_l {E F C D X Y} L : - forall (t t' : ctree E C X) (u : ctree F D Y), - gfp (sb' L) true t u -> - epsilon t t' -> - gfp (sb' L) true t' u. -Proof. - intros. step. split; intro; [| discriminate]. - eapply ss'_gen_epsilon_l. - - cbn. intros. step in H2. now apply H2. - - step in H. now apply H. - - apply H0. +(*| +The classic single-shot strong bisimulation over the combined-step LTS, +and its equivalence with [sbisim']. +|*) +#[local] Obligation Tactic := idtac. +Program Definition sb {E F B X} (L : rel (@label E X) (@label F X)) : + mon (@SS E B X -> @SS F B X -> Prop) := + {| body R t u := ss L R t u /\ ss (flip L) (flip R) u t |}. +Next Obligation. + intros E F B X L R R' HRR' t u (H1 & H2); split. + - intros t' l Hne TR. + destruct (H1 _ _ Hne TR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit; auto. + apply HRR', HR. + - intros u' l Hne TR. + destruct (H2 _ _ Hne TR) as (l' & t' & STEP & HR & HL). + exists l', t'; ssplit; auto. + apply HRR', HR. Qed. +#[local] Obligation Tactic := Tactics.program_simpl. -Lemma sbisim'_epsilon_r {E F C D X Y} L : - forall (t : ctree E C X) (u u' : ctree F D Y), - gfp (sb' L) false t u -> - epsilon u u' -> - gfp (sb' L) false t u'. -Proof. - intros. step. split; intro; [discriminate |]. - eapply ss'_gen_epsilon_l. - - cbn. intros. step in H2. now apply H2. - - step in H. now apply H. - - apply H0. -Qed. +Definition sbisim {E F B X} L := (gfp (@sb E F B X L) : hrel _ _). -Lemma ss_sb'_l_chain {E F C D X Y L} {R : Chain (sb' L)} : - forall (t : ctree E C X) (u : ctree F D Y), +Lemma ss_sb'_l_chain {E F B X L} {R : Chain (@sb' E F B X L)} : + forall (t : @SS E B X) (u : @SS F B X), ss L (fun t u => forall b, `R b t u) t u -> sb' L `R true t u. Proof. - intros. revert t u H. intros. split. - 2: intros; discriminate. intros _; ssplit; intros. - + apply H in H1. destruct H1 as (? & ? & ? & ? & ?). - eexists _, _. split; [apply H1 |]. split; [| apply H3]. - intro. destruct side; auto. - + subs. apply ss_br_l_inv with (x := x) in H. - exists u. split; eauto. now apply ss_st'_l. - + subs. apply ss_guard_l_inv in H. - exists u. split; eauto. now apply ss_st'_l. + intros t u HSS; split; intro; [| easy]. + split. + - intros t' l Hne TR. + assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t') + by (apply trans_star_l; exact TR). + destruct (HSS _ _ Hne cTR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit; assumption. + - intros t' TR. + exists u; split. + + apply trans_star_self. + + apply ss_st'_l. + split; auto. + intros t'' l Hne cTR. + assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') + by (eapply estar_cons; [exact TR | exact cTR]). + destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit; assumption. Qed. -Theorem gfp_sb'_ss_sbisim {E F C D X Y} : - forall L (t : ctree E C X) (u : ctree F D Y), +(* first half of the theorem *) +Theorem gfp_sb'_ss_sbisim {E F B X} : + forall L (t : @SS E B X) (u : @SS F B X), (ss L (sbisim L) t u -> gfp (sb' L) true t u) /\ (ss (flip L) (flip (sbisim L)) u t -> gfp (sb' L) false t u). Proof. - intros. revert t u. coinduction R CH. intros. split; split. - 2, 3: intros; discriminate. - - intros _. apply ss_sb'_l_chain; auto. - cbn. intros. - apply H in H0. destruct H0 as (? & ? & ? & ? & ?). - eexists _, _. split; [apply H0 |]. split; [| apply H2]. - step in H1. intro. destruct b; apply CH; apply H1. - - intros _; ssplit; intros. - + apply H in H1. destruct H1 as (? & ? & ? & ? & ?). - eexists _, _. split; [apply H1 |]. split; [| apply H3]. - step in H2. destruct side; apply CH; apply H2. - + subs. apply ss_br_l_inv with (x := x) in H. - exists t. split; eauto. now apply CH. - + subs. apply ss_guard_l_inv in H. - exists t. split; eauto. now apply CH. + intros L. coinduction R CH. intros t u. + split; intro H. + - apply ss_sb'_l_chain. + intros t' l Hne cTR. + destruct (H _ _ Hne cTR) as (l' & u' & STEP & HR & HL). + exists l', u'; ssplit. + + assumption. + + intro b. step in HR. destruct HR as [HR1 HR2]. + destruct b. + * apply CH; exact HR1. + * apply CH; exact HR2. + + assumption. + - split; intro; [easy |]. + split. + + intros u1 l Hne TR. + assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) u u1) + by (apply trans_star_l; exact TR). + destruct (H _ _ Hne cTR) as (l' & t1 & STEP & HR & HL). + exists l', t1; ssplit. + * assumption. + * intro b. step in HR. destruct HR as [HR1 HR2]. + destruct b. + -- apply CH; exact HR1. + -- apply CH; exact HR2. + * assumption. + + intros u1 TR. + exists t; split. + * apply trans_star_self. + * apply CH. + intros u2 l Hne cTR. + apply (H u2 l Hne). + eapply estar_cons; [exact TR | exact cTR]. Qed. -Lemma gfp_sb'_true_ss_sbisim {E F C D X Y} : - forall L (t : ctree E C X) (u : ctree F D Y), +Lemma gfp_sb'_true_ss_sbisim {E F B X} : + forall L (t : @SS E B X) (u : @SS F B X), ss L (sbisim L) t u -> gfp (sb' L) true t u. Proof. - apply gfp_sb'_ss_sbisim. + intros L t u; apply (gfp_sb'_ss_sbisim L t u). Qed. -Theorem sbisim_sbisim' {E F C D X Y} : - forall L (t : ctree E C X) (t' : ctree F D Y), sbisim L t t' <-> sbisim' L t t'. +(* main result. both halves are a proof by coinduction; + the first half is proved seperately in [gfp_sb'_ss_sbisim]. *) +Theorem sbisim_sbisim' {E F B X} : + forall L (t : @SS E B X) (t' : @SS F B X), sbisim L t t' <-> sbisim' L t t'. Proof. - split; intro. - - intros []. - + eapply (proj1 (gfp_sb'_ss_sbisim _ _ _)). step in H. apply H. - + eapply (proj2 (gfp_sb'_ss_sbisim _ _ _)). step in H. apply H. - - revert t t' H. - coinduction R CH. intros. split; intros. - + cbn. intros. apply trans_epsilon in H0 as (? & ? & ? & ?). - apply sbisim'_epsilon_l with (t' := x) in H; auto. - step in H. apply (proj1 H) in H2 as (? & ? & ? & ? & ?); auto. eauto 6. - + cbn. intros. apply trans_epsilon in H0 as (? & ? & ? & ?). - apply sbisim'_epsilon_r with (u' := x) in H; auto. - step in H. apply (proj2 H) in H2 as (? & ? & ? & ? & ?); auto. eauto 6. + split; intro H. + (* immediate from [gfp_sb'_ss_sbisim] *) + - intro side; destruct side. + + apply (gfp_sb'_ss_sbisim L t t'). step in H. apply H. + + apply (gfp_sb'_ss_sbisim L t t'). step in H. apply H. + - revert t t' H. unfold sbisim. coinduction R CH. intros t t' H. + split. + + intros s l Hne cTR. + destruct cTR as [m STAR STEP]. + pose proof (HT := H true). + eapply sbisim'_epsilon_l in HT; [| exact STAR]. + step in HT. + destruct HT as [HT _]; specialize (HT eq_refl); destruct HT as [HTA _]. + destruct (HTA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). + exists l', u'; ssplit. + * assumption. + * apply CH; exact Hall. + * assumption. + + intros s l Hne cTR. + destruct cTR as [m STAR STEP]. + pose proof (HF := H false). + eapply sbisim'_epsilon_r in HF; [| exact STAR]. + step in HF. + destruct HF as [_ HF]; specialize (HF eq_refl); destruct HF as [HFA _]. + destruct (HFA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). + exists l', u'; ssplit. + * assumption. + * apply CH; exact Hall. + * assumption. Qed. -Corollary sbisim_gfp_sb' {E F C D X Y} : - forall L side (t : ctree E C X) (t' : ctree F D Y), sbisim L t t' -> gfp (sb' L) side t t'. +Corollary sbisim_gfp_sb' {E F B X} : + forall L side (t : @SS E B X) (t' : @SS F B X), sbisim L t t' -> gfp (sb' L) side t t'. Proof. intros. apply sbisim_sbisim' in H. apply H. Qed. -Theorem ss_sbisim_gfp_sb' {E F C D X Y} : - forall L (t : ctree E C X) (u : ctree F D Y), +(* split converse *) +Theorem ss_sbisim_gfp_sb' {E F B X} : + forall L (t : @SS E B X) (u : @SS F B X), (gfp (sb' L) true t u -> ss L (sbisim L) t u) /\ (gfp (sb' L) false t u -> ss (flip L) (flip (sbisim L)) u t). Proof. - intros. revert t u. intros. split; cbn; intros. - - apply trans_epsilon in H0 as (? & ? & ? & ?). - apply sbisim'_epsilon_l with (t' := x) in H; auto. - step in H. apply (proj1 H) in H2 as (? & ? & ? & ? & ?); auto. - exists x0, x1. ssplit; auto. now apply sbisim_sbisim'. - - apply trans_epsilon in H0 as (? & ? & ? & ?). - apply sbisim'_epsilon_r with (u' := x) in H; auto. - step in H. apply (proj2 H) in H2 as (? & ? & ? & ? & ?); auto. - exists x0, x1. ssplit; auto. now apply sbisim_sbisim'. + intros L t u; split; intro H. + - intros t1 l Hne cTR. + destruct cTR as [m STAR STEP]. + eapply sbisim'_epsilon_l in H; [| exact STAR]. + step in H. + destruct H as [H _]; specialize (H eq_refl); destruct H as [HA _]. + destruct (HA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). + exists l', u'; ssplit. + + assumption. + + apply sbisim_sbisim'; intro side; apply Hall. + + assumption. + - intros u1 l Hne cTR. + destruct cTR as [m STAR STEP]. + eapply sbisim'_epsilon_r in H; [| exact STAR]. + step in H. + destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA _]. + destruct (HA _ _ Hne STEP) as (l' & t1 & RESP & Hall & HL). + exists l', t1; ssplit. + + assumption. + + apply sbisim_sbisim'; intro side; apply Hall. + + assumption. Qed. (* From 5c06ffd35ad7e3947fbcb51463ecf68a8a08eecf Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Wed, 15 Jul 2026 14:16:25 +0200 Subject: [PATCH 40/61] Fixed bind in SBisimAlt --- theories/Eq/SBisimAlt.v | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index e545a7e..4f1c1c9 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -1289,17 +1289,17 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : X -> ctree F B X') side, gfp (sb' uvr) side (Active t) (Active t') -> - (forall side x x', R0 x x' -> gfp (sb' L) side (Active (k x)) (Active (k' x'))) -> + (forall side x x', R0 x x' -> `R side (Active (k x)) (Active (k' x'))) -> ` R side (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. apply (@tower _ _ _ (fun (P : bool -> rel (@SS E B X') (@SS F B X')) => forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : X -> ctree F B X') side, gfp (sb' uvr) side (Active t) (Active t') -> - (forall side x x', R0 x x' -> gfp (sb' L) side (Active (k x)) (Active (k' x'))) -> + (forall side x x', R0 x x' -> P side (Active (k x)) (Active (k' x'))) -> P side (Active (x <- t;; k x)) (Active (x <- t';; k' x)))). - intros ? INC t t' k k' side tt kk ? ?; red. - apply INC; auto. + apply INC; auto. intros. apply kk; auto. - clear; intros R IH t t' k k' side tt kk. split; intro; subst. + (* side = true *) @@ -1323,7 +1323,6 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. pose proof (kkT := kk true x x' Hx). - step in kkT. destruct kkT as [kkT _]; specialize (kkT eq_refl). destruct kkT as [kkA _]. destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). @@ -1335,7 +1334,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. ** eapply estar_trans; [| exact STAR2]. apply estar_seq; constructor. rewrite H, bind_ret_l; reflexivity. - ++ intro side'; apply (gfp_chain R), Hall. + ++ intro side'; apply Hall. ++ exact HL'. -- (* τ step in the prefix *) step in tt. @@ -1351,7 +1350,9 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. ** apply estar_bind; exact STAR. ** apply trans_bind_l_τ; eapply Transstep; eauto. ++ intro side'; rewrite SQ. - apply IH; [apply Htt' | exact kk]. + apply IH. + ** apply Htt'. + ** intros. step. now apply kk. ++ exact HLττ. -- easy. -- (* ask step in the prefix: the short trip through passives *) @@ -1395,7 +1396,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') ⩸ (Active (x <- k0 w';; k' x))). { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. +++ exact HLrr. --- intros s2 TR2. apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. @@ -1424,7 +1425,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. assert (SQ5 : (Active (x <- t1;; k x) : @SS E B X') ⩸ (Active (x <- g v';; k x))). { constructor; rewrite EQ0, <- (EQ v'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. +++ exact HLrr. --- intros s2 TR2. apply trans_passive_inv' in TR2 as (w & _ & Habs); easy. @@ -1447,7 +1448,6 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. pose proof (kkT := kk true x x' Hx). - step in kkT. destruct kkT as [kkT _]; specialize (kkT eq_refl). destruct kkT as [_ kkB]. destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). @@ -1457,11 +1457,11 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. ** eapply estar_trans; [| exact STARu]. apply estar_seq; constructor. rewrite H, bind_ret_l; reflexivity. - ++ apply (gfp_chain R); exact Hgfp2. + ++ exact Hgfp2. -- easy. -- exists (Active (x <- t';; k' x)); split. ++ apply trans_star_self. - ++ rewrite SQ; apply IH; [| exact kk]. + ++ rewrite SQ; apply IH; [| intros; step; now apply kk]. eapply sbisim'_epsilon_l; [exact tt | apply estar_single; exact TRt]. -- easy. + (* side = false *) @@ -1485,7 +1485,6 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. pose proof (kkF := kk false x x' Hx). - step in kkF. destruct kkF as [_ kkF]; specialize (kkF eq_refl). destruct kkF as [kkA _]. destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). @@ -1497,7 +1496,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. ** eapply estar_trans; [| exact STAR2]. apply estar_seq; constructor. rewrite H, bind_ret_l; reflexivity. - ++ intro side'; apply (gfp_chain R), Hall. + ++ intro side'; apply Hall. ++ exact HL'. -- (* τ step in the prefix *) step in tt. @@ -1513,7 +1512,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. ** apply estar_bind; exact STAR. ** apply trans_bind_l_τ; eapply Transstep; eauto. ++ intro side'; rewrite SQ. - apply IH; [apply Htt' | exact kk]. + apply IH; [apply Htt' | intros; step; now apply kk]. ++ exact HLττ. -- easy. -- (* ask step in the prefix: the short trip, mirrored *) @@ -1557,7 +1556,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') ⩸ (Active (x <- g w';; k' x))). { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. +++ exact HLrr. --- intros s2 TR2. apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. @@ -1586,7 +1585,7 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. assert (SQ5 : (Active (x <- t1;; k x) : @SS E B X') ⩸ (Active (x <- k0 v';; k x))). { constructor; rewrite EQ0, <- (EQ v'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | exact kk]. + rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. +++ exact HLrr. --- intros s2 TR2. apply trans_passive_inv' in TR2 as (w & _ & Habs); easy. @@ -1609,7 +1608,6 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. pose proof (kkF := kk false x x' Hx). - step in kkF. destruct kkF as [_ kkF]; specialize (kkF eq_refl). destruct kkF as [_ kkB]. destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). @@ -1619,11 +1617,11 @@ prefixes are related by the [gfp] of [sb' uvr] at the same side. ** eapply estar_trans; [| exact STARu]. apply estar_seq; constructor. rewrite H, bind_ret_l; reflexivity. - ++ apply (gfp_chain R); exact Hgfp2. + ++ apply Hgfp2. -- easy. -- exists (Active (x <- t;; k x)); split. ++ apply trans_star_self. - ++ rewrite SQ; apply IH; [| exact kk]. + ++ rewrite SQ; apply IH; [| intros; step; now apply kk]. eapply sbisim'_epsilon_r; [exact tt | apply estar_single; exact TRt]. -- easy. Qed. From e19ac799b6c348d803e122b2914eafc115f0965b Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Wed, 15 Jul 2026 14:22:41 +0200 Subject: [PATCH 41/61] Fixed bind in SSimAlt --- theories/Eq/SSimAlt.v | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 36708a6..ee71fec 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -1112,12 +1112,13 @@ Section bind_restore. forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : X -> ctree F B X'), ssim uvr (Active t) (Active t') -> - (forall x x', R0 x x' -> ssim' L (Active (k x)) (Active (k' x'))) -> + (forall x x', R0 x x' -> ` R (Active (k x)) (Active (k' x'))) -> ` R (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. apply tower. - intros ? INC t t' k k' tt kk ? ?; red. apply INC; auto. + intros. now apply kk. - clear; intros R IH t t' k k' tt kk. split. + intros s l Hne TR. @@ -1136,7 +1137,7 @@ Section bind_restore. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. specialize (kk x x' Hx). - step in kk; destruct kk as (kkA & _). + destruct kk as (kkA & _). destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hgfp & HL'). exists l', u'; ssplit. -- destruct RESP2 as [m2 STAR2 STEP2]. @@ -1146,7 +1147,7 @@ Section bind_restore. ++ eapply estar_trans; [| exact STAR2]. apply estar_seq; constructor. rewrite H, bind_ret_l; reflexivity. - -- apply (gfp_chain R); exact Hgfp. + -- exact Hgfp. -- exact HL'. * assert (cT : ((trans_alt ε)^* ⋅ trans_alt τ) (Active t) (Active t1)) by (apply trans_star_l; exact TRt). @@ -1160,7 +1161,7 @@ Section bind_restore. -- exists (Active (x <- t0;; k' x)). ++ apply estar_bind; exact STAR. ++ apply trans_bind_l_τ; eapply Transstep; eauto. - -- rewrite SQ; apply IH; [exact Htt' | exact kk]. + -- rewrite SQ; apply IH; [exact Htt' | intros; step; now apply kk]. -- exact HLττ. * easy. (* a short trip is needed: active -> passive -> active @@ -1201,7 +1202,7 @@ Section bind_restore. assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') ⩸ (Active (x <- k0 w';; k' x))). { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } - rewrite <- SQ5; apply IH; [exact Htt2 | exact kk]. + rewrite <- SQ5; apply IH; [exact Htt2 | intros; step; now apply kk]. ** exact HLrr. ++ intros s2 TR2. apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. @@ -1222,7 +1223,7 @@ Section bind_restore. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. specialize (kk x x' Hx). - step in kk; destruct kk as (_ & kkB). + destruct kk as (_ & kkB). destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). exists u2; split. -- eapply estar_trans. @@ -1230,11 +1231,11 @@ Section bind_restore. ++ eapply estar_trans; [| exact STARu]. apply estar_seq; constructor. rewrite H, bind_ret_l; reflexivity. - -- apply (gfp_chain R); exact Hgfp2. + -- exact Hgfp2. * easy. * exists (Active (x <- t';; k' x)); split. -- apply trans_star_self. - -- rewrite SQ; apply IH; [| exact kk]. + -- rewrite SQ; apply IH; [| intros; step; now apply kk]. eapply ssim_eps_l; [exact tt | exact TRt]. * easy. Qed. From ca57c2ac00853c318b2eb32681a367d1cb26718f Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 15 Jul 2026 15:25:44 +0200 Subject: [PATCH 42/61] nits from meeting --- theories/Eq/SSimAlt.v | 66 +++++++++++++------------------------------ 1 file changed, 19 insertions(+), 47 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index ee71fec..47ef259 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -28,26 +28,17 @@ Ltac ssplit := split; [| split]. Section StrongSimAlt. - (* finition ss'_gen {E F C D : Type -> Type} {X : Type} - (L : rel (@label E X) (@label F X)) - (R Reps : rel (ctree E C X) (ctree F D X)) - (t : ctree E C X) (u : ctree F D Y) := - - (productive t -> - (* t and u step together under labels related by L, assuming - t is "productive"; that is, not a Br *) - forall l t', trans l t t' -> - exists l' u', trans l' u u' /\ R t' u' /\ L l l') - (* if t branches, u ϵ-steps to u' *) - /\ (forall Z (c : C Z) k, - t ≅ Br c k -> - forall x, exists u', epsilon u u' /\ Reps (k x) u') - /\ (forall t', - t ≅ Guard t' -> - exists u', epsilon u u' /\ Reps t' u'). - *) - -Locate dot. + (* TODO: Make it heterogeneous, propagate the use of lrel *) + (* Definition ss'_gen {E F B : Type -> Type} {X : Type} *) + (* (L : lrel E F X X) *) + (* (R Reps : rel SS SS) *) + (* (t : SS) (u : SS) := *) + + (* (forall t' l, l <> ε -> trans_alt (B:=B) l t t' *) + (* -> exists l' u', ((trans_alt (B:=B) ε)^* ⋅ (trans_alt l')) u u' /\ R t' u' /\ L l l') *) + (* /\ *) + (* (forall t', trans_alt (B:=B) ε t t' -> exists u', (trans_alt (B:=B) ε)^* u u' /\ Reps t' u'). *) + Definition ss'_gen {E F B : Type -> Type} {X : Type} (L : rel (@label E X) (@label F X)) (R Reps : rel SS SS) @@ -81,7 +72,7 @@ Locate dot. - apply Hep in H as (u' & Htrans & HRtu). exists u'; split; [assumption | now apply HReps]. Qed. -(*| + (*| An alternative definition [ss'] of strong simulation. The simulation challenge does not involve an inductive transition relation, thus simplifying proofs. @@ -90,20 +81,20 @@ thus simplifying proofs. (L : rel (@label E X) (@label F X)) : mon (SS -> SS -> Prop) := {| body R t u := - @ss'_gen E F B X L R R t u + @ss'_gen E F B X L R R t u |}. - Next Obligation. + Next Obligation. epose proof (@ss'_gen_mon E F B X). eapply H1. 3: apply H0. all: auto. Qed. - End StrongSimAlt. Definition ssim' {E F B X} L := (gfp (@ss' E F B X L): hrel _ _). +(* TODO: is this definition needed? *) Program Definition ss {E F B : Type -> Type} {X : Type} (L : rel (@label E X) (@label F X)) : mon (@SS E B X -> @SS F B X -> Prop) := @@ -121,7 +112,7 @@ Qed. Definition ssim {E F B X} L := (gfp (@ss E F B X L) : hrel _ _). - (* todo: remove this and rewrite using simple proper instances *) +(* TODO: remove this and rewrite using simple proper instances *) Variant Seq_clos_body {E F B X} (R : rel (@S E B X) (@S F B X)) : rel (@S E B X) (@S F B X) := | Seq_clos_intro : forall t t' u' u (Seqt : t ⩸ t') @@ -249,22 +240,6 @@ Ltac __step_in_ssim' H := step in H; fold (@ssim' E F B X L) in H end. -(* goal: elem x y wtp b x y - -step: - -gfp b <= b (elem) <= elem - -H: gfp b x y -goal: -b (elem) x y - -elem <- b elem <- gfp b <-> b (gfp b) - -unstep: -b gfp -> gfp - -*) Tactic Notation "step" "in" ident(H) := __step_in_ssim' H || step in H. Tactic Notation "__coinduction_ssim'" simple_intropattern(r) simple_intropattern(cih) := @@ -280,9 +255,7 @@ Section ssim'_homogenous_theory. Notation ss' := (@ss' E E B X). Notation ssim' := (@ssim' E E B X). - - #[global] Instance Reflexive_ss' R Reps - `{Reflexive _ R} `{Reflexive _ L} `{Reflexive _ Reps}: + #[global] Instance Reflexive_ss' R Reps `{Reflexive _ R} `{Reflexive _ L} `{Reflexive _ Reps}: Reflexive (@ss'_gen E E B X L R Reps). Proof. split; intros. @@ -301,6 +274,8 @@ Section ssim'_homogenous_theory. use_steps (1 : nat). econstructor; eauto. Qed. + (* [Transitive `C] should hold? *) + End ssim'_homogenous_theory. (*| @@ -503,8 +478,6 @@ Section Proof_Rules. apply estar_single'. Qed. - - Lemma estar_cons {G : Type -> Type} (a b c : @S G B X) l : trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> ((trans_alt ε)^* ⋅ trans_alt l) a c. @@ -927,7 +900,6 @@ Section upto. End upto. - Arguments ss_sst' {E F B X} L. Lemma ss_ss'_chain {E F B X} {L : rel (@label E X) (@label F X)} From d37b30fb51d7821844ddc1de50281aab582523dc Mon Sep 17 00:00:00 2001 From: Yannick Date: Wed, 15 Jul 2026 16:10:41 +0200 Subject: [PATCH 43/61] mon instance --- theories/Eq/SSim.v | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index 9fd557f..b19a67d 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -57,15 +57,14 @@ there for an illustration. |*) Section StrongSim. -(*| + (*| [ss L R t u]: every transition from [t] can be matched by [u] up to [L] on labels, with the resulting continuations related by [R]. |*) - Program Definition ss {E F C D : Type -> Type} {X Y : Type} - (L : lrel E F X Y) : - mon (@S E C X -> @S F D Y -> Prop) := - {| body R t u := forall l t', trans l t t' -> - exists l' u', trans l' u u' /\ R t' u' /\ L l l' + Program Definition ss {E F C D : Type -> Type} : + mon (forall X Y, lrel E F X Y -> @S E C X -> @S F D Y -> Prop) := + {| body R X Y L t u := forall l t', trans l t t' -> + exists l' u', trans l' u u' /\ R _ _ L t' u' /\ L l l' |}. Next Obligation. edestruct3 H0; eauto. From c1a53b5d0429dfc6d9b29b41c0fa13366367e587 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Wed, 15 Jul 2026 16:12:32 +0200 Subject: [PATCH 44/61] Rm some intermediate ss defs --- theories/Eq/SSimAlt.v | 132 +++--------------------------------------- 1 file changed, 9 insertions(+), 123 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index ee71fec..71173eb 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -104,22 +104,6 @@ End StrongSimAlt. Definition ssim' {E F B X} L := (gfp (@ss' E F B X L): hrel _ _). -Program Definition ss {E F B : Type -> Type} {X : Type} - (L : rel (@label E X) (@label F X)) : - mon (@SS E B X -> @SS F B X -> Prop) := - {| body R t u := - forall t' l, l <> ε -> ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t' -> - exists l' u', ((trans_alt (B:=B) ε)^* ⋅ trans_alt l') u u' /\ R t' u' /\ L l l' - |}. -Next Obligation. - destruct (H0 _ _ H1 H2) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - - assumption. - - now apply H. - - assumption. -Qed. - -Definition ssim {E F B X} L := (gfp (@ss E F B X L) : hrel _ _). (* todo: remove this and rewrite using simple proper instances *) Variant Seq_clos_body {E F B X} (R : rel (@S E B X) (@S F B X)) : rel (@S E B X) (@S F B X) := @@ -891,92 +875,9 @@ Section upto. eapply step_ss'_epsilon_r; [ exact HSS | exact STAR ]. Qed. - Lemma ss_sst' {c : Chain (@ss' E F B X L)} : - forall x y, ss L `c x y -> `c x y. - Proof. - apply tower. - - intros ? INC x y HSS ? ?; red. - apply INC; auto. - intros t' l Hne TR. - destruct (HSS _ _ Hne TR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - + assumption. - + apply leq_infx in H; now apply H. - + assumption. - - clear; intros R IH t u HSS; split. - + intros t' l Hne TR. - assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t') - by (apply trans_star_l; exact TR). - destruct (HSS _ _ Hne cTR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - * assumption. - * now apply (b_chain R). - * assumption. - + intros t' TR. - exists u; split. - * apply trans_star_self. - * apply IH; intros t'' l Hne cTR. - assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') - by (eapply estar_cons; [exact TR | exact cTR]). - destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - -- assumption. - -- now apply (b_chain R). - -- assumption. - Qed. - End upto. -Arguments ss_sst' {E F B X} L. - -Lemma ss_ss'_chain {E F B X} {L : rel (@label E X) (@label F X)} - {R : Chain (@ss' E F B X L)} : - forall (t : @SS E B X) (u : @SS F B X), - ss L `R t u -> ss' L `R t u. -Proof. - intros t u HSS; split. - - intros t' l Hne TR. - assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t') - by (apply trans_star_l; exact TR). - destruct (HSS _ _ Hne cTR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit; assumption. - - intros t' TR. - exists u; split. - + apply trans_star_self. - + apply ss_sst'; intros t'' l Hne cTR. - assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') - by (eapply estar_cons; [exact TR | exact cTR]). - destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit; assumption. -Qed. - -Theorem ssim_ssim' {E F B X} (L : rel (@label E X) (@label F X)) : - forall (t : @SS E B X) (u : @SS F B X), ssim L t u <-> ssim' L t u. -Proof. - split; intro H. - - revert t u H; unfold ssim'; coinduction R CH; intros t u H. - apply ss_ss'_chain. - intros t' l Hne TR. - step in H. - destruct (H _ _ Hne TR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - + assumption. - + apply CH, HR. - + assumption. - - revert t u H; unfold ssim; coinduction R CH; intros t u H. - intros t' l Hne TR. - destruct TR as [m STAR STEP]. - eapply ssim'_epsilon_l in H; [| exact STAR]. - step in H. - destruct H as (Hchal & _). - destruct (Hchal _ _ Hne STEP) as (l' & u' & RESP & Hgfp & HL). - exists l', u'; ssplit. - + assumption. - + apply CH, Hgfp. - + assumption. -Qed. - #[local] Example ssim'_spin {E F B X} (L : rel (@label E X) (@label F X)) : forall (u : @SS F B X), ssim' L (Active (@spin E B X)) u. Proof. @@ -1082,23 +983,6 @@ Proof. * apply IHn; exact REST. Qed. -Lemma ssim_eps_l {E F B X} (L : rel (@label E X) (@label F X)) - (t t1 : @SS E B X) (u : @SS F B X) : - ssim L t u -> trans_alt ε t t1 -> ssim L t1 u. -Proof. - intros H TR. - unfold ssim in *. - step in H. - apply (b_chain (chain_gfp (ss L))). - intros t' l Hne cTR. - destruct cTR as [m STAR STEP]. - assert (cTR2 : ((trans_alt ε)^* ⋅ trans_alt l) t t'). - { exists m. - - eapply estar_cons0; [exact TR | exact STAR]. - - exact STEP. } - destruct (H _ _ Hne cTR2) as (l' & u' & RESP & HR & HL). - exists l', u'; ssplit; assumption. -Qed. Section bind_restore. @@ -1111,7 +995,7 @@ Section bind_restore. Lemma bind_chain_gen {R : Chain (@ss' E F B X' L)} : forall (t : ctree E B X) (t' : ctree F B X) (k : X -> ctree E B X') (k' : X -> ctree F B X'), - ssim uvr (Active t) (Active t') -> + ssim' uvr (Active t) (Active t') -> (forall x x', R0 x x' -> ` R (Active (k x)) (Active (k' x'))) -> ` R (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. @@ -1127,12 +1011,14 @@ Section bind_restore. | [ (-> & t1 & TRt & SQ) | [ (Heps & _) | (Z & e & g & -> & TRt & SQ) ]]]. - * assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val x)) - (Active t) (Active (Stuck : ctree E B X))). - { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } - step in tt. - assert (HneV : (val x : @label E X) <> ε) by discriminate. - destruct (tt _ _ HneV cV) as (l2 & n & RESP & _ & HL2). + (* t ≅ Ret, show t' steps to Stuck as well *) + * assert (cV : trans_alt (val x) + (Active t) (Active (Stuck : ctree E B X))) by now constructor. + step in tt; repeat red in tt; destruct tt as [tt_nonep tt_ep]. + (* know cV reduced *) + assert (HneV : (val x : @label E X) <> ε) by easy. + (* take the nonep branch *) + destruct (tt_nonep _ _ HneV cV) as (l2 & n & RESP & _ & HL2). apply update_val_rel_val_l in HL2 as (x' & -> & Hx). destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. From 053cb7a463d1a6d8e8f2f5f1004c0c9ff66ce436 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Wed, 15 Jul 2026 16:56:12 +0200 Subject: [PATCH 45/61] Push lrel under ss' mon --- theories/Eq/SSimAlt.v | 95 ++++++++++++++++++------------------------- 1 file changed, 39 insertions(+), 56 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 1b1e433..1289160 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -6,7 +6,6 @@ From Stdlib Require Import Program.Equality Logic.Eqdep. -From Coinduction Require Import all. From ITree Require Import Core.Subevent. @@ -19,6 +18,7 @@ From CTree Require Import From RelationAlgebra Require Export monoid kat kat_tac rel srel. +From Coinduction Require Import all. Import CoindNotations. Import CTree. @@ -28,71 +28,54 @@ Ltac ssplit := split; [| split]. Section StrongSimAlt. - (* TODO: Make it heterogeneous, propagate the use of lrel *) - (* Definition ss'_gen {E F B : Type -> Type} {X : Type} *) - (* (L : lrel E F X X) *) - (* (R Reps : rel SS SS) *) - (* (t : SS) (u : SS) := *) - - (* (forall t' l, l <> ε -> trans_alt (B:=B) l t t' *) - (* -> exists l' u', ((trans_alt (B:=B) ε)^* ⋅ (trans_alt l')) u u' /\ R t' u' /\ L l l') *) - (* /\ *) - (* (forall t', trans_alt (B:=B) ε t t' -> exists u', (trans_alt (B:=B) ε)^* u u' /\ Reps t' u'). *) - - Definition ss'_gen {E F B : Type -> Type} {X : Type} - (L : rel (@label E X) (@label F X)) - (R Reps : rel SS SS) - (t : SS) (u : SS) := - - (forall t' l, l <> ε -> trans_alt (B:=B) l t t' - -> exists l' u', ((trans_alt (B:=B) ε)^* ⋅ (trans_alt l')) u u' /\ R t' u' /\ L l l') + (*| +An alternative definition [ss'] of strong simulation. +The simulation challenge does not involve an inductive transition relation, +thus simplifying proofs. +|*) + +Definition ss'_gen {E F C D : Type -> Type} +(R Reps : (forall X Y, lrel E F X Y -> @S E C X -> @S F D Y -> Prop)) +(X Y : Type) (L : lrel E F X Y) (t: @S E C X) (u: @S F D Y) := + (forall t' l, l <> ε -> trans_alt (B:=C) l t t' + -> exists l' u', ((trans_alt (B:=D) ε)^* ⋅ (trans_alt l')) u u' /\ R X Y L t' u' /\ L l l') /\ - (forall t', trans_alt (B:=B) ε t t' -> exists u', (trans_alt (B:=B) ε)^* u u' /\ Reps t' u'). + (forall t', trans_alt (B:=C) ε t t' -> exists u', (trans_alt (B:=D) ε)^* u u' /\ Reps X Y L t' u'). + + Program Definition ss' {E F C D : Type -> Type} : + mon (forall (X Y : Type), + lrel E F X Y -> (* L *) + @S E C X -> (* t *) + @S F D Y -> (* u *) + Prop) := + {| body R := ss'_gen R R + |}. +Next Obligation. +Proof. + split; intros; destruct H0. + - destruct (H0 _ _ H1 H2) as (l'' & u'' & Htrans & HRtu & HL'). + eauto 12. + - apply H2 in H1 as (u' & Htrans & HRtu). eauto. + Qed. - #[global] Instance weq_ss'_gen {E F B X} : - Proper (weq ==> weq) (@ss'_gen E F B X). + #[global] Instance weq_ss' {E F C D} : + Proper (weq ==> weq) (@ss' E F C D). Proof. cbn. intros L L' HL R x y; split; intros (HA & HB); split; intros. - destruct (HA _ _ H H0) as (l'' & u'' & Htrans & HR & HL'). - do 2 esplit; split; [eassumption | split; [eassumption |]]; now apply HL. - - now apply HB in H. + do 2 esplit; split; eauto. split; [now apply HL | assumption]. + - apply HB in H as (u' & Htr & HL_). + exists u'; split; auto. now apply HL. - destruct (HA _ _ H H0) as (l'' & u'' & Htrans & HR & HL'). - do 2 esplit; split; [eassumption | split; [eassumption |]]; now apply HL. - - now apply HB in H. - Qed. - - #[global] Instance ss'_gen_mon {E F B X} - (L : rel (@label E X) (@label F X)) : - Proper (Coinduction.lattice.leq ==> Coinduction.lattice.leq ==> Coinduction.lattice.leq) - (@ss'_gen E F B X L). - Proof. - cbn. intros R R' HR Reps1 Reps2 HReps s1 s2 [Hl Hep]; split; intros. - - destruct (Hl _ _ H H0) as (l'' & u'' & Htrans & HRtu & HL'). - do 2 esplit; split; [eassumption | split; [now apply HR | assumption]]. - - apply Hep in H as (u' & Htrans & HRtu). exists u'; split; [assumption | now apply HReps]. - Qed. - - (*| -An alternative definition [ss'] of strong simulation. -The simulation challenge does not involve an inductive transition relation, -thus simplifying proofs. -|*) - Program Definition ss' {E F B : Type -> Type} {X : Type} - (L : rel (@label E X) (@label F X)) : - mon (SS -> SS -> Prop) := - {| body R t u := - @ss'_gen E F B X L R R t u - |}. - Next Obligation. - epose proof (@ss'_gen_mon E F B X). eapply H1. - 3: apply H0. - all: auto. + do 2 esplit; split; eauto. split; [now apply HL | assumption]. + - apply HB in H as (u' & Htr & HL_). + exists u'; split; auto. now apply HL. Qed. End StrongSimAlt. -Definition ssim' {E F B X} L := - (gfp (@ss' E F B X L): hrel _ _). +Definition ssim' {E F C D X Y} L := + (gfp (@ss' E F C D) X Y L : hrel _ _). (* TODO: remove this and rewrite using simple proper instances *) From 19810c561d31129bf1d18ecac80fdcfc89948e53 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Wed, 15 Jul 2026 21:35:02 +0200 Subject: [PATCH 46/61] Progress on global fixes to SSimAlt --- theories/Eq/SSimAlt.v | 179 ++++++++++++++++++------------------------ 1 file changed, 78 insertions(+), 101 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 1289160..fe2a8b7 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -35,20 +35,20 @@ thus simplifying proofs. |*) Definition ss'_gen {E F C D : Type -> Type} -(R Reps : (forall X Y, lrel E F X Y -> @S E C X -> @S F D Y -> Prop)) +(R Reps : (forall [X Y], lrel E F X Y -> @S E C X -> @S F D Y -> Prop)) (X Y : Type) (L : lrel E F X Y) (t: @S E C X) (u: @S F D Y) := (forall t' l, l <> ε -> trans_alt (B:=C) l t t' - -> exists l' u', ((trans_alt (B:=D) ε)^* ⋅ (trans_alt l')) u u' /\ R X Y L t' u' /\ L l l') + -> exists l' u', ((trans_alt (B:=D) ε)^* ⋅ (trans_alt l')) u u' /\ R L t' u' /\ L l l') /\ - (forall t', trans_alt (B:=C) ε t t' -> exists u', (trans_alt (B:=D) ε)^* u u' /\ Reps X Y L t' u'). + (forall t', trans_alt (B:=C) ε t t' -> exists u', (trans_alt (B:=D) ε)^* u u' /\ Reps L t' u'). Program Definition ss' {E F C D : Type -> Type} : mon (forall (X Y : Type), lrel E F X Y -> (* L *) - @S E C X -> (* t *) - @S F D Y -> (* u *) - Prop) := - {| body R := ss'_gen R R + hrel (@S E C X) (* t *) + (@S F D Y) (* u *) + ) := + {| body R := ss'_gen R R (* simulation: R and Reps are the same relation *) |}. Next Obligation. Proof. @@ -77,101 +77,73 @@ End StrongSimAlt. Definition ssim' {E F C D X Y} L := (gfp (@ss' E F C D) X Y L : hrel _ _). - -(* TODO: remove this and rewrite using simple proper instances *) -Variant Seq_clos_body {E F B X} (R : rel (@S E B X) (@S F B X)) : rel (@S E B X) (@S F B X) := - | Seq_clos_intro : forall t t' u' u - (Seqt : t ⩸ t') - (HR : R t' u') - (Sequ : u' ⩸ u), - Seq_clos_body R t u. - -Program Definition Seq_clos {E F B X} : mon (rel (@S E B X) (@S F B X)) := - {| body := @Seq_clos_body E F B X |}. -Next Obligation. - match goal with h : Seq_clos_body _ _ _ |- _ => inv h end. - econstructor; eauto. -Qed. - Section ssim'_theory. Arguments label: clear implicits. - Context {E F B: Type -> Type} {X : Type} - {L: rel (@label E X) (@label F X)}. + Context {E F C D: Type -> Type} {X Y : Type} + {R: forall X Y, lrel E F X Y -> rel (@S E C X) (@S F D Y)} + {L: lrel E F X Y}. (*| Strong simulation up-to [equ] is valid ---------------------------------------- |*) - #[global] Instance Seq_ss'_gen_goal {R Reps} : - Proper (Seq ==> Seq ==> flip impl) (@ss'_gen E F B X L R Reps). - Proof. - intros t t' EQt u u' EQu (HA & HB); split. - - intros t'' l Hl TR. rewrite EQt in TR. - apply HA in TR as (l' & u'' & STEP & HRtu & HL); auto. - exists l', u''; split; [| split; assumption]. - now rewrite EQu. - - intros t'' TR. rewrite EQt in TR. - apply HB in TR as (u'' & STEP & HRtu). - exists u''; split; [| assumption]. - now rewrite EQu. - Qed. - #[global] Instance Seq_ss'_gen_ctx {R Reps} : - Proper (Seq ==> Seq ==> impl) (@ss'_gen E F B X L R Reps). + #[global] Instance Seq_proper_ss'_chain_goal {c: Chain (@ss' E F C D)} : + Proper (Seq ==> Seq ==> flip impl) (`c X Y L). Proof. - intros t t' EQt u u' EQu H. now rewrite <- EQt, <- EQu. + do 5 red. + apply tower. + - intros T HT a b Hseq x y Hseq2 Hinf i Hi. red. eapply HT; eauto. + now apply Hinf. + - clear c; intros c CIH x y Hseq x' y' Hseq2 [Hnonep Hep]. + split; intros. + + rewrite Hseq in H0. destruct (Hnonep _ _ H H0) as + (l' & u' & Htr & Hc & HL). rewrite <- Hseq2 in Htr. + exists l', u'; split; eauto. + + rewrite Hseq in H. apply Hep in H as (u' & Htr & Hc). + rewrite <- Hseq2 in Htr. + exists u'; split; eauto. Qed. - Lemma Seq_clos_sst' {c: Chain (@ss' E F B X L)}: - forall x y, Seq_clos `c x y -> `c x y. + #[global] Instance Seq_proper_ss'_chain_ctx {c: Chain (@ss' E F C D)} : + Proper (Seq ==> Seq ==> impl) (`c X Y L). Proof. - apply tower. - - intros ? INC x y [t t' u' u EQt HR EQu] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - intros R IH x y [t t' u' u EQt HR EQu]. - eapply Seq_ss'_gen_goal; [ exact EQt | symmetry; exact EQu | exact HR ]. - Qed. - - #[global] Instance Seq_clos_sst_goal {c: Chain (@ss' E F B X L)} : - Proper (Seq ==> Seq ==> flip impl) `c. - Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply Seq_clos_sst'; econstructor; [eauto | | symmetry; eauto]; assumption. + do 4 red. + apply tower. + - intros T HT a b Hseq x y Hseq2 Hinf i Hi. red. eapply HT; eauto. + now apply Hinf. + - clear c; intros c CIH x y Hseq x' y' Hseq2 [Hnonep Hep]. + split; intros. + + rewrite <- Hseq in H0. destruct (Hnonep _ _ H H0) as + (l' & u' & Htr & Hc & HL). rewrite Hseq2 in Htr. + exists l', u'; split; eauto. + + rewrite <- Hseq in H. apply Hep in H as (u' & Htr & Hc). + rewrite Hseq2 in Htr. + exists u'; split; eauto. Qed. - #[global] Instance Seq_clos_sst'_ctx {c: Chain (@ss' E F B X L)} : - Proper (Seq ==> Seq ==> impl) `c. - Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply Seq_clos_sst'; econstructor; [symmetry; eauto | | eauto]; assumption. - Qed. - #[global] Instance Seq_clos_ssim'_goal : Proper (Seq ==> Seq ==> flip impl) (@ssim' E F B X L). + #[global] Instance Seq_proper_ssim'_goal : Proper (Seq ==> Seq ==> flip impl) (@ssim' E F C D X Y L). Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply Seq_clos_sst'; econstructor; eauto; now symmetry. + exact (@Seq_proper_ss'_chain_goal (chain_gfp (@ss' E F C D))). Qed. - #[global] Instance Seq_clos_ssim'_ctx : Proper (Seq ==> Seq ==> impl) (@ssim' E F B X L). + #[global] Instance Seq_proper_ssim'_ctx : Proper (Seq ==> Seq ==> impl) (@ssim' E F C D X Y L). Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - now rewrite <- eq1, <- eq2. + exact (@Seq_proper_ss'_chain_ctx (chain_gfp (@ss' E F C D))). Qed. - Lemma ss'_gen_epsilon_star {R : rel (@S E B X) (@S F B X)} : - forall (t t' : @S E B X) (u : @S F B X), - ss'_gen L R R t u -> + Lemma ss'_gen_epsilon_star : + forall (t t' : @S E C X) (u : @S F D Y), + ss'_gen R R L t u -> trans_alt ε t t' -> - exists u', (trans_alt ε)^* u u' /\ R t' u'. + exists u', (trans_alt ε)^* u u' /\ R L t' u'. Proof. intros * (_ & H); apply H. Qed. Lemma trans_alt_estar_l {G : Type -> Type} : - forall (t t' : @S G B X) l, + forall (t t' : @S G C X) l, trans_alt l t t' -> ((trans_alt ε)^* ⋅ trans_alt l) t t'. Proof. @@ -183,28 +155,28 @@ End ssim'_theory. Ltac fold_ssim' := repeat match goal with - | h: context[gfp (@ss' ?E ?F ?B ?X ?L)] |- _ => - fold (@ssim' E F B X L) in h - | |- context[gfp (@ss' ?E ?F ?B ?X ?L)] => - fold (@ssim' E F B X L) + | h: context[gfp (@ss' ?E ?F ?C ?D ?X ?Y ?L)] |- _ => + fold (@ssim' E F C D X Y L) in h + | |- context[gfp (@ss' ?E ?F ?C ?D ?X ?Y ?L)] => + fold (@ssim' E F C D X Y L) end. Tactic Notation "__step_ssim'" := match goal with - | |- context[@ssim' ?E ?F ?B ?X ?L] => + | |- context[@ssim' ?E ?F ?C ?D ?X ?Y ?L] => unfold ssim'; - step; - fold (@ssim' E F B X L) + apply (pfp_gfp (@ss' E F C D)); + fold (@ssim' E F C D X Y L) end. Tactic Notation "step" := __step_ssim' || step. Ltac __step_in_ssim' H := match type of H with - | context[@ssim' ?E ?F ?B ?X ?L] => + | context[@ssim' ?E ?F ?C ?D ?X ?Y ?L] => unfold ssim' in H; - step in H; - fold (@ssim' E F B X L) in H + apply (gfp_pfp (@ss' E F C D)); + fold (@ssim' E F C D X Y L) in H end. Tactic Notation "step" "in" ident(H) := __step_in_ssim' H || step in H. @@ -215,14 +187,15 @@ Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := Import CTreeNotations. Import EquNotations. Section ssim'_homogenous_theory. - Context {E B: Type -> Type} {X: Type} - {L: relation (@label E X)}. + Context {E F C D : Type -> Type} {X Y: Type} + {L: lrel E E X X} + {R Reps: forall X Y : Type, lrel E E X Y -> rel (S E C X) (S E C Y)}. - Notation ss' := (@ss' E E B X). - Notation ssim' := (@ssim' E E B X). + Notation ss' := (@ss' E E C C). + Notation ssim' := (@ssim' E E C C X X). - #[global] Instance Reflexive_ss' R Reps `{Reflexive _ R} `{Reflexive _ L} `{Reflexive _ Reps}: - Reflexive (@ss'_gen E E B X L R Reps). + #[global] Instance Reflexive_ss' `{Reflexive _ (R L)} `{Reflexive _ (Reps L)} `{Reflexive _ L}: + Reflexive (@ss'_gen E E C C R Reps X X L). Proof. split; intros. exists l, t'. split; auto. @@ -231,9 +204,10 @@ Section ssim'_homogenous_theory. use_steps (1 : nat). econstructor; eauto. Qed. - #[global] Instance refl_ss' {LR: Reflexive L} {C: Chain (ss' L)}: Reflexive `C. + #[global] Instance refl_ss' {LR: Reflexive L} {c: Chain (ss')}: Reflexive (`c X X L). Proof. - apply Reflexive_chain. + (* of note: Reflexive chain fails here because elem has arguments.. we should fix that. *) + tower induction. (* it works! sometimes *) split; intros. - do 2 eexists. split. use_steps O. apply H1. now split. - exists t'; split; auto. @@ -249,25 +223,28 @@ Parametric theory of [ss] with heterogenous [L] |*) Section ssim'_heterogenous_theory. Arguments label: clear implicits. - Context {E F B: Type -> Type} {X: Type} - {L: rel (@label E X) (@label F X)}. + Context {E F C D : Type -> Type} {X Y : Type} + {L: lrel E F X Y}. - Notation ss' := (@ss' E F B X). - Notation ssim' := (@ssim' E F B X). + (* Notation ss' := (@ss' E F C D). + Notation ssim' := (@ssim' E F C D X Y). *) (*| stuck ctrees can be simulated by anything. |*) Lemma ss'_stuck R Reps : - forall (u : @S F B X), - ss'_gen L R Reps (Stuck : ctree E B X) u. + forall (u : @S F D Y), + ss'_gen R Reps L (Stuck : ctree E C X) u. Proof. split; intros; exfalso; eapply trans_stuck_inv; eassumption. Qed. - Lemma ssim'_stuck (t : @S F B X) : ssim' L (Stuck : ctree E B X) t. + Lemma ssim'_stuck (t : @S F D Y) : ssim' L (Stuck : ctree E C X) t. Proof. - intros. step. apply ss'_stuck. + (* todo: step doesn't work here: the type of sub_bChain seems to demand + the two trees have the same type, which is too restrictive. *) + Fail (red; Coinduction.tactics.step). + step. apply ss'_stuck. Qed. End ssim'_heterogenous_theory. From 10fc3ee81aab6c967afbc8bed63b538d4b3a23d6 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 16 Jul 2026 14:58:00 +0200 Subject: [PATCH 47/61] More type fixes --- theories/Eq/SSimAlt.v | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index fe2a8b7..336ec60 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -269,23 +269,23 @@ Ltac __eplay_ssim' := Section Proof_Rules. Arguments label: clear implicits. - Context {E F B : Type -> Type} - {X : Type} - {L : rel (@label E X) (@label F X)} - {R Reps : rel (@S E B X) (@S F B X)} - {HR : (Proper (Seq ==> Seq ==> impl) R)} - {HReps : (Proper (Seq ==> Seq ==> impl) Reps)}. + Context {E F C D : Type -> Type} + {X Y : Type} + {L : lrel E F X Y} + {R Reps : (forall X Y : Type, lrel E F X Y -> rel (S E C X) (S F D Y))} + {HR : (Proper (Seq ==> Seq ==> impl) (R X Y L))} + {HReps : (Proper (Seq ==> Seq ==> impl) (Reps X Y L))}. Lemma step_ss'_stuck : - ss'_gen L R Reps (Stuck : ctree E B X) (Stuck : ctree F B X). + ss'_gen R Reps L (Stuck : ctree E C X) (Stuck : ctree F D Y). Proof. split; intros; exfalso; eapply trans_stuck_inv; eassumption. Qed. - Lemma step_ss'_ret (x : X) (y : X) : - R Stuck Stuck -> + Lemma step_ss'_ret (x : X) (y : Y) : + R L Stuck Stuck -> L (val x) (val y) -> - ss'_gen L R Reps (Ret x : ctree E B X) (Ret y : ctree F B X). + ss'_gen R Reps L (Ret x : ctree E C X) (Ret y : ctree F D Y). Proof. intros Rstuck Lval. split. - intros t' l Hl TR. apply trans_ret_inv' in TR as (EQ & ->). From 207648d114aaae6fb4af733c8879d1110ccaf4b0 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 16 Jul 2026 23:34:25 +0200 Subject: [PATCH 48/61] Revert ssim to before --- theories/Eq/SSim.v | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index b19a67d..cc049b1 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -61,10 +61,11 @@ Section StrongSim. [ss L R t u]: every transition from [t] can be matched by [u] up to [L] on labels, with the resulting continuations related by [R]. |*) - Program Definition ss {E F C D : Type -> Type} : - mon (forall X Y, lrel E F X Y -> @S E C X -> @S F D Y -> Prop) := - {| body R X Y L t u := forall l t', trans l t t' -> - exists l' u', trans l' u u' /\ R _ _ L t' u' /\ L l l' + Program Definition ss {E F C D : Type -> Type} {X Y : Type} + (L : lrel E F X Y) : + mon (@S E C X -> @S F D Y -> Prop) := + {| body R t u := forall l t', trans l t t' -> + exists l' u', trans l' u u' /\ R t' u' /\ L l l' |}. Next Obligation. edestruct3 H0; eauto. From 136e68f377c9114d4ca2e64a983859ab6f2de74e Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Sat, 25 Jul 2026 12:03:39 +0100 Subject: [PATCH 49/61] Lots of equivalences, need cleaning --- theories/Eq/AltEquiv.v | 49 +++- theories/Eq/SSimAlt.v | 618 ++++++++++++++++++++++------------------- 2 files changed, 368 insertions(+), 299 deletions(-) diff --git a/theories/Eq/AltEquiv.v b/theories/Eq/AltEquiv.v index 68934e6..fc1d979 100644 --- a/theories/Eq/AltEquiv.v +++ b/theories/Eq/AltEquiv.v @@ -155,9 +155,31 @@ Proof. apply transR_label_base; apply STEP. Qed. -Definition lift_L {E F X} (L : Trans.lrel E F X X) - : rel (TransAlt.label E X) (TransAlt.label F X) := - fun a b => exists la lb, a = o2n_label la /\ b = o2n_label lb /\ Trans.build_rel L la lb. +Definition lift_L {E F X} (L : Trans.lrel E F X X) : TransAlt.lrel E F X X := + {| TransAlt.RR := Trans.RR L ; + TransAlt.Rask := Trans.Rask L ; + TransAlt.Rrcv := Trans.Rrcv L |}. + +(* old to new through lifting *) +Lemma lift_L_o2n {E F X} (L : Trans.lrel E F X X) + (la : Trans.label E X) (lb : Trans.label F X) : + Trans.build_rel L la lb -> + TransAlt.build_rel (lift_L L) (o2n_label la) (o2n_label lb). +Proof. + intros H; destruct H; cbn [o2n_label]; now constructor. +Qed. + +Lemma lift_L_o2n_inv {E F X} (L : Trans.lrel E F X X) + (a : TransAlt.label E X) (b : TransAlt.label F X) : + TransAlt.build_rel (lift_L L) a b -> + exists la lb, a = o2n_label la /\ b = o2n_label lb /\ Trans.build_rel L la lb. +Proof. + intros H; destruct H. + - exists Trans.τ, Trans.τ; cbn [o2n_label]; repeat split; constructor. + - exists (Trans.ask e), (Trans.ask f); cbn [o2n_label]; repeat split; now constructor. + - exists (Trans.rcv e x), (Trans.rcv f y); cbn [o2n_label]; repeat split; now constructor. + - exists (Trans.val x), (Trans.val y); cbn [o2n_label]; repeat split; now constructor. +Qed. Lemma label_non_eps_image {E X} (l : TransAlt.label E X) : l <> ε -> exists lo, l = o2n_label lo. @@ -230,7 +252,7 @@ Proof. + apply transR_o2n. apply TRb. + specialize (cih (n2o_S x) bo' Hrel). rewrite o2n_n2o_S in cih. apply cih. - + red. exists lo, lo'. tauto. + + apply lift_L_o2n; exact HL. - intros x TR. exists (o2n_S b). split. + apply trans_star_self. @@ -260,12 +282,12 @@ Proof. apply transR_o2n in oTR. destruct oTR as [m STAR STEP]. eapply SSimAlt.ssim'_epsilon_l in H. 2: apply STAR. - apply (gfp_pfp (SSimAlt.ss' (lift_L L))) in H. + apply (gfp_pfp (@SSimAlt.ss' E F B B) X X (lift_L L)) in H. destruct H as (Hchal & _). destruct (Hchal (o2n_S ao') (o2n_label l)) as (nl' & u' & RESP & Hgfp & HL). { destruct l; cbn [o2n_label]; easy. } { apply STEP. } - destruct HL as (la & lb & Hla & Hlb & HLab). + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). apply o2n_label_inj in Hla; subst la. subst nl'. exists lb, (n2o_S u'). @@ -284,3 +306,18 @@ Proof. - apply o_ssim_to_ssim' in H. apply H. - apply ssim'_to_o_ssim. apply H. Qed. + +Lemma ss'_clo_bind_eq {E B X X'} + (t t' : ctree E B X) (k k' : X -> ctree E B X') : + SSim.ssim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> + (forall x, SSimAlt.ssim' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> + SSimAlt.ssim' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). +Proof. + intros tt kk. + apply ssim_ssim' in tt. + eapply SSimAlt.ssim'_clo_bind with (SS := @eq X). + - exact tt. + - intros x x' ->; apply kk. +Qed. diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 336ec60..6dae833 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -36,7 +36,7 @@ thus simplifying proofs. Definition ss'_gen {E F C D : Type -> Type} (R Reps : (forall [X Y], lrel E F X Y -> @S E C X -> @S F D Y -> Prop)) -(X Y : Type) (L : lrel E F X Y) (t: @S E C X) (u: @S F D Y) := +{X Y : Type} (L : lrel E F X Y) (t: @S E C X) (u: @S F D Y) := (forall t' l, l <> ε -> trans_alt (B:=C) l t t' -> exists l' u', ((trans_alt (B:=D) ε)^* ⋅ (trans_alt l')) u u' /\ R L t' u' /\ L l l') /\ @@ -48,7 +48,7 @@ Definition ss'_gen {E F C D : Type -> Type} hrel (@S E C X) (* t *) (@S F D Y) (* u *) ) := - {| body R := ss'_gen R R (* simulation: R and Reps are the same relation *) + {| body R := @ss'_gen E F C D R R (* simulation: R and Reps are the same relation *) |}. Next Obligation. Proof. @@ -296,11 +296,11 @@ Section Proof_Rules. - intros t' TR. apply trans_ret_inv' in TR as (_ & abs). discriminate. Qed. - Lemma step_ss'_ret_l (x : X) (y : X) (u u' : @S F B X) : - R Stuck Stuck -> + Lemma step_ss'_ret_l (x : X) (y : Y) (u u' : @S F D Y) : + R L Stuck Stuck -> L (val x) (val y) -> trans_alt (val y) u u' -> - ss'_gen L R Reps (Ret x : ctree E B X) u. + ss'_gen R Reps L (Ret x : ctree E C X) u. Proof. intros Rstuck Lval TR. split. - intros t' l Hl TRl. apply trans_ret_inv' in TRl as (EQ & ->). @@ -318,10 +318,10 @@ Section Proof_Rules. the itree-style rule. |*) Lemma step_ss'_vis {Z Z'} (e : E Z) (f: F Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : - R (Passive e k) (Passive f k') -> + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + R L (Passive e k) (Passive f k') -> L (ask e) (ask f) -> - ss'_gen L R Reps (Vis e k) (Vis f k'). + ss'_gen R Reps L (Vis e k) (Vis f k'). Proof. intros HRpas Lask. split. - intros t' l Hl TR. apply trans_vis_inv' in TR as (EQ & ->). @@ -333,18 +333,18 @@ Section Proof_Rules. Qed. Lemma step_ss'_vis_id {Z} (e : E Z) (f: F Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : - R (Passive e k) (Passive f k') -> + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : + R L (Passive e k) (Passive f k') -> L (ask e) (ask f) -> - ss'_gen L R Reps (Vis e k) (Vis f k'). + ss'_gen R Reps L (Vis e k) (Vis f k'). Proof. intros; apply step_ss'_vis; auto. Qed. Lemma step_ss'_vis_l {Z} : - forall (e : E Z) (k : Z -> ctree E B X) (u : @S F B X), - (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R (Passive e k) u' /\ L (ask e) l') -> - ss'_gen L R Reps (Vis e k) u. + forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R L (Passive e k) u' /\ L (ask e) l') -> + ss'_gen R Reps L (Vis e k) u. Proof. intros e k u (l' & u' & STEP & HRu & Lask). split. - intros t' l Hl TR. apply trans_vis_inv' in TR as (EQ & ->). @@ -358,7 +358,7 @@ Section Proof_Rules. (*| With this definition [ss'] of simulation, delayed nodes allow to perform a coinductive step. |*) - Lemma trans_alt_br_inv {G : Type -> Type} {Z} (c : B Z) (k : Z -> ctree G B X) l u : + Lemma trans_alt_br_inv {G B : Type -> Type} {Z} (c : B Z) (k : Z -> ctree G B X) l u : trans_alt l (Br c k) u -> l = ε /\ exists x, u ⩸ (Active (k x)). Proof. intros TR; unfold trans_alt in TR; cbn in TR. @@ -369,7 +369,7 @@ Section Proof_Rules. | now rewrite EQ | now rewrite <- EQ ]. Qed. - Lemma trans_alt_guard_inv {G : Type -> Type} (t : ctree G B X) l u : + Lemma trans_alt_guard_inv {G B : Type -> Type} (t : ctree G B X) l u : trans_alt l (Guard t) u -> l = ε /\ u ⩸ (Active t). Proof. intros TR; unfold trans_alt in TR; cbn in TR. @@ -380,10 +380,10 @@ Section Proof_Rules. | now (rewrite H0; symmetry) ]. Qed. - Lemma step_ss'_br_l {Z} (c : B Z) - (k : Z -> ctree E B X) (u : @S F B X): - (forall x, Reps (Active (k x)) u) -> - ss'_gen L R Reps (Br c k) u. + Lemma step_ss'_br_l {Z} (c : C Z) + (k : Z -> ctree E C X) (u : @S F D Y): + (forall x, Reps L (Active (k x)) u) -> + ss'_gen R Reps L (Br c k) u. Proof. intros HReps'. split. - intros t' l Hl TR. apply trans_alt_br_inv in TR as (-> & _). easy. @@ -393,58 +393,58 @@ Section Proof_Rules. + rewrite EQ. apply HReps'. Qed. - Lemma estar_trans {G : Type -> Type} (a b c : @S G B X) : + Lemma estar_trans {G B : Type -> Type} {V : Type} (a b c : @S G B V) : (trans_alt ε)^* a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. Proof. intros S1 S2. - assert (H : (@trans_alt G B X ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + assert (H : (@trans_alt G B V ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. apply H; eexists; eassumption. Qed. - Lemma estar_cons0 {G : Type -> Type} (a b c : @S G B X) : + Lemma estar_cons0 {G B : Type -> Type} {V : Type} (a b c : @S G B V) : trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. Proof. intros S1 S2. - assert (H : @trans_alt G B X ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + assert (H : @trans_alt G B V ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. apply H; eexists; eassumption. Qed. - Lemma estar_single' {G : Type -> Type} : - (@trans_alt G B X ε) ≦ (trans_alt ε)^*. + Lemma estar_single' {G B : Type -> Type} {V : Type} : + (@trans_alt G B V ε) ≦ (trans_alt ε)^*. Proof. ka. Qed. - Lemma estar_single {G : Type -> Type} (a b : @S G B X) : + Lemma estar_single {G B : Type -> Type} {V : Type} (a b : @S G B V) : trans_alt ε a b -> (trans_alt ε)^* a b. Proof. apply estar_single'. Qed. - Lemma estar_cons {G : Type -> Type} (a b c : @S G B X) l : + Lemma estar_cons {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> ((trans_alt ε)^* ⋅ trans_alt l) a c. Proof. intros S1 S2. - assert (H : @trans_alt G B X ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + assert (H : @trans_alt G B V ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) ≦ (trans_alt ε)^* ⋅ trans_alt l) by ka. apply H; eexists; eassumption. Qed. - Lemma estar_app {G : Type -> Type} (a b c : @S G B X) l : + Lemma estar_app {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : (trans_alt ε)^* a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> ((trans_alt ε)^* ⋅ trans_alt l) a c. Proof. intros S1 S2. - assert (H : (@trans_alt G B X ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + assert (H : (@trans_alt G B V ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) ≦ (trans_alt ε)^* ⋅ trans_alt l) by ka. apply H; eexists; eassumption. Qed. - Lemma step_ss'_br_r {Z} (c : B Z) x - (k : Z -> ctree F B X) (t: @S E B X): - ss'_gen L R Reps t (k x) -> - ss'_gen L R Reps t (Br c k). + Lemma step_ss'_br_r {Z} (c : D Z) x + (k : Z -> ctree F D Y) (t: @S E C X): + ss'_gen R Reps L t (k x) -> + ss'_gen R Reps L t (Br c k). Proof. intros (HA & HB); split. - intros t' l Hl TR. apply HA in TR as (l' & u' & STEP & HRtu & HL); auto. @@ -455,10 +455,10 @@ Section Proof_Rules. eapply estar_cons0; [ apply trans_br | exact STEP ]. Qed. - Lemma step_ss'_br {Z Z'} (a: B Z) (b: B Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : - (forall x, exists y, Reps (k x) (k' y)) -> - ss'_gen L R Reps (Br a k) (Br b k'). + Lemma step_ss'_br {Z Z'} (a: C Z) (b: D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + (forall x, exists y, Reps L (k x) (k' y)) -> + ss'_gen R Reps L (Br a k) (Br b k'). Proof. intros HRep; split. - intros t' l Hl TR. apply trans_alt_br_inv in TR as (-> & _); easy. @@ -469,18 +469,18 @@ Section Proof_Rules. + rewrite EQ. apply HR'. Qed. - Lemma step_ss'_br_id {Z} (c: B Z) (d: B Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : - (forall x, Reps (k x) (k' x)) -> - ss'_gen L R Reps (Br c k) (Br d k'). + Lemma step_ss'_br_id {Z} (c: C Z) (d: D Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : + (forall x, Reps L (k x) (k' x)) -> + ss'_gen R Reps L (Br c k) (Br d k'). Proof. intros. apply step_ss'_br; eauto. Qed. Lemma step_ss'_guard_l - (t: ctree E B X) (u: @S F B X) : - Reps t u -> - ss'_gen L R Reps (Guard t) u. + (t: ctree E C X) (u: @S F D Y) : + Reps L t u -> + ss'_gen R Reps L (Guard t) u. Proof. intros HRep; split. - intros t' l Hl TR. apply trans_alt_guard_inv in TR as (-> & _); easy. @@ -489,9 +489,9 @@ Section Proof_Rules. Qed. Lemma step_ss'_guard_r - (t: @S E B X) (t': ctree F B X) : - ss'_gen L R Reps t t' -> - ss'_gen L R Reps t (Guard t'). + (t: @S E C X) (t': ctree F D Y) : + ss'_gen R Reps L t t' -> + ss'_gen R Reps L t (Guard t'). Proof. intros (HA & HB); split. - intros s l Hl TR. apply HA in TR as (l' & u' & STEP & HRtu & HL); auto. @@ -503,9 +503,9 @@ Section Proof_Rules. Qed. Lemma step_ss'_guard - (t: ctree E B X) (t': ctree F B X) : - Reps t t' -> - ss'_gen L R Reps (Guard t) (Guard t'). + (t: ctree E C X) (t': ctree F D Y) : + Reps L t t' -> + ss'_gen R Reps L (Guard t) (Guard t'). Proof. intros HRep; split. - intros s l Hl TR. apply trans_alt_guard_inv in TR as (-> & _); easy. @@ -516,8 +516,8 @@ Section Proof_Rules. Qed. Lemma step_ss'_epsilon_r : - forall (t : @S E B X) (u u' : @S F B X), - ss'_gen L R Reps t u' -> (trans_alt ε)^* u u' -> ss'_gen L R Reps t u. + forall (t : @S E C X) (u u' : @S F D Y), + ss'_gen R Reps L t u' -> (trans_alt ε)^* u u' -> ss'_gen R Reps L t u. Proof. intros t u u' (HA & HB) STAR; split. - intros s l Hl TR. apply HA in TR as (l' & u'' & STEP & HRtu & HL); auto. @@ -529,16 +529,19 @@ Section Proof_Rules. Qed. Lemma ss'_gen_epsilon_l : - forall (t t' : @S E B X) (u : @S F B X), - Reps <= ss'_gen L R Reps -> - ss'_gen L R Reps t u -> + forall (t t' : @S E C X) (u : @S F D Y), + (Reps L) <= ss'_gen R Reps L -> + ss'_gen R Reps L t u -> (trans_alt ε)^* t t' -> - ss'_gen L R Reps t' u. + ss'_gen R Reps L t' u. Proof. intros t t' u HRle HSS STAR. destruct STAR as [n STAR]. revert t t' u HRle HSS STAR. induction n; intros t t' u HRle HSS STAR. - - cbn in STAR. now rewrite STAR in HSS. + - cbn in STAR. + destruct HSS as (HA & HB); split. + + intros s l Hne TR. rewrite <- STAR in TR. exact (HA _ _ Hne TR). + + intros s TR. rewrite <- STAR in TR. exact (HB _ TR). - destruct STAR as [m STEP REST]. destruct HSS as (HA & HB). apply HB in STEP as (u' & STARu & HRep). @@ -551,10 +554,10 @@ Section Proof_Rules. Same goes for visible τ nodes. |*) Lemma step_ss'_step - (t : ctree E B X) (t': ctree F B X) : + (t : ctree E C X) (t': ctree F D Y) : L τ τ -> - R t t' -> - ss'_gen L R Reps (Step t) (Step t'). + R L t t' -> + ss'_gen R Reps L (Step t) (Step t'). Proof. intros Ltau HRtt; split. - intros s l Hl TR. apply trans_step_inv' in TR as (EQ & ->). @@ -566,9 +569,9 @@ Section Proof_Rules. Qed. Lemma step_ss'_step_l : - forall (t : ctree E B X) (u : @S F B X), - (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R t u' /\ L τ l') -> - ss'_gen L R Reps (Step t) u. + forall (t : ctree E C X) (u : @S F D Y), + (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R L t u' /\ L τ l') -> + ss'_gen R Reps L (Step t) u. Proof. intros t u (l' & u' & STEP & HRtu & Ltau). split. - intros s l Hl TR. apply trans_step_inv' in TR as (EQ & ->). @@ -591,17 +594,17 @@ End Proof_Rules. (* Specialized proof rules *) Lemma ssim'_stuck' {E F B X} - (L : rel _ _) : + (L : lrel _ _ _ _) : ssim' L (Stuck : ctree E B X) (Stuck : ctree F B X). Proof. step. apply step_ss'_stuck. Qed. -Lemma step_ssbt'_ret {E F B X} - (x : X) (y : X) (L : rel _ _) - {R : Chain (@ss' E F B X L)} : +Lemma step_ssbt'_ret {E F C D X Y} + (x : X) (y : Y) (L : lrel _ _ _ _) + {R : Chain (@ss' E F C D)} : L (val x) (val y) -> - ss' L `R (Ret x : ctree E B X) (Ret y : ctree F B X). + ss' `R X Y L (Ret x : ctree E C X) (Ret y : ctree F D Y). Proof. intros. unshelve eapply step_ss'_ret; eauto. @@ -609,7 +612,7 @@ Proof. Qed. Lemma ssim'_ret {E F B X} - (x : X) (y : X) (L : rel _ _) : + (x : X) (y : X) (L : lrel _ _ _ _) : L (val x) (val y) -> ssim' L (Ret x : ctree E B X) (Ret y : ctree F B X). Proof. @@ -617,7 +620,7 @@ Proof. Qed. Lemma ssim'_step {E F B X} - (t : ctree E B X) (u : ctree F B X) (L : rel _ _) : + (t : ctree E B X) (u : ctree F B X) (L : lrel _ _ _ _) : L τ τ -> ssim' L t u -> ssim' L (Step t) (Step u). @@ -626,7 +629,7 @@ Proof. Qed. Lemma ssim'_guard {E F B X} - (t : ctree E B X) (u : ctree F B X) (L : rel _ _) : + (t : ctree E B X) (u : ctree F B X) (L : lrel _ _ _ _) : ssim' L t u -> ssim' L (Guard t) (Guard u). Proof. @@ -651,13 +654,14 @@ Proof. now intros; step; apply step_ss'_br_id. Qed. -Lemma step_ssbt'_brS {E F B X Z Z'} {L} - {R : Chain (@ss' E F B X L)} - (c: B Z) (d: B Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : +Lemma step_ssbt'_brS {E F C D X Y Z Z'} + {L : lrel _ _ _ _} + {R : Chain (@ss' E F C D)} + (c: C Z) (d: D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : L τ τ -> - (forall x, exists y, `R (k x) (k' y)) -> - ss' L `R (BrS c k) (BrS d k'). + (forall x, exists y, `R X Y L (k x) (k' y)) -> + ss' `R X Y L (BrS c k) (BrS d k'). Proof. intros. apply step_ss'_br; auto. @@ -665,32 +669,35 @@ Proof. apply (b_chain R), step_ss'_step; auto. Qed. -Lemma ssim'_brS {E F B X Z Z'} {L} - (c: B Z) (d: B Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : +Lemma ssim'_brS {E F C D X Y Z Z'} + {L : lrel _ _ _ _} + {R : Chain (@ss' E F C D)} + (c: C Z) (d: D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : L τ τ -> (forall x, exists y, ssim' L (k x) (k' y)) -> ssim' L (BrS c k) (BrS d k'). Proof. - now intros; step; apply step_ssbt'_brS. + intros; step; now apply step_ssbt'_brS. Qed. -Lemma step_ssbt'_brS_id {E F B X Z} {L} - {R : Chain (@ss' E F B X L)} - (c: B Z) (d: B Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : +Lemma step_ssbt'_brS_id {E F C D X Y Z} + {L : lrel _ _ _ _} + {R : Chain (@ss' E F C D)} + (c: C Z) (d: D Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : L τ τ -> - (forall x, ` R (k x) (k' x)) -> - ss' L `R (BrS c k) (BrS d k'). + (forall x, ` R X Y L (k x) (k' x)) -> + ss' `R X Y L (BrS c k) (BrS d k'). Proof. intros. apply step_ss'_br_id; auto. intros; apply (b_chain R), step_ss'_step; auto. Qed. -Lemma ssim'_brS_id {E F B X Z} {L} - (c: B Z) (d: B Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : +Lemma ssim'_brS_id {E F C D X Y Z} {L : lrel _ _ _ _} + (c: C Z) (d: D Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : L τ τ -> (forall x, ssim' L (k x) (k' x)) -> ssim' L (BrS c k) (BrS d k'). @@ -699,9 +706,9 @@ Proof. Qed. Lemma ssim'_vis - {E F B X Z Z'} {L} + {E F C D X Y Z Z'} {L : lrel _ _ _ _} (e: E Z) (f: F Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : ssim' L (Passive e k) (Passive f k') -> L (ask e) (ask f) -> ssim' L (Vis e k) (Vis f k'). @@ -710,9 +717,9 @@ Proof. Qed. Lemma ssim'_vis_id - {E F B X Z} {L} + {E F C D X Y Z} {L : lrel _ _ _ _} (e: E Z) (f: F Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : ssim' L (Passive e k) (Passive f k') -> L (ask e) (ask f) -> ssim' L (Vis e k) (Vis f k'). @@ -721,48 +728,48 @@ Proof. Qed. Lemma ssim'_vis_l - {E F B X Z} {L} + {E F C D X Y Z} {L : lrel _ _ _ _} (e: E Z) - (k : Z -> ctree E B X) (u : @S F B X) : + (k : Z -> ctree E C X) (u : @S F D Y) : (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ ssim' L (Passive e k) u' /\ L (ask e) l') -> ssim' L (Vis e k) u. Proof. intros H; step; apply step_ss'_vis_l; exact H. Qed. -Lemma ssim'_epsilon_l {E F B X} {L} : - forall (t t' : @S E B X) (u : @S F B X), +Lemma ssim'_epsilon_l {E F C D X Y} {L : lrel _ _ _ _} : + forall (t t' : @S E C X) (u : @S F D Y), ssim' L t u -> (trans_alt ε)^* t t' -> ssim' L t' u. Proof. intros. step. eapply ss'_gen_epsilon_l. (* blessed postfixpoint *) - - exact (gfp_pfp (ss' L)). + - exact (gfp_pfp (@ss' E F C D) X Y L). - step in H. apply H. - apply H0. Qed. Section Inversion_Rules. - Context {E F B : Type -> Type} - {X : Type} - {L : rel (@label E X) (@label F X)} - {R Reps : rel (@S E B X) (@S F B X)}. + Context {E F C D : Type -> Type} + {X Y : Type} + {L : lrel E F X Y} + {R Reps : forall X Y : Type, lrel E F X Y -> rel (@S E C X) (@S F D Y)}. Lemma ss'_vis_l_inv {Z} : - forall (e : E Z) (k : Z -> ctree E B X) (u : @S F B X), - ss'_gen L R Reps (Vis e k) u -> - exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R (Passive e k) u' /\ L (ask e) l'. + forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), + ss'_gen R Reps L (Vis e k) u -> + exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R L (Passive e k) u' /\ L (ask e) l'. Proof. intros e k u (HA & _). apply (HA (Passive e k) (ask e)); [ discriminate | apply trans_ask ]. Qed. Lemma ss'_step_l_inv : - forall (t : ctree E B X) (u : @S F B X), - ss'_gen L R Reps (Step t) u -> - exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R t u' /\ L τ l'. + forall (t : ctree E C X) (u : @S F D Y), + ss'_gen R Reps L (Step t) u -> + exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R L t u' /\ L τ l'. Proof. intros t u (HA & _). apply (HA (Active t) τ); [ discriminate | apply trans_step ]. @@ -780,37 +787,37 @@ Definition epsilon_det_ctx {E B X} (R : ctree E B X -> Prop) Section upto. - Context {E F B : Type -> Type} {X : Type} - (L : rel (@label E X) (@label F X)). + Context {E F C D : Type -> Type}. (* Up-to epsilon *) #[local] Obligation Tactic := idtac. - Program Definition epsilon_ctx_r : mon (rel (@S E B X) (@S F B X)) - := {| body R t u := exists u', (trans_alt ε)^* u u' /\ R t u' |}. + Program Definition epsilon_ctx_r : + mon (forall X Y, lrel E F X Y -> hrel (@S E C X) (@S F D Y)) + := {| body R := fun X Y L t u => exists u', (trans_alt ε)^* u u' /\ R X Y L t u' |}. Next Obligation. - intros R R' HR t u (u' & STAR & HRtu). + intros R R' HR X Y L t u (u' & STAR & HRtu). exists u'; split; [ exact STAR | now apply HR ]. Qed. - Lemma epsilon_ctx_r_sst' {c: Chain (@ss' E F B X L)}: - forall x y, epsilon_ctx_r `c x y -> `c x y. + Lemma epsilon_ctx_r_sst' {c: Chain (@ss' E F C D)}: + forall X Y L x y, epsilon_ctx_r `c X Y L x y -> `c X Y L x y. Proof. apply tower. - - intros ? INC x y (? & ? & ?) ??; red. + - intros ? INC X Y L x y (? & ? & ?) ??; red. apply INC; auto. eexists; split; eauto. apply leq_infx in H1. now apply H1. - clear. - intros R IH t u (u' & STAR & HSS). + intros R IH X Y L t u (u' & STAR & HSS). eapply step_ss'_epsilon_r; [ exact HSS | exact STAR ]. Qed. End upto. -#[local] Example ssim'_spin {E F B X} (L : rel (@label E X) (@label F X)) : +#[local] Example ssim'_spin {E F B X} (L : lrel E F X X) : forall (u : @SS F B X), ssim' L (Active (@spin E B X)) u. Proof. unfold ssim'; coinduction R CH; intros u. @@ -916,157 +923,207 @@ Proof. Qed. +Definition Sbind {E B X Y} (s : @S E B X) (k : X -> ctree E B Y) : @S E B Y := + match s with + | Active t => Active (x <- t;; k x) + | Passive e g => Passive e (fun z => x <- g z;; k x) + end. + +Lemma estar_active {E B X} (t : ctree E B X) (u : @S E B X) : + (trans_alt ε)^* (Active t) u -> exists u0 : ctree E B X, u ⩸ (Active u0). +Proof. + intros [n STAR]; revert t STAR; induction n; intros t STAR. + - cbn in STAR; dependent destruction STAR. eexists; reflexivity. + - destruct STAR as [mid STEP REST]. + unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. + + eapply IHn; exact REST. + + eapply IHn; exact REST. +Qed. + +Lemma Sbind_Seq {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : + s ⩸ u -> (Sbind s k) ⩸ (Sbind u k). +Proof. + intros EQ; destruct EQ; cbn; constructor. + - now rewrite EQ. + - intros; now rewrite EQ. +Qed. + +Lemma estar_Sbind {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : + (trans_alt ε)^* s u -> (trans_alt ε)^* (Sbind s k) (Sbind u k). +Proof. + destruct s as [t | Z e g]; intros STAR. + - destruct (estar_active STAR) as [u0 EQ]. + assert (STAR2 : (trans_alt ε)^* (Active t) (Active u0)) + by (eapply estar_trans; [ exact STAR | apply estar_seq, EQ ]). + eapply (estar_trans (b := Sbind (Active u0 : @S E B X) k)). + + cbn. apply estar_bind; exact STAR2. + + apply estar_seq. apply Sbind_Seq. now symmetry. + - apply estar_passive in STAR. now apply estar_seq, Sbind_Seq. +Qed. + +Lemma trans_Sbind_τ {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : + trans_alt τ s u -> trans_alt τ (Sbind s k) (Sbind u k). +Proof. + intros TR; destruct s as [t | Z e g]. + - unfold trans_alt in TR; cbn in TR; dependent destruction TR; cbn. + apply trans_bind_l_τ; eapply Transstep; eauto. + - apply trans_passive_inv' in TR as (z & _ & Habs); easy. +Qed. + +Lemma trans_Sbind_ask {E B X Y Z} (s u : @S E B X) (k : X -> ctree E B Y) (e : E Z) : + trans_alt (ask e) s u -> trans_alt (ask e) (Sbind s k) (Sbind u k). +Proof. + intros TR; destruct s as [t | Z0 e0 g]. + - unfold trans_alt in TR; cbn in TR; dependent destruction TR; cbn. + apply trans_bind_l_ask; econstructor; eauto. + - apply trans_passive_inv' in TR as (z & _ & Habs); easy. +Qed. + +Lemma trans_Sbind_rcv {E B X Y Z} (s u : @S E B X) (k : X -> ctree E B Y) (e : E Z) (w : Z) : + trans_alt (rcv e w) s u -> trans_alt (rcv e w) (Sbind s k) (Sbind u k). +Proof. + intros TR; destruct s as [t | Z0 e0 g]. + - unfold trans_alt in TR; cbn in TR; dependent destruction TR. + - apply trans_passive_inv' in TR as (z & EQ & Heq). + dependent destruction Heq; cbn. + assert (HS : (Sbind u k) ⩸ (Active (x <- g z;; k x))). + { transitivity (Sbind (Active (g z)) k); [ now apply Sbind_Seq | reflexivity ]. } + rewrite HS. econstructor; reflexivity. +Qed. + Section bind_restore. - Context {E F B : Type -> Type} {X X' : Type} - (L : rel (@label E X') (@label F X')) - (R0 : rel X X). + Context {E F C D : Type -> Type} {X Y X' Y' : Type}. - Notation uvr := (update_val_rel L R0). + Lemma sbind_chain_gen (L : lrel E F X' Y') {R : Chain (@ss' E F C D)} : + forall (s : @S E C X) (s' : @S F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y') + (SS : rel X Y), + ` R X Y (upd_rel L SS) s s' -> + (forall x x', SS x x' -> ` R X' Y' L (Active (k x)) (Active (k' x'))) -> + ` R X' Y' L (Sbind s k) (Sbind s' k'). + Proof. + tower induction. + - intros IH s s' k k' SS tt kk. + destruct s as [t | Zs es gs]. + + split. + * intros succ l Hne TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (Heps & _) + | (Z & e & g & -> & TRt & SQ) ]]]. + -- assert (cV : trans_alt (val x) + (Active t) (Active (Stuck : ctree E C X))) by now constructor. + destruct tt as [tt_ne tt_ep]. + destruct (tt_ne _ (val x) (ltac:(easy)) cV) as (l2 & resp & RESP & _ & HL2). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv. + dependent destruction STEPv; inversion HL2; subst. + specialize (kk x r ltac:(assumption)). + destruct kk as (kkA & _). + destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hgfp & HL'). + exists l', u'; ssplit. + ++ destruct RESP2 as [m2 STAR2 STEP2]. + exists m2; [| exact STEP2]. + eapply estar_trans. + ** apply estar_Sbind; exact STAR. + ** eapply estar_trans; [| exact STAR2]. + apply estar_seq; cbn; constructor. + rewrite H, bind_ret_l; reflexivity. + ++ exact Hgfp. + ++ exact HL'. + -- destruct tt as [tt_ne tt_ep]. + destruct (tt_ne _ τ (ltac:(easy)) TRt) as (l2 & resp & RESP & Hpre & HL2). + inversion HL2; subst. + destruct RESP as [m STAR STEPτ]. + exists τ, (Sbind resp k'); ssplit. + ++ exists (Sbind m k'). + ** apply estar_Sbind; exact STAR. + ** apply trans_Sbind_τ; exact STEPτ. + ++ rewrite SQ. apply (IH (Active t1) resp k k' SS); [ exact Hpre | intros ? ? ?; apply (b_chain R); now apply kk ]. + ++ constructor. + -- easy. + -- destruct tt as [tt_ne tt_ep]. + destruct (tt_ne _ (ask e) (ltac:(easy)) TRt) as (l2 & resp & RESP & Hpre & HL2). + dependent destruction HL2. + destruct RESP as [m STAR STEPa]. + exists (ask f), (Sbind resp k'); ssplit. + ++ exists (Sbind m k'). + ** apply estar_Sbind; exact STAR. + ** apply trans_Sbind_ask; exact STEPa. + ++ rewrite SQ. apply (IH (Passive e g) resp k k' SS); [ exact Hpre | intros ? ? ?; apply (b_chain R); now apply kk ]. + ++ now constructor. + * intros succ TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & e & g & Habs & _) ]]]. + -- assert (cV : trans_alt (val x) (Active t) (Active (Stuck : ctree E C X))) + by (eapply Transval; [ exact EQt | reflexivity ]). + destruct tt as [tt_ne tt_ep]. + destruct (tt_ne _ (val x) (ltac:(easy)) cV) as (l2 & resp & RESP & _ & HL2). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv. + dependent destruction STEPv; inversion HL2; subst. + specialize (kk x r ltac:(assumption)). + destruct kk as (_ & kkB). + destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). + exists u2; split. + ++ eapply estar_trans. + ** apply estar_Sbind; exact STAR. + ** eapply estar_trans; [| exact STARu]. + apply estar_seq; cbn; constructor. + rewrite H, bind_ret_l; reflexivity. + ++ exact Hgfp2. + -- easy. + -- destruct tt as [tt_ne tt_ep]. + destruct (tt_ep _ TRt) as (resp & STARr & Hpre). + exists (Sbind resp k'); split. + ++ apply estar_Sbind; exact STARr. + ++ rewrite SQ. apply (IH (Active t1) resp k k' SS); [ exact Hpre | intros ? ? ?; apply (b_chain R); now apply kk ]. + -- easy. + + split. + * intros succ l Hne TR. + apply trans_passive_inv' in TR as (z & SQ & ->). + assert (TRrcv : trans_alt (rcv es z) (Passive es gs) (Active (gs z))) + by (econstructor; reflexivity). + destruct tt as [tt_ne tt_ep]. + destruct (tt_ne _ (rcv es z) (ltac:(easy)) TRrcv) as (l2 & resp & RESP & Hpre & HL2). + dependent destruction HL2. + destruct RESP as [m STAR STEPr]. + exists (rcv f y), (Sbind resp k'); ssplit. + -- exists (Sbind m k'). + ++ apply estar_Sbind; exact STAR. + ++ apply trans_Sbind_rcv; exact STEPr. + -- rewrite SQ. apply (IH (Active (gs z)) resp k k' SS); [ exact Hpre | intros ? ? ?; apply (b_chain R); now apply kk ]. + -- now constructor. + * intros succ TR. + apply trans_passive_inv' in TR as (z & _ & Habs); easy. + Qed. - Lemma bind_chain_gen {R : Chain (@ss' E F B X' L)} : - forall (t : ctree E B X) (t' : ctree F B X) - (k : X -> ctree E B X') (k' : X -> ctree F B X'), - ssim' uvr (Active t) (Active t') -> - (forall x x', R0 x x' -> ` R (Active (k x)) (Active (k' x'))) -> - ` R (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + Lemma bind_chain_gen (L : lrel E F X' Y') {R : Chain (@ss' E F C D)} : + forall (t : ctree E C X) (t' : ctree F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y') + (SS : rel X Y), + ` R X Y (upd_rel L SS) (Active t) (Active t') -> + (forall x x', SS x x' -> ` R X' Y' L (Active (k x)) (Active (k' x'))) -> + ` R X' Y' L (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. - apply tower. - - intros ? INC t t' k k' tt kk ? ?; red. - apply INC; auto. - intros. now apply kk. - - clear; intros R IH t t' k k' tt kk. - split. - + intros s l Hne TR. - apply trans_bind_inv in TR as - [ (x & EQt & TRk) - | [ (-> & t1 & TRt & SQ) - | [ (Heps & _) - | (Z & e & g & -> & TRt & SQ) ]]]. - (* t ≅ Ret, show t' steps to Stuck as well *) - * assert (cV : trans_alt (val x) - (Active t) (Active (Stuck : ctree E B X))) by now constructor. - step in tt; repeat red in tt; destruct tt as [tt_nonep tt_ep]. - (* know cV reduced *) - assert (HneV : (val x : @label E X) <> ε) by easy. - (* take the nonep branch *) - destruct (tt_nonep _ _ HneV cV) as (l2 & n & RESP & _ & HL2). - apply update_val_rel_val_l in HL2 as (x' & -> & Hx). - destruct RESP as [m STAR STEPv]. - unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. - specialize (kk x x' Hx). - destruct kk as (kkA & _). - destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hgfp & HL'). - exists l', u'; ssplit. - -- destruct RESP2 as [m2 STAR2 STEP2]. - exists m2; [| exact STEP2]. - eapply estar_trans. - ++ apply estar_bind; exact STAR. - ++ eapply estar_trans; [| exact STAR2]. - apply estar_seq; constructor. - rewrite H, bind_ret_l; reflexivity. - -- exact Hgfp. - -- exact HL'. - * assert (cT : ((trans_alt ε)^* ⋅ trans_alt τ) (Active t) (Active t1)) - by (apply trans_star_l; exact TRt). - step in tt. - assert (Hneτ : (τ : @label E X) <> ε) by discriminate. - destruct (tt _ _ Hneτ cT) as (l2 & n & RESP & Htt' & HL2). - apply update_val_rel_τ_l in HL2 as (-> & HLττ). - destruct RESP as [m STAR STEPτ]. - unfold trans_alt in STEPτ; cbn in STEPτ; dependent destruction STEPτ. - exists τ, (Active (x <- u;; k' x)); ssplit. - -- exists (Active (x <- t0;; k' x)). - ++ apply estar_bind; exact STAR. - ++ apply trans_bind_l_τ; eapply Transstep; eauto. - -- rewrite SQ; apply IH; [exact Htt' | intros; step; now apply kk]. - -- exact HLττ. - * easy. - (* a short trip is needed: active -> passive -> active - via ask/rcv. not hard but a bit tedious. if this - logic appears again it should be factored out into a lemma. *) - * assert (cA : ((trans_alt ε)^* ⋅ trans_alt (ask e)) - (Active t) (Passive e g)) - by (apply trans_star_l; exact TRt). - step in tt. - assert (HneA : (ask e : @label E X) <> ε) by discriminate. - destruct (tt _ _ HneA cA) as (l2 & n & RESP & Htt' & HL2). - apply update_val_rel_ask_l in HL2 as (Z' & f & -> & HLaa). - destruct RESP as [m STAR STEPa]. - unfold trans_alt in STEPa; cbn in STEPa; dependent destruction STEPa. - exists (ask f), (Passive f (fun z => x <- k0 z;; k' x)); ssplit. - -- exists (Active (x <- t0;; k' x)). - ++ apply estar_bind; exact STAR. - ++ apply trans_bind_l_ask; econstructor; exact H. - -- rewrite SQ; apply (b_chain R); split. - ++ intros s2 l2 Hne2 TR2. - apply trans_passive_inv' in TR2 as (z & SQ2 & ->). - step in Htt'. - assert (cR : ((trans_alt ε)^* ⋅ trans_alt (rcv e z)) - (Passive e g) (Active (g z))). - { apply trans_star_l; econstructor; reflexivity. } - assert (HneR : (rcv e z : @label E X) <> ε) by discriminate. - destruct (Htt' _ _ HneR cR) as (l3 & n3 & RESP3 & Htt2 & HL3). - apply update_val_rel_rcv_l in HL3 as (Z2 & f2 & w & -> & HLrr). - destruct RESP3 as [m3 STAR3 STEP3]. - apply estar_passive in STAR3. - dependent destruction STAR3. - apply trans_passive_inv' in STEP3 as (w' & SQ3 & Heq). - dependent destruction Heq. - dependent destruction SQ3. - exists (rcv f w'), (Active (x <- k0 w';; k' x)); ssplit. - ** apply trans_star_l; econstructor; reflexivity. - ** rewrite SQ2. - assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') - ⩸ (Active (x <- k0 w';; k' x))). - { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } - rewrite <- SQ5; apply IH; [exact Htt2 | intros; step; now apply kk]. - ** exact HLrr. - ++ intros s2 TR2. - apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. - -- exact HLaa. - + intros s TR. - apply trans_bind_inv in TR as - [ (x & EQt & TRk) - | [ (Habs & _) - | [ (_ & t1 & TRt & SQ) - | (Z & e & g & Habs & _) ]]]. - * assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val x)) - (Active t) (Active (Stuck : ctree E B X))). - { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } - step in tt. - assert (HneV : (val x : @label E X) <> ε) by discriminate. - destruct (tt _ _ HneV cV) as (l2 & n & RESP & _ & HL2). - apply update_val_rel_val_l in HL2 as (x' & -> & Hx). - destruct RESP as [m STAR STEPv]. - unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. - specialize (kk x x' Hx). - destruct kk as (_ & kkB). - destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). - exists u2; split. - -- eapply estar_trans. - ++ apply estar_bind; exact STAR. - ++ eapply estar_trans; [| exact STARu]. - apply estar_seq; constructor. - rewrite H, bind_ret_l; reflexivity. - -- exact Hgfp2. - * easy. - * exists (Active (x <- t';; k' x)); split. - -- apply trans_star_self. - -- rewrite SQ; apply IH; [| intros; step; now apply kk]. - eapply ssim_eps_l; [exact tt | exact TRt]. - * easy. + intros t t' k k' SS. + exact (sbind_chain_gen L (Active t) (Active t') k k' SS). Qed. - Lemma ssim'_clo_bind : - forall (t : ctree E B X) (t' : ctree F B X) - (k : X -> ctree E B X') (k' : X -> ctree F B X'), - ssim uvr (Active t) (Active t') -> - (forall x x', R0 x x' -> ssim' L (Active (k x)) (Active (k' x'))) -> + Lemma ssim'_clo_bind (L : lrel E F X' Y') : + forall (t : ctree E C X) (t' : ctree F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y') (SS : rel X Y), + ssim' (upd_rel L SS) (Active t) (Active t') -> + (forall x x', SS x x' -> ssim' L (Active (k x)) (Active (k' x'))) -> ssim' L (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. - intros t t' k k' tt kk. - apply (@bind_chain_gen (chain_gfp (ss' L))); assumption. + intros t t' k k' SS tt kk. + exact (@bind_chain_gen L (chain_gfp (@ss' E F C D)) t t' k k' SS tt kk). Qed. End bind_restore. @@ -1079,38 +1136,13 @@ Proof. all: easy || now constructor. Qed. -Lemma ssim_update_val_rel_eq {E B X X'} : - forall (t u : @SS E B X), - ssim eq t u -> ssim (@update_val_rel E E X X' eq eq) t u. -Proof. - unfold ssim at 2; coinduction R CH; intros t u H. - intros t' l Hne TR. - step in H. - destruct (H _ _ Hne TR) as (l' & u' & RESP & HR & HL). - exists l', u'; ssplit. - - assumption. - - apply CH, HR. - - subst l'; apply update_val_rel_eq_refl; assumption. -Qed. - -Lemma ss'_clo_bind_eq {E B X X'} {R : Chain (@ss' E E B X' eq)} : - forall (t t' : ctree E B X) (k k' : X -> ctree E B X'), - ssim eq (Active t) (Active t') -> - (forall x, ssim' eq (Active (k x)) (Active (k' x))) -> - ` R (Active (x <- t;; k x)) (Active (x <- t';; k' x)). -Proof. - intros t t' k k' tt kk. - apply bind_chain_gen with (R0 := eq). - - apply ssim_update_val_rel_eq; exact tt. - - intros x x' ->; apply kk. -Qed. - Lemma ssim'_clo_bind_eq {E B X X'} : forall (t t' : ctree E B X) (k k' : X -> ctree E B X'), - ssim eq (Active t) (Active t') -> - (forall x, ssim' eq (Active (k x)) (Active (k' x))) -> - ssim' eq (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + ssim' (upd_rel (@Leq E X') eq) (Active t) (Active t') -> + (forall x, ssim' (@Leq E X') (Active (k x)) (Active (k' x))) -> + ssim' (@Leq E X') (Active (x <- t;; k x)) (Active (x <- t';; k' x)). Proof. intros t t' k k' tt kk. - apply (@ss'_clo_bind_eq E B X X' (chain_gfp (ss' eq))); assumption. + eapply ssim'_clo_bind; [ exact tt |]. + intros x x' ->; apply kk. Qed. From ad52ae5b1aa228260f9b278f71c90656eba4afc7 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Sun, 26 Jul 2026 14:34:25 +0100 Subject: [PATCH 50/61] Factored out Estar --- theories/Eq/AltEquiv.v | 15 ++---- theories/Eq/EstarTheory.v | 98 +++++++++++++++++++++++++++++++++++++++ theories/Eq/SSimAlt.v | 79 +++++-------------------------- 3 files changed, 113 insertions(+), 79 deletions(-) create mode 100644 theories/Eq/EstarTheory.v diff --git a/theories/Eq/AltEquiv.v b/theories/Eq/AltEquiv.v index fc1d979..d0baff7 100644 --- a/theories/Eq/AltEquiv.v +++ b/theories/Eq/AltEquiv.v @@ -9,7 +9,7 @@ From ITree Require Import From CTree Require Import CTree Eq.Shallow Eq.Equ Eq.Epsilon. -From CTree Require Eq.Trans Eq.SSim. +From CTree Require Eq.Trans Eq.SSim Eq.EstarTheory. From CTree Require Import Eq.TransAlt Eq.SSimAlt. @@ -53,15 +53,6 @@ Proof. now destruct s. Qed. Lemma o2n_n2o_S {E B X} (s : TransAlt.S E B X) : o2n_S (n2o_S s) = s. Proof. now destruct s. Qed. -(* add an epsilon *) -Lemma estar_cons {E B X} (a b c : TransAlt.S E B X) : - trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. -Proof. - intros H1 H2. - assert (HH : (trans_alt (E:=E) (B:=B) (R:=X) ε ⋅ (trans_alt ε)^*) ≦ (trans_alt ε)^*) by ka. - apply HH. exists b; assumption. -Qed. - Lemma transR_o2n {E B X} (l : Trans.label E X) (a a' : Trans.S E B X) : Trans.transR l a a' -> ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) (o2n_S a) (o2n_S a'). @@ -69,11 +60,11 @@ Proof. intros TR; induction TR. - destruct IHTR as [m STAR STEP]. exists m; [| apply STEP]. - eapply estar_cons; [ | apply STAR ]. + eapply EstarTheory.estar_cons_epsilon; [ | apply STAR ]. eapply TransAlt.Transbr; [ apply H | apply H0 ]. - destruct IHTR as [m STAR STEP]. exists m; [| apply STEP]. - eapply estar_cons; [ | apply STAR ]. + eapply EstarTheory.estar_cons_epsilon; [ | apply STAR ]. eapply TransAlt.Transguard; [ apply H | reflexivity ]. - apply trans_star_l. eapply TransAlt.Transstep; [ apply H | apply H0 ]. - apply trans_star_l. eapply TransAlt.Transask; apply H. diff --git a/theories/Eq/EstarTheory.v b/theories/Eq/EstarTheory.v new file mode 100644 index 0000000..ff4666f --- /dev/null +++ b/theories/Eq/EstarTheory.v @@ -0,0 +1,98 @@ +From Stdlib Require Import Program.Equality. + +From CTree Require Import + CTree + Eq.Equ + Eq.TransAlt. + +From RelationAlgebra Require Export + monoid kat kat_tac rel srel. +From Coinduction Require Import all. + +Import CTree. +Import EquNotations. +Set Implicit Arguments. + +(* l -> *ε ⋅ l *) +Lemma estar_l_lift {X} {C G : Type -> Type} : + forall (t t' : @S G C X) l, + trans_alt l t t' -> + ((trans_alt ε)^* ⋅ trans_alt l) t t'. + Proof. + intros. use_steps O. assumption. + Qed. + +(* ^*ε is transitive. *) +Lemma estar_trans {G B : Type -> Type} {V : Type} (a b c : @S G B V) : + (trans_alt ε)^* a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. +Proof. + intros S1 S2. + assert (H : (@trans_alt G B V ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + apply H; eexists; eassumption. +Qed. + +(* adding an ε preserves ^*ε. *) +Lemma estar_cons_epsilon {G B : Type -> Type} {V : Type} (a b c : @S G B V) : + trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. +Proof. + intros S1 S2. + assert (H : @trans_alt G B V ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + apply H; eexists; eassumption. +Qed. + +(* lift ε to ^*ε *) +Lemma estar_single {G B : Type -> Type} {V : Type} (a b : @S G B V) : + trans_alt ε a b -> (trans_alt ε)^* a b. +Proof. + enough (H: (@trans_alt G B V ε) ≦ (trans_alt ε)^*); + [apply H | ka]. +Qed. + +(* adding an ε preserves ^ε ⋅ l for any l *) +Lemma estar_cons_label {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : + trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> + ((trans_alt ε)^* ⋅ trans_alt l) a c. +Proof. + enough (H: @trans_alt G B V ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + ≦ (trans_alt ε)^* ⋅ trans_alt l); [|ka]. + intros; apply H; eexists; eauto. +Qed. + +(* adding .^*ε preserves ^ε ⋅ l for any l *) +Lemma estar_app {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : + (trans_alt ε)^* a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> + ((trans_alt ε)^* ⋅ trans_alt l) a c. +Proof. + enough (H : (@trans_alt G B V ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + ≦ (trans_alt ε)^* ⋅ trans_alt l); [|ka]. + intros; apply H; eexists; eassumption. +Qed. + +(* lift ^*ε through ⩸ *) +Lemma estar_seq {E B X} (a b : @SS E B X) : + a ⩸ b -> (trans_alt ε)^* a b. +Proof. + intros H; exists O; exact H. +Qed. + +Lemma estar_passive {E B X Z} (e : E Z) (g : Z -> ctree E B X) (m : @SS E B X) : + (trans_alt ε)^* (Passive e g) m -> + (Passive e g : @SS E B X) ⩸ m. +Proof. + intros [n STAR]; destruct n. + - cbn in STAR. exact STAR. + - destruct STAR as [mid STEP _]. + (* STEP is absurd; [β] only steps with [rcv] *) + apply trans_passive_inv' in STEP as (z & _ & Habs); easy. +Qed. + +Lemma estar_active {E B X} (t : ctree E B X) (u : @S E B X) : + (trans_alt ε)^* (Active t) u -> exists u0 : ctree E B X, u ⩸ (Active u0). +Proof. + intros [n STAR]; revert t STAR; induction n; intros t STAR. + - cbn in STAR; dependent destruction STAR. eexists; reflexivity. + - destruct STAR as [mid STEP REST]. + unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. + + eapply IHn; exact REST. + + eapply IHn; exact REST. +Qed. diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 6dae833..8a47f3a 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -14,6 +14,7 @@ From CTree Require Import Utils Eq.Equ Eq.TransAlt + Eq.EstarTheory Eq.Epsilon. From RelationAlgebra Require Export @@ -142,14 +143,6 @@ Section ssim'_theory. intros * (_ & H); apply H. Qed. - Lemma trans_alt_estar_l {G : Type -> Type} : - forall (t t' : @S G C X) l, - trans_alt l t t' -> - ((trans_alt ε)^* ⋅ trans_alt l) t t'. - Proof. - intros. use_steps O. assumption. - Qed. - End ssim'_theory. Ltac fold_ssim' := @@ -290,7 +283,7 @@ Section Proof_Rules. intros Rstuck Lval. split. - intros t' l Hl TR. apply trans_ret_inv' in TR as (EQ & ->). exists (val y), (Active Stuck). split; [| split]. - + apply trans_alt_estar_l, trans_ret. + + apply estar_l_lift, trans_ret. + rewrite EQ. apply Rstuck. + assumption. - intros t' TR. apply trans_ret_inv' in TR as (_ & abs). discriminate. @@ -306,7 +299,7 @@ Section Proof_Rules. - intros t' l Hl TRl. apply trans_ret_inv' in TRl as (EQ & ->). pose proof (trans_val_inv' TR) as EQ'. exists (val y), u'. split; [| split]. - + apply trans_alt_estar_l, TR. + + apply estar_l_lift, TR. + rewrite EQ, EQ'. apply Rstuck. + assumption. - intros t' TRl. apply trans_ret_inv' in TRl as (_ & abs). discriminate. @@ -326,7 +319,7 @@ Section Proof_Rules. intros HRpas Lask. split. - intros t' l Hl TR. apply trans_vis_inv' in TR as (EQ & ->). exists (ask f), (Passive f k'). split; [| split]. - + apply trans_alt_estar_l, trans_ask. + + apply estar_l_lift, trans_ask. + rewrite EQ. apply HRpas. + assumption. - intros t' TR. apply trans_vis_inv' in TR as (_ & abs). discriminate. @@ -392,55 +385,7 @@ Section Proof_Rules. + apply (str_refl (trans_alt ε)); cbn; reflexivity. + rewrite EQ. apply HReps'. Qed. - - Lemma estar_trans {G B : Type -> Type} {V : Type} (a b c : @S G B V) : - (trans_alt ε)^* a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. - Proof. - intros S1 S2. - assert (H : (@trans_alt G B V ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. - apply H; eexists; eassumption. - Qed. - - Lemma estar_cons0 {G B : Type -> Type} {V : Type} (a b c : @S G B V) : - trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. - Proof. - intros S1 S2. - assert (H : @trans_alt G B V ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. - apply H; eexists; eassumption. - Qed. - - Lemma estar_single' {G B : Type -> Type} {V : Type} : - (@trans_alt G B V ε) ≦ (trans_alt ε)^*. - Proof. - ka. - Qed. - - Lemma estar_single {G B : Type -> Type} {V : Type} (a b : @S G B V) : - trans_alt ε a b -> (trans_alt ε)^* a b. - Proof. - apply estar_single'. - Qed. - - Lemma estar_cons {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : - trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> - ((trans_alt ε)^* ⋅ trans_alt l) a c. - Proof. - intros S1 S2. - assert (H : @trans_alt G B V ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) - ≦ (trans_alt ε)^* ⋅ trans_alt l) by ka. - apply H; eexists; eassumption. - Qed. - - Lemma estar_app {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : - (trans_alt ε)^* a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> - ((trans_alt ε)^* ⋅ trans_alt l) a c. - Proof. - intros S1 S2. - assert (H : (@trans_alt G B V ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) - ≦ (trans_alt ε)^* ⋅ trans_alt l) by ka. - apply H; eexists; eassumption. - Qed. - + Lemma step_ss'_br_r {Z} (c : D Z) x (k : Z -> ctree F D Y) (t: @S E C X): ss'_gen R Reps L t (k x) -> @@ -449,10 +394,10 @@ Section Proof_Rules. intros (HA & HB); split. - intros t' l Hl TR. apply HA in TR as (l' & u' & STEP & HRtu & HL); auto. exists l', u'; split; [| split; assumption]. - eapply estar_cons; [ apply trans_br | exact STEP ]. + eapply estar_cons_label; [ apply trans_br | exact STEP ]. - intros t' TR. apply HB in TR as (u' & STEP & HRep). exists u'; split; [| assumption]. - eapply estar_cons0; [ apply trans_br | exact STEP ]. + eapply estar_cons_epsilon; [ apply trans_br | exact STEP ]. Qed. Lemma step_ss'_br {Z Z'} (a: C Z) (b: D Z') @@ -496,10 +441,10 @@ Section Proof_Rules. intros (HA & HB); split. - intros s l Hl TR. apply HA in TR as (l' & u' & STEP & HRtu & HL); auto. exists l', u'; split; [| split; assumption]. - eapply estar_cons; [ apply trans_guard | exact STEP ]. + eapply estar_cons_label; [ apply trans_guard | exact STEP ]. - intros s TR. apply HB in TR as (u' & STEP & HRep). exists u'; split; [| assumption]. - eapply estar_cons0; [ apply trans_guard | exact STEP ]. + eapply estar_cons_epsilon; [ apply trans_guard | exact STEP ]. Qed. Lemma step_ss'_guard @@ -562,7 +507,7 @@ Section Proof_Rules. intros Ltau HRtt; split. - intros s l Hl TR. apply trans_step_inv' in TR as (EQ & ->). exists τ, (Active t'). split; [| split]. - + apply trans_alt_estar_l, trans_step. + + apply estar_l_lift, trans_step. + rewrite EQ. apply HRtt. + assumption. - intros s TR. apply trans_step_inv' in TR as (_ & abs). discriminate. @@ -914,10 +859,10 @@ Proof. now rewrite EQ. - destruct STAR as [mid STEP REST]. unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. - + eapply estar_cons0. + + eapply estar_cons_epsilon. * apply trans_bind_l_ε; eapply Transbr; eauto. * apply IHn; exact REST. - + eapply estar_cons0. + + eapply estar_cons_epsilon. * apply trans_bind_l_ε; eapply Transguard; eauto. * apply IHn; exact REST. Qed. From 5bc692bccf3803972dba0876a782f52f6d786171 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Tue, 28 Jul 2026 14:57:38 +0100 Subject: [PATCH 51/61] Cleaned SSimAlt, removed update_val_rel, documented. --- theories/Eq/EstarTheory.v | 19 +++++ theories/Eq/SSimAlt.v | 142 +++++--------------------------------- 2 files changed, 37 insertions(+), 124 deletions(-) diff --git a/theories/Eq/EstarTheory.v b/theories/Eq/EstarTheory.v index ff4666f..2d1696e 100644 --- a/theories/Eq/EstarTheory.v +++ b/theories/Eq/EstarTheory.v @@ -96,3 +96,22 @@ Proof. + eapply IHn; exact REST. + eapply IHn; exact REST. Qed. + +Import CTreeNotations. +Lemma estar_bind {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) : + (trans_alt ε)^* (Active t) (Active u) -> + (trans_alt ε)^* (Active (x <- t;; k x)) (Active (x <- u;; k x)). +Proof. + intros [n STAR]; revert t STAR; induction n; intros t STAR. + - cbn in STAR; dependent destruction STAR. + apply estar_seq; constructor. + now rewrite EQ. + - destruct STAR as [mid STEP REST]. + unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. + + eapply estar_cons_epsilon. + * apply trans_bind_l_ε; eapply Transbr; eauto. + * apply IHn; exact REST. + + eapply estar_cons_epsilon. + * apply trans_bind_l_ε; eapply Transguard; eauto. + * apply IHn; exact REST. +Qed. \ No newline at end of file diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 8a47f3a..7d5e143 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -85,18 +85,16 @@ Section ssim'_theory. {L: lrel E F X Y}. (*| - Strong simulation up-to [equ] is valid + Strong simulation up-to [equ] is valid. Note Seq is eq lifted to SS + (active/passive tags). ---------------------------------------- |*) #[global] Instance Seq_proper_ss'_chain_goal {c: Chain (@ss' E F C D)} : Proper (Seq ==> Seq ==> flip impl) (`c X Y L). Proof. - do 5 red. - apply tower. - - intros T HT a b Hseq x y Hseq2 Hinf i Hi. red. eapply HT; eauto. - now apply Hinf. - - clear c; intros c CIH x y Hseq x' y' Hseq2 [Hnonep Hep]. + tower induction. + - intros CIH x y Hseq x' y' Hseq2 [Hnonep Hep]. split; intros. + rewrite Hseq in H0. destruct (Hnonep _ _ H H0) as (l' & u' & Htr & Hc & HL). rewrite <- Hseq2 in Htr. @@ -109,11 +107,8 @@ Section ssim'_theory. #[global] Instance Seq_proper_ss'_chain_ctx {c: Chain (@ss' E F C D)} : Proper (Seq ==> Seq ==> impl) (`c X Y L). Proof. - do 4 red. - apply tower. - - intros T HT a b Hseq x y Hseq2 Hinf i Hi. red. eapply HT; eauto. - now apply Hinf. - - clear c; intros c CIH x y Hseq x' y' Hseq2 [Hnonep Hep]. + tower induction. + - intros CIH x y Hseq x' y' Hseq2 [Hnonep Hep]. split; intros. + rewrite <- Hseq in H0. destruct (Hnonep _ _ H H0) as (l' & u' & Htr & Hc & HL). rewrite Hseq2 in Htr. @@ -184,10 +179,12 @@ Section ssim'_homogenous_theory. {L: lrel E E X X} {R Reps: forall X Y : Type, lrel E E X Y -> rel (S E C X) (S E C Y)}. + (** Theory of chains of ss' *) + Notation ss' := (@ss' E E C C). Notation ssim' := (@ssim' E E C C X X). - #[global] Instance Reflexive_ss' `{Reflexive _ (R L)} `{Reflexive _ (Reps L)} `{Reflexive _ L}: + #[global] Instance Reflexive_ss'_gen `{Reflexive _ (R L)} `{Reflexive _ (Reps L)} `{Reflexive _ L}: Reflexive (@ss'_gen E E C C R Reps X X L). Proof. split; intros. @@ -197,10 +194,10 @@ Section ssim'_homogenous_theory. use_steps (1 : nat). econstructor; eauto. Qed. - #[global] Instance refl_ss' {LR: Reflexive L} {c: Chain (ss')}: Reflexive (`c X X L). + #[global] Instance Reflexive_ss'_chain {LR: Reflexive L} {c: Chain (ss')}: Reflexive (`c X X L). Proof. - (* of note: Reflexive chain fails here because elem has arguments.. we should fix that. *) - tower induction. (* it works! sometimes *) + (* of note: Reflexive_chain fails here because elem has arguments.. we should fix that. *) + tower induction. split; intros. - do 2 eexists. split. use_steps O. apply H1. now split. - exists t'; split; auto. @@ -219,8 +216,6 @@ Section ssim'_heterogenous_theory. Context {E F C D : Type -> Type} {X Y : Type} {L: lrel E F X Y}. - (* Notation ss' := (@ss' E F C D). - Notation ssim' := (@ssim' E F C D X Y). *) (*| stuck ctrees can be simulated by anything. @@ -233,10 +228,7 @@ Section ssim'_heterogenous_theory. Qed. Lemma ssim'_stuck (t : @S F D Y) : ssim' L (Stuck : ctree E C X) t. - Proof. - (* todo: step doesn't work here: the type of sub_bChain seems to demand - the two trees have the same type, which is too restrictive. *) - Fail (red; Coinduction.tactics.step). + Proof. step. apply ss'_stuck. Qed. @@ -782,91 +774,7 @@ Proof. Unshelve. exact E. exact F. all: auto. Qed. -Variant update_val_rel {E F X X'} - (L : rel (@label E X') (@label F X')) (R0 : rel X X) - : rel (@label E X) (@label F X) := -| uvr_τ : - L τ τ -> - update_val_rel L R0 τ τ -| uvr_ask {Z Z'} (e : E Z) (f : F Z') : - L (ask e) (ask f) -> - update_val_rel L R0 (ask e) (ask f) -| uvr_rcv {Z Z'} (e : E Z) (v : Z) (f : F Z') (w : Z') : - L (rcv e v) (rcv f w) -> - update_val_rel L R0 (rcv e v) (rcv f w) -| uvr_val (v w : X) : - R0 v w -> - update_val_rel L R0 (val v) (val w). - -Section uvr_inv. - - Context {E F : Type -> Type} {X X' : Type} - {L : rel (@label E X') (@label F X')} {R0 : rel X X}. - - Lemma update_val_rel_val_l (v : X) (l2 : @label F X) : - update_val_rel L R0 (val v) l2 -> - exists w, l2 = val w /\ R0 v w. - Proof. - intros H; dependent destruction H; eauto. - Qed. - - Lemma update_val_rel_τ_l (l2 : @label F X) : - update_val_rel L R0 τ l2 -> - l2 = τ /\ L τ τ. - Proof. - intros H; dependent destruction H; eauto. - Qed. - - Lemma update_val_rel_ask_l {Z} (e : E Z) (l2 : @label F X) : - update_val_rel L R0 (ask e) l2 -> - exists Z' (f : F Z'), l2 = ask f /\ L (ask e) (ask f). - Proof. - intros H; dependent destruction H; eauto. - Qed. - - Lemma update_val_rel_rcv_l {Z} (e : E Z) (v : Z) (l2 : @label F X) : - update_val_rel L R0 (rcv e v) l2 -> - exists Z' (f : F Z') (w : Z'), l2 = rcv f w /\ L (rcv e v) (rcv f w). - Proof. - intros H; dependent destruction H; eauto. - Qed. - -End uvr_inv. - -Lemma estar_seq {E B X} (a b : @SS E B X) : - a ⩸ b -> (trans_alt ε)^* a b. -Proof. - intros H; exists O; exact H. -Qed. - -Lemma estar_passive {E B X Z} (e : E Z) (g : Z -> ctree E B X) (m : @SS E B X) : - (trans_alt ε)^* (Passive e g) m -> - (Passive e g : @SS E B X) ⩸ m. -Proof. - intros [n STAR]; destruct n. - - exact STAR. - - destruct STAR as [mid STEP _]. - apply trans_passive_inv' in STEP as (z & _ & Habs); easy. -Qed. - -Lemma estar_bind {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) : - (trans_alt ε)^* (Active t) (Active u) -> - (trans_alt ε)^* (Active (x <- t;; k x)) (Active (x <- u;; k x)). -Proof. - intros [n STAR]; revert t STAR; induction n; intros t STAR. - - cbn in STAR; dependent destruction STAR. - apply estar_seq; constructor. - now rewrite EQ. - - destruct STAR as [mid STEP REST]. - unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. - + eapply estar_cons_epsilon. - * apply trans_bind_l_ε; eapply Transbr; eauto. - * apply IHn; exact REST. - + eapply estar_cons_epsilon. - * apply trans_bind_l_ε; eapply Transguard; eauto. - * apply IHn; exact REST. -Qed. - +Section Sbind. Definition Sbind {E B X Y} (s : @S E B X) (k : X -> ctree E B Y) : @S E B Y := match s with @@ -874,16 +782,7 @@ Definition Sbind {E B X Y} (s : @S E B X) (k : X -> ctree E B Y) : @S E B Y := | Passive e g => Passive e (fun z => x <- g z;; k x) end. -Lemma estar_active {E B X} (t : ctree E B X) (u : @S E B X) : - (trans_alt ε)^* (Active t) u -> exists u0 : ctree E B X, u ⩸ (Active u0). -Proof. - intros [n STAR]; revert t STAR; induction n; intros t STAR. - - cbn in STAR; dependent destruction STAR. eexists; reflexivity. - - destruct STAR as [mid STEP REST]. - unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. - + eapply IHn; exact REST. - + eapply IHn; exact REST. -Qed. +(* theory of Sbind, from which we derive bind *) Lemma Sbind_Seq {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : s ⩸ u -> (Sbind s k) ⩸ (Sbind u k). @@ -936,6 +835,8 @@ Proof. rewrite HS. econstructor; reflexivity. Qed. +End Sbind. + Section bind_restore. Context {E F C D : Type -> Type} {X Y X' Y' : Type}. @@ -1073,14 +974,7 @@ Section bind_restore. End bind_restore. -Lemma update_val_rel_eq_refl {E X X'} : - forall (l : @label E X), - l <> ε -> @update_val_rel E E X X' eq eq l l. -Proof. - destruct l; intro Hne. - all: easy || now constructor. -Qed. - +(** Finally, up-to bind closure for trees of the same type. *) Lemma ssim'_clo_bind_eq {E B X X'} : forall (t t' : ctree E B X) (k k' : X -> ctree E B X'), ssim' (upd_rel (@Leq E X') eq) (Active t) (Active t') -> From c09362fec83b326eb4ddb36743c98326d9402a1c Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 30 Jul 2026 13:46:10 +0200 Subject: [PATCH 52/61] Types under sb' for bind chain argument. Now fixing files. --- theories/Eq/SBisimAlt.v | 100 +++++++++++++++++++++------------------- theories/Eq/SSimAlt.v | 53 ++++++++++++++++----- theories/Eq/TransAlt.v | 6 +++ 3 files changed, 99 insertions(+), 60 deletions(-) diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 4f1c1c9..2e61cd2 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -32,13 +32,15 @@ An alternative definition [sb'] of strong bisimulation. The simulation challenge does not involve an inductive transition relation, thus simplifying proofs. |*) - Program Definition sb' {E F B : Type -> Type} {X : Type} - (L : rel (@label E X) (@label F X)) - : mon (bool -> SS -> SS -> Prop) - := - {| body R side t u := - (side = true -> @ss'_gen E F B X L (fun t u => forall side, R side t u) (R true) t u) /\ - (side = false -> ss'_gen (flip L) (fun u t => forall side, R side t u) (flip (R false)) u t) + + Program Definition sb' {E F C D : Type -> Type} + : mon (bool -> forall X Y : Type, lrel E F X Y -> rel (S E C X) (S F D Y)) + := + {| body (R : bool -> forall X Y : Type, lrel E F X Y -> rel (S E C X) (S F D Y)) side X Y (L : lrel E F X Y) t u := + (side = true -> @ss'_gen E F C D (fun X Y L t' u' => forall side, R side X Y L t' u') (R true) X Y L t u) + /\ + (side = false -> @ss'_gen F E D C (fun Y X L t' u' => forall side, R side X Y (flipL L) u' t') + (fun Y X (L : lrel F E Y X) u' t' => R false X Y (flipL L) t' u') Y X (flipL L) u t) |}. Next Obligation. split; intro; subst; [specialize (H0 eq_refl); clear H1 | specialize (H1 eq_refl); clear H0]. @@ -50,59 +52,61 @@ End StrongBisimAlt. Section Symmetry. - Program Definition sb'l {E F B X} L : - mon (bool -> rel SS SS) := - {| body R side t u := side = true -> @sb' E F B X L R side t u |}. + Program Definition sb'l {E F C D} : + mon (bool -> forall X Y, lrel E F X Y -> rel SS SS) := + {| body R side X Y L t u := side = true -> @sb' E F C D R side X Y L t u |}. Next Obligation. - eapply (Hbody (sb' L)). - 2: { specialize (H0 eq_refl). apply H0. } - cbn. apply H. - Qed. + split; intro Hb; try easy. + eapply (Hbody sb'). + cbn. apply H. + apply H0. + (* dispatch true = true *) + all: trivial. +Qed. - Program Definition converse_neg {A : Type} : mon (bool -> relation A) := - {| body := fun (R : bool -> rel A A) b (x y : A) => R (negb b) y x |}. +(*| +[converse_neg] now swaps type indices and L +|*) + Program Definition converse_neg {E C : Type -> Type} : + mon (bool -> forall X Y : Type, lrel E E X Y -> rel (@S E C X) (@S E C Y)) := + {| body R b X Y L t u := R (negb b) Y X (flipL L) u t |}. - #[global] Instance converse_neg_invol {A} : Involution (@converse_neg A). + #[global] Instance converse_neg_invol {E C} : Involution (@converse_neg E C). Proof. - cbn. intros. - now rewrite Bool.negb_involutive. + cbn. intros R b X Y L t u. + rewrite Bool.negb_involutive, flipL_flipL. + reflexivity. Qed. - #[global] Instance sbisim'_sym {E C X L} : - `{Symmetric L} -> - Symmetrical converse_neg (@sb' E E C X L) (sb'l L). + #[global] Instance sbisim'_sym {E C} : + Symmetrical converse_neg (@sb' E E C C) (@sb'l E E C C). Proof. - intros SYM. - assert (HL: L == flip L). { cbn. intuition. } - eapply weq_ss'_gen in HL. - cbn -[sb']. split; intros. - - split; cbn -[sb']; intro. - + apply H. - + intros. apply Bool.negb_true_iff in H0. subst. - destruct H as [_ ?]. - specialize (H eq_refl). - apply HL in H. - split; intros; subst; try easy. - eapply ss'_gen_mon. 3: now apply H. - * cbn. intros. apply H1. - * cbn. intros. apply H1. - - split; intros; subst. - + now apply H. - + intros. - apply HL. - eapply ss'_gen_mon. 3: now apply H. - * cbn. intros. - specialize (H0 (negb side)). - rewrite Bool.negb_involutive in H0. apply H0. - * cbn. intros. apply H0. + cbn -[sb' ss'_gen]. intros R b X Y L t u. + split. + - intros [Ht Hf]; split; intro Hb. + + split; assumption. + + apply Bool.negb_true_iff in Hb; subst. + split; [| now intro]. + intros _. + eapply ss'_gen_mon. 3: now apply Hf. + * cbn. intros ? ? ? ? ? Hall side. apply Hall. + * cbn. intros. assumption. + - intros [Ht Hf]; split; intro Hb; subst. + + now apply (Ht eq_refl). + + cbn in Hf. destruct (Hf eq_refl) as [Hf' _]; specialize (Hf' eq_refl). + eapply ss'_gen_mon. 3: now apply Hf'. + * cbn. intros ? ? ? ? ? Hall side. + specialize (Hall (negb side)). + now rewrite Bool.negb_involutive in Hall. + * cbn. intros. assumption. Qed. End Symmetry. -Lemma sb'_flip {E F B X} {L : rel (label E X) (label F X)} +Lemma sb'_flip {E F C D X Y} {L : lrel E F X Y} side (t: SS) (u: SS) R : - @sb' F E B X (flip L) (fun b => flip (R (negb b))) (negb side) u t -> - sb' L R side t u. + @sb' F E D C (fun b X Y L t u => R (negb b) Y X (flipL L) u t) (negb side) Y X (flipL L) u t -> + sb' R side X Y L t u. Proof. split; intros; subst; destruct H; cbn in H. - specialize (H0 eq_refl). diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 7d5e143..4662025 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -43,22 +43,52 @@ Definition ss'_gen {E F C D : Type -> Type} /\ (forall t', trans_alt (B:=C) ε t t' -> exists u', (trans_alt (B:=D) ε)^* u u' /\ Reps L t' u'). - Program Definition ss' {E F C D : Type -> Type} : - mon (forall (X Y : Type), +(*| +[ss'_gen] is monotone in both of its relational arguments independently. +|*) +#[global] Instance ss'_gen_mon {E F C D} : + Proper (leq ==> leq ==> leq) (@ss'_gen E F C D). +Proof. + intros R R' HR Reps Reps' HReps X Y L t u [Hprogress Heps]. + split; intros. + - destruct (Hprogress _ _ H H0) as (l'' & u'' & Htrans & HRtu & HL'). + cbn in HR. eauto 12. + - apply Heps in H as (u' & Htrans & HRtu). + cbn in HReps. eauto 12. + Qed. + + Definition ss'_ {E F C D : Type -> Type} : + (forall (X Y : Type), + lrel E F X Y -> (* L *) + hrel (@S E C X) (* t *) + (@S F D Y) (* u *) + ) -> + (forall (X Y : Type), lrel E F X Y -> (* L *) hrel (@S E C X) (* t *) (@S F D Y) (* u *) ) := - {| body R := @ss'_gen E F C D R R (* simulation: R and Reps are the same relation *) - |}. -Next Obligation. -Proof. - split; intros; destruct H0. - - destruct (H0 _ _ H1 H2) as (l'' & u'' & Htrans & HRtu & HL'). - eauto 12. - - apply H2 in H1 as (u' & Htrans & HRtu). eauto. + fun (R : forall (X Y : Type), + lrel E F X Y -> (* L *) + hrel (@S E C X) (* t *) + (@S F D Y) (* u *) + ) => @ss'_gen E F C D R R. (* simulation: R and Reps are the same relation *) + +#[global] Instance ss'__mon {E F C D} : Proper (leq ==> leq) (@ss'_ E F C D). +Proof. + intros R R' HR. now apply ss'_gen_mon. Qed. + + Program Definition ss' {E F C D : Type -> Type} : + mon (forall (X Y : Type), + lrel E F X Y -> (* L *) + hrel (@S E C X) (* t *) + (@S F D Y) (* u *) + ) := + {| body R := @ss'_ E F C D R ; Hbody := ss'__mon (* simulation: R and Reps are the same relation *) + |}. + #[global] Instance weq_ss' {E F C D} : Proper (weq ==> weq) (@ss' E F C D). Proof. @@ -744,8 +774,7 @@ Section upto. - intros ? INC X Y L x y (? & ? & ?) ??; red. apply INC; auto. eexists; split; eauto. - apply leq_infx in H1. - now apply H1. + apply H0, H1. - clear. intros R IH X Y L t u (u' & STAR & HSS). eapply step_ss'_epsilon_r; [ exact HSS | exact STAR ]. diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v index 7ca4248..47d6201 100644 --- a/theories/Eq/TransAlt.v +++ b/theories/Eq/TransAlt.v @@ -2284,6 +2284,12 @@ Proof. intros f e; split; cbn; intros []; constructor; auto. Qed. +Lemma flipL_flipL {E F X Y} (L : lrel E F X Y) : + flipL (flipL L) = L. +Proof. + now destruct L. +Qed. + Lemma lequiv_sub_lrel {E F X Y} (L L' : lrel E F X Y): sub_lrel L L' -> sub_lrel (flipL L) (flipL L'). From 16dbf7c8f54b7d40aeafbef30c20ce4d4befbb1a Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 30 Jul 2026 14:35:05 +0200 Subject: [PATCH 53/61] Done up to up to bind, needs some renaming. removing uvr. --- theories/Eq/SBisimAlt.v | 793 +++++++++++++++++++++------------------- theories/Eq/SSimAlt.v | 41 +++ theories/Eq/TransAlt.v | 12 + 3 files changed, 464 insertions(+), 382 deletions(-) diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 2e61cd2..c23ceef 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -16,6 +16,7 @@ From CTree Require Import Eq.Equ Eq.TransAlt Eq.Epsilon + Eq.EstarTheory Eq.SSimAlt Misc.Pure. @@ -108,23 +109,22 @@ Lemma sb'_flip {E F C D X Y} {L : lrel E F X Y} @sb' F E D C (fun b X Y L t u => R (negb b) Y X (flipL L) u t) (negb side) Y X (flipL L) u t -> sb' R side X Y L t u. Proof. - split; intros; subst; destruct H; cbn in H. - - specialize (H0 eq_refl). - cbn -[ss'_gen] in H0. unfold flip in H0. - eapply (ss'_gen_mon (x := fun t u => forall side, R (negb side) t u)). - { cbn. intros. specialize (H1 (negb side)). rewrite Bool.negb_involutive in H1. apply H1. } - { cbn. intros. apply H1. } - apply H0. - - specialize (H eq_refl). - cbn -[ss'_gen] in H. - eapply (ss'_gen_mon (x := fun t u => forall side, R (negb side) u t)). - { cbn. intros. specialize (H1 (negb side)). rewrite Bool.negb_involutive in H1. apply H1. } - { cbn. intros. apply H1. } - apply H. + intros [Ht Hf]. + split; intros; subst. + - specialize (Hf eq_refl). + eapply ss'_gen_mon. 3: now apply Hf. + + cbn. intros ? ? ? ? ? Hall s. + specialize (Hall (negb s)). now rewrite Bool.negb_involutive in Hall. + + cbn. intros. assumption. + - specialize (Ht eq_refl). + eapply ss'_gen_mon. 3: now apply Ht. + + cbn. intros ? ? ? ? ? Hall s. + specialize (Hall (negb s)). now rewrite Bool.negb_involutive in Hall. + + cbn. intros. assumption. Qed. -Definition sbisim' {E F B X} L t u := - forall side, gfp (@sb' E F B X L) side t u. +Definition sbisim' {E F C D X Y} (L : lrel E F X Y) (t : S E C X) (u : S F D Y) := + forall side, gfp (@sb' E F C D) side X Y L t u. Program Definition lift_rel3 {A B} : mon (rel A B) -> mon (bool -> rel A B) := fun f => {| body R side := f (R side) |}. @@ -146,66 +146,130 @@ Qed. Section sbisim'_theory. Arguments label: clear implicits. - Context {E F B: Type -> Type} {X : Type} - {L: rel (@label E X) (@label F X)}. + Context {E F C D: Type -> Type} {X Y : Type} + {L: lrel E F X Y}. (*| Strong bisimulation up-to [Seq] is valid ---------------------------------------- |*) - Lemma Seq_clos_sb' {c: Chain (@sb' E F B X L)}: - forall b x y, lift_rel3 Seq_clos `c b x y -> `c b x y. + #[global] Instance Seq_proper_sb'_chain_goal {c: Chain (@sb' E F C D)} : + forall side, Proper (Seq ==> Seq ==> flip impl) (`c side X Y L). Proof. - apply tower. - - intros ? INC side x y [t t' u' u EQt HR EQu] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - clear. - intros R IH side x y [t t' u' u EQt HR EQu]. + tower induction. + - intros CIH side x y Hseq x' y' Hseq2 [Ht Hf]. split; intro; subst. - + destruct HR as [HR _]; specialize (HR eq_refl). - rewrite EQt, <- EQu; exact HR. - + destruct HR as [_ HR]; specialize (HR eq_refl). - rewrite EQt, <- EQu; exact HR. + + destruct (Ht eq_refl) as [Hnonep Hep]; split; intros. + * rewrite Hseq in H0. destruct (Hnonep _ _ H H0) as + (l' & u' & Htr & Hc & HL). + rewrite <- Hseq2 in Htr. + exists l', u'; split; eauto. + * rewrite Hseq in H. apply Hep in H as (u' & Htr & Hc). + rewrite <- Hseq2 in Htr. + exists u'; split; eauto. + + destruct (Hf eq_refl) as [Hnonep Hep]; split; intros. + * rewrite Hseq2 in H0. destruct (Hnonep _ _ H H0) as + (l' & u' & Htr & Hc & HL). + rewrite <- Hseq in Htr. + exists l', u'; split; eauto. + * rewrite Hseq2 in H. apply Hep in H as (u' & Htr & Hc). + rewrite <- Hseq in Htr. + exists u'; split; eauto. Qed. - #[global] Instance Seq_clos_sb'_chain {c: Chain (@sb' E F B X L)} : - forall side, Proper (Seq ==> Seq ==> iff) (`c side). + #[global] Instance Seq_proper_sb'_chain_ctx {c: Chain (@sb' E F C D)} : + forall side, Proper (Seq ==> Seq ==> impl) (`c side X Y L). Proof. - split; intros. - - symmetry in H. - apply Seq_clos_sb'; econstructor; eauto. - - symmetry in H0. apply Seq_clos_sb'; econstructor; eauto. + tower induction. + - intros CIH side x y Hseq x' y' Hseq2 [Ht Hf]. + split; intro; subst. + + destruct (Ht eq_refl) as [Hnonep Hep]; split; intros. + * rewrite <- Hseq in H0. destruct (Hnonep _ _ H H0) as + (l' & u' & Htr & Hc & HL). + rewrite Hseq2 in Htr. + exists l', u'; split; eauto. + * rewrite <- Hseq in H. apply Hep in H as (u' & Htr & Hc). + rewrite Hseq2 in Htr. + exists u'; split; eauto. + + destruct (Hf eq_refl) as [Hnonep Hep]; split; intros. + * rewrite <- Hseq2 in H0. destruct (Hnonep _ _ H H0) as + (l' & u' & Htr & Hc & HL). + rewrite Hseq in Htr. + exists l', u'; split; eauto. + * rewrite <- Hseq2 in H. apply Hep in H as (u' & Htr & Hc). + rewrite Hseq in Htr. + exists u'; split; eauto. Qed. - #[global] Instance Seq_clos_st'_ctx4 {c: Chain (@sb' E F B X L)} : - Proper (eq ==> Seq ==> Seq ==> impl) `c. + #[global] Instance Seq_proper_sb'_chain_ctx4 {c: Chain (@sb' E F C D)} : + Proper (eq ==> Seq ==> Seq ==> impl) (fun side => `c side X Y L). Proof. intros ? side -> ? ? eq1 ? ? eq2 H. now rewrite <- eq1, <- eq2. Qed. - #[global] Instance Seq_clos_sb'_gfp : forall side, Proper (Seq ==> Seq ==> iff) (gfp (@sb' E F B X L) side). + #[global] Instance Seq_proper_sb'_gfp_goal : + forall side, Proper (Seq ==> Seq ==> flip impl) (gfp (@sb' E F C D) side X Y L). + Proof. + exact (@Seq_proper_sb'_chain_goal (chain_gfp (@sb' E F C D))). + Qed. + + #[global] Instance Seq_proper_sb'_gfp_ctx : + forall side, Proper (Seq ==> Seq ==> impl) (gfp (@sb' E F C D) side X Y L). + Proof. + exact (@Seq_proper_sb'_chain_ctx (chain_gfp (@sb' E F C D))). + Qed. + + #[global] Instance Seq_proper_sbisim'_goal : + Proper (Seq ==> Seq ==> flip impl) (@sbisim' E F C D X Y L). Proof. - exact (@Seq_clos_sb'_chain (chain_gfp (sb' L))). + intros x y Hseq x' y' Hseq2 H side. + now rewrite Hseq, Hseq2. Qed. - #[global] Instance Seq_clos_sbisim' : Proper (Seq ==> Seq ==> iff) (@sbisim' E F B X L). + #[global] Instance Seq_proper_sbisim'_ctx : + Proper (Seq ==> Seq ==> impl) (@sbisim' E F C D X Y L). Proof. - unfold sbisim'. repeat red; split; intros. - - now rewrite <- H, <- H0. - - now rewrite H, H0. + intros x y Hseq x' y' Hseq2 H side. + now rewrite <- Hseq, <- Hseq2. Qed. End sbisim'_theory. +Lemma lequiv_sb'_chain {E F C D} {c : Chain (@sb' E F C D)} : + forall side X Y (L L' : lrel E F X Y), + lequiv L L' -> `c side X Y L <= `c side X Y L'. +Proof. + tower induction. + - intros IH side X Y L L' HL t u [Ht Hf]. + split; intro; subst. + + specialize (Ht eq_refl). + revert Ht. apply lequiv_ss'_gen. + * assumption. + * cbn. intros ? ? H s. eapply IH; [exact HL | apply H]. + * cbn. intros ? ? H. eapply IH; [exact HL | exact H]. + + specialize (Hf eq_refl). + revert Hf. apply lequiv_ss'_gen. + * now apply lequiv_flipL. + * cbn. intros ? ? H s. eapply IH; [exact HL | apply H]. + * cbn. intros ? ? H. eapply IH; [exact HL | exact H]. +Qed. + +Lemma sb'_chain_flip {E C} {c : Chain (@sb' E E C C)} : + forall side X Y (L : lrel E E X Y) t u, + `c (negb side) Y X (flipL L) u t <-> `c side X Y L t u. +Proof. + intros side X Y L t u. + exact (invol_chain (i := @converse_neg E C) c side X Y L t u). +Qed. + Ltac fold_sbisim' := repeat match goal with - | h: context[gfp (@sb' ?E ?F ?B ?X ?L)] |- _ => try fold (@sbisim' E F B X L) in h - | |- context[gfp (@sb' ?E ?F ?B ?X ?L)] => try fold (@sbisim' E F B X L) + | h: context[gfp (@sb' ?E ?F ?C ?D) ?side ?X ?Y ?L] |- _ => + try fold (@sbisim' E F C D X Y L) in h + | |- context[gfp (@sb' ?E ?F ?C ?D) ?side ?X ?Y ?L] => + try fold (@sbisim' E F C D X Y L) end. Tactic Notation "__coinduction_sbisim'" simple_intropattern(r) simple_intropattern(cih) := @@ -213,42 +277,49 @@ Tactic Notation "__coinduction_sbisim'" simple_intropattern(r) simple_intropatte Tactic Notation "__step_sbisim'" := match goal with - | |- context[@sbisim' ?E ?F ?B ?X ?LR] => + | |- context[@sbisim' ?E ?F ?C ?D ?X ?Y ?LR] => unfold sbisim'; intro; step end. -Tactic Notation "step" := __step_sbisim' || step. +Ltac __step_sb' := + first [ apply (b_chain (b := @sb' _ _ _ _) _) + | apply (gfp_fp (@sb' _ _ _ _)) ]. + +Tactic Notation "step" := __step_sbisim' || __step_sb' || step. Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) := __coinduction_sbisim' R H || coinduction R H. Ltac __step_in_sbisim' H := match type of H with - | context[@sbisim' ?E ?F ?B ?X ?LR] => + | context[@sbisim' ?E ?F ?C ?D ?X ?Y ?LR] => unfold sbisim' in H; let Hl := fresh H "l" in let Hr := fresh H "r" in pose proof (H true) as Hl; pose proof (H false) as Hr; step in Hl; step in Hr; - try fold (@sbisim' E F B X LR) in Hl; - try fold (@sbisim' E F B X LR) in Hr + try fold (@sbisim' E F C D X Y LR) in Hl; + try fold (@sbisim' E F C D X Y LR) in Hr end. -Tactic Notation "step" "in" ident(H) := __step_in_sbisim' H || step in H. +Ltac __step_in_sb' H := apply (gfp_pfp (@sb' _ _ _ _)) in H. + +Tactic Notation "step" "in" ident(H) := + __step_in_sbisim' H || __step_in_sb' H || step in H. Import CTreeNotations. Import EquNotations. Section sbisim'_homogenous_theory. Context {E B: Type -> Type} {X: Type} - {L: relation (@label E X)}. + {L: lrel E E X X}. - Notation sb' := (@sb' E E B X). - Notation sbisim' := (@sbisim' E E B X). + Notation sb' := (@sb' E E B B). + Notation sbisim' := (@sbisim' E E B B X X). - #[global] Instance refl_sb' {LR: Reflexive L} {C: Chain (sb' L)} - : forall side, Reflexive (`C side). + #[global] Instance refl_sb' {LR: Reflexive L} {C: Chain sb'} + : forall side, Reflexive (`C side X X L). Proof. apply tower. - cbv. firstorder. @@ -256,7 +327,7 @@ Section sbisim'_homogenous_theory. split; intros _; split. + intros t' l Hne TR. exists l, t'; ssplit. - * apply trans_alt_estar_l; exact TR. + * apply estar_l_lift; exact TR. * intro; apply IH. * apply LR. + intros t' TR. @@ -265,17 +336,17 @@ Section sbisim'_homogenous_theory. * apply IH. + intros t' l Hne TR. exists l, t'; ssplit. - * apply trans_alt_estar_l; exact TR. + * apply estar_l_lift; exact TR. * intro; apply IH. - * apply LR. + * reflexivity. + intros t' TR. exists t'; split. * apply estar_single; exact TR. * apply IH. Qed. - #[global] Instance refl_bsb' {LR: Reflexive L} {C: Chain (sb' L)} - : forall side, Reflexive (sb' L `C side). + #[global] Instance refl_bsb' {LR: Reflexive L} {C: Chain sb'} + : forall side, Reflexive (sb' `C side X X L). Proof. intros ??. apply refl_sb'. @@ -287,33 +358,18 @@ Section sbisim'_homogenous_theory. intros ??; apply refl_sb'. Qed. - Lemma sym_sb {LT: Symmetric L} {C: Chain (sb' L)} : - forall side x y, `C (negb side) x y -> `C side y x. + Lemma sym_sb {LT: Symmetric L} {C: Chain sb'} : + forall side x y, `C (negb side) X X L x y -> `C side X X L y x. Proof. - apply tower. - - cbv. firstorder. - - clear C. - intros R IH ? x y EQC. - split; intros EQ. - + subst. - destruct EQC as [_ EQC]; specialize (EQC eq_refl). - eapply (weq_ss'_gen (x := L)) in EQC. 2: { split; apply LT. } - eapply ss'_gen_mon. - 3:apply EQC. - { cbn. intros. apply IH; auto. } - { cbn. intros. apply IH, H. } - + subst. - destruct EQC as [EQC _]; specialize (EQC eq_refl). - eapply (weq_ss'_gen (x := flip L)) in EQC. 2: { split; apply LT. } - eapply ss'_gen_mon. - 3:apply EQC. - { cbn. intros. apply IH, H. } - { cbn. intros. apply IH, H. } - Qed. - - Lemma st'_flip `{SL: Symmetric _ L} {C: Chain (sb' L)}: + intros side x y H. + apply sb'_chain_flip. + eapply lequiv_sb'_chain; [| exact H]. + symmetry. apply lequiv_flipL_sym. + Qed. + + Lemma st'_flip `{SL: Symmetric _ L} {C: Chain sb'}: forall b t u, - `C b t u <-> `C (negb b) u t. + `C b X X L t u <-> `C (negb b) X X L u t. Proof. split; intro; apply sym_sb; auto. now rewrite Bool.negb_involutive. @@ -328,10 +384,10 @@ Section sbisim'_homogenous_theory. End sbisim'_homogenous_theory. -Lemma split_st' : forall {E B X L} `{SL: Symmetric _ L} (t u : ctree E B X) - {C: Chain (sb' L)}, - (forall side, `C side t u) <-> - `C true t u /\ `C true u t. +Lemma split_st' : forall {E B X} {L : lrel E E X X} `{SL: Symmetric _ L} + (t u : ctree E B X) {C: Chain (@sb' E E B B)}, + (forall side, `C side X X L t u) <-> + `C true X X L t u /\ `C true X X L u t. Proof. intros. split; intros. - split; auto. @@ -340,23 +396,23 @@ Proof. now apply st'_flip. Qed. -Lemma split_st'_eq : forall {E B X} (t u : ctree E B X) {C: Chain (sb' eq)}, - (forall side, `C side t u) <-> - `C true t u /\ `C true u t. +Lemma split_st'_eq : forall {E B X} (t u : ctree E B X) {C: Chain (@sb' E E B B)}, + (forall side, `C side X X Leq t u) <-> + `C true X X Leq t u /\ `C true X X Leq u t. Proof. intros. apply split_st'. Qed. Section sbisim'_heterogenous_theory. Arguments label: clear implicits. - Context {E F B: Type -> Type} {X: Type} - {L: rel (@label E X) (@label F X)}. + Context {E F C D: Type -> Type} {X Y: Type} + {L: lrel E F X Y}. - Notation sb' := (@sb' E F B X). - Notation sbisim' := (@sbisim' E F B X). + Notation sb' := (@sb' E F C D). + Notation sbisim' := (@sbisim' E F C D X Y). #[global] Instance Seq_sb'_goal {RR} : - forall b, Proper (Seq ==> Seq ==> flip impl) (sb' L RR b). + forall b, Proper (Seq ==> Seq ==> flip impl) (sb' RR b X Y L). Proof. intros b x x' eq1 y y' eq2 H. split; intro; subst. @@ -367,15 +423,16 @@ Section sbisim'_heterogenous_theory. Qed. #[global] Instance Seq_sb'_ctx {RR} : - Proper (eq ==> Seq ==> Seq ==> impl) (sb' L RR). + Proper (eq ==> Seq ==> Seq ==> impl) (fun b => sb' RR b X Y L). Proof. intros ? b -> ? ? eq1 ? ? eq2 H. now rewrite <- eq1, <- eq2. Qed. Lemma sb'_true_ss' R : - forall (t : @SS E B X) (u : @SS F B X), - sb' L R true t u <-> ss'_gen L (fun t u => forall side, R side t u) (R true) t u. + forall (t : @S E C X) (u : @S F D Y), + sb' R true X Y L t u <-> + ss'_gen (fun X Y L t u => forall side, R side X Y L t u) (R true) L t u. Proof. split; intros. - now apply H. @@ -383,8 +440,11 @@ Section sbisim'_heterogenous_theory. Qed. Lemma sb'_false_ss' R : - forall (t : @SS E B X) (u : @SS F B X), - sb' L R false t u <-> ss'_gen (flip L) (fun u t => forall side, R side t u) (flip (R false)) u t. + forall (t : @S E C X) (u : @S F D Y), + sb' R false X Y L t u <-> + @ss'_gen F E D C (fun Y X L t' u' => forall side, R side X Y (flipL L) u' t') + (fun Y X (L : lrel F E Y X) u' t' => R false X Y (flipL L) t' u') + Y X (flipL L) u t. Proof. split; intros. - now apply H. @@ -392,8 +452,8 @@ Section sbisim'_heterogenous_theory. Qed. Lemma sb'_true_stuck R : - forall (u : @SS F B X), - sb' L R true (Stuck : ctree E B X) u. + forall (u : @S F D Y), + sb' R true X Y L (Stuck : ctree E C X) u. Proof. intros. apply sb'_true_ss'. apply ss'_stuck. @@ -401,9 +461,9 @@ Section sbisim'_heterogenous_theory. End sbisim'_heterogenous_theory. -Lemma sb'_stuck {E F B X L} R : +Lemma sb'_stuck {E F C D X Y} {L : lrel E F X Y} R : forall side, - sb' L R side (Stuck : ctree E B X) (Stuck : ctree F B X). + sb' R side X Y L (Stuck : ctree E C X) (Stuck : ctree F D Y). Proof. intros. destruct side. - apply sb'_true_stuck. @@ -417,60 +477,66 @@ Qed. [R true] and [flip (R false)]; the following instances discharge those side-conditions from a single Properness assumption on [R]. |*) -#[global] Instance Proper_forall_R {E F B X} - {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} : - Proper (Seq ==> Seq ==> impl) (fun t u => forall side, R side t u). +Notation sb'R E F C D := + (bool -> forall X Y : Type, lrel E F X Y -> rel (@S E C X) (@S F D Y)). + +Notation sb'Proper R := + (forall X Y (L : lrel _ _ X Y), + Proper (eq ==> Seq ==> Seq ==> impl) (fun b => R b X Y L)). + +#[global] Instance Proper_forall_R {E F C D X Y} + {R : sb'R E F C D} {L : lrel E F X Y} + {HR: sb'Proper R} : + Proper (Seq ==> Seq ==> impl) (fun t u => forall side, R side X Y L t u). Proof. intros ? ? eq1 ? ? eq2 H side; eapply HR; eauto. Qed. -#[global] Instance Proper_forall_R_flip {E F B X} - {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} : - Proper (Seq ==> Seq ==> impl) (fun u t => forall side, R side t u). +#[global] Instance Proper_forall_R_flip {E F C D X Y} + {R : sb'R E F C D} {L : lrel E F X Y} + {HR: sb'Proper R} : + Proper (Seq ==> Seq ==> impl) (fun u t => forall side, R side X Y L t u). Proof. intros ? ? eq1 ? ? eq2 H side; eapply HR; eauto. Qed. -#[global] Instance Proper_R_side {E F B X} - {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} side : - Proper (Seq ==> Seq ==> impl) (R side). +#[global] Instance Proper_R_side {E F C D X Y} + {R : sb'R E F C D} {L : lrel E F X Y} + {HR: sb'Proper R} side : + Proper (Seq ==> Seq ==> impl) (R side X Y L). Proof. intros ? ? eq1 ? ? eq2 H; eapply HR; eauto. Qed. -#[global] Instance Proper_R_side_flip {E F B X} - {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} side : - Proper (Seq ==> Seq ==> impl) (flip (R side)). +#[global] Instance Proper_R_side_flip {E F C D X Y} + {R : sb'R E F C D} {L : lrel E F X Y} + {HR: sb'Proper R} side : + Proper (Seq ==> Seq ==> impl) (fun u t => R side X Y L t u). Proof. - intros ? ? eq1 ? ? eq2 H; unfold flip in *; eapply HR; eauto. + intros ? ? eq1 ? ? eq2 H; eapply HR; eauto. Qed. Section Proof_Rules. Arguments label: clear implicits. - Context {E F B: Type -> Type} - {X: Type} - {L : rel (@label E X) (@label F X)}. + Context {E F C D: Type -> Type} + {X Y: Type} + {L : lrel E F X Y}. - Lemma step_sb'_ret {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} - (x : X) (y : X) : + Lemma step_sb'_ret {R : sb'R E F C D} {HR: sb'Proper R} + (x : X) (y : Y) : L (val x) (val y) -> - (forall side, R side Stuck Stuck) -> - forall side, sb' L R side (Ret x : ctree E B X) (Ret y : ctree F B X). + (forall side, R side X Y L Stuck Stuck) -> + forall side, sb' R side X Y L (Ret x : ctree E C X) (Ret y : ctree F D Y). Proof. intros Lval Rstuck side; split; intro; subst. - apply step_ss'_ret; [apply Rstuck | exact Lval]. - - apply step_ss'_ret; [apply Rstuck | exact Lval]. + - apply step_ss'_ret; [apply Rstuck | now apply flipL_flip]. Qed. - Lemma step_sbt'_ret (x y : X) {R : Chain (sb' L)} : + Lemma step_sbt'_ret (x : X) (y : Y) {R : Chain (@sb' E F C D)} : L (val x) (val y) -> - forall side, `R side (Ret x : ctree E B X) (Ret y : ctree F B X). + forall side, `R side X Y L (Ret x : ctree E C X) (Ret y : ctree F D Y). Proof. intros HL side. apply (b_chain R), step_sb'_ret. @@ -482,36 +548,33 @@ Section Proof_Rules. The vis nodes are deterministic from the perspective of the labeled transition system: both sides step to the corresponding passive states. |*) - Lemma step_sb'_vis {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + Lemma step_sb'_vis {R : sb'R E F C D} {HR: sb'Proper R} {Z Z'} (e : E Z) (f: F Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : - (forall side, R side (Passive e k) (Passive f k')) -> + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + (forall side, R side X Y L (Passive e k) (Passive f k')) -> L (ask e) (ask f) -> - forall side, sb' L R side (Vis e k) (Vis f k'). + forall side, sb' R side X Y L (Vis e k) (Vis f k'). Proof. intros HRpas Lask side; split; intro; subst. - apply step_ss'_vis; [apply HRpas | exact Lask]. - - apply step_ss'_vis; [apply HRpas | exact Lask]. + - apply step_ss'_vis; [apply HRpas | now apply flipL_flip]. Qed. - Lemma step_sb'_vis_id {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} + Lemma step_sb'_vis_id {R : sb'R E F C D} {HR: sb'Proper R} {Z} (e : E Z) (f: F Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) : - (forall side, R side (Passive e k) (Passive f k')) -> + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : + (forall side, R side X Y L (Passive e k) (Passive f k')) -> L (ask e) (ask f) -> - forall side, sb' L R side (Vis e k) (Vis f k'). + forall side, sb' R side X Y L (Vis e k) (Vis f k'). Proof. intros; now apply step_sb'_vis. Qed. - Lemma step_sb'_vis_l {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} {Z} : - forall (e : E Z) (k : Z -> ctree E B X) (u : @SS F B X), + Lemma step_sb'_vis_l {R : sb'R E F C D} {HR: sb'Proper R} {Z} : + forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' - /\ (forall side, R side (Passive e k) u') /\ L (ask e) l') -> - sb' L R true (Vis e k) u. + /\ (forall side, R side X Y L (Passive e k) u') /\ L (ask e) l') -> + sb' R true X Y L (Vis e k) u. Proof. intros e k u (l' & u' & STEP & HRu & Hask). split; intro; [| easy]. @@ -525,30 +588,29 @@ Section Proof_Rules. (*| With this definition [sb'] of bisimulation, delayed nodes allow to perform a coinductive step. |*) - Lemma step_sb'_guard {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} - (t: ctree E B X) (t': ctree F B X) side : - R side t t' -> - sb' L R side (Guard t) (Guard t'). + Lemma step_sb'_guard {R : sb'R E F C D} {HR: sb'Proper R} + (t: ctree E C X) (t': ctree F D Y) side : + R side X Y L t t' -> + sb' R side X Y L (Guard t) (Guard t'). Proof. intros HRtt'; split; intro; subst; apply step_ss'_guard; exact HRtt'. Qed. Lemma step_sb'_true_guard_l - {R : Chain (sb' L)} - (t: ctree E B X) (t': @SS F B X) : - ` R true t t' -> - sb' L `R true (Guard t) t'. + {R : Chain (@sb' E F C D)} + (t: ctree E C X) (t': @S F D Y) : + ` R true X Y L t t' -> + sb' `R true X Y L (Guard t) t'. Proof. intros H; split; intro; [| easy]. apply step_ss'_guard_l; exact H. Qed. Lemma step_sb'_guard_l - {R : Chain (sb' L)} - (t: ctree E B X) (t': @SS F B X) side : - sb' L (` R) side t t' -> - sb' L `R side (Guard t) t'. + {R : Chain (@sb' E F C D)} + (t: ctree E C X) (t': @S F D Y) side : + sb' (` R) side X Y L t t' -> + sb' `R side X Y L (Guard t) t'. Proof. intros H; split; intro; subst. - apply step_ss'_guard_l. @@ -557,20 +619,20 @@ Section Proof_Rules. Qed. Lemma step_sb'_false_guard_r - {R : Chain (sb' L)} - (t: @SS E B X) (t': ctree F B X) : - ` R false t t' -> - sb' L `R false t (Guard t'). + {R : Chain (@sb' E F C D)} + (t: @S E C X) (t': ctree F D Y) : + ` R false X Y L t t' -> + sb' `R false X Y L t (Guard t'). Proof. intros H; split; intro; [easy |]. apply step_ss'_guard_l; exact H. Qed. Lemma step_sb'_guard_r - {R : Chain (sb' L)} - (t: @SS E B X) (t': ctree F B X) side : - sb' L (` R) side t t' -> - sb' L `R side t (Guard t'). + {R : Chain (@sb' E F C D)} + (t: @S E C X) (t': ctree F D Y) side : + sb' (` R) side X Y L t t' -> + sb' `R side X Y L t (Guard t'). Proof. intros H; split; intro; subst. - apply step_ss'_guard_r; now apply H. @@ -578,43 +640,41 @@ Section Proof_Rules. apply (b_chain R); exact H. Qed. - Lemma step_sb'_br {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} - {Z Z'} (a: B Z) (b: B Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) side : - (forall x, exists y, R side (k x) (k' y)) -> - (forall y, exists x, R side (k x) (k' y)) -> - sb' L R side (Br a k) (Br b k'). + Lemma step_sb'_br {R : sb'R E F C D} {HR: sb'Proper R} + {Z Z'} (a: C Z) (b: D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) side : + (forall x, exists y, R side X Y L (k x) (k' y)) -> + (forall y, exists x, R side X Y L (k x) (k' y)) -> + sb' R side X Y L (Br a k) (Br b k'). Proof. intros H1 H2; split; intro; subst; apply step_ss'_br. - intro x; destruct (H1 x) as (y & ?); eauto. - intro y; destruct (H2 y) as (x & ?); eauto. Qed. - Lemma step_sb'_br_id {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} - {Z} (c: B Z) (d: B Z) - (k : Z -> ctree E B X) (k' : Z -> ctree F B X) side : - (forall x, R side (k x) (k' x)) -> - sb' L R side (Br c k) (Br d k'). + Lemma step_sb'_br_id {R : sb'R E F C D} {HR: sb'Proper R} + {Z} (c: C Z) (d: D Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) side : + (forall x, R side X Y L (k x) (k' x)) -> + sb' R side X Y L (Br c k) (Br d k'). Proof. intros. apply step_sb'_br; eauto. Qed. - Lemma step_sb'_true_br_l {R : Chain (sb' L)} {Z} : - forall (c : B Z) (k : Z -> ctree E B X) (u : @SS F B X), - (forall x, `R true (k x) u) -> - sb' L `R true (Br c k) u. + Lemma step_sb'_true_br_l {R : Chain (@sb' E F C D)} {Z} : + forall (c : C Z) (k : Z -> ctree E C X) (u : @S F D Y), + (forall x, `R true X Y L (k x) u) -> + sb' `R true X Y L (Br c k) u. Proof. intros c k u H; split; intro; [| easy]. apply step_ss'_br_l. intro x; apply H. Qed. - Lemma step_sb'_br_l {R : Chain (sb' L)} {Z} : - forall (c : B Z) (z : Z) (k : Z -> ctree E B X) (u : @SS F B X) side, - (forall x, sb' L `R side (k x) u) -> - sb' L `R side (Br c k) u. + Lemma step_sb'_br_l {R : Chain (@sb' E F C D)} {Z} : + forall (c : C Z) (z : Z) (k : Z -> ctree E C X) (u : @S F D Y) side, + (forall x, sb' `R side X Y L (k x) u) -> + sb' `R side X Y L (Br c k) u. Proof. intros c z k u side H; split; intro; subst. - apply step_ss'_br_l. @@ -625,16 +685,15 @@ Section Proof_Rules. (*| Step |*) - Lemma step_sb'_step {R : bool -> rel (@SS E B X) (@SS F B X)} - {HR: Proper (eq ==> Seq ==> Seq ==> impl) R} - (t : ctree E B X) (t': ctree F B X) : + Lemma step_sb'_step {R : sb'R E F C D} {HR: sb'Proper R} + (t : ctree E C X) (t': ctree F D Y) : L τ τ -> - (forall side, R side t t') -> - forall side, sb' L R side (Step t) (Step t'). + (forall side, R side X Y L t t') -> + forall side, sb' R side X Y L (Step t) (Step t'). Proof. intros Hτ HRtt' side; split; intro; subst. - apply step_ss'_step; [exact Hτ | apply HRtt']. - - apply step_ss'_step; [exact Hτ | apply HRtt']. + - apply step_ss'_step; [now apply flipL_flip | apply HRtt']. Qed. End Proof_Rules. @@ -645,14 +704,14 @@ End Proof_Rules. A useful special case is the one where the arity coincide and we simply use the identity in both directions. We can in this case have [n] rather than [2n] obligations. |*) -Lemma step_sb'_brS {E F B X L} - {R : Chain (sb' L)} - {Z Z'} (c : B Z) (d : B Z') - (k : Z -> ctree E B X) (k' : Z' -> ctree F B X) : - (forall x, exists y, forall side, `R side (k x) (k' y)) -> - (forall y, exists x, forall side, `R side (k x) (k' y)) -> +Lemma step_sb'_brS {E F C D X Y} {L : lrel E F X Y} + {R : Chain (@sb' E F C D)} + {Z Z'} (c : C Z) (d : D Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + (forall x, exists y, forall side, `R side X Y L (k x) (k' y)) -> + (forall y, exists x, forall side, `R side X Y L (k x) (k' y)) -> L τ τ -> - forall side, sb' L `R side (BrS c k) (BrS d k'). + forall side, sb' `R side X Y L (BrS c k) (BrS d k'). Proof. intros H1 H2 Hτ side. apply step_sb'_br. @@ -662,25 +721,25 @@ Proof. step. now apply step_sb'_step. Qed. -Lemma step_sb'_brS_id {E F B X L} - {R : Chain (sb' L)} - {Z} (c : B Z) (d: B Z) - (k: Z -> ctree E B X) (k': Z -> ctree F B X) : +Lemma step_sb'_brS_id {E F C D X Y} {L : lrel E F X Y} + {R : Chain (@sb' E F C D)} + {Z} (c : C Z) (d: D Z) + (k: Z -> ctree E C X) (k': Z -> ctree F D Y) : L τ τ -> - (forall x side, `R side (k x) (k' x)) -> - forall side, sb' L `R side (BrS c k) (BrS d k'). + (forall x side, `R side X Y L (k x) (k' x)) -> + forall side, sb' `R side X Y L (BrS c k) (BrS d k'). Proof. intros Hτ H side. apply step_sb'_br_id. intro x; apply (b_chain R), step_sb'_step; auto. Qed. -Lemma step_sb'_true_step_l {E F B X L} - {R : Chain (sb' L)} : - forall (t : ctree E B X) (u : @SS F B X), +Lemma step_sb'_true_step_l {E F C D X Y} {L : lrel E F X Y} + {R : Chain (@sb' E F C D)} : + forall (t : ctree E C X) (u : @S F D Y), (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' - /\ (forall side, `R side t u') /\ L τ l') -> - sb' L `R true (Step t) u. + /\ (forall side, `R side X Y L t u') /\ L τ l') -> + sb' `R true X Y L (Step t) u. Proof. intros t u (l' & u' & STEP & HR' & Hτ). split; intro; [| easy]. @@ -691,13 +750,13 @@ Proof. - exact Hτ. Qed. -Lemma step_sb'_true_brS_l {E F B X L} - {R : Chain (sb' L)} +Lemma step_sb'_true_brS_l {E F C D X Y} {L : lrel E F X Y} + {R : Chain (@sb' E F C D)} {Z} : - forall (c : B Z) (k : Z -> ctree E B X) (u : @SS F B X), + forall (c : C Z) (k : Z -> ctree E C X) (u : @S F D Y), (forall x, exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' - /\ (forall side, `R side (k x) u') /\ L τ l') -> - sb' L `R true (BrS c k) u. + /\ (forall side, `R side X Y L (k x) u') /\ L τ l') -> + sb' `R true X Y L (BrS c k) u. Proof. intros c k u H. apply step_sb'_true_br_l; intro x. @@ -707,15 +766,15 @@ Qed. Section Inversion_Rules. - Context {E F B: Type -> Type} - {X: Type}. - Variable (L : rel (@label E X) (@label F X)). + Context {E F C D: Type -> Type} + {X Y: Type}. + Variable (L : lrel E F X Y). (* Lemmas to exploit sb' and sbisim' hypotheses *) - Lemma estar_vis_inv {G : Type -> Type} {Z} (e : G Z) (k : Z -> ctree G B X) (m : @SS G B X) : + Lemma estar_vis_inv {G K : Type -> Type} {W Z} (e : G Z) (k : Z -> ctree G K W) (m : @S G K W) : (trans_alt ε)^* (Active (Vis e k)) m -> - (Active (Vis e k) : @SS G B X) ⩸ m. + (Active (Vis e k) : @S G K W) ⩸ m. Proof. intros [n STAR]; destruct n. - exact STAR. @@ -724,20 +783,20 @@ Section Inversion_Rules. Qed. Lemma sb'_true_vis_l_inv {Z R} : - forall (e : E Z) (k : Z -> ctree E B X) (u : @SS F B X), - sb' L R true (Vis e k) u -> + forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), + sb' R true X Y L (Vis e k) u -> exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' - /\ (forall side, R side (Passive e k) u') /\ L (ask e) l'. + /\ (forall side, R side X Y L (Passive e k) u') /\ L (ask e) l'. Proof. intros. apply sb'_true_ss' in H. now apply ss'_vis_l_inv in H. Qed. Lemma sb'_true_vis_inv {Z Z' R} : - forall (e : E Z) (f : F Z') (k : Z -> ctree E B X) (k' : Z' -> ctree F B X), - (Proper (eq ==> Seq ==> Seq ==> impl) R) -> - sb' L R true (Vis e k) (Vis f k') -> - (forall side, R side (Passive e k) (Passive f k')) /\ L (ask e) (ask f). + forall (e : E Z) (f : F Z') (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y), + sb'Proper R -> + sb' R true X Y L (Vis e k) (Vis f k') -> + (forall side, R side X Y L (Passive e k) (Passive f k')) /\ L (ask e) (ask f). Proof. intros * HP H. apply sb'_true_vis_l_inv in H as (l' & u' & STEP & HR & HL). @@ -751,9 +810,9 @@ Section Inversion_Rules. Qed. Lemma sb'_true_br_l_inv {Z R} : - forall (c : B Z) (k : Z -> ctree E B X) (u : @SS F B X), - sb' L R true (Br c k) u -> - forall x, exists u', (trans_alt ε)^* u u' /\ R true (k x) u'. + forall (c : C Z) (k : Z -> ctree E C X) (u : @S F D Y), + sb' R true X Y L (Br c k) u -> + forall x, exists u', (trans_alt ε)^* u u' /\ R true X Y L (k x) u'. Proof. intros * H x. destruct H as [H _]; specialize (H eq_refl); destruct H as [_ HB]. @@ -762,9 +821,9 @@ Section Inversion_Rules. Qed. Lemma sb'_false_br_l_inv {Z R} : - forall (t : @SS E B X) (c : B Z) (k : Z -> ctree F B X), - sb' L R false t (Br c k) -> - forall x, exists t', (trans_alt ε)^* t t' /\ R false t' (k x). + forall (t : @S E C X) (c : D Z) (k : Z -> ctree F D Y), + sb' R false X Y L t (Br c k) -> + forall x, exists t', (trans_alt ε)^* t t' /\ R false X Y L t' (k x). Proof. intros * H x. destruct H as [_ H]; specialize (H eq_refl); destruct H as [_ HB]. @@ -773,9 +832,9 @@ Section Inversion_Rules. Qed. Lemma sb'_true_guard_l_inv {R} : - forall (t : ctree E B X) (u : @SS F B X), - sb' L R true (Guard t) u -> - exists u', (trans_alt ε)^* u u' /\ R true t u'. + forall (t : ctree E C X) (u : @S F D Y), + sb' R true X Y L (Guard t) u -> + exists u', (trans_alt ε)^* u u' /\ R true X Y L t u'. Proof. intros * H. destruct H as [H _]; specialize (H eq_refl); destruct H as [_ HB]. @@ -784,9 +843,9 @@ Section Inversion_Rules. Qed. Lemma sb'_false_guard_l_inv {R} : - forall (t : @SS E B X) (u : ctree F B X), - sb' L R false t (Guard u) -> - exists t', (trans_alt ε)^* t t' /\ R false t' u. + forall (t : @S E C X) (u : ctree F D Y), + sb' R false X Y L t (Guard u) -> + exists t', (trans_alt ε)^* t t' /\ R false X Y L t' u. Proof. intros * H. destruct H as [_ H]; specialize (H eq_refl); destruct H as [_ HB]. @@ -794,9 +853,9 @@ Section Inversion_Rules. exists t'; split; [exact STAR | exact HR]. Qed. - Lemma sbisim'_br_l_inv {Z} c x (k : Z -> ctree E B X) (t' : @SS F B X) : - gfp (sb' L) true (Br c k) t' -> - gfp (sb' L) true (k x) t'. + Lemma sbisim'_br_l_inv {Z} c x (k : Z -> ctree E C X) (t' : @S F D Y) : + gfp (@sb' E F C D) true X Y L (Br c k) t' -> + gfp (@sb' E F C D) true X Y L (k x) t'. Proof. intros H. step in H. eapply sb'_true_br_l_inv with (x := x) in H as (u' & STAR & HR). @@ -805,9 +864,9 @@ Section Inversion_Rules. step in HR. now apply HR. Qed. - Lemma sbisim'_br_r_inv {Z} c x (k : Z -> ctree F B X) (t : @SS E B X) : - gfp (sb' L) false t (Br c k) -> - gfp (sb' L) false t (k x). + Lemma sbisim'_br_r_inv {Z} c x (k : Z -> ctree F D Y) (t : @S E C X) : + gfp (@sb' E F C D) false X Y L t (Br c k) -> + gfp (@sb' E F C D) false X Y L t (k x). Proof. intros H. step in H. eapply sb'_false_br_l_inv with (x := x) in H as (t0 & STAR & HR). @@ -816,9 +875,9 @@ Section Inversion_Rules. step in HR. now apply HR. Qed. - Lemma sbisim'_guard_l_inv (t : ctree E B X) (t' : @SS F B X) : - gfp (sb' L) true (Guard t) t' -> - gfp (sb' L) true t t'. + Lemma sbisim'_guard_l_inv (t : ctree E C X) (t' : @S F D Y) : + gfp (@sb' E F C D) true X Y L (Guard t) t' -> + gfp (@sb' E F C D) true X Y L t t'. Proof. intros H. step in H. apply sb'_true_guard_l_inv in H as (u' & STAR & HR). @@ -827,9 +886,9 @@ Section Inversion_Rules. step in HR. now apply HR. Qed. - Lemma sbisim'_guard_r_inv (t : @SS E B X) (t' : ctree F B X) : - gfp (sb' L) false t (Guard t') -> - gfp (sb' L) false t t'. + Lemma sbisim'_guard_r_inv (t : @S E C X) (t' : ctree F D Y) : + gfp (@sb' E F C D) false X Y L t (Guard t') -> + gfp (@sb' E F C D) false X Y L t t'. Proof. intros H. step in H. apply sb'_false_guard_l_inv in H as (t0 & STAR & HR). @@ -844,47 +903,45 @@ End Inversion_Rules. [eq]-specialized inversions, stated outside the section so [L] can be instantiated with [eq]. |*) -Lemma sb'_eq_vis_invT {E B X Z Z' R} : - forall side (e : E Z) (f : E Z') (k : Z -> ctree E B X) (k' : Z' -> ctree E B X), - sb' eq R side (Vis e k) (Vis f k') -> +Lemma sb'_eq_vis_invT {E C X Z Z' R} : + forall side (e : E Z) (f : E Z') (k : Z -> ctree E C X) (k' : Z' -> ctree E C X), + sb' R side X X Leq (Vis e k) (Vis f k') -> Z = Z'. Proof. intros side e f k k' H. destruct side. - apply sb'_true_vis_l_inv in H as (l' & u' & STEP & _ & HL). - subst l'. destruct STEP as [m STAR STEPa]. apply estar_vis_inv in STAR; rewrite <- STAR in STEPa. - apply trans_vis_inv' in STEPa as (_ & Heq). - now apply ask_invT in Heq. + apply trans_vis_inv' in STEPa as (_ & ->). + apply build_rel_ask in HL. + now dependent destruction HL. - apply sb'_false_ss' in H. apply ss'_vis_l_inv in H as (l' & u' & STEP & _ & HL). - unfold flip in HL; subst l'. destruct STEP as [m STAR STEPa]. apply estar_vis_inv in STAR; rewrite <- STAR in STEPa. - apply trans_vis_inv' in STEPa as (_ & Heq). - apply ask_invT in Heq. - now symmetry. + apply trans_vis_inv' in STEPa as (_ & ->). + apply build_rel_ask in HL. + now dependent destruction HL. Qed. -Lemma sb'_eq_vis_inv {E B X Z R} : - forall side (e f : E Z) (k k' : Z -> ctree E B X), - (Proper (eq ==> Seq ==> Seq ==> impl) R) -> - sb' eq R side (Vis e k) (Vis f k') -> - e = f /\ (forall side, R side (Passive e k) (Passive f k')). +Lemma sb'_eq_vis_inv {E C X Z R} : + forall side (e f : E Z) (k k' : Z -> ctree E C X), + sb'Proper R -> + sb' R side X X Leq (Vis e k) (Vis f k') -> + e = f /\ (forall side, R side X X Leq (Passive e k) (Passive f k')). Proof. intros side e f k k' HP H. destruct side. - apply sb'_true_vis_inv in H as (HR & Heq); [| exact HP]. - apply ask_inv in Heq; subst f. + apply build_rel_ask in Heq; dependent destruction Heq. auto. - apply sb'_false_ss' in H. apply ss'_vis_l_inv in H as (l' & u' & STEP & HR & HL). - unfold flip in HL; subst l'. destruct STEP as [m STAR STEPa]. apply estar_vis_inv in STAR; rewrite <- STAR in STEPa. - apply trans_vis_inv' in STEPa as (EQ & Heq). - apply ask_inv in Heq; subst f. + apply trans_vis_inv' in STEPa as (EQ & ->). + apply build_rel_ask in HL; dependent destruction HL. split; [reflexivity |]. intro side'; rewrite <- EQ; apply HR. Qed. @@ -898,94 +955,63 @@ Lemma epsilon_det_estar {E B X} (t t' : ctree E B X) : Proof. induction 1. - apply estar_seq; constructor; exact H. - - eapply estar_cons0. + - eapply estar_cons_epsilon. + eapply Transguard; [exact H0 | reflexivity]. + exact IHepsilon_det. Qed. Section upto. - Context {E F B: Type -> Type} {X: Type} - (L : rel (@label E X) (@label F X)). + Context {E F C D: Type -> Type}. #[local] Obligation Tactic := idtac. - Program Definition ss_ctx3_l : mon (bool -> rel (@SS E B X) (@SS F B X)) - := {| body R b t u := b = true /\ ss L (fun t u => forall side, R side t u) t u |}. + Program Definition ss_ctx3_l : mon (sb'R E F C D) + := {| body R b X Y L t u := + b = true /\ + ss' (fun X Y L t u => forall side, R side X Y L t u) X Y L t u |}. Next Obligation. - intros R R' HRR' b t u (-> & Hss); split; auto. - intros t' l Hne TR. - destruct (Hss _ _ Hne TR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit; auto. - intro side; apply HRR', HR. + intros R R' HRR' b X Y L t u (-> & Hss); split; [reflexivity |]. + revert Hss; apply ss'_gen_mon; + cbn; intros ? ? ? ? ? H side; apply HRR', H. Qed. - Lemma ss_st'_l (r : Chain (sb' L)) : - forall side x y, ss_ctx3_l `r side x y -> `r side x y. + Lemma ss_st'_l (r : Chain (@sb' E F C D)) : + forall side X Y L x y, ss_ctx3_l `r side X Y L x y -> `r side X Y L x y. Proof. - apply tower. - - intros ? INC side x y [-> Hss] ? ?. red. - apply INC; auto. - split; auto. - intros t' l Hne TR. - destruct (Hss _ _ Hne TR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - + assumption. - + intro side'; apply leq_infx in H; apply H, HR. - + assumption. - - clear. - intros R IH side x y [-> Hss]. - split; intro; [| easy]. - split. - + intros t' l Hne TR. - assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) x t') - by (apply trans_star_l; exact TR). - destruct (Hss _ _ Hne cTR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - * assumption. - * intro side'; apply (b_chain R), HR. - * assumption. - + intros t' TR. - exists y; split. - * apply trans_star_self. - * apply IH. - split; auto. - intros t'' l Hne cTR. - assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) x t'') - by (eapply estar_cons; [exact TR | exact cTR]). - destruct (Hss _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - -- assumption. - -- intro side'; apply (b_chain R), HR. - -- assumption. + intros side X Y L x y (-> & Hss). + apply (b_chain r); split; intro; [| easy]. + revert Hss; apply ss'_gen_mon. + - cbn; intros ? ? ? ? ? HH; exact HH. + - cbn; intros ? ? ? ? ? HH; apply HH. Qed. (* Up-to guard *) - Program Definition guard_ctx3_l : mon (bool -> rel (@SS E B X) (@SS F B X)) - := {| body R b t u := guard_ctx (fun t => R b t u) t |}. + Program Definition guard_ctx3_l : mon (sb'R E F C D) + := {| body R b X Y L t u := guard_ctx (fun t => R b X Y L t u) t |}. Next Obligation. - intros R R' HRR' b t u (t0 & EQ & HR). + intros R R' HRR' b X Y L t u (t0 & EQ & HR). exists t0; split; [exact EQ | apply HRR', HR]. Qed. - Program Definition guard_ctx3_r : mon (bool -> rel (@SS E B X) (@SS F B X)) - := {| body R b t u := guard_ctx (fun u => R b t u) u |}. + Program Definition guard_ctx3_r : mon (sb'R E F C D) + := {| body R b X Y L t u := guard_ctx (fun u => R b X Y L t u) u |}. Next Obligation. - intros R R' HRR' b t u (u0 & EQ & HR). + intros R R' HRR' b X Y L t u (u0 & EQ & HR). exists u0; split; [exact EQ | apply HRR', HR]. Qed. - Lemma guard_ctx3_l_sbisim' (r : Chain (sb' L)) : - forall side x y, guard_ctx3_l `r side x y -> `r side x y. + Lemma guard_ctx3_l_sbisim' (r : Chain (@sb' E F C D)) : + forall side X Y L x y, guard_ctx3_l `r side X Y L x y -> `r side X Y L x y. Proof. apply tower. - - intros ? INC side x y (t0 & EQ & HR) ? ?; red. + - intros ? INC side X Y L x y (t0 & EQ & HR) ? ?; red. apply INC; auto. exists t0; split; [exact EQ |]. apply leq_infx in H. apply H, HR. - clear. - intros R IH side x y (t0 & EQ & HR). + intros R IH side X Y L x y (t0 & EQ & HR). split; intro; subst. + rewrite EQ. apply step_ss'_guard_l. @@ -995,17 +1021,17 @@ Section upto. now apply HR. Qed. - Lemma guard_ctx3_r_sbisim' (r : Chain (sb' L)) : - forall side x y, guard_ctx3_r `r side x y -> `r side x y. + Lemma guard_ctx3_r_sbisim' (r : Chain (@sb' E F C D)) : + forall side X Y L x y, guard_ctx3_r `r side X Y L x y -> `r side X Y L x y. Proof. apply tower. - - intros ? INC side x y (u0 & EQ & HR) ? ?; red. + - intros ? INC side X Y L x y (u0 & EQ & HR) ? ?; red. apply INC; auto. exists u0; split; [exact EQ |]. apply leq_infx in H. apply H, HR. - clear. - intros R IH side x y (u0 & EQ & HR). + intros R IH side X Y L x y (u0 & EQ & HR). split; intro; subst. + rewrite EQ. apply step_ss'_guard_r. @@ -1017,12 +1043,12 @@ Section upto. (* Up-to epsilon *) - Program Definition epsilon_det_ctx3_l : mon (bool -> rel (@SS E B X) (@SS F B X)) - := {| body R b t u := + Program Definition epsilon_det_ctx3_l : mon (sb'R E F C D) + := {| body R b X Y L t u := b = true /\ exists t0 t1, t ⩸ (Active t0) /\ epsilon_det t0 t1 - /\ R b (Active t1) u |}. + /\ R b X Y L (Active t1) u |}. Next Obligation. - intros R R' HRR' b t u (-> & t0 & t1 & EQ & DET & HR). + intros R R' HRR' b X Y L t u (-> & t0 & t1 & EQ & DET & HR). split; auto. exists t0, t1; ssplit. - exact EQ. @@ -1030,18 +1056,19 @@ Section upto. - apply HRR', HR. Qed. - Definition pure_bind_ctx {X0} (P : X0 -> Prop) (R : @SS E B X -> Prop) - (t : @SS E B X) := - exists (t0 : ctree E B X0) k0, + Definition pure_bind_ctx {W X0} (P : X0 -> Prop) (R : @S E C W -> Prop) + (t : @S E C W) := + exists (t0 : ctree E C X0) k0, t ⩸ (Active (CTree.bind t0 k0)) /\ (forall l t', l <> ε -> ((trans_alt ε)^* ⋅ trans_alt l) (Active t0) t' -> exists v, l = val v /\ P v) /\ forall x, P x -> R (Active (k0 x)). - Program Definition pure_bind_ctx3_l {X0} (P : X0 -> Prop) : mon (bool -> rel (@SS E B X) (@SS F B X)) - := {| body R b t u := b = true /\ pure_bind_ctx P (fun t => R b t u) t |}. + Program Definition pure_bind_ctx3_l {X0} (P : X0 -> Prop) : mon (sb'R E F C D) + := {| body R b X Y L t u := + b = true /\ pure_bind_ctx P (fun t => R b X Y L t u) t |}. Next Obligation. - intros X0 P R R' HRR' b t u (-> & t0 & k0 & EQ & HTR & HB). + intros X0 P R R' HRR' b X Y L t u (-> & t0 & k0 & EQ & HTR & HB). split; auto. exists t0, k0; ssplit. - exact EQ. @@ -1049,19 +1076,20 @@ Section upto. - intros v Pv; apply HRR', HB, Pv. Qed. - Program Definition epsilon_ctx3_r : mon (bool -> rel (@SS E B X) (@SS F B X)) - := {| body R b t u := b = true /\ exists u', (trans_alt ε)^* u u' /\ R b t u' |}. + Program Definition epsilon_ctx3_r : mon (sb'R E F C D) + := {| body R b X Y L t u := + b = true /\ exists u', (trans_alt ε)^* u u' /\ R b X Y L t u' |}. Next Obligation. - intros R R' HRR' b t u (-> & u' & STAR & HR). + intros R R' HRR' b X Y L t u (-> & u' & STAR & HR). split; auto. exists u'; split; [exact STAR | apply HRR', HR]. Qed. - Lemma epsilon_det_ctx3_l_sbisim' (r : Chain (sb' L)) : - forall side x y, epsilon_det_ctx3_l `r side x y -> `r side x y. + Lemma epsilon_det_ctx3_l_sbisim' (r : Chain (@sb' E F C D)) : + forall side X Y L x y, epsilon_det_ctx3_l `r side X Y L x y -> `r side X Y L x y. Proof. apply tower. - - intros ? INC side x y (-> & t0 & t1 & EQ & DET & HR) ? ?; red. + - intros ? INC side X Y L x y (-> & t0 & t1 & EQ & DET & HR) ? ?; red. apply INC; auto. split; auto. exists t0, t1; ssplit. @@ -1070,15 +1098,15 @@ Section upto. + apply leq_infx in H. apply H, HR. - clear. - intros R IH side x y (-> & t0 & t1 & EQ & DET & HR). + intros R IH side X Y L x y (-> & t0 & t1 & EQ & DET & HR). split; intro; [| easy]. rewrite EQ; clear x EQ. revert HR; induction DET as [ta tb EQ01 | ta tb tc DET' IHDET EQg]; intro HR. - + assert (SQ : (Active ta : @SS E B X) ⩸ (Active tb)) + + assert (SQ : (Active ta : @S E C X) ⩸ (Active tb)) by (constructor; exact EQ01). rewrite SQ. now apply HR. - + assert (SQ : (Active tc : @SS E B X) ⩸ (Active (Guard ta))) + + assert (SQ : (Active tc : @S E C X) ⩸ (Active (Guard ta))) by (constructor; exact EQg). rewrite SQ. apply step_ss'_guard_l. @@ -1090,11 +1118,11 @@ Section upto. * apply (b_chain R); exact HR. Qed. - Lemma pure_bind_ctx3_l_sbisim' {X0} (P : X0 -> Prop) (r : Chain (sb' L)) : - forall side x y, pure_bind_ctx3_l P `r side x y -> `r side x y. + Lemma pure_bind_ctx3_l_sbisim' {X0} (P : X0 -> Prop) (r : Chain (@sb' E F C D)) : + forall side X Y L x y, pure_bind_ctx3_l P `r side X Y L x y -> `r side X Y L x y. Proof. apply tower. - - intros ? INC side x y (-> & t0 & k0 & EQ & HTR & HB) ? ?; red. + - intros ? INC side X Y L x y (-> & t0 & k0 & EQ & HTR & HB) ? ?; red. apply INC; auto. split; auto. exists t0, k0; ssplit. @@ -1104,7 +1132,7 @@ Section upto. apply leq_infx in H. apply H, HB, Pv. - clear. - intros R IH side x y (-> & t0 & k0 & EQ & HTR & HB). + intros R IH side X Y L x y (-> & t0 & k0 & EQ & HTR & HB). split; intro; [| easy]. rewrite EQ. split. @@ -1116,7 +1144,7 @@ Section upto. | (Z & e & g & -> & TRt & SQ) ]]]. * assert (HneV : (val v : @label E X0) <> ε) by easy. assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val v)) - (Active t0) (Active (Stuck : ctree E B X0))). + (Active t0) (Active (Stuck : ctree E C X0))). { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } destruct (HTR _ _ HneV cV) as (w & Hvw & Pw). apply val_eq_inv in Hvw; subst w. @@ -1146,7 +1174,7 @@ Section upto. | (Z & e & g & Habs & _) ]]]. * assert (HneV : (val v : @label E X0) <> ε) by easy. assert (cV : ((trans_alt ε)^* ⋅ trans_alt (val v)) - (Active t0) (Active (Stuck : ctree E B X0))). + (Active t0) (Active (Stuck : ctree E C X0))). { apply trans_star_l; eapply Transval; [exact EQt | reflexivity]. } destruct (HTR _ _ HneV cV) as (w & Hvw & Pw). apply val_eq_inv in Hvw; subst w. @@ -1165,31 +1193,32 @@ Section upto. ++ reflexivity. ++ intros l t' Hne cTR. eapply (HTR l t'); [exact Hne |]. - eapply estar_cons; [exact TRt | exact cTR]. + eapply estar_cons_label; [exact TRt | exact cTR]. ++ intros v Pv; apply (b_chain R), HB, Pv. * easy. Qed. - Lemma epsilon_ctx3_r_sbisim' (r : Chain (sb' L)) : - forall side x y, epsilon_ctx3_r `r side x y -> `r side x y. + Lemma epsilon_ctx3_r_sbisim' (r : Chain (@sb' E F C D)) : + forall side X Y L x y, epsilon_ctx3_r `r side X Y L x y -> `r side X Y L x y. Proof. apply tower. - - intros ? INC side x y (-> & u' & STAR & HR) ? ?; red. + - intros ? INC side X Y L x y (-> & u' & STAR & HR) ? ?; red. apply INC; auto. split; auto. exists u'; split; [exact STAR |]. apply leq_infx in H. apply H, HR. - clear. - intros R IH side x y (-> & u' & STAR & HR). + intros R IH side X Y L x y (-> & u' & STAR & HR). split; intro; [| easy]. eapply step_ss'_epsilon_r; [| exact STAR]. now apply HR. Qed. - #[global] Instance epsilon_det_st' : forall (R : Chain (@sb' E F B X L)), + #[global] Instance epsilon_det_st' {X Y} {L : lrel E F X Y} : + forall (R : Chain (@sb' E F C D)), Proper (epsilon_det ==> epsilon_det ==> flip impl) - (fun (t : ctree E B X) (u : ctree F B X) => ` R true t u). + (fun (t : ctree E C X) (u : ctree F D Y) => ` R true X Y L t u). Proof. intros R t t' DETt u u' DETu H. apply epsilon_det_ctx3_l_sbisim'. @@ -1210,11 +1239,11 @@ End upto. Epsilon-absorption for the [sb'] game: the left player of the [true] side (resp. the right player of the [false] side) may be advanced by ε-steps. |*) -Lemma sbisim'_epsilon_l {E F B X} L : - forall (t t' : @SS E B X) (u : @SS F B X), - gfp (@sb' E F B X L) true t u -> +Lemma sbisim'_epsilon_l {E F C D X Y} (L : lrel E F X Y) : + forall (t t' : @S E C X) (u : @S F D Y), + gfp (@sb' E F C D) true X Y L t u -> (trans_alt ε)^* t t' -> - gfp (sb' L) true t' u. + gfp (@sb' E F C D) true X Y L t' u. Proof. intros t t' u H STAR. step. split; intro; [| easy]. eapply ss'_gen_epsilon_l. @@ -1223,11 +1252,11 @@ Proof. - exact STAR. Qed. -Lemma sbisim'_epsilon_r {E F B X} L : - forall (t : @SS E B X) (u u' : @SS F B X), - gfp (@sb' E F B X L) false t u -> +Lemma sbisim'_epsilon_r {E F C D X Y} (L : lrel E F X Y) : + forall (t : @S E C X) (u u' : @S F D Y), + gfp (@sb' E F C D) false X Y L t u -> (trans_alt ε)^* u u' -> - gfp (sb' L) false t u'. + gfp (@sb' E F C D) false X Y L t u'. Proof. intros t u u' H STAR. step. split; intro; [easy |]. eapply ss'_gen_epsilon_l. @@ -1796,7 +1825,7 @@ Proof. split; auto. intros t'' l Hne cTR. assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') - by (eapply estar_cons; [exact TR | exact cTR]). + by (eapply estar_cons_label; [exact TR | exact cTR]). destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). exists l', u'; ssplit; assumption. Qed. @@ -1838,7 +1867,7 @@ Proof. * apply CH. intros u2 l Hne cTR. apply (H u2 l Hne). - eapply estar_cons; [exact TR | exact cTR]. + eapply estar_cons_label; [exact TR | exact cTR]. Qed. Lemma gfp_sb'_true_ss_sbisim {E F B X} : diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 4662025..906c403 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -57,6 +57,47 @@ Proof. cbn in HReps. eauto 12. Qed. +Lemma lequiv_ss'_gen {E F C D} + (R Reps : forall X Y, lrel E F X Y -> rel (@S E C X) (@S F D Y)) + {X Y} (L L' : lrel E F X Y) : + lequiv L L' -> + R X Y L <= R X Y L' -> + Reps X Y L <= Reps X Y L' -> + ss'_gen R Reps L <= ss'_gen R Reps L'. +Proof. + intros HL HR HReps t u [Hprogress Heps]; split; intros. + - destruct (Hprogress _ _ H H0) as (l'' & u'' & Htrans & HRtu & HL'). + exists l'', u''; split; [| split]. + + assumption. + + now apply HR. + + now apply (lequiv_build_rel HL l l''). + - apply Heps in H as (u' & Htrans & HRtu). + exists u'; split; [assumption | now apply HReps]. +Qed. + +#[global] Instance Seq_proper_ss'_gen_ctx {E F C D} + {R Reps : forall X Y, lrel E F X Y -> rel (@S E C X) (@S F D Y)} + {X Y} {L : lrel E F X Y} : + Proper (Seq ==> Seq ==> impl) (ss'_gen R Reps L). +Proof. + intros t t' Ht u u' Hu [Hprogress Heps]; split; intros. + - rewrite <- Ht in H0. + destruct (Hprogress _ _ H H0) as (l'' & u'' & Htrans & HRtu & HL'). + rewrite Hu in Htrans. eauto 12. + - rewrite <- Ht in H. + apply Heps in H as (u'' & Htrans & HRtu). + rewrite Hu in Htrans. eauto 12. +Qed. + +#[global] Instance Seq_proper_ss'_gen_goal {E F C D} + {R Reps : forall X Y, lrel E F X Y -> rel (@S E C X) (@S F D Y)} + {X Y} {L : lrel E F X Y} : + Proper (Seq ==> Seq ==> flip impl) (ss'_gen R Reps L). +Proof. + intros t t' Ht u u' Hu H. + eapply Seq_proper_ss'_gen_ctx; [symmetry; exact Ht | symmetry; exact Hu | exact H]. +Qed. + Definition ss'_ {E F C D : Type -> Type} : (forall (X Y : Type), lrel E F X Y -> (* L *) diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v index 47d6201..394cfe2 100644 --- a/theories/Eq/TransAlt.v +++ b/theories/Eq/TransAlt.v @@ -2290,6 +2290,18 @@ Proof. now destruct L. Qed. +Lemma lequiv_flipL_sym {E X} (L : lrel E E X X) {SL : Symmetric L} : + lequiv (flipL L) L. +Proof. + split3; cbn. + - intros x y; split; intro H; + apply build_rel_val, SL; now constructor. + - intros A B e f; split; intro H; + apply build_rel_ask, SL; now constructor. + - intros A B e f a b; split; intro H; + apply build_rel_rcv, SL; now constructor. +Qed. + Lemma lequiv_sub_lrel {E F X Y} (L L' : lrel E F X Y): sub_lrel L L' -> sub_lrel (flipL L) (flipL L'). From f7aa35ab608bd254fe70039372b0cb1fb3698624 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 31 Jul 2026 13:39:42 +0200 Subject: [PATCH 54/61] Minor fix to proof legibility --- theories/Eq/SSimAlt.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 906c403..0568d6e 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -936,7 +936,7 @@ Section bind_restore. destruct RESP as [m STAR STEPv]. unfold trans_alt in STEPv; cbn in STEPv. dependent destruction STEPv; inversion HL2; subst. - specialize (kk x r ltac:(assumption)). + specialize (kk x r H3). destruct kk as (kkA & _). destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hgfp & HL'). exists l', u'; ssplit. From 8723c7403dd3d75bc89e62216de9b2bad645387b Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Fri, 31 Jul 2026 13:40:05 +0200 Subject: [PATCH 55/61] finished functional draft of sbisimalt.v. onto tests. --- theories/Eq/SBisimAlt.v | 1067 +++++++++++++++++---------------------- 1 file changed, 453 insertions(+), 614 deletions(-) diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index c23ceef..ba9fd52 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -1,3 +1,4 @@ +(* TODO: organize this file wrt SBisim.v *) From Stdlib Require Import Lia Basics @@ -20,6 +21,9 @@ From CTree Require Import Eq.SSimAlt Misc.Pure. +From CTree Require Eq.Trans Eq.SSim Eq.SBisim. +From CTree Require Import Eq.AltEquiv. + From RelationAlgebra Require Export rel srel. @@ -963,27 +967,7 @@ Qed. Section upto. Context {E F C D: Type -> Type}. - #[local] Obligation Tactic := idtac. - - Program Definition ss_ctx3_l : mon (sb'R E F C D) - := {| body R b X Y L t u := - b = true /\ - ss' (fun X Y L t u => forall side, R side X Y L t u) X Y L t u |}. - Next Obligation. - intros R R' HRR' b X Y L t u (-> & Hss); split; [reflexivity |]. - revert Hss; apply ss'_gen_mon; - cbn; intros ? ? ? ? ? H side; apply HRR', H. - Qed. - - Lemma ss_st'_l (r : Chain (@sb' E F C D)) : - forall side X Y L x y, ss_ctx3_l `r side X Y L x y -> `r side X Y L x y. - Proof. - intros side X Y L x y (-> & Hss). - apply (b_chain r); split; intro; [| easy]. - revert Hss; apply ss'_gen_mon. - - cbn; intros ? ? ? ? ? HH; exact HH. - - cbn; intros ? ? ? ? ? HH; apply HH. - Qed. + #[local] Obligation Tactic := idtac. (* Up-to guard *) @@ -1265,398 +1249,250 @@ Proof. - exact STAR. Qed. -(*| -Right-hand inversions for [update_val_rel], complementing the left-hand -ones provided by SSimAlt. Needed for the [false] side of the bind lemma. -|*) -Section uvr_inv_r. - - Context {E F : Type -> Type} {X X' : Type} - {L : rel (@label E X') (@label F X')} {R0 : rel X X}. - - Lemma update_val_rel_val_r (w : X) (l1 : @label E X) : - update_val_rel L R0 l1 (val w) -> - exists v, l1 = val v /\ R0 v w. - Proof. - intros H; dependent destruction H; eauto. - Qed. - - Lemma update_val_rel_τ_r (l1 : @label E X) : - update_val_rel L R0 l1 τ -> - l1 = τ /\ L τ τ. - Proof. - intros H; dependent destruction H; eauto. - Qed. - - Lemma update_val_rel_ask_r {Z'} (f : F Z') (l1 : @label E X) : - update_val_rel L R0 l1 (ask f) -> - exists Z (e : E Z), l1 = ask e /\ L (ask e) (ask f). - Proof. - intros H; dependent destruction H; eauto. - Qed. - - Lemma update_val_rel_rcv_r {Z'} (f : F Z') (w : Z') (l1 : @label E X) : - update_val_rel L R0 l1 (rcv f w) -> - exists Z (e : E Z) (v : Z), l1 = rcv e v /\ L (rcv e v) (rcv f w). - Proof. - intros H; dependent destruction H; eauto. - Qed. - -End uvr_inv_r. Section bind. Arguments label: clear implicits. - Context {E F B : Type -> Type} {X X' : Type} - (L : rel (@label E X') (@label F X')) - (R0 : rel X X). - - Notation uvr := (update_val_rel L R0). + Context {E F C D : Type -> Type} {X X' Y Y' : Type} + (L : lrel E F X' Y') + (R0 : forall X Y : Type, lrel E F X' Y' -> rel X Y). (*| Up-to-bind for [sb']. As in SSimAlt, the continuations must be related at the [gfp] level (they need to be stepped for the ε-conjunct), while the prefixes are related by the [gfp] of [sb' uvr] at the same side. |*) - Lemma bind_chain_gen {R : Chain (@sb' E F B X' L)} : - forall (t : ctree E B X) (t' : ctree F B X) - (k : X -> ctree E B X') (k' : X -> ctree F B X') side, - gfp (sb' uvr) side (Active t) (Active t') -> - (forall side x x', R0 x x' -> `R side (Active (k x)) (Active (k' x'))) -> - ` R side (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + Lemma sbind_chain_gen {R : Chain (@sb' E F C D)} : + forall (s : @S E C X) (s' : @S F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y') + (SS : rel X Y) side, + ` R side X Y (upd_rel L SS) s s' -> + (forall side x y, SS x y -> ` R side X' Y' L (Active (k x)) (Active (k' y))) -> + ` R side X' Y' L (Sbind s k) (Sbind s' k'). Proof. - apply (@tower _ _ _ (fun (P : bool -> rel (@SS E B X') (@SS F B X')) => - forall (t : ctree E B X) (t' : ctree F B X) - (k : X -> ctree E B X') (k' : X -> ctree F B X') side, - gfp (sb' uvr) side (Active t) (Active t') -> - (forall side x x', R0 x x' -> P side (Active (k x)) (Active (k' x'))) -> - P side (Active (x <- t;; k x)) (Active (x <- t';; k' x)))). - - intros ? INC t t' k k' side tt kk ? ?; red. - apply INC; auto. intros. apply kk; auto. - - clear; intros R IH t t' k k' side tt kk. + tower induction. + - intros IH s s' k k' SS side tt kk. split; intro; subst. - + (* side = true *) - split. - * (* non-ε challenge on x <- t;; k x *) - intros s l Hne TR. - apply trans_bind_inv in TR as - [ (x & EQt & TRk) - | [ (-> & t1 & TRt & SQ) - | [ (-> & _) - | (Z & e & g & -> & TRt & SQ) ]]]. - -- (* the prefix returns; the step happens in k *) - step in tt. - destruct tt as [tt _]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (HneV : (val x : @label E X) <> ε) by easy. - assert (TRv : trans_alt (val x) (Active t) (Active (Stuck : ctree E B X))) - by (eapply Transval; [exact EQt | reflexivity]). - destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). - apply update_val_rel_val_l in HL2 as (x' & -> & Hx). - destruct RESP as [m STAR STEPv]. - unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. - pose proof (kkT := kk true x x' Hx). - destruct kkT as [kkT _]; specialize (kkT eq_refl). - destruct kkT as [kkA _]. - destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). - exists l', u'; ssplit. - ++ destruct RESP2 as [m2 STAR2 STEP2]. - exists m2; [| exact STEP2]. - eapply estar_trans. - ** apply estar_bind; exact STAR. - ** eapply estar_trans; [| exact STAR2]. - apply estar_seq; constructor. - rewrite H, bind_ret_l; reflexivity. - ++ intro side'; apply Hall. - ++ exact HL'. - -- (* τ step in the prefix *) - step in tt. - destruct tt as [tt _]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (Hneτ : (τ : @label E X) <> ε) by easy. - destruct (ttA _ _ Hneτ TRt) as (l2 & n & RESP & Htt' & HL2). - apply update_val_rel_τ_l in HL2 as (-> & HLττ). - destruct RESP as [m STAR STEPτ]. - unfold trans_alt in STEPτ; cbn in STEPτ; dependent destruction STEPτ. - exists τ, (Active (x <- u;; k' x)); ssplit. - ++ exists (Active (x <- t0;; k' x)). - ** apply estar_bind; exact STAR. - ** apply trans_bind_l_τ; eapply Transstep; eauto. + + destruct tt as [tt _]; specialize (tt eq_refl). + destruct tt as [tt_ne tt_ep]. + destruct s as [t | Zs es gs]. + * split. + -- intros succ l Hne TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (-> & _) + | (Z & e & g & -> & TRt & SQ) ]]]. + ++ assert (cV : trans_alt (val x) (Active t) (Active (Stuck : ctree E C X))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (tt_ne _ (val x) (ltac:(easy)) cV) as (l2 & resp & RESP & _ & HL2). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv. + dependent destruction STEPv; inversion HL2; subst. + pose proof (kkT := kk true x r H3). + destruct kkT as [kkT _]; specialize (kkT eq_refl). + destruct kkT as [kkA _]. + destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). + exists l', u'; ssplit. + ** destruct RESP2 as [m2 STAR2 STEP2]. + exists m2; [| exact STEP2]. + eapply estar_trans. + --- apply estar_Sbind; exact STAR. + --- eapply estar_trans; [| exact STAR2]. + apply estar_seq; cbn; constructor. + rewrite H, bind_ret_l; reflexivity. + ** exact Hall. + ** exact HL'. + ++ destruct (tt_ne _ τ (ltac:(easy)) TRt) as (l2 & resp & RESP & Hpre & HL2). + inversion HL2; subst. + destruct RESP as [m STAR STEPτ]. + exists τ, (Sbind resp k'); ssplit. + ** exists (Sbind m k'). + --- apply estar_Sbind; exact STAR. + --- apply trans_Sbind_τ; exact STEPτ. + ** intro side'; rewrite SQ. + apply (IH (Active t1) resp k k' SS side'); + [ apply Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ** constructor. + ++ easy. + ++ destruct (tt_ne _ (ask e) (ltac:(easy)) TRt) as (l2 & resp & RESP & Hpre & HL2). + dependent destruction HL2. + destruct RESP as [m STAR STEPa]. + exists (ask f), (Sbind resp k'); ssplit. + ** exists (Sbind m k'). + --- apply estar_Sbind; exact STAR. + --- apply trans_Sbind_ask; exact STEPa. + ** intro side'; rewrite SQ. + apply (IH (Passive e g) resp k k' SS side'); + [ apply Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ** now constructor. + -- intros succ TR. + apply trans_bind_inv in TR as + [ (x & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & e & g & Habs & _) ]]]. + ++ assert (cV : trans_alt (val x) (Active t) (Active (Stuck : ctree E C X))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (tt_ne _ (val x) (ltac:(easy)) cV) as (l2 & resp & RESP & _ & HL2). + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv. + dependent destruction STEPv; inversion HL2; subst. + pose proof (kkT := kk true x r ltac:(assumption)). + destruct kkT as [kkT _]; specialize (kkT eq_refl). + destruct kkT as [_ kkB]. + destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). + exists u2; split. + ** eapply estar_trans. + --- apply estar_Sbind; exact STAR. + --- eapply estar_trans; [| exact STARu]. + apply estar_seq; cbn; constructor. + rewrite H, bind_ret_l; reflexivity. + ** exact Hgfp2. + ++ easy. + ++ destruct (tt_ep _ TRt) as (resp & STARr & Hpre). + exists (Sbind resp k'); split. + ** apply estar_Sbind; exact STARr. + ** rewrite SQ. + apply (IH (Active t1) resp k k' SS true); + [ exact Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ++ easy. + * split. + -- intros succ l Hne TR. + apply trans_passive_inv' in TR as (z & SQ & ->). + assert (TRrcv : trans_alt (rcv es z) (Passive es gs) (Active (gs z))) + by (econstructor; reflexivity). + destruct (tt_ne _ (rcv es z) (ltac:(easy)) TRrcv) + as (l2 & resp & RESP & Hpre & HL2). + dependent destruction HL2. + destruct RESP as [m STAR STEPr]. + exists (rcv f y), (Sbind resp k'); ssplit. + ++ exists (Sbind m k'). + ** apply estar_Sbind; exact STAR. + ** apply trans_Sbind_rcv; exact STEPr. ++ intro side'; rewrite SQ. - apply IH. - ** apply Htt'. - ** intros. step. now apply kk. - ++ exact HLττ. - -- easy. - -- (* ask step in the prefix: the short trip through passives *) - step in tt. - destruct tt as [tt _]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (HneA : (ask e : @label E X) <> ε) by easy. - destruct (ttA _ _ HneA TRt) as (l2 & n & RESP & Htt' & HL2). - apply update_val_rel_ask_l in HL2 as (Z' & f & -> & HLaa). - destruct RESP as [m STAR STEPa]. - unfold trans_alt in STEPa; cbn in STEPa; dependent destruction STEPa. - exists (ask f), (Passive f (fun z => x <- k0 z;; k' x)); ssplit. - ++ exists (Active (x <- t0;; k' x)). - ** apply estar_bind; exact STAR. - ** apply trans_bind_l_ask; econstructor; exact H. + apply (IH (Active (gs z)) resp k k' SS side'); + [ apply Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ++ now constructor. + -- intros succ TR. + apply trans_passive_inv' in TR as (z & _ & Habs); easy. + + destruct tt as [_ tt]; specialize (tt eq_refl). + destruct tt as [tt_ne tt_ep]. + destruct s' as [t' | Zs fs gs]. + * split. + -- intros succ l Hne TR. + apply trans_bind_inv in TR as + [ (y & EQt & TRk) + | [ (-> & t1 & TRt & SQ) + | [ (-> & _) + | (Z & f & g & -> & TRt & SQ) ]]]. + ++ assert (cV : trans_alt (val y) (Active t') (Active (Stuck : ctree F D Y))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (tt_ne _ (val y) (ltac:(easy)) cV) as (l2 & resp & RESP & _ & HL2). + apply flipL_flip in HL2. + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv. + dependent destruction STEPv; inversion HL2; subst. + pose proof (kkF := kk false r y H3). + destruct kkF as [_ kkF]; specialize (kkF eq_refl). + destruct kkF as [kkA _]. + destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). + exists l', u'; ssplit. + ** destruct RESP2 as [m2 STAR2 STEP2]. + exists m2; [| exact STEP2]. + eapply estar_trans. + --- apply estar_Sbind; exact STAR. + --- eapply estar_trans; [| exact STAR2]. + apply estar_seq; cbn; constructor. + rewrite H, bind_ret_l; reflexivity. + ** exact Hall. + ** exact HL'. + ++ destruct (tt_ne _ τ (ltac:(easy)) TRt) as (l2 & resp & RESP & Hpre & HL2). + apply flipL_flip in HL2; inversion HL2; subst. + destruct RESP as [m STAR STEPτ]. + exists τ, (Sbind resp k); ssplit. + ** exists (Sbind m k). + --- apply estar_Sbind; exact STAR. + --- apply trans_Sbind_τ; exact STEPτ. + ** intro side'; rewrite SQ. + apply (IH resp (Active t1) k k' SS side'); + [ apply Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ** apply flipL_flip; constructor. + ++ easy. + ++ destruct (tt_ne _ (ask f) (ltac:(easy)) TRt) as (l2 & resp & RESP & Hpre & HL2). + apply flipL_flip in HL2; dependent destruction HL2. + destruct RESP as [m STAR STEPa]. + exists (ask e), (Sbind resp k); ssplit. + ** exists (Sbind m k). + --- apply estar_Sbind; exact STAR. + --- apply trans_Sbind_ask; exact STEPa. + ** intro side'; rewrite SQ. + apply (IH resp (Passive f g) k k' SS side'); + [ apply Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ** apply flipL_flip; now constructor. + -- intros succ TR. + apply trans_bind_inv in TR as + [ (y & EQt & TRk) + | [ (Habs & _) + | [ (_ & t1 & TRt & SQ) + | (Z & f & g & Habs & _) ]]]. + ++ assert (cV : trans_alt (val y) (Active t') (Active (Stuck : ctree F D Y))) + by (eapply Transval; [exact EQt | reflexivity]). + destruct (tt_ne _ (val y) (ltac:(easy)) cV) as (l2 & resp & RESP & _ & HL2). + apply flipL_flip in HL2. + destruct RESP as [m STAR STEPv]. + unfold trans_alt in STEPv; cbn in STEPv. + dependent destruction STEPv; inversion HL2; subst. + pose proof (kkF := kk false r y ltac:(assumption)). + destruct kkF as [_ kkF]; specialize (kkF eq_refl). + destruct kkF as [_ kkB]. + destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). + exists u2; split. + ** eapply estar_trans. + --- apply estar_Sbind; exact STAR. + --- eapply estar_trans; [| exact STARu]. + apply estar_seq; cbn; constructor. + rewrite H, bind_ret_l; reflexivity. + ** exact Hgfp2. + ++ easy. + ++ destruct (tt_ep _ TRt) as (resp & STARr & Hpre). + exists (Sbind resp k); split. + ** apply estar_Sbind; exact STARr. + ** rewrite SQ. + apply (IH resp (Active t1) k k' SS false); + [ exact Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ++ easy. + * split. + -- intros succ l Hne TR. + apply trans_passive_inv' in TR as (z & SQ & ->). + assert (TRrcv : trans_alt (rcv fs z) (Passive fs gs) (Active (gs z))) + by (econstructor; reflexivity). + destruct (tt_ne _ (rcv fs z) (ltac:(easy)) TRrcv) + as (l2 & resp & RESP & Hpre & HL2). + apply flipL_flip in HL2; dependent destruction HL2. + destruct RESP as [m STAR STEPr]. + exists (rcv e x), (Sbind resp k); ssplit. + ++ exists (Sbind m k). + ** apply estar_Sbind; exact STAR. + ** apply trans_Sbind_rcv; exact STEPr. ++ intro side'; rewrite SQ. - apply (b_chain R). - split; intro; subst. - ** (* challenges of the E-side passive *) - split. - --- intros s2 l2 Hne2 TR2. - apply trans_passive_inv' in TR2 as (z & SQ2 & ->). - pose proof (HttT := Htt' true). - step in HttT. - destruct HttT as [HttT _]; specialize (HttT eq_refl). - destruct HttT as [HttA _]. - assert (HneR : (rcv e z : @label E X) <> ε) by easy. - assert (TRr : trans_alt (rcv e z) (Passive e g) (Active (g z))) - by (econstructor; reflexivity). - destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). - apply update_val_rel_rcv_l in HL3 as (Z2 & f2 & w & -> & HLrr). - destruct RESP3 as [m3 STAR3 STEP3]. - apply estar_passive in STAR3. - dependent destruction STAR3. - apply trans_passive_inv' in STEP3 as (w' & SQ3 & Heq). - dependent destruction Heq. - dependent destruction SQ3. - exists (rcv f w'), (Active (x <- k0 w';; k' x)); ssplit. - +++ apply trans_star_l; econstructor; reflexivity. - +++ intro side''; rewrite SQ2. - assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') - ⩸ (Active (x <- k0 w';; k' x))). - { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. - +++ exact HLrr. - --- intros s2 TR2. - apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. - ** (* challenges of the F-side passive *) - split. - --- intros s2 l2 Hne2 TR2. - apply trans_passive_inv' in TR2 as (w & SQ2 & ->). - pose proof (HttF := Htt' false). - step in HttF. - destruct HttF as [_ HttF]; specialize (HttF eq_refl). - destruct HttF as [HttA _]. - assert (HneR : (rcv f w : @label F X) <> ε) by easy. - assert (TRr : trans_alt (rcv f w) (Passive f k0) (Active (k0 w))) - by (econstructor; reflexivity). - destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). - apply update_val_rel_rcv_r in HL3 as (Z2 & e2 & v & -> & HLrr). - destruct RESP3 as [m3 STAR3 STEP3]. - apply estar_passive in STAR3. - dependent destruction STAR3. - apply trans_passive_inv' in STEP3 as (v' & SQ3 & Heq). - dependent destruction Heq. - dependent destruction SQ3. - exists (rcv e v'), (Active (x <- g v';; k x)); ssplit. - +++ apply trans_star_l; econstructor; reflexivity. - +++ intro side''; rewrite SQ2. - assert (SQ5 : (Active (x <- t1;; k x) : @SS E B X') - ⩸ (Active (x <- g v';; k x))). - { constructor; rewrite EQ0, <- (EQ v'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. - +++ exact HLrr. - --- intros s2 TR2. - apply trans_passive_inv' in TR2 as (w & _ & Habs); easy. - ++ exact HLaa. - * (* ε challenge on x <- t;; k x *) - intros s TR. - apply trans_bind_inv in TR as - [ (x & EQt & TRk) - | [ (Habs & _) - | [ (_ & t1 & TRt & SQ) - | (Z & e & g & Habs & _) ]]]. - -- step in tt. - destruct tt as [tt _]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (HneV : (val x : @label E X) <> ε) by easy. - assert (TRv : trans_alt (val x) (Active t) (Active (Stuck : ctree E B X))) - by (eapply Transval; [exact EQt | reflexivity]). - destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). - apply update_val_rel_val_l in HL2 as (x' & -> & Hx). - destruct RESP as [m STAR STEPv]. - unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. - pose proof (kkT := kk true x x' Hx). - destruct kkT as [kkT _]; specialize (kkT eq_refl). - destruct kkT as [_ kkB]. - destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). - exists u2; split. - ++ eapply estar_trans. - ** apply estar_bind; exact STAR. - ** eapply estar_trans; [| exact STARu]. - apply estar_seq; constructor. - rewrite H, bind_ret_l; reflexivity. - ++ exact Hgfp2. - -- easy. - -- exists (Active (x <- t';; k' x)); split. - ++ apply trans_star_self. - ++ rewrite SQ; apply IH; [| intros; step; now apply kk]. - eapply sbisim'_epsilon_l; [exact tt | apply estar_single; exact TRt]. - -- easy. - + (* side = false *) - split. - * (* non-ε challenge on x <- t';; k' x *) - intros s l Hne TR. - apply trans_bind_inv in TR as - [ (x' & EQt & TRk) - | [ (-> & t1 & TRt & SQ) - | [ (-> & _) - | (Z & f & g & -> & TRt & SQ) ]]]. - -- (* the prefix returns; the step happens in k' *) - step in tt. - destruct tt as [_ tt]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (HneV : (val x' : @label F X) <> ε) by easy. - assert (TRv : trans_alt (val x') (Active t') (Active (Stuck : ctree F B X))) - by (eapply Transval; [exact EQt | reflexivity]). - destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). - apply update_val_rel_val_r in HL2 as (x & -> & Hx). - destruct RESP as [m STAR STEPv]. - unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. - pose proof (kkF := kk false x x' Hx). - destruct kkF as [_ kkF]; specialize (kkF eq_refl). - destruct kkF as [kkA _]. - destruct (kkA _ _ Hne TRk) as (l' & u' & RESP2 & Hall & HL'). - exists l', u'; ssplit. - ++ destruct RESP2 as [m2 STAR2 STEP2]. - exists m2; [| exact STEP2]. - eapply estar_trans. - ** apply estar_bind; exact STAR. - ** eapply estar_trans; [| exact STAR2]. - apply estar_seq; constructor. - rewrite H, bind_ret_l; reflexivity. - ++ intro side'; apply Hall. - ++ exact HL'. - -- (* τ step in the prefix *) - step in tt. - destruct tt as [_ tt]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (Hneτ : (τ : @label F X) <> ε) by easy. - destruct (ttA _ _ Hneτ TRt) as (l2 & n & RESP & Htt' & HL2). - apply update_val_rel_τ_r in HL2 as (-> & HLττ). - destruct RESP as [m STAR STEPτ]. - unfold trans_alt in STEPτ; cbn in STEPτ; dependent destruction STEPτ. - exists τ, (Active (x <- u;; k x)); ssplit. - ++ exists (Active (x <- t0;; k x)). - ** apply estar_bind; exact STAR. - ** apply trans_bind_l_τ; eapply Transstep; eauto. - ++ intro side'; rewrite SQ. - apply IH; [apply Htt' | intros; step; now apply kk]. - ++ exact HLττ. - -- easy. - -- (* ask step in the prefix: the short trip, mirrored *) - step in tt. - destruct tt as [_ tt]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (HneA : (ask f : @label F X) <> ε) by easy. - destruct (ttA _ _ HneA TRt) as (l2 & n & RESP & Htt' & HL2). - apply update_val_rel_ask_r in HL2 as (Z' & e & -> & HLaa). - destruct RESP as [m STAR STEPa]. - unfold trans_alt in STEPa; cbn in STEPa; dependent destruction STEPa. - exists (ask e), (Passive e (fun z => x <- k0 z;; k x)); ssplit. - ++ exists (Active (x <- t0;; k x)). - ** apply estar_bind; exact STAR. - ** apply trans_bind_l_ask; econstructor; exact H. - ++ intro side'; rewrite SQ. - apply (b_chain R). - split; intro; subst. - ** (* challenges of the E-side passive *) - split. - --- intros s2 l2 Hne2 TR2. - apply trans_passive_inv' in TR2 as (z & SQ2 & ->). - pose proof (HttT := Htt' true). - step in HttT. - destruct HttT as [HttT _]; specialize (HttT eq_refl). - destruct HttT as [HttA _]. - assert (HneR : (rcv e z : @label E X) <> ε) by easy. - assert (TRr : trans_alt (rcv e z) (Passive e k0) (Active (k0 z))) - by (econstructor; reflexivity). - destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). - apply update_val_rel_rcv_l in HL3 as (Z2 & f2 & w & -> & HLrr). - destruct RESP3 as [m3 STAR3 STEP3]. - apply estar_passive in STAR3. - dependent destruction STAR3. - apply trans_passive_inv' in STEP3 as (w' & SQ3 & Heq). - dependent destruction Heq. - dependent destruction SQ3. - exists (rcv f w'), (Active (x <- g w';; k' x)); ssplit. - +++ apply trans_star_l; econstructor; reflexivity. - +++ intro side''; rewrite SQ2. - assert (SQ5 : (Active (x <- t1;; k' x) : @SS F B X') - ⩸ (Active (x <- g w';; k' x))). - { constructor; rewrite EQ0, <- (EQ w'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. - +++ exact HLrr. - --- intros s2 TR2. - apply trans_passive_inv' in TR2 as (z & _ & Habs); easy. - ** (* challenges of the F-side passive *) - split. - --- intros s2 l2 Hne2 TR2. - apply trans_passive_inv' in TR2 as (w & SQ2 & ->). - pose proof (HttF := Htt' false). - step in HttF. - destruct HttF as [_ HttF]; specialize (HttF eq_refl). - destruct HttF as [HttA _]. - assert (HneR : (rcv f w : @label F X) <> ε) by easy. - assert (TRr : trans_alt (rcv f w) (Passive f g) (Active (g w))) - by (econstructor; reflexivity). - destruct (HttA _ _ HneR TRr) as (l3 & n3 & RESP3 & Hall3 & HL3). - apply update_val_rel_rcv_r in HL3 as (Z2 & e2 & v & -> & HLrr). - destruct RESP3 as [m3 STAR3 STEP3]. - apply estar_passive in STAR3. - dependent destruction STAR3. - apply trans_passive_inv' in STEP3 as (v' & SQ3 & Heq). - dependent destruction Heq. - dependent destruction SQ3. - exists (rcv e v'), (Active (x <- k0 v';; k x)); ssplit. - +++ apply trans_star_l; econstructor; reflexivity. - +++ intro side''; rewrite SQ2. - assert (SQ5 : (Active (x <- t1;; k x) : @SS E B X') - ⩸ (Active (x <- k0 v';; k x))). - { constructor; rewrite EQ0, <- (EQ v'); reflexivity. } - rewrite <- SQ5; apply IH; [apply Hall3 | intros; step; now apply kk]. - +++ exact HLrr. - --- intros s2 TR2. - apply trans_passive_inv' in TR2 as (w & _ & Habs); easy. - ++ exact HLaa. - * (* ε challenge on x <- t';; k' x *) - intros s TR. - apply trans_bind_inv in TR as - [ (x' & EQt & TRk) - | [ (Habs & _) - | [ (_ & t1 & TRt & SQ) - | (Z & f & g & Habs & _) ]]]. - -- step in tt. - destruct tt as [_ tt]; specialize (tt eq_refl). - destruct tt as [ttA _]. - assert (HneV : (val x' : @label F X) <> ε) by easy. - assert (TRv : trans_alt (val x') (Active t') (Active (Stuck : ctree F B X))) - by (eapply Transval; [exact EQt | reflexivity]). - destruct (ttA _ _ HneV TRv) as (l2 & n & RESP & _ & HL2). - apply update_val_rel_val_r in HL2 as (x & -> & Hx). - destruct RESP as [m STAR STEPv]. - unfold trans_alt in STEPv; cbn in STEPv; dependent destruction STEPv. - pose proof (kkF := kk false x x' Hx). - destruct kkF as [_ kkF]; specialize (kkF eq_refl). - destruct kkF as [_ kkB]. - destruct (kkB _ TRk) as (u2 & STARu & Hgfp2). - exists u2; split. - ++ eapply estar_trans. - ** apply estar_bind; exact STAR. - ** eapply estar_trans; [| exact STARu]. - apply estar_seq; constructor. - rewrite H, bind_ret_l; reflexivity. - ++ apply Hgfp2. - -- easy. - -- exists (Active (x <- t;; k x)); split. - ++ apply trans_star_self. - ++ rewrite SQ; apply IH; [| intros; step; now apply kk]. - eapply sbisim'_epsilon_r; [exact tt | apply estar_single; exact TRt]. - -- easy. + apply (IH resp (Active (gs z)) k k' SS side'); + [ apply Hpre | intros ? ? ? ?; apply (b_chain R); now apply kk ]. + ++ apply flipL_flip; now constructor. + -- intros succ TR. + apply trans_passive_inv' in TR as (z & _ & Habs); easy. + Qed. + + Lemma bind_chain_gen {R : Chain (@sb' E F C D)} : + forall (t : ctree E C X) (t' : ctree F D Y) + (k : X -> ctree E C X') (k' : Y -> ctree F D Y') + (SS : rel X Y) side, + ` R side X Y (upd_rel L SS) (Active t) (Active t') -> + (forall side x y, SS x y -> ` R side X' Y' L (Active (k x)) (Active (k' y))) -> + ` R side X' Y' L (Active (x <- t;; k x)) (Active (x <- t';; k' x)). + Proof. + intros t t' k k' SS side. + exact (sbind_chain_gen (Active t) (Active t') k k' SS side). Qed. End bind. @@ -1669,286 +1505,289 @@ Expliciting the reasoning rule provided by the up-to principles. (* Note: In this section, I changed the relation between t1 and t2 to be at the gfp. *) -Lemma st'_clo_bind {E F B: Type -> Type} {X X': Type} {L : rel (@label E X') (@label F X')} - (R0 : rel X X) +Lemma st'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : lrel E F X' Y'} + (SS : rel X Y) side - (t1 : ctree E B X) (t2: ctree F B X) - (k1 : X -> ctree E B X') (k2 : X -> ctree F B X') - (R : Chain (@sb' E F B X' L)) : - gfp (sb' (update_val_rel L R0)) side (Active t1) (Active t2) -> - (forall x y, R0 x y -> forall b, gfp (sb' L) b (Active (k1 x)) (Active (k2 y))) -> - `R side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). + (t1 : ctree E C X) (t2: ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') + (R : Chain (@sb' E F C D)) : + gfp (@sb' E F C D) side X Y (upd_rel L SS) (Active t1) (Active t2) -> + (forall x y, SS x y -> forall b, gfp (@sb' E F C D) b X' Y' L (Active (k1 x)) (Active (k2 y))) -> + `R side X' Y' L (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros H1 H2. - eapply bind_chain_gen; [exact H1 |]. - intros b x x' Hxx'; apply H2, Hxx'. + eapply bind_chain_gen. + - apply (gfp_chain R); exact H1. + - intros b x y Hxy; apply (gfp_chain R), H2, Hxy. Qed. -Lemma sbisim'_clo_bind {E F B: Type -> Type} {X X': Type} {L : rel (@label E X') (@label F X')} - (R0 : rel X X) +Lemma sbisim'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : lrel E F X' Y'} + (SS : rel X Y) side - (t1 : ctree E B X) (t2: ctree F B X) - (k1 : X -> ctree E B X') (k2 : X -> ctree F B X') : - gfp (sb' (update_val_rel L R0)) side (Active t1) (Active t2) -> - (forall x y, R0 x y -> forall b, gfp (sb' L) b (Active (k1 x)) (Active (k2 y))) -> - gfp (sb' L) side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). + (t1 : ctree E C X) (t2: ctree F D Y) + (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') : + gfp (@sb' E F C D) side X Y (upd_rel L SS) (Active t1) (Active t2) -> + (forall x y, SS x y -> forall b, gfp (@sb' E F C D) b X' Y' L (Active (k1 x)) (Active (k2 y))) -> + gfp (@sb' E F C D) side X' Y' L (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros H1 H2. - apply (@st'_clo_bind E F B X X' L R0 side t1 t2 k1 k2 (chain_gfp (sb' L))); assumption. -Qed. - -(*| -[eq] as label relation is preserved by [update_val_rel]. -|*) -Lemma sbisim_update_val_rel_eq {E B X X'} : - forall side (t u : @SS E B X), - gfp (@sb' E E B X eq) side t u -> - gfp (sb' (@update_val_rel E E X X' eq eq)) side t u. -Proof. - apply (@tower _ _ _ (fun (P : bool -> rel (@SS E B X) (@SS E B X)) => - forall side t u, gfp (@sb' E E B X eq) side t u -> P side t u)). - - intros ? INC side t u H ? ?; red. - apply INC; auto. - - clear; intros R IH side t u H. - step in H. - split; intro; subst. - + destruct H as [H _]; specialize (H eq_refl); destruct H as [HA HB]. - split. - * intros s l Hne TR. - destruct (HA _ _ Hne TR) as (l' & u' & RESP & Hall & HL). - subst l'. - exists l, u'; ssplit. - -- exact RESP. - -- intro side'; apply IH, Hall. - -- apply update_val_rel_eq_refl; exact Hne. - * intros s TR. - destruct (HB _ TR) as (u' & STAR & Hrep). - exists u'; split; [exact STAR | apply IH, Hrep]. - + destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA HB]. - split. - * intros s l Hne TR. - destruct (HA _ _ Hne TR) as (l' & u' & RESP & Hall & HL). - unfold flip in HL; subst l'. - exists l, u'; ssplit. - -- exact RESP. - -- intro side'; apply IH, Hall. - -- apply update_val_rel_eq_refl; exact Hne. - * intros s TR. - destruct (HB _ TR) as (u' & STAR & Hrep). - exists u'; split; [exact STAR | apply IH, Hrep]. + apply (@st'_clo_bind E F C D X Y X' Y' L SS side t1 t2 k1 k2 + (chain_gfp (@sb' E F C D))); assumption. Qed. -Lemma st'_clo_bind_eq {E B: Type -> Type} {X X': Type} - side (t1 t2 : ctree E B X) - (k1 k2 : X -> ctree E B X') - (R : Chain (@sb' E E B X' eq)) : - gfp (sb' eq) side (Active t1) (Active t2) -> - (forall x b, gfp (@sb' E E B X' eq) b (Active (k1 x)) (Active (k2 x))) -> - ` R side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). +Lemma st'_clo_bind_eq {E C: Type -> Type} {X X': Type} + side (t1 t2 : ctree E C X) + (k1 k2 : X -> ctree E C X') + (R : Chain (@sb' E E C C)) : + gfp (@sb' E E C C) side X X (upd_rel (@Leq E X') eq) (Active t1) (Active t2) -> + (forall x b, gfp (@sb' E E C C) b X' X' (@Leq E X') (Active (k1 x)) (Active (k2 x))) -> + ` R side X' X' (@Leq E X') (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros H1 H2. - eapply bind_chain_gen with (R0 := eq). - - apply sbisim_update_val_rel_eq; exact H1. - - intros b x x' ->; apply H2. + eapply st'_clo_bind with (SS := eq); [exact H1 |]. + intros x y ->; apply H2. Qed. -Lemma sbisim'_clo_bind_eq {E B: Type -> Type} {X X': Type} : - forall side (t1 t2 : ctree E B X) (k1 k2 : X -> ctree E B X'), - gfp (@sb' E E B X eq) side (Active t1) (Active t2) -> - (forall x b, gfp (@sb' E E B X' eq) b (Active (k1 x)) (Active (k2 x))) -> - gfp (sb' eq) side (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). +Lemma sbisim'_clo_bind_eq {E C: Type -> Type} {X X': Type} : + forall side (t1 t2 : ctree E C X) (k1 k2 : X -> ctree E C X'), + gfp (@sb' E E C C) side X X (upd_rel (@Leq E X') eq) (Active t1) (Active t2) -> + (forall x b, gfp (@sb' E E C C) b X' X' (@Leq E X') (Active (k1 x)) (Active (k2 x))) -> + gfp (@sb' E E C C) side X' X' (@Leq E X') (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros. - apply (@st'_clo_bind_eq E B X X' side t1 t2 k1 k2 (chain_gfp (sb' eq))); assumption. + apply (@st'_clo_bind_eq E C X X' side t1 t2 k1 k2 (chain_gfp (@sb' E E C C))); assumption. Qed. -Lemma step_sb'_guard_l' {E F B X L} - (t: ctree E B X) (t': @SS F B X) - (R : Chain (@sb' E F B X L)) : - (forall side, `R side t t') -> - forall side, `R side (Guard t) t'. +Lemma step_sb'_guard_l' {E F C D X Y} {L : lrel E F X Y} + (t: ctree E C X) (t': @S F D Y) + (R : Chain (@sb' E F C D)) : + (forall side, `R side X Y L t t') -> + forall side, `R side X Y L (Guard t) t'. Proof. intros H side. apply guard_ctx3_l_sbisim'. exists t; split; [reflexivity | apply H]. Qed. -Lemma step_sb'_guard_r' {E F B X L} - (t: @SS E B X) (t': ctree F B X) (R : Chain (@sb' E F B X L)) : - (forall side, `R side t t') -> - forall side, `R side t (Guard t'). +Lemma step_sb'_guard_r' {E F C D X Y} {L : lrel E F X Y} + (t: @S E C X) (t': ctree F D Y) (R : Chain (@sb' E F C D)) : + (forall side, `R side X Y L t t') -> + forall side, `R side X Y L t (Guard t'). Proof. intros H side. apply guard_ctx3_r_sbisim'. exists t'; split; [reflexivity | apply H]. Qed. -(*| -The classic single-shot strong bisimulation over the combined-step LTS, -and its equivalence with [sbisim']. -|*) -#[local] Obligation Tactic := idtac. -Program Definition sb {E F B X} (L : rel (@label E X) (@label F X)) : - mon (@SS E B X -> @SS F B X -> Prop) := - {| body R t u := ss L R t u /\ ss (flip L) (flip R) u t |}. -Next Obligation. - intros E F B X L R R' HRR' t u (H1 & H2); split. - - intros t' l Hne TR. - destruct (H1 _ _ Hne TR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit; auto. - apply HRR', HR. - - intros u' l Hne TR. - destruct (H2 _ _ Hne TR) as (l' & t' & STEP & HR & HL). - exists l', t'; ssplit; auto. - apply HRR', HR. + + + +(* +Tactic Notation "__upto_bind_sbisim'" uconstr(R0) := TODO +Tactic Notation "__upto_bind_eq_sbisim'" uconstr(R0) := TODO +*) + +(* +Equivalence of old and new bisimilarities +*) +Section sbisim_sbisim'. + +Lemma o_ss_br_step {E F B X} (L : Trans.lrel E F X X) + (Rel : rel (Trans.S E B X) (Trans.S F B X)) + Z (c : B Z) (k : Z -> ctree E B X) (t u : ctree E B X) (b : Trans.S F B X) x : + SSim.ss L Rel (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> + SSim.ss L Rel (Trans.Active u) b. +Proof. + intros H Hbr Hu; cbn in H |- *; intros l t' TR. + apply (H l t'). + eapply Trans.Transbr; [apply Hbr | apply Hu | apply TR]. Qed. -#[local] Obligation Tactic := Tactics.program_simpl. -Definition sbisim {E F B X} L := (gfp (@sb E F B X L) : hrel _ _). +Lemma o_ss_guard_step {E F B X} (L : Trans.lrel E F X X) + (Rel : rel (Trans.S E B X) (Trans.S F B X)) + (t tg u : ctree E B X) (b : Trans.S F B X) : + SSim.ss L Rel (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> + SSim.ss L Rel (Trans.Active u) b. +Proof. + intros H Hg Hu; cbn in H |- *; intros l t' TR. + apply (H l t'). + assert (Htu : t ≅ Guard u) by (rewrite Hu; apply Hg). + eapply Trans.Transguard; [apply Htu | apply TR]. +Qed. -Lemma ss_sb'_l_chain {E F B X L} {R : Chain (@sb' E F B X L)} : - forall (t : @SS E B X) (u : @SS F B X), - ss L (fun t u => forall b, `R b t u) t u -> - sb' L `R true t u. +Lemma lift_L_flipL {E F X} (L : Trans.lrel E F X X) : + lift_L (Trans.flipL L) = TransAlt.flipL (lift_L L). Proof. - intros t u HSS; split; intro; [| easy]. - split. - - intros t' l Hne TR. - assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t') - by (apply trans_star_l; exact TR). - destruct (HSS _ _ Hne cTR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit; assumption. - - intros t' TR. - exists u; split. - + apply trans_star_self. - + apply ss_st'_l. - split; auto. - intros t'' l Hne cTR. - assert (cTR2 : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) t t'') - by (eapply estar_cons_label; [exact TR | exact cTR]). - destruct (HSS _ _ Hne cTR2) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit; assumption. + now destruct L. Qed. -(* first half of the theorem *) -Theorem gfp_sb'_ss_sbisim {E F B X} : - forall L (t : @SS E B X) (u : @SS F B X), - (ss L (sbisim L) t u -> gfp (sb' L) true t u) /\ - (ss (flip L) (flip (sbisim L)) u t -> gfp (sb' L) false t u). +(* need to split at [side] so that the simulation game lines up. *) +Theorem gfp_sb'_ss_sbisim {E F B X} (L : Trans.lrel E F X X) : + forall (a : Trans.S E B X) (b : Trans.S F B X), + (SSim.ss L (SBisim.sbisim L) a b -> + gfp (@sb' E F B B) true X X (lift_L L) (o2n_S a) (o2n_S b)) /\ + (SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a -> + gfp (@sb' E F B B) false X X (lift_L L) (o2n_S a) (o2n_S b)). Proof. - intros L. coinduction R CH. intros t u. + coinduction R CH. intros a b. split; intro H. - - apply ss_sb'_l_chain. - intros t' l Hne cTR. - destruct (H _ _ Hne cTR) as (l' & u' & STEP & HR & HL). - exists l', u'; ssplit. - + assumption. - + intro b. step in HR. destruct HR as [HR1 HR2]. - destruct b. - * apply CH; exact HR1. - * apply CH; exact HR2. - + assumption. + - split; intro; [| easy]. + split. + + intros x l Hne TR. + apply label_non_eps_image in Hne as [lo ->]. + assert (oTR : Trans.transR lo a (n2o_S x)). + { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } + cbn in H. + destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). + exists (o2n_label lo'), (o2n_S bo'); ssplit. + * apply transR_o2n; exact TRb. + * apply (gfp_pfp (@SBisim.sb E F B B X X L)) in Hrel. + destruct Hrel as [Hf Hb]. + pose proof (CH (n2o_S x) bo') as CHx. + rewrite o2n_n2o_S in CHx. + intro side; destruct side; [apply CHx | apply CHx]; assumption. + * apply lift_L_o2n; exact HL. + + intros x TR. + exists (o2n_S b); split; [apply trans_star_self |]. + apply trans_alt_eps_inv in TR as + [ (Z & c & k & t & u & x0 & Ha & Hx & Hbr & Hu) + | (t & tg & u & Ha & Hx & Hg & Hu) ]. + * subst x; destruct a as [ta | ? e0 k0]; cbn in Ha; [| easy]. + inv Ha; apply (CH (Trans.Active u) b). + eapply o_ss_br_step; eauto. + * subst x; destruct a as [ta | ? e0 k0]; cbn in Ha; [| easy]. + inv Ha; apply (CH (Trans.Active u) b). + eapply o_ss_guard_step; eauto. - split; intro; [easy |]. split. - + intros u1 l Hne TR. - assert (cTR : ((trans_alt (B:=B) ε)^* ⋅ trans_alt l) u u1) - by (apply trans_star_l; exact TR). - destruct (H _ _ Hne cTR) as (l' & t1 & STEP & HR & HL). - exists l', t1; ssplit. - * assumption. - * intro b. step in HR. destruct HR as [HR1 HR2]. - destruct b. - -- apply CH; exact HR1. - -- apply CH; exact HR2. - * assumption. - + intros u1 TR. - exists t; split. - * apply trans_star_self. - * apply CH. - intros u2 l Hne cTR. - apply (H u2 l Hne). - eapply estar_cons_label; [exact TR | exact cTR]. + + intros x l Hne TR. + apply label_non_eps_image in Hne as [lo ->]. + assert (oTR : Trans.transR lo b (n2o_S x)). + { rewrite <- (n2o_o2n_S b). apply transR_n2o. apply trans_star_l. apply TR. } + cbn in H. + destruct (H lo (n2o_S x) oTR) as (lo' & ao' & TRa & Hrel & HL). + exists (o2n_label lo'), (o2n_S ao'); ssplit. + * apply transR_o2n; exact TRa. + * unfold flip in Hrel. + apply (gfp_pfp (@SBisim.sb E F B B X X L)) in Hrel. + destruct Hrel as [Hf Hb]. + pose proof (CH ao' (n2o_S x)) as CHx. + rewrite o2n_n2o_S in CHx. + intro side; destruct side; [apply CHx | apply CHx]; assumption. + * rewrite <- lift_L_flipL. apply lift_L_o2n; exact HL. + + intros x TR. + exists (o2n_S a); split; [apply trans_star_self |]. + apply trans_alt_eps_inv in TR as + [ (Z & c & k & t & u & x0 & Hb & Hx & Hbr & Hu) + | (t & tg & u & Hb & Hx & Hg & Hu) ]. + * subst x; destruct b as [tb | ? e0 k0]; cbn in Hb; [| easy]. + inv Hb; apply (CH a (Trans.Active u)). + eapply o_ss_br_step; eauto. + * subst x; destruct b as [tb | ? e0 k0]; cbn in Hb; [| easy]. + inv Hb; apply (CH a (Trans.Active u)). + eapply o_ss_guard_step; eauto. Qed. -Lemma gfp_sb'_true_ss_sbisim {E F B X} : - forall L (t : @SS E B X) (u : @SS F B X), - ss L (sbisim L) t u -> gfp (sb' L) true t u. +Lemma gfp_sb'_true_ss_sbisim {E F B X} (L : Trans.lrel E F X X) : + forall (a : Trans.S E B X) (b : Trans.S F B X), + SSim.ss L (SBisim.sbisim L) a b -> + gfp (@sb' E F B B) true X X (lift_L L) (o2n_S a) (o2n_S b). Proof. - intros L t u; apply (gfp_sb'_ss_sbisim L t u). + intros a b; apply (gfp_sb'_ss_sbisim L a b). Qed. -(* main result. both halves are a proof by coinduction; - the first half is proved seperately in [gfp_sb'_ss_sbisim]. *) -Theorem sbisim_sbisim' {E F B X} : - forall L (t : @SS E B X) (t' : @SS F B X), sbisim L t t' <-> sbisim' L t t'. +Theorem sbisim_sbisim' {E F B X} (L : Trans.lrel E F X X) : + forall (a : Trans.S E B X) (b : Trans.S F B X), + SBisim.sbisim L a b <-> sbisim' (lift_L L) (o2n_S a) (o2n_S b). Proof. - split; intro H. - (* immediate from [gfp_sb'_ss_sbisim] *) - - intro side; destruct side. - + apply (gfp_sb'_ss_sbisim L t t'). step in H. apply H. - + apply (gfp_sb'_ss_sbisim L t t'). step in H. apply H. - - revert t t' H. unfold sbisim. coinduction R CH. intros t t' H. + intros a b; split; intro H. + (* from previous lemmas *) + - intro side. + step in H. + destruct H as [Hf Hb]; destruct side; + apply (gfp_sb'_ss_sbisim L a b); assumption. + (* here we do a manual argument by coinduction. + in each case we can use the sbisim' argument with + a different boolean flag to match the argument we wish to + follow. + *) + - revert a b H. unfold SBisim.sbisim. coinduction R CH. intros a b H. split. - + intros s l Hne cTR. - destruct cTR as [m STAR STEP]. + + intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. pose proof (HT := H true). eapply sbisim'_epsilon_l in HT; [| exact STAR]. - step in HT. + step in HT. destruct HT as [HT _]; specialize (HT eq_refl); destruct HT as [HTA _]. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). destruct (HTA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). - exists l', u'; ssplit. - * assumption. - * apply CH; exact Hall. - * assumption. - + intros s l Hne cTR. - destruct cTR as [m STAR STEP]. + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hla; subst la; subst l'. + exists lb, (n2o_S u'); ssplit. + (* trick is to lift through n2o_S *) + * rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. + * apply CH. rewrite o2n_n2o_S. exact Hall. + * exact HLab. + + intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. pose proof (HF := H false). eapply sbisim'_epsilon_r in HF; [| exact STAR]. - step in HF. + step in HF. destruct HF as [_ HF]; specialize (HF eq_refl); destruct HF as [HFA _]. - destruct (HFA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). - exists l', u'; ssplit. - * assumption. - * apply CH; exact Hall. - * assumption. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). + destruct (HFA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). + apply flipL_flip in HL. + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hlb; subst. + exists la, (n2o_S t''); ssplit. + * rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. + * unfold flip. apply CH. rewrite o2n_n2o_S. exact Hall. + * apply Trans.flipL_flip; exact HLab. Qed. -Corollary sbisim_gfp_sb' {E F B X} : - forall L side (t : @SS E B X) (t' : @SS F B X), sbisim L t t' -> gfp (sb' L) side t t'. +Corollary sbisim_gfp_sb' {E F B X} (L : Trans.lrel E F X X) : + forall side (a : Trans.S E B X) (b : Trans.S F B X), + SBisim.sbisim L a b -> + gfp (@sb' E F B B) side X X (lift_L L) (o2n_S a) (o2n_S b). Proof. intros. apply sbisim_sbisim' in H. apply H. Qed. -(* split converse *) -Theorem ss_sbisim_gfp_sb' {E F B X} : - forall L (t : @SS E B X) (u : @SS F B X), - (gfp (sb' L) true t u -> ss L (sbisim L) t u) /\ - (gfp (sb' L) false t u -> ss (flip L) (flip (sbisim L)) u t). +Theorem ss_sbisim_gfp_sb' {E F B X} (L : Trans.lrel E F X X) : + forall (a : Trans.S E B X) (b : Trans.S F B X), + (gfp (@sb' E F B B) true X X (lift_L L) (o2n_S a) (o2n_S b) -> + SSim.ss L (SBisim.sbisim L) a b) /\ + (gfp (@sb' E F B B) false X X (lift_L L) (o2n_S a) (o2n_S b) -> + SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a). Proof. - intros L t u; split; intro H. - - intros t1 l Hne cTR. - destruct cTR as [m STAR STEP]. + intros a b; split; intro H. + - intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. eapply sbisim'_epsilon_l in H; [| exact STAR]. - step in H. + apply (gfp_pfp (@sb' E F B B)) in H. destruct H as [H _]; specialize (H eq_refl); destruct H as [HA _]. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). destruct (HA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). - exists l', u'; ssplit. - + assumption. - + apply sbisim_sbisim'; intro side; apply Hall. - + assumption. - - intros u1 l Hne cTR. - destruct cTR as [m STAR STEP]. + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hla; subst la; subst l'. + exists lb, (n2o_S u'); ssplit. + + rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. + + apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. + + exact HLab. + - intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. eapply sbisim'_epsilon_r in H; [| exact STAR]. - step in H. + apply (gfp_pfp (@sb' E F B B)) in H. destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA _]. - destruct (HA _ _ Hne STEP) as (l' & t1 & RESP & Hall & HL). - exists l', t1; ssplit. - + assumption. - + apply sbisim_sbisim'; intro side; apply Hall. - + assumption. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). + destruct (HA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). + apply flipL_flip in HL. + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hlb; subst lb; subst l'. + exists la, (n2o_S t''); ssplit. + + rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. + + unfold flip. apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. + + apply Trans.flipL_flip; exact HLab. Qed. -(* -Tactic Notation "__upto_bind_sbisim'" uconstr(R0) := TODO -Tactic Notation "__upto_bind_eq_sbisim'" uconstr(R0) := TODO -*) +End sbisim_sbisim'. \ No newline at end of file From f4891a21a37a6644be85b218f2103ab4ddee9d08 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Mon, 28 Sep 2026 22:27:48 -0400 Subject: [PATCH 56/61] Commits before larger push forward --- theories/Eq.v | 7 ----- theories/Eq/AltEquiv.v | 64 ++++++++++++++++++++-------------------- theories/Eq/IterFacts.v | 34 +++++++++++++-------- theories/Eq/SBisimAlt.v | 36 ++++++++++++++++------ theories/Eq/SBisim_old.v | 4 +-- 5 files changed, 83 insertions(+), 62 deletions(-) diff --git a/theories/Eq.v b/theories/Eq.v index 75b78c4..0b27772 100644 --- a/theories/Eq.v +++ b/theories/Eq.v @@ -76,14 +76,7 @@ The upto [Vis] context principle for [sbisim] (* are identical: assumes [reflexivity] will solve the first goal, and proceed to substitute the equality *) (* - [upto_bind with SS]: for [equ], provides explicitly the intermediate relation *) (* |*) *) -(* #[global] Tactic Notation "upto_bind" := *) -(* __eupto_bind_equ || __eupto_bind_sbisim. *) -(* #[global] Tactic Notation "upto_bind_eq" := *) -(* __upto_bind_equ_eq || __upto_bind_sbisim_eq. *) - -(* #[global] Tactic Notation "upto_bind" "with" uconstr(SS) := *) -(* __upto_bind_equ SS || __upto_bind_sbisim SS. *) (*| Weakens equalities into respectively [equ] and [sbisim] equations --- diff --git a/theories/Eq/AltEquiv.v b/theories/Eq/AltEquiv.v index d0baff7..a0c0316 100644 --- a/theories/Eq/AltEquiv.v +++ b/theories/Eq/AltEquiv.v @@ -27,13 +27,13 @@ Set Implicit Arguments. (* label and S conversion *) (* convention: "o" is old, "n" is new. *) -Definition o2n_S {E B X} (s : Trans.S E B X) : TransAlt.S E B X := +Definition o2n_S {E C X} (s : Trans.S E C X) : TransAlt.S E C X := match s with | Trans.Active t => TransAlt.Active t | Trans.Passive e k => TransAlt.Passive e k end. -Definition n2o_S {E B X} (s : TransAlt.S E B X) : Trans.S E B X := +Definition n2o_S {E C X} (s : TransAlt.S E C X) : Trans.S E C X := match s with | TransAlt.Active t => Trans.Active t | TransAlt.Passive e k => Trans.Passive e k @@ -47,13 +47,13 @@ Definition o2n_label {E X} (l : Trans.label E X) : TransAlt.label E X := | Trans.val v => TransAlt.val v end. -Lemma n2o_o2n_S {E B X} (s : Trans.S E B X) : n2o_S (o2n_S s) = s. +Lemma n2o_o2n_S {E C X} (s : Trans.S E C X) : n2o_S (o2n_S s) = s. Proof. now destruct s. Qed. -Lemma o2n_n2o_S {E B X} (s : TransAlt.S E B X) : o2n_S (n2o_S s) = s. +Lemma o2n_n2o_S {E C X} (s : TransAlt.S E C X) : o2n_S (n2o_S s) = s. Proof. now destruct s. Qed. -Lemma transR_o2n {E B X} (l : Trans.label E X) (a a' : Trans.S E B X) : +Lemma transR_o2n {E C X} (l : Trans.label E X) (a a' : Trans.S E C X) : Trans.transR l a a' -> ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) (o2n_S a) (o2n_S a'). Proof. @@ -72,13 +72,13 @@ Proof. - apply trans_star_l. eapply TransAlt.Transval; [ apply H | apply H0 ]. Qed. -Lemma n2o_S_Seq {E B X} (a b : TransAlt.S E B X) : +Lemma n2o_S_Seq {E C X} (a b : TransAlt.S E C X) : TransAlt.Seq a b -> Trans.Seq (n2o_S a) (n2o_S b). Proof. intros H; inv H; cbn [n2o_S]; constructor; assumption. Qed. -Lemma trans_alt_eps_inv {E B X} (a mid : TransAlt.S E B X) : +Lemma trans_alt_eps_inv {E C X} (a mid : TransAlt.S E C X) : trans_alt ε a mid -> - (exists Z (c : B Z) (k : Z -> ctree E B X) t u x, + (exists Z (c : C Z) (k : Z -> ctree E C X) t u x, a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Br c k /\ u ≅ k x) \/ (exists t t' u, a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Guard t' /\ u ≅ t'). @@ -89,7 +89,7 @@ Proof. - right. eauto 12. Qed. -Lemma eps_absorb1 {E B X} (l : Trans.label E X) (a mid c : TransAlt.S E B X) : +Lemma eps_absorb1 {E C X} (l : Trans.label E X) (a mid c : TransAlt.S E C X) : trans_alt ε a mid -> Trans.transR l (n2o_S mid) (n2o_S c) -> Trans.transR l (n2o_S a) (n2o_S c). @@ -115,7 +115,7 @@ Proof. rewrite S2. apply Hold. Qed. -Lemma estar_absorb {E B X} (l : Trans.label E X) (a m : TransAlt.S E B X) : +Lemma estar_absorb {E C X} (l : Trans.label E X) (a m : TransAlt.S E C X) : (trans_alt ε)^* a m -> forall c, Trans.transR l (n2o_S m) (n2o_S c) -> Trans.transR l (n2o_S a) (n2o_S c). Proof. @@ -127,7 +127,7 @@ Proof. eapply IHn; [ apply REST | apply Hold ]. Qed. -Lemma transR_label_base {E B X} (l : Trans.label E X) (m b : TransAlt.S E B X) : +Lemma transR_label_base {E C X} (l : Trans.label E X) (m b : TransAlt.S E C X) : trans_alt (o2n_label l) m b -> Trans.transR l (n2o_S m) (n2o_S b). Proof. destruct l; cbn [o2n_label]; intros TR; unfold trans_alt in TR; cbn in TR. @@ -137,7 +137,7 @@ Proof. - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transval; eassumption. Qed. -Lemma transR_n2o {E B X} (l : Trans.label E X) (a b : TransAlt.S E B X) : +Lemma transR_n2o {E C X} (l : Trans.label E X) (a b : TransAlt.S E C X) : ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) a b -> Trans.transR l (n2o_S a) (n2o_S b). Proof. @@ -146,22 +146,22 @@ Proof. apply transR_label_base; apply STEP. Qed. -Definition lift_L {E F X} (L : Trans.lrel E F X X) : TransAlt.lrel E F X X := +Definition lift_L {E F X Y} (L : Trans.lrel E F X Y) : TransAlt.lrel E F X Y := {| TransAlt.RR := Trans.RR L ; TransAlt.Rask := Trans.Rask L ; TransAlt.Rrcv := Trans.Rrcv L |}. (* old to new through lifting *) -Lemma lift_L_o2n {E F X} (L : Trans.lrel E F X X) - (la : Trans.label E X) (lb : Trans.label F X) : +Lemma lift_L_o2n {E F X Y} (L : Trans.lrel E F X Y) + (la : Trans.label E X) (lb : Trans.label F Y) : Trans.build_rel L la lb -> TransAlt.build_rel (lift_L L) (o2n_label la) (o2n_label lb). Proof. intros H; destruct H; cbn [o2n_label]; now constructor. Qed. -Lemma lift_L_o2n_inv {E F X} (L : Trans.lrel E F X X) - (a : TransAlt.label E X) (b : TransAlt.label F X) : +Lemma lift_L_o2n_inv {E F X Y} (L : Trans.lrel E F X Y) + (a : TransAlt.label E X) (b : TransAlt.label F Y) : TransAlt.build_rel (lift_L L) a b -> exists la lb, a = o2n_label la /\ b = o2n_label lb /\ Trans.build_rel L la lb. Proof. @@ -190,8 +190,8 @@ Proof. dependent destruction H; reflexivity. Qed. -Lemma o_ssim_br_step {E F B X} (L : Trans.lrel E F X X) - Z (c : B Z) (k : Z -> ctree E B X) (t u : ctree E B X) (b : Trans.S F B X) x : +Lemma o_ssim_br_step {E F C D X Y} (L : Trans.lrel E F X Y) + Z (c : C Z) (k : Z -> ctree E C X) (t u : ctree E C X) (b : Trans.S F D Y) x : SSim.ssim L (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> SSim.ssim L (Trans.Active u) b. Proof. @@ -207,8 +207,8 @@ Proof. - apply TR. Qed. -Lemma o_ssim_guard_step {E F B X} (L : Trans.lrel E F X X) - (t tg u : ctree E B X) (b : Trans.S F B X) : +Lemma o_ssim_guard_step {E F C D X Y} (L : Trans.lrel E F X Y) + (t tg u : ctree E C X) (b : Trans.S F D Y) : SSim.ssim L (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> SSim.ssim L (Trans.Active u) b. Proof. @@ -223,8 +223,8 @@ Proof. Qed. (* main result *) -Lemma o_ssim_to_ssim' {E F B X} (L : Trans.lrel E F X X) : - forall (a : Trans.S E B X) (b : Trans.S F B X), +Lemma o_ssim_to_ssim' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), SSim.ssim L a b -> SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b). Proof. unfold SSimAlt.ssim'. @@ -233,10 +233,10 @@ Proof. split. - intros x l Hne TR. apply label_non_eps_image in Hne as [lo ->]. - step in H. + step in H. assert (oTR : Trans.transR lo a (n2o_S x)). { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } - repeat red in H. + repeat red in H. destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). exists (o2n_label lo'), (o2n_S bo'). split; [| split]. @@ -252,9 +252,9 @@ Proof. | (t & tg & u & Ha & Hx & Hg & Hu) ]. (* t is a branch, *) * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. - inv Ha. + inv Ha. apply (cih (Trans.Active u) b). - eapply o_ssim_br_step; eauto. + eapply o_ssim_br_step; eauto. (* t is a guard, one epsilon step and coinduction *) * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. inv Ha. @@ -262,8 +262,8 @@ Proof. eapply o_ssim_guard_step; eauto. Qed. -Lemma ssim'_to_o_ssim {E F B X} (L : Trans.lrel E F X X) : - forall (a : Trans.S E B X) (b : Trans.S F B X), +Lemma ssim'_to_o_ssim {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b) -> SSim.ssim L a b. Proof. unfold SSim.ssim. @@ -273,7 +273,7 @@ Proof. apply transR_o2n in oTR. destruct oTR as [m STAR STEP]. eapply SSimAlt.ssim'_epsilon_l in H. 2: apply STAR. - apply (gfp_pfp (@SSimAlt.ss' E F B B) X X (lift_L L)) in H. + apply (gfp_pfp (@SSimAlt.ss' E F C D) X Y (lift_L L)) in H. destruct H as (Hchal & _). destruct (Hchal (o2n_S ao') (o2n_label l)) as (nl' & u' & RESP & Hgfp & HL). { destruct l; cbn [o2n_label]; easy. } @@ -288,8 +288,8 @@ Proof. - apply HLab. Qed. -Theorem ssim_ssim' {E F B X} (L : Trans.lrel E F X X) - (t : ctree E B X) (t' : ctree F B X) : +Theorem ssim_ssim' {E F C D X Y} (L : Trans.lrel E F X Y) + (t : ctree E C X) (t' : ctree F D Y) : SSim.ssim L (Trans.Active t) (Trans.Active t') <-> SSimAlt.ssim' (lift_L L) (TransAlt.Active t) (TransAlt.Active t'). Proof. diff --git a/theories/Eq/IterFacts.v b/theories/Eq/IterFacts.v index 67f53a3..5b78e2e 100644 --- a/theories/Eq/IterFacts.v +++ b/theories/Eq/IterFacts.v @@ -11,6 +11,7 @@ From CTree Require Import Utils Eq Eq.SSimAlt + Eq.AltEquiv Eq.SBisimAlt. Import CTree. @@ -39,8 +40,12 @@ Qed. Proof. cbn. intros step step' ? t t' EQ. unfold iter_gen. - revert t t' EQ. coinduction CR CH. intros. - subs. upto_bind_eq. red in H. + revert t t' EQ. + unfold equ at -1. + (* coinduction library bug: *) + coinduction CR CH. intros. + subs. + upto_bind_eq. red in H. destruct x; [| reflexivity]. constructor. rewrite !iter_iter_gen. apply CH. now apply H. @@ -52,27 +57,32 @@ Proof. cbn. intros step step' ? i i' EQ. rewrite !iter_iter_gen. apply iter_gen_equ; auto. Qed. - (* Thanks to SSimAlt, this proof does not need an helper inductive. *) Theorem ssim_iter {E F C D A A' B B'} - (L : rel (@label E) (@label F)) (Ra : rel A A') (Rb : rel B B') L0 - (HL0 : is_update_val_rel L (sum_rel Ra Rb) L0) + (L : lrel E F _ _) (Ra : rel A A') (Rb : rel B B') (HRb : forall b b', Rb b b' <-> L (val b) (val b')) : forall (step : A -> ctree E C (A + B)) (step' : A' -> ctree F D (A' + B')), - (forall a a', Ra a a' -> step a (≲L0) step' a') -> + (forall a a', Ra a a' -> step a (≲(upd_rel L (sum_rel Ra Rb))) step' a') -> forall a a', Ra a a' -> iter step a (≲L) iter step' a'. Proof. - intros. apply ssim_ssim'. + intros. apply (ssim_ssim'). revert step a a' H H0. red. coinduction R CH. intros. - unfold iter_gen. rewrite !unfold_iter. - eapply SSimAlt.bind_chain_gen. - - apply HL0. - - now apply H. + rewrite !unfold_iter. + eapply SSimAlt.bind_chain_gen with (SS:=(sum_rel Ra Rb)). + Locate upd_rel. + - cbn -[ss']. + (* coinduction library: want [base] tactic that does this and always works *) + apply (gfp_chain (chain_b R)). + apply H in H0. now apply ssim_ssim' in H0. - intros. destruct x, x'; try destruct H1. + apply step_ss'_guard. apply CH; auto. - + apply step_ssbt'_ret. now apply HRb. + + apply step_ssbt'_ret. + change (TransAlt.val b) with (@o2n_label E _ (val b)). + change (TransAlt.val b0) with (@o2n_label F _ (val b0)). + eapply AltEquiv.lift_L_o2n. + now apply HRb. Qed. #[global] Instance ssim_eq_iter {E B X Y} : diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index ba9fd52..7045036 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -1505,7 +1505,7 @@ Expliciting the reasoning rule provided by the up-to principles. (* Note: In this section, I changed the relation between t1 and t2 to be at the gfp. *) -Lemma st'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : lrel E F X' Y'} +Lemma sb'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : lrel E F X' Y'} (SS : rel X Y) side (t1 : ctree E C X) (t2: ctree F D Y) @@ -1531,11 +1531,11 @@ Lemma sbisim'_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : lrel E F X gfp (@sb' E F C D) side X' Y' L (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros H1 H2. - apply (@st'_clo_bind E F C D X Y X' Y' L SS side t1 t2 k1 k2 + apply (@sb'_clo_bind E F C D X Y X' Y' L SS side t1 t2 k1 k2 (chain_gfp (@sb' E F C D))); assumption. Qed. -Lemma st'_clo_bind_eq {E C: Type -> Type} {X X': Type} +Lemma sb'_clo_bind_eq {E C: Type -> Type} {X X': Type} side (t1 t2 : ctree E C X) (k1 k2 : X -> ctree E C X') (R : Chain (@sb' E E C C)) : @@ -1544,7 +1544,7 @@ Lemma st'_clo_bind_eq {E C: Type -> Type} {X X': Type} ` R side X' X' (@Leq E X') (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros H1 H2. - eapply st'_clo_bind with (SS := eq); [exact H1 |]. + eapply sb'_clo_bind with (SS := eq); [exact H1 |]. intros x y ->; apply H2. Qed. @@ -1555,7 +1555,7 @@ Lemma sbisim'_clo_bind_eq {E C: Type -> Type} {X X': Type} : gfp (@sb' E E C C) side X' X' (@Leq E X') (Active (x <- t1;; k1 x)) (Active (x <- t2;; k2 x)). Proof. intros. - apply (@st'_clo_bind_eq E C X X' side t1 t2 k1 k2 (chain_gfp (@sb' E E C C))); assumption. + apply (@sb'_clo_bind_eq E C X X' side t1 t2 k1 k2 (chain_gfp (@sb' E E C C))); assumption. Qed. Lemma step_sb'_guard_l' {E F C D X Y} {L : lrel E F X Y} @@ -1579,13 +1579,31 @@ Proof. exists t'; split; [reflexivity | apply H]. Qed. +(* gfp-gfp / gfp-elem *) +Ltac __upto_bind_sbisim' R := + first [apply sbisim'_clo_bind with (R0 := R) | apply sb'_clo_bind with (R0 := R)]. +Ltac __eupto_bind_sbisim' := + first [eapply sbisim'_clo_bind | eapply sb'_clo_bind]. + +Ltac __upto_bind_sbisim'_eq := + first [apply sb'_clo_bind_eq | apply sbisim'_clo_bind_eq]. + + +Tactic Notation "__upto_bind_sbisim'" uconstr(R0) := __upto_bind_sbisim' R0. +Tactic Notation "__upto_bind_sbisim'_eq" := __upto_bind_sbisim'_eq. + + +#[global] Tactic Notation "upto_bind" := + __eupto_bind_equ || __eupto_bind_sbisim'. + +#[global] Tactic Notation "upto_bind_eq" := + __upto_bind_equ_eq || __upto_bind_sbisim'_eq. + +#[global] Tactic Notation "upto_bind" "with" uconstr(SS) := + __upto_bind_equ SS || __upto_bind_sbisim' SS. -(* -Tactic Notation "__upto_bind_sbisim'" uconstr(R0) := TODO -Tactic Notation "__upto_bind_eq_sbisim'" uconstr(R0) := TODO -*) (* Equivalence of old and new bisimilarities diff --git a/theories/Eq/SBisim_old.v b/theories/Eq/SBisim_old.v index 640e953..c10f539 100644 --- a/theories/Eq/SBisim_old.v +++ b/theories/Eq/SBisim_old.v @@ -683,10 +683,10 @@ Proof. apply update_val_rel_correct. Qed. -Ltac __upto_bind_sbisim' R := +(* Ltac __upto_bind_sbisim' R := first [apply sbisim_clo_bind with (R0 := R) | apply sb_chain_bind with (R0 := R)]. -Tactic Notation "__upto_bind_sbisim" uconstr(t) := __upto_bind_sbisim' t. +Tactic Notation "__upto_bind_sbisim" uconstr(t) := __upto_bind_sbisim' t. *) Ltac __eupto_bind_sbisim := first [eapply sbisim_clo_bind | eapply sb_chain_bind]. From 04ed9b8fd9bd1b481a9e68e4014fd869e0c9f20b Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Tue, 29 Sep 2026 19:27:13 -0400 Subject: [PATCH 57/61] More patches. Now restructuring. --- examples/AltBisim/BisimExample.v | 27 ++++---- theories/Eq/AltEquiv.v | 5 ++ theories/Eq/IterFacts.v | 90 ++++++++++++++------------ theories/Eq/SBisimAlt.v | 106 +++++++++++++++++++++---------- theories/Eq/SSimAlt.v | 32 ++++++++-- theories/Eq/TransAlt.v | 15 +++++ 6 files changed, 184 insertions(+), 91 deletions(-) diff --git a/examples/AltBisim/BisimExample.v b/examples/AltBisim/BisimExample.v index cf862a7..d794dbd 100644 --- a/examples/AltBisim/BisimExample.v +++ b/examples/AltBisim/BisimExample.v @@ -18,37 +18,36 @@ Proof. step. cbn. reflexivity. Qed. Lemma unfold_u : u ≅ br2 (trigger (print true);; u) u. Proof. step. cbn. reflexivity. Qed. -Theorem bisim_t_u : t ~ u. +Theorem bisim_t_u : t ≃ u. Proof. - coinduction R CH. + __coinduction_sbisim R CH. rewrite unfold_t, unfold_u. - apply step_sb_br; intros []. + apply sb_br; intros []. 2: { exists true. rewrite !bind_trigger. - apply step_sb_vis_id. intros []. - split; [| auto]. - apply CH. + apply sb_vis_id; [constructor |]. intros []. + split; [apply CH | constructor]. } { exists false. - Fail apply CH. + Fail apply CH. Abort. -Theorem bisim_t_u : t ~ u. +Theorem bisim_t_u : t ≃ u. Proof. (* We switch to the alternative characterization of bisimulation. *) rewrite sbisim_sbisim'. (* The rest of the proof proceeds as before, but this time it succeeds. *) coinduction R CH. intros. - rewrite unfold_t, unfold_u. + cbn [AltEquiv.o2n_S]. rewrite unfold_t, unfold_u. apply step_sb'_br; intros []. (* Notice that unlike step_sb_br, step_sb'_br has unlocked the coinduction hypothesis. *) 2: { exists true. rewrite !bind_trigger. - step. apply step_sb'_vis_id. intros []. - split; [| auto]. + step. apply step_sb'_vis_id; [| constructor; constructor]. intros. + apply (b_chain R). apply step_sb'_passive_id; [| constructor; constructor]. intros ? []. apply CH. } { @@ -59,8 +58,8 @@ Proof. { exists false. rewrite !bind_trigger. - step. apply step_sb'_vis_id. intros []. - split; [| auto]. + step. apply step_sb'_vis_id; [| constructor; constructor]. intros. + apply (b_chain R). apply step_sb'_passive_id; [| constructor; constructor]. intros ? []. apply CH. } { @@ -78,7 +77,7 @@ Definition t' : ctree PrintE B2 void := Definition u' : ctree PrintE B2 void := CTree.iter (fun _ => br2 (trigger (print true);; Ret (inl tt)) (Ret (inl tt))) tt. -Theorem bisim_t'_u'_simple : t' ~ u'. +Theorem bisim_t'_u'_simple : t' ≃ u'. Proof. unfold t', u'. apply sbisim_eq_iter. intros _. diff --git a/theories/Eq/AltEquiv.v b/theories/Eq/AltEquiv.v index a0c0316..82f0453 100644 --- a/theories/Eq/AltEquiv.v +++ b/theories/Eq/AltEquiv.v @@ -172,6 +172,11 @@ Proof. - exists (Trans.val x), (Trans.val y); cbn [o2n_label]; repeat split; now constructor. Qed. +#[global] Instance lift_L_Leq_reflexiveL {E X} : ReflexiveL (lift_L (@Trans.Leq E X)). +Proof. + intros [] Hne; try easy; constructor; cbn; first [reflexivity | constructor]. +Qed. + Lemma label_non_eps_image {E X} (l : TransAlt.label E X) : l <> ε -> exists lo, l = o2n_label lo. Proof. diff --git a/theories/Eq/IterFacts.v b/theories/Eq/IterFacts.v index 5b78e2e..4889daf 100644 --- a/theories/Eq/IterFacts.v +++ b/theories/Eq/IterFacts.v @@ -71,7 +71,6 @@ Proof. red. coinduction R CH. intros. rewrite !unfold_iter. eapply SSimAlt.bind_chain_gen with (SS:=(sum_rel Ra Rb)). - Locate upd_rel. - cbn -[ss']. (* coinduction library: want [base] tactic that does this and always works *) apply (gfp_chain (chain_b R)). @@ -87,52 +86,61 @@ Qed. #[global] Instance ssim_eq_iter {E B X Y} : @Proper ((X -> ctree E B (X + Y)) -> X -> ctree E B Y) - (pointwise_relation _ (ssim eq) ==> eq ==> (ssim eq)) + (pointwise_relation _ (fun t u => ssim Leq (α t) (α u)) ==> eq ==> + (fun t u => ssim Leq (α t) (α u))) iter. Proof. - repeat intro. - eapply ssim_iter with (L := eq) (L0 := eq) (Ra := eq) (Rb := eq). - - eassert (@weq (relation (X + Y)) _ (sum_rel eq eq) eq). - { cbn. intros [] []; cbn; split; intro; subst; try easy. now inv H1. now inv H1. } - rewrite H1; auto. apply update_val_rel_eq. - - split; intro. now subst. now apply val_eq_inv in H1. - - intros. subst. apply H. - - apply H0. + repeat intro. subst. + eapply ssim_iter with (L := Leq) (Ra := eq) (Rb := eq). + - intros b b'. split; [intros ->; reflexivity | intros EQ; apply Leq_eq in EQ; now apply val_eq_inv in EQ]. + - intros a ? <-. + assert (LEQ : lequiv (upd_rel (@Leq E Y) (sum_rel (@eq X) (@eq Y))) (@Leq E (X + Y))). + { split3; cbn; try reflexivity. + intros [] []; cbn; split; intro EQ; subst; try easy; now inv EQ. } + apply (weq_ssim LEQ). apply H. + - reflexivity. Qed. Theorem sbisim_iter {E F C D A A' B B'} - (L : rel (@label E) (@label F)) (Ra : rel A A') (Rb : rel B B') L0 - (HL0 : is_update_val_rel L (sum_rel Ra Rb) L0) + (L : lrel E F _ _) (Ra : rel A A') (Rb : rel B B') (HRb : forall b b', Rb b b' <-> L (val b) (val b')) : forall (step : A -> ctree E C (A + B)) (step' : A' -> ctree F D (A' + B')), - (forall a a', Ra a a' -> step a (~L0) step' a') -> + (forall a a', Ra a a' -> step a (≃(upd_rel L (sum_rel Ra Rb))) step' a') -> forall a a', Ra a a' -> - iter step a (~L) iter step' a'. + iter step a (≃L) iter step' a'. Proof. intros. apply sbisim_sbisim'. revert step a a' H H0. red. coinduction R CH. intros. - rewrite !unfold_iter. - eapply sbt'_clo_bind_gen. - - apply HL0. - - apply H in H0. apply sbisim_sbisim' in H0. apply H0. - - intros. destruct x, y; try destruct H1. + cbn [o2n_S]. rewrite !unfold_iter. + eapply (@SBisimAlt.bind_chain_gen _ _ _ _ _ _ _ _ _ (chain_b R)) with (SS := sum_rel Ra Rb). + - apply (gfp_chain (chain_b R)). + change (gfp sb' side _ _ (lift_L (Trans.upd_rel L (sum_rel Ra Rb))) + (o2n_S (α step a)) (o2n_S (α step' a'))). + apply sbisim_gfp_sb'. now apply H. + - intros side0 x x' Hx. destruct x, x'; try destruct Hx. + apply step_sb'_guard. apply CH; auto. - + apply step_sbt'_ret. now apply HRb. + + apply step_sbt'_ret. + change (TransAlt.val b) with (@o2n_label E _ (val b)). + change (TransAlt.val b0) with (@o2n_label F _ (val b0)). + eapply AltEquiv.lift_L_o2n. + now apply HRb. Qed. #[global] Instance sbisim_eq_iter {E B X Y} : @Proper ((X -> ctree E B (X + Y)) -> X -> ctree E B Y) - (pointwise_relation _ (sbisim eq) ==> pointwise_relation _ (sbisim eq)) + (pointwise_relation _ (fun t u => sbisim Leq (α t) (α u)) ==> + pointwise_relation _ (fun t u => sbisim Leq (α t) (α u))) iter. Proof. repeat intro. - eapply sbisim_iter with (L := eq) (L0 := eq) (Ra := eq) (Rb := eq). - - eassert (@weq (relation (X + Y)) _ (sum_rel eq eq) eq). - { cbn. intros [] []; cbn; split; intro; subst; try easy. now inv H0. now inv H0. } - rewrite H0; auto. apply update_val_rel_eq. - - split; intro. now subst. now apply val_eq_inv in H0. - - intros. subst. apply H. + eapply sbisim_iter with (L := Leq) (Ra := eq) (Rb := eq). + - intros b b'. split; [intros ->; reflexivity | intros EQ; apply Leq_eq in EQ; now apply val_eq_inv in EQ]. + - intros ? ? <-. + assert (LEQ : lequiv (upd_rel (@Leq E Y) (sum_rel (@eq X) (@eq Y))) (@Leq E (X + Y))). + { split3; cbn; try reflexivity. + intros [] []; cbn; split; intro EQ; subst; try easy; now inv EQ. } + apply (weq_sbisim LEQ). apply H. - reflexivity. Qed. @@ -168,7 +176,7 @@ Lemma iter_dinatural_ctree_inner {E C X Y Z} : | inl y => g y | inr z => Ret (inr z) end)) x - ~ CTree.bind (f x) + ≃ CTree.bind (f x) (fun yz : Y + Z => match yz with | inl y => @@ -184,8 +192,8 @@ Lemma iter_dinatural_ctree_inner {E C X Y Z} : end). Proof. intros. apply sbisim_sbisim'. red. revert x. coinduction R CH. intros. - rewrite unfold_iter, bind_bind. - apply sbt'_clo_bind_eq. { reflexivity. } + cbn [o2n_S]. rewrite unfold_iter, bind_bind. + apply (sb'_clo_bind_lift_eq (R := chain_b R)). { reflexivity. } intros. destruct x0. 2: { rewrite bind_ret_l. reflexivity. } destruct (observe (g y)) eqn:?. @@ -206,9 +214,9 @@ Proof. - setoid_rewrite (ctree_eta (g y)). rewrite Heqc, bind_step. rewrite unfold_iter, bind_bind, (ctree_eta (g y)), Heqc, bind_step. apply step_sb'_guard_r'. - apply step_sb'_step; auto. + apply step_sb'_step; [constructor |]. intros. - apply st'_clo_bind_eq; auto. + apply (sb'_clo_bind_lift_eq (R := R)); auto. intros. destruct x0. + apply step_sb'_guard_l'. intros; apply CH. + rewrite bind_ret_l. reflexivity. @@ -218,7 +226,7 @@ Proof. apply step_sb'_guard. apply step_sb'_guard_r'. intros. - apply st'_clo_bind_eq; auto. + apply (sb'_clo_bind_lift_eq (R := R)); auto. intros. destruct x0. + apply step_sb'_guard_l'. intros; apply CH. + rewrite bind_ret_l. reflexivity. @@ -226,9 +234,9 @@ Proof. - setoid_rewrite (ctree_eta (g y)). rewrite Heqc, bind_vis. apply step_sb'_guard_r. rewrite unfold_iter, bind_bind, (ctree_eta (g y)), Heqc, bind_vis. - apply step_sb'_vis_id. intros. - split; auto. intros. - apply st'_clo_bind_eq. { reflexivity. } + apply step_sb'_vis_id; [| constructor; constructor]. + intros. apply (b_chain R). apply step_sb'_passive_id; [| constructor; constructor]. + intros. apply (sb'_clo_bind_lift_eq (R := R)). { reflexivity. } intros. destruct x1. + apply step_sb'_guard_l'. apply CH. + rewrite bind_ret_l. reflexivity. @@ -237,7 +245,7 @@ Proof. apply step_sb'_guard_r'. intros. rewrite unfold_iter, bind_bind, (ctree_eta (g y)), Heqc, bind_br. apply step_sb'_br_id; auto. intros. - apply st'_clo_bind_eq. { reflexivity. } + apply (sb'_clo_bind_lift_eq (R := R)). { reflexivity. } intros. destruct x1. + apply step_sb'_guard_l'. intros. apply CH. + rewrite bind_ret_l. reflexivity. @@ -253,7 +261,7 @@ Lemma iter_dinatural_ctree {E C X Y Z} : | inl y => g y | inr z => Ret (inr z) end)) x - ~ CTree.bind (f x) + ≃ CTree.bind (f x) (fun yz : Y + Z => match yz with | inl y => @@ -270,13 +278,13 @@ Lemma iter_dinatural_ctree {E C X Y Z} : Proof. intros. rewrite unfold_iter, bind_bind. - upto_bind_eq. + apply sbisim_bind_eq; [reflexivity | intros x0]. destruct x0. 2: { rewrite bind_ret_l. reflexivity. } - rewrite unfold_iter, bind_bind. upto_bind_eq. + rewrite unfold_iter, bind_bind. apply sbisim_bind_eq; [reflexivity | intros x0]. destruct x0. 2: { rewrite bind_ret_l. reflexivity. } - rewrite sb_guard. apply iter_dinatural_ctree_inner. + rewrite sbisim_guard. apply iter_dinatural_ctree_inner. Qed. Theorem iter_codiagonal_ctree {E C A B} : diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 7045036..7148fe8 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -322,7 +322,7 @@ Section sbisim'_homogenous_theory. Notation sb' := (@sb' E E B B). Notation sbisim' := (@sbisim' E E B B X X). - #[global] Instance refl_sb' {LR: Reflexive L} {C: Chain sb'} + #[global] Instance refl_sb' {LR: ReflexiveL L} {C: Chain sb'} : forall side, Reflexive (`C side X X L). Proof. apply tower. @@ -333,7 +333,7 @@ Section sbisim'_homogenous_theory. exists l, t'; ssplit. * apply estar_l_lift; exact TR. * intro; apply IH. - * apply LR. + * now apply LR. + intros t' TR. exists t'; split. * apply estar_single; exact TR. @@ -342,21 +342,21 @@ Section sbisim'_homogenous_theory. exists l, t'; ssplit. * apply estar_l_lift; exact TR. * intro; apply IH. - * reflexivity. + * now apply flipL_reflexiveL. + intros t' TR. exists t'; split. * apply estar_single; exact TR. * apply IH. Qed. - #[global] Instance refl_bsb' {LR: Reflexive L} {C: Chain sb'} + #[global] Instance refl_bsb' {LR: ReflexiveL L} {C: Chain sb'} : forall side, Reflexive (sb' `C side X X L). Proof. intros ??. apply refl_sb'. Qed. - #[global] Instance refl_sbisim' {LR: Reflexive L} + #[global] Instance refl_sbisim' {LR: ReflexiveL L} : Reflexive (sbisim' L). Proof. intros ??; apply refl_sb'. @@ -574,6 +574,31 @@ Section Proof_Rules. intros; now apply step_sb'_vis. Qed. + Lemma step_sb'_passive {R : sb'R E F C D} {HR: sb'Proper R} + {Z Z'} (e : E Z) (f : F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + (forall x, exists y, (forall side, R side X Y L (k x) (k' y)) /\ L (rcv e x) (rcv f y)) -> + (forall y, exists x, (forall side, R side X Y L (k x) (k' y)) /\ L (rcv e x) (rcv f y)) -> + forall side, sb' R side X Y L (Passive e k) (Passive f k'). + Proof. + intros Hl Hr side; split; intro; subst. + - apply step_ss'_passive. intros x. + destruct (Hl x) as (y & HRxy & Lrcv). eauto. + - apply step_ss'_passive. intros y. + destruct (Hr y) as (x & HRxy & Lrcv). + exists x; split; [apply HRxy | now apply flipL_flip]. + Qed. + + Lemma step_sb'_passive_id {R : sb'R E F C D} {HR: sb'Proper R} + {Z} (e : E Z) (f : F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : + (forall side x, R side X Y L (k x) (k' x)) -> + (forall x, L (rcv e x) (rcv f x)) -> + forall side, sb' R side X Y L (Passive e k) (Passive f k'). + Proof. + intros; apply step_sb'_passive; eauto. + Qed. + Lemma step_sb'_vis_l {R : sb'R E F C D} {HR: sb'Proper R} {Z} : forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' @@ -1610,9 +1635,9 @@ Equivalence of old and new bisimilarities *) Section sbisim_sbisim'. -Lemma o_ss_br_step {E F B X} (L : Trans.lrel E F X X) - (Rel : rel (Trans.S E B X) (Trans.S F B X)) - Z (c : B Z) (k : Z -> ctree E B X) (t u : ctree E B X) (b : Trans.S F B X) x : +Lemma o_ss_br_step {E F C D X Y} (L : Trans.lrel E F X Y) + (Rel : rel (Trans.S E C X) (Trans.S F D Y)) + Z (c : C Z) (k : Z -> ctree E C X) (t u : ctree E C X) (b : Trans.S F D Y) x : SSim.ss L Rel (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> SSim.ss L Rel (Trans.Active u) b. Proof. @@ -1621,9 +1646,9 @@ Proof. eapply Trans.Transbr; [apply Hbr | apply Hu | apply TR]. Qed. -Lemma o_ss_guard_step {E F B X} (L : Trans.lrel E F X X) - (Rel : rel (Trans.S E B X) (Trans.S F B X)) - (t tg u : ctree E B X) (b : Trans.S F B X) : +Lemma o_ss_guard_step {E F C D X Y} (L : Trans.lrel E F X Y) + (Rel : rel (Trans.S E C X) (Trans.S F D Y)) + (t tg u : ctree E C X) (b : Trans.S F D Y) : SSim.ss L Rel (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> SSim.ss L Rel (Trans.Active u) b. Proof. @@ -1633,19 +1658,19 @@ Proof. eapply Trans.Transguard; [apply Htu | apply TR]. Qed. -Lemma lift_L_flipL {E F X} (L : Trans.lrel E F X X) : +Lemma lift_L_flipL {E F X Y} (L : Trans.lrel E F X Y) : lift_L (Trans.flipL L) = TransAlt.flipL (lift_L L). Proof. now destruct L. Qed. (* need to split at [side] so that the simulation game lines up. *) -Theorem gfp_sb'_ss_sbisim {E F B X} (L : Trans.lrel E F X X) : - forall (a : Trans.S E B X) (b : Trans.S F B X), +Theorem gfp_sb'_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), (SSim.ss L (SBisim.sbisim L) a b -> - gfp (@sb' E F B B) true X X (lift_L L) (o2n_S a) (o2n_S b)) /\ + gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b)) /\ (SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a -> - gfp (@sb' E F B B) false X X (lift_L L) (o2n_S a) (o2n_S b)). + gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b)). Proof. coinduction R CH. intros a b. split; intro H. @@ -1659,7 +1684,7 @@ Proof. destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). exists (o2n_label lo'), (o2n_S bo'); ssplit. * apply transR_o2n; exact TRb. - * apply (gfp_pfp (@SBisim.sb E F B B X X L)) in Hrel. + * apply (gfp_pfp (@SBisim.sb E F C D X Y L)) in Hrel. destruct Hrel as [Hf Hb]. pose proof (CH (n2o_S x) bo') as CHx. rewrite o2n_n2o_S in CHx. @@ -1687,7 +1712,7 @@ Proof. exists (o2n_label lo'), (o2n_S ao'); ssplit. * apply transR_o2n; exact TRa. * unfold flip in Hrel. - apply (gfp_pfp (@SBisim.sb E F B B X X L)) in Hrel. + apply (gfp_pfp (@SBisim.sb E F C D X Y L)) in Hrel. destruct Hrel as [Hf Hb]. pose proof (CH ao' (n2o_S x)) as CHx. rewrite o2n_n2o_S in CHx. @@ -1706,16 +1731,16 @@ Proof. eapply o_ss_guard_step; eauto. Qed. -Lemma gfp_sb'_true_ss_sbisim {E F B X} (L : Trans.lrel E F X X) : - forall (a : Trans.S E B X) (b : Trans.S F B X), +Lemma gfp_sb'_true_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), SSim.ss L (SBisim.sbisim L) a b -> - gfp (@sb' E F B B) true X X (lift_L L) (o2n_S a) (o2n_S b). + gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b). Proof. intros a b; apply (gfp_sb'_ss_sbisim L a b). Qed. -Theorem sbisim_sbisim' {E F B X} (L : Trans.lrel E F X X) : - forall (a : Trans.S E B X) (b : Trans.S F B X), +Theorem sbisim_sbisim' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), SBisim.sbisim L a b <-> sbisim' (lift_L L) (o2n_S a) (o2n_S b). Proof. intros a b; split; intro H. @@ -1763,26 +1788,26 @@ Proof. * apply Trans.flipL_flip; exact HLab. Qed. -Corollary sbisim_gfp_sb' {E F B X} (L : Trans.lrel E F X X) : - forall side (a : Trans.S E B X) (b : Trans.S F B X), +Corollary sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall side (a : Trans.S E C X) (b : Trans.S F D Y), SBisim.sbisim L a b -> - gfp (@sb' E F B B) side X X (lift_L L) (o2n_S a) (o2n_S b). + gfp (@sb' E F C D) side X Y (lift_L L) (o2n_S a) (o2n_S b). Proof. intros. apply sbisim_sbisim' in H. apply H. Qed. -Theorem ss_sbisim_gfp_sb' {E F B X} (L : Trans.lrel E F X X) : - forall (a : Trans.S E B X) (b : Trans.S F B X), - (gfp (@sb' E F B B) true X X (lift_L L) (o2n_S a) (o2n_S b) -> +Theorem ss_sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + (gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b) -> SSim.ss L (SBisim.sbisim L) a b) /\ - (gfp (@sb' E F B B) false X X (lift_L L) (o2n_S a) (o2n_S b) -> + (gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b) -> SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a). Proof. intros a b; split; intro H. - intros lo x oTR. apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. eapply sbisim'_epsilon_l in H; [| exact STAR]. - apply (gfp_pfp (@sb' E F B B)) in H. + apply (gfp_pfp (@sb' E F C D)) in H. destruct H as [H _]; specialize (H eq_refl); destruct H as [HA _]. assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). destruct (HA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). @@ -1795,7 +1820,7 @@ Proof. - intros lo x oTR. apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. eapply sbisim'_epsilon_r in H; [| exact STAR]. - apply (gfp_pfp (@sb' E F B B)) in H. + apply (gfp_pfp (@sb' E F C D)) in H. destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA _]. assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). destruct (HA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). @@ -1808,4 +1833,21 @@ Proof. + apply Trans.flipL_flip; exact HLab. Qed. +Lemma sb'_clo_bind_lift_eq {E B X X'} {R : Chain (@sb' E E B B)} side + (t t' : ctree E B X) (k k' : X -> ctree E B X') : + SBisim.sbisim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> + (forall side x, elem R side X' X' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> + elem R side X' X' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). +Proof. + intros tt kk. + eapply bind_chain_gen with (SS := @eq X). + - apply (gfp_chain R). + change (gfp (@sb' E E B B) side X X (lift_L (@Trans.Leq E X)) + (o2n_S (Trans.Active t)) (o2n_S (Trans.Active t'))). + now apply sbisim_gfp_sb'. + - intros ? x ? <-; apply kk. +Qed. + End sbisim_sbisim'. \ No newline at end of file diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 0568d6e..7d66a5d 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -255,22 +255,22 @@ Section ssim'_homogenous_theory. Notation ss' := (@ss' E E C C). Notation ssim' := (@ssim' E E C C X X). - #[global] Instance Reflexive_ss'_gen `{Reflexive _ (R L)} `{Reflexive _ (Reps L)} `{Reflexive _ L}: + #[global] Instance Reflexive_ss'_gen `{Reflexive _ (R L)} `{Reflexive _ (Reps L)} {LR: ReflexiveL L}: Reflexive (@ss'_gen E E C C R Reps X X L). Proof. split; intros. - exists l, t'. split; auto. + exists l, t'. split; [| split; [reflexivity | now apply LR]]. use_steps O. assumption. exists t'; split; eauto. use_steps (1 : nat). econstructor; eauto. Qed. - #[global] Instance Reflexive_ss'_chain {LR: Reflexive L} {c: Chain (ss')}: Reflexive (`c X X L). + #[global] Instance Reflexive_ss'_chain {LR: ReflexiveL L} {c: Chain (ss')}: Reflexive (`c X X L). Proof. (* of note: Reflexive_chain fails here because elem has arguments.. we should fix that. *) tower induction. split; intros. - - do 2 eexists. split. use_steps O. apply H1. now split. + - do 2 eexists. split. use_steps O. apply H1. split; [now apply H | now apply LR]. - exists t'; split; auto. use_steps (1 : nat). econstructor; eauto. Qed. @@ -397,6 +397,30 @@ Section Proof_Rules. intros; apply step_ss'_vis; auto. Qed. + Lemma step_ss'_passive {Z Z'} (e : E Z) (f : F Z') + (k : Z -> ctree E C X) (k' : Z' -> ctree F D Y) : + (forall x, exists y, R L (k x) (k' y) /\ L (rcv e x) (rcv f y)) -> + ss'_gen R Reps L (Passive e k) (Passive f k'). + Proof. + intros HRk. split. + - intros t' l Hl TR. apply trans_passive_inv' in TR as (x & EQ & ->). + destruct (HRk x) as (y & HRxy & Lrcv). + exists (rcv f y), (Active (k' y)). split; [| split]. + + apply estar_l_lift, trans_rcv. + + rewrite EQ. apply HRxy. + + assumption. + - intros t' TR. apply trans_passive_inv' in TR as (? & _ & abs). discriminate. + Qed. + + Lemma step_ss'_passive_id {Z} (e : E Z) (f : F Z) + (k : Z -> ctree E C X) (k' : Z -> ctree F D Y) : + (forall x, R L (k x) (k' x)) -> + (forall x, L (rcv e x) (rcv f x)) -> + ss'_gen R Reps L (Passive e k) (Passive f k'). + Proof. + intros; apply step_ss'_passive; eauto. + Qed. + Lemma step_ss'_vis_l {Z} : forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), (exists l' u', ((trans_alt ε)^* ⋅ trans_alt l') u u' /\ R L (Passive e k) u' /\ L (ask e) l') -> diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v index 394cfe2..f074304 100644 --- a/theories/Eq/TransAlt.v +++ b/theories/Eq/TransAlt.v @@ -2371,6 +2371,21 @@ Proof. split; typeclasses eauto. Qed. +Class ReflexiveL {E X} (L : lrel E E X X) : Prop := + reflL : forall l, l <> ε -> build_rel L l l. + +#[global] Instance flipL_reflexiveL {E X} (L : lrel E E X X) {LR: ReflexiveL L} : ReflexiveL (flipL L). +Proof. + intros l Hne. + apply flipL_flip. + now apply LR. +Qed. + +#[global] Instance Leq_reflexiveL {E X} : ReflexiveL (@Leq E X). +Proof. + intros [] Hne; try easy; constructor; cbn; auto with trans_alt. +Qed. + #[global] Instance build_rel_symmetric {E X L} `{Symmetric X L} : Symmetric (@build_rel E E X X (Lvrel L)). Proof. intros l l' HL. From 0ca3858b38963bec0afeb49d981db5a9dbda688d Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Tue, 29 Sep 2026 20:06:33 -0400 Subject: [PATCH 58/61] Partway through new structure, checkpointing --- theories/Eq/EpsilonAlt.v | 230 +++++++++++++++++++++++++++++++++++++++ theories/Eq/SBisimAlt.v | 57 ++++------ theories/Eq/SSimAlt.v | 11 +- theories/Eq/TransAlt.v | 28 +---- 4 files changed, 252 insertions(+), 74 deletions(-) create mode 100644 theories/Eq/EpsilonAlt.v diff --git a/theories/Eq/EpsilonAlt.v b/theories/Eq/EpsilonAlt.v new file mode 100644 index 0000000..8868ea0 --- /dev/null +++ b/theories/Eq/EpsilonAlt.v @@ -0,0 +1,230 @@ +From Stdlib Require Import Program.Equality. + +From CTree Require Import + CTree + Eq.Equ + Eq.TransAlt. + +From RelationAlgebra Require Export + monoid kat kat_tac rel srel. +From Coinduction Require Import all. + +Import CTree. +Import EquNotations. +Set Implicit Arguments. + +Ltac use_steps n := +lazymatch goal with +|- context [(str _)] => + repeat red; + + repeat match goal with + + (* ^* case *) + | |- exists2 _, _ & _ => eexists; repeat red + (* base case: just ^* *) + | |- exists n : nat, _ => + exists (n : nat); + cbn; try solve [reflexivity] end + end. + +Lemma trans_star_self {E B R} (x : SS) l: (@trans_alt E B R l)^* x x. +Proof. use_steps O. Qed. + +Lemma trans_star_l {E B R} (x y : SS) l1 l2 : +trans_alt l2 x y -> +((@trans_alt E B R l1)^* ⋅ trans_alt l2) x y. +Proof. intros. use_steps O. assumption. Qed. + +Tactic Notation "use" ident(n) "steps" := use_steps n. + +(* l -> *ε ⋅ l *) +Lemma estar_l_lift {X} {C G : Type -> Type} : + forall (t t' : @S G C X) l, + trans_alt l t t' -> + ((trans_alt ε)^* ⋅ trans_alt l) t t'. + Proof. + intros. use_steps O. assumption. + Qed. + +(* ^*ε is transitive. *) +Lemma estar_trans {G B : Type -> Type} {V : Type} (a b c : @S G B V) : + (trans_alt ε)^* a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. +Proof. + intros S1 S2. + assert (H : (@trans_alt G B V ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + apply H; eexists; eassumption. +Qed. + +(* adding an ε preserves ^*ε. *) +Lemma estar_cons_epsilon {G B : Type -> Type} {V : Type} (a b c : @S G B V) : + trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. +Proof. + intros S1 S2. + assert (H : @trans_alt G B V ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. + apply H; eexists; eassumption. +Qed. + +(* lift ε to ^*ε *) +Lemma estar_single {G B : Type -> Type} {V : Type} (a b : @S G B V) : + trans_alt ε a b -> (trans_alt ε)^* a b. +Proof. + enough (H: (@trans_alt G B V ε) ≦ (trans_alt ε)^*); + [apply H | ka]. +Qed. + +(* adding an ε preserves ^ε ⋅ l for any l *) +Lemma estar_cons_label {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : + trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> + ((trans_alt ε)^* ⋅ trans_alt l) a c. +Proof. + enough (H: @trans_alt G B V ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + ≦ (trans_alt ε)^* ⋅ trans_alt l); [|ka]. + intros; apply H; eexists; eauto. +Qed. + +(* adding .^*ε preserves ^ε ⋅ l for any l *) +Lemma estar_app {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : + (trans_alt ε)^* a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> + ((trans_alt ε)^* ⋅ trans_alt l) a c. +Proof. + enough (H : (@trans_alt G B V ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) + ≦ (trans_alt ε)^* ⋅ trans_alt l); [|ka]. + intros; apply H; eexists; eassumption. +Qed. + +(* lift ^*ε through ⩸ *) +Lemma estar_seq {E B X} (a b : @SS E B X) : + a ⩸ b -> (trans_alt ε)^* a b. +Proof. + intros H; exists O; exact H. +Qed. + +Lemma estar_passive {E B X Z} (e : E Z) (g : Z -> ctree E B X) (m : @SS E B X) : + (trans_alt ε)^* (Passive e g) m -> + (Passive e g : @SS E B X) ⩸ m. +Proof. + intros [n STAR]; destruct n. + - cbn in STAR. exact STAR. + - destruct STAR as [mid STEP _]. + (* STEP is absurd; [β] only steps with [rcv] *) + apply trans_passive_inv' in STEP as (z & _ & Habs); easy. +Qed. + +Lemma estar_active {E B X} (t : ctree E B X) (u : @S E B X) : + (trans_alt ε)^* (Active t) u -> exists u0 : ctree E B X, u ⩸ (Active u0). +Proof. + intros [n STAR]; revert t STAR; induction n; intros t STAR. + - cbn in STAR; dependent destruction STAR. eexists; reflexivity. + - destruct STAR as [mid STEP REST]. + unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. + + eapply IHn; exact REST. + + eapply IHn; exact REST. +Qed. + +Import CTreeNotations. +Lemma estar_bind {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) : + (trans_alt ε)^* (Active t) (Active u) -> + (trans_alt ε)^* (Active (x <- t;; k x)) (Active (x <- u;; k x)). +Proof. + intros [n STAR]; revert t STAR; induction n; intros t STAR. + - cbn in STAR; dependent destruction STAR. + apply estar_seq; constructor. + now rewrite EQ. + - destruct STAR as [mid STEP REST]. + unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. + + eapply estar_cons_epsilon. + * apply trans_bind_l_ε; eapply Transbr; eauto. + * apply IHn; exact REST. + + eapply estar_cons_epsilon. + * apply trans_bind_l_ε; eapply Transguard; eauto. + * apply IHn; exact REST. +Qed. + +Lemma estar_vis_inv {G K : Type -> Type} {W Z} (e : G Z) (k : Z -> ctree G K W) (m : @S G K W) : + (trans_alt ε)^* (Active (Vis e k)) m -> + (Active (Vis e k) : @S G K W) ⩸ m. +Proof. + intros [n STAR]; destruct n. + - exact STAR. + - destruct STAR as [mid STEP _]. + apply trans_vis_inv' in STEP as (_ & Habs); easy. +Qed. + +Definition Sbind {E B X Y} (s : @S E B X) (k : X -> ctree E B Y) : @S E B Y := + match s with + | Active t => Active (x <- t;; k x) + | Passive e g => Passive e (fun z => x <- g z;; k x) + end. + +Lemma Sbind_Seq {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : + s ⩸ u -> (Sbind s k) ⩸ (Sbind u k). +Proof. + intros EQ; destruct EQ; cbn; constructor. + - now rewrite EQ. + - intros; now rewrite EQ. +Qed. + +Lemma estar_Sbind {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : + (trans_alt ε)^* s u -> (trans_alt ε)^* (Sbind s k) (Sbind u k). +Proof. + destruct s as [t | Z e g]; intros STAR. + - destruct (estar_active STAR) as [u0 EQ]. + assert (STAR2 : (trans_alt ε)^* (Active t) (Active u0)) + by (eapply estar_trans; [ exact STAR | apply estar_seq, EQ ]). + eapply (estar_trans (b := Sbind (Active u0 : @S E B X) k)). + + cbn. apply estar_bind; exact STAR2. + + apply estar_seq. apply Sbind_Seq. now symmetry. + - apply estar_passive in STAR. now apply estar_seq, Sbind_Seq. +Qed. + +Variant guardR {E B X} : hrel (@S E B X) (@S E B X) := + | Guardstep t t' u : t ≅ Guard t' -> u ≅ t' -> guardR (Active t) (Active u). + +#[global] Instance guardR_Seq {E B X} : + Proper (Seq ==> Seq ==> iff) (@guardR E B X). +Proof. + intros a a' Ea b b' Eb; split; intros H; destruct H; + dependent destruction Ea; dependent destruction Eb; econstructor. + - rewrite <- EQ; eassumption. + - rewrite <- EQ0; eassumption. + - rewrite EQ; eassumption. + - rewrite EQ0; eassumption. +Qed. + +Definition guard_alt {E B X} : srel (@SS E B X) (@SS E B X) := + {| hrel_of := @guardR E B X : hrel (@SS E B X) (@SS E B X) |}. + +Definition epsilon_det' {E B X} : srel (@SS E B X) (@SS E B X) := (@guard_alt E B X)^*. + +Lemma guard_alt_eps {E B X} : @guard_alt E B X ≦ trans_alt ε. +Proof. + intros a b H; destruct H; eapply Transguard; eassumption. +Qed. + +Lemma epsilon_det'_estar {E B X} (a b : @SS E B X) : + epsilon_det' a b -> (trans_alt ε)^* a b. +Proof. + enough (H : (@guard_alt E B X)^* ≦ (trans_alt ε)^*) by apply H. + now rewrite guard_alt_eps. +Qed. + +Lemma epsilon_det'_guard {E B X} (t t' : ctree E B X) : + t ≅ Guard t' -> epsilon_det' (Active t) (Active t'). +Proof. + intros EQ; exists 1%nat, (Active t'); [econstructor; [exact EQ | reflexivity] | reflexivity]. +Qed. + +Lemma epsilon_det'_trans {E B X} (a b c : @SS E B X) : + epsilon_det' a b -> epsilon_det' b c -> epsilon_det' a c. +Proof. + intros S1 S2. + assert (H : (@guard_alt E B X)^* ⋅ (guard_alt)^* ≦ (guard_alt)^*) by ka. + apply H; eexists; eassumption. +Qed. + +Lemma epsilon_det'_seq {E B X} (a b : @SS E B X) : + a ⩸ b -> epsilon_det' a b. +Proof. + intros H; exists O; exact H. +Qed. diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 7148fe8..0a0f4c5 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -16,7 +16,7 @@ From CTree Require Import Utils Eq.Equ Eq.TransAlt - Eq.Epsilon + Eq.EpsilonAlt Eq.EstarTheory Eq.SSimAlt Misc.Pure. @@ -979,16 +979,6 @@ Definition guard_ctx {E B X} (R : @SS E B X -> Prop) (t : @SS E B X) := exists t', t ⩸ (Active (Guard t')) /\ R (Active t'). -Lemma epsilon_det_estar {E B X} (t t' : ctree E B X) : - epsilon_det t t' -> (trans_alt ε)^* (Active t) (Active t'). -Proof. - induction 1. - - apply estar_seq; constructor; exact H. - - eapply estar_cons_epsilon. - + eapply Transguard; [exact H0 | reflexivity]. - + exact IHepsilon_det. -Qed. - Section upto. Context {E F C D: Type -> Type}. @@ -1054,15 +1044,11 @@ Section upto. Program Definition epsilon_det_ctx3_l : mon (sb'R E F C D) := {| body R b X Y L t u := - b = true /\ exists t0 t1, t ⩸ (Active t0) /\ epsilon_det t0 t1 - /\ R b X Y L (Active t1) u |}. + b = true /\ exists t1, epsilon_det' t t1 /\ R b X Y L t1 u |}. Next Obligation. - intros R R' HRR' b X Y L t u (-> & t0 & t1 & EQ & DET & HR). + intros R R' HRR' b X Y L t u (-> & t1 & DET & HR). split; auto. - exists t0, t1; ssplit. - - exact EQ. - - exact DET. - - apply HRR', HR. + exists t1; split; [exact DET | apply HRR', HR]. Qed. Definition pure_bind_ctx {W X0} (P : X0 -> Prop) (R : @S E C W -> Prop) @@ -1098,32 +1084,31 @@ Section upto. forall side X Y L x y, epsilon_det_ctx3_l `r side X Y L x y -> `r side X Y L x y. Proof. apply tower. - - intros ? INC side X Y L x y (-> & t0 & t1 & EQ & DET & HR) ? ?; red. + - intros ? INC side X Y L x y (-> & t1 & DET & HR) ? ?; red. apply INC; auto. split; auto. - exists t0, t1; ssplit. - + exact EQ. + exists t1; split. + exact DET. + apply leq_infx in H. apply H, HR. - clear. - intros R IH side X Y L x y (-> & t0 & t1 & EQ & DET & HR). + intros R IH side X Y L x y (-> & t1 & [n DET] & HR). split; intro; [| easy]. - rewrite EQ; clear x EQ. - revert HR; induction DET as [ta tb EQ01 | ta tb tc DET' IHDET EQg]; intro HR. - + assert (SQ : (Active ta : @S E C X) ⩸ (Active tb)) - by (constructor; exact EQ01). - rewrite SQ. + destruct n as [| n]. + + cbn in DET. rewrite DET. now apply HR. - + assert (SQ : (Active tc : @S E C X) ⩸ (Active (Guard ta))) + + destruct DET as [m STEP REST]. + destruct STEP as [t t' u EQg EQu]. + assert (SQ : (Active t : @S E C X) ⩸ (Active (Guard t'))) by (constructor; exact EQg). rewrite SQ. apply step_ss'_guard_l. apply IH. split; auto. - exists ta, tb; ssplit. - * reflexivity. - * exact DET'. + exists t1; split. + * assert (SQ' : (Active t' : @S E C X) ⩸ (Active u)) + by (constructor; symmetry; exact EQu). + exists n. rewrite SQ'. exact REST. * apply (b_chain R); exact HR. Qed. @@ -1226,19 +1211,17 @@ Section upto. #[global] Instance epsilon_det_st' {X Y} {L : lrel E F X Y} : forall (R : Chain (@sb' E F C D)), - Proper (epsilon_det ==> epsilon_det ==> flip impl) - (fun (t : ctree E C X) (u : ctree F D Y) => ` R true X Y L t u). + Proper (epsilon_det' ==> epsilon_det' ==> flip impl) (` R true X Y L). Proof. intros R t t' DETt u u' DETu H. apply epsilon_det_ctx3_l_sbisim'. split; auto. - exists t, t'; ssplit. - - reflexivity. + exists t'; split. - exact DETt. - apply epsilon_ctx3_r_sbisim'. split; auto. - exists (Active u'); split. - + apply epsilon_det_estar; exact DETu. + exists u'; split. + + apply epsilon_det'_estar; exact DETu. + exact H. Qed. diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 7d66a5d..0fb26d1 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -14,8 +14,7 @@ From CTree Require Import Utils Eq.Equ Eq.TransAlt - Eq.EstarTheory - Eq.Epsilon. + Eq.EstarTheory. From RelationAlgebra Require Export monoid kat kat_tac rel srel. @@ -809,14 +808,6 @@ Section Inversion_Rules. End Inversion_Rules. -Definition epsilon_ctx {E B X} (R : ctree E B X -> Prop) - (t : ctree E B X) := - exists t', epsilon t t' /\ R t'. - -Definition epsilon_det_ctx {E B X} (R : ctree E B X -> Prop) - (t : ctree E B X) := - exists t', epsilon_det t t' /\ R t'. - Section upto. Context {E F C D : Type -> Type}. diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v index f074304..54f6ed5 100644 --- a/theories/Eq/TransAlt.v +++ b/theories/Eq/TransAlt.v @@ -45,7 +45,7 @@ From ITree Require Import Indexed.Sum. From CTree Require Import - CTree Eq.Shallow Eq.Equ Eq.Epsilon. + CTree Eq.Shallow Eq.Equ. From RelationAlgebra Require Import monoid @@ -177,15 +177,6 @@ node, labelling the transition by the returned value. Definition sss {R1 R2} RR := @SeqR E B _ _ (@equ E B R1 R2 RR). -(* epsilon lifted through S *) - - Inductive epsilon_S : TransAlt.S E B R -> TransAlt.S E B R -> Prop := - | epsilon_id_AA t t' : epsilon t t' -> epsilon_S (Active t) (Active t') - | epsilon_id_AP {X} t e k : forall x, epsilon t (k x) -> epsilon_S (Active t) (@Passive E B R X e k) - | epsilon_id_PA {X} t e k : forall x, epsilon (k x) t -> epsilon_S (@Passive E B R X e k) (Active t) - | epsilon_id_PP {X} e k1 k2 : forall x y, epsilon (k1 x) (k2 y) -> epsilon_S (@Passive E B R X e k1) (@Passive E B R X e k2) - . - (* question: equ constraints as before or direct constructors? *) Variant transR : label -> hrel S S := @@ -233,23 +224,6 @@ Definition sss {R1 R2} RR := @SeqR E B _ _ (@equ E B R1 R2 RR). now intros ?? EQ; constructor. Qed. -Ltac epsilon_congr := - repeat match goal with | [HE : epsilon_S (Active _) (Active _) |- _] => inv HE - | [HE : epsilon_S _ (Passive _ _) |- _] => dependent destruction HE - | [HE : epsilon_S (Passive _ _ ) _ |- _] => dependent destruction HE - | [|- epsilon_S _ _] => econstructor - end; - match goal with - H: epsilon ?t1 ?t2 |- epsilon ?t3 ?t4 => - try match goal with [EQ13 : t1 ≅ t3 |- _] => rewrite <- EQ13; eauto end; - try match goal with [EQ31 : t3 ≅ t1 |- _] => rewrite EQ31; eauto end; - try match goal with [EQ24 : t2 ≅ t4 |- _] => rewrite <- EQ24; eauto end; - try match goal with [EQ42 : t4 ≅ t2 |- _] => rewrite EQ42; eauto end; - try match goal with [EQ : forall a, (?k a) ≅ ?g a |- epsilon _ (?g _)] => rewrite <- EQ; eauto end; - try match goal with [EQ : forall a, (?k a) ≅ ?g a |- epsilon _ (?k _)] => rewrite EQ; eauto end - end. - - #[global] Instance transR_equ_ l : Proper (Seq ==> Seq ==> iff) (transR l). Proof. From 0020815190c5f685dab64630e29142f41ef81963 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Wed, 30 Sep 2026 13:04:43 -0400 Subject: [PATCH 59/61] First step of structural refactor to get clean parallel structure between old and alt. --- examples/AltBisim/BisimExample.v | 6 +- theories/Eq.v | 60 ++++- theories/Eq/AltEquiv.v | 319 ------------------------- theories/Eq/CSSim.v | 147 +++++++++++- theories/Eq/Epsilon.v | 140 +---------- theories/Eq/EstarTheory.v | 117 --------- theories/Eq/IterFacts.v | 10 +- theories/Eq/OldAltEquiv/EpsilonEquiv.v | 91 +++++++ theories/Eq/OldAltEquiv/SBisimEquiv.v | 240 +++++++++++++++++++ theories/Eq/OldAltEquiv/SSimEquiv.v | 148 ++++++++++++ theories/Eq/OldAltEquiv/TransEquiv.v | 136 +++++++++++ theories/Eq/SBisim.v | 152 ++---------- theories/Eq/SBisimAlt.v | 251 +------------------ theories/Eq/SSim.v | 125 +++++++++- theories/Eq/SSimAlt.v | 35 +-- theories/Eq/TransAlt.v | 28 +-- 16 files changed, 989 insertions(+), 1016 deletions(-) delete mode 100644 theories/Eq/AltEquiv.v delete mode 100644 theories/Eq/EstarTheory.v create mode 100644 theories/Eq/OldAltEquiv/EpsilonEquiv.v create mode 100644 theories/Eq/OldAltEquiv/SBisimEquiv.v create mode 100644 theories/Eq/OldAltEquiv/SSimEquiv.v create mode 100644 theories/Eq/OldAltEquiv/TransEquiv.v diff --git a/examples/AltBisim/BisimExample.v b/examples/AltBisim/BisimExample.v index d794dbd..40f23a8 100644 --- a/examples/AltBisim/BisimExample.v +++ b/examples/AltBisim/BisimExample.v @@ -1,4 +1,4 @@ -From CTree Require Import CTree Eq Eq.SBisimAlt Eq.IterFacts. +From CTree Require Import CTree Eq Eq.SBisimAlt Eq.OldAltEquiv.TransEquiv Eq.OldAltEquiv.SBisimEquiv Eq.IterFacts. Import CoindNotations. Import CTreeNotations. @@ -20,7 +20,7 @@ Proof. step. cbn. reflexivity. Qed. Theorem bisim_t_u : t ≃ u. Proof. - __coinduction_sbisim R CH. + coinduction R CH. rewrite unfold_t, unfold_u. apply sb_br; intros []. 2: { @@ -40,7 +40,7 @@ Proof. rewrite sbisim_sbisim'. (* The rest of the proof proceeds as before, but this time it succeeds. *) coinduction R CH. intros. - cbn [AltEquiv.o2n_S]. rewrite unfold_t, unfold_u. + cbn [TransEquiv.o2n_S]. rewrite unfold_t, unfold_u. apply step_sb'_br; intros []. (* Notice that unlike step_sb_br, step_sb'_br has unlocked the coinduction hypothesis. *) 2: { diff --git a/theories/Eq.v b/theories/Eq.v index 0b27772..a8f0e33 100644 --- a/theories/Eq.v +++ b/theories/Eq.v @@ -17,6 +17,7 @@ From CTree.Eq Require Export Shallow Equ Trans + Epsilon SBisim SSim CSSim @@ -37,14 +38,53 @@ The [step], [step in] and [coinduction] tactics from [coinduction] with additional unfolding and refolding of [equ] and [sbisim] |*) +From CTree.Eq Require Import + TransAlt + EpsilonAlt + SSimAlt + SBisimAlt. + +Ltac __concl_is t := + assert_succeeds (repeat match goal with |- forall _, _ => intro end; t). + #[global] Tactic Notation "step" := - __step_equ || __step_sbisim || __step_ssim || __step_cssim || step. + first [ __step_equ | __step_sbisim | __step_ssim | __step_cssim + | __step_sbisim' | __step_sb' | __step_ssim' | step + | match goal with |- ?G => + fail 1 "step: the goal is not an equ, sbisim, ssim, cssim, sbisim' or ssim' goal, nor a chain element or gfp of one:" G + end ]. #[global] Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) := - __coinduction_equ R H || __coinduction_sbisim R H || __coinduction_ssim R H || __coinduction_cssim R H || coinduction R H. + first + [ __concl_is ltac:(lazymatch goal with |- equ _ _ _ => idtac end); + first [ __coinduction_equ R H + | fail 2 "coinduction: the conclusion is an equ goal, but coinduction on equ failed" ] + | __concl_is ltac:(lazymatch goal with |- sbisim _ _ _ => idtac end); + first [ __coinduction_sbisim R H + | fail 2 "coinduction: the conclusion is an sbisim goal, but coinduction on sbisim failed" ] + | __concl_is ltac:(lazymatch goal with |- ssim _ _ _ => idtac end); + first [ __coinduction_ssim R H + | fail 2 "coinduction: the conclusion is an ssim goal, but coinduction on ssim failed" ] + | __concl_is ltac:(lazymatch goal with |- cssim _ _ _ => idtac end); + first [ __coinduction_cssim R H + | fail 2 "coinduction: the conclusion is a cssim goal, but coinduction on cssim failed" ] + | __concl_is ltac:(lazymatch goal with |- sbisim' _ _ _ => idtac end); + first [ __coinduction_sbisim' R H + | fail 2 "coinduction: the conclusion is an sbisim' goal, but coinduction on sbisim' failed" ] + | __concl_is ltac:(lazymatch goal with |- ssim' _ _ _ => idtac end); + first [ __coinduction_ssim' R H + | fail 2 "coinduction: the conclusion is an ssim' goal, but coinduction on ssim' failed" ] + | __coinduction_equ R H | __coinduction_sbisim R H | __coinduction_ssim R H | __coinduction_cssim R H + | __coinduction_sbisim' R H | __coinduction_ssim' R H + | coinduction R H + | match goal with |- ?G => + fail 1 "coinduction: the goal is not an equ, sbisim, ssim, cssim, sbisim' or ssim' goal, nor a gfp:" G + end ]. #[global] Tactic Notation "step" "in" ident(H) := - __step_in_equ H || __step_in_sbisim H || __step_in_ssim H || __step_in_cssim H || step_in H. + first [ __step_in_equ H | __step_in_sbisim H | __step_in_ssim H | __step_in_cssim H + | __step_in_sbisim' H | __step_in_sb' H | __step_in_ssim' H | step_in H + | fail "step in: the hypothesis" H "is not an equ, sbisim, ssim, cssim, sbisim' or ssim' fact, nor a chain element or gfp of one" ]. (*| Assuming a goal of the shape [t ~ u], initialize the two challenges @@ -77,6 +117,18 @@ The upto [Vis] context principle for [sbisim] (* - [upto_bind with SS]: for [equ], provides explicitly the intermediate relation *) (* |*) *) +#[global] Tactic Notation "upto_bind" := + first [ __eupto_bind_equ | __eupto_bind_sbisim' + | fail "upto_bind: the goal is not an equ or sbisim' goal (or chain element of one) relating two binds" ]. + +#[global] Tactic Notation "upto_bind_eq" := + first [ __upto_bind_equ_eq | __upto_bind_sbisim'_eq + | fail "upto_bind_eq: the goal is not an equ or sbisim' goal (or chain element of one) relating two binds with the same prefix" ]. + +#[global] Tactic Notation "upto_bind" "with" uconstr(SS) := + first [ __upto_bind_equ SS | __upto_bind_sbisim' SS + | fail "upto_bind with: the goal is not an equ or sbisim' goal (or chain element of one) relating two binds" ]. + (*| Weakens equalities into respectively [equ] and [sbisim] equations --- @@ -92,4 +144,4 @@ Ltac eq2sb H := | ?u = ?t => let eq := fresh "EQ" in assert (eq : u ≃ t) by (rewrite H; reflexivity); clear H end. -#[global] Opaque wtrans. +#[global] Opaque Trans.wtrans. diff --git a/theories/Eq/AltEquiv.v b/theories/Eq/AltEquiv.v deleted file mode 100644 index 82f0453..0000000 --- a/theories/Eq/AltEquiv.v +++ /dev/null @@ -1,319 +0,0 @@ -From Stdlib Require Import Fin Program.Equality. - -From Coinduction Require Import all. - -From ITree Require Import - Core.Subevent - Indexed.Sum. - -From CTree Require Import - CTree Eq.Shallow Eq.Equ Eq.Epsilon. - -From CTree Require Eq.Trans Eq.SSim Eq.EstarTheory. - -From CTree Require Import Eq.TransAlt Eq.SSimAlt. - -From RelationAlgebra Require Import - monoid kat kat_tac prop rel srel comparisons rewriting normalisation. - -Import CTree. -Import CTreeNotations. -Import EquNotations. -Import CoindNotations. -Open Scope ctree. - -Set Implicit Arguments. - -(* label and S conversion *) -(* convention: "o" is old, "n" is new. *) - -Definition o2n_S {E C X} (s : Trans.S E C X) : TransAlt.S E C X := - match s with - | Trans.Active t => TransAlt.Active t - | Trans.Passive e k => TransAlt.Passive e k - end. - -Definition n2o_S {E C X} (s : TransAlt.S E C X) : Trans.S E C X := - match s with - | TransAlt.Active t => Trans.Active t - | TransAlt.Passive e k => Trans.Passive e k - end. - -Definition o2n_label {E X} (l : Trans.label E X) : TransAlt.label E X := - match l with - | Trans.τ => TransAlt.τ - | Trans.ask e => TransAlt.ask e - | Trans.rcv e v => TransAlt.rcv e v - | Trans.val v => TransAlt.val v - end. - -Lemma n2o_o2n_S {E C X} (s : Trans.S E C X) : n2o_S (o2n_S s) = s. -Proof. now destruct s. Qed. - -Lemma o2n_n2o_S {E C X} (s : TransAlt.S E C X) : o2n_S (n2o_S s) = s. -Proof. now destruct s. Qed. - -Lemma transR_o2n {E C X} (l : Trans.label E X) (a a' : Trans.S E C X) : - Trans.transR l a a' -> - ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) (o2n_S a) (o2n_S a'). -Proof. - intros TR; induction TR. - - destruct IHTR as [m STAR STEP]. - exists m; [| apply STEP]. - eapply EstarTheory.estar_cons_epsilon; [ | apply STAR ]. - eapply TransAlt.Transbr; [ apply H | apply H0 ]. - - destruct IHTR as [m STAR STEP]. - exists m; [| apply STEP]. - eapply EstarTheory.estar_cons_epsilon; [ | apply STAR ]. - eapply TransAlt.Transguard; [ apply H | reflexivity ]. - - apply trans_star_l. eapply TransAlt.Transstep; [ apply H | apply H0 ]. - - apply trans_star_l. eapply TransAlt.Transask; apply H. - - apply trans_star_l. eapply TransAlt.Transrcv; apply H. - - apply trans_star_l. eapply TransAlt.Transval; [ apply H | apply H0 ]. -Qed. - -Lemma n2o_S_Seq {E C X} (a b : TransAlt.S E C X) : - TransAlt.Seq a b -> Trans.Seq (n2o_S a) (n2o_S b). -Proof. intros H; inv H; cbn [n2o_S]; constructor; assumption. Qed. - -Lemma trans_alt_eps_inv {E C X} (a mid : TransAlt.S E C X) : - trans_alt ε a mid -> - (exists Z (c : C Z) (k : Z -> ctree E C X) t u x, - a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Br c k /\ u ≅ k x) - \/ (exists t t' u, - a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Guard t' /\ u ≅ t'). -Proof. - intros TR; unfold trans_alt in TR; cbn in TR. - inversion TR; subst. - - left. eauto 12. - - right. eauto 12. -Qed. - -Lemma eps_absorb1 {E C X} (l : Trans.label E X) (a mid c : TransAlt.S E C X) : - trans_alt ε a mid -> - Trans.transR l (n2o_S mid) (n2o_S c) -> - Trans.transR l (n2o_S a) (n2o_S c). -Proof. - intros TR Hold. - apply trans_alt_eps_inv in TR as - [ (Z & cc & k & t & u & x & -> & -> & Hbr & Hu) - | (t & t' & u & -> & -> & Hg & Hu) ]; - cbn [n2o_S] in *. - - assert (S1 : Trans.Seq (Trans.Active t) (Trans.Active (Br cc k))) - by (constructor; apply Hbr). - rewrite S1. - eapply Trans.trans_br with (y := x). - assert (S2 : Trans.Seq (Trans.Active (k x)) (Trans.Active u)) - by (constructor; symmetry; apply Hu). - rewrite S2. apply Hold. - - assert (S1 : Trans.Seq (Trans.Active t) (Trans.Active (Guard t'))) - by (constructor; apply Hg). - rewrite S1. - eapply Trans.trans_guard. - assert (S2 : Trans.Seq (Trans.Active t') (Trans.Active u)) - by (constructor; symmetry; apply Hu). - rewrite S2. apply Hold. -Qed. - -Lemma estar_absorb {E C X} (l : Trans.label E X) (a m : TransAlt.S E C X) : - (trans_alt ε)^* a m -> - forall c, Trans.transR l (n2o_S m) (n2o_S c) -> Trans.transR l (n2o_S a) (n2o_S c). -Proof. - intros [n STAR]. revert a m STAR. - induction n; intros a m STAR c Hold. - - cbn in STAR. apply n2o_S_Seq in STAR. rewrite STAR. apply Hold. - - destruct STAR as [mid STEP REST]. - eapply eps_absorb1; [ apply STEP | ]. - eapply IHn; [ apply REST | apply Hold ]. -Qed. - -Lemma transR_label_base {E C X} (l : Trans.label E X) (m b : TransAlt.S E C X) : - trans_alt (o2n_label l) m b -> Trans.transR l (n2o_S m) (n2o_S b). -Proof. - destruct l; cbn [o2n_label]; intros TR; unfold trans_alt in TR; cbn in TR. - - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transstep; eassumption. - - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transask; eassumption. - - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transrcv; eassumption. - - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transval; eassumption. -Qed. - -Lemma transR_n2o {E C X} (l : Trans.label E X) (a b : TransAlt.S E C X) : - ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) a b -> - Trans.transR l (n2o_S a) (n2o_S b). -Proof. - intros [m STAR STEP]. - eapply estar_absorb; [ apply STAR | ]. - apply transR_label_base; apply STEP. -Qed. - -Definition lift_L {E F X Y} (L : Trans.lrel E F X Y) : TransAlt.lrel E F X Y := - {| TransAlt.RR := Trans.RR L ; - TransAlt.Rask := Trans.Rask L ; - TransAlt.Rrcv := Trans.Rrcv L |}. - -(* old to new through lifting *) -Lemma lift_L_o2n {E F X Y} (L : Trans.lrel E F X Y) - (la : Trans.label E X) (lb : Trans.label F Y) : - Trans.build_rel L la lb -> - TransAlt.build_rel (lift_L L) (o2n_label la) (o2n_label lb). -Proof. - intros H; destruct H; cbn [o2n_label]; now constructor. -Qed. - -Lemma lift_L_o2n_inv {E F X Y} (L : Trans.lrel E F X Y) - (a : TransAlt.label E X) (b : TransAlt.label F Y) : - TransAlt.build_rel (lift_L L) a b -> - exists la lb, a = o2n_label la /\ b = o2n_label lb /\ Trans.build_rel L la lb. -Proof. - intros H; destruct H. - - exists Trans.τ, Trans.τ; cbn [o2n_label]; repeat split; constructor. - - exists (Trans.ask e), (Trans.ask f); cbn [o2n_label]; repeat split; now constructor. - - exists (Trans.rcv e x), (Trans.rcv f y); cbn [o2n_label]; repeat split; now constructor. - - exists (Trans.val x), (Trans.val y); cbn [o2n_label]; repeat split; now constructor. -Qed. - -#[global] Instance lift_L_Leq_reflexiveL {E X} : ReflexiveL (lift_L (@Trans.Leq E X)). -Proof. - intros [] Hne; try easy; constructor; cbn; first [reflexivity | constructor]. -Qed. - -Lemma label_non_eps_image {E X} (l : TransAlt.label E X) : - l <> ε -> exists lo, l = o2n_label lo. -Proof. - destruct l; intro Hne. - - exists Trans.τ; reflexivity. - - easy. - - exists (Trans.ask e); reflexivity. - - exists (Trans.rcv e v); reflexivity. - - exists (Trans.val v); reflexivity. -Qed. - -Lemma o2n_label_inj {E X} (l l' : Trans.label E X) : - o2n_label l = o2n_label l' -> l = l'. -Proof. - destruct l, l'; cbn; intro H; try easy; - dependent destruction H; reflexivity. -Qed. - -Lemma o_ssim_br_step {E F C D X Y} (L : Trans.lrel E F X Y) - Z (c : C Z) (k : Z -> ctree E C X) (t u : ctree E C X) (b : Trans.S F D Y) x : - SSim.ssim L (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> - SSim.ssim L (Trans.Active u) b. -Proof. - intros H Hbr Hu. - unfold SSim.ssim in H |- *. - apply (gfp_pfp (SSim.ss L)) in H. - apply (b_chain (chain_gfp (SSim.ss L))). - intros l t' TR. - apply (H l t'). - eapply Trans.Transbr. - - apply Hbr. - - apply Hu. - - apply TR. -Qed. - -Lemma o_ssim_guard_step {E F C D X Y} (L : Trans.lrel E F X Y) - (t tg u : ctree E C X) (b : Trans.S F D Y) : - SSim.ssim L (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> - SSim.ssim L (Trans.Active u) b. -Proof. - intros H Hg Hu. - unfold SSim.ssim in H |- *. - apply (gfp_pfp (SSim.ss L)) in H. - apply (b_chain (chain_gfp (SSim.ss L))). - intros l t' TR. - apply (H l t'). - assert (Htu : t ≅ Guard u) by (rewrite Hu; apply Hg). - eapply Trans.Transguard; [ apply Htu | apply TR ]. -Qed. - -(* main result *) -Lemma o_ssim_to_ssim' {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - SSim.ssim L a b -> SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b). -Proof. - unfold SSimAlt.ssim'. - coinduction c cih. - intros a b H. - split. - - intros x l Hne TR. - apply label_non_eps_image in Hne as [lo ->]. - step in H. - assert (oTR : Trans.transR lo a (n2o_S x)). - { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } - repeat red in H. - destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). - exists (o2n_label lo'), (o2n_S bo'). - split; [| split]. - + apply transR_o2n. apply TRb. - + specialize (cih (n2o_S x) bo' Hrel). - rewrite o2n_n2o_S in cih. apply cih. - + apply lift_L_o2n; exact HL. - - intros x TR. - exists (o2n_S b). split. - + apply trans_star_self. - + apply trans_alt_eps_inv in TR as - [ (Z & c' & k & t & u & x0 & Ha & Hx & Hbr & Hu) - | (t & tg & u & Ha & Hx & Hg & Hu) ]. - (* t is a branch, *) - * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. - inv Ha. - apply (cih (Trans.Active u) b). - eapply o_ssim_br_step; eauto. - (* t is a guard, one epsilon step and coinduction *) - * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. - inv Ha. - apply (cih (Trans.Active u) b). - eapply o_ssim_guard_step; eauto. -Qed. - -Lemma ssim'_to_o_ssim {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b) -> SSim.ssim L a b. -Proof. - unfold SSim.ssim. - coinduction R cih. - intros a b H. - intros l ao' oTR. - apply transR_o2n in oTR. - destruct oTR as [m STAR STEP]. - eapply SSimAlt.ssim'_epsilon_l in H. 2: apply STAR. - apply (gfp_pfp (@SSimAlt.ss' E F C D) X Y (lift_L L)) in H. - destruct H as (Hchal & _). - destruct (Hchal (o2n_S ao') (o2n_label l)) as (nl' & u' & RESP & Hgfp & HL). - { destruct l; cbn [o2n_label]; easy. } - { apply STEP. } - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hla; subst la. - subst nl'. - exists lb, (n2o_S u'). - split; [| split]. - - rewrite <- (n2o_o2n_S b). apply transR_n2o. apply RESP. - - apply cih. rewrite o2n_n2o_S. apply Hgfp. - - apply HLab. -Qed. - -Theorem ssim_ssim' {E F C D X Y} (L : Trans.lrel E F X Y) - (t : ctree E C X) (t' : ctree F D Y) : - SSim.ssim L (Trans.Active t) (Trans.Active t') <-> - SSimAlt.ssim' (lift_L L) (TransAlt.Active t) (TransAlt.Active t'). -Proof. - split; intro H. - - apply o_ssim_to_ssim' in H. apply H. - - apply ssim'_to_o_ssim. apply H. -Qed. - -Lemma ss'_clo_bind_eq {E B X X'} - (t t' : ctree E B X) (k k' : X -> ctree E B X') : - SSim.ssim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> - (forall x, SSimAlt.ssim' (lift_L (@Trans.Leq E X')) - (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> - SSimAlt.ssim' (lift_L (@Trans.Leq E X')) - (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). -Proof. - intros tt kk. - apply ssim_ssim' in tt. - eapply SSimAlt.ssim'_clo_bind with (SS := @eq X). - - exact tt. - - intros x x' ->; apply kk. -Qed. diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index edf5edc..d480dd3 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -16,7 +16,8 @@ From CTree Require Import Eq.Equ Eq.Shallow Eq.Trans - Eq.SSim. + Eq.SSim + Eq.SBisim. From RelationAlgebra Require Export rel srel. @@ -1194,3 +1195,147 @@ TODO: these principles are mirrored on ssim directly. We should be able to deriv End Proof_Rules. +Import SBisimNotations. + +Section sbisim_cssim. + Context {E F C D : Type -> Type} {X Y : Type} {L : lrel E F X Y}. + + Lemma sbisim_cssim_subrelation_gen : + forall x y, @sbisim E F C D X Y L x y -> cssim L x y. + Proof. + red. + coinduction r cih; intros * SB. + __step_in_sbisim SB; destruct SB as [fwd bwd]. + split. + - intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. + - intros (? & ? & TR). apply bwd in TR as (? & ? & ? & ? & ?); eauto 10. + Qed. + +End sbisim_cssim. + +#[global] Instance sbisim_cssim_subrelation {E C X L} : + subrelation (@sbisim E E C C X X L) (cssim L). +Proof. + red; apply sbisim_cssim_subrelation_gen. +Qed. + +#[local] Tactic Notation "playL" "in" ident(H) := __playL_sbisim H. +#[local] Tactic Notation "playR" "in" ident(H) := __playR_sbisim H. +#[local] Tactic Notation "play" "in" ident(H) := first [playL in H; [] | playR in H; []]. +#[local] Tactic Notation "answer" := __answer_sbisim. + +Section SBisim_vs_CSSim. + + Section withParam. + + Context {E F C D : Type -> Type} {X Y : Type} + {L : lrel E F X Y}. + + Notation css := (@css E F C D X Y). + Notation cssim := (@cssim E F C D X Y). + + Tactic Notation "dec3" ident(h) "as" + simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) + := destruct h as (a & b & c). + + #[global] Instance sbisim_css_chain_goal {c : Chain (css L)} : + Proper (sbisimeq ==> sbisimeq ==> flip impl) `c. + Proof. + apply tower. + - intros ? INC x y EQ x' y' EQ' ?? HP; red. + eapply INC; eauto. + eapply leq_infx in HP. + now apply HP. + - clear. + intros c IH x y EQ x' y' EQ'; split. + + intros ?? TR. + playL in EQ. + play in H. + playR in EQ'. + __answer_sbisim. + eapply IH; eauto. + now simpL. + + intros (? & ? & TR). + playL in EQ'. + destruct H as [_ LIV]. + dec3 LIV as ? ? TR'; eauto. + playR in EQ. + eauto. + Qed. + + #[global] Instance sbisim_css_chain_ctx {c : Chain (css L)} : + Proper (sbisimeq ==> sbisimeq ==> impl) `c. + Proof. + apply tower. + - intros ? INC x y EQ x' y' EQ' ?? HP; red. + eapply INC; eauto. + eapply leq_infx in HP. + now apply HP. + - clear. + intros c IH x y EQ x' y' EQ'; split. + + intros ?? TR. + playR in EQ. + play in H. + playL in EQ'. + __answer_sbisim. + eapply IH; eauto. + now simpL. + + intros (? & ? & TR). + playR in EQ'. + destruct H as [_ LIV]. + dec3 LIV as ? ? TR'; eauto. + playL in EQ. + eauto. + Qed. + + #[global] Instance sbisim_cssim_goal : + Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (cssim L). + Proof. + repeat intro; eapply sbisim_css_chain_goal; eauto. + Qed. + + #[global] Instance sbisim_cssim_ctx : + Proper (sbisim Leq ==> sbisim Leq ==> impl) (cssim L). + Proof. + repeat intro; eapply sbisim_css_chain_ctx; eauto. + Qed. + + Lemma css_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : + css L R t u -> + CSSim.css (flipL L) (flip R) u t -> + sb L R t u. + Proof. + split; cbn; intros. + - apply H in H1 as (? & ? & ? & ? & ?); eauto. + - apply H0 in H1 as (? & ? & ? & ? & ?); eauto. + Qed. + + End withParam. + + (* Bisimilarity entails co-similarity. *) + Lemma sbisim_cssim {E C X} (t u : ctree E C X) : + t ≃ u -> + cssim Leq t u /\ cssim Leq u t. + Proof. + intros SB. + split. + - coinduction r cih. + split. + + intros ?? TR. + __playL_sbisim SB. + __answer_sbisim. + now rewrite EQ. + + intros (? & ? & TR). + __playR_sbisim SB; eauto. + - coinduction r cih. + split. + + intros ?? TR. + __playR_sbisim SB. + simpL. + __answer_sbisim. + now rewrite EQ. + + intros (? & ? & TR). + __playL_sbisim SB; eauto. + Qed. + +End SBisim_vs_CSSim. diff --git a/theories/Eq/Epsilon.v b/theories/Eq/Epsilon.v index 54ddf3e..cd738dc 100644 --- a/theories/Eq/Epsilon.v +++ b/theories/Eq/Epsilon.v @@ -4,13 +4,25 @@ From ITree Require Import Basics.Basics Core.Subevent. +From Stdlib Require Import Basics. + +From RelationAlgebra Require Import + rel srel. + +From Coinduction Require Import all. + From CTree Require Import CTree - Eq. + Eq.Shallow + Eq.Equ + Eq.Trans. Import CTreeNotations. +Import EquNotations. Open Scope ctree_scope. +#[local] Tactic Notation "step" "in" ident(H) := __step_in_equ H. + (* end hide *) (*| @@ -111,14 +123,6 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat - apply IHepsilon_det in H0. apply trans_guard in H0. now rewrite <- H1 in H0. Qed. - Lemma sbisim_epsilon_det {E C X}: - forall (t t' : ctree E C X), epsilon_det t t' -> t ≃ t'. - Proof. - intros. induction H. - - now rewrite H. - - rewrite H0. rewrite sbisim_guard. apply IHepsilon_det. - Qed. - End epsilon_det_theory. Section productive_theory. @@ -436,124 +440,6 @@ Helper inductive: [epsilon t t'] judges that [t'] is reachable from [t] by a pat - rewrite H0. now constructor. Qed. - Lemma ss_epsilon_l {E F C D X Y L R} - (t t0 : ctree E C X) (u : ctree F D Y) : - epsilon t0 t -> - ss L R t0 u -> - ss L R t u. - Proof. - intros. cbn. intros. - eapply epsilon_trans in H1; [| eassumption]. - apply H0 in H1 as (? & ? & ? & ? & ?). eauto 6. - Qed. - - (* Is this one really useful? *) - Lemma ss_epsilon_l' {E F C D X Y L R} - (t : ctree E C X) (u : ctree F D Y) : - (forall t0, epsilon t t0 -> productive t0 -> ss L R t0 u) -> - ss L R t u. - Proof. - intros. cbn. intros. apply trans_epsilon in H0 as (? & ? & ? & ?). - red in H0. - setoid_rewrite (ctree_eta t) in H. genobs t ot. clear t Heqot. - rewrite (ctree_eta x) in H1, H2. genobs x ox. clear x Heqox. - induction H0. - - apply H in H1 as ?. 2: { rewrite H0. now constructor. } - apply H3 in H2. apply H2. - - apply IHepsilon_; auto. intros. apply H; auto. econstructor 2. apply H3. - - apply IHepsilon_; auto. intros. apply H; auto. econstructor 3. apply H3. - Qed. - - Lemma ss_epsilon_r {E F C D X Y L R} - (t : ctree E C X) (u u0 : ctree F D Y) : - epsilon u u0 -> - ss L R t u0 -> - ss L R t u. - Proof. - intros. cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?). - eapply epsilon_trans in H1; eauto. - Qed. - - Lemma ssim_epsilon_l {E F C D X Y L} - (t0 t : ctree E C X) (u : ctree F D Y) : - epsilon t0 t -> - ssim L t0 u -> - ssim L t u. - Proof. - intros. cbn. intros. - step in H0. step. eapply ss_epsilon_l in H0; eauto. - Qed. - - Lemma ssim_epsilon_l' {E F C D X Y L} - (t : ctree E C X) (u : ctree F D Y) : - (forall t0, epsilon t t0 -> productive t0 -> ssim L t0 u) -> - ssim L t u. - Proof. - intros. step. apply ss_epsilon_l'. - intros. apply H in H1. now step in H1. assumption. - Qed. - - Lemma ssim_epsilon_r {E F C D X Y L} - (t : ctree E C X) (u u0 : ctree F D Y) : - epsilon u u0 -> - ssim L t u0 -> - ssim L t u. - Proof. - intros. cbn. intros. - step in H0. step. eapply ss_epsilon_r in H0; eauto. - Qed. - - Notation "l ⊢ x → y" := (hrel_of (trans l) x y) (at level 10, x at next level, y at next level, only printing). - Notation "x" := (α x) (at level 9, only printing). - - Lemma ssim_ret_epsilon {E F C D X Y L} : - forall r (u : ctree F D Y), - (Ret r : ctree E C X) (≲L) u -> - exists r', epsilon u (Ret r') /\ L (val r) (val r'). - Proof. - intros * SIM *. - play in SIM. - invL. - apply trans_val_epsilon in TR. - etrans. - Qed. - - Lemma ssim_vis_epsilon {E F C D X Y Z L} : - forall e (k : Z -> ctree E C X) (u : ctree F D Y), - Vis e k (≲L) u -> - forall x, exists Z' (e' : F Z') k' y, - epsilon u (Vis e' k') /\ - k x (≲L) k' y /\ - L (ask e) (ask e') /\ - L (rcv e x) (rcv e' y). - Proof. - intros * SIM *. - apply ssim_vis_l_inv in SIM as (? & ? & ? & TR & ? & SIM). - apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR). - destruct PROD; subs; inv_trans. - dependent induction EQ. - pose proof ask_invT EQl; subst. - pose proof ask_inv EQl; subst. - destruct (SIM x) as (? & ? & ?). - rewrite EQ in H2. - ex4; split4; eauto; etrans. - Qed. - - Lemma ssim_brS_epsilon {E F C D X Y Z L} : - forall c (k : Z -> ctree E C X) (u : ctree F D Y), - BrS c k (≲L) u -> - forall x, - (exists v, epsilon u (Step v) /\ k x (≲L) v). - Proof. - intros * SIM *. - step in SIM. cbn in SIM. specialize (SIM τ (k x) (trans_brS _ _ _)). - destruct SIM as (l' & u'' & TR & SIM & EQ). - apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR). - destruct PROD; subs; inv_trans; etrans. - invL. - invL. - Qed. - End epsilon_theory. #[global] Hint Resolve epsilon_trans : trans. diff --git a/theories/Eq/EstarTheory.v b/theories/Eq/EstarTheory.v deleted file mode 100644 index 2d1696e..0000000 --- a/theories/Eq/EstarTheory.v +++ /dev/null @@ -1,117 +0,0 @@ -From Stdlib Require Import Program.Equality. - -From CTree Require Import - CTree - Eq.Equ - Eq.TransAlt. - -From RelationAlgebra Require Export - monoid kat kat_tac rel srel. -From Coinduction Require Import all. - -Import CTree. -Import EquNotations. -Set Implicit Arguments. - -(* l -> *ε ⋅ l *) -Lemma estar_l_lift {X} {C G : Type -> Type} : - forall (t t' : @S G C X) l, - trans_alt l t t' -> - ((trans_alt ε)^* ⋅ trans_alt l) t t'. - Proof. - intros. use_steps O. assumption. - Qed. - -(* ^*ε is transitive. *) -Lemma estar_trans {G B : Type -> Type} {V : Type} (a b c : @S G B V) : - (trans_alt ε)^* a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. -Proof. - intros S1 S2. - assert (H : (@trans_alt G B V ε)^* ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. - apply H; eexists; eassumption. -Qed. - -(* adding an ε preserves ^*ε. *) -Lemma estar_cons_epsilon {G B : Type -> Type} {V : Type} (a b c : @S G B V) : - trans_alt ε a b -> (trans_alt ε)^* b c -> (trans_alt ε)^* a c. -Proof. - intros S1 S2. - assert (H : @trans_alt G B V ε ⋅ (trans_alt ε)^* ≦ (trans_alt ε)^*) by ka. - apply H; eexists; eassumption. -Qed. - -(* lift ε to ^*ε *) -Lemma estar_single {G B : Type -> Type} {V : Type} (a b : @S G B V) : - trans_alt ε a b -> (trans_alt ε)^* a b. -Proof. - enough (H: (@trans_alt G B V ε) ≦ (trans_alt ε)^*); - [apply H | ka]. -Qed. - -(* adding an ε preserves ^ε ⋅ l for any l *) -Lemma estar_cons_label {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : - trans_alt ε a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> - ((trans_alt ε)^* ⋅ trans_alt l) a c. -Proof. - enough (H: @trans_alt G B V ε ⋅ ((trans_alt ε)^* ⋅ trans_alt l) - ≦ (trans_alt ε)^* ⋅ trans_alt l); [|ka]. - intros; apply H; eexists; eauto. -Qed. - -(* adding .^*ε preserves ^ε ⋅ l for any l *) -Lemma estar_app {G B : Type -> Type} {V : Type} (a b c : @S G B V) l : - (trans_alt ε)^* a b -> ((trans_alt ε)^* ⋅ trans_alt l) b c -> - ((trans_alt ε)^* ⋅ trans_alt l) a c. -Proof. - enough (H : (@trans_alt G B V ε)^* ⋅ ((trans_alt ε)^* ⋅ trans_alt l) - ≦ (trans_alt ε)^* ⋅ trans_alt l); [|ka]. - intros; apply H; eexists; eassumption. -Qed. - -(* lift ^*ε through ⩸ *) -Lemma estar_seq {E B X} (a b : @SS E B X) : - a ⩸ b -> (trans_alt ε)^* a b. -Proof. - intros H; exists O; exact H. -Qed. - -Lemma estar_passive {E B X Z} (e : E Z) (g : Z -> ctree E B X) (m : @SS E B X) : - (trans_alt ε)^* (Passive e g) m -> - (Passive e g : @SS E B X) ⩸ m. -Proof. - intros [n STAR]; destruct n. - - cbn in STAR. exact STAR. - - destruct STAR as [mid STEP _]. - (* STEP is absurd; [β] only steps with [rcv] *) - apply trans_passive_inv' in STEP as (z & _ & Habs); easy. -Qed. - -Lemma estar_active {E B X} (t : ctree E B X) (u : @S E B X) : - (trans_alt ε)^* (Active t) u -> exists u0 : ctree E B X, u ⩸ (Active u0). -Proof. - intros [n STAR]; revert t STAR; induction n; intros t STAR. - - cbn in STAR; dependent destruction STAR. eexists; reflexivity. - - destruct STAR as [mid STEP REST]. - unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. - + eapply IHn; exact REST. - + eapply IHn; exact REST. -Qed. - -Import CTreeNotations. -Lemma estar_bind {E B X Y} (t u : ctree E B X) (k : X -> ctree E B Y) : - (trans_alt ε)^* (Active t) (Active u) -> - (trans_alt ε)^* (Active (x <- t;; k x)) (Active (x <- u;; k x)). -Proof. - intros [n STAR]; revert t STAR; induction n; intros t STAR. - - cbn in STAR; dependent destruction STAR. - apply estar_seq; constructor. - now rewrite EQ. - - destruct STAR as [mid STEP REST]. - unfold trans_alt in STEP; cbn in STEP; dependent destruction STEP. - + eapply estar_cons_epsilon. - * apply trans_bind_l_ε; eapply Transbr; eauto. - * apply IHn; exact REST. - + eapply estar_cons_epsilon. - * apply trans_bind_l_ε; eapply Transguard; eauto. - * apply IHn; exact REST. -Qed. \ No newline at end of file diff --git a/theories/Eq/IterFacts.v b/theories/Eq/IterFacts.v index 4889daf..7d3e34a 100644 --- a/theories/Eq/IterFacts.v +++ b/theories/Eq/IterFacts.v @@ -11,7 +11,9 @@ From CTree Require Import Utils Eq Eq.SSimAlt - Eq.AltEquiv + Eq.OldAltEquiv.TransEquiv + Eq.OldAltEquiv.SSimEquiv + Eq.OldAltEquiv.SBisimEquiv Eq.SBisimAlt. Import CTree. @@ -41,8 +43,6 @@ Proof. cbn. intros step step' ? t t' EQ. unfold iter_gen. revert t t' EQ. - unfold equ at -1. - (* coinduction library bug: *) coinduction CR CH. intros. subs. upto_bind_eq. red in H. @@ -80,7 +80,7 @@ Proof. + apply step_ssbt'_ret. change (TransAlt.val b) with (@o2n_label E _ (val b)). change (TransAlt.val b0) with (@o2n_label F _ (val b0)). - eapply AltEquiv.lift_L_o2n. + eapply TransEquiv.lift_L_o2n. now apply HRb. Qed. @@ -123,7 +123,7 @@ Proof. + apply step_sbt'_ret. change (TransAlt.val b) with (@o2n_label E _ (val b)). change (TransAlt.val b0) with (@o2n_label F _ (val b0)). - eapply AltEquiv.lift_L_o2n. + eapply TransEquiv.lift_L_o2n. now apply HRb. Qed. diff --git a/theories/Eq/OldAltEquiv/EpsilonEquiv.v b/theories/Eq/OldAltEquiv/EpsilonEquiv.v new file mode 100644 index 0000000..2f3cca9 --- /dev/null +++ b/theories/Eq/OldAltEquiv/EpsilonEquiv.v @@ -0,0 +1,91 @@ +From Stdlib Require Import Fin Program.Equality. + +From Coinduction Require Import all. + +From ITree Require Import + Core.Subevent + Indexed.Sum. + +From CTree Require Import + CTree Eq Eq.Equ. + +From CTree Require Eq.Trans. + +From CTree Require Import Eq.TransAlt Eq.EpsilonAlt Eq.OldAltEquiv.TransEquiv. + +From RelationAlgebra Require Import + monoid kat kat_tac prop rel srel comparisons rewriting normalisation. + +Import CTree. +Import CTreeNotations. +Import EquNotations. +Import CoindNotations. +Open Scope ctree. + +Set Implicit Arguments. + +Lemma transR_o2n {E C X} (l : Trans.label E X) (a a' : Trans.S E C X) : + Trans.transR l a a' -> + ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) (o2n_S a) (o2n_S a'). +Proof. + intros TR; induction TR. + - destruct IHTR as [m STAR STEP]. + exists m; [| apply STEP]. + eapply EpsilonAlt.estar_cons_epsilon; [ | apply STAR ]. + eapply TransAlt.Transbr; [ apply H | apply H0 ]. + - destruct IHTR as [m STAR STEP]. + exists m; [| apply STEP]. + eapply EpsilonAlt.estar_cons_epsilon; [ | apply STAR ]. + eapply TransAlt.Transguard; [ apply H | reflexivity ]. + - apply trans_star_l. eapply TransAlt.Transstep; [ apply H | apply H0 ]. + - apply trans_star_l. eapply TransAlt.Transask; apply H. + - apply trans_star_l. eapply TransAlt.Transrcv; apply H. + - apply trans_star_l. eapply TransAlt.Transval; [ apply H | apply H0 ]. +Qed. + +Lemma eps_absorb1 {E C X} (l : Trans.label E X) (a mid c : TransAlt.S E C X) : + trans_alt ε a mid -> + Trans.transR l (n2o_S mid) (n2o_S c) -> + Trans.transR l (n2o_S a) (n2o_S c). +Proof. + intros TR Hold. + apply trans_alt_eps_inv in TR as + [ (Z & cc & k & t & u & x & -> & -> & Hbr & Hu) + | (t & t' & u & -> & -> & Hg & Hu) ]; + cbn [n2o_S] in *. + - assert (S1 : Trans.Seq (Trans.Active t) (Trans.Active (Br cc k))) + by (constructor; apply Hbr). + rewrite S1. + eapply Trans.trans_br with (y := x). + assert (S2 : Trans.Seq (Trans.Active (k x)) (Trans.Active u)) + by (constructor; symmetry; apply Hu). + rewrite S2. apply Hold. + - assert (S1 : Trans.Seq (Trans.Active t) (Trans.Active (Guard t'))) + by (constructor; apply Hg). + rewrite S1. + eapply Trans.trans_guard. + assert (S2 : Trans.Seq (Trans.Active t') (Trans.Active u)) + by (constructor; symmetry; apply Hu). + rewrite S2. apply Hold. +Qed. + +Lemma estar_absorb {E C X} (l : Trans.label E X) (a m : TransAlt.S E C X) : + (trans_alt ε)^* a m -> + forall c, Trans.transR l (n2o_S m) (n2o_S c) -> Trans.transR l (n2o_S a) (n2o_S c). +Proof. + intros [n STAR]. revert a m STAR. + induction n; intros a m STAR c Hold. + - cbn in STAR. apply n2o_S_Seq in STAR. rewrite STAR. apply Hold. + - destruct STAR as [mid STEP REST]. + eapply eps_absorb1; [ apply STEP | ]. + eapply IHn; [ apply REST | apply Hold ]. +Qed. + +Lemma transR_n2o {E C X} (l : Trans.label E X) (a b : TransAlt.S E C X) : + ((trans_alt ε)^* ⋅ trans_alt (o2n_label l)) a b -> + Trans.transR l (n2o_S a) (n2o_S b). +Proof. + intros [m STAR STEP]. + eapply estar_absorb; [ apply STAR | ]. + apply transR_label_base; apply STEP. +Qed. diff --git a/theories/Eq/OldAltEquiv/SBisimEquiv.v b/theories/Eq/OldAltEquiv/SBisimEquiv.v new file mode 100644 index 0000000..1d400a8 --- /dev/null +++ b/theories/Eq/OldAltEquiv/SBisimEquiv.v @@ -0,0 +1,240 @@ +From Stdlib Require Import Fin Program.Equality. + +From Coinduction Require Import all. + +From ITree Require Import + Core.Subevent + Indexed.Sum. + +From CTree Require Import + CTree Eq Eq.Equ. + +From CTree Require Eq.Trans Eq.SSim Eq.SBisim. + +From CTree Require Import Eq.TransAlt Eq.EpsilonAlt Eq.SSimAlt Eq.SBisimAlt Eq.OldAltEquiv.TransEquiv Eq.OldAltEquiv.EpsilonEquiv Eq.OldAltEquiv.SSimEquiv. + +From RelationAlgebra Require Import + monoid kat kat_tac prop rel srel comparisons rewriting normalisation. + +Import CTree. +Import CTreeNotations. +Import EquNotations. +Import CoindNotations. +Open Scope ctree. + +Set Implicit Arguments. + +(* +Equivalence of old and new bisimilarities +*) +Section sbisim_sbisim'. + +Lemma o_ss_br_step {E F C D X Y} (L : Trans.lrel E F X Y) + (Rel : rel (Trans.S E C X) (Trans.S F D Y)) + Z (c : C Z) (k : Z -> ctree E C X) (t u : ctree E C X) (b : Trans.S F D Y) x : + SSim.ss L Rel (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> + SSim.ss L Rel (Trans.Active u) b. +Proof. + intros H Hbr Hu; cbn in H |- *; intros l t' TR. + apply (H l t'). + eapply Trans.Transbr; [apply Hbr | apply Hu | apply TR]. +Qed. + +Lemma o_ss_guard_step {E F C D X Y} (L : Trans.lrel E F X Y) + (Rel : rel (Trans.S E C X) (Trans.S F D Y)) + (t tg u : ctree E C X) (b : Trans.S F D Y) : + SSim.ss L Rel (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> + SSim.ss L Rel (Trans.Active u) b. +Proof. + intros H Hg Hu; cbn in H |- *; intros l t' TR. + apply (H l t'). + assert (Htu : t ≅ Guard u) by (rewrite Hu; apply Hg). + eapply Trans.Transguard; [apply Htu | apply TR]. +Qed. + +Theorem gfp_sb'_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + (SSim.ss L (SBisim.sbisim L) a b -> + gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b)) /\ + (SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a -> + gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b)). +Proof. + coinduction R CH. intros a b. + split; intro H. + - split; intro; [| easy]. + split. + + intros x l Hne TR. + apply label_non_eps_image in Hne as [lo ->]. + assert (oTR : Trans.transR lo a (n2o_S x)). + { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } + cbn in H. + destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). + exists (o2n_label lo'), (o2n_S bo'); ssplit. + * apply transR_o2n; exact TRb. + * apply (gfp_pfp (@SBisim.sb E F C D X Y L)) in Hrel. + destruct Hrel as [Hf Hb]. + pose proof (CH (n2o_S x) bo') as CHx. + rewrite o2n_n2o_S in CHx. + intro side; destruct side; [apply CHx | apply CHx]; assumption. + * apply lift_L_o2n; exact HL. + + intros x TR. + exists (o2n_S b); split; [apply trans_star_self |]. + apply trans_alt_eps_inv in TR as + [ (Z & c & k & t & u & x0 & Ha & Hx & Hbr & Hu) + | (t & tg & u & Ha & Hx & Hg & Hu) ]. + * subst x; destruct a as [ta | ? e0 k0]; cbn in Ha; [| easy]. + inv Ha; apply (CH (Trans.Active u) b). + eapply o_ss_br_step; eauto. + * subst x; destruct a as [ta | ? e0 k0]; cbn in Ha; [| easy]. + inv Ha; apply (CH (Trans.Active u) b). + eapply o_ss_guard_step; eauto. + - split; intro; [easy |]. + split. + + intros x l Hne TR. + apply label_non_eps_image in Hne as [lo ->]. + assert (oTR : Trans.transR lo b (n2o_S x)). + { rewrite <- (n2o_o2n_S b). apply transR_n2o. apply trans_star_l. apply TR. } + cbn in H. + destruct (H lo (n2o_S x) oTR) as (lo' & ao' & TRa & Hrel & HL). + exists (o2n_label lo'), (o2n_S ao'); ssplit. + * apply transR_o2n; exact TRa. + * unfold flip in Hrel. + apply (gfp_pfp (@SBisim.sb E F C D X Y L)) in Hrel. + destruct Hrel as [Hf Hb]. + pose proof (CH ao' (n2o_S x)) as CHx. + rewrite o2n_n2o_S in CHx. + intro side; destruct side; [apply CHx | apply CHx]; assumption. + * rewrite <- lift_L_flipL. apply lift_L_o2n; exact HL. + + intros x TR. + exists (o2n_S a); split; [apply trans_star_self |]. + apply trans_alt_eps_inv in TR as + [ (Z & c & k & t & u & x0 & Hb & Hx & Hbr & Hu) + | (t & tg & u & Hb & Hx & Hg & Hu) ]. + * subst x; destruct b as [tb | ? e0 k0]; cbn in Hb; [| easy]. + inv Hb; apply (CH a (Trans.Active u)). + eapply o_ss_br_step; eauto. + * subst x; destruct b as [tb | ? e0 k0]; cbn in Hb; [| easy]. + inv Hb; apply (CH a (Trans.Active u)). + eapply o_ss_guard_step; eauto. +Qed. + +Lemma gfp_sb'_true_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + SSim.ss L (SBisim.sbisim L) a b -> + gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b). +Proof. + intros a b; apply (gfp_sb'_ss_sbisim L a b). +Qed. + +Theorem sbisim_sbisim' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + SBisim.sbisim L a b <-> sbisim' (lift_L L) (o2n_S a) (o2n_S b). +Proof. + intros a b; split; intro H. + (* from previous lemmas *) + - intro side. + step in H. + destruct H as [Hf Hb]; destruct side; + apply (gfp_sb'_ss_sbisim L a b); assumption. + (* here we do a manual argument by coinduction. + in each case we can use the sbisim' argument with + a different boolean flag to match the argument we wish to + follow. + *) + - revert a b H. unfold SBisim.sbisim. coinduction R CH. intros a b H. + split. + + intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. + pose proof (HT := H true). + eapply sbisim'_epsilon_l in HT; [| exact STAR]. + step in HT. + destruct HT as [HT _]; specialize (HT eq_refl); destruct HT as [HTA _]. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). + destruct (HTA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hla; subst la; subst l'. + exists lb, (n2o_S u'); ssplit. + (* trick is to lift through n2o_S *) + * rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. + * apply CH. rewrite o2n_n2o_S. exact Hall. + * exact HLab. + + intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. + pose proof (HF := H false). + eapply sbisim'_epsilon_r in HF; [| exact STAR]. + step in HF. + destruct HF as [_ HF]; specialize (HF eq_refl); destruct HF as [HFA _]. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). + destruct (HFA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). + apply flipL_flip in HL. + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hlb; subst. + exists la, (n2o_S t''); ssplit. + * rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. + * unfold flip. apply CH. rewrite o2n_n2o_S. exact Hall. + * apply Trans.flipL_flip; exact HLab. +Qed. + +Corollary sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall side (a : Trans.S E C X) (b : Trans.S F D Y), + SBisim.sbisim L a b -> + gfp (@sb' E F C D) side X Y (lift_L L) (o2n_S a) (o2n_S b). +Proof. + intros. apply sbisim_sbisim' in H. apply H. +Qed. + +Theorem ss_sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + (gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b) -> + SSim.ss L (SBisim.sbisim L) a b) /\ + (gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b) -> + SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a). +Proof. + intros a b; split; intro H. + - intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. + eapply sbisim'_epsilon_l in H; [| exact STAR]. + apply (gfp_pfp (@sb' E F C D)) in H. + destruct H as [H _]; specialize (H eq_refl); destruct H as [HA _]. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). + destruct (HA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hla; subst la; subst l'. + exists lb, (n2o_S u'); ssplit. + + rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. + + apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. + + exact HLab. + - intros lo x oTR. + apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. + eapply sbisim'_epsilon_r in H; [| exact STAR]. + apply (gfp_pfp (@sb' E F C D)) in H. + destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA _]. + assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). + destruct (HA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). + apply flipL_flip in HL. + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hlb; subst lb; subst l'. + exists la, (n2o_S t''); ssplit. + + rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. + + unfold flip. apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. + + apply Trans.flipL_flip; exact HLab. +Qed. + +Lemma sb'_clo_bind_lift_eq {E B X X'} {R : Chain (@sb' E E B B)} side + (t t' : ctree E B X) (k k' : X -> ctree E B X') : + SBisim.sbisim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> + (forall side x, elem R side X' X' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> + elem R side X' X' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). +Proof. + intros tt kk. + eapply bind_chain_gen with (SS := @eq X). + - apply (gfp_chain R). + change (gfp (@sb' E E B B) side X X (lift_L (@Trans.Leq E X)) + (o2n_S (Trans.Active t)) (o2n_S (Trans.Active t'))). + now apply sbisim_gfp_sb'. + - intros ? x ? <-; apply kk. +Qed. + +End sbisim_sbisim'. diff --git a/theories/Eq/OldAltEquiv/SSimEquiv.v b/theories/Eq/OldAltEquiv/SSimEquiv.v new file mode 100644 index 0000000..f4b560c --- /dev/null +++ b/theories/Eq/OldAltEquiv/SSimEquiv.v @@ -0,0 +1,148 @@ +From Stdlib Require Import Fin Program.Equality. + +From Coinduction Require Import all. + +From ITree Require Import + Core.Subevent + Indexed.Sum. + +From CTree Require Import + CTree Eq Eq.Equ. + +From CTree Require Eq.Trans Eq.SSim. + +From CTree Require Import Eq.TransAlt Eq.EpsilonAlt Eq.SSimAlt Eq.OldAltEquiv.TransEquiv Eq.OldAltEquiv.EpsilonEquiv. + +From RelationAlgebra Require Import + monoid kat kat_tac prop rel srel comparisons rewriting normalisation. + +Import CTree. +Import CTreeNotations. +Import EquNotations. +Import CoindNotations. +Open Scope ctree. + +Set Implicit Arguments. + +Lemma o_ssim_br_step {E F C D X Y} (L : Trans.lrel E F X Y) + Z (c : C Z) (k : Z -> ctree E C X) (t u : ctree E C X) (b : Trans.S F D Y) x : + SSim.ssim L (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> + SSim.ssim L (Trans.Active u) b. +Proof. + intros H Hbr Hu. + unfold SSim.ssim in H |- *. + apply (gfp_pfp (SSim.ss L)) in H. + apply (b_chain (chain_gfp (SSim.ss L))). + intros l t' TR. + apply (H l t'). + eapply Trans.Transbr. + - apply Hbr. + - apply Hu. + - apply TR. +Qed. + +Lemma o_ssim_guard_step {E F C D X Y} (L : Trans.lrel E F X Y) + (t tg u : ctree E C X) (b : Trans.S F D Y) : + SSim.ssim L (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> + SSim.ssim L (Trans.Active u) b. +Proof. + intros H Hg Hu. + unfold SSim.ssim in H |- *. + apply (gfp_pfp (SSim.ss L)) in H. + apply (b_chain (chain_gfp (SSim.ss L))). + intros l t' TR. + apply (H l t'). + assert (Htu : t ≅ Guard u) by (rewrite Hu; apply Hg). + eapply Trans.Transguard; [ apply Htu | apply TR ]. +Qed. + +(* main result *) +Lemma o_ssim_to_ssim' {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + SSim.ssim L a b -> SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b). +Proof. + unfold SSimAlt.ssim'. + coinduction c cih. + intros a b H. + split. + - intros x l Hne TR. + apply label_non_eps_image in Hne as [lo ->]. + step in H. + assert (oTR : Trans.transR lo a (n2o_S x)). + { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } + repeat red in H. + destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). + exists (o2n_label lo'), (o2n_S bo'). + split; [| split]. + + apply transR_o2n. apply TRb. + + specialize (cih (n2o_S x) bo' Hrel). + rewrite o2n_n2o_S in cih. apply cih. + + apply lift_L_o2n; exact HL. + - intros x TR. + exists (o2n_S b). split. + + apply trans_star_self. + + apply trans_alt_eps_inv in TR as + [ (Z & c' & k & t & u & x0 & Ha & Hx & Hbr & Hu) + | (t & tg & u & Ha & Hx & Hg & Hu) ]. + (* t is a branch, *) + * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. + inv Ha. + apply (cih (Trans.Active u) b). + eapply o_ssim_br_step; eauto. + (* t is a guard, one epsilon step and coinduction *) + * subst x. destruct a as [ta | YY e0 k0]; cbn in Ha; [| easy]. + inv Ha. + apply (cih (Trans.Active u) b). + eapply o_ssim_guard_step; eauto. +Qed. + +Lemma ssim'_to_o_ssim {E F C D X Y} (L : Trans.lrel E F X Y) : + forall (a : Trans.S E C X) (b : Trans.S F D Y), + SSimAlt.ssim' (lift_L L) (o2n_S a) (o2n_S b) -> SSim.ssim L a b. +Proof. + unfold SSim.ssim. + coinduction R cih. + intros a b H. + intros l ao' oTR. + apply transR_o2n in oTR. + destruct oTR as [m STAR STEP]. + eapply SSimAlt.ssim'_epsilon_l in H. 2: apply STAR. + apply (gfp_pfp (@SSimAlt.ss' E F C D) X Y (lift_L L)) in H. + destruct H as (Hchal & _). + destruct (Hchal (o2n_S ao') (o2n_label l)) as (nl' & u' & RESP & Hgfp & HL). + { destruct l; cbn [o2n_label]; easy. } + { apply STEP. } + apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). + apply o2n_label_inj in Hla; subst la. + subst nl'. + exists lb, (n2o_S u'). + split; [| split]. + - rewrite <- (n2o_o2n_S b). apply transR_n2o. apply RESP. + - apply cih. rewrite o2n_n2o_S. apply Hgfp. + - apply HLab. +Qed. + +Theorem ssim_ssim' {E F C D X Y} (L : Trans.lrel E F X Y) + (t : ctree E C X) (t' : ctree F D Y) : + SSim.ssim L (Trans.Active t) (Trans.Active t') <-> + SSimAlt.ssim' (lift_L L) (TransAlt.Active t) (TransAlt.Active t'). +Proof. + split; intro H. + - apply o_ssim_to_ssim' in H. apply H. + - apply ssim'_to_o_ssim. apply H. +Qed. + +Lemma ss'_clo_bind_eq {E B X X'} + (t t' : ctree E B X) (k k' : X -> ctree E B X') : + SSim.ssim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> + (forall x, SSimAlt.ssim' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> + SSimAlt.ssim' (lift_L (@Trans.Leq E X')) + (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). +Proof. + intros tt kk. + apply ssim_ssim' in tt. + eapply SSimAlt.ssim'_clo_bind with (SS := @eq X). + - exact tt. + - intros x x' ->; apply kk. +Qed. diff --git a/theories/Eq/OldAltEquiv/TransEquiv.v b/theories/Eq/OldAltEquiv/TransEquiv.v new file mode 100644 index 0000000..3744605 --- /dev/null +++ b/theories/Eq/OldAltEquiv/TransEquiv.v @@ -0,0 +1,136 @@ +From Stdlib Require Import Fin Program.Equality. + +From Coinduction Require Import all. + +From ITree Require Import + Core.Subevent + Indexed.Sum. + +From CTree Require Import + CTree Eq Eq.Equ. + +From CTree Require Eq.Trans. + +From CTree Require Import Eq.TransAlt. + +From RelationAlgebra Require Import + monoid kat kat_tac prop rel srel comparisons rewriting normalisation. + +Import CTree. +Import CTreeNotations. +Import EquNotations. +Import CoindNotations. +Open Scope ctree. + +Set Implicit Arguments. + +(* label and S conversion *) +(* convention: "o" is old, "n" is new. *) + +Definition o2n_S {E C X} (s : Trans.S E C X) : TransAlt.S E C X := + match s with + | Trans.Active t => TransAlt.Active t + | Trans.Passive e k => TransAlt.Passive e k + end. + +Definition n2o_S {E C X} (s : TransAlt.S E C X) : Trans.S E C X := + match s with + | TransAlt.Active t => Trans.Active t + | TransAlt.Passive e k => Trans.Passive e k + end. + +Definition o2n_label {E X} (l : Trans.label E X) : TransAlt.label E X := + match l with + | Trans.τ => TransAlt.τ + | Trans.ask e => TransAlt.ask e + | Trans.rcv e v => TransAlt.rcv e v + | Trans.val v => TransAlt.val v + end. + +Lemma n2o_o2n_S {E C X} (s : Trans.S E C X) : n2o_S (o2n_S s) = s. +Proof. now destruct s. Qed. + +Lemma o2n_n2o_S {E C X} (s : TransAlt.S E C X) : o2n_S (n2o_S s) = s. +Proof. now destruct s. Qed. + +Lemma n2o_S_Seq {E C X} (a b : TransAlt.S E C X) : + TransAlt.Seq a b -> Trans.Seq (n2o_S a) (n2o_S b). +Proof. intros H; inv H; cbn [n2o_S]; constructor; assumption. Qed. + +Lemma trans_alt_eps_inv {E C X} (a mid : TransAlt.S E C X) : + trans_alt ε a mid -> + (exists Z (c : C Z) (k : Z -> ctree E C X) t u x, + a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Br c k /\ u ≅ k x) + \/ (exists t t' u, + a = TransAlt.Active t /\ mid = TransAlt.Active u /\ t ≅ Guard t' /\ u ≅ t'). +Proof. + intros TR; unfold trans_alt in TR; cbn in TR. + inversion TR; subst. + - left. eauto 12. + - right. eauto 12. +Qed. + +Lemma transR_label_base {E C X} (l : Trans.label E X) (m b : TransAlt.S E C X) : + trans_alt (o2n_label l) m b -> Trans.transR l (n2o_S m) (n2o_S b). +Proof. + destruct l; cbn [o2n_label]; intros TR; unfold trans_alt in TR; cbn in TR. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transstep; eassumption. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transask; eassumption. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transrcv; eassumption. + - dependent destruction TR; cbn [n2o_S]. eapply Trans.Transval; eassumption. +Qed. + +Definition lift_L {E F X Y} (L : Trans.lrel E F X Y) : TransAlt.lrel E F X Y := + {| TransAlt.RR := Trans.RR L ; + TransAlt.Rask := Trans.Rask L ; + TransAlt.Rrcv := Trans.Rrcv L |}. + +(* old to new through lifting *) +Lemma lift_L_o2n {E F X Y} (L : Trans.lrel E F X Y) + (la : Trans.label E X) (lb : Trans.label F Y) : + Trans.build_rel L la lb -> + TransAlt.build_rel (lift_L L) (o2n_label la) (o2n_label lb). +Proof. + intros H; destruct H; cbn [o2n_label]; now constructor. +Qed. + +Lemma lift_L_o2n_inv {E F X Y} (L : Trans.lrel E F X Y) + (a : TransAlt.label E X) (b : TransAlt.label F Y) : + TransAlt.build_rel (lift_L L) a b -> + exists la lb, a = o2n_label la /\ b = o2n_label lb /\ Trans.build_rel L la lb. +Proof. + intros H; destruct H. + - exists Trans.τ, Trans.τ; cbn [o2n_label]; repeat split; constructor. + - exists (Trans.ask e), (Trans.ask f); cbn [o2n_label]; repeat split; now constructor. + - exists (Trans.rcv e x), (Trans.rcv f y); cbn [o2n_label]; repeat split; now constructor. + - exists (Trans.val x), (Trans.val y); cbn [o2n_label]; repeat split; now constructor. +Qed. + +#[global] Instance lift_L_Leq_reflexiveL {E X} : ReflexiveL (lift_L (@Trans.Leq E X)). +Proof. + intros [] Hne; try easy; constructor; cbn; first [reflexivity | constructor]. +Qed. + +Lemma label_non_eps_image {E X} (l : TransAlt.label E X) : + l <> ε -> exists lo, l = o2n_label lo. +Proof. + destruct l; intro Hne. + - exists Trans.τ; reflexivity. + - easy. + - exists (Trans.ask e); reflexivity. + - exists (Trans.rcv e v); reflexivity. + - exists (Trans.val v); reflexivity. +Qed. + +Lemma o2n_label_inj {E X} (l l' : Trans.label E X) : + o2n_label l = o2n_label l' -> l = l'. +Proof. + destruct l, l'; cbn; intro H; try easy; + dependent destruction H; reflexivity. +Qed. + +Lemma lift_L_flipL {E F X Y} (L : Trans.lrel E F X Y) : + lift_L (Trans.flipL L) = TransAlt.flipL (lift_L L). +Proof. + now destruct L. +Qed. diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim.v index 5eb4c58..eb55a66 100644 --- a/theories/Eq/SBisim.v +++ b/theories/Eq/SBisim.v @@ -46,8 +46,8 @@ From CTree Require Import Eq.Equ Eq.Shallow Eq.Trans - Eq.SSim - Eq.CSSim. + Eq.Epsilon + Eq.SSim. From RelationAlgebra Require Export rel srel. @@ -151,7 +151,7 @@ Tactic Notation "__step_sbisim" := step; fold (@sbisim E F C D X Y L) end. -#[local] Tactic Notation "step" := __step_sbisim || __step_cssim || __step_ssim || step. +#[local] Tactic Notation "step" := __step_sbisim || __step_ssim || step. Ltac __step_in_sbisim H := match type of H with @@ -165,7 +165,7 @@ Ltac __step_in_sbisim H := Tactic Notation "__coinduction_sbisim" simple_intropattern(r) simple_intropattern(cih) := first [unfold sbisim at 4 | unfold sbisim at 3 | unfold sbisim at 2 | unfold sbisim at 1]; coinduction r cih. #[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := - __coinduction_sbisim r cih || __coinduction_cssim r cih || __coinduction_ssim r cih || coinduction r cih. + __coinduction_sbisim r cih || __coinduction_ssim r cih || coinduction r cih. Ltac __play_sbisim := (try step); split; cbn; intros ? ? ?TR. @@ -462,21 +462,13 @@ Section sbisim_heterogenous_theory. (*| Subrelations. |*) - Lemma sbisim_cssim_subrelation_gen : - forall x y, sbisim L x y -> cssim L x y. + Lemma sbisim_ssim_subrelation_gen : + forall x y, sbisim L x y -> ssim L x y. Proof. red. coinduction r cih; intros * SB. - step in SB; destruct SB as [fwd bwd]. - split. - - intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. - - intros (? & ? & TR). apply bwd in TR as (? & ? & ? & ? & ?); eauto 10. - Qed. - - Lemma sbisim_ssim_subrelation_gen : - forall x y, sbisim L x y -> ssim L x y. - Proof. - intros. now apply cssim_ssim_subrelation_gen, sbisim_cssim_subrelation_gen. + step in SB; destruct SB as [fwd _]. + intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. Qed. End sbisim_heterogenous_theory. @@ -492,12 +484,6 @@ Proof. red; intros * EQ; now rewrite EQ. Qed. -#[global] Instance sbisim_cssim_subrelation {E C X L} : - subrelation (@sbisim E E C C X X L) (cssim L). -Proof. - red; apply sbisim_cssim_subrelation_gen. -Qed. - #[global] Instance sbisim_ssim_subrelation {E C X L} : subrelation (@sbisim E E C C X X L) (ssim L). Proof. @@ -1692,118 +1678,10 @@ Section Two_ss_is_not_sb. End Two_ss_is_not_sb. -Section SBisim_vs_CSSim. - - Section withParam. - - Context {E F C D : Type -> Type} {X Y : Type} - {L : lrel E F X Y}. - - Notation css := (@css E F C D X Y). - Notation cssim := (@cssim E F C D X Y). - - Tactic Notation "dec3" ident(h) "as" - simple_intropattern(a) simple_intropattern(b) simple_intropattern(c) - := destruct h as (a & b & c). - - #[global] Instance sbisim_css_chain_goal {c : Chain (css L)} : - Proper (sbisimeq ==> sbisimeq ==> flip impl) `c. - Proof. - apply tower. - - intros ? INC x y EQ x' y' EQ' ?? HP; red. - eapply INC; eauto. - eapply leq_infx in HP. - now apply HP. - - clear. - intros c IH x y EQ x' y' EQ'; split. - + intros ?? TR. - playL in EQ. - play in H. - playR in EQ'. - answer. - eapply IH; eauto. - now simpL. - + intros (? & ? & TR). - playL in EQ'. - destruct H as [_ LIV]. - dec3 LIV as ? ? TR'; eauto. - playR in EQ. - eauto. - Qed. - - #[global] Instance sbisim_css_chain_ctx {c : Chain (css L)} : - Proper (sbisimeq ==> sbisimeq ==> impl) `c. - Proof. - apply tower. - - intros ? INC x y EQ x' y' EQ' ?? HP; red. - eapply INC; eauto. - eapply leq_infx in HP. - now apply HP. - - clear. - intros c IH x y EQ x' y' EQ'; split. - + intros ?? TR. - playR in EQ. - play in H. - playL in EQ'. - answer. - eapply IH; eauto. - now simpL. - + intros (? & ? & TR). - playR in EQ'. - destruct H as [_ LIV]. - dec3 LIV as ? ? TR'; eauto. - playL in EQ. - eauto. - Qed. - - #[global] Instance sbisim_cssim_goal : - Proper (sbisim Leq ==> sbisim Leq ==> flip impl) (cssim L). - Proof. - repeat intro; eapply sbisim_css_chain_goal; eauto. - Qed. - - #[global] Instance sbisim_cssim_ctx : - Proper (sbisim Leq ==> sbisim Leq ==> impl) (cssim L). - Proof. - repeat intro; eapply sbisim_css_chain_ctx; eauto. - Qed. - - Lemma css_sb (R : rel _ _) (t : ctree E C X) (u : ctree F D Y) : - css L R t u -> - CSSim.css (flipL L) (flip R) u t -> - sb L R t u. - Proof. - split; cbn; intros. - - apply H in H1 as (? & ? & ? & ? & ?); eauto. - - apply H0 in H1 as (? & ? & ? & ? & ?); eauto. - Qed. - - End withParam. - - (* Bisimilarity entails co-similarity. *) - Lemma sbisim_cssim {E C X} (t u : ctree E C X) : - t ≃ u -> - cssim Leq t u /\ cssim Leq u t. - Proof. - intros SB. - split. - - coinduction r cih. - split. - + intros ?? TR. - playL in SB. - answer. - now rewrite EQ. - + intros (? & ? & TR). - playR in SB; eauto. - - coinduction r cih. - split. - + intros ?? TR. - playR in SB. - simpL. - answer. - now rewrite EQ. - + intros (? & ? & TR). - playL in SB; eauto. - Qed. - -End SBisim_vs_CSSim. +Lemma sbisim_epsilon_det {E C X}: + forall (t t' : ctree E C X), epsilon_det t t' -> t ≃ t'. +Proof. + intros. induction H. + - now rewrite H. + - rewrite H0. rewrite sbisim_guard. apply IHepsilon_det. +Qed. diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 0a0f4c5..4eeff09 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -17,12 +17,8 @@ From CTree Require Import Eq.Equ Eq.TransAlt Eq.EpsilonAlt - Eq.EstarTheory - Eq.SSimAlt - Misc.Pure. + Eq.SSimAlt. -From CTree Require Eq.Trans Eq.SSim Eq.SBisim. -From CTree Require Import Eq.AltEquiv. From RelationAlgebra Require Export rel srel. @@ -290,9 +286,9 @@ Ltac __step_sb' := first [ apply (b_chain (b := @sb' _ _ _ _) _) | apply (gfp_fp (@sb' _ _ _ _)) ]. -Tactic Notation "step" := __step_sbisim' || __step_sb' || step. +#[local] Tactic Notation "step" := __step_sbisim' || __step_sb' || step. -Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) := +#[local] Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) := __coinduction_sbisim' R H || coinduction R H. Ltac __step_in_sbisim' H := @@ -310,7 +306,7 @@ Ltac __step_in_sbisim' H := Ltac __step_in_sb' H := apply (gfp_pfp (@sb' _ _ _ _)) in H. -Tactic Notation "step" "in" ident(H) := +#[local] Tactic Notation "step" "in" ident(H) := __step_in_sbisim' H || __step_in_sb' H || step in H. Import CTreeNotations. @@ -801,16 +797,6 @@ Section Inversion_Rules. (* Lemmas to exploit sb' and sbisim' hypotheses *) - Lemma estar_vis_inv {G K : Type -> Type} {W Z} (e : G Z) (k : Z -> ctree G K W) (m : @S G K W) : - (trans_alt ε)^* (Active (Vis e k)) m -> - (Active (Vis e k) : @S G K W) ⩸ m. - Proof. - intros [n STAR]; destruct n. - - exact STAR. - - destruct STAR as [mid STEP _]. - apply trans_vis_inv' in STEP as (_ & Habs); easy. - Qed. - Lemma sb'_true_vis_l_inv {Z R} : forall (e : E Z) (k : Z -> ctree E C X) (u : @S F D Y), sb' R true X Y L (Vis e k) u -> @@ -1603,234 +1589,11 @@ Tactic Notation "__upto_bind_sbisim'" uconstr(R0) := __upto_bind_sbisim' R0. Tactic Notation "__upto_bind_sbisim'_eq" := __upto_bind_sbisim'_eq. -#[global] Tactic Notation "upto_bind" := +#[local] Tactic Notation "upto_bind" := __eupto_bind_equ || __eupto_bind_sbisim'. -#[global] Tactic Notation "upto_bind_eq" := +#[local] Tactic Notation "upto_bind_eq" := __upto_bind_equ_eq || __upto_bind_sbisim'_eq. -#[global] Tactic Notation "upto_bind" "with" uconstr(SS) := +#[local] Tactic Notation "upto_bind" "with" uconstr(SS) := __upto_bind_equ SS || __upto_bind_sbisim' SS. - - -(* -Equivalence of old and new bisimilarities -*) -Section sbisim_sbisim'. - -Lemma o_ss_br_step {E F C D X Y} (L : Trans.lrel E F X Y) - (Rel : rel (Trans.S E C X) (Trans.S F D Y)) - Z (c : C Z) (k : Z -> ctree E C X) (t u : ctree E C X) (b : Trans.S F D Y) x : - SSim.ss L Rel (Trans.Active t) b -> t ≅ Br c k -> u ≅ k x -> - SSim.ss L Rel (Trans.Active u) b. -Proof. - intros H Hbr Hu; cbn in H |- *; intros l t' TR. - apply (H l t'). - eapply Trans.Transbr; [apply Hbr | apply Hu | apply TR]. -Qed. - -Lemma o_ss_guard_step {E F C D X Y} (L : Trans.lrel E F X Y) - (Rel : rel (Trans.S E C X) (Trans.S F D Y)) - (t tg u : ctree E C X) (b : Trans.S F D Y) : - SSim.ss L Rel (Trans.Active t) b -> t ≅ Guard tg -> u ≅ tg -> - SSim.ss L Rel (Trans.Active u) b. -Proof. - intros H Hg Hu; cbn in H |- *; intros l t' TR. - apply (H l t'). - assert (Htu : t ≅ Guard u) by (rewrite Hu; apply Hg). - eapply Trans.Transguard; [apply Htu | apply TR]. -Qed. - -Lemma lift_L_flipL {E F X Y} (L : Trans.lrel E F X Y) : - lift_L (Trans.flipL L) = TransAlt.flipL (lift_L L). -Proof. - now destruct L. -Qed. - -(* need to split at [side] so that the simulation game lines up. *) -Theorem gfp_sb'_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - (SSim.ss L (SBisim.sbisim L) a b -> - gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b)) /\ - (SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a -> - gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b)). -Proof. - coinduction R CH. intros a b. - split; intro H. - - split; intro; [| easy]. - split. - + intros x l Hne TR. - apply label_non_eps_image in Hne as [lo ->]. - assert (oTR : Trans.transR lo a (n2o_S x)). - { rewrite <- (n2o_o2n_S a). apply transR_n2o. apply trans_star_l. apply TR. } - cbn in H. - destruct (H lo (n2o_S x) oTR) as (lo' & bo' & TRb & Hrel & HL). - exists (o2n_label lo'), (o2n_S bo'); ssplit. - * apply transR_o2n; exact TRb. - * apply (gfp_pfp (@SBisim.sb E F C D X Y L)) in Hrel. - destruct Hrel as [Hf Hb]. - pose proof (CH (n2o_S x) bo') as CHx. - rewrite o2n_n2o_S in CHx. - intro side; destruct side; [apply CHx | apply CHx]; assumption. - * apply lift_L_o2n; exact HL. - + intros x TR. - exists (o2n_S b); split; [apply trans_star_self |]. - apply trans_alt_eps_inv in TR as - [ (Z & c & k & t & u & x0 & Ha & Hx & Hbr & Hu) - | (t & tg & u & Ha & Hx & Hg & Hu) ]. - * subst x; destruct a as [ta | ? e0 k0]; cbn in Ha; [| easy]. - inv Ha; apply (CH (Trans.Active u) b). - eapply o_ss_br_step; eauto. - * subst x; destruct a as [ta | ? e0 k0]; cbn in Ha; [| easy]. - inv Ha; apply (CH (Trans.Active u) b). - eapply o_ss_guard_step; eauto. - - split; intro; [easy |]. - split. - + intros x l Hne TR. - apply label_non_eps_image in Hne as [lo ->]. - assert (oTR : Trans.transR lo b (n2o_S x)). - { rewrite <- (n2o_o2n_S b). apply transR_n2o. apply trans_star_l. apply TR. } - cbn in H. - destruct (H lo (n2o_S x) oTR) as (lo' & ao' & TRa & Hrel & HL). - exists (o2n_label lo'), (o2n_S ao'); ssplit. - * apply transR_o2n; exact TRa. - * unfold flip in Hrel. - apply (gfp_pfp (@SBisim.sb E F C D X Y L)) in Hrel. - destruct Hrel as [Hf Hb]. - pose proof (CH ao' (n2o_S x)) as CHx. - rewrite o2n_n2o_S in CHx. - intro side; destruct side; [apply CHx | apply CHx]; assumption. - * rewrite <- lift_L_flipL. apply lift_L_o2n; exact HL. - + intros x TR. - exists (o2n_S a); split; [apply trans_star_self |]. - apply trans_alt_eps_inv in TR as - [ (Z & c & k & t & u & x0 & Hb & Hx & Hbr & Hu) - | (t & tg & u & Hb & Hx & Hg & Hu) ]. - * subst x; destruct b as [tb | ? e0 k0]; cbn in Hb; [| easy]. - inv Hb; apply (CH a (Trans.Active u)). - eapply o_ss_br_step; eauto. - * subst x; destruct b as [tb | ? e0 k0]; cbn in Hb; [| easy]. - inv Hb; apply (CH a (Trans.Active u)). - eapply o_ss_guard_step; eauto. -Qed. - -Lemma gfp_sb'_true_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - SSim.ss L (SBisim.sbisim L) a b -> - gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b). -Proof. - intros a b; apply (gfp_sb'_ss_sbisim L a b). -Qed. - -Theorem sbisim_sbisim' {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - SBisim.sbisim L a b <-> sbisim' (lift_L L) (o2n_S a) (o2n_S b). -Proof. - intros a b; split; intro H. - (* from previous lemmas *) - - intro side. - step in H. - destruct H as [Hf Hb]; destruct side; - apply (gfp_sb'_ss_sbisim L a b); assumption. - (* here we do a manual argument by coinduction. - in each case we can use the sbisim' argument with - a different boolean flag to match the argument we wish to - follow. - *) - - revert a b H. unfold SBisim.sbisim. coinduction R CH. intros a b H. - split. - + intros lo x oTR. - apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. - pose proof (HT := H true). - eapply sbisim'_epsilon_l in HT; [| exact STAR]. - step in HT. - destruct HT as [HT _]; specialize (HT eq_refl); destruct HT as [HTA _]. - assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). - destruct (HTA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hla; subst la; subst l'. - exists lb, (n2o_S u'); ssplit. - (* trick is to lift through n2o_S *) - * rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. - * apply CH. rewrite o2n_n2o_S. exact Hall. - * exact HLab. - + intros lo x oTR. - apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. - pose proof (HF := H false). - eapply sbisim'_epsilon_r in HF; [| exact STAR]. - step in HF. - destruct HF as [_ HF]; specialize (HF eq_refl); destruct HF as [HFA _]. - assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). - destruct (HFA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). - apply flipL_flip in HL. - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hlb; subst. - exists la, (n2o_S t''); ssplit. - * rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. - * unfold flip. apply CH. rewrite o2n_n2o_S. exact Hall. - * apply Trans.flipL_flip; exact HLab. -Qed. - -Corollary sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : - forall side (a : Trans.S E C X) (b : Trans.S F D Y), - SBisim.sbisim L a b -> - gfp (@sb' E F C D) side X Y (lift_L L) (o2n_S a) (o2n_S b). -Proof. - intros. apply sbisim_sbisim' in H. apply H. -Qed. - -Theorem ss_sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - (gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b) -> - SSim.ss L (SBisim.sbisim L) a b) /\ - (gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b) -> - SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a). -Proof. - intros a b; split; intro H. - - intros lo x oTR. - apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. - eapply sbisim'_epsilon_l in H; [| exact STAR]. - apply (gfp_pfp (@sb' E F C D)) in H. - destruct H as [H _]; specialize (H eq_refl); destruct H as [HA _]. - assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). - destruct (HA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hla; subst la; subst l'. - exists lb, (n2o_S u'); ssplit. - + rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. - + apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. - + exact HLab. - - intros lo x oTR. - apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. - eapply sbisim'_epsilon_r in H; [| exact STAR]. - apply (gfp_pfp (@sb' E F C D)) in H. - destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA _]. - assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). - destruct (HA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). - apply flipL_flip in HL. - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hlb; subst lb; subst l'. - exists la, (n2o_S t''); ssplit. - + rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. - + unfold flip. apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. - + apply Trans.flipL_flip; exact HLab. -Qed. - -Lemma sb'_clo_bind_lift_eq {E B X X'} {R : Chain (@sb' E E B B)} side - (t t' : ctree E B X) (k k' : X -> ctree E B X') : - SBisim.sbisim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> - (forall side x, elem R side X' X' (lift_L (@Trans.Leq E X')) - (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> - elem R side X' X' (lift_L (@Trans.Leq E X')) - (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). -Proof. - intros tt kk. - eapply bind_chain_gen with (SS := @eq X). - - apply (gfp_chain R). - change (gfp (@sb' E E B B) side X X (lift_L (@Trans.Leq E X)) - (o2n_S (Trans.Active t)) (o2n_S (Trans.Active t'))). - now apply sbisim_gfp_sb'. - - intros ? x ? <-; apply kk. -Qed. - -End sbisim_sbisim'. \ No newline at end of file diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index cc049b1..af412e2 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -15,7 +15,8 @@ From CTree Require Import Utils Eq.Equ Eq.Shallow - Eq.Trans. + Eq.Trans + Eq.Epsilon. From RelationAlgebra Require Export rel srel. @@ -1114,3 +1115,125 @@ Question: are the principles useful over [ss] as well? Qed. End Proof_Rules. + +Section ssim_epsilon. + + Lemma ss_epsilon_l {E F C D X Y L R} + (t t0 : ctree E C X) (u : ctree F D Y) : + epsilon t0 t -> + ss L R t0 u -> + ss L R t u. + Proof. + intros. cbn. intros. + eapply epsilon_trans in H1; [| eassumption]. + apply H0 in H1 as (? & ? & ? & ? & ?). eauto 6. + Qed. + + (* Is this one really useful? *) + Lemma ss_epsilon_l' {E F C D X Y L R} + (t : ctree E C X) (u : ctree F D Y) : + (forall t0, epsilon t t0 -> productive t0 -> ss L R t0 u) -> + ss L R t u. + Proof. + intros. cbn. intros. apply trans_epsilon in H0 as (? & ? & ? & ?). + red in H0. + setoid_rewrite (ctree_eta t) in H. genobs t ot. clear t Heqot. + rewrite (ctree_eta x) in H1, H2. genobs x ox. clear x Heqox. + induction H0. + - apply H in H1 as ?. 2: { rewrite H0. now constructor. } + apply H3 in H2. apply H2. + - apply IHepsilon_; auto. intros. apply H; auto. econstructor 2. apply H3. + - apply IHepsilon_; auto. intros. apply H; auto. econstructor 3. apply H3. + Qed. + + Lemma ss_epsilon_r {E F C D X Y L R} + (t : ctree E C X) (u u0 : ctree F D Y) : + epsilon u u0 -> + ss L R t u0 -> + ss L R t u. + Proof. + intros. cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?). + eapply epsilon_trans in H1; eauto. + Qed. + + Lemma ssim_epsilon_l {E F C D X Y L} + (t0 t : ctree E C X) (u : ctree F D Y) : + epsilon t0 t -> + ssim L t0 u -> + ssim L t u. + Proof. + intros. cbn. intros. + step in H0. step. eapply ss_epsilon_l in H0; eauto. + Qed. + + Lemma ssim_epsilon_l' {E F C D X Y L} + (t : ctree E C X) (u : ctree F D Y) : + (forall t0, epsilon t t0 -> productive t0 -> ssim L t0 u) -> + ssim L t u. + Proof. + intros. step. apply ss_epsilon_l'. + intros. apply H in H1. now step in H1. assumption. + Qed. + + Lemma ssim_epsilon_r {E F C D X Y L} + (t : ctree E C X) (u u0 : ctree F D Y) : + epsilon u u0 -> + ssim L t u0 -> + ssim L t u. + Proof. + intros. cbn. intros. + step in H0. step. eapply ss_epsilon_r in H0; eauto. + Qed. + + Notation "l ⊢ x → y" := (hrel_of (trans l) x y) (at level 10, x at next level, y at next level, only printing). + Notation "x" := (α x) (at level 9, only printing). + + Lemma ssim_ret_epsilon {E F C D X Y L} : + forall r (u : ctree F D Y), + (Ret r : ctree E C X) (≲L) u -> + exists r', epsilon u (Ret r') /\ L (val r) (val r'). + Proof. + intros * SIM *. + play in SIM. + invL. + apply trans_val_epsilon in TR. + etrans. + Qed. + + Lemma ssim_vis_epsilon {E F C D X Y Z L} : + forall e (k : Z -> ctree E C X) (u : ctree F D Y), + Vis e k (≲L) u -> + forall x, exists Z' (e' : F Z') k' y, + epsilon u (Vis e' k') /\ + k x (≲L) k' y /\ + L (ask e) (ask e') /\ + L (rcv e x) (rcv e' y). + Proof. + intros * SIM *. + apply ssim_vis_l_inv in SIM as (? & ? & ? & TR & ? & SIM). + apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR). + destruct PROD; subs; inv_trans. + dependent induction EQ. + pose proof ask_invT EQl; subst. + pose proof ask_inv EQl; subst. + destruct (SIM x) as (? & ? & ?). + rewrite EQ in H2. + ex4; split4; eauto; etrans. + Qed. + + Lemma ssim_brS_epsilon {E F C D X Y Z L} : + forall c (k : Z -> ctree E C X) (u : ctree F D Y), + BrS c k (≲L) u -> + forall x, + (exists v, epsilon u (Step v) /\ k x (≲L) v). + Proof. + intros * SIM *. + step in SIM. cbn in SIM. specialize (SIM τ (k x) (trans_brS _ _ _)). + destruct SIM as (l' & u'' & TR & SIM & EQ). + apply trans_epsilon in TR. destruct TR as (u' & EPS & PROD & TR). + destruct PROD; subs; inv_trans; etrans. + invL. + invL. + Qed. + +End ssim_epsilon. diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 0fb26d1..6b77653 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -14,7 +14,7 @@ From CTree Require Import Utils Eq.Equ Eq.TransAlt - Eq.EstarTheory. + Eq.EpsilonAlt. From RelationAlgebra Require Export monoid kat kat_tac rel srel. @@ -227,7 +227,7 @@ Tactic Notation "__step_ssim'" := fold (@ssim' E F C D X Y L) end. -Tactic Notation "step" := __step_ssim' || step. +#[local] Tactic Notation "step" := __step_ssim' || step. Ltac __step_in_ssim' H := match type of H with @@ -236,11 +236,11 @@ Ltac __step_in_ssim' H := apply (gfp_pfp (@ss' E F C D)); fold (@ssim' E F C D X Y L) in H end. -Tactic Notation "step" "in" ident(H) := __step_in_ssim' H || step in H. +#[local] Tactic Notation "step" "in" ident(H) := __step_in_ssim' H || step in H. Tactic Notation "__coinduction_ssim'" simple_intropattern(r) simple_intropattern(cih) := first [unfold ssim' at 4 | unfold ssim' at 3 | unfold ssim' at 2 | unfold ssim' at 1]; coinduction r cih. -Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_ssim' r cih || coinduction r cih. +#[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_ssim' r cih || coinduction r cih. Import CTreeNotations. Import EquNotations. @@ -861,35 +861,8 @@ Qed. Section Sbind. -Definition Sbind {E B X Y} (s : @S E B X) (k : X -> ctree E B Y) : @S E B Y := - match s with - | Active t => Active (x <- t;; k x) - | Passive e g => Passive e (fun z => x <- g z;; k x) - end. - (* theory of Sbind, from which we derive bind *) -Lemma Sbind_Seq {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : - s ⩸ u -> (Sbind s k) ⩸ (Sbind u k). -Proof. - intros EQ; destruct EQ; cbn; constructor. - - now rewrite EQ. - - intros; now rewrite EQ. -Qed. - -Lemma estar_Sbind {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : - (trans_alt ε)^* s u -> (trans_alt ε)^* (Sbind s k) (Sbind u k). -Proof. - destruct s as [t | Z e g]; intros STAR. - - destruct (estar_active STAR) as [u0 EQ]. - assert (STAR2 : (trans_alt ε)^* (Active t) (Active u0)) - by (eapply estar_trans; [ exact STAR | apply estar_seq, EQ ]). - eapply (estar_trans (b := Sbind (Active u0 : @S E B X) k)). - + cbn. apply estar_bind; exact STAR2. - + apply estar_seq. apply Sbind_Seq. now symmetry. - - apply estar_passive in STAR. now apply estar_seq, Sbind_Seq. -Qed. - Lemma trans_Sbind_τ {E B X Y} (s u : @S E B X) (k : X -> ctree E B Y) : trans_alt τ s u -> trans_alt τ (Sbind s k) (Sbind u k). Proof. diff --git a/theories/Eq/TransAlt.v b/theories/Eq/TransAlt.v index 54f6ed5..addc72c 100644 --- a/theories/Eq/TransAlt.v +++ b/theories/Eq/TransAlt.v @@ -45,7 +45,7 @@ From ITree Require Import Indexed.Sum. From CTree Require Import - CTree Eq.Shallow Eq.Equ. + CTree Eq.Equ. From RelationAlgebra Require Import monoid @@ -2638,30 +2638,4 @@ Ltac inv_label_eq EQl := Ltac inv_trans := repeat (inv_trans_one). *) -Ltac use_steps n := -lazymatch goal with -|- context [(str _)] => - repeat red; - - repeat match goal with - - (* ^* case *) - | |- exists2 _, _ & _ => eexists; repeat red - (* base case: just ^* *) - | |- exists n : nat, _ => - exists (n : nat); - cbn; try solve [reflexivity] end - end. - - (* break iter *) - (* Unset Printing Notations. *) -Lemma trans_star_self {E B R} (x : SS) l: (@trans_alt E B R l)^* x x. -Proof. use_steps O. Qed. - -Lemma trans_star_l {E B R} (x y : SS) l1 l2 : -trans_alt l2 x y -> -((@trans_alt E B R l1)^* ⋅ trans_alt l2) x y. -Proof. intros. use_steps O. assumption. Qed. - -Tactic Notation "use" ident(n) "steps" := use_steps n. \ No newline at end of file From b1b815b0b4810630b79334ca9625a35a32b6f544 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 1 Oct 2026 01:42:55 -0400 Subject: [PATCH 60/61] Move-arounds before larger definitional fixes. --- theories/Eq.v | 2 - theories/Eq/CSSim.v | 1 - theories/Eq/OldAltEquiv/EpsilonEquiv.v | 2 +- theories/Eq/OldAltEquiv/SBisimEquiv.v | 47 +- theories/Eq/OldAltEquiv/SSimEquiv.v | 14 - theories/Eq/OldAltEquiv/TransEquiv.v | 2 +- theories/Eq/SBisim.v | 1 - theories/Eq/SBisim_old.v | 1833 ------------------------ theories/Eq/SSim.v | 1 - theories/Eq/Trans.v | 2 +- theories/Interp/FoldCTree.v | 8 +- 11 files changed, 8 insertions(+), 1905 deletions(-) delete mode 100644 theories/Eq/SBisim_old.v diff --git a/theories/Eq.v b/theories/Eq.v index a8f0e33..fd2a535 100644 --- a/theories/Eq.v +++ b/theories/Eq.v @@ -39,8 +39,6 @@ The [step], [step in] and [coinduction] tactics from [coinduction] |*) From CTree.Eq Require Import - TransAlt - EpsilonAlt SSimAlt SBisimAlt. diff --git a/theories/Eq/CSSim.v b/theories/Eq/CSSim.v index d480dd3..2b72576 100644 --- a/theories/Eq/CSSim.v +++ b/theories/Eq/CSSim.v @@ -14,7 +14,6 @@ From CTree Require Import CTree Utils Eq.Equ - Eq.Shallow Eq.Trans Eq.SSim Eq.SBisim. diff --git a/theories/Eq/OldAltEquiv/EpsilonEquiv.v b/theories/Eq/OldAltEquiv/EpsilonEquiv.v index 2f3cca9..9122139 100644 --- a/theories/Eq/OldAltEquiv/EpsilonEquiv.v +++ b/theories/Eq/OldAltEquiv/EpsilonEquiv.v @@ -7,7 +7,7 @@ From ITree Require Import Indexed.Sum. From CTree Require Import - CTree Eq Eq.Equ. + CTree Eq.Equ. From CTree Require Eq.Trans. diff --git a/theories/Eq/OldAltEquiv/SBisimEquiv.v b/theories/Eq/OldAltEquiv/SBisimEquiv.v index 1d400a8..0a22fa0 100644 --- a/theories/Eq/OldAltEquiv/SBisimEquiv.v +++ b/theories/Eq/OldAltEquiv/SBisimEquiv.v @@ -11,7 +11,7 @@ From CTree Require Import From CTree Require Eq.Trans Eq.SSim Eq.SBisim. -From CTree Require Import Eq.TransAlt Eq.EpsilonAlt Eq.SSimAlt Eq.SBisimAlt Eq.OldAltEquiv.TransEquiv Eq.OldAltEquiv.EpsilonEquiv Eq.OldAltEquiv.SSimEquiv. +From CTree Require Import Eq.TransAlt Eq.EpsilonAlt Eq.SSimAlt Eq.SBisimAlt Eq.OldAltEquiv.TransEquiv Eq.OldAltEquiv.EpsilonEquiv. From RelationAlgebra Require Import monoid kat kat_tac prop rel srel comparisons rewriting normalisation. @@ -118,14 +118,6 @@ Proof. eapply o_ss_guard_step; eauto. Qed. -Lemma gfp_sb'_true_ss_sbisim {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - SSim.ss L (SBisim.sbisim L) a b -> - gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b). -Proof. - intros a b; apply (gfp_sb'_ss_sbisim L a b). -Qed. - Theorem sbisim_sbisim' {E F C D X Y} (L : Trans.lrel E F X Y) : forall (a : Trans.S E C X) (b : Trans.S F D Y), SBisim.sbisim L a b <-> sbisim' (lift_L L) (o2n_S a) (o2n_S b). @@ -183,43 +175,6 @@ Proof. intros. apply sbisim_sbisim' in H. apply H. Qed. -Theorem ss_sbisim_gfp_sb' {E F C D X Y} (L : Trans.lrel E F X Y) : - forall (a : Trans.S E C X) (b : Trans.S F D Y), - (gfp (@sb' E F C D) true X Y (lift_L L) (o2n_S a) (o2n_S b) -> - SSim.ss L (SBisim.sbisim L) a b) /\ - (gfp (@sb' E F C D) false X Y (lift_L L) (o2n_S a) (o2n_S b) -> - SSim.ss (Trans.flipL L) (flip (SBisim.sbisim L)) b a). -Proof. - intros a b; split; intro H. - - intros lo x oTR. - apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. - eapply sbisim'_epsilon_l in H; [| exact STAR]. - apply (gfp_pfp (@sb' E F C D)) in H. - destruct H as [H _]; specialize (H eq_refl); destruct H as [HA _]. - assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). - destruct (HA _ _ Hne STEP) as (l' & u' & RESP & Hall & HL). - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hla; subst la; subst l'. - exists lb, (n2o_S u'); ssplit. - + rewrite <- (n2o_o2n_S b). apply transR_n2o; exact RESP. - + apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. - + exact HLab. - - intros lo x oTR. - apply transR_o2n in oTR; destruct oTR as [m STAR STEP]. - eapply sbisim'_epsilon_r in H; [| exact STAR]. - apply (gfp_pfp (@sb' E F C D)) in H. - destruct H as [_ H]; specialize (H eq_refl); destruct H as [HA _]. - assert (Hne : o2n_label lo <> ε) by (destruct lo; cbn [o2n_label]; easy). - destruct (HA _ _ Hne STEP) as (l' & t'' & RESP & Hall & HL). - apply flipL_flip in HL. - apply lift_L_o2n_inv in HL as (la & lb & Hla & Hlb & HLab). - apply o2n_label_inj in Hlb; subst lb; subst l'. - exists la, (n2o_S t''); ssplit. - + rewrite <- (n2o_o2n_S a). apply transR_n2o; exact RESP. - + unfold flip. apply sbisim_sbisim'. rewrite o2n_n2o_S. exact Hall. - + apply Trans.flipL_flip; exact HLab. -Qed. - Lemma sb'_clo_bind_lift_eq {E B X X'} {R : Chain (@sb' E E B B)} side (t t' : ctree E B X) (k k' : X -> ctree E B X') : SBisim.sbisim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> diff --git a/theories/Eq/OldAltEquiv/SSimEquiv.v b/theories/Eq/OldAltEquiv/SSimEquiv.v index f4b560c..137914b 100644 --- a/theories/Eq/OldAltEquiv/SSimEquiv.v +++ b/theories/Eq/OldAltEquiv/SSimEquiv.v @@ -132,17 +132,3 @@ Proof. - apply ssim'_to_o_ssim. apply H. Qed. -Lemma ss'_clo_bind_eq {E B X X'} - (t t' : ctree E B X) (k k' : X -> ctree E B X') : - SSim.ssim (@Trans.Leq E X) (Trans.Active t) (Trans.Active t') -> - (forall x, SSimAlt.ssim' (lift_L (@Trans.Leq E X')) - (TransAlt.Active (k x)) (TransAlt.Active (k' x))) -> - SSimAlt.ssim' (lift_L (@Trans.Leq E X')) - (TransAlt.Active (x <- t;; k x)) (TransAlt.Active (x <- t';; k' x)). -Proof. - intros tt kk. - apply ssim_ssim' in tt. - eapply SSimAlt.ssim'_clo_bind with (SS := @eq X). - - exact tt. - - intros x x' ->; apply kk. -Qed. diff --git a/theories/Eq/OldAltEquiv/TransEquiv.v b/theories/Eq/OldAltEquiv/TransEquiv.v index 3744605..f81f941 100644 --- a/theories/Eq/OldAltEquiv/TransEquiv.v +++ b/theories/Eq/OldAltEquiv/TransEquiv.v @@ -7,7 +7,7 @@ From ITree Require Import Indexed.Sum. From CTree Require Import - CTree Eq Eq.Equ. + CTree Eq.Equ. From CTree Require Eq.Trans. diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim.v index eb55a66..5e46af5 100644 --- a/theories/Eq/SBisim.v +++ b/theories/Eq/SBisim.v @@ -44,7 +44,6 @@ From CTree Require Import CTree Utils Eq.Equ - Eq.Shallow Eq.Trans Eq.Epsilon Eq.SSim. diff --git a/theories/Eq/SBisim_old.v b/theories/Eq/SBisim_old.v deleted file mode 100644 index c10f539..0000000 --- a/theories/Eq/SBisim_old.v +++ /dev/null @@ -1,1833 +0,0 @@ -(*| -========================================= -Strong and Weak Bisimulations over ctrees -========================================= -The [equ] relation provides [ctree]s with a suitable notion of equality. -It is however much too fine to properly capture any notion of behavioral -equivalence that we could want to capture over computations modelled as -[ctree]s. -If we draw a parallel with [itree]s, [equ] maps directly to [eq_itree], -while [eutt] was introduced to characterize computations that exhibit the -same external observations, but may disagree finitely on the amount of -internal steps occuring between any two observations. -While the only consideration over [itree]s was to be insensitive to the -amount of fuel needed to run, things are richer over [ctree]s. -We essentially want to capture three intuitive things: -- to be insensitive to the particular branches chosen at non-deterministic -nodes -- in particular, we want [br t u ~~ br u t]; -- to always be insensitive to how many _invisible_ br nodes are crawled -through -- they really are a generalization of [Tau] in [itree]s; -- to have the flexibility to be sensible or not to the amount of _visible_ -br nodes encountered -- they really are a generalization of CCS's tau -steps. This last fact, whether we observe or not these nodes, will constrain -the distinction between the weak and strong bisimulations we define. - -In contrast with [equ], as well as the relations in [itree]s, we do not -define the functions generating the relations directly structurally on -the trees. Instead, we follow a definition closely following the style -developed for process calculi, essentially stating that diagrams of this -shape can be closed. -t R u -| | -l l -v v -t' R u' -The transition relations that we use to this end are defined in the [Trans] -module: -- strong bisimulation is defined as a symmetric games over [trans]; -- weak bisimulation is defined as an asymmetric game in which [trans] get -answered by [wtrans]. - -.. coq::none -|*) -From Stdlib Require Import - Lia - Basics - Fin - RelationClasses - Program.Equality - Logic.Eqdep. - -From Coinduction Require Import all. - -From ITree Require Import Core.Subevent. - -From CTree Require Import - CTree - Utils - Eq.Equ - Eq.Shallow - Eq.Trans - Eq.SSim - Eq.CSSim. - -From RelationAlgebra Require Export - rel srel. - -Import CoindNotations. -Set Implicit Arguments. -Import CTree. -Import CTreeNotations. -Import EquNotations. - -(*| -Strong Bisimulation -------------------- -Relation relaxing [equ] to become insensitive to: -- the amount of _invisible_ brs taken; -- the particular branches taken during (any kind of) brs. -|*) - -Section StrongBisim. - Context {E F C D : Type -> Type} {X Y : Type}. - -(*| -In the heterogeneous case, the relation is not symmetric. -|*) - Program Definition sb L : mon (@S E C X -> @S F D Y -> Prop) := - {| body R t u := ss L R t u /\ ss (flipL L) (flip R) u t |}. - Next Obligation. - split; intros; [edestruct H0 as (? & ? & ?) | edestruct H1 as (? & ? & ?)]; eauto; eexists; eexists; intuition; eauto. - Qed. - - #[global] Instance lequiv_sb : - Proper (lequiv ==> weq) sb. - Proof. - cbn -[sb]. intros * EQ *; split. - - intros [For Bac]; split. - eapply lequiv_ss in EQ. - now apply EQ in For. - eapply lequiv_ss; [| eauto]. - now apply lequiv_flipL. - - intros [For Bac]; split. - eapply lequiv_ss; eauto. - eapply lequiv_ss; [| eauto]. - now apply lequiv_flipL. - Qed. - -End StrongBisim. - -Definition sbisim {E F C D X Y} L := - (gfp (@sb E F C D X Y L) : hrel _ _). - -Module SBisimNotations. - -(*| -sb (bisimulation) notation -|*) - Notation "t ~ u" := (sbisim eq t u) (at level 70). - Notation "t (~ [ Q ] ) u" := (sbisim (Lvrel Q) t u) (at level 79). - Notation "t (~ L ) u" := (sbisim L t u) (at level 70). - Notation "t {{ ~ L }} u" := (sb L _ t u) (at level 79). - Notation "t '{{~' [ R ] '}}' u" := (sb (Lvrel R) (` _) t u) (at level 90, only printing). - Notation "t {{~}} u" := (sb eq _ t u) (at level 79). - -End SBisimNotations. - -Import SBisimNotations. - -(* This instance allows to use the symmetric tactic from coq-coinduction - for homogeneous bisimulations *) -#[global] Instance sbisim_sym {E C X L} : - Symmetric L -> - Symmetrical converse (@sb E E C C X X (Lvrel L)) (@ss E E C C X X (Lvrel L)). -Proof. - intros SYM. intros RR u v. split; intros HSIM. - - destruct HSIM as [F B]. split. - + apply F. - + cbn. intros l v' TR. - apply B in TR as (l' & u' & TR & HR & HR'). - ex2; split3; eauto. - symmetry. - pose proof flipL_flip (Lvrel L) l l' as G. - now apply G. - - destruct HSIM as [F B]. split. - + apply F. - + intros l v' TR. - apply B in TR as (l' & u' & TR & HR & HR'). - ex2; split3; eauto. - pose proof flipL_flip (Lvrel L) l l' as G. - apply G. - now symmetry. -Qed. - -Ltac fold_sbisim := - repeat - match goal with - | h: context[gfp (@sb ?E ?F ?C ?D ?X ?Y ?L)] |- _ => fold (@sbisim E F C D X Y L) in h - | |- context[gfp (@sb ?E ?F ?C ?D ?X ?Y ?L)] => fold (@sbisim E F C D X Y L) - end. - -Tactic Notation "__step_sbisim" := - match goal with - | |- context[@sbisim ?E ?F ?C ?D ?X ?Y ?LR] => - unfold sbisim; - step; - fold (@sbisim E F C D X Y L) - end. -#[local] Tactic Notation "step" := __step_sbisim || __step_ssim || __step_cssim || step. - -Ltac __step_in_sbisim H := - match type of H with - | context [@sbisim ?E ?F ?C ?D ?X ?Y ?L] => - unfold sbisim in H; - step in H; - fold (@sbisim E F C D X Y L) in H - end. -#[local] Tactic Notation "step" "in" ident(H) := __step_in_sbisim H || step in H. - -Tactic Notation "__coinduction_sbisim" simple_intropattern(r) simple_intropattern(cih) := - first [unfold sbisim at 4 | unfold sbisim at 3 | unfold sbisim at 2 | unfold sbisim at 1]; coinduction r cih. -#[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := - __coinduction_sbisim r cih || __coinduction_cssim r cih || __coinduction_ssim r cih || coinduction r cih. - -Ltac __play_sbisim := (try step); split; cbn; intros ? ? ?TR. - -Ltac __playL_sbisim H := - (try step in H); - let Hf := fresh "Hf" in - destruct H as [Hf _]; - cbn in Hf; edestruct Hf as (? & ? & ?TR & ?EQ & ?); - clear Hf; subst; [etrans |]. - -Ltac __eplayL_sbisim := - match goal with - | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => - __playL_sbisim h - | h : body (sb ?L) ?R _ _ |- _ => - __playL_sbisim h - end. - -Ltac __playR_sbisim H := - try (step in H); - let Hb := fresh "Hb" in - destruct H as [_ Hb]; - cbn in Hb; edestruct Hb as (? & ? & ?TR & ?EQ & ?); - clear Hb; subst; [etrans |]. - -Ltac __eplayR_sbisim := - match goal with - | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => - __playR_sbisim h - | h : body (sb ?L) ?R _ _ |- _ => - __playR_sbisim h - end. - -Ltac __answer_sbisim := ex2; split3; etrans. - -#[local] Tactic Notation "play" := __play_sbisim. -#[local] Tactic Notation "playL" "in" ident(H) := __playL_sbisim H. -#[local] Tactic Notation "playR" "in" ident(H) := __playR_sbisim H. -#[local] Tactic Notation "play" "in" ident(H) := first [playL in H; [] | playR in H; []]. -#[local] Tactic Notation "eplayL" := __eplayL_sbisim. -#[local] Tactic Notation "eplayR" := __eplayR_sbisim. -#[local] Tactic Notation "eplay" := first [eplayL; [] | eplayR; []]. -#[local] Tactic Notation "answer" := __answer_sbisim. - -Section sbisim_homogenous_theory. - Context {E B: Type -> Type} {X: Type} {L: lrel E E X X}. - - Notation sb := (@sb E E B B X X). - - #[global] Instance reflexive_sb {R} - (LR: Reflexive L) - (RR: Reflexive R): Reflexive (sb L R). - Proof. - split. reflexivity. - cbn; eauto 10. - Qed. - - #[global] Instance reflexive_chain {LR: Reflexive L} {C: Chain (sb L)}: Reflexive `C. - Proof. - apply Reflexive_chain; typeclasses eauto. - Qed. - - #[global] Instance symmetric_sb {R} - (LS : Symmetric L) - (RS : Symmetric R) : - Symmetric (sb L R). - Proof. - intros u v SB. - play; eplay. - answer; now apply flipL_flip. - answer; now apply flipL_flip. - Qed. - - #[global] Instance symmetric_chain {LR: Symmetric L} {C: Chain (sb L)}: Symmetric `C. - Proof. - apply Symmetric_chain; typeclasses eauto. - Qed. - - #[global] Instance transitive_sb {R} - (LT: Transitive L) - (RT: Transitive R): Transitive (sb L R). - Proof. - intros x y z SS1 SS2. - play. - - play in SS1; play in SS2; answer. - - play in SS2; play in SS1; answer. - apply (flipL_flip L) in H,H0; apply flipL_flip; cbn in *; eauto. - Qed. - - #[global] Instance transitive_chain {LT: Transitive L} {C: Chain (sb L)}: Transitive `C. - Proof. - apply Transitive_chain; typeclasses eauto. - Qed. - - (*| Equivalence |*) - #[global] Instance equivalence_sb {R} - (LE : Equivalence L) - (RE : Equivalence R) : Equivalence (sb L R). - Proof. split; typeclasses eauto. Qed. - - #[global] Instance equivalence_chain {LE: Equivalence L} {C: Chain (sb L)}: Equivalence `C. - Proof. split; typeclasses eauto. Qed. - -End sbisim_homogenous_theory. - -(* Section Homogeneous. *) - -(* Context {E C: Type -> Type} {X: Type} *) -(* {L: rel (@label E) (@label E)}. *) -(* Notation ss := (@ss E E C C X X). *) -(* Notation ssim := (@ssim E E C C X X). *) - -(* #[global] Instance sbisim_clos_ssim_goal `{Symmetric _ L} `{Transitive _ L} : *) -(* Proper (sbisim L ==> sbisim L ==> flip impl) (ssim L). *) -(* Proof. *) -(* repeat intro. *) -(* transitivity y0. transitivity y. *) -(* - now apply sbisim_ssim_subrelation in H1. *) -(* - now exact H3. *) -(* - symmetry in H2; now apply sbisim_ssim_subrelation in H2. *) -(* Qed. *) - -(* #[global] Instance sbisim_clos_ssim_ctx `{Equivalence _ L}: *) -(* Proper (sbisim L ==> sbisim L ==> impl) (ssim L). *) -(* Proof. *) -(* repeat intro. symmetry in H0, H1. eapply sbisim_clos_ssim_goal; eauto. *) -(* Qed. *) - -(* End Homogeneous. *) - -Section VRel. - Context {E B: Type -> Type} {X Y: Type} {RR: rel X Y}. -(*| -Hence [equ eq] is a included in [sbisim] -|*) - -(* TODO: Generalize SEQ to take a relation on values as argument *) -Lemma foo u v : - SeqR RR u v -> - @sbisim E E B B X Y (Lvrel RR) u v. -Proof. - intros SEQ. - dependent induction SEQ. - - rewrite EQ. - -#[global] Instance equ_sbisim_subrelation {X Y} (RR : rel X Y) : subrelation (SeqR RR) (sbisim (Lvrel RR)). - Proof. - red; intros. - rewrite H; reflexivity. - Qed. - - #[global] Instance is_stuck_sbisim : Proper (sbisim L ==> flip impl) is_stuck. - Proof. - cbn. intros ???????. - step in H. destruct H as [? _]. - apply H in H1 as (? & ? & ? & ? & ?). now apply H0 in H1. - Qed. - - #[global] Instance sbisim_cssim_subrelation : subrelation (sbisim L) (cssim L). - Proof. - red; apply sbisim_cssim_subrelation_gen. - Qed. - - #[global] Instance sbisim_ssim_subrelation : subrelation (sbisim L) (ssim L). - Proof. - red; apply sbisim_ssim_subrelation_gen. - Qed. - - -(*| - This section should describe lemmas proved for the - heterogenous version of `css`, parametric on - - Return types X, Y - - Label types E, F - - Branch effects C, D -|*) -Section sbisim_heterogenous_theory. - - Arguments label: clear implicits. - Context {E F C D : Type -> Type} {X Y : Type} - {L: rel (@label E) (@label F)}. - - Notation sb := (@sb E F C D X Y). - Notation sbisim := (@sbisim E F C D X Y). - -(*| -Strong bisimulation up-to [equ] is valid ----------------------------------------- -|*) - Lemma equ_clos_sb {c: Chain (sb L)}: - forall x y, equ_clos `c x y -> `c x y. - Proof. - apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - clear. - intros c IH x y []; split. - + intros l z x'z. - rewrite Equt in x'z. - apply HR in x'z as (? & ? & ? & ? & ?). - do 2 eexists; intuition; eauto. - rewrite <- Equu; eauto. - + intros l z x'z. - rewrite <- Equu in x'z. - apply HR in x'z as (? & ? & ? & ? & ?). - do 2 eexists; intuition; eauto. - rewrite Equt; eauto. - Qed. - -(*| - Aggressively providing instances for rewriting [equ] under all [sb]-related - contexts. -|*) - #[global] Instance equ_clos_sb_goal {c: Chain (sb L)} : - Proper (equ eq ==> equ eq ==> flip impl) `c. - Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sb; econstructor; [eauto | | symmetry; eauto]; assumption. - Qed. - - #[global] Instance equ_clos_sb_ctx {c: Chain (sb L)} : - Proper (equ eq ==> equ eq ==> impl) `c. - Proof. - cbn; intros ? ? eq1 ? ? eq2 H. - apply equ_clos_sb; econstructor; [symmetry; eauto | | eauto]; assumption. - Qed. - - #[global] Instance equ_sb_closed_goal {r} : Proper (@equ E C X X eq ==> @equ F D Y Y eq ==> flip impl) (sb L r). - Proof. - intros t t' tt' u u' uu'. - split. - rewrite tt', uu'; apply H. - rewrite tt', uu'; apply H. - Qed. - - #[global] Instance equ_sb_closed_ctx {r} : Proper (@equ E C X X eq ==> @equ F D Y Y eq ==> impl) (sb L r). - Proof. - cbn -[sb]. intros. now subs. - Qed. - -(*| -Up-to-bisimulation enhancing function -|*) - Variant sbisim_clos_body {LE LF} - (R : rel (ctree E C X) (ctree F D Y)) : (rel (ctree E C X) (ctree F D Y)) := - | Sbisim_clos : forall t t' u' u - (Sbisimt : t (~ LE) t') - (HR : R t' u') - (Sbisimu : u' (~ LF) u), - @sbisim_clos_body LE LF R t u. - - Program Definition sbisim_clos {LE LF} : mon (rel (ctree E C X) (ctree F D Y)) := - {| body := @sbisim_clos_body LE LF |}. - Next Obligation. - destruct H0. - econstructor; eauto. - Qed. - -(*| -stuck ctrees can be simulated by anything. -|*) - Lemma is_stuck_sb (R : rel _ _) (t : ctree E C X) (t': ctree F D Y): - is_stuck t -> is_stuck t' -> sb L R t t'. - Proof. - split; repeat intro. - - now apply H in H1. - - now apply H0 in H1. - Qed. - - Lemma sbisim_clos_sb {c: Chain (sb L)}: - forall x y, @sbisim_clos eq eq `c x y -> `c x y. - Proof. - apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - clear. - intros c IH x y []; split; intros ? ? TR. - + destruct HR as [fwd bckd]. - step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis & <-). - apply fwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). - step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & <-). - do 2 eexists; repeat split; eauto. - apply IH. - econstructor; eauto. - + destruct HR as [fwd bwd]. - step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis & <-). - apply bwd in TR; destruct TR as (? & ? & TR & Sbis' & HL). - step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis'' & <-). - do 2 eexists; repeat split; eauto. - apply IH. - econstructor; eauto. - Qed. - - Lemma sbisim_cssim_subrelation_gen : forall x y, sbisim L x y -> cssim L x y. - Proof. - red. - coinduction r cih; intros * SB. - step in SB; destruct SB as [fwd bwd]. - split. - - intros ?? TR; apply fwd in TR as (? & ? & ? & ? & ?); eauto 10. - - intros ?? TR; apply bwd in TR as (? & ? & ? & ? & ?); eauto 10. - Qed. - - Lemma sbisim_ssim_subrelation_gen : forall x y, sbisim L x y -> ssim L x y. - Proof. - now intros; apply cssim_ssim_subrelation_gen, sbisim_cssim_subrelation_gen. - Qed. - -End sbisim_heterogenous_theory. - -(*| -Up-to [bind] context bisimulations ----------------------------------- -We have proved in the module [Equ] that up-to bind context is -a valid enhancement to prove [equ]. -We now prove the same result, but for strong and weak bisimulation. -|*) - -Section bind. - Obligation Tactic := trivial. - Arguments label: clear implicits. - Context {E F C D: Type -> Type} {X X' Y Y': Type} - {L: rel (label E) (label F)} (R0 : rel X Y). - - Lemma bind_chain_gen - (RR : rel (label E) (label F)) - (ISVR : is_update_val_rel L R0 RR) - {R : Chain (@sb E F C D X' Y' L)} : - forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), - sbisim RR t t' -> - (forall x x', R0 x x' -> ` R (k x) (k' x')) -> - ` R (bind t k) (bind t' k'). - Proof. - apply tower. - - intros ? INC ? ? ? ? tt' kk' ? ?. - apply INC. apply H. apply tt'. - intros x x' xx'. apply leq_infx in H. apply H. now apply kk'. - - intros ? ? ? ? ? ? tt' kk'. - step in tt'; destruct tt' as [fwd bwd]. - split; cbn; intros * STEP. - + apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | (v & STEPres & STEP)]. - * apply fwd in STEP as (? & ? & ? & ? & ?). - do 2 eexists; split; [| split]. - apply trans_bind_l; eauto. - ++ intro Hl. destruct Hl. - apply ISVR in H3; etrans. - inversion H3; subst. apply H0. constructor. apply H5. constructor. - ++ rewrite EQ. - apply H. - apply H2. - intros * HR. - now apply (b_chain x), kk'. - ++ apply ISVR in H3; etrans. - destruct H3. exfalso. apply H0. constructor. eauto. - * apply fwd in STEPres as (u' & ? & STEPres & EQ' & ?). - apply ISVR in H0; etrans. - dependent destruction H0. - 2 : exfalso; apply H0; constructor. - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk' v v2 H0). - apply kk' in STEP as (u'' & ? & STEP & EQ'' & ?); cbn in *. - do 2 eexists; split. - eapply trans_bind_r; eauto. - split; auto. - + apply trans_bind_inv in STEP as [(?H & ?t' & STEP & EQ) | (v & STEPres & STEP)]. - * apply bwd in STEP as (? & ? & ? & ? & ?). - do 2 eexists; split; [| split]. - apply trans_bind_l; eauto. - ++ intro Hl. destruct Hl. - apply ISVR in H3; etrans. - inversion H3; subst. apply H0. constructor. apply H4. constructor. - ++ rewrite EQ. - apply H. - apply H2. - intros * HR. - now apply (b_chain x), kk'. - ++ apply ISVR in H3; etrans. - destruct H3. exfalso. apply H0. constructor. eauto. - * apply bwd in STEPres as (u' & ? & STEPres & EQ' & ?). - apply ISVR in H0; etrans. - dependent destruction H0. - 2 : exfalso; apply H1; constructor. - pose proof (trans_val_inv STEPres) as EQ. - rewrite EQ in STEPres. - specialize (kk' v1 v H0). - apply kk' in STEP as (u'' & ? & STEP & EQ'' & ?); cbn in *. - do 2 eexists; split. - eapply trans_bind_r; eauto. - split; auto. - Qed. - -End bind. - -(*| -Expliciting the reasoning rule provided by the up-to principles. -|*) -Lemma sbisim_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) L0 - (t1 : ctree E C X) (t2: ctree F D Y) - (HL0 : is_update_val_rel L R0 L0) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') : - t1 (~L0) t2 -> - (forall x y, R0 x y -> k1 x (~L) k2 y) -> - t1 >>= k1 (~L) t2 >>= k2. -Proof. - now apply bind_chain_gen. -Qed. - -Lemma sbisim_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) - (t1 : ctree E C X) (t2: ctree F D Y) - (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') : - t1 (~update_val_rel L R0) t2 -> - (forall x y, R0 x y -> k1 x (~L) k2 y) -> - t1 >>= k1 (~L) t2 >>= k2. -Proof. - now apply bind_chain_gen. -Qed. - -Lemma sb_clo_bind_eq {E C} {X Y} - (t1 t2 : ctree E C X) - k1 k2 - {R : Chain (@sb E E C C Y Y eq)} : - t1 ~ t2 -> - (forall x, ` R (k1 x) (k2 x)) -> - `R (t1 >>= k1) (t2 >>= k2). -Proof. - intros; eapply bind_chain_gen with (R0 := eq); eauto. - apply update_val_rel_eq. - now intros ??->. -Qed. - -Lemma sbisim_clo_bind_eq {E C D: Type -> Type} {X X': Type} - (t1 : ctree E C X) (t2: ctree E D X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') : - t1 ~ t2 -> - (forall x, k1 x ~ k2 x) -> - t1 >>= k1 ~ t2 >>= k2. -Proof. - intros; eapply sbisim_clo_bind_gen with (R0 := eq); eauto. - apply update_val_rel_eq. - now intros ??->. -Qed. - -(*| -And in particular, we get the proper instance justifying rewriting [~] to the left of a [bind]. -|*) -#[global] Instance bind_sbisim_cong_gen {E C X Y} - {R : Chain (@sb E E C C Y Y eq)} : - Proper (sbisim eq ==> pointwise_relation X (`R) ==> `R) (@bind E C X Y). -Proof. - cbn; intros; eapply sb_clo_bind_eq; auto. -Qed. - -#[global] Instance bind_sbisim_cong {E C X Y} : - Proper (sbisim eq ==> pointwise_relation X (sbisim eq) ==> sbisim eq) (@bind E C X Y). -Proof. - cbn; intros; eapply sb_clo_bind_eq; auto. -Qed. - -Lemma sbisim_bind_eq {E C: Type -> Type} {X X': Type} - (t : ctree E C X) - (k1 : X -> ctree E C X') (k2 : X -> ctree E C X') : - (forall x, k1 x ~ k2 x) -> - t >>= k1 ~ t >>= k2. -Proof. - intros; eapply sbisim_clo_bind_gen with (R0 := eq); eauto. - apply update_val_rel_eq. - now intros ??->. -Qed. - -Lemma sb_chain_bind_eq {E C} {X Y} - (t : ctree E C X) k1 k2 - {R : Chain (@sb E E C C Y Y eq)} : - (forall x, elem R (k1 x) (k2 x)) -> - elem R (t >>= k1) (t >>= k2). -Proof. - intros; eapply SBisim.bind_chain_gen with (R0 := eq); eauto. - apply update_val_rel_eq. - now intros ??->. -Qed. - -Lemma sb_chain_bind - {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)} - (R0 : rel X Y) - {R : Chain (@sb E F C D X' Y' L)} : - forall (t : ctree E C X) (t' : ctree F D Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y'), - t (~update_val_rel L R0) t' -> - (forall x x', R0 x x' -> elem R (k x) (k' x')) -> - elem R (bind t k) (bind t' k'). -Proof. - intros. - eapply SBisim.bind_chain_gen; eauto. - apply update_val_rel_correct. -Qed. - -(* Ltac __upto_bind_sbisim' R := - first [apply sbisim_clo_bind with (R0 := R) | - apply sb_chain_bind with (R0 := R)]. -Tactic Notation "__upto_bind_sbisim" uconstr(t) := __upto_bind_sbisim' t. *) - -Ltac __eupto_bind_sbisim := - first [eapply sbisim_clo_bind | eapply sb_chain_bind]. - -Ltac __upto_bind_sbisim_eq := - first [apply sbisim_bind_eq | apply sb_chain_bind_eq]. - -Lemma vis_chain_gen {E F C D: Type -> Type} {X X' Y Y': Type} L - {R : Chain (@sb E F C D X' Y' L)} : - forall (e : E X) (e' : F Y) (k : X -> ctree E C X') (k' : Y -> ctree F D Y') - (right : X -> Y) (left : Y -> X), - (forall x, L (obs e x) (obs e' (right x))) -> - (forall y, L (obs e (left y)) (obs e' y)) -> - (forall x, ` R (k x) (k' (right x))) -> - (forall x', ` R (k (left x')) (k' x')) -> - ` R (Vis e k) (Vis e' k'). -Proof. - intros. - apply (b_chain R). - split; intros ?? TR; inv_trans; subst. - do 2 eexists; intuition; eauto. - rewrite EQ; auto. - do 2 eexists; intuition; eauto. - rewrite EQ; apply H2. - apply H0. -Qed. - -Lemma vis_chain {E C X Y} - {R : Chain (@sb E E C C X X eq)} : - forall (e : E Y) (k : Y -> ctree E C X) (k' : Y -> ctree E C X), - (forall x, ` R (k x) (k' x)) -> - ` R (Vis e k) (Vis e k'). -Proof. - intros. eapply vis_chain_gen with (left := fun x => x) (right := fun x => x); auto. -Qed. - - -(*| -Proof rules for [~] -------------------- -Naive bisimulations proofs naturally degenerate into exponential proofs, -splitting into two goals at each step. -The following proof rules avoid this issue in particular cases. - -Be sure to notice that contrary to equations such that [sb_guard] or -up-to principles such that [upto_vis], (most of) these rules consume a [sb]. - -TODO: need to think more about this --- do we want more proof rules? -Do we actually need them on [sb (st R)], or something else? -|*) -Section Proof_Rules. - - Arguments label : clear implicits. - Context {E F C D : Type -> Type} {X Y: Type} {L : rel (label E) (label F)}. - - Lemma step_sb_ret_gen - (x: X) (y: Y) (R : rel (ctree E C X) (ctree F D Y)) : - R Stuck Stuck -> - L (val x) (val y) -> - (Proper (equ eq ==> equ eq ==> impl) R) -> - sb L R (Ret x) (Ret y). - Proof. - intros Rstuck ValRefl PROP. - split; apply step_ss_ret_gen; eauto. - typeclasses eauto. - Qed. - - Lemma step_sb_ret (x: X) (y: Y) - {R : Chain (@sb E F C D X Y L)} : - L (val x) (val y) -> - sb L `R (Ret x) (Ret y). - Proof. - intros LH; subst. - apply step_sb_ret_gen; eauto. - - apply (b_chain R); split; apply is_stuck_sb; apply Stuck_is_stuck. - - typeclasses eauto. - Qed. - - Lemma sbisim_ret (x: X) (y: Y) : - L (val x) (val y) -> - @sbisim E F C D _ _ L (Ret x) (Ret y). - Proof. - intros. step. now apply step_sb_ret. - Qed. - -(*| - The vis nodes are deterministic from the perspective of the labeled transition system, - stepping is hence symmetric and we can just recover the itree-style rule. -|*) - Lemma step_sb_vis_gen {X' Y'} (e: E X') (f: F Y') - (k: X' -> ctree E C X) (k': Y' -> ctree F D Y) {R : rel _ _}: - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, exists y, R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - (forall y, exists x, R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - sb L R (Vis e k) (Vis f k'). - Proof. - intros PR EQs EQs'. - split; apply step_ss_vis_gen; eauto. - typeclasses eauto. - Qed. - - Lemma step_sb_vis {X' Y'} - (e: E X') (f: F Y') (k: X' -> ctree E C X) (k': Y' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - (forall x, exists y, ` R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - (forall y, exists x, ` R (k x) (k' y) /\ L (obs e x) (obs f y)) -> - sb L `R (Vis e k) (Vis f k'). - Proof. - intros EQs EQs'. - apply step_sb_vis_gen; eauto. - typeclasses eauto. - Qed. - - Lemma sbisim_vis {X' Y'} - (e: E X') (f: F Y') (k: X' -> ctree E C X) (k': Y' -> ctree F D Y) : - (forall x, exists y, sbisim L (k x) (k' y) /\ L (obs e x) (obs f y)) -> - (forall y, exists x, sbisim L (k x) (k' y) /\ L (obs e x) (obs f y)) -> - sbisim L (Vis e k) (Vis f k'). - Proof. - intros. step. now apply step_sb_vis. - Qed. - - Lemma step_sb_vis_id_gen {X'} (e: E X') (f: F X') - (k: X' -> ctree E C X) (k': X' -> ctree F D Y) {R : rel _ _}: - (Proper (equ eq ==> equ eq ==> impl) R) -> - (forall x, R (k x) (k' x) /\ L (obs e x) (obs f x)) -> - sb L R (Vis e k) (Vis f k'). - Proof. - intros; eapply step_sb_vis_gen; eauto. - Qed. - - Lemma step_sb_vis_id {X'} - (e: E X') (f: F X') (k: X' -> ctree E C X) (k': X' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - (forall x, ` R (k x) (k' x) /\ L (obs e x) (obs f x)) -> - sb L `R (Vis e k) (Vis f k'). - Proof. - intros; eapply step_sb_vis; eauto. - Qed. - - Lemma sbisim_vis_id {X'} - (e: E X') (f: F X') (k: X' -> ctree E C X) (k': X' -> ctree F D Y) : - (forall x, sbisim L (k x) (k' x) /\ L (obs e x) (obs f x)) -> - sbisim L (Vis e k) (Vis f k'). - Proof. - intros. step. now apply step_sb_vis_id. - Qed. - - (*| - Guard -|*) - Lemma step_sb_guard_gen (t : ctree E C X) (u : ctree F D Y) {R : rel _ _} : - sb L R t u -> - sb L R (Guard t) (Guard u). - Proof. - split; apply step_ss_guard_gen; eauto; apply H. - Qed. - - Lemma step_sb_guard_l_gen (t : ctree E C X) (u : ctree F D Y) {R : rel _ _} : - sb L R t u -> - sb L R (Guard t) u. - Proof. - split. - apply step_ss_guard_l_gen; eauto; apply H. - apply step_ss_guard_r_gen; eauto; apply H. - Qed. - - Lemma step_sb_guard_r_gen (t : ctree E C X) (u : ctree F D Y) {R : rel _ _} : - sb L R t u -> - sb L R t (Guard u). - Proof. - split. - apply step_ss_guard_r_gen; eauto; apply H. - apply step_ss_guard_l_gen; eauto; apply H. - Qed. - - Lemma step_sb_guard (t : ctree E C X) (u : ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - sb L (` R) t u -> - sb L `R (Guard t) (Guard u). - Proof. - intros; apply step_sb_guard_gen; auto. - Qed. - - Lemma step_sb_guard_l (t : ctree E C X) (u : ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - sb L (` R) t u -> - sb L `R (Guard t) u. - Proof. - intros; apply step_sb_guard_l_gen; auto. - Qed. - - Lemma step_sb_guard_r (t : ctree E C X) (u : ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - sb L (` R) t u -> - sb L `R t (Guard u). - Proof. - intros; apply step_sb_guard_r_gen; auto. - Qed. - - Lemma sbisim_guard (t : ctree E C X) (u : ctree F D Y) : - sbisim L t u -> - sbisim L (Guard t) (Guard u). - Proof. - intros * EQ; step; apply step_sb_guard; step in EQ; auto. - Qed. - - Lemma sbisim_guard_l (t : ctree E C X) (u : ctree F D Y) : - sbisim L t u -> - sbisim L (Guard t) u. - Proof. - intros * EQ; step; apply step_sb_guard_l; step in EQ; auto. - Qed. - - Lemma sbisim_guard_r (t : ctree E C X) (u : ctree F D Y) : - sbisim L t u -> - sbisim L t (Guard u). - Proof. - intros * EQ; step; apply step_sb_guard_r; step in EQ; auto. - Qed. - -(*| -br -|*) - - Lemma step_sb_br_gen {X' Y'} (c : C X') (d: D Y') - (k : X' -> ctree E C X) (k' : Y' -> ctree F D Y) (R : rel _ _) : - (forall x, exists y, sb L R (k x) (k' y)) -> - (forall y, exists x, sb L R (k x) (k' y)) -> - sb L R (Br c k) (Br d k'). - Proof. - intros EQs1 EQs2. - split; apply step_ss_br_gen; intros. - - destruct (EQs1 x) as [z [FW _]]. eauto. - - destruct (EQs2 x) as [z [_ BA]]. eauto. - Qed. - - Lemma step_sb_br_id_gen {X'} (c : C X') (d: D X') - (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) (R : rel _ _) : - (forall x, sb L R (k x) (k' x)) -> - sb L R (Br c k) (Br d k'). - Proof. - intros EQs. - split; apply step_ss_br_id_gen; intros. - - destruct (EQs x); auto. - - destruct (EQs x); auto. - Qed. - - Lemma step_sb_br_l_gen {X'} (c : C X') - (k : X' -> ctree E C X) (u : ctree F D Y) (R : rel _ _) : - X' -> - (forall x, sb L R (k x) u) -> - sb L R (Br c k) u. - Proof. - intros x EQs. - split. - - apply step_ss_br_l_gen; intros; apply EQs. - - intros ?? TR. - eapply step_ss_br_r_gen with (x := x); eauto. - apply EQs. - Qed. - - Lemma step_sb_br_r_gen {Y'} (c : D Y') - (t : ctree E C X) (k : Y' -> ctree F D Y) (R : rel _ _) : - Y' -> - (forall x, sb L R t (k x)) -> - sb L R t (Br c k). - Proof. - intros x EQs. - split. - - apply step_ss_br_r_gen with (x := x); intros; apply EQs. - - apply step_ss_br_l_gen; intros; apply EQs. - Qed. - - Lemma step_sb_br {X' Y'} - (c : C X') (d: D Y') - (k : X' -> ctree E C X) (k' : Y' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - (forall x, exists y, sb L (` R) (k x) (k' y)) -> - (forall y, exists x, sb L (` R) (k x) (k' y)) -> - sb L `R (Br c k) (Br d k'). - Proof. - intros; apply step_sb_br_gen; auto. - Qed. - - Lemma step_sb_br_id {X'} - (c : C X') (d: D X') - (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - (forall x, sb L (` R) (k x) (k' x)) -> - sb L `R (Br c k) (Br d k'). - Proof. - intros; apply step_sb_br_id_gen; auto. - Qed. - - Lemma step_sb_br_l {X'} - (c : C X') - (k : X' -> ctree E C X) (u : ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - X' -> - (forall x, sb L (` R) (k x) u) -> - sb L `R (Br c k) u. - Proof. - intros; apply step_sb_br_l_gen; auto. - Qed. - - Lemma step_sb_br_r {Y'} - (d : D Y') - (t : ctree E C X) (k' : Y' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - Y' -> - (forall x, sb L (` R) t (k' x)) -> - sb L `R t (Br d k'). - Proof. - intros; apply step_sb_br_r_gen; auto. - Qed. - - Lemma sbisim_br {X' Y'} - (c : C X') (d: D Y') - (k : X' -> ctree E C X) (k' : Y' -> ctree F D Y) : - (forall x, exists y, sbisim L (k x) (k' y)) -> - (forall y, exists x, sbisim L (k x) (k' y)) -> - sbisim L (Br c k) (Br d k'). - Proof. - intros H1 H2; step; apply step_sb_br; eauto. - intros x; destruct (H1 x); eexists; step in H; eauto. - intros x; destruct (H2 x); eexists; step in H; eauto. - Qed. - - Lemma sbisim_br_id {X'} - (c : C X') (d: D X') - (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) : - (forall x, sbisim L (k x) (k' x)) -> - sbisim L (Br c k) (Br d k'). - Proof. - intros; step; apply step_sb_br_id; eauto. - intros x; specialize (H x); step in H; auto. - Qed. - - Lemma sbisim_br_l {X'} - (c : C X') - (k : X' -> ctree E C X) (u : ctree F D Y) : - X' -> - (forall x, sbisim L (k x) u) -> - sbisim L (Br c k) u. - Proof. - intros; step; apply step_sb_br_l; eauto. - intros x; specialize (H x); step in H; auto. - Qed. - - Lemma sbisim_br_r {Y'} - (d: D Y') - (t : ctree E C X) (k' : Y' -> ctree F D Y) : - Y' -> - (forall x, sbisim L t (k' x)) -> - sbisim L t (Br d k'). - Proof. - intros; step; apply step_sb_br_r; eauto. - intros x; specialize (H x); step in H; auto. - Qed. - -(*| - Same goes for step nodes. -|*) - Lemma step_sb_step_gen (t : ctree E C X) (u : ctree F D Y) {R : rel _ _} : - (Proper (equ eq ==> equ eq ==> iff) R) -> - L τ τ -> - R t u -> - sb L R (Step t) (Step u). - Proof. - split; apply step_ss_step_gen; eauto. - repeat intro; edestruct H; eauto. - unfold flip. - repeat intro; edestruct H; eauto. - Qed. - - Lemma step_sb_step (t : ctree E C X) (u : ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - L τ τ -> - ` R t u -> - sb L `R (Step t) (Step u). - Proof. - intros. - apply step_sb_step_gen; eauto. - split; intros HR. - now rewrite <- H1, <- H2. - now rewrite H1, H2. - Qed. - - Lemma sbisim_step (t : ctree E C X) (u : ctree F D Y) : - L τ τ -> - sbisim L t u -> - sbisim L (Step t) (Step u). - Proof. - intros. step. apply step_sb_step; auto. - Qed. - -(*| -BrS -|*) - - Lemma step_sb_brS_gen {X' Y'} (c : C X') (d: D Y') - (k : X' -> ctree E C X) (k' : Y' -> ctree F D Y) (R : rel _ _) : - (Proper (equ eq ==> equ eq ==> iff) R) -> - L τ τ -> - (forall x, exists y, R (k x) (k' y)) -> - (forall y, exists x, R (k x) (k' y)) -> - sb L R (BrS c k) (BrS d k'). - Proof. - intros HP EQτ EQs1 EQs2. - apply step_sb_br_gen. - - intros x; destruct (EQs1 x) as [y ?]; exists y. - apply step_sb_step_gen; auto. - - intros y; destruct (EQs2 y) as [x ?]; exists x. - apply step_sb_step_gen; auto. - Qed. - - Lemma step_sb_brS_id_gen {X'} (c : C X') (d: D X') - (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) (R : rel _ _) : - (Proper (equ eq ==> equ eq ==> iff) R) -> - L τ τ -> - (forall x, R (k x) (k' x)) -> - sb L R (BrS c k) (BrS d k'). - Proof. - intros HP EQτ EQs. - apply step_sb_br_id_gen. - intros. - apply step_sb_step_gen; auto. - Qed. - - Lemma step_sb_brS - {X' Y'} (c : C X') (d: D Y') - (k : X' -> ctree E C X) (k' : Y' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - L τ τ -> - (forall x, exists y, ` R (k x) (k' y)) -> - (forall y, exists x, ` R (k x) (k' y)) -> - sb L `R (BrS c k) (BrS d k'). - Proof. - intros. - apply step_sb_brS_gen; eauto. - split; intros HR. - now rewrite <- H3, <- H2. - now rewrite H3, H2. - Qed. - - Lemma step_sb_brS_id - {X'} (c : C X') (d: D X') - (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) - {R : Chain (@sb E F C D X Y L)} : - L τ τ -> - (forall x, ` R (k x) (k' x)) -> - sb L `R (BrS c k) (BrS d k'). - Proof. - intros. - apply step_sb_br_id. - intros. - split; intros ?? TR; inv_trans; do 2 eexists; split; etrans; subst; split; auto. - rewrite EQ; apply H0. - rewrite EQ; apply H0. - Qed. - - Lemma sbisim_brS - {X' Y'} (c : C X') (d: D Y') - (k : X' -> ctree E C X) (k' : Y' -> ctree F D Y) : - L τ τ -> - (forall x, exists y, sbisim L (k x) (k' y)) -> - (forall y, exists x, sbisim L (k x) (k' y)) -> - sbisim L (BrS c k) (BrS d k'). - Proof. - intros. step. now apply step_sb_brS. - Qed. - - Lemma sbisim_brS_id - {X'} (c : C X') (d: D X') - (k : X' -> ctree E C X) (k' : X' -> ctree F D Y) : - L τ τ -> - (forall x, sbisim L (k x) (k' x)) -> - sbisim L (BrS c k) (BrS d k'). - Proof. - intros. step. now apply step_sb_brS_id. - Qed. - -End Proof_Rules. - -(*| -Proof system for [~] --------------------- - -We specialize the proof system established in the previous section to [~] for clarity. -|*) -Section Sb_Proof_System. - Arguments label: clear implicits. - Context {E C: Type -> Type} {X: Type}. - - Lemma sb_ret : forall x y, - x = y -> - (Ret x: ctree E C X) ~ (Ret y: ctree E C X). - Proof. - intros * EQ; step. - now apply step_sb_ret; subst. - Qed. - - Lemma sb_vis {Y}: forall (e: E X) (k k': X -> ctree E C Y), - (forall x, k x ~ k' x) -> - Vis e k ~ Vis e k'. - Proof. - intros. - apply vis_chain, H. - Qed. - - (*| - Visible vs. Invisible Taus - ~~~~~~~~~~~~~~~~~~~~~~~~~~ - Invisible taus can be stripped-out w.r.t. to [sbisim], but not visible ones -|*) - Lemma sb_guard: forall (t : ctree E C X), - Guard t ~ t. - Proof. - intros t; play. - - inv_trans; etrans. - - eauto 6 with trans. - Qed. - - Lemma sb_guard_l: forall (t u : ctree E C X), - t ~ u -> - Guard t ~ u. - Proof. - intros * EQ; now rewrite sb_guard. - Qed. - - Lemma sb_guard_r: forall (t u : ctree E C X), - t ~ u -> - t ~ Guard u. - Proof. - intros * EQ; now rewrite sb_guard. - Qed. - - Lemma sb_guard_lr: forall (t u : ctree E C X), - t ~ u -> - Guard t ~ Guard u. - Proof. - intros * EQ; now rewrite !sb_guard. - Qed. - - Lemma sb_step: forall (t u : ctree E C X), - t ~ u -> - Step t ~ Step u. - Proof. - intros; apply sbisim_step; auto. - Qed. - - Lemma sb_br I J (ci : C I) (cj : C J) - (k : I -> ctree E C X) (k' : J -> ctree E C X) : - (forall x, exists y, k x ~ k' y) -> - (forall y, exists x, k x ~ k' y) -> - Br ci k ~ Br cj k'. - Proof. - intros; apply sbisim_br; auto. - Qed. - - Lemma sb_br_id I (c : C I) - (k k' : I -> ctree E C X) : - (forall x, k x ~ k' x) -> - Br c k ~ Br c k'. - Proof. - intros; apply sbisim_br_id; auto. - Qed. - - Lemma sb_br_l {Y} c (y : Y) (k: Y -> ctree E C X) (t: ctree E C X): - (forall x, k x ~ t) -> - Br c k ~ t. - Proof. - intros; apply sbisim_br_l; auto. - Qed. - - Lemma sb_brS I J (ci : C I) (cj : C J) - (k : I -> ctree E C X) (k' : J -> ctree E C X) : - (forall x, exists y, k x ~ k' y) -> - (forall y, exists x, k x ~ k' y) -> - BrS ci k ~ BrS cj k'. - Proof. - intros; apply sbisim_brS; auto. - Qed. - - Lemma sb_brS_id I (c : C I) - (k k' : I -> ctree E C X) : - (forall x, k x ~ k' x) -> - BrS c k ~ BrS c k'. - Proof. - intros; apply sbisim_brS_id; auto. - Qed. - - Lemma sb_unfold_forever : forall (k: X -> ctree E C X) (i: X), - forever k i ~ r <- k i ;; forever k r. - Proof. - intros. - rewrite unfold_forever. - apply sbisim_clo_bind_eq; auto. - intros; now rewrite sb_guard. - Qed. - -End Sb_Proof_System. - -(* TODO: tactics! - Should it be the same to step at both levels or two different sets? - -Ltac bsret := apply step_sb_ret. -Ltac bsvis := apply step_sb_vis. -Ltac bstauv := apply step_sb_tauV. -Ltac bsstep := bsret || bsvis || bstauv. - -Ltac sret := apply sb_ret. -Ltac svis := apply sb_vis. -Ltac stauv := apply sb_tauV. -Ltac sstep := sret || svis || stauv. - - - *) - -Section WithParams. - - Context {E C : Type -> Type}. - Context {HasC2 : B2 -< C}. - Context {HasC3 : B3 -< C}. - -(*| -Sanity checks -============= -- invisible n-ary spins are strongly bisimilar -- non-empty visible n-ary spins are strongly bisimilar -- Binary invisible br is: - + associative - + commutative - + merges into a ternary invisible br - + admits any Stuck computation as a unit - -Note: binary visible br are not associative up-to [sbisim]. -They aren't even up-to [wbisim]. -|*) - -(*| -Note that with visible schedules, nary-spins are equivalent only -if neither are empty, or if both are empty: they match each other's -tau challenge infinitely often. -With invisible schedules, they are always equivalent: neither of them -produce any challenge for the other. -|*) - - Lemma spinS_gen_nonempty : forall {Z X Y} (c: C X) (c': C Y) (x: X) (y: Y), - @spinS_gen E C Z X c ~ @spinS_gen E C Z Y c'. - Proof. - intros R. - coinduction S CIH. symmetric. - intros ** L t' TR; - rewrite ctree_eta in TR; cbn in TR; - apply trans_brS_inv in TR as (_ & EQ & ->); - eexists; eexists; - rewrite ctree_eta; cbn. - split; [econstructor|]. - - exact y. - - constructor; reflexivity. - - rewrite EQ; eauto. - Qed. - - Lemma spin_gen_bisim : forall {Z X Y} (c: C X) (c': C Y), - @spin_gen E C Z X c ~ @spin_gen E C Z Y c'. - Proof. - intros R. - coinduction S _; split; cbn; - intros * TR; exfalso; eapply spinD_gen_is_stuck, TR. - Qed. - -(*| - Br2 is associative, commutative, idempotent, merges into Br3, and admits _a lot_ of units. -|*) - Lemma br2_assoc X : forall (t u v : ctree E C X), - br2 (br2 t u) v ~ br2 t (br2 u v). - Proof. - intros. - play; inv_trans; eauto 7 with trans. - Qed. - - Lemma br2_commut {X} : forall (t u : ctree E C X), - br2 t u ~ br2 u t. - Proof. - intros. - play; inv_trans; eauto 6 with trans. - Qed. - - Lemma br2_idem {X} : forall (t : ctree E C X), - br2 t t ~ t. - Proof. - intros. - play; inv_trans; eauto 6 with trans. - Qed. - - Lemma br2_merge {X} : forall (t u v : ctree E C X), - br2 (br2 t u) v ~ br3 t u v. - Proof. - intros. - play; inv_trans; eauto 7 with trans. - Qed. - - Lemma br2_is_stuck {X} : forall (u v : ctree E C X), - is_stuck u -> - br2 u v ~ v. - Proof. - intros * ST. - play. - - inv_trans. - exfalso; eapply ST, TR. (* automate stuck transition trying to step? *) - exists l, t'; eauto. (* automate trivial case *) - - eauto 6 with trans. - Qed. - - Lemma br2_stuck_l {X} : forall (t : ctree E C X), - br2 Stuck t ~ t. - Proof. - intros; apply br2_is_stuck, Stuck_is_stuck. - Qed. - - Lemma br2_stuck_r {X} : forall (t : ctree E C X), - br2 t Stuck ~ t. - Proof. - intros; rewrite br2_commut; apply br2_stuck_l. - Qed. - - Lemma br2_spin_l {X} : forall (t : ctree E C X), - br2 spin t ~ t. - Proof. - intros; apply br2_is_stuck, spin_is_stuck. - Qed. - - Lemma br2_spin_r {X} : forall (t : ctree E C X), - br2 t spin ~ t. - Proof. - intros; rewrite br2_commut; apply br2_is_stuck, spin_is_stuck. - Qed. - -(*| -BrS2 is commutative and "almost" idempotent -|*) - Lemma brS2_commut : forall X (t u : ctree E C X), - brS2 t u ~ brS2 u t. - Proof. - intros. - play; inv_trans; subst. - all: do 2 eexists; split; [| split; [rewrite EQ; reflexivity| reflexivity]]; etrans. - Qed. - - Lemma brS2_idem : forall X (t : ctree E C X), - brS2 t t ~ Step t. - Proof. - intros. - play; inv_trans; subst. - all: do 2 eexists; split; [| split; [rewrite EQ; reflexivity| reflexivity]]; etrans. - Qed. - -(*| -Inversion principles --------------------- -|*) - Lemma sbisim_ret_inv X (r1 r2 : X) : - (Ret r1 : ctree E C X) ~ (Ret r2 : ctree E C X) -> r1 = r2. - Proof. - intro. - eplayL. - now inv_trans. - Qed. - -(*| - For the next few lemmas, we need to know that [X] is inhabited in order to - take a step -|*) - Lemma sbisim_vis_invT {X X1 X2} - (e1 : E X1) (e2 : E X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree E C X) (x : X1): - Vis e1 k1 ~ Vis e2 k2 -> - X1 = X2. - Proof. - intros. - eplayL. - inv TR; auto. - Unshelve. auto. - Qed. - - Lemma sbisim_vis_inv {X Y} (e1 e2 : E Y) (k1 k2 : Y -> ctree E C X) (x : Y) : - Vis e1 k1 ~ Vis e2 k2 -> - e1 = e2 /\ forall x, k1 x ~ k2 x. - Proof. - intros. - split. - - eplayL. - etrans. - inv_trans; eauto. - - intros. - clear x. - eplayL. - inv_trans. - subst. eauto. - Unshelve. auto. - Qed. - - Lemma sbisim_brS_inv {X Y Z} - c1 c2 (k1 : X -> ctree E C Z) (k2 : Y -> ctree E C Z) : - BrS c1 k1 ~ BrS c2 k2 -> - (forall i1, exists i2, k1 i1 ~ k2 i2) /\ (forall i2, exists i1, k1 i1 ~ k2 i2). - Proof. - intros EQ; split; intros i. - eplayL; inv_trans; eauto. - eplayR; inv_trans; eauto. - Qed. - -(*| - Annoying case: [Vis e k ~ BrS c k'] is true if [e : E void] and [c : C void]. - We rule out this case in this definition. -|*) - Definition are_bisim_incompat {X} (t u : ctree E C X) : Type := - match observe t, observe u with - | RetF _, RetF _ - | VisF _ _, VisF _ _ - | BrF _ _, _ - | _, BrF _ _ - | GuardF _, _ - | _, GuardF _ - | StepF _, StepF _ - | StuckF, StuckF - => False - | @VisF _ _ _ _ X _ _, StuckF - | StuckF, @VisF _ _ _ _ X _ _ => - inhabited X - | _, _ => True - end. - - Lemma sbisim_absurd {X} (t u : ctree E C X) : - are_bisim_incompat t u -> - t ~ u -> - False. - Proof. - intros * IC EQ. - unfold are_bisim_incompat in IC. - setoid_rewrite ctree_eta in EQ. - genobs t ot. genobs u ou. - destruct ot, ou. - all: try now inv IC. - all: try now unshelve (inv IC; playR in EQ; inv_trans); auto. - all: try now unshelve (inv IC; playL in EQ; inv_trans); auto. - Qed. - - Ltac sb_abs h := - eapply sbisim_absurd; [| eassumption]; cbn; try reflexivity. - - Lemma sbisim_ret_vis_inv {X Y} (r : Y) (e : E X) (k : X -> ctree E C Y) : - (Ret r : ctree E C _) ~ Vis e k -> False. - Proof. - intros * abs. sb_abs abs. - Qed. - - Lemma sbisim_ret_BrS_inv {X Y} (r : Y) (c : C X) (k : X -> ctree E C Y) : - (Ret r : ctree E C _) ~ BrS c k -> False. - Proof. - intros EQ; playL in EQ; inv_trans. - Qed. - -(*| - For this to be absurd, we need one of the return types to be inhabited. -|*) - Lemma sbisim_vis_BrS_inv {X Y Z} - (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2: Y -> ctree E C Z) (y : Y) : - Vis e k1 ~ BrS c k2 -> False. - Proof. - unshelve (intros EQ; playR in EQ; inv_trans); auto. - Qed. - - Lemma sbisim_vis_BrS_inv' {X Y Z} - (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2: Y -> ctree E C Z) (x : X) : - Vis e k1 ~ BrS c k2 -> False. - Proof. - unshelve (intros EQ; playL in EQ; inv_trans); auto. - Qed. - -(*| -Not fond of this, need to give some thoughts about them -|*) - Lemma sbisim_ret_Br_inv {X Y} (r : Y) (c : C X) (k : X -> ctree E C Y) : - (Ret r : ctree E C _) ~ Br c k -> - exists x, (Ret r : ctree E C _) ~ k x. - Proof. - intros EQ; generalize EQ; intros EQ'; playL in EQ; inv_trans. - pose proof trans_val_inv TR as H; rewrite H in TR; clear x0 EQ H. - exists x; play. - - inv_trans; subst. - do 2 eexists; intuition; eauto. - now rewrite EQ. - - playR in EQ'. - apply trans_ret_inv in TR1; intuition; subst. - do 2 eexists; intuition; eauto. - apply trans_val_inv in TR0. - rewrite TR0; eauto. - Qed. - -End WithParams. - -Section StrongSimulations. - - Section Heterogeneous. - - Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. - - Notation ss := (@ss E F C D X Y). - Notation ssim := (@ssim E F C D X Y). - - Lemma sbisim_clos_ss {c: Chain (ss L)}: - forall x y, sbisim_clos (LE := eq) (LF := eq) `c x y -> `c x y. - Proof. - apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - clear. - intros c IH x y []; intros ? ? TR. - step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis & <-). - apply HR in TR; destruct TR as (? & ? & TR & Sbis' & HL). - step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & <-). - do 2 eexists; repeat split; eauto. - apply IH. - econstructor; eauto. - Qed. - -(*| - Instances for rewriting [sbisim] under all [ss]-related contexts -|*) - #[global] Instance sbisim_eq_clos_ss_goal `{R : Chain (ss L)}: - Proper (sbisim eq ==> sbisim eq ==> flip impl) `R. - Proof. - repeat intro. - apply sbisim_clos_ss. - econstructor; [eassumption | | symmetry in H0; eassumption]. - eauto. - Qed. - - #[global] Instance sbisim_eq_clos_ss_ctx `{R : Chain (ss L)} : - Proper (sbisim eq ==> sbisim eq ==> impl) `R. - Proof. - repeat intro. symmetry in H, H0. eapply sbisim_eq_clos_ss_goal; eauto. - Qed. - - #[global] Instance sbisim_eq_clos_ssim_goal: - Proper (sbisim eq ==> sbisim eq ==> flip impl) (ssim L). - Proof. - apply sbisim_eq_clos_ss_goal. - Qed. - - #[global] Instance sbisim_eq_clos_ssim_ctx : - Proper (sbisim eq ==> sbisim eq ==> impl) (ssim L). - Proof. - apply sbisim_eq_clos_ss_ctx. - Qed. - - Lemma ss_sb : forall RR (t : ctree E C X) (t' : ctree F D Y), - ss L RR t t' -> - SSim.ss (flip L) (flip RR) t' t -> - sb L RR t t'. - Proof. - split; cbn; intros. - - apply H in H1 as (? & ? & ? & ? & ?); eauto. - - apply H0 in H1 as (? & ? & ? & ? & ?); eauto. - Qed. - - End Heterogeneous. - - Section two_ss_is_not_sb. - - Lemma split_sb_eq : forall {E C X} RR - (t t' : ctree E C X), - ss eq RR t t' -> - ss eq (flip RR) t' t -> - sb eq RR t t'. - Proof. - intros. - split; eauto. - simpl in *; intros. - destruct (H0 _ _ H1) as (? & ? & ? & ? & ?). - destruct (H _ _ H2) as (? & ? & ? & ? & ?). - subst; eauto. - Qed. - - Lemma split_sbisim_eq : forall {E B X} (t u : ctree E B X), - t ~ u <-> ss eq (sbisim eq) t u /\ ss eq (sbisim eq) u t. - Proof. - split; intro. - - step in H. split; [apply H |]. - symmetry in H. apply H. - - step. split; [apply H |]. - destruct H as [_ ?]. - eapply weq_ss with (y := eq). { cbn. split; auto. } - eapply (Hbody (ss eq)). 2: apply H. - cbn. intros. now symmetry. - Qed. - - #[local] Definition t1 : ctree void1 B2 unit := - Step (Ret tt). - - #[local] Definition t2 : ctree void1 B2 unit := - brS2 (Ret tt) (Stuck). - - Lemma ssim_sbisim_nequiv : - ssim eq t1 t2 /\ ssim eq t2 t1 /\ ~ sbisim eq t1 t2. - Proof. - unfold t1, t2. intuition. - - unfold brS2. - step. - intros ?? TR. - inv_trans; subst. - exists τ, (Ret tt); split. - apply Transbr with true. - constructor; reflexivity. - split; auto. - rewrite EQ; auto. - - step; intros ?? TR. - inv_trans; subst. - exists τ, (Ret tt); intuition; now rewrite EQ. - exists τ, (Ret tt). intuition. - rewrite EQ; apply Stuck_ssim. - - step in H. cbn in H. destruct H as [_ ?]. - specialize (H τ Stuck). lapply H; [| etrans]. - intros. destruct H0 as (? & ? & ? & ? & ?). - inv_trans. step in H1. cbn in H1. destruct H1 as [? _]. - specialize (H0 (val tt) Stuck). lapply H0. - 2: subst; etrans. - intro; destruct H1 as (? & ? & ? & ? & ?). - now apply Stuck_is_stuck in H1. - Qed. - - End two_ss_is_not_sb. - -End StrongSimulations. - -Section CompleteStrongSimulations. - - Context {E F C D: Type -> Type} {X Y: Type} - {L: rel (@label E) (@label F)}. - - Notation css := (@css E F C D X Y). - Notation cssim := (@cssim E F C D X Y). - -(*| -A bisimulation trivially gives a simulation. -|*) - Lemma sb_css : forall RR (t : ctree E C X) (t' : ctree F D Y), - sb L RR t t' -> css L RR t t'. - Proof. - intros; split. - - apply H. - - intros. apply H in H0 as (? & ? & ? & ? & ?). eauto. - Qed. - - Lemma sbisim_clos_css {c: Chain (css L)}: - forall x y, sbisim_clos (LE := eq) (LF := eq) `c x y -> `c x y. - Proof. - apply tower. - - intros ? INC x y [x' y' x'' y'' EQ' EQ''] ??. red. - apply INC; auto. - econstructor; eauto. - apply leq_infx in H. - now apply H. - - clear. - intros c IH x y []; split; intros ? ? TR. - + step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis & <-). - apply HR in TR; destruct TR as (? & ? & TR & Sbis' & HL). - step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & <-). - do 2 eexists; repeat split; eauto. - apply IH. - econstructor; eauto. - + playR in Sbisimu. - apply HR in TR0 as (? & ? & ?). - playR in Sbisimt. - eauto. - Qed. - -(*| - Instances for rewriting [sbisim] under all [css]-related contexts -|*) - #[global] Instance sbisim_eq_clos_css_goal `{R : Chain (css L)}: - Proper (sbisim eq ==> sbisim eq ==> flip impl) `R. - Proof. - repeat intro. - apply sbisim_clos_css. - econstructor; [eassumption | | symmetry in H0; eassumption]. - eauto. - Qed. - - #[global] Instance sbisim_eq_clos_css_ctx `{R : Chain (css L)} : - Proper (sbisim eq ==> sbisim eq ==> impl) `R. - Proof. - repeat intro. symmetry in H, H0. eapply sbisim_eq_clos_css_goal; eauto. - Qed. - - #[global] Instance sbisim_eq_clos_cssim_goal: - Proper (sbisim eq ==> sbisim eq ==> flip impl) (cssim L). - Proof. - apply sbisim_eq_clos_css_goal. - Qed. - - #[global] Instance sbisim_eq_clos_cssim_ctx : - Proper (sbisim eq ==> sbisim eq ==> impl) (cssim L). - Proof. - apply sbisim_eq_clos_css_ctx. - Qed. - - #[global] Instance sbisim_clos_cssim_goal: - Proper (sbisim eq ==> sbisim eq ==> flip impl) (cssim L). - Proof. - cbn; intros; eapply sbisim_clos_css; econstructor; eauto. - now symmetry. - Qed. - - #[global] Instance sbisim_clos_cssim_ctx : - Proper (sbisim eq ==> sbisim eq ==> impl) (cssim L). - Proof. - repeat intro. symmetry in H, H0. eapply sbisim_clos_cssim_goal; eauto. - Qed. - -(*| -A strong bisimulation gives two strong simulations, -but two strong simulations do not always give a strong bisimulation. -This property is true if we only allow choices with 0 or 1 branch, -but we prove a counter-example for a ctree with a binary choice. -|*) - Lemma css_sb : forall RR (t : ctree E C X) (t' : ctree F D Y), - css L RR t t' -> - CSSim.css (flip L) (flip RR) t' t -> - sb L RR t t'. - Proof. - split; cbn; intros. - - apply H in H1 as (? & ? & ? & ? & ?); eauto. - - apply H0 in H1 as (? & ? & ? & ? & ?); eauto. - Qed. - -End CompleteStrongSimulations. - diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index af412e2..c1bb6b2 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -14,7 +14,6 @@ From CTree Require Import CTree Utils Eq.Equ - Eq.Shallow Eq.Trans Eq.Epsilon. diff --git a/theories/Eq/Trans.v b/theories/Eq/Trans.v index a8a4b3d..e26b404 100644 --- a/theories/Eq/Trans.v +++ b/theories/Eq/Trans.v @@ -45,7 +45,7 @@ From ITree Require Import Indexed.Sum. From CTree Require Import - CTree Eq.Shallow Eq.Equ. + CTree Eq.Equ. From RelationAlgebra Require Import monoid diff --git a/theories/Interp/FoldCTree.v b/theories/Interp/FoldCTree.v index 8d0e3ec..ee36bc6 100644 --- a/theories/Interp/FoldCTree.v +++ b/theories/Interp/FoldCTree.v @@ -227,10 +227,10 @@ Section FoldCTree. Proof. now rewrite unfold_refine. Qed. Lemma refine_trigger `{E -< F} (e: E X) : - refine g (trigger e : ctree E C X) ~ (trigger e : ctree F D X). + refine g (trigger e : ctree E C X) ≃ (trigger e : ctree F D X). Proof. rewrite unfold_refine; cbn. - setoid_rewrite sb_guard. + setoid_rewrite sbisim_guard. setoid_rewrite refine_ret. now rewrite bind_ret_r. Qed. @@ -326,7 +326,7 @@ Module CounterExample. #[local] Definition t1 := Ret 1 : ctree VoidE B2 nat. #[local] Definition t2 := br2 (Ret 1) (x <- trigger voidE;; match x : void with end) : ctree VoidE B2 nat. - Goal t1 ~ t2. + Goal t1 ≃ t2. Proof. unfold t1, t2. rewrite br2_commut. @@ -339,7 +339,7 @@ Module CounterExample. intros. destruct X. exact (Step Stuck). Defined. - Example interpE_sbsisim_counterexample : ~ (interp h t1 ~ interp h t2). + Example interpE_sbsisim_counterexample : ~ (interp h t1 ≃ interp h t2). Proof. red. intros. unfold t2 in H. playR in H. From 6b8d6721964260fc29125e9635dd6b835f3ff381 Mon Sep 17 00:00:00 2001 From: Roger Burtonpatel Date: Thu, 1 Oct 2026 09:29:46 -0400 Subject: [PATCH 61/61] Large patch to many files towards full repair. --- examples/AltBisim/BisimExample.v | 2 +- examples/CCS/Denotation.v | 26 +- examples/CCS/OpDenot.v | 12 +- examples/ImpBr/ImpBr.v | 22 +- examples/SimpleSim/SimExample.v | 20 +- examples/Yield/Lang.v | 34 +-- examples/Yield/Par.v | 10 +- examples/Yield/Util.v | 16 +- theories/Eq.v | 16 +- theories/Eq/EpsilonAlt.v | 2 +- theories/Eq/SBisim.v | 96 +++++- theories/Eq/SBisimAlt.v | 3 + theories/Eq/SSim.v | 51 +++- theories/Eq/SSimAlt.v | 2 +- theories/Interp/FoldCTree.v | 8 +- theories/Interp/FoldCTree_scratch.v | 451 ++++++++++++++++++++++++++++ theories/Interp/FoldStateT.v | 4 +- theories/Interp/Refine.v | 12 +- 18 files changed, 685 insertions(+), 102 deletions(-) create mode 100644 theories/Interp/FoldCTree_scratch.v diff --git a/examples/AltBisim/BisimExample.v b/examples/AltBisim/BisimExample.v index 40f23a8..4fd4664 100644 --- a/examples/AltBisim/BisimExample.v +++ b/examples/AltBisim/BisimExample.v @@ -37,7 +37,7 @@ Abort. Theorem bisim_t_u : t ≃ u. Proof. (* We switch to the alternative characterization of bisimulation. *) - rewrite sbisim_sbisim'. + unfold sbisimT; rewrite sbisim_sbisim'. (* The rest of the proof proceeds as before, but this time it succeeds. *) coinduction R CH. intros. cbn [TransEquiv.o2n_S]. rewrite unfold_t, unfold_u. diff --git a/examples/CCS/Denotation.v b/examples/CCS/Denotation.v index 902db66..5958a35 100644 --- a/examples/CCS/Denotation.v +++ b/examples/CCS/Denotation.v @@ -1063,25 +1063,25 @@ Qed. Section Theory. - Lemma plsC: forall (p q : ccs), p+q ~ q+p. + Lemma plsC: forall (p q : ccs), p+q ≃ q+p. Proof. apply br2_commut. Qed. - Lemma plsA (p q r : ccs): p+(q+r) ~ (p+q)+r. + Lemma plsA (p q r : ccs): p+(q+r) ≃ (p+q)+r. Proof. symmetry; apply br2_assoc. Qed. - Lemma pls0p (p : ccs) : 0 + p ~ p. + Lemma pls0p (p : ccs) : 0 + p ≃ p. Proof. apply br2_stuck_l. Qed. - Lemma plsp0 (p : ccs) : p + 0 ~ p. + Lemma plsp0 (p : ccs) : p + 0 ≃ p. Proof. now rewrite plsC, pls0p. Qed. - Lemma plsidem (p : ccs) : p + p ~ p. + Lemma plsidem (p : ccs) : p + p ≃ p. Proof. apply br2_idem. Qed. @@ -1093,7 +1093,7 @@ Section Theory. all:rewrite eqb_sym; auto. Qed. - Lemma paraC: forall (p q : ccs), p ∥ q ~ q ∥ p. + Lemma paraC: forall (p q : ccs), p ∥ q ≃ q ∥ p. Proof. coinduction r CIH; symmetric. intros p q ? ? tr. @@ -1113,7 +1113,7 @@ Section Theory. reflexivity. Qed. - Lemma para0p : forall (p : ccs), 0 ∥ p ~ p. + Lemma para0p : forall (p : ccs), 0 ∥ p ≃ p. Proof. coinduction R CIH. intros. @@ -1130,12 +1130,12 @@ Section Theory. cbn; auto. Qed. - Lemma parap0 : forall (p : ccs), p ∥ 0 ~ p. + Lemma parap0 : forall (p : ccs), p ∥ 0 ≃ p. Proof. intros; rewrite paraC; apply para0p. Qed. - Lemma paraA : forall (p q r : ccs), p ∥ (q ∥ r) ~ (p ∥ q) ∥ r. + Lemma paraA : forall (p q r : ccs), p ∥ (q ∥ r) ≃ (p ∥ q) ∥ r. Proof. coinduction r CIH; intros. split. @@ -1194,7 +1194,7 @@ Section Theory. End Theory. Lemma para_parabang : forall p q r, - parabang (p ∥ q) r ~ p ∥ parabang q r. + parabang (p ∥ q) r ≃ p ∥ parabang q r. Proof. coinduction R CIH. intros; split. @@ -1310,7 +1310,7 @@ Proof. Qed. Lemma parabang_aux : forall p q, - parabang (p ∥ q) q ~ parabang p q. + parabang (p ∥ q) q ≃ parabang p q. Proof. coinduction R CIH. split. @@ -1381,7 +1381,7 @@ Proof. Qed. Lemma parabang_eq : forall p q, - parabang p q ~ p ∥ !q. + parabang p q ≃ p ∥ !q. Proof. coinduction R CIH. intros p q; split. @@ -1451,7 +1451,7 @@ Proof. Qed. Lemma unfold_bang' : forall p, - !p ~ !p ∥ p. + !p ≃ !p ∥ p. Proof. intros; unfold bang at 1. rewrite parabang_eq. rewrite paraC; reflexivity. diff --git a/examples/CCS/OpDenot.v b/examples/CCS/OpDenot.v index 86917a9..426d449 100644 --- a/examples/CCS/OpDenot.v +++ b/examples/CCS/OpDenot.v @@ -103,7 +103,7 @@ Proof. exists R; split; auto. Qed. -Definition bisim_model := fun P (q: ccs) => ⟦P⟧ ~ q. +Definition bisim_model := fun P (q: ccs) => ⟦P⟧ ≃ q. Lemma complete : forward bisim_model. Proof. @@ -321,7 +321,7 @@ Lemma cross_model_compose : forall T t u U, bisimilar t T -> Operational.bisim t u -> bisimilar u U -> - T ~ U. + T ≃ U. Proof. coinduction r cih. intros * EQtT EQtu EQuU. @@ -343,7 +343,7 @@ Qed. Lemma cross_model_compose' : forall T t u U, bisimilar t T -> - T ~ U -> + T ≃ U -> bisimilar u U -> Operational.bisim t u. Proof. @@ -373,7 +373,7 @@ Proof. red; intros; edestruct F; eauto. Qed. -Lemma embed_sound : forall t u, Operational.bisim t u -> ⟦t⟧ ~ ⟦u⟧. +Lemma embed_sound : forall t u, Operational.bisim t u -> ⟦t⟧ ≃ ⟦u⟧. Proof. intros * BIS. apply (gfp_fp b t u) in BIS; destruct BIS as [F B]; cbn in *. @@ -402,7 +402,7 @@ Proof. eapply cross_model_compose; eauto. Qed. -Lemma embed_complete : forall t u, ⟦t⟧ ~ ⟦u⟧ -> Operational.bisim t u. +Lemma embed_complete : forall t u, ⟦t⟧ ≃ ⟦u⟧ -> Operational.bisim t u. Proof. intros * BIS. step in BIS; destruct BIS as [F B]; cbn in *. @@ -431,7 +431,7 @@ Proof. eapply cross_model_compose'; eauto. Qed. -Theorem equiv_bisims : forall t u, ⟦t⟧ ~ ⟦u⟧ <-> Operational.bisim t u. +Theorem equiv_bisims : forall t u, ⟦t⟧ ≃ ⟦u⟧ <-> Operational.bisim t u. Proof. intros; split; eauto using embed_complete, embed_sound. Qed. diff --git a/examples/ImpBr/ImpBr.v b/examples/ImpBr/ImpBr.v index 9f590e9..681d67a 100755 --- a/examples/ImpBr/ImpBr.v +++ b/examples/ImpBr/ImpBr.v @@ -137,41 +137,41 @@ Section Theory. at the level of uninterpreted ctrees. |*) Lemma branch_commut : forall (a b : stmt), - ⟦Branch a b⟧ ~ ⟦Branch b a⟧. + ⟦Branch a b⟧ ≃ ⟦Branch b a⟧. Proof. intros; apply br2_commut. Qed. Lemma branch_assoc : forall (a b c : stmt), - ⟦Branch a (Branch b c)⟧ ~ ⟦Branch (Branch a b) c⟧. + ⟦Branch a (Branch b c)⟧ ≃ ⟦Branch (Branch a b) c⟧. Proof. intros; cbn. now rewrite br2_assoc. Qed. Lemma branch_idem : forall a : stmt, - ⟦Branch a a⟧ ~ ⟦a⟧. + ⟦Branch a a⟧ ≃ ⟦a⟧. Proof. intros; apply br2_idem. Qed. Lemma branch_congr : forall a a' b b', - ⟦a⟧ ~ ⟦a'⟧ -> - ⟦b⟧ ~ ⟦b'⟧ -> - ⟦Branch a b⟧ ~ ⟦Branch a' b'⟧. + ⟦a⟧ ≃ ⟦a'⟧ -> + ⟦b⟧ ≃ ⟦b'⟧ -> + ⟦Branch a b⟧ ≃ ⟦Branch a' b'⟧. Proof. - intros. cbn. apply sb_br_id. + intros. cbn. apply sbisim_br_id. intro; destruct x; rewrite ?H, ?H0; reflexivity. Qed. Lemma branch_block_l : forall a : stmt, - ⟦Branch Block a⟧ ~ ⟦a⟧. + ⟦Branch Block a⟧ ≃ ⟦a⟧. Proof. intros; apply br2_stuck_l. Qed. Lemma branch_block_r : forall a : stmt, - ⟦Branch a Block⟧ ~ ⟦a⟧. + ⟦Branch a Block⟧ ≃ ⟦a⟧. Proof. intros; apply br2_stuck_r. Qed. @@ -189,7 +189,7 @@ Section Theory. Qed. Lemma branch_block_r_interp : forall (a : stmt) s, - ℑ (Branch a Block) s ~ + ℑ (Branch a Block) s ≃ ℑ a s. Proof. intros. @@ -222,7 +222,7 @@ from Section 2 are indeed equivalent. (Seq (Assign "x" (Lit 0)) (Assign "x" (Lit 1))) - Block) s ~ + Block) s ≃ ℑ (Assign "x" (Lit 1)) s. Proof with (unfold interp_imp). intros... diff --git a/examples/SimpleSim/SimExample.v b/examples/SimpleSim/SimExample.v index 2e09e1e..b965693 100644 --- a/examples/SimpleSim/SimExample.v +++ b/examples/SimpleSim/SimExample.v @@ -43,27 +43,27 @@ Theorem sim_t_u : t ≲ u. Proof. coinduction R CH. rewrite unfold_t, unfold_u. - apply step_ss_br_r with (x := true). - apply step_ss_vis_id. intros []. split; auto. + apply ss_br_r with (x := true). + apply ss_vis_eq. intros []. rewrite unfold_u. - step. apply step_ss_br_r with (x := false). - apply step_ss_vis_id. intros []. split; [| auto]. + step. apply ss_br_r with (x := false). + apply ss_vis_eq. intros []. apply CH. Qed. -Theorem bisim_u_u' : u ~ u'. +Theorem bisim_u_u' : u ≃ u'. Proof. coinduction R CH. rewrite unfold_u, unfold_u'. unfold br2. rewrite bind_br. - apply step_sb_br_id. intros. + apply sb_br_id. intros. destruct x. - rewrite bind_trigger. - apply step_sb_vis_id. intros []. split; [| auto]. - rewrite sb_guard. + apply sb_vis_eq. intros []. + rewrite sbisim_guard. apply CH. - rewrite bind_trigger. - apply step_sb_vis_id. intros []. split; [| auto]. - rewrite sb_guard. + apply sb_vis_eq. intros []. + rewrite sbisim_guard. apply CH. Qed. diff --git a/examples/Yield/Lang.v b/examples/Yield/Lang.v index 6301837..8f2fcc2 100644 --- a/examples/Yield/Lang.v +++ b/examples/Yield/Lang.v @@ -197,12 +197,12 @@ Section Denote1. Qed. Lemma schedule_order (t1 t1' t2 t2' : ctree E void1 unit) - (Ht1 : t1 ~ t1') - (Ht2 : t2 ~ t2') : + (Ht1 : t1 ≃ t1') + (Ht2 : t2 ≃ t2') : BrS (branchn 2) (fun i' : fin 2 => schedule 2 (cons_vec t1 (fun _ => t2)) - (Some i')) ~ + (Some i')) ≃ BrS (branchn 2) (fun i' : fin 2 => schedule 2 (cons_vec t2' (fun _ => t1')) @@ -219,12 +219,12 @@ Section Denote1. Qed. Lemma schedule_order' (t1 t1' t2 t2' : ctree E void1 unit) - (Ht1 : t1 ~ t1') - (Ht2 : t2 ~ t2') : + (Ht1 : t1 ≃ t1') + (Ht2 : t2 ≃ t2') : Br (branchn 2) (fun i' : fin 2 => schedule 2 (cons_vec t1 (fun _ => t2)) - (Some i')) ~ + (Some i')) ≃ Br (branchn 2) (fun i' : fin 2 => schedule 2 (cons_vec t2' (fun _ => t1')) @@ -241,9 +241,9 @@ Section Denote1. Qed. Lemma schedule_order'' (t1 t1' t2 t2' : ctree E void1 unit) - (Ht1 : t1 ~ t1') - (Ht2 : t2 ~ t2') : - schedule 2 (cons_vec t1 (fun _ => t2)) None ~ + (Ht1 : t1 ≃ t1') + (Ht2 : t2 ≃ t2') : + schedule 2 (cons_vec t1 (fun _ => t2)) None ≃ schedule 2 (cons_vec t2' (fun _ => t1')) None. Proof. do 2 rewrite rewrite_schedule. simp schedule_match. @@ -251,7 +251,7 @@ Section Denote1. Qed. Lemma commut_forks s1 s2 : - interp_concurrency (Fork s1 (Fork s2 Skip)) ~ + interp_concurrency (Fork s1 (Fork s2 Skip)) ≃ interp_concurrency (Fork s2 (Fork s1 Skip)). Proof. unfold interp_concurrency. @@ -325,7 +325,7 @@ Section Denote1. Qed. Lemma br1_guard {F X} (t : ctree F Bn X) : - br1 t ~ Guard t. + br1 t ≃ Guard t. Proof. step; split; intros ?? TR; inv_trans. - exists l, t'; split; [| split]; etrans. @@ -336,7 +336,7 @@ Section Denote1. (* first one has one more yield *) Lemma yield_yield_fork s : - interp_yield (interp_spawn (interp_concurrency (Seq YieldS (Seq YieldS s)))) ~ + interp_yield (interp_spawn (interp_concurrency (Seq YieldS (Seq YieldS s)))) ≃ interp_yield (interp_spawn (interp_concurrency (Fork s Skip))). Proof. rewrite yield_equ, fork_skip_equ. @@ -355,7 +355,7 @@ Section Denote1. Qed. Lemma fork_skip_yield s : - interp_spawn (interp_concurrency (Seq YieldS s)) ~ + interp_spawn (interp_concurrency (Seq YieldS s)) ≃ interp_spawn (interp_concurrency (Fork s Skip)). Proof. rewrite yield_equ, fork_skip_equ. @@ -366,7 +366,7 @@ Section Denote1. Qed. Lemma spawn_skip s : - interp_yield (interp_spawn (interp_concurrency (Fork s Skip))) ~ + interp_yield (interp_spawn (interp_concurrency (Fork s Skip))) ≃ interp_yield (interp_spawn (interp_concurrency s)). Proof. rewrite fork_skip_equ. @@ -378,7 +378,7 @@ Section Denote1. Qed. Lemma while_true_unfold_sbisim s1 : - denote_imp (While (Lit 1%nat) s1) ~ denote_imp s1;; denote_imp (While (Lit 1%nat) s1). + denote_imp (While (Lit 1%nat) s1) ≃ denote_imp s1;; denote_imp (While (Lit 1%nat) s1). Proof. cbn. unfold while. rewrite unfold_iter at 1. rewrite bind_ret_l. unfold is_true. @@ -389,7 +389,7 @@ Section Denote1. Qed. Lemma commut_forks_unfold s : - interp_concurrency (Fork (While (Lit 1%nat) YieldS) (Fork s Skip)) ~ + interp_concurrency (Fork (While (Lit 1%nat) YieldS) (Fork s Skip)) ≃ interp_concurrency (Fork s (Fork (Seq YieldS (While (Lit 1%nat) YieldS)) Skip)). Proof. unfold interp_concurrency. @@ -473,7 +473,7 @@ Section Denote1. Lemma interp_fork_assign_assign s : interp_imp (Fork (Assign "x" (Lit 2)) - (Assign "x" (Lit 1%nat))) s ~ + (Assign "x" (Lit 1%nat))) s ≃ interp_imp (Assign "x" (Lit 2)) s. Proof. unfold interp_imp. diff --git a/examples/Yield/Par.v b/examples/Yield/Par.v index 15f6152..9d1ab27 100644 --- a/examples/Yield/Par.v +++ b/examples/Yield/Par.v @@ -682,9 +682,9 @@ Section parallel. Lemma schedule_permutation n (v1 v2 : vec n) i (p q : fin n -> fin n) (Hpq : forall i, p (q i) = i) (Hqp : forall i, q (p i) = i) - (Hsb1 : forall i, v1 i ~ v2 (p i)) - (Hsb2 : forall i, v2 i ~ v1 (q i)) : - schedule n v1 (Some i) ~ schedule n v2 (Some (p i)). + (Hsb1 : forall i, v1 i ≃ v2 (p i)) + (Hsb2 : forall i, v2 i ≃ v1 (q i)) : + schedule n v1 (Some i) ≃ schedule n v2 (Some (p i)). Proof. revert n v1 v2 i p q Hpq Hqp Hsb1 Hsb2. coinduction r CIH. @@ -882,8 +882,8 @@ Section parallel. Definition perm_id {n} : fin n -> fin n := fun i => i. Lemma sbisim_schedule n (v1 v2 : vec n) i - (Hsb : forall i, v1 i ~ v2 i) : - schedule n v1 (Some i) ~ schedule n v2 (Some i). + (Hsb : forall i, v1 i ≃ v2 i) : + schedule n v1 (Some i) ≃ schedule n v2 (Some i). Proof. replace i with (perm_id i) at 2; auto. eapply schedule_permutation; auto. symmetry. auto. diff --git a/examples/Yield/Util.v b/examples/Yield/Util.v index 40b22cd..60b6c78 100644 --- a/examples/Yield/Util.v +++ b/examples/Yield/Util.v @@ -44,8 +44,8 @@ Import CTreeNotations. Lemma sbisim_vis_visible {E R X} (t2 : ctree E void1 R) (e : E X) (k1 : X -> ctree E void1 R) (Hin: inhabited X) : - Vis e k1 ~ t2 -> - exists k2, visible t2 (Vis e k2) /\ (forall x, k1 x ~ k2 x). + Vis e k1 ≃ t2 -> + exists k2, visible t2 (Vis e k2) /\ (forall x, k1 x ≃ k2 x). Proof. unfold trans in *; intros. step in H. destruct H as [Hf Hb]. @@ -85,9 +85,9 @@ Qed. Lemma sbisim_visible {E R X} (t1 t2 : ctree E void1 R) (e : E X) (k1 : X -> ctree E void1 R) (Hin: inhabited X) : - t1 ~ t2 -> + t1 ≃ t2 -> visible t1 (Vis e k1) -> - exists k2, visible t2 (Vis e k2) /\ (forall x, k1 x ~ k2 x). + exists k2, visible t2 (Vis e k2) /\ (forall x, k1 x ≃ k2 x). Proof. unfold trans; intros. cbn in *. red in H0. remember (observe t1). remember (observe (Vis e k1)). revert X t1 e k1 t2 H Heqc Heqc0 Hin. @@ -1018,10 +1018,10 @@ Section Vector_brD_bound. (Hqp : forall i, q (p i) = i) (Hpq' : forall i, p' (q' i) = i) (Hqp' : forall i, q' (p' i) = i) - (Hsb1 : forall i, v1 i ~ v2 (p i)) - (Hsb2 : forall i, v2 i ~ v1 (q i)) : - (forall j, remove_vec v1 i j ~ remove_vec v2 (p i) (p' j)) /\ - (forall j, remove_vec v2 (p i) j ~ remove_vec v1 i (q' j)). + (Hsb1 : forall i, v1 i ≃ v2 (p i)) + (Hsb2 : forall i, v2 i ≃ v1 (q i)) : + (forall j, remove_vec v1 i j ≃ remove_vec v2 (p i) (p' j)) /\ + (forall j, remove_vec v2 (p i) j ≃ remove_vec v1 i (q' j)). Proof. split; intros j. { diff --git a/theories/Eq.v b/theories/Eq.v index fd2a535..78e8fcb 100644 --- a/theories/Eq.v +++ b/theories/Eq.v @@ -57,10 +57,10 @@ Ltac __concl_is t := [ __concl_is ltac:(lazymatch goal with |- equ _ _ _ => idtac end); first [ __coinduction_equ R H | fail 2 "coinduction: the conclusion is an equ goal, but coinduction on equ failed" ] - | __concl_is ltac:(lazymatch goal with |- sbisim _ _ _ => idtac end); + | __concl_is ltac:(lazymatch goal with |- sbisim _ _ _ => idtac | |- sbisimT _ _ _ => idtac end); first [ __coinduction_sbisim R H | fail 2 "coinduction: the conclusion is an sbisim goal, but coinduction on sbisim failed" ] - | __concl_is ltac:(lazymatch goal with |- ssim _ _ _ => idtac end); + | __concl_is ltac:(lazymatch goal with |- ssim _ _ _ => idtac | |- ssimT _ _ _ => idtac end); first [ __coinduction_ssim R H | fail 2 "coinduction: the conclusion is an ssim goal, but coinduction on ssim failed" ] | __concl_is ltac:(lazymatch goal with |- cssim _ _ _ => idtac end); @@ -116,16 +116,16 @@ The upto [Vis] context principle for [sbisim] (* |*) *) #[global] Tactic Notation "upto_bind" := - first [ __eupto_bind_equ | __eupto_bind_sbisim' - | fail "upto_bind: the goal is not an equ or sbisim' goal (or chain element of one) relating two binds" ]. + first [ __eupto_bind_equ | __eupto_bind_sbisim | __eupto_bind_sbisim' + | fail "upto_bind: the goal is not an equ, sbisim or sbisim' goal (or chain element of one) relating two binds" ]. #[global] Tactic Notation "upto_bind_eq" := - first [ __upto_bind_equ_eq | __upto_bind_sbisim'_eq - | fail "upto_bind_eq: the goal is not an equ or sbisim' goal (or chain element of one) relating two binds with the same prefix" ]. + first [ __upto_bind_equ_eq | __upto_bind_sbisim_eq | __upto_bind_sbisim'_eq + | fail "upto_bind_eq: the goal is not an equ, sbisim or sbisim' goal (or chain element of one) relating two binds with the same prefix" ]. #[global] Tactic Notation "upto_bind" "with" uconstr(SS) := - first [ __upto_bind_equ SS | __upto_bind_sbisim' SS - | fail "upto_bind with: the goal is not an equ or sbisim' goal (or chain element of one) relating two binds" ]. + first [ __upto_bind_equ SS | __upto_bind_sbisim SS | __upto_bind_sbisim' SS + | fail "upto_bind with: the goal is not an equ, sbisim or sbisim' goal (or chain element of one) relating two binds" ]. (*| diff --git a/theories/Eq/EpsilonAlt.v b/theories/Eq/EpsilonAlt.v index 8868ea0..082c562 100644 --- a/theories/Eq/EpsilonAlt.v +++ b/theories/Eq/EpsilonAlt.v @@ -5,7 +5,7 @@ From CTree Require Import Eq.Equ Eq.TransAlt. -From RelationAlgebra Require Export +From RelationAlgebra Require Import monoid kat kat_tac rel srel. From Coinduction Require Import all. diff --git a/theories/Eq/SBisim.v b/theories/Eq/SBisim.v index 5e46af5..f2f4a2e 100644 --- a/theories/Eq/SBisim.v +++ b/theories/Eq/SBisim.v @@ -44,6 +44,7 @@ From CTree Require Import CTree Utils Eq.Equ + Eq.Shallow Eq.Trans Eq.Epsilon Eq.SSim. @@ -88,12 +89,15 @@ End StrongBisim. Definition sbisim {E F C D X Y} L := (gfp (@sb E F C D X Y L) : hrel _ _). +Definition sbisimT {E F C D X Y} (L : lrel E F X Y) (t : ctree E C X) (u : ctree F D Y) : Prop := + sbisim L (Active t) (Active u). + Module SBisimNotations. Notation sbisimeq := (sbisim Leq). - Infix "≃" := (sbisim Leq) (at level 70). - Notation "t (≃ [ Q ] ) u" := (sbisim (Lvrel Q) t u) (at level 79). - Notation "t (≃ L ) u" := (sbisim L t u) (at level 79). + Infix "≃" := (sbisimT Leq) (at level 70). + Notation "t (≃ [ Q ] ) u" := (sbisimT (Lvrel Q) t u) (at level 79). + Notation "t (≃ L ) u" := (sbisimT L t u) (at level 79). Notation "t '[≃]' u" := (sb Leq _ t u) (at level 90, only printing). Notation "t '[≃' [ R ] ']' u" := (sb (Lvrel R) _ t u) (at level 90, only printing). @@ -144,6 +148,7 @@ Ltac fold_sbisim := end. Tactic Notation "__step_sbisim" := + (try unfold sbisimT); match goal with | |- context[@sbisim ?E ?F ?C ?D ?X ?Y ?L] => unfold sbisim; @@ -153,6 +158,7 @@ Tactic Notation "__step_sbisim" := #[local] Tactic Notation "step" := __step_sbisim || __step_ssim || step. Ltac __step_in_sbisim H := + (try unfold sbisimT in H); match type of H with | context[@sbisim ?E ?F ?C ?D ?X ?Y ?L] => unfold sbisim in H; @@ -162,6 +168,7 @@ Ltac __step_in_sbisim H := #[local] Tactic Notation "step" "in" ident(H) := __step_in_sbisim H || step in H. Tactic Notation "__coinduction_sbisim" simple_intropattern(r) simple_intropattern(cih) := + (try unfold sbisimT); first [unfold sbisim at 4 | unfold sbisim at 3 | unfold sbisim at 2 | unfold sbisim at 1]; coinduction r cih. #[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_sbisim r cih || __coinduction_ssim r cih || coinduction r cih. @@ -185,12 +192,14 @@ Ltac __playR_sbisim H := Ltac __eplayL_sbisim := match goal with | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => __playL_sbisim h + | h : @sbisimT ?E _ ?C _ ?X _ ?RR _ _ |- _ => __playL_sbisim h | h : body (sb ?L) ?R _ _ |- _ => __playL_sbisim h end. Ltac __eplayR_sbisim := match goal with | h : @sbisim ?E _ ?C _ ?X _ ?RR _ _ |- _ => __playR_sbisim h + | h : @sbisimT ?E _ ?C _ ?X _ ?RR _ _ |- _ => __playR_sbisim h | h : body (sb ?L) ?R _ _ |- _ => __playR_sbisim h end. @@ -273,6 +282,14 @@ Section sbisim_homogenous_theory. End sbisim_homogenous_theory. +#[global] Instance sbisimT_equiv {E C X} : Equivalence (@sbisimT E E C C X X Leq). +Proof. + unfold sbisimT; split; red; intros. + - reflexivity. + - now symmetry. + - etransitivity; eauto. +Qed. + (*| Heterogeneous theory -------------------- @@ -472,6 +489,14 @@ Section sbisim_heterogenous_theory. End sbisim_heterogenous_theory. +#[global] Instance sbisimT_goal {E F C D X Y} {L : lrel E F X Y} : + Proper (sbisimT Leq ==> sbisimT Leq ==> iff) (@sbisimT E F C D X Y L). +Proof. + unfold sbisimT; intros t t' Ht u u' Hu; split; intros H. + - eapply (@sbisim_chain_goal E F C D X Y L (chain_gfp _)); [symmetry; exact Ht | symmetry; exact Hu | exact H]. + - eapply (@sbisim_chain_goal E F C D X Y L (chain_gfp _)); [exact Ht | exact Hu | exact H]. +Qed. + (* TODO (?) : generalize Lemma equ_sbisim_subrelation_gen {E B X Y} (RR : rel X Y) : forall x y, SeqR RR x y -> @sbisim E E B B X Y (Lvrel RR) x y. @@ -1291,7 +1316,7 @@ Inversion principles Lemma sbisim_step_l_inv L (t : ctree E C X) (u : ctree F D Y) : (Step t) (≃ L) u -> - exists u', trans τ u u' /\ t (≃ L) u'. + exists u', trans τ u u' /\ sbisim L t u'. Proof. intros. eplayL. invL. @@ -1300,7 +1325,7 @@ Inversion principles Lemma sbisim_step_r_inv L (t : ctree E C X) (u : ctree F D Y) : t (≃ L) (Step u) -> - exists t', trans τ t t' /\ t' (≃ L) u. + exists t', trans τ t t' /\ sbisim L t' u. Proof. intros. eplayR. invL. @@ -1323,7 +1348,7 @@ Inversion principles Lemma sbisim_brS_l_inv L {A} (c : C A) (k1 : A -> ctree E C X) (u : ctree F D Y) : (BrS c k1) (≃ L) u -> - forall a, exists u', trans τ u u' /\ (k1 a) (≃ L) u'. + forall a, exists u', trans τ u u' /\ sbisim L (k1 a) u'. Proof. intros. unshelve eplayL; auto; inv_trans; invL; eauto. @@ -1332,7 +1357,7 @@ Inversion principles Lemma sbisim_brS_r_inv L {B} (d : D B) (k2 : B -> ctree F D Y) (t : ctree E C X) : t (≃ L) (BrS d k2) -> - forall b, exists t', trans τ t t' /\ t' (≃ L) (k2 b). + forall b, exists t', trans τ t t' /\ sbisim L t' (k2 b). Proof. intros. unshelve eplayR; auto; inv_trans; invL; eauto. @@ -1684,3 +1709,60 @@ Proof. - now rewrite H. - rewrite H0. rewrite sbisim_guard. apply IHepsilon_det. Qed. + +#[global] Instance equ_sbisimT {E C X} : + subrelation (equ eq) (@sbisimT E E C C X X Leq). +Proof. intros t u EQ; apply equ_sbisim_subrelation; now constructor. Qed. + +#[global] Instance Active_sbisimT {E C X} : + Proper (sbisimT Leq ==> @sbisim E E C C X X Leq) Active. +Proof. intros t u H; exact H. Qed. + +#[global] Instance bind_sbisimT {E C X Y} : + Proper (sbisimT Leq ==> pointwise_relation X (sbisimT Leq) ==> sbisimT Leq) (@bind E C X Y). +Proof. intros t t' Ht k k' Hk; now apply sbisim_bind_eq. Qed. + +#[global] Instance GuardF_sbisimT {E C X} : + Proper (sbisimT Leq ==> going (sbisimT Leq)) (@GuardF E C X _). +Proof. intros t u H; constructor; now rewrite !sbisim_guard. Qed. + +#[global] Instance StepF_sbisimT {E C X} : + Proper (sbisimT Leq ==> going (sbisimT Leq)) (@StepF E C X _). +Proof. intros t u H; constructor; now apply sbisim_step. Qed. + +#[global] Instance BrF_sbisimT {E C X Z} (c : C Z) : + Proper (pointwise_relation Z (sbisimT Leq) ==> going (sbisimT Leq)) (@BrF E C X _ Z c). +Proof. intros k k' H; constructor; now apply sbisim_br_id. Qed. + +#[global] Instance VisF_sbisimT {E C X Z} (e : E Z) : + Proper (pointwise_relation Z (sbisimT Leq) ==> going (sbisimT Leq)) (@VisF E C X _ Z e). +Proof. intros k k' H; constructor; apply sbisim_vis_id; [constructor | intros z; split; [apply H | constructor]]. Qed. + +#[global] Instance sbisimT_ssimT_goal {E F C D X Y} {L : lrel E F X Y} : + Proper (sbisimT Leq ==> sbisimT Leq ==> flip impl) (@ssimT E F C D X Y L). +Proof. intros t t' Ht u u' Hu H; unfold ssimT in *; now rewrite Ht, Hu. Qed. + +Lemma sb_vis_eq {E C X Z} (e : E Z) (k k' : Z -> ctree E C X) + {R : Chain (@sb E E C C X X Leq)} : + (forall z, ` R (k z) (k' z)) -> + sb Leq ` R (Vis e k) (Vis e k'). +Proof. intros; apply sb_vis_id; [constructor | intros z; split; [auto | constructor]]. Qed. + +Lemma sbisim_clo_bind_eq {E C X Y} (t : ctree E C X) (k1 k2 : X -> ctree E C Y) : + (forall x, k1 x ≃ k2 x) -> t >>= k1 ≃ t >>= k2. +Proof. intros; apply sbisim_bind_eq; [reflexivity | auto]. Qed. + +Lemma sbisim_clo_bind_gen_eq {E C X Y} {R : Chain (@sb E E C C Y Y Leq)} + (t : ctree E C X) (k1 k2 : X -> ctree E C Y) : + (forall x, ` R (k1 x) (k2 x)) -> ` R (t >>= k1) (t >>= k2). +Proof. intros; apply bind_chain_eq; [reflexivity | auto]. Qed. + +Ltac __upto_bind_sbisim_with R := + first [apply sbisim_bind_gen with (SS := R) | apply bind_chain_gen with (SS := R)]. +Tactic Notation "__upto_bind_sbisim" uconstr(t) := __upto_bind_sbisim_with t. + +Ltac __eupto_bind_sbisim := + first [eapply sbisim_bind_gen | eapply bind_chain_gen]. + +Ltac __upto_bind_sbisim_eq := + first [apply sbisim_clo_bind_eq | apply sbisim_clo_bind_gen_eq]. diff --git a/theories/Eq/SBisimAlt.v b/theories/Eq/SBisimAlt.v index 4eeff09..39ff54f 100644 --- a/theories/Eq/SBisimAlt.v +++ b/theories/Eq/SBisimAlt.v @@ -23,6 +23,9 @@ From CTree Require Import From RelationAlgebra Require Export rel srel. +From RelationAlgebra Require Import + monoid kat kat_tac. + Import CoindNotations. Import CTree. Set Implicit Arguments. diff --git a/theories/Eq/SSim.v b/theories/Eq/SSim.v index c1bb6b2..95b68c9 100644 --- a/theories/Eq/SSim.v +++ b/theories/Eq/SSim.v @@ -14,6 +14,7 @@ From CTree Require Import CTree Utils Eq.Equ + Eq.Shallow Eq.Trans Eq.Epsilon. @@ -88,12 +89,15 @@ End StrongSim. Definition ssim {E F C D X Y} L := (gfp (@ss E F C D X Y L): hrel _ _). +Definition ssimT {E F C D X Y} (L : lrel E F X Y) (t : ctree E C X) (u : ctree F D Y) : Prop := + ssim L (Active t) (Active u). + (* TODO : TESTER LVREL COERCION *) Module SSimNotations. - Infix "≲" := (ssim Leq) (at level 70). - Notation "t (≲ [ Q ] ) u" := (ssim (Lvrel Q) t u) (at level 79). - Notation "t (≲ Q ) u" := (ssim Q t u) (at level 79). + Infix "≲" := (ssimT Leq) (at level 70). + Notation "t (≲ [ Q ] ) u" := (ssimT (Lvrel Q) t u) (at level 79). + Notation "t (≲ Q ) u" := (ssimT Q t u) (at level 79). Notation "t '[≲]' u" := (ss Leq (` _) t u) (at level 90, only printing). Notation "t '[≲' [ R ] ']' u" := (ss (Lvrel R) (` _) t u) (at level 90, only printing). @@ -114,6 +118,7 @@ Import CTreeNotations. Import EquNotations. Tactic Notation "__step_ssim" := + (try unfold ssimT); match goal with | |- context[@ssim ?E ?F ?C ?D ?X ?Y ?LR] => unfold ssim; @@ -124,6 +129,7 @@ Tactic Notation "__step_ssim" := #[local] Tactic Notation "step" := __step_ssim || step. Ltac __step_in_ssim H := + (try unfold ssimT in H); match type of H with | context[@ssim ?E ?F ?C ?D ?X ?Y ?LR] => unfold ssim in H; @@ -134,6 +140,7 @@ Ltac __step_in_ssim H := #[local] Tactic Notation "step" "in" ident(H) := __step_in_ssim H || step in H. Tactic Notation "__coinduction_ssim" simple_intropattern(r) simple_intropattern(cih) := + (try unfold ssimT); first [unfold ssim at 4 | unfold ssim at 3 | unfold ssim at 2 | unfold ssim at 1]; coinduction r cih. #[local] Tactic Notation "coinduction" simple_intropattern(r) simple_intropattern(cih) := __coinduction_ssim r cih || coinduction r cih. @@ -147,6 +154,7 @@ Ltac __play_ssim_in H := Ltac __eplay_ssim := match goal with | h : ssim ?L ?u ?v |- _ => __play_ssim_in h + | h : ssimT ?L ?u ?v |- _ => __play_ssim_in h | h : body (ss ?L) ?R ?u ?v |- _ => __play_ssim_in h end. @@ -1236,3 +1244,40 @@ Section ssim_epsilon. Qed. End ssim_epsilon. + +#[global] Instance ssimT_preorder {E C X} : PreOrder (@ssimT E E C C X X Leq). +Proof. + unfold ssimT; split; red; intros. + - reflexivity. + - etransitivity; eauto. +Qed. + +#[global] Instance Active_ssimT {E C X} : + Proper (ssimT Leq ==> @ssim E E C C X X Leq) Active. +Proof. intros t u H; exact H. Qed. + +#[global] Instance bind_ssimT {E C X Y} : + Proper (ssimT Leq ==> pointwise_relation X (ssimT Leq) ==> ssimT Leq) (@bind E C X Y). +Proof. intros t t' Ht k k' Hk; now apply ssim_bind_eq. Qed. + +#[global] Instance GuardF_ssimT {E C X} : + Proper (ssimT Leq ==> going (ssimT Leq)) (@GuardF E C X _). +Proof. intros t u H; constructor; now apply ssim_guard. Qed. + +#[global] Instance StepF_ssimT {E C X} : + Proper (ssimT Leq ==> going (ssimT Leq)) (@StepF E C X _). +Proof. intros t u H; constructor; now apply ssim_step. Qed. + +#[global] Instance BrF_ssimT {E C X Z} (c : C Z) : + Proper (pointwise_relation Z (ssimT Leq) ==> going (ssimT Leq)) (@BrF E C X _ Z c). +Proof. intros k k' H; constructor; now apply ssim_br_id. Qed. + +#[global] Instance VisF_ssimT {E C X Z} (e : E Z) : + Proper (pointwise_relation Z (ssimT Leq) ==> going (ssimT Leq)) (@VisF E C X _ Z e). +Proof. intros k k' H; constructor; apply ssim_vis_id; [constructor | intros z; split; [apply H | constructor]]. Qed. + +Lemma ss_vis_eq {E C X Z} (e : E Z) (k k' : Z -> ctree E C X) + {R : Chain (@ss E E C C X X Leq)} : + (forall z, ` R (k z) (k' z)) -> + ss Leq ` R (Vis e k) (Vis e k'). +Proof. intros; apply ss_vis_id; [constructor | intros z; split; [auto | constructor]]. Qed. diff --git a/theories/Eq/SSimAlt.v b/theories/Eq/SSimAlt.v index 6b77653..2b1bf02 100644 --- a/theories/Eq/SSimAlt.v +++ b/theories/Eq/SSimAlt.v @@ -16,7 +16,7 @@ From CTree Require Import Eq.TransAlt Eq.EpsilonAlt. -From RelationAlgebra Require Export +From RelationAlgebra Require Import monoid kat kat_tac rel srel. From Coinduction Require Import all. diff --git a/theories/Interp/FoldCTree.v b/theories/Interp/FoldCTree.v index ee36bc6..23985d1 100644 --- a/theories/Interp/FoldCTree.v +++ b/theories/Interp/FoldCTree.v @@ -323,15 +323,15 @@ Module CounterExample. | voidE : VoidE void. (* Notation B012 := (B01 +' B2). *) - #[local] Definition t1 := Ret 1 : ctree VoidE B2 nat. - #[local] Definition t2 := br2 (Ret 1) (x <- trigger voidE;; match x : void with end) : ctree VoidE B2 nat. + #[local] Definition t1 := Ret 1%nat : ctree VoidE B2 nat. + #[local] Definition t2 := br2 (Ret 1%nat) (x <- trigger voidE;; match x : void with end) : ctree VoidE B2 nat. Goal t1 ≃ t2. Proof. unfold t1, t2. rewrite br2_commut. rewrite br2_is_stuck. reflexivity. - red. intros. intro. inv_trans. destruct x. + red. intros. intro. inv_trans; match goal with v : void |- _ => destruct v end. Qed. #[local] Definition h : VoidE ~> ctree VoidE B2. @@ -407,7 +407,7 @@ Lemma trans_val_interp {E F B X} trans (val v) (interp h t) Stuck. Proof. intros. - apply trans_val_epsilon in H as []. subs. + apply trans_val_epsilon in H. eapply epsilon_interp in H. eapply epsilon_trans; [apply H |]. rewrite interp_ret. etrans. diff --git a/theories/Interp/FoldCTree_scratch.v b/theories/Interp/FoldCTree_scratch.v new file mode 100644 index 0000000..2e08877 --- /dev/null +++ b/theories/Interp/FoldCTree_scratch.v @@ -0,0 +1,451 @@ +(* begin hide *) +Unset Universe Checking. + +From ExtLib Require Import + Structures.Functor + Structures.Monad. + +From ITree Require Import + Basics.Basics + Core.Subevent. + +From CTree Require Import + CTree + Eq + Eq.Epsilon + Eq.IterFacts + Eq.SSimAlt + Misc.Pure + Fold. + +Import CTreeNotations. +Open Scope ctree_scope. + +(* end hide *) + +(** Establishing generic results on [fold] is tricky: because it goes into + a very generic monad [M], it requires some heavy axiomatization of this + monad. Yoon et al.'s ICFP'22 develop the necessary tools to this end. + For now, we simply specialize results to specific [M]s. + *) + +Section FoldCTree. + + Section With_Params. + + (** Specialization to [M = ctree F (B01 +' D)] *) + Context {E F C D: Type -> Type} {X : Type} + {h : E ~> ctree F D} {g : C ~> ctree F D}. + + (** ** [interpE] and constructors *) + Definition fold_ctree : forall [T], ctree E C T -> ctree F D T := + fold h g. + (* fold (mstuck (M := ctree F D)) (mstep (M := ctree F D)) h (mbr (M := ctree F D)) g. *) + (* fold (fun T => Stuck: ctree F D T) (Step (Ret tt)) h g. *) + + (** Unfolding of [fold]. *) + Notation fold_ctree_ t := + (match observe t with + | RetF r => Ret r + | StuckF => Stuck + | GuardF t => Guard (fold_ctree t) + | StepF t => Step (Guard (fold_ctree t)) + | VisF e k => CTree.bind (h _ e) (fun x => Guard (fold_ctree (k x))) + | BrF c k => CTree.bind (g _ c) (fun x => Guard (fold_ctree (k x))) + end)%function. + + (** Unfold lemma. *) + Lemma unfold_fold_ctree (t: ctree E C X): + fold_ctree t ≅ fold_ctree_ t. + Proof. + unfold fold_ctree, fold, Basics.iter, MonadIter_ctree, mbr, MonadBr_ctree, CTree.branch. + rewrite unfold_iter. + destruct (observe t); cbn. + - now rewrite ?bind_ret_l. + - now rewrite ?bind_stuck. + - setoid_rewrite bind_step. + setoid_rewrite bind_step. + setoid_rewrite bind_ret_l. + now setoid_rewrite bind_ret_l. + - now rewrite ?bind_ret_l. + - now rewrite bind_map, ?bind_ret_l. + - now rewrite bind_map. + Qed. + + Lemma fold_ctree_ret (x: X): + fold_ctree (Ret x) ≅ Ret x. + Proof. now rewrite unfold_fold_ctree. Qed. + + Lemma fold_ctree_vis {U} (e: E U) (k: U -> ctree E C X) : + fold_ctree (Vis e k) ≅ x <- h _ e;; Guard (fold_ctree (k x)). + Proof. now rewrite unfold_fold_ctree. Qed. + + Lemma fold_ctree_stuck : + fold_ctree (Stuck : ctree E C X) ≅ Stuck. + Proof. now rewrite unfold_fold_ctree. Qed. + + Lemma fold_ctree_guard (t : ctree E C X) : + fold_ctree (Guard t) ≅ Guard (fold_ctree t). + Proof. now rewrite unfold_fold_ctree. Qed. + + Lemma fold_ctree_step (t : ctree E C X) : + fold_ctree (Step t) ≅ Step (Guard (fold_ctree t)). + Proof. now rewrite unfold_fold_ctree. Qed. + + Lemma fold_ctree_br {U} (c : C U) (k: _ -> ctree E C X) : + fold_ctree (Br c k) ≅ x <- g _ c;; Guard (fold_ctree (k x)). + Proof. now rewrite unfold_fold_ctree. Qed. + + #[global] Instance fold_ctree_equ : + Proper (equ eq ==> equ eq) (fold_ctree (T := X)). + Proof. + cbn. + coinduction r CIH. + intros * EQ; step in EQ. + rewrite 2 unfold_fold_ctree. + inv EQ; auto. + - constructor; eauto. + - constructor; eauto. + step; constructor; eauto. + - upto_bind_eq. + intros ?; constructor; auto. + - upto_bind_eq. + intros ?; constructor; auto. + Qed. + + (** Unfolding of [interp]. *) + + Notation interp_ h t := + (match observe t with + | RetF r => Ret r + | StuckF => Stuck + | GuardF t => Guard (interp h t) + | StepF t => Step (Guard (interp h t)) + | VisF e k => bind (h _ e) (fun x => Guard (interp h (k x))) + | BrF c k => bind (mbr _ c) (fun x => Guard (interp h (k x))) + end)%function. + + (** Unfold lemma. *) + Lemma unfold_interp `{C -< D} (t: ctree E C X): + interp h t ≅ interp_ h t. + Proof. + unfold interp,fold, Basics.iter, MonadIter_ctree, mbr, MonadBr_ctree, CTree.branch. + rewrite unfold_iter. + destruct (observe t); cbn. + - now rewrite ?bind_ret_l. + - now rewrite bind_stuck. + - repeat setoid_rewrite bind_step. + step; constructor. + now rewrite ?bind_ret_l. + - now rewrite bind_ret_l. + - now rewrite bind_map, ?bind_ret_l. + - now rewrite bind_map. + Qed. + + Lemma interp_ret `{C -< D} (x: X): + interp h (Ret x : ctree E C X) ≅ Ret x. + Proof. now rewrite unfold_interp. Qed. + + Lemma interp_stuck `{C -< D} : + interp h (Stuck : ctree E C X) ≅ Stuck. + Proof. now rewrite unfold_interp. Qed. + + Lemma interp_vis `{C -< D} {U} (e: E U) (k: U -> ctree E C X) : + interp h (Vis e k) ≅ x <- h _ e;; Guard (interp h (k x)). + Proof. now rewrite unfold_interp. Qed. + + Lemma interp_guard `{C -< D} (t : ctree E C X) : + interp h (Guard t) ≅ Guard (interp h t). + Proof. now rewrite unfold_interp. Qed. + + Lemma interp_step `{C -< D} (t : ctree E C X) : + interp h (Step t) ≅ Step (Guard (interp h t)). + Proof. now rewrite unfold_interp. Qed. + + Lemma interp_br `{C -< D} {U} (c : C U) (k: _ -> ctree E C X) : + interp h (Br c k) ≅ x <- branch c;; Guard (interp h (k x)). + Proof. now rewrite unfold_interp. Qed. + + Lemma interp_br' `{C -< D} {U} (c : C U) (k: _ -> ctree E C X) : + interp h (Br c k) ≅ br c (fun x => Guard (interp h (k x))). + Proof. rewrite interp_br; unfold branch; rewrite bind_br; setoid_rewrite bind_ret_l. + reflexivity. + Qed. + + #[global] Instance interp_equ `{C -< D} {R} : + Proper (equ R ==> equ R) (interp (B := C) (M := ctree F D) h (T := X)). + Proof. + cbn. + coinduction r CIH. + intros * EQ; step in EQ. + rewrite 2 unfold_interp. + inv EQ. + - constructor; auto. + - constructor; auto. + - constructor; auto. + - constructor; step; constructor; auto. + - upto_bind_eq; intros. + constructor; eauto. + - upto_bind_eq; intros. + constructor; eauto. + Qed. + + (** Unfolding of [refine]. *) + Notation refine_ g t := + (match observe t with + | RetF r => Ret r + | StuckF => Stuck + | GuardF t => Guard (refine g t) + | StepF t => Step (Guard (refine g t)) + | VisF e k => bind (mtrigger e) (fun x => Guard (refine g (k x))) + | BrF c k => bind (g _ c) (fun x => Guard (refine g (k x))) + end)%function. + + (** Unfold lemma. *) + Lemma unfold_refine `{E -< F} (t: ctree E C X): + refine g t ≅ refine_ g t. + Proof. + unfold refine,fold, Basics.iter, MonadIter_ctree, mbr, MonadBr_ctree, CTree.branch. + rewrite unfold_iter. + destruct (observe t); cbn. + - now rewrite ?bind_ret_l. + - now rewrite bind_stuck. + - repeat setoid_rewrite bind_step. + step; constructor. + now rewrite ?bind_ret_l. + - now rewrite bind_ret_l. + - now rewrite bind_map, ?bind_ret_l. + - now rewrite bind_map. + Qed. + + Lemma refine_ret `{E -< F} (x: X): + refine g (Ret x : ctree E C X) ≅ Ret x. + Proof. now rewrite unfold_refine. Qed. + + Lemma refine_vis `{E -< F} {U} (e: E U) (k: U -> ctree E C X) : + refine g (Vis e k) ≅ x <- trigger e;; Guard (refine g (k x)). + Proof. now rewrite unfold_refine. Qed. + + Lemma refine_trigger `{E -< F} (e: E X) : + refine g (trigger e : ctree E C X) ≃ (trigger e : ctree F D X). + Proof. + rewrite unfold_refine; cbn. + setoid_rewrite sbisim_guard. + setoid_rewrite refine_ret. + now rewrite bind_ret_r. + Qed. + + Lemma refine_guard `{E -< F} (t: ctree E C X) : + refine g (Guard t) ≅ Guard (refine g t). + Proof. now rewrite unfold_refine. Qed. + + Lemma refine_step `{E -< F} (t: ctree E C X) : + refine g (Step t) ≅ Step (Guard (refine g t)). + Proof. now rewrite unfold_refine. Qed. + + Lemma refine_br `{E -< F} {U} (c : C U) (k: _ -> ctree E C X) : + refine g (Br c k) ≅ x <- g _ c;; Guard (refine g (k x)). + Proof. now rewrite unfold_refine. Qed. + + #[global] Instance refine_equ `{E -< F} : + Proper (equ eq ==> equ eq) (refine (E := E) (M := ctree F _) g (T := X)). + Proof. + cbn. + coinduction r CIH. + intros * EQ; step in EQ. + rewrite 2 unfold_refine. + inv EQ; try constructor; auto. + - step; constructor; auto. + - upto_bind_eq. + intros ?; constructor; auto. + - upto_bind_eq. + intros ?; constructor; auto. + Qed. + + End With_Params. + + Arguments fold_ctree {E F C D} h g [T]. + + Section FoldBind. + + Context {E F C D: Type -> Type} {X : Type}. + + Lemma fold_ctree_bind (h : E ~> ctree F D) (g : C ~> ctree F D) {S} (t : ctree E C X) (k : X -> ctree _ _ S) : + fold_ctree h g (t >>= k) ≅ fold_ctree h g t >>= (fun x => fold_ctree h g (k x)). + Proof. + revert t. + coinduction r CIH. + intros t. + rewrite unfold_bind, (unfold_fold_ctree t). + desobs t. + - now rewrite bind_ret_l. + - now rewrite bind_stuck, fold_ctree_stuck. + - rewrite bind_step, fold_ctree_step, bind_guard. + constructor; step; constructor. + auto. + - rewrite bind_guard, fold_ctree_guard. + constructor; auto. + - rewrite fold_ctree_vis, bind_bind. + upto_bind_eq; intros. + rewrite bind_guard. + now constructor. + - rewrite fold_ctree_br, bind_bind. + upto_bind_eq; intros. + rewrite bind_guard. + now constructor. + Qed. + + Lemma interp_bind (h : E ~> ctree F D) `{C -< D} {S} (t : ctree E C X) (k : X -> ctree _ _ S) : + interp h (t >>= k) ≅ interp h t >>= (fun x => interp h (k x)). + Proof. + unfold interp. + now setoid_rewrite fold_ctree_bind. + Qed. + + Lemma refine_bind (g : C ~> ctree F D) `{E -< F} {S} (t : ctree E C X) (k : X -> ctree _ _ S) : + refine g (t >>= k) ≅ refine g t >>= (fun x => refine g (k x)). + Proof. + unfold refine. + now setoid_rewrite fold_ctree_bind. + Qed. + + End FoldBind. + +End FoldCTree. + +(*| +Counter-example showing that interp does not preserve sbisim in the general case. +|*) + +Module CounterExample. + + Inductive VoidE : Type -> Type := + | voidE : VoidE void. + + (* Notation B012 := (B01 +' B2). *) + #[local] Definition t1 := Ret 1%nat : ctree VoidE B2 nat. + #[local] Definition t2 := br2 (Ret 1%nat) (x <- trigger voidE;; match x : void with end) : ctree VoidE B2 nat. + + Goal t1 ≃ t2. + Admitted. + + #[local] Definition h : VoidE ~> ctree VoidE B2. + Proof. + intros. destruct X. exact (Step Stuck). + Defined. + + Example interpE_sbsisim_counterexample : ~ (interp h t1 ≃ interp h t2). + Admitted. + +End CounterExample. + +Section epsilon_interp_theory. + + Lemma interp_productive {E C F X} (h : E ~> ctree F C) : forall (t : ctree E C X), + productive (interp h t) -> productive t. + Proof. + intros. inversion H; + subst; + rewrite unfold_interp in EQ; + rewrite (ctree_eta t); + destruct (observe t) eqn:?; + (try destruct vis); + (try step in EQ; inv EQ); + try now econstructor. + Qed. + + Lemma epsilon_interp : forall {E C F X} + (h : E ~> ctree F C) (t t' : ctree E C X), + epsilon t t' -> epsilon (interp h t) (interp h t'). + Proof. + intros. red in H. setoid_rewrite (ctree_eta t). setoid_rewrite (ctree_eta t'). + genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'. + induction H. + - constructor. rewrite H. reflexivity. + - rewrite unfold_interp. cbn. setoid_rewrite bind_br. + apply epsilon_br with (x := x). rewrite bind_ret_l. + simpl. eapply epsilon_guard. apply IHepsilon_. + - rewrite unfold_interp. cbn. + now apply epsilon_guard. + Qed. + +End epsilon_interp_theory. + +Lemma interp_ret_inv {E F B X} (h : E ~> ctree F B) : + forall (t : ctree E B X) r, + interp h t ≅ Ret r -> t ≅ Ret r. +Proof. + intros. setoid_rewrite (ctree_eta t) in H. setoid_rewrite (ctree_eta t). + destruct (observe t) eqn:?; try now inv_equ. + - rewrite interp_ret in H. step in H. inv H. reflexivity. + - rewrite interp_vis in H. apply ret_equ_bind in H as (? & ? & ?). step in H0. inv H0. +Qed. + +Lemma bind_guard_r {E B X Y} : forall (t : ctree E B X) (k : X -> ctree E B Y), + x <- t;; Guard (k x) ≅ x <- (x <- t;; Guard (Ret x));; k x. +Proof. + intros. rewrite bind_bind. upto_bind_eq; intros ?. rewrite bind_guard. setoid_rewrite bind_ret_l. reflexivity. +Qed. + +Lemma trans_val_interp {E F B X} + (h : E ~> ctree F B) : + forall (t u : ctree E B X) (v : X), + trans (val v) t u -> + trans (val v) (interp h t) Stuck. +Proof. + intros. + apply trans_val_epsilon in H. + eapply epsilon_interp in H. + eapply epsilon_trans; [apply H |]. + rewrite interp_ret. etrans. +Qed. + +Lemma trans_tau_interp {E F B X} + (h : E ~> ctree F B) : + forall (t u : ctree E B X), + trans τ t u -> + trans τ (interp h t) (Guard (interp h u)). +Proof. + intros. + apply trans_τ_epsilon in H as (? & ? & ?). subs. + eapply epsilon_interp in H. + eapply epsilon_trans; [apply H |]. + rewrite interp_step. + etrans. +Qed. + +Lemma trans_obs_interp_step {E F B X Y} + (h : E ~> ctree F B) : + forall (t u : ctree E B X) u' (e : E Y) x l, + trans (obs e x) t u -> + trans l (h _ e) u' -> + ~ is_val l -> + epsilon_det u' (Ret x) -> + trans l (interp h t) (u';; Guard (interp h u)). +Proof. + intros. + apply trans_obs_epsilon in H as (? & ? & ?). + setoid_rewrite H3. clear H3. + apply epsilon_interp with (h := h) in H. + rewrite interp_vis in H. + eapply epsilon_trans. apply H. + epose proof (epsilon_det_bind_ret_l_equ u' (fun x => Guard (interp h (x0 x))) x H2). + rewrite <- H3; auto. + apply trans_bind_l; auto. +Qed. + +Lemma trans_obs_interp_pure {E F B X Y} + (h : E ~> ctree F B) : + forall (t u : ctree E B X) (e : E Y) x, + trans (obs e x) t u -> + trans (val x) (h _ e) Stuck -> + epsilon (interp h t) (Guard (interp h u)). +Proof. + intros t u e x TR TRh. + apply trans_obs_epsilon in TR as (k & EPS & ?). subs. + apply epsilon_interp with (h := h) in EPS. + rewrite interp_vis in EPS. + apply trans_val_epsilon in TRh as [EPSh _]. + eapply epsilon_bind_ret in EPSh. + apply (epsilon_transitive _ _ _ EPS EPSh). +Qed. diff --git a/theories/Interp/FoldStateT.v b/theories/Interp/FoldStateT.v index b8c3216..9047db7 100644 --- a/theories/Interp/FoldStateT.v +++ b/theories/Interp/FoldStateT.v @@ -208,13 +208,13 @@ Section State. Qed. Lemma fold_state_trigger_sb (e : E R) (s : S) - : fold_state h g (CTree.trigger e) s ~ h e s. + : fold_state h g (CTree.trigger e) s ≃ h e s. Proof. unfold CTree.trigger. rewrite fold_state_vis. rewrite <- (bind_ret_r (h e s)) at 2. cbn. upto_bind_eq; intros []. - now rewrite sb_guard, fold_state_ret. + now rewrite sbisim_guard, fold_state_ret. Qed. (** Unfolding of [interp]. *) diff --git a/theories/Interp/Refine.v b/theories/Interp/Refine.v index b497392..0fd62ae 100644 --- a/theories/Interp/Refine.v +++ b/theories/Interp/Refine.v @@ -9,6 +9,8 @@ From CTree Require Import Eq Eq.Epsilon Eq.SSimAlt + Eq.OldAltEquiv.TransEquiv + Eq.OldAltEquiv.SSimEquiv Interp.Fold Interp.FoldCTree Interp.FoldStateT @@ -18,14 +20,14 @@ Import ITree.Basics.Basics.Monads. Import MonadNotation. Open Scope monad_scope. -Theorem ssim_pure {E F B C X} : forall (L : rel _ _) (t : ctree E B X), +Theorem ssim_pure {E F B C X} : forall (L : lrel E F X unit) (t : ctree E B X), pure_finite t -> (forall x : X, L (val x) (val tt)) -> ssim L t (Ret tt : ctree F C unit). Proof. intros. induction H; subs. - - now apply ssim_ret. - - now apply Stuck_ssim. + - apply ssim_ret. now apply build_rel_val. + - now apply ssim_stuck. - now apply ssim_br_l. - now apply ssim_guard_l. Qed. @@ -37,7 +39,7 @@ Theorem refine_ctree_ssim {E B B' X} : (forall X c, pure_finite (h X c)) -> refine h t ≲ t. Proof. - intros. rewrite ssim_ssim'. red. revert t. coinduction R CH. intros. + intros. unfold ssimT. rewrite ssim_ssim'. red. revert t. coinduction R CH. intros. rewrite (ctree_eta t) at 2. setoid_rewrite unfold_refine. cbn. destruct (observe t) eqn:?. @@ -66,7 +68,7 @@ Theorem refine_state_ssim {E B B' X St} : (forall X c s, pure_finite (h X c s)) -> forall s, refine h t s (≲@Lrr St E X) t. Proof. - intros. rewrite ssim_ssim'. red. revert t s. coinduction R CH. intros. + intros. unfold ssimT. rewrite ssim_ssim'. red. revert t s. coinduction R CH. intros. rewrite (ctree_eta t) at 2. setoid_rewrite unfold_refine_state. cbn. destruct (observe t) eqn:?.