(** Subcrelations induce a morphism on the identity. *)
Global Instance proper_subrelation_proper_arrow :
Proper (subrelation ++> eq ==> arrow) (@Proper A).
Unset Strict Universe Declaration.
(** The complement of a crelation conserves its proper elements. *)
(** The [flip] too, actually the [flip] instance is a bit more general. *)
Program Definition flip_proper
`(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
Proper (RB ==> RA ==> RC) (flip f) := _.
Next Obligation.
(** Every Transitive crelation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *)
Global Program
Instance trans_contra_co_type_morphism
`(Transitive A R) : Proper (R --> R ++> arrow) R.
Next Obligation.
Proof with auto.
intros A R H x y X x0 y0 X0 X1.
apply transitivity with x...
apply transitivity with x0...
Qed.
(** Proper declarations for partial applications. *)
Global Program
Instance trans_contra_inv_impl_type_morphism
`(Transitive A R) {x} : Proper (R --> flip arrow) (R x) | 3.
Next Obligation.
Proof with auto.
intros A R H x x0 y X X0.
apply transitivity with y...
Qed.
Global Program
Instance trans_co_impl_type_morphism
`(Transitive A R) {x} : Proper (R ++> arrow) (R x) | 3.
Next Obligation.
Proof with auto.
intros A R H x x0 y X X0.
apply transitivity with x0...
Qed.
Global Program
Instance trans_sym_co_inv_impl_type_morphism
`(PER A R) {x} : Proper (R ++> flip arrow) (R x) | 3.
Next Obligation.
Proof with auto.
intros A R H x x0 y X X0.
apply transitivity with y... apply symmetry...
Qed.
Global Program Instance trans_sym_contra_arrow_morphism
`(PER A R) {x} : Proper (R --> arrow) (R x) | 3.
Next Obligation.
Proof with auto.
intros A R H x x0 y X X0.
apply transitivity with x0... apply symmetry...
Qed.
Global Program Instance per_partial_app_type_morphism
`(PER A R) {x} : Proper (R ==> iffT) (R x) | 2.
Next Obligation.
Proof with auto.
intros A R H x x0 y X.
split.
- intros ; apply transitivity with x0...
- intros.
apply transitivity with y...
apply symmetry...
Qed.
(** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *)
Global Program
Instance trans_co_eq_inv_arrow_morphism
`(Transitive A R) : Proper (R ==> (@eq A) ==> flip arrow) R | 2.
Next Obligation.
Proof with auto.
intros A R H x y X y0 y1 e X0; destruct e.
apply transitivity with y...
Qed.
(** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *)
Global Program
Instance PER_type_morphism `(PER A R) : Proper (R ==> R ==> iffT) R | 1.
Next Obligation.
Proof with auto.
intros A R H x y X x0 y0 X0.
split ; intros.
- apply transitivity with x0...
apply transitivity with x... apply symmetry...
- apply transitivity with y... apply transitivity with y0...
apply symmetry...
Qed.

(* Specifications: *)
Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R).
Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') {A} :
Reflexive (@Logic.eq A ==> R').