(** 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_params:
  Params (@rel_pull) 3.(** ** 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).(** ** 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).(** 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_params:
  Params (@rel_push) 3.(** ** 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.(** 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.(** 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.(** ** The [req] relation *)

(** The relation [req a] asserts that both elements are equal to [a].
  This comes in handy when expressing the relational properties of
  functions: it can be used to fix the value of an argument, or
  parametrize it using a variable with a broader scope. *)

Inductive req {A} (a: A): rel A A :=
  req_intro: req a a a.(** ** The [req] relation *)

(** The relation [req a] asserts that both elements are equal to [a].
  This comes in handy when expressing the relational properties of
  functions: it can be used to fix the value of an argument, or
  parametrize it using a variable with a broader scope. *)

Inductive req {A} (a: A): rel A A :=
  req_intro: req a a a.

Lemma req_rintro {A} (a: A): RIntro True (req a) a a.