Added a library for solving recursive domain equations.

lib/recdom/BI.v

+Require Import PreoMet.
+Require Import PCM.
+
+Section CompleteBI.
+  Context {T : Type}.
+
+  Class topBI  := top  : T.
+  Class botBI  := bot  : T.
+  Class andBI  := and  : T -> T -> T.
+  Class orBI   := or   : T -> T -> T.
+  Class implBI := impl : T -> T -> T.
+  Class scBI   := sc   : T -> T -> T.
+  Class siBI   := si   : T -> T -> T.
+  Class allBI  `{cmT : cmetric T} :=
+    all  : forall {U} `{pU : cmetric U}, (U -n> T) -> T.
+  Class xistBI `{cmT : cmetric T} :=
+    xist : forall {U} `{pU : cmetric U}, (U -n> T) -> T.
+
+  Section Lift.
+    Context (f : T -> T -> T) `{cmT : cmetric T}
+            {fequiv : Proper (equiv ==> equiv ==> equiv) f}
+            {fdist : forall n, Proper (dist n ==> dist n ==> dist n) f}
+            {U} `{cmU : cmetric U} (P : U -n> T) (Q : U -n> T).
+
+    Local Obligation Tactic := intros; resp_set.
+
+    Program Definition lift_bin : U -n> T :=
+      n[(fun u => f (P u) (Q u))].
+
+  End Lift.
+
+  Class ComplBI `{pcmT : pcmType T, BIT : topBI, BIB : botBI, BIA : andBI,
+                                    BIO : orBI, BII : implBI, BISC : scBI, BISI : siBI}
+        {BIAll : allBI} {BIXist : xistBI} :=
+    mkCBI {
+        top_true    :  forall P, P ⊑ top;
+        bot_false   :  forall P, bot ⊑ P;
+        and_self    :  forall P, P ⊑ and P P;
+        and_projL   :  forall P Q, and P Q ⊑ P;
+        and_projR   :  forall P Q, and P Q ⊑ Q;
+        and_equiv   :> Proper (equiv ==> equiv ==> equiv) and;
+        and_dist n  :> Proper (dist n ==> dist n ==> dist n) and;
+        and_pord    :> Proper (pord ==> pord ==> pord) and;
+        and_impl    :  forall P Q R, and P Q ⊑ R <-> P ⊑ impl Q R;
+        impl_equiv  :> Proper (equiv ==> equiv ==> equiv) impl;
+        impl_dist n :> Proper (dist n ==> dist n ==> dist n) impl;
+        impl_pord   :> Proper (pord --> pord ++> pord) impl;
+        or_injL     :  forall P Q, P ⊑ or P Q;
+        or_injR     :  forall P Q, Q ⊑ or P Q;
+        or_self     :  forall P, or P P ⊑ P;
+        or_equiv    :> Proper (equiv ==> equiv ==> equiv) or;
+        or_dist n   :> Proper (dist n ==> dist n ==> dist n) or;
+        or_pord     :> Proper (pord ==> pord ==> pord) or;
+        sc_comm     :> Commutative sc;
+        sc_assoc    :> Associative sc;
+        sc_top_unit :  forall P, sc top P == P;
+        sc_equiv    :> Proper (equiv ==> equiv ==> equiv) sc;
+        sc_dist n   :> Proper (dist n ==> dist n ==> dist n) sc;
+        sc_pord     :> Proper (pord ==> pord ==> pord) sc;
+        sc_si       :  forall P Q R, sc P Q ⊑ R <-> P ⊑ si Q R;
+        si_equiv    :> Proper (equiv ==> equiv ==> equiv) si;
+        si_dist n   :> Proper (dist n ==> dist n ==> dist n) si;
+        si_pord     :> Proper (pord --> pord ++> pord) si;
+        all_R      U `{cmU : cmetric U} :
+          forall P (Q : U -n> T), (forall u, P ⊑ Q u) <-> P ⊑ all Q;
+        all_equiv  U `{cmU : cmetric U} :> Proper (equiv ==> equiv) all;
+        all_dist   U `{cmU : cmetric U} n :> Proper (dist n ==> dist n) all;
+        all_pord   U `{cmU : cmetric U} (P Q : U -n> T) :
+          (forall u, P u ⊑ Q u) -> all P ⊑ all Q;
+        xist_L     U `{cmU : cmetric U} :
+          forall (P : U -n> T) Q, (forall u, P u ⊑ Q) <-> xist P ⊑ Q;
+        xist_sc    U `{cmU : cmetric U} :
+          forall (P : U -n> T) Q, sc (xist P) Q ⊑ xist (lift_bin sc P (umconst Q));
+        xist_equiv U `{cmU : cmetric U} :> Proper (equiv ==> equiv) xist;
+        xist_dist  U `{cmU : cmetric U} n :> Proper (dist n ==> dist n) xist;
+        xist_pord  U `{cmU : cmetric U} (P Q : U -n> T) :
+          (forall u, P u ⊑ Q u) -> xist P ⊑ xist Q
+      }.
+
+End CompleteBI.
+
+Arguments topBI  : default implicits.
+Arguments botBI  : default implicits.
+Arguments andBI  : default implicits.
+Arguments orBI   : default implicits.
+Arguments implBI : default implicits.
+Arguments scBI   : default implicits.
+Arguments siBI   : default implicits.
+Arguments allBI  T {_ _ _}.
+Arguments xistBI T {_ _ _}.
+Arguments ComplBI T {_ _ _ _ _ _ _ _ _ _ _ _ _ _}.
+
+Class Valid (T : Type) `{pcmT : pcmType T} :=
+  { valid : T -> Prop;
+    valid_top (t t' : T) (HV : valid t) : t' ⊑ t
+  }.
+
+Class Later (T : Type) `{pcmT : pcmType T} {vT : Valid T} :=
+  { later : T -m> T;
+    later_mon (t : T) : t ⊑ later t;
+    later_contr : contractive later;
+    loeb (t : T) (HL : later t ⊑ t) : valid t
+  }.
+
+Notation " ▹ p " := (later p) (at level 20) : bi_scope.
+
+Require Import UPred.
+
+Section UPredLater.
+  Context Res `{preoRes : preoType Res}.
+  Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
+
+  Global Program Instance valid_up : Valid (UPred Res) :=
+    Build_Valid _ _ _ _ _ _ (fun p : UPred Res => forall n r, p n r) _.
+  Next Obligation.
+    intros n r _; apply HV.
+  Qed.
+
+  Global Instance later_up_mon : Proper (pord ==> pord) later_up.
+  Proof.
+    intros p q Hpq [| n] r; [intros; exact I | simpl; apply Hpq].
+  Qed.
+
+  Global Program Instance later_upred : Later (UPred Res) :=
+    Build_Later _ _ _ _ _ _ _ m[(later_up)] _ _ _.
+  Next Obligation.
+    intros [| n] r Ht; [exact I | simpl].
+    rewrite Le.le_n_Sn; assumption.
+  Qed.
+  Next Obligation.
+    intros n p q Hpq [| m] r HLt; simpl; [tauto |].
+    apply Hpq; auto with arith.
+  Qed.
+  Next Obligation.
+    intros n r; induction n.
+    - apply HL; exact I.
+    - apply HL, IHn.
+  Qed.
+
+End UPredLater.
+
+Section UPredBI.
+  Context Res `{pcmRes : PCM Res}.
+  Local Open Scope pcm_scope.
+  Local Obligation Tactic := intros; eauto with typeclass_instances.
+  Local Instance eqRes : Setoid Res := discreteType.
+
+  (* Standard interpretations of propositional connectives. *)
+  Global Program Instance top_up : topBI (UPred Res) := up_cr (const True).
+  Global Program Instance bot_up : botBI (UPred Res) := up_cr (const False).
+
+  Global Program Instance and_up : andBI (UPred Res) :=
+    fun P Q =>
+      mkUPred (fun n r => P n r /\ Q n r) _.
+  Next Obligation.
+    intros n m r1 r2 HLe HSub; rewrite HSub, HLe; tauto.
+  Qed.
+  Global Program Instance or_up : orBI (UPred Res) :=
+    fun P Q =>
+      mkUPred (fun n r => P n r \/ Q n r) _.
+  Next Obligation.
+    intros n m r1 r2 HLe HSub; rewrite HSub, HLe; tauto.
+  Qed.
+
+  Global Program Instance impl_up : implBI (UPred Res) :=
+    fun P Q =>
+      mkUPred (fun n r => forall m r', m <= n -> r ⊑ r' -> P m r' -> Q m r') _.
+  Next Obligation.
+    intros n m r1 r2 HLe HSub HImp k r3 HLe' HSub' HP.
+    apply HImp; try (etransitivity; eassumption); assumption.
+  Qed.
+
+  (* BI connectives. *)
+  Global Program Instance sc_up : scBI (UPred Res) :=
+    fun P Q =>
+      mkUPred (fun n r => exists r1 r2, Some r1 · Some r2 = Some r /\ P n r1 /\ Q n r2) _.
+  Next Obligation.
+    intros n m r1 r2 HLe [r3 HEq] [r11 [r12 [HEq' [HP HQ]]]].
+    assert (PA := pcm_op_assoc Res r3 (Some r11) (Some r12)); simpl in PA.
+    erewrite <- HEq', (assoc (Associative := pcm_op_assoc _)) in HEq.
+    destruct (r3 · Some r11) as [r311 |] eqn: EQ;
+      [| erewrite pcm_op_zero in HEq by eassumption; discriminate].
+    exists r311 r12; rewrite HLe.
+    split; [assumption |].
+    assert (HS : r11 ⊑ r311) by (eexists; eassumption).
+    rewrite <- HS; tauto.
+  Qed.
+
+  Global Program Instance si_up : siBI (UPred Res) :=
+    fun P Q =>
+      mkUPred (fun n r => forall m r' rr, Some r · Some r' = Some rr -> m <= n -> P m r' -> Q m rr) _.
+  Next Obligation.
+    intros n m r1 r2 HLe [[r12 |] HEq] HSI k r rr HEq' HSub HP;
+    [| erewrite pcm_op_zero in HEq by eassumption; discriminate].
+    rewrite (comm (Commutative := pcm_op_comm _)) in HEq.
+    rewrite <- HEq, <- (assoc (Associative := pcm_op_assoc _)) in HEq'.
+    destruct (Some r12 · Some r) as [r12r |] eqn: HEq'';
+      [| erewrite (comm (Commutative := pcm_op_comm _)), pcm_op_zero in HEq' by eassumption; discriminate].
+    eapply HSI; [eassumption | etransitivity; eassumption |]; [].
+    assert (HS : r ⊑ r12r) by (eexists; eassumption).
+    rewrite <- HS; assumption.
+  Qed.
+
+  (* Quantifiers. *)
+  Global Program Instance all_up : allBI (UPred Res) :=
+    fun T eqT mT cmT R =>
+      mkUPred (fun n r => forall t, R t n r) _.
+  Next Obligation.
+    intros n m r1 r2 HLe HSub HR t; rewrite HLe, <- HSub; apply HR.
+  Qed.
+
+  Global Program Instance xist_up : xistBI (UPred Res) :=
+    fun T eqT mT cmT R =>
+      mkUPred (fun n r => exists t, R t n r) _.
+  Next Obligation.
+    intros n m r1 r2 HLe HSub [t HR]; exists t; rewrite HLe, <- HSub; apply HR.
+  Qed.
+
+  (* All of the above preserve all the props it should. *)
+
+  Global Instance and_up_equiv : Proper (equiv ==> equiv ==> equiv) and_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    rewrite EQP, EQQ; tauto.
+  Qed.
+  Global Instance and_up_dist n : Proper (dist n ==> dist n ==> dist n) and_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ m r HLt; simpl.
+    split; intros; (split; [apply EQP | apply EQQ]; now auto with arith).
+  Qed.
+  Global Instance and_up_ord : Proper (pord ==> pord ==> pord) and_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    rewrite EQP, EQQ; tauto.
+  Qed.
+
+  Global Instance or_up_equiv : Proper (equiv ==> equiv ==> equiv) or_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    rewrite EQP, EQQ; tauto.
+  Qed.
+  Global Instance or_up_dist n : Proper (dist n ==> dist n ==> dist n) or_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ m r HLt; simpl.
+    split; (intros [HP | HQ]; [left; apply EQP | right; apply EQQ]; now auto with arith).
+  Qed.
+  Global Instance or_up_ord : Proper (pord ==> pord ==> pord) or_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    rewrite EQP, EQQ; tauto.
+  Qed.
+
+  Global Instance impl_up_equiv : Proper (equiv ==> equiv ==> equiv) impl_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    setoid_rewrite EQP; setoid_rewrite EQQ; tauto.
+  Qed.
+  Global Instance impl_up_dist n : Proper (dist n ==> dist n ==> dist n) impl_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ m r HLt; simpl.
+    split; intros; apply EQQ, H, EQP; now eauto with arith.
+  Qed.
+  Global Instance impl_up_ord : Proper (pord --> pord ++> pord) impl_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r HP m r'.
+    rewrite <- EQP, <- EQQ; apply HP.
+  Qed.
+
+  Global Instance sc_up_equiv : Proper (equiv ==> equiv ==> equiv) sc_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    setoid_rewrite EQP; setoid_rewrite EQQ; tauto.
+  Qed.
+  Global Instance sc_up_dist n : Proper (dist n ==> dist n ==> dist n) sc_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ m r HLt; simpl.
+    split; intros [r1 [r2 [EQr [HP HQ]]]]; exists r1; exists r2;
+    (split; [assumption | split; [apply EQP | apply EQQ]; now auto with arith]).
+  Qed.
+  Global Instance sc_up_ord : Proper (pord ==> pord ==> pord) sc_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r HH; simpl.
+    setoid_rewrite <- EQP; setoid_rewrite <- EQQ; apply HH.
+  Qed.
+
+  Global Instance si_up_equiv : Proper (equiv ==> equiv ==> equiv) si_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r; simpl.
+    setoid_rewrite EQP; setoid_rewrite EQQ; tauto.
+  Qed.
+  Global Instance si_up_dist n : Proper (dist n ==> dist n ==> dist n) si_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ m r HLt; simpl.
+    split; intros; eapply EQQ, H, EQP; now eauto with arith.
+  Qed.
+  Global Instance si_up_ord : Proper (pord --> pord ++> pord) si_up.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ n r HP m r' rr.
+    rewrite <- EQP, <- EQQ; apply HP.
+  Qed.
+
+  Section Quantifiers.
+    Context V `{pU : cmetric V}.
+
+    Global Instance all_up_equiv : Proper (equiv (T := V -n> UPred Res) ==> equiv) all.
+    Proof.
+      intros R1 R2 EQR n r; simpl.
+      setoid_rewrite EQR; tauto.
+    Qed.
+    Global Instance all_up_dist n : Proper (dist (T := V -n> UPred Res) n ==> dist n) all.
+    Proof.
+      intros R1 R2 EQR m r HLt; simpl.
+      split; intros; apply EQR; now auto.
+    Qed.
+
+    Global Instance xist_up_equiv : Proper (equiv (T := V -n> UPred Res) ==> equiv) xist.
+    Proof.
+      intros R1 R2 EQR n r; simpl.
+      setoid_rewrite EQR; tauto.
+    Qed.
+    Global Instance xist_up_dist n : Proper (dist (T := V -n> UPred Res)n ==> dist n) xist.
+    Proof.
+      intros R1 R2 EQR m r HLt; simpl.
+      split; intros [t HR]; exists t; apply EQR; now auto.
+    Qed.
+
+  End Quantifiers.
+
+  Global Program Instance bi_up : ComplBI (UPred Res).
+  Next Obligation.
+    intros n r _; exact I.
+  Qed.
+  Next Obligation.
+    intros n r HC; contradiction HC.
+  Qed.
+  Next Obligation.
+    intros n r; simpl; tauto.
+  Qed.
+  Next Obligation.
+    intros n r [HP HQ]; assumption.
+  Qed.
+  Next Obligation.
+    intros n r [HP HQ]; assumption.
+  Qed.
+  Next Obligation.
+    split; intros HH n r.
+    - intros HP m r' HLe HSub HQ; apply HH; split; [rewrite HLe, <- HSub |]; assumption.
+    - intros [HP HQ]; eapply HH; eassumption || reflexivity.
+  Qed.
+  Next Obligation.
+    intros n r HP; left; assumption.
+  Qed.
+  Next Obligation.
+    intros n r HQ; right; assumption.
+  Qed.
+  Next Obligation.
+    intros n r; simpl; tauto.
+  Qed.
+  Next Obligation.
+    intros P Q n r; simpl.
+    setoid_rewrite (comm (Commutative := pcm_op_comm _)) at 1.
+    firstorder.
+  Qed.
+  Next Obligation.
+    intros P Q R n r; simpl; split.
+    - intros [r1 [rr [EQr [HP [r2 [r3 [EQrr [HQ HR]]]]]]]].
+      rewrite <- EQrr, (assoc (Associative := pcm_op_assoc _)) in EQr.
+      destruct (Some r1 · Some r2) as [r12 |] eqn: EQr12;
+        [| erewrite pcm_op_zero in EQr by eassumption; discriminate].
+      exists r12 r3; split; [assumption |].
+      split; [exists r1 r2; split; [assumption |] |]; tauto.
+    - intros [rr [r3 [EQr [[r1 [r2 [EQrr [HP HQ]]]] HR]]]].
+      rewrite <- EQrr, <- (assoc (Associative := pcm_op_assoc _)) in EQr.
+      destruct (Some r2 · Some r3) as [r23 |] eqn: EQr23;
+        [| erewrite (comm (Commutative := pcm_op_comm _)), pcm_op_zero in EQr by eassumption; discriminate].
+      exists r1 r23; split; [assumption |].
+      split; [| exists r2; exists r3; split; [assumption |]]; tauto.
+  Qed.
+  Next Obligation.
+    intros n r; simpl; split.
+    - intros [r1 [r2 [EQr [_ HP]]]].
+      assert (HT : r2 ⊑ r) by (eexists; apply EQr).
+      rewrite <- HT; assumption.
+    - intros HP; exists (pcm_unit _) r; unfold const; intuition eauto using pcm_op_unit.
+  Qed.
+  Next Obligation.
+    split; intros HH n r.
+    - intros HP m r' rr EQrr HLe HQ; apply HH; rewrite <- HLe in HP.
+      eexists; eexists; split; [eassumption | tauto].
+    - intros [r1 [r2 [EQr [HP HQ]]]]; eapply HH; eassumption || reflexivity.
+  Qed.
+  Next Obligation.
+    split.
+    - intros HH n r HP u; apply HH; assumption.
+    - intros HH u n r HP; apply HH; assumption.
+  Qed.
+  Next Obligation.
+    intros n r HA u; apply H, HA.
+  Qed.
+  Next Obligation.
+    split.
+    - intros HH n r [u HP]; eapply HH; eassumption.
+    - intros HH u n r HP; apply HH; exists u; assumption.
+  Qed.
+  Next Obligation.
+    intros n t [t1 [t2 [EQt [[u HP] HQ]]]]; exists u t1 t2; tauto.
+  Qed.
+  Next Obligation.
+    intros n r [u HA]; exists u; apply H, HA.
+  Qed.
+
+End UPredBI.
+
+(* This class describes a type that can close over "future Us",
+   thus making a nonexpansive map monotone *)
+Class MonotoneClosure T `{pcmT : pcmType T} :=
+  { mclose : forall {U} `{pcmU : pcmType U} {eU : extensible U},
+               (U -n> T) -n> U -m> T;
+    mclose_cl : forall {U} `{pcmU : pcmType U} {eU : extensible U} (f : U -n> T) u,
+                  mclose f u ⊑ f u;
+    mclose_fw : forall {U} `{pcmU : pcmType U} {eU : extensible U} (f : U -n> T) u t
+                       (HFW : forall u' (HS : u ⊑ u'), t ⊑ f u'),
+                  t ⊑ mclose f u
+  }.
+Arguments Build_MonotoneClosure {_ _ _ _ _ _} _ {_ _}.
+
+Section MonotoneExt.
+  Context B `{BBI : ComplBI B} {MCB : MonotoneClosure B}
+          T `{pcmT' : pcmType T} {eT : extensible T}.
+  Local Obligation Tactic := intros; resp_set || mono_resp || eauto with typeclass_instances.
+
+  Global Instance top_mm : topBI (T -m> B) := pcmconst top.
+  Global Instance bot_mm : botBI (T -m> B) := pcmconst bot.
+
+  Global Program Instance and_mm : andBI (T -m> B) :=
+    fun P Q => m[(lift_bin and P Q)].
+  Global Program Instance or_mm  : orBI  (T -m> B) :=
+    fun P Q => m[(lift_bin or P Q)].
+
+  Global Instance impl_mm : implBI (T -m> B) :=
+    fun P Q => mclose (lift_bin impl P Q).
+
+  Global Program Instance sc_mm  : scBI  (T -m> B) :=
+    fun P Q => m[(lift_bin sc P Q)].
+
+  Global Instance si_mm : siBI (T -m> B) :=
+    fun P Q => mclose (lift_bin si P Q).
+
+  Global Program Instance all_mm : allBI (T -m> B) :=
+    fun U eqU mU cmU R =>
+      m[(fun t => all n[(fun u => R u t)])].
+  Next Obligation.
+    intros t1 t2 EQt; apply all_equiv; intros u; simpl morph.
+    rewrite EQt; reflexivity.
+  Qed.
+  Next Obligation.
+    intros t1 t2 EQt; apply all_dist; intros u; simpl morph.
+    rewrite EQt; reflexivity.
+  Qed.
+  Next Obligation.
+    intros t1 t2 Subt; apply all_pord; intros u; simpl morph.
+    rewrite Subt; reflexivity.
+  Qed.
+
+  Global Program Instance xist_mm : xistBI (T -m> B) :=
+    fun U eqU mU cmU R =>
+      m[(fun t => xist n[(fun u => R u t)])].
+  Next Obligation.
+    intros t1 t2 EQt; apply xist_equiv; intros u; simpl morph.
+    rewrite EQt; reflexivity.
+  Qed.
+  Next Obligation.
+    intros t1 t2 EQt; apply xist_dist; intros u; simpl morph.
+    rewrite EQt; reflexivity.
+  Qed.
+  Next Obligation.
+    intros t1 t2 Subt; apply xist_pord; intros u; simpl morph.
+    rewrite Subt; reflexivity.
+  Qed.
+
+  (* All of the above preserve all the props it should. *)
+  Global Instance and_mm_equiv : Proper (equiv ==> equiv ==> equiv) and_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply and_equiv; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance and_mm_dist n : Proper (dist n ==> dist n ==> dist n) and_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply and_dist; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance and_mm_ord : Proper (pord ==> pord ==> pord) and_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply and_pord; [apply EQP | apply EQQ].
+  Qed.
+
+  Global Instance or_mm_equiv : Proper (equiv ==> equiv ==> equiv) or_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply or_equiv; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance or_mm_dist n : Proper (dist n ==> dist n ==> dist n) or_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply or_dist; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance or_mm_ord : Proper (pord ==> pord ==> pord) or_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply or_pord; [apply EQP | apply EQQ].
+  Qed.
+
+  Global Instance impl_mm_equiv : Proper (equiv ==> equiv ==> equiv) impl_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ; unfold impl_mm.
+    apply (morph_resp mclose); intros t; simpl morph.
+    apply impl_equiv; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance impl_mm_dist n : Proper (dist n ==> dist n ==> dist n) impl_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ; apply met_morph_nonexp; intros t; simpl morph.
+    apply impl_dist; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance impl_mm_ord : Proper (pord --> pord ++> pord) impl_mm.
+  Proof.
+    intros P1 P2 SubP Q1 Q2 SubQ t; unfold flip in SubP; unfold impl, impl_mm.
+    apply mclose_fw; intros t' Subt; rewrite Subt; clear t Subt; simpl morph.
+    rewrite SubP, <- SubQ; apply mclose_cl.
+  Qed.
+
+  Global Instance sc_mm_equiv : Proper (equiv ==> equiv ==> equiv) sc_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply sc_equiv; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance sc_mm_dist n : Proper (dist n ==> dist n ==> dist n) sc_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply sc_dist; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance sc_mm_ord : Proper (pord ==> pord ==> pord) sc_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ t; simpl morph.
+    apply sc_pord; [apply EQP | apply EQQ].
+  Qed.
+
+  Global Instance si_mm_equiv : Proper (equiv ==> equiv ==> equiv) si_mm.
+  Proof.
+    intros P1 P2 EQP Q1 Q2 EQQ; apply (morph_resp mclose); intros t; simpl morph.
+    apply si_equiv; [apply EQP | apply EQQ].
+  Qed.
+  Global Instance si_mm_dist n : Proper (dist n ==> dist n ==> dist n) si_mm.