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.
Hint Extern 1 (Coreflexive (_ !! _)) =>
eapply rel_push_corefl : typeclass_instances.
(** When using [R !! fst] or [R !! snd], if [rel_push_intro] does not apply, we can use the following instances instead. *)
Hint Extern 1 (RExists _ (_ !! fst) _ _) =>
eapply rel_push_fst_rexists : typeclass_instances.
Hint Extern 1 (RExists _ (_ !! snd) _ _) =>
eapply rel_push_snd_rexists : typeclass_instances.
(** ** Relation currying *)
(* An interesting special case of [rel_pull] is [rel_curry], which takes a relation over [A * B -> C] and turns it into a relation over [A -> B -> C].  [rel_curry] is particularly useful when two (curried) arguments to a given function have to be related in a dependent way. For example in Compcert, memory injections relate memory blocks and offsets jointly, but many operations have those as two separate arguments. To state the relational property of such operations, we can uncurry a joint relation on (block, offset) pairs.  [rel_curry] can be obtained by pulling back the original relation along [uncurry]: *)
Definition curry {A B C} (f: A * B -> C): A -> B -> C :=
fun a b => f (a, b).
Definition uncurry {A B C} (f: A -> B -> C): A * B -> C :=
fun ab => match ab with (a, b) => f a b end.
Definition rel_curry {A1 B1 C1 A2 B2 C2} (R: rel (A1*B1->C1) (A2*B2->C2)) :=
(R @@ uncurry)%rel.
Definition rel_uncurry {A1 B1 C1 A2 B2 C2} (R: rel (A1->B1->C1) (A2->B2->C2)) :=
(R @@ curry)%rel.
(** We use the following notation for [rel_curry], which evokes splitting a pair into two separate arguments. Note that we use the same priority as for [++>], [-->], and [==>], because we usually want [rel_curry] to nest in such a way that for instance, [S ++> % R --> % R ++> impl] will be interpreted as [S ++> rel_curry (R --> rel_curry (R ++> impl))]. *)
Notation "% R" := (rel_curry R) (at level 55, right associativity) : rel_scope.
(** In order to provide an [RElim] instance for [rel_curry], we will rely on the fact that:  uncurry f (x1, x2) x3 ... xn = f x1 x2 x3 ... xn,  and that:  rel_curry R f g <-> R (uncurry f) (uncurry g),  so that when the instance of [RElim] associated with [R] allows us to show:  Rcod (uncurry f (x1, x2) x3 ... xn) (uncurry g (y1, y2) y3 ... yn)  we can convert it into an instance for proving:  Rcod (f x1 x2 x3 ... xn) (g y1 y2 y3 ... yn),  which is what will be expected for [monotonicity]. To accomplish this, we need to [unfold uncurry] in the result provided for [R] before we use it to solve the [rel_uncurry] case. This helper class does this. *)
Class UnfoldUncurry {A} (before: A) (after: A) :=
unfold_uncurry_before_after: before = after.
Ltac unfold_uncurry :=
match goal with
| |- context C[uncurry ?f ?p] =>
is_evar p;
let T := type of p in
let Av := fresh in evar (Av: Type);
let A := eval red in Av in clear Av;
let Bv := fresh in evar (Bv: Type);
let B := eval red in Bv in clear Bv;
unify T (prod A B)%type;
let av := fresh in evar (av : A);
let a := eval red in av in clear av;
let bv := fresh in evar (bv : B);
let b := eval red in bv in clear bv;
let G := context C[f a b] in
unify p (a, b);
change G
end.
Hint Extern 1 (UnfoldUncurry ?P ?Q) =>
repeat unfold_uncurry; constructor : typeclass_instances.
(** Now we can provide a somewhat general [RElim] instance for [rel_uncurry]. *)

Lemma rel_curry_relim {A1 B1 C1 A2 B2 C2} R f g P Q Q':
@RElim (A1 * B1 -> C1) (A2 * B2 -> C2) R (uncurry f) (uncurry g) P Q ->
UnfoldUncurry Q Q' ->
@RElim (A1 -> B1 -> C1) (A2 -> B2 -> C2) (% R) f g P Q'.