Local Open Scope rel_scope.
(** * Tests *)
(** ** Reflexivity *)
Goal
forall A (a: A), a = a.
Goal
forall A (a: A), exists b, b = a.
(** ** Setoid rewriting *)
Goal
forall A (a b: A) `(HR: Equivalence A) (H: R a b),
sum_rel R R (inl a) (inl b).
(** There is an issue with the following. *)
Goal
forall A (a b: A) (R: rel A A) (f: A -> A) (p: A -> Prop),
Monotonic f (R ++> R) ->
Monotonic p (R --> impl) ->
R a b ->
p (f b) ->
p (f a).
Goal
forall A (a b: A) (R: rel A A) (H: R a b),
let f (x y: A * A) := (@pair (A+A) (A+A) (inr (fst x)) (inl (snd y))) in
Monotonic f (R * ⊤ ++> ⊤ * R ++> (⊥ + R) * (R + ⊥))%rel.
Goal
forall {A1 A2 B1 B2} (R1 R1': rel A1 A2) (R2 R2': rel B1 B2),
subrel R1' R1 ->
subrel R2 R2' ->
subrel (R1 ++> R2) (R1' ++> R2').
(** Check that we can use relational hypotheses from the context as well as [Monotonic]/[Related] instances. *)
Goal
forall
{A B} (R: rel A A)
(op: A -> B) (Hop: (R ++> eq) op op)
(x y: A) (Hxy: R x y),
op x = op y.
(** Bug with relational parametricity: you can't [RElim] a relation you don't know yet. *)
Goal
forall {A B} (RA: rel A A) (RB: rel B B) (m n: (A -> B) * B) (x y: A),
((- ==> RB) * RB)%rel m n ->
RB (fst m x) (fst n x).
Goal
forall {A B} (RA: rel A A) (RB: rel B B) (x y: A * B) (z: A),
RA z z ->
prod_rel RA RB x y ->
RA (let (a, b) := x in z)
(let (a, b) := y in z).
Goal
forall {A} (R: rel A A),
Monotonic
(fun (b: bool) x y => if b then x else y)
(- ==> R ++> R ++> R).
Goal
forall {A} (R : rel A A) (b : bool) (x y : A),
b = b ->
R x x ->
R y y ->
R (if b then x else y)
(if b then x else y).
(** [rel_curry] *)
Goal
forall {A B C} R R' S (f: A -> B -> B -> C) (x1 y1: A) (x2 y2: B),
Monotonic f (rel_curry (R ++> R' ++> S)) ->
S (f x1 x2 x2) (f y1 y2 y2).
(** *** Hypotheses from the context *)
(* This used to fail because [Hyy] would shadow [Hxy] (the hypothesis we want). *)
Goal
forall {A} (R: rel A A) (x y: A),
R x y -> eq y y -> R x y.
(* This still fail with Coq 8.5, but Coq 8.6 is able to backtrack and try hypothesis from the context beyond the first one it finds. *)
Goal
forall {A} (R: rel A A) (x y: A),
R x y -> eq x y -> R x y.
(** Then *this* used to fail because the [flip] was hidden until after we exploit the [subrel] property. This is important in particular when using the equivalences for a given partial order, as in [eqrel] vs. [subrel], where we want to be able to use equivalences in both directions. *)
Goal
forall {A} (R R': rel A A) (f: A -> A),
Monotonic f (R ++> R) ->
Related R' (flip R) subrel ->
(R' ++> flip R) f f.
(** As an example where proper handling of [flip] is important, this is a goal generated by [setoid_rewrite] when we try to rewrite using [eqrel] under [option_le]. Here, both [R1] and [R2] have to be instantiated as [flip eq] (so that the associated hypotheses can be used to solve goals of the form [yi = xi]), and similarly we need to use the super-relation [flip subrel] of [eqrel]. *)
Goal
forall A, exists R1 R2: relation (option A),
(eqrel ==> R1 ==> R2 ==> flip impl)%signature option_le option_le.
(** *** [impl] vs. [subrel] *)
(** This checks that a relational property written in terms of [subrel] can be used to solve a goal stated in terms of [impl]. This is made possible by [subrel_impl_relim]. *)
Goal
forall A B C (R: rel A A) (f: A -> rel B C) a1 a2 b c,
Monotonic f (R ++> subrel) ->
R a1 a2 ->
impl (f a1 b c) (f a2 b c).
Goal
forall A1 A2 B1 B2 (R1 R2: rel A1 A2) (R: rel B1 B2),
subrel R1 R2 ->
forall x y,
(R2 ++> R) x y ->
(R1 ++> R) x y.
(** *** Generic rules *)
(** The [coreflexivity] of [rel_prod] and [eq] makes it possible for [pair_rel] to behave in the same way as [f_equal] below, since they allow us to deduce that [eq * eq] is a [subrel] of [eq]. *)
Goal
forall A B (x1 x2 : A) (y1 y2 : B),
x1 = x2 -> y1 = y2 -> (x1, y1) = (x2, y2).
(** ** Using [foo_subrel] instances *)
(** Still broken because of the interaction between [subrel] and [- ==> - ==> impl] (or lack thereof) *)
Goal
forall A1 A2 B1 B2 C1 C2 (R1 R2: rel A1 A2) (R1': rel B1 B2) (R: rel C1 C2),
subrel R1 R2 ->
forall x y,
(R2 ++> R) x y ->
(R1 ++> R) x y.
Goal
forall A B (xa1 xa2 ya1 ya2 : A) (xb1 xb2 yb1 yb2 : B)
(opA: A -> A -> A) (opB: B -> B -> B)
(RA: rel A A) (RB: rel B B)
(HopA: Monotonic opA (RA ++> RA ++> RA))
(HopB: Monotonic opB (RB ++> RB ++> RB))
(Hxa: RA xa1 xa2)
(Hxb: RB xb1 xb2)
(Hya: RA ya1 ya2)
(Hyb: RB yb1 yb2),
(RA * RB)%rel
(opA xa1 ya1, opB xb1 yb1)
(opA xa2 ya2, opB xb2 yb2).
Goal
forall A1 A2 B1 B2 C1 C2 (R1 R2: rel A1 A2) (R1': rel B1 B2) (R: rel C1 C2),
subrel R1 R2 ->
forall x y,
(R2 * R1' ++> R) x y ->
(R1 * R1' ++> R) x y.
(** ** The [rgraph] tactic *)
Goal
forall {A} (R S T: rel A A),
subrel R S ->
subrel S R ->
subrel S T ->
subrel R T.
Goal
forall `(PER) (x y z t : A),
R x y ->
R z y ->
R z t ->
R t x.
(** ** The [transport] tactic *)
Goal
forall W acc A B C (R1: W -> rel A A) (R2: W -> rel B B) (R3: W -> rel C C) f g a b x w,
Monotonic f (rforall w, R1 w ++> R2 w) ->
Monotonic g (rforall w, R2 w ++> option_rel (rel_incr acc R3 w)) ->
R1 w a b ->
g (f a) = Some x ->
exists y, rel_incr acc R3 w x y.
(** ** Tests for specific relators *)
(** *** [list_rel] *)
(** [list_subrel] use to not work because of a missing [Params] declaration. *)
Goal
forall A B (R R': rel A B) l1 l2 x y,
subrel R R' ->
list_rel R l1 l2 ->
R' x y ->
list_rel R' (x :: l1) (y :: l2).
(** *** [rel_pull] *)
(** The [RIntro] instance for [rel_pull] used to be less general. *)
Goal
forall A B (f: A -> B) (R: rel B B) x y,
R (f x) (f y) ->
(R @@ f) x y.
(** We don't want the introduction rule for [rel_pull] to shadow relational properties. *)

Lemma rel_pull_2:
forall A B (f: A -> B) (R: rel B B) (g: A -> A) x y,
Monotonic g (⊤ ==> R @@ f) ->
(R @@ f) (g x) (g y).