Section Proper.
Context {A : Type}.
Class Proper (R : crelation A) (m : A) :=
proper_prf : R m m.
(** Every element in the carrier of a reflexive relation is a morphism for this relation.  We use a proxy class for this case which is used internally to discharge reflexivity constraints.  The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able to set different priorities in different hint bases and select a particular hint database for resolution of a type class constraint. *)
Class ProperProxy (R : crelation A) (m : A) :=
proper_proxy : R m m.
(** Subcrelations induce a morphism on the identity. *)
Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id.
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.
transitivity x...
transitivity x0...
Qed.
(** Proper declarations for partial applications. *)
Global Program
Instance trans_contra_inv_impl_type_morphism
`(Transitive A R) : Proper (R --> flip arrow) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity y...
Qed.
Global Program
Instance trans_co_impl_type_morphism
`(Transitive A R) : Proper (R ++> arrow) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity x0...
Qed.
Global Program
Instance trans_sym_co_inv_impl_type_morphism
`(PER A R) : Proper (R ++> flip arrow) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity y... symmetry...
Qed.
Global Program Instance trans_sym_contra_arrow_morphism
`(PER A R) : Proper (R --> arrow) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity x0... symmetry...
Qed.
Global Program Instance per_partial_app_type_morphism
`(PER A R) : Proper (R ==> iffT) (R x) | 2.
Next Obligation.
Proof with auto.
split.
- intros ; transitivity x0...
- intros.
transitivity y...
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.
transitivity 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.
split ; intros.
- transitivity x0... transitivity x... symmetry...
- transitivity y... transitivity y0... symmetry...
Qed.
(** Coq functions are morphisms for Leibniz equality, applied only if really needed. *)
Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') :
Reflexive (@Logic.eq A ==> R').
(** [R] is Reflexive, hence we can build the needed proof. *)

Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) :
Proper R' (m x).