Require Export RelDefinitions.
(** ** Union of relations *)
Definition rel_union {A B} (R1 R2: rel A B): rel A B :=
fun x y => R1 x y \/ R2 x y.
Arguments rel_union {_ _} R1%rel R2%rel _ _.
Infix "\/" := rel_union : rel_scope.
Global Instance rel_union_subrel {A B}:
Monotonic (@rel_union A B) (subrel ++> subrel ++> subrel).
Global Instance rel_union_subrel_params:
Params (@rel_union) 4.
Defined.
(** Since we're forced to commit to a branch, we can't use [RIntro], but can still provide [RExists] instances. *)
Hint Extern 0 (RExists _ (_ \/ _) _ _) =>
eapply rel_union_rexists_l : typeclass_instances.
Hint Extern 0 (RExists _ (_ \/ _) _ _) =>
eapply rel_union_rexists_r : typeclass_instances.
(** More often, we can solve a [rel_union] goal using a monotonicity property, and the [subrel] instances below. *)
Hint Extern 0 (RExists _ subrel _ (_ \/ _)%rel) =>
eapply rel_union_subrel_rexists_l : typeclass_instances.
Hint Extern 0 (RExists _ subrel _ (_ \/ _)%rel) =>
eapply rel_union_subrel_rexists_r : typeclass_instances.
Hint Extern 2 (RIntro _ subrel (_ \/ _)%rel _) =>
eapply rel_union_lub : typeclass_instances.
Hint Extern 1 (Reflexive (_ \/ _)) =>
eapply rel_union_refl_l : typeclass_instances.
Hint Extern 1 (Reflexive (_ \/ _)) =>
eapply rel_union_refl_r : typeclass_instances.
Hint Extern 1 (Coreflexive (_ \/ _)) =>
eapply rel_union_corefl : typeclass_instances.
Hint Extern 1 (Symmetric (_ \/ _)) =>
eapply rel_union_sym : typeclass_instances.
(** ** Intersection of relations *)
Definition rel_inter {A B} (R1 R2: rel A B): rel A B :=
fun x y => R1 x y /\ R2 x y.
Arguments rel_inter {_ _} R1%rel R2%rel _ _.
Infix "/\" := rel_inter : rel_scope.
Global Instance rel_inter_subrel {A B}:
Monotonic (@rel_inter A B) (subrel ++> subrel ++> subrel).
Global Instance rel_inter_params:
Params (@rel_inter) 4.
Defined.
(** In some cases, the relation in the goal will cause existential variables to be instantiated accordingly; for instance, [rstep] run on [?R x y |- (R1 /\ R2) x y] will instantiate [?R := R1 /\ R2]. Because of this, splitting a [rel_inter] goal into two subgoals may cause a dead-end and we have to use [RExists] for the following rule. *)
Hint Extern 0 (RExists _ (_ /\ _) _ _) =>
eapply rel_inter_rexists : typeclass_instances.
Hint Extern 0 (RExists _ subrel (_ /\ _)%rel _) =>
eapply rel_inter_subrel_rexists_l : typeclass_instances.
Hint Extern 0 (RExists _ subrel (_ /\ _)%rel _) =>
eapply rel_inter_subrel_rexists_r : typeclass_instances.
Hint Extern 2 (RIntro _ subrel _ (_ /\ _)%rel) =>
eapply rel_inter_glb : typeclass_instances.
Hint Extern 2 (Reflexive (_ /\ _)) =>
eapply rel_inter_refl : typeclass_instances.
Hint Extern 1 (Coreflexive (_ /\ _)) =>
eapply rel_inter_corefl_l : typeclass_instances.
Hint Extern 1 (Coreflexive (_ /\ _)) =>
eapply rel_inter_corefl_r : typeclass_instances.
Hint Extern 2 (Transitive (_ /\ _)) =>
eapply rel_inter_trans : typeclass_instances.
Hint Extern 2 (Symmetric (_ /\ _)) =>
eapply rel_inter_sym : typeclass_instances.
Global Instance rel_inter_flip_sym {A} (R: rel A A):
Symmetric (R /\ flip R).
(** On a related note, a symmetric subrelation of [R] is also a subrelation of its inverse. *)
Hint Extern 60 (RStep _ (subrel _ (flip _))) =>
eapply subrel_sym_flip : typeclass_instances.
(** ** Implication *)
Definition rel_impl {A B} (R1 R2: rel A B): rel A B :=
fun x y => R1 x y -> R2 x y.
Global Instance rel_impl_subrel {A B}:
Monotonic (@rel_impl A B) (subrel --> subrel ++> subrel).
Global Instance rel_impl_subrel_params:
Params (@rel_impl) 4.
Defined.
Hint Extern 0 (RIntro _ (rel_impl _ _) _ _) =>
eapply rel_impl_rintro : typeclass_instances.
Hint Extern 0 (RElim (rel_impl _ _) _ _ _ _) =>
eapply rel_impl_relim : typeclass_instances.
(** ** The bottom and top relations *)
Definition rel_bot {A B}: rel A B :=
fun x y => False.
Notation "⊥" := rel_bot : rel_scope.
Hint Extern 0 (Related ⊥%rel _ _) =>
eapply rel_bot_subrel : typeclass_instances.
Hint Extern 0 (RElim ⊥ _ _ _ _) =>
eapply rel_bot_relim : typeclass_instances.
Definition rel_top {A B}: rel A B :=
fun x y => True.
Notation "⊤" := rel_top : rel_scope.
Hint Extern 0 (RIntro _ ⊤ _ _) =>
eapply rel_top_rintro : typeclass_instances.
Global Instance rel_top_equiv {A}:
@Equivalence A ⊤.
(** ** Relation equivalence *)
Definition eqrel {A B}: rel (rel A B) (rel A B) :=
(subrel /\ flip subrel)%rel.
Arguments eqrel {_ _} RA%rel RB%rel.
Global Instance eqrel_equivalence A B:
Equivalence (@eqrel A B).
Global Instance eqrel_subrel A B:
Related (@eqrel A B) (@subrel A B) subrel.
(** ** Relation composition *)
Definition rel_compose {A B C} (RAB: rel A B) (RBC: rel B C): rel A C :=
fun x z => exists y, RAB x y /\ RBC y z.
Hint Unfold rel_compose.
Global Instance rel_compose_subrel {A B C}:
Monotonic (@rel_compose A B C) (subrel ++> subrel ++> subrel).
Global Instance rel_compose_eqrel {A B C}:
Monotonic (@rel_compose A B C) (eqrel ==> eqrel ==> eqrel).
Global Instance rel_compose_params:
Params (@rel_compose) 4.
Defined.
(** Transitivity and decomposition can be expressed in terms of [rel_compose] in the following way. *)
Global Instance rel_compose_rcompose {A B C} (RAB : rel A B) (RBC : rel B C) :
RCompose RAB RBC (rel_compose RAB RBC).
Global Instance rel_compose_rdecompose {A B C} (RAB : rel A B) (RBC : rel B C) :
RDecompose RAB RBC (rel_compose RAB RBC).
Global Instance rcompose_subrel `(RCompose) :
Related (rel_compose RAB RBC) RAC subrel.
Global Instance rdecompose_subrel `(RDecompose) :
Related RAC (rel_compose RAB RBC) subrel.
(** ** Pulling a relation along functions *)
Definition rel_pull {A B A' B'} f g (R: rel A' B'): rel A B :=
fun x y => R (f x) (g y).
(** We use the following notation. Left associativity would make more sense but we have to match [Coq.Classes.RelationPairs]. *)
Notation "R @@ ( f , g )" := (rel_pull f g R)
(at level 30, right associativity) : rel_scope.
Notation "R @@ f" := (rel_pull f f R)
(at level 30, right associativity) : rel_scope.
Notation "R @@ ( f )" := (rel_pull f f R)
(at level 30, right associativity) : rel_scope.
Global Instance rel_pull_subrel {A B A' B'} (f: A -> A') (g: B -> B'):
Monotonic (rel_pull f g) (subrel ++> subrel).
Global Instance rel_pull_subrel_params:
Params (@rel_pull) 3.
Defined.
(** In the restricted case where [f = g], [rel_pull] preserves many properties of the underlying relation. *)
Hint Extern 1 (Reflexive (rel_pull _ _ _)) =>
eapply rel_pull_refl : typeclass_instances.
Hint Extern 1 (Symmetric (rel_pull _ _ _)) =>
eapply rel_pull_sym : typeclass_instances.
Hint Extern 1 (RCompose _ _ (rel_pull _ _ _)) =>
eapply rel_pull_rcompose : typeclass_instances.
(** The introduction rule is straightforward, but changes the head terms to the functions used with [rel_pull]. This means that an [RIntro] rule would short-circuit any relational property formulated for the original terms, even if the codomain is a matching [rel_pull] relation and we have an appropriate [RElim] instance. To avoid shadowing such properties, we define our introduction rule as an [RStep] with a low priority. See test [rel_pull_2]. *)
Hint Extern 60 (RStep _ ((_ @@ (_, _))%rel _ _)) =>
eapply rel_pull_rintro : typeclass_instances.
(** We can reuse an instance of [RElim] for the underlying relation to provide corresponding instances for the pulled relation. *)
Hint Extern 1 (RElim (_ @@ (_, _)) _ _ _ _) =>
eapply rel_pull_relim : typeclass_instances.
(** ** Pushing a relation along functions *)
Inductive rel_push {A1 A2 B1 B2} f g (R: rel A1 A2): rel B1 B2 :=
rel_push_rintro x y: RIntro (R x y) (rel_push f g R) (f x) (g y).
Hint Extern 1 (RIntro _ (rel_push _ _ _) _ _) =>
eapply rel_push_rintro : typeclass_instances.
(** The level we choose here is to match the notation used for [PTree.get] in Compcert's [Maps] library. *)
Notation "R !! ( f , g )" := (rel_push f g R)
(at level 1) : rel_scope.
Notation "R !! f" := (rel_push f f R)
(at level 1) : rel_scope.
Notation "R !! ( f )" := (rel_push f f R)
(at level 1) : rel_scope.
Global Instance rel_push_subrel {A1 A2 B1 B2} (f: A1 -> B1) (g: A2 -> B2):
Proper (subrel ++> subrel) (rel_push f g).
Global Instance rel_push_subrel_params:
Params (@rel_push) 3.
Defined.

Lemma rel_push_corefl {A B} (f: A -> B) (R: rel A A):
Coreflexive R ->
Coreflexive (R !! f).