(** Respectful morphisms. *)
  
  (** The fully dependent version, not used yet. *)
  
  Definition respectful_hetero
  (A B : Type)
  (C : A -> Type) (D : B -> Type)
  (R : A -> B -> Type)
  (R' : forall (x : A) (y : B), C x -> D y -> Type) :
    (forall x : A, C x) -> (forall x : B, D x) -> Type :=
    fun f g => forall x y, R x y -> R' x y (f x) (g y).(** The non-dependent version is an instance where we forget dependencies. *)
  
  Definition respectful {B} (R : crelation A) (R' : crelation B) : crelation (A -> B) :=
    Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').#[global]
Hint Extern 2 (ProperProxy ?R _) => 
  not_evar R; class_apply @proper_proper_proxy : typeclass_instances.Notation " R ++> R' " := (@respectful _ _ (R%signatureT) (R'%signatureT))
    (right associativity, at level 55) : signatureT_scope.Notation " R ==> R' " := (@respectful _ _ (R%signatureT) (R'%signatureT))
    (right associativity, at level 55) : signatureT_scope.Notation " R --> R' " := (@respectful _ _ (flip (R%signatureT)) (R'%signatureT))
    (right associativity, at level 55) : signatureT_scope.(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f]
    by repeated introductions and setoid rewrites. It should work
    fine when [f] is a combination of already known morphisms and
    quantifiers. *)

Ltac solve_respectful t :=
 match goal with
   | |- respectful _ _ _ _ =>
     let H := fresh "H" in
     intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t)
   | _ => t; reflexivity
 end.Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac).(** [forall_def] reifies the dependent product as a definition. *)
  
  Definition forall_def (P : A -> Type) : Type := forall x : A, P x.(** Dependent pointwise lifting of a crelation on the range. *)
  
  Definition forall_relation (P : A -> Type)
             (sig : forall a, crelation (P a)) : crelation (forall x, P x) :=
    fun f g => forall a, sig a (f a) (g a).(** Non-dependent pointwise lifting *)
  Definition pointwise_relation {B} (R : crelation B) : crelation (A -> B) :=
    fun f g => forall a, R (f a) (g a).

Lemma subrelation_proper `(mor : Proper A R' m) `(unc : Unconvertible (crelation A) R R') `(sub : subrelation A R' R) : Proper R m.