From 8ab960b4574d8ab27fa92fc95cc034a8e122de78 Mon Sep 17 00:00:00 2001 From: Yannick Date: Thu, 23 Oct 2025 11:58:03 +0200 Subject: [PATCH 01/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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/56] 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].