Section Proper.
Let U := Type.
Context {A B : U}.
Class Proper (R : relation A) (m : A) : Prop :=
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 : relation A) (m : A) : Prop :=
proper_proxy : R m m.
Global Instance proper_subrelation_proper :
Proper (subrelation ++> eq ==> impl) (@Proper A).
(** The complement of a relation conserves its proper elements. *)
Program Definition complement_proper
`(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
Proper (RA ==> RA ==> iff) (complement R) := _.
Next Obligation.
(** 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 relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *)
Global Program
Instance trans_contra_co_morphism
`(Transitive A R) : Proper (R --> R ++> impl) R.
Next Obligation.
Proof with auto.
transitivity x...
transitivity x0...
Qed.
(** Proper declarations for partial applications. *)
Global Program
Instance trans_contra_inv_impl_morphism
`(Transitive A R) : Proper (R --> flip impl) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity y...
Qed.
Global Program
Instance trans_co_impl_morphism
`(Transitive A R) : Proper (R ++> impl) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity x0...
Qed.
Global Program
Instance trans_sym_co_inv_impl_morphism
`(PER A R) : Proper (R ++> flip impl) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity y... symmetry...
Qed.
Global Program Instance trans_sym_contra_impl_morphism
`(PER A R) : Proper (R --> impl) (R x) | 3.
Next Obligation.
Proof with auto.
transitivity x0... symmetry...
Qed.
Global Program Instance per_partial_app_morphism
`(PER A R) : Proper (R ==> iff) (R x) | 2.
Next Obligation.
Proof with auto.
split.
- intros ; transitivity x0...
- intros.
transitivity y...
symmetry...
Qed.
(** Every Transitive relation 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_impl_morphism
`(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2.
Next Obligation.
Proof with auto.
transitivity y...
Qed.
(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *)
Global Program
Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) 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).