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