(** * 6.512 Formal Reasoning About Programs, Spring 2023 - Pset 2 *)

(* Author: Samuel Gruetter <gruetter@mit.edu>

This pset will introduce you to one of the major applications of formal
reasoning about programs: proving that an optimized program behaves the same as
a simple program.

Once again, you can check the tips section near the bottom of this file for some
useful tips and tricks to help you navigate Coq and Ltac. In the signature file there
is a hint specific to the problems in this pset that you can consult if you find
yourself stuck!

Imagine you're writing a program that needs some function F. You know how to
implement F naively, but as you run your program, you notice that it spends a
lot of time in the function F. You find a library which claims to provide a very
efficient implementation of F, but looking at its source code, you don't really
understand why this code should calculate F, and you've seen some bug reports
against previous versions of the library, so you can't really know whether this
library implements F correctly.  Since you care a lot about writing a correct
program, you finally decide to keep using your naive slow implementation.
Formal reasoning about programs to the rescue! If the authors of the library
want to increase the user's trust in their library, they can include the naive
but simple-to-understand version of F in their library as well and write a
proof that for all possible inputs, the optimized version of F returns the same
value as the simple version of F.  If that proof is in a machine-checkable
format (e.g. in a Coq file), the library users do not need to understand the
implementation of the optimized F, nor the body of the proof, but can still use
the optimized F and be sure that it does the same as the simple implementation,
as long as they trust the proof checker.

In this pset, we will put you in the role of the library author who writes a
naive version of F, an optimized implementation of F, and a proof that the two
of them behave the same. *)

Require Import Coq.NArith.NArith. Open Scope N_scope.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.micromega.Lia.
Require Import Frap.Frap.
Require Import Pset2Sig.

(* As usual, the grading rubric for this pset is in Pset2Sig.v. *)

Module Impl.
  (* Recursive functions *)
  (* ******************* *)

  (* We will need some recursive functions in this PSet. Defining recursive
     functions in Coq can be a bit tricky, because Coq only accepts recursive
     functions that very obviously terminate.

     For natural numbers represented as "nat", and for data structures like the
     abstract syntax trees we saw in class, recursive functions can usually be
     defined using "Fixpoint", because each recursive call is made on a subterm of
     the original argument, which is required for Coq to be convinced that the
     recursive function terminates. Coq accepts the [fact_nat] function below
     because the recursive call [fact_nat n'] operates on [n'], which is a subterm
     of [n].
   *)

  Fixpoint fact_nat (n : nat) : nat :=
    match n with
    | O => 1
    | S n' => (n' + 1) * (fact_nat n')
    end.

  (*
     In this pset, however, we want to use the binary representation of natural
     numbers, which is called "N" in Coq.  This representation stores numbers as
     lists of binary digits, so recursive functions on these numbers don't
     decrease by one on every call: they remove one binary digit on every call
     (which corresponds to dividing by two).

     So, a Fixpoint on N called with the binary number "1101" can only make
     recursive calls with the number "110".  To make recursive calls with one
     less than the argument, i.e. with 1100 in this example, we need a special
     recursion operator:

       N.recursion base_case update_fn n_iters

    This pattern can only define functions recursing over a natural number until
    it reaches 0, with one recursive case where the recursive call is for one less
    than the argument. It corresponds to the following function on nat: *)

  Fixpoint nat_recursion {A} (base_case: A) (update_fn: nat -> A -> A) n_iters :=
    match n_iters with
    | 0 => base_case
    | S n => update_fn n (nat_recursion base_case update_fn n)
    end%nat.

  (*
    To show how we can use this function, we can define an alternate version of
    fact_nat as follows:
   *)

  Definition fact_nat' : nat -> nat :=
    nat_recursion 1%nat (fun n recurse => (n + 1) * recurse)%nat.

  (* To make definitions more readable, we have defined a notation for
     N.recursion that mirrors the structure of the match statement in the original
     fact_nat fixpoint but actually desugars to a definition like fact_nat'.
     We'll be using the following factorial function, defined using our notation,
     for the rest of this assignment:
   *)

  Definition fact: N -> N :=
    recurse by cases
    | 0 => 1
    | n + 1 => (n + 1) * recurse
    end.

  (* The above function implements factorial, i.e. "fact n = 1 * 2 * ... * n".  In
     the recursive case, you can use the word "recurse" to refer to the result of
     the recursive call. *)

  (* Aside: If you don't like the above notation and want to see the real
     definition, you can do this:

  Close Scope N_recursion_scope.
  Print fact.
  *)

  (* Let's compute the first few values of fact: *)
  Compute fact 0.
  Compute fact 1.
  Compute fact 2.
  Compute fact 3.
  Compute fact 4.

  (* Instead of writing "(fact x)" all the time, it's more convenient to just
     write "x!", so we make a Notation for this: *)
  Local Notation "x !" := (fact x) (at level 12, format "x !").

  (* Exercise: Define a simple exponentiation function in the same style, so that
     "exp base n" equals "base^n". *)

  Definition exp(base: N): N -> N. Admitted.

  (* Once you define "exp", you can replace "Admitted." below by "Proof. equality. Qed." *)
  Lemma test_exp_2_3: exp 2 3 = 8. Admitted.
  Lemma test_exp_3_2: exp 3 2 = 9. Admitted.
  Lemma test_exp_4_1: exp 4 1 = 4. Admitted.
  Lemma test_exp_5_0: exp 5 0 = 1. Admitted.
  Lemma test_exp_1_3: exp 1 3 = 1. Admitted.

  (* Here's another recursive function defined in the same style to apply a
     function f to a range of values:
     "seq f len start" computes the list [f start; f (start+1); ... f (start+len-1)] *)
  Definition seq(f: N -> N): N -> N -> list N :=
    recurse by cases
    | 0 => fun start => []
    | n + 1 => fun start => f start :: recurse (start + 1)
    end.

  Compute (seq (fun x => x * x) 4 10).

  (* "ith i l" returns the i-th element of the list l.
     To understand the recursion, note that "ith i" returns a function which takes
     a list and, depending on whether i was 0 or not, returns the head of the list
     or the (i-1)-th element of the tail.  If the index is out of bounds, it
     returns the default value 0. *)
  Definition ith: N -> list N -> N :=
    recurse by cases
    | 0 => fun (l: list N) => match l with
                              | h :: t => h
                              | nil => 0
                              end
    | i + 1 => fun (l: list N) => match l with
                                  | h :: t => recurse t
                                  | nil => 0
                                  end
    end.

  (* The standard library already contains a function called "length": *)
  Check length.
  (* However, it returns a "nat", i.e., the representation of natural numbers
     using O and S, which is very inefficient: To represent the number n, it needs
     roughly c*n bytes of RAM, where c is some constant, whereas "N", the binary
     representation of natural numbers, only used c*log(n) bytes of RAM.
     Therefore, we redefine our own length function which returns an N: *)
  Fixpoint len(l: list N): N :=
    match l with
    | [] => 0
    | h :: t => 1 + len t
    end.
  (* Note that since the recursion follows the structure of the data (the list)
     here, we use Fixpoint instead of "recurse by cases". *)

  (* Here's a simple lemma: If we tell "seq" to return a list of length "count",
     it indeed does: *)
  Lemma seq_len: forall f count start, len (seq f count start) = count.
  Proof.
    induct count; simplify.
    - (* base case: count = 0 *)
      equality.
    - (* recursive case: assuming the statement holds for some "count", show that
         it also holds for "count + 1".
         This goal contains "seq f (count + 1) start", so we know that we're in
         the recursive case of "seq", so we'd like to replace "seq f (count + 1)
         start" by the recursive case we wrote in its definition.  Unfortunately,
         neither "unfold seq" nor "simplify" can do this, but the tactic
         "unfold_recurse F k", where F is the function in question and k its
         argument, does the job: *)
      unfold_recurse (seq f) count.
      (* And here's a hint you'll need later: Sometimes, your goal won't exactly
         contain (seq f (count + 1) start), but maybe (seq f someOtherExpression
         start), but you still know that someOtherExpression is strictly greater
         than 0.  In such cases, if you want to use "unfold_recurse", you first
         have to run

         <<<
         replace someOtherExpression with (someOtherExpression - 1 + 1) by
         linear_arithmetic.
         >>>

         Note that if someOtherExpression could be 0, this won't work, because
         subtraction on natural numbers in Coq returns 0 if the result is
         negative, so "0 - 1 + 1" equals 1 in Coq's natural numbers, and
         linear_arithmetic can't prove "0 = 1" for you! *)

      simplify. rewrite IHcount. linear_arithmetic.
  Qed.

  (* And here's another general hint: You don't always need induction.  Some lemmas
     in this pset can be solved using induction but don't actually require it
     and are simpler to solve if you don't use induction, so before doing
     induction, try to think where/if you would need an inductive hypothesis. *)

  (* Exercise: Prove that the i-th element of seq has the value we'd expect. *)
  Lemma seq_spec: forall f count i start, i < count -> ith i (seq f count start) = f (start + i).
  Proof.
    induct count; simplify.
  Admitted.

  (* Exercise: Prove that if the index is out of bounds, "ith" returns 0. *)
  Lemma ith_out_of_bounds_0: forall i l, len l <= i -> ith i l = 0.
  Proof.
  Admitted.

  (* Binomial coefficients *)
  (* ********************* *)

  (* You might remember binomial coefficients from your math classes. They appear in many combinatorics
     problems and form the coefficients of the expansion of the polynomial (x + y)^n.
     In math notation, they are defined as follows:

        / n \        n!
        |   |  = ---------
        \ k /    (n-k)! k!

     We can transcribe this to Coq as follows: *)

  Definition C(n k: N): N := n! / ((n - k)! * k!).

  (* If we want to know how many ways there are to pick 2 items out of 4 items, we
     can compute this in Coq: *)
  Compute C 4 2.

  (* And here are the coefficients of the expansion of (x + y)^3: *)
  Compute [C 3 0; C 3 1; C 3 2; C 3 3].

  (* For larger numbers, however, this way of computing C becomes quite slow:

  Compute C 1000 100.

     …takes about 2 seconds on my computer. You can measure the time by putting
     "Time" in front of any command:

  Time Compute C 1000 100.

     In the fraction defining C, there are many factors which appear both in the
     numerator and in the denominator, so it seems that we should be able to
     cancel these out and write a more efficient implementation of C. Here is one
     candidate: *)

  Definition bcoeff(n: N): N -> N :=
    recurse by cases
    | 0 => 1
    | k + 1 => recurse * (n - k) / (k + 1)
    end.

  (* Now if we do

  Time Compute bcoeff 1000 100.

     it only takes about 0.02 seconds on my computer, so we got a 100x speed
     improvement, yay!  But how do we know whether it's correct?  We could do some
     quick tests: *)

  Compute [bcoeff 3 0; bcoeff 3 1; bcoeff 3 2; bcoeff 3 3].

  (* This test produces the same values as for C, but we want to be sure that
     bcoeff will *always* produce the same values as C, so let's prove it,
     i.e. let's show that

     forall n k, k <= n -> bcoeff n k = C n k

     We will do so further below, but we first need a few helper lemmas and
     techniques:

     Many arithmetic goals in this pset are linear, i.e. there are only
     multiplications by constants but no multiplications of two variables.  For
     these linear-arithmetic goals, the linear_arithmetic tactic works just fine,
     but for some non-linear goals which will appear in this Pset, you can try the
     tactic "nia" (which stands for "non-linear integer arithmetic"), but it does
     not always work, so sometimes you will have to search for appropriate lemmas
     to apply manually.  For instance, to prove the following: *)
  Goal forall n m, n <> 0 -> m <> 0 -> n * m <> 0.
  Proof.
    simplify.
    (* you could use the "Search" command with a pattern: *)
    Search (_ * _ <> 0).
    (* which outputs the name of a handy lemma we can apply: *)
    apply N.neq_mul_0.
    split; assumption.
    (* (Note that in this case "nia" would have worked as well, but in any case, it's good to know
       the "Search" command.) *)
  Qed.

  (* Here's another example of how to use the "Search" command: Suppose you have
     the goal *)
  Goal forall n, n <> 0 -> n / n = 1.
  Proof.
    simplify.
    (* If we do "Search (_ / _)" we get a very long list, but if we do *)
    Search (?x / ?x).
    (* we force the two numbers on both sides of the / to be the same, and we only get the lemma we need: *)
    apply N.div_same.
    assumption.
  Qed.

  (* Now we're ready to prove a few simple facts: *)

  Lemma fact_nonzero: forall n, n! <> 0.
  Proof.
  Admitted.

  Lemma Cn0: forall n, C n 0 = 1.
  Proof.
  Admitted.

  Lemma Cnn: forall n, C n n = 1.
  Proof.
  Admitted.

  (* It's somewhat surprising that in the definition of C(n, k),

        n!
    -----------
    (n - k)! k!

    the denominator always divides the numerator.
    The following lemma proves it. Note that "(a | b)" means "a divides b".  We
    provide the solution for you, so that you can step through it and use it as a
    source of useful strategies you can apply in the exercises below.  Make sure
    to step through it and to understand each proof step! *)
  Lemma C_is_integer: forall n k, k <= n ->
      (((n - k)! * k!) | n!).
  Proof.
    induct n; simplify.

    - replace k with 0 by linear_arithmetic.
      Search (1 * _).
      rewrite N.mul_1_l; simplify.
      Search (?a | ?a).
      apply N.divide_refl.

    - (* We want to use the induction hypothesis, but it is not directly
         applicable to [k], since [k] could be equal to [n + 1]. *)
      assert (k = 0 \/ k = n + 1 \/ 0 < k <= n) as Hk by linear_arithmetic;
        cases Hk; subst; simplify.

      + rewrite N.sub_0_r, N.mul_1_r.
        apply N.divide_refl.

      + rewrite N.sub_diag; simplify.
        rewrite N.mul_1_l.
        apply N.divide_refl.

      + (* The key idea is to use the induction hypothesis twice. *)
        assert (k <= n) as Hle by linear_arithmetic.
        pose proof (IHn k Hle) as Hdk.

        assert (k - 1 <= n) as Hle1 by linear_arithmetic.
        pose proof (IHn (k - 1) Hle1) as Hdk1.

        (* How can we use facts about divisibility?
           Unfolding the definition helps: *)
        (* Locate "|". (* Notation "( p | q )" := (N.divide p q) *) *)
        (* unfold N.divide in *. *)

        (* [invert] will give us a concrete value instead of an existential: *)
        (* invert Hdk; invert Hdk1. *)

        (* Next we proceed to harmonize the divisors to be able to sum them. *)
        Search (_ * _ | _ * _).

        (* The first equation is missing a (n - k + 1) factor *)
        apply N.mul_divide_mono_l with (p := n + 1 - k) in Hdk.
        replace ((n + 1 - k) * ((n - k)! * k!))
          with ((n + 1 - k)! * k!) in Hdk; cycle 1.
        { replace (n + 1 - k) with (n - k + 1) by linear_arithmetic.
          unfold_recurse fact (n - k).
          replace (n - k + 1) with (n + 1 - k) by linear_arithmetic.
          linear_arithmetic. }

        (* The second is missing a (k) factor *)
        apply N.mul_divide_mono_l with (p := k) in Hdk1.
        replace (n - (k - 1)) with (n + 1 - k) in Hdk1
          by linear_arithmetic.
        replace (k * ((n + 1 - k)! * (k - 1)!))
          with ((n + 1 - k)! * k!) in Hdk1; cycle 1.
        { replace k with (k - 1 + 1) at 2 by linear_arithmetic.
          unfold_recurse fact (k - 1).
          replace (k - 1 + 1) with k by linear_arithmetic.
          linear_arithmetic. }

        (* Now we can sum the equations: *)
        Search (_ | _ + _).
        pose proof N.divide_add_r _ _ _ Hdk Hdk1 as Hd.
        replace ((n + 1 - k) * n! + k * n!) with ((n + 1)!) in Hd; cycle 1.
        { unfold_recurse fact n. nia. }

        equality.
  Qed.

  (* Now we're ready to prove correctness of our optimized implementation bcoeff.
     Since this is not a class about math, we're providing a paper proof of each
     proof step of the inductive case:

    C(n, k + 1)

               n!
  = -----------------------
    (n - (k + 1))! (k + 1)!

               n!
  = -----------------------
    (n - k - 1)! k! (k + 1)

           n! (n - k)
  = -------------------------------
    (n - k - 1)! (n - k) k! (k + 1)

                 n! (n - k)
  = ---------------------------------------
    (n - k - 1)! (n - k - 1 + 1) k! (k + 1)

            n! (n - k)
  = ---------------------------
    (n - k - 1 + 1)! k! (k + 1)

        n! (n - k)
  = -------------------
    (n - k)! k! (k + 1)

    n! (n - k)
  = ----------- / (k + 1)
    (n - k)! k!

        n!
  = ----------- * (n - k) / (k + 1)
    (n - k)! k!

  = C(n, k) * (n - k) / (k + 1)

  = bcoeff(n, k) * (n - k) / (k + 1)

  = bcoeff(n, k + 1)

  Your task is to translate this proof into Coq!

  Potentially useful hint:
  Note that multiplication and division have the same operator priority, and both
  are left-associative, so
     "a / b * c / d" is "((a / b) * c) / d", NOT "(a / b) * (c / d)"

  Here we go: *)
  Lemma bcoeff_correct: forall n k, k <= n -> bcoeff n k = C n k.
  Proof.
    induct k; simplify.
  Admitted.

  (* All binomial coefficients for a given n *)
  (* *************************************** *)

  (* In some applications, we need to know all binomal coefficients C(n,k) for a fixed n.
     For instance, if we want to symbolically evaluate (x + y)^4, the result is

     C(4,0)*x^4 + C(4,1)*x^3*y + C(4,2)*x^2*y^2 + C(4,3)*x*y^3 + C(4,4)*y^4

     The simplest way to compute such lists would be to just use the C we defined above: *)

  Definition all_coeffs_slow1(n: N): list N :=
    (recurse by cases
     | 0 => [1]
     | k + 1 => C n (k + 1) :: recurse
     end) n.

  Compute all_coeffs_slow1 0.
  Compute all_coeffs_slow1 1.
  Compute all_coeffs_slow1 2.
  Compute all_coeffs_slow1 3.
  Compute all_coeffs_slow1 4.
  Compute all_coeffs_slow1 5.
  Compute all_coeffs_slow1 15.
  (* However, this is not very efficient:

  Time Compute all_coeffs_slow1 100.

  takes 0.8s on my machine *)

  (* We could use our more efficient bcoeff from above: *)
  Definition all_coeffs_slow2(n: N): list N :=
    (recurse by cases
     | 0 => [1]
     | k + 1 => bcoeff n (k + 1) :: recurse
     end) n.

  Compute all_coeffs_slow2 5.
  Compute all_coeffs_slow2 15.
  (* This is faster:

     Time Compute all_coeffs_slow2 100.

  takes 0.2s on my machine and

    Time Compute all_coeffs_slow2 200.

  takes 1.7 s on my machine.

  But we can do even better by using Pascal's triangle:

        1
       1 1
      1 2 1
     1 3 3 1
    1 4 6 4 1

  You can observe that the i-th row of this triangle is the result of
  "all_coeffs_slow1 i", and that each value not at the boundary of the triangle is
  the sum of the values to its upper left and its upper right. For instance, the 6
  in the last row is the sum of the two 3s above it.
  More formally, we can state this as follows: *)
  Definition Pascal's_rule: Prop := forall n k,
      1 <= k <= n ->
      C (n+1) k = C n (k - 1) + C n k.
  (* Note that the above is only a definition which gives a name to this
     proposition but not a lemma.  We don't ask you to prove it, but it's a fun
     optional exercise; have a look at the end of this file if you're
     interested! *)

  (* The following function takes in a line of Pascal's triangle and computes the
     line below it: *)
  Definition nextLine(l: list N): list N :=
    1 :: seq (fun k => ith (k - 1) l + ith k l) (len l) 1.

  Compute nextLine [1; 3; 3; 1].
  Compute nextLine (nextLine [1; 3; 3; 1]).

  (* This allows us to define a faster all_coeffs function: *)
  Definition all_coeffs_fast: N -> list N :=
    recurse by cases
    | 0 => [1]
    | n + 1 => nextLine recurse
    end.

  (* Time Compute all_coeffs_fast 200. takes 0.35s on my computer *)

  (* Exercise: Let's prove that all_coeffs_fast is correct.
     Note that you can assume Pascal's rule to prove this. *)
  (* HINT 1 (see Pset2Sig.v) *)
  Lemma all_coeffs_fast_correct:
    Pascal's_rule ->
    forall n k,
      k <= n ->
      ith k (all_coeffs_fast n) = C n k.
  Proof.
  Admitted.

  (* ----- THIS IS THE END OF PSET2 ----- All exercises below this line are optional. *)

  (* Optional exercise: Let's prove that Pascal's rule holds.
     On paper, this can be proved as follows, but feel free to ignore this if you want
     the full challenge!

     C(n, k-1) + C(n, k)

             n!                 n!
  = --------------------- + -----------
    (n - k + 1)! (k - 1)!   (n - k)! k!

                n!                          n!
  = ----------------------------- + -------------------
    (n - k)! (n - k + 1) (k - 1)!   (n - k)! k (k - 1)!

                 n! k                          n! (n - k + 1)
  = ------------------------------- + -------------------------------
    (n - k)! (n - k + 1) (k - 1)! k   (n - k)! k (k - 1)! (n - k + 1)

           n! (k + n - k + 1)
  = -------------------------------
    (n - k)! (n - k + 1) (k - 1)! k

      (n + 1)!
  = ---------------
    (n - k + 1)! k!

  = C(n+1, k)
  *)
  Lemma Pascal's_rule_holds: Pascal's_rule.
  Proof.
    unfold Pascal's_rule.

    (* Note: Proving
         a     b     a+b
        --- + --- =  ---
         c     c      c
       is a bit trickier than you might expect, because we're using integer division here.
       So, for instance,
        1     3                                                              1+3
       --- + ---   equals 0 + 1 in round-down integer division, which is not ---
        2     2                                                               2
       To make sure this rule holds, we must also require that c and b both divide a: *)
    assert (forall a b c, c <> 0 -> (c | a) -> (c | b) -> a / c + b / c = (a + b) / c)
      as add_fractions. {
      clear.
      simplify.
      unfold N.divide in *. invert H0. invert H1.
      rewrite N.div_mul by assumption.
      rewrite N.div_mul by assumption.
      replace (x * c + x0 * c) with ((x + x0) * c) by nia.
      rewrite N.div_mul by assumption.
      reflexivity.
    }

  Admitted.

  (* Optional exercise:
     all_coeffs_fast is still not as fast as it could be, because nextLine uses ith
     to access the elements of the previous line, and each invocation of ith takes
     linear time in i.
     It would be more efficient to implement nextLine as a recursive function
     which iterates through the previous line just once and computes the next line
     on the fly.
     Define such a nextLine' function, and then use it to define all_coeffs_faster,
     observe how it's even faster than all_coeffs_fast, and finally, prove that
     it's correct. *)

  Definition nextLine'(l: list N): list N. Admitted.

  Definition all_coeffs_faster: N -> list N. Admitted.

  Lemma all_coeffs_faster_correct: forall n k,
      k <= n ->
      ith k (all_coeffs_faster n) = C n k.
  Proof.
  Admitted.
End Impl.

Module ImplCorrect : Pset2Sig.S := Impl.

(*|
TIPS: A few things to keep in mind as you work through pset 2
=============================================================
|*)

Require Import Coq.NArith.NArith.
Open Scope N_scope.
Require Import Frap.Frap.
Import Pset2.Impl.

Notation "x !" := (fact x) (at level 12, format "x !"). (* local in Pset2 *)

(* Here we demonstrate a number of useful Coq tactics.  Step though the
   examples, and check Coq's reference manual or ask us in office hours if
   you're confused about any of these tactics.

   These are not exercises, just neat examples; feel free to work on it at your
   pace over multiple psets and to refer to it at later points; no need to go
   through it all at once.  *)

(* The tactic we introduce in each example is underlined like this. *)
                                             (********************)

Parameter whatever: Prop.

(* ‘apply’ matches the conclusion of a theorem to the current goal, then
   replaces it with one subgoal per premise of that theorem: *)

Goal forall (P Q R: Prop) (H1: P) (H2: Q) (IH: P -> Q -> R), R.
Proof.
  simplify.
  apply IH.
 (********)
Abort.

(* Apply works with implications (`A -> B`) but also with equivalences, where
   it tries to pick the right direction based on the goal: *)
Goal forall (n m k: N), n = m.
Proof.
  simplify.
  Check N.mul_cancel_r.

  (* Careful: apply only works if it's clear how the theorem applies to your goal: *)
  Fail apply N.mul_cancel_r.
  (* Here, Coq wants to know the value of ‘p’ before it can apply the lemma; so,
     we use the ‘with’ for of ‘apply’ to supply it: *)
  apply N.mul_cancel_r with (p := n - k + 1).
 (****)               (****)
Abort.

(* Apply also works in hypotheses, where it turns premises into conclusions: *)
Goal forall (n m k: N), n = m -> whatever.
Proof.
  simplify.
  apply N.mul_cancel_r with (p := n - k + 1) in H.
 (*****)              (****)                (**)
Abort.

Goal forall (n m k: N), n - k + 1 <> 0 -> n = m -> whatever.
Proof.
  simplify.

  (* Specifying parameters by hand is not always convenient, so we can ask Coq
     to create placeholders instead, to be filled later: *)
  eapply N.mul_cancel_r in H0.
 (******)              (**)
  2: { (* This ‘2:’ notation means: operate on the second goal *)
    apply H.
  } (* … and the curly braces delimit a subproof. *)
Abort.

Goal forall (P Q R S: Prop), (P -> S) -> (R -> S) -> P \/ Q \/ R -> S.
Proof.
  simplify.
  cases H1. (* You are familiar with ‘cases’ from pset 1. *)
 (*****)
  - apply H. apply H1.
  - admit. (* ‘admit’ is just like ‘Admitted’ but for a single goal *)
   (*****)
  - apply H0. apply H1.
Fail Qed. (* But if you use ‘admit’, no ‘Qed’ for you! *)
Admitted.

(* Here is a convenient pattern that you will be familiar with from math
   classes.  It's called a “cut”.  We state an intermediate fact and prove it
   as part of a larger proof. *)

Goal forall (f : N -> N) (count : N)
       (IHcount : forall i start : N, i < count ->
                                 ith i (seq f count start) = f (start + i))
       (i start : N)
       (H : i < count + 1),
  ith i (f start :: seq f count (start + 1)) = f (start + i).
Proof.
  simplify.

  (* ‘assert’ introduces the fact that we want to prove, then uses *)
  assert (i = 0 \/ 0 < i) as A. { (* the ‘as’ clause to name the resulting fact *)
 (******)                (**)
    linear_arithmetic.          (* The proof of the lemma comes first. *)
  }
  cases A.                      (* Then we get to use the lemma itself. *)
  - subst. (* ‘subst’ rewrites all equalities. *)
   (*****)  (* or "subst i" for just one var *)
    simplify. admit.
  - (* Another assertion! This time we fit the whole proof in a ‘by’ clause. *)
    assert (i = i - 1 + 1) as E by linear_arithmetic.
   (******)                    (**)
    rewrite E.
    unfold_recurse ith (i - 1).
Abort.

Goal forall (n x0 k: N),
    0 < k ->
    k + 1 < n ->
    n! = x0 * ((n - (k - 1))! * (k - 1)!) ->
    whatever.
Proof.
  intros n m.
 (******)
  (* ‘simplify’ takes care of moving variables into the “context” above the
     line, but ‘intros’ gives finer grained control and lets you name
     hypotheses.  Users of Proof General with company-coq can type ‘intros!’ to
     get names automatically inserted. *)
  intros. (* A plain ‘intros’ takes care of all remaining variables. *)
  (******)

  (* Sometimes we want to say “a = b, so replace all ‘a’s with ‘b’s.”.  Replace
     is the perfect tactic for these cases; it's like ‘assert’ followed by
     ‘rewrite’. *)
  replace (n - (k - 1)) with (n - k + 1) in H1 by linear_arithmetic.
 (*******)             (****)           (**)  (**)
  (* "in" and "by" are optional *)
  unfold_recurse fact (n - k).
Abort.

Goal forall (P Q R: Prop) (H0: Q) (x: N) (H: forall (a b: N), P -> Q -> a < b -> R), whatever.
Proof.
  simplify.
  (* Often you have a general hypothesis, and you want to make it more specific
     to your case.  Then, ‘specialize’ is the tactic you want: *)
  specialize H with (b := x).
 (**********) (****)
  assert (3 < x) by admit.
  specialize H with (2 := H0) (3 := H1).
Abort.

Goal forall (f : N -> N) (start : N),
    f start = f (start + 0).
Proof.
  simplify.

  (* We have seen ‘apply’ earlier, which applies a theorem ending with an
     implication to a complete goal.  ‘rewrite’ takes a theorem ending in an
     equality and replaces matching subterms of the goal according to that
     equality: *)
  rewrite N.add_0_r.
 (*******)
  (* Options like "with (a := 2)", "in H", "by tactic" also work! *)
  equality.
Abort.

Goal forall (f : N -> N) (start : N),
    f start = f (start + 0).
Proof.
  simplify.
  (* Alternatively, sometimes, it helps to apply the principle that, if two
     function arguments match, then the function calls themselves match: *)
  f_equal.
 (*******)
  linear_arithmetic.
Abort.

Goal forall (f : N -> N) (start : N),
    f start = f (start + 0).
Proof.
  simplify.
  (* How many other ways can we find to deal with this theorem? *)
  assert (start + 0 = start) as E by linear_arithmetic.
  rewrite E.
Abort.

Goal forall (A B: Type) (f: A -> B) (a1 a2 a3: A),
    Some a1 = Some a2 ->
    Some a2 = Some a3 ->
    f a3 = f a1.
Proof.
  (* ‘simplify’ is a favorite of this class, which does all sorts of small goal
     reorganization to make things more readable. *)
  simplify.

  (* ‘invert’ is another favorite: it “replaces hypothesis H with other facts that can be deduced from the structure of H's statement”.

     Specifically, it looks at the structure of the arguments passed to the
     constructors of inductive types appearing in H and deduces equalities from
     that and then substitutes the equalities.  It's also particularly useful
     for inductive ‘Prop’s, which we will see later in this class. *)
  invert H. (* Watch what happens carefully in this example *)
 (******)
  invert H0.
  equality.
Abort.

Goal forall (A B: Type) (f: A -> B) (a1 a2 a3: A),
    Some a1 = Some a2 ->
    Some a2 = Some a3 ->
    f a3 = f a1.
Proof.
  simplify.
  equality. (* Of course, ‘equality’ can do all the work for us here. *)
 (********)
Abort.

Goal forall (a1 a2 b1 b2: N) (l1 l2: list N),
    a1 :: b1 :: l1 = a2 :: b2 :: l2 ->
    a1 = a2 /\ b1 = b2 /\ l1 = l2.
Proof.
  simplify.
  (* ‘invert’ works at arbitrary depth, btw: *)
  invert H.
 (******)
Abort.

(* If you ever end up with contradictory hypotheses, you'll want to apply the
   pompously named “ex falso quodlibet” principle (also known under the
   scary-sounding name of “principle of explosion”), through the aptly named
   ‘exfalso’ tactic: *)
Goal forall (P: Prop) (a b: N),
    (a < b -> ~P) ->
    P ->
    whatever.
Proof.
  simplify.
  assert (a < b \/ b <= a) as C by linear_arithmetic. cases C.
  - exfalso.
   (*******)
    unfold not in H.
    apply H.
    all: assumption.
Abort.

(* Contradictions can take many forms; a common one is Coq is an impossible equality between two constructors; here the empty list ‘[]’ and a nonempty list ‘a :: l’. *)
Goal forall (a : N) (l : list N),
    a :: l = [] ->
    whatever.
Proof.
  simplify.
  discriminate.
 (************)
Abort.

Goal forall (P Q R S T: Prop), (P \/ Q -> T) -> (R \/ S -> T) -> P \/ S -> T.
Proof.
  simplify.
  cases H1.
  - apply H. left. assumption.
  - apply H0. right. assumption.
Abort.

(* Here are some more interesting tactics to look into along your Coq journey.
   Happy proving!

   - constructor, econstructor
   - eassumption
   - eexists
   - first_order
   - induct
   - left, right
   - trivial
   - transitivity
   - symmetry
*)

(* References:

   - FRAP book Appendix A.2. Tactic Reference (http://adam.chlipala.net/frap/frap_book.pdf)
   - Coq Reference Manual, Chapter on Tactics (https://coq.inria.fr/refman/proof-engine/tactics.html)
*)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Binary relations                                                        *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibBool LibLogic LibProd LibSum.
From TLC Require Export LibOperation.

(* ********************************************************************** *)
(** * Type of binary relations *)

(* ---------------------------------------------------------------------- *)
(** ** Type of endorelation, i.e. homogeneous binary relations *)

(* --TODO: what would be a better name for [binary]? *)

Definition binary (A : Type) := A -> A -> Prop.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance Inhab_binary : forall A, Inhab (binary A).
Proof using. intros. apply (Inhab_of_val (fun _ _ => True)). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Extensionality *)

Lemma binary_ext : forall A (R1 R2:binary A),
  (forall x y, R1 x y <-> R2 x y) ->
  R1 = R2.
Proof using. extens*. Qed.

Instance Extensionality_binary : forall A,
  Extensionality (binary A).
Proof using. intros. apply (Extensionality_make (@binary_ext A)). Defined.

(* ********************************************************************** *)
(** * Properties of relations *)

(* ---------------------------------------------------------------------- *)
(** ** Reflexivity *)

Definition refl A (R:binary A) :=
  forall x, R x x.

Section Refl.
Variables (A : Type).
Implicit Types R : binary A.

Lemma refl_inv : forall x y R,
  refl R ->
  x = y ->
  R x y.
Proof using. intros_all. subst~. Qed.

End Refl.

(* ---------------------------------------------------------------------- *)
(** ** Irreflexivity *)

Definition irrefl A (R:binary A) :=
  forall x, ~ (R x x).

Section Irrefl.
Variables (A : Type).
Implicit Types R : binary A.

Lemma irrefl_inv : forall x R,
  irrefl R ->
  R x x ->
  False.
Proof using. introv H P. apply* H. Qed.

Lemma irrefl_eq_forall_neq : forall R,
  irrefl R = (forall x y, R x y -> x <> y).
Proof using.
  unfold irrefl. extens. iff M.
  { introv H E. subst*. }
  { autos*. }
Qed.

Lemma irrefl_inv_neq : forall x y R,
  irrefl R ->
  R x y ->
  x <> y.
Proof using. introv H M. rewrite* irrefl_eq_forall_neq in H. Qed.

End Irrefl.

(* ---------------------------------------------------------------------- *)
(** ** Symmetry *)

Definition sym A (R:binary A) :=
  forall x y, R x y -> R y x.

Section Sym.
Variables (A : Type).
Implicit Types R : binary A.

Lemma sym_inv : forall x y R,
  sym R ->
  R x y ->
  R y x.
Proof using. introv Sy R1. apply* Sy. Qed.

Lemma sym_inv_eq : forall x y R,
  sym R ->
  R x y = R y x.
Proof using. unfold sym. extens*. Qed.

Lemma sym_eq_forall_eq : forall R,
  sym R = (forall x y, R x y = R y x).
Proof using.
  unfold sym. extens. iff M.
  { extens*. }
  { intros. rewrite* M. }
Qed.

End Sym.

(* ---------------------------------------------------------------------- *)
(** ** Asymmetry *)

Definition asym A (R:binary A) :=
  forall x y, R x y -> ~ R y x.

Section Asym.
Variables (A : Type).
Implicit Types R : binary A.

Lemma asym_eq_forall_false : forall R,
  asym R = (forall x y, R x y -> R y x -> False).
Proof using. unfold asym. extens*. Qed.

Lemma asym_inv : forall x y R,
  asym R ->
  R x y ->
  R y x ->
  False.
Proof using. introv H M1 M2. apply* H. Qed.

End Asym.

(* ---------------------------------------------------------------------- *)
(** ** Antisymmetry *)

Definition antisym A (R:binary A) :=
  forall x y, R x y -> R y x -> x = y.

Section Antisym.
Variables (A : Type).
Implicit Types R : binary A.

Lemma antisym_eq_forall_eq : forall R,
  antisym R = (forall x y, R x y -> R y x -> x = y).
Proof using. unfold antisym. extens*. Qed.

Lemma antisym_inv : forall x y R,
  antisym R ->
  R x y ->
  R y x ->
  x <> y ->
  False.
Proof using. intros_all*. Qed.

End Antisym.

(* ---------------------------------------------------------------------- *)
(** ** Antisymmetry with respect to an equivalence relation *)

Definition antisym_wrt A (E:binary A) R :=
  forall x y, R x y -> R y x -> E x y.

(* --LATER: lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Transitivity *)

Definition trans A (R:binary A) :=
  forall y x z, R x y -> R y z -> R x z.

Section Trans.
Variables (A : Type).
Implicit Types R : binary A.

Lemma trans_eq_forall_impl : forall R,
  trans R = (forall y x z, R x y -> R y z -> R x z).
Proof using. unfold trans. extens*. Qed.

Lemma trans_inv : forall y x z R,
  trans R ->
  R x y ->
  R y z ->
  R x z.
Proof using. introv Tr R1 R2. apply* Tr. Qed.

Lemma trans_inv_swap : forall y x z R,
  trans R ->
  R y z ->
  R x y ->
  R x z.
Proof using. introv Tr R1 R2. apply* Tr. Qed.

(** [trans] + [sym] *)

Definition trans_sym_ll := trans_inv.

Lemma trans_sym_lr : forall y x z R,
  trans R ->
  sym R ->
  R x y ->
  R z y ->
  R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_rr : forall y x z R,
  trans R ->
  sym R ->
  R y x ->
  R z y ->
  R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_rl : forall y x z R,
  trans R ->
  sym R ->
  R y x ->
  R y z ->
  R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

End Trans.

Arguments trans_inv [A] y [x] [z] [R].
Arguments trans_inv_swap [A] y [x] [z] [R].
Arguments trans_sym_rr [A] y [x] [z] [R].
Arguments trans_sym_lr [A] y [x] [z] [R].
Arguments trans_sym_rl [A] y [x] [z] [R].

(* ---------------------------------------------------------------------- *)
(** ** Equivalence relation *)

Record equiv A (R:binary A) :=
 { equiv_refl : refl R;
   equiv_sym : sym R;
   equiv_trans : trans R }.

Section Equiv.
Variables (A : Type).
Implicit Types R : binary A.

(* --LATER: lemmas *)

End Equiv.

(* ---------------------------------------------------------------------- *)
(** ** Inclusion *)

(* --LATER: see also typeclass [incl] *)

Definition rel_incl A B (R1 R2:A->B->Prop) :=
  forall x y, R1 x y -> R2 x y.

Section Incl.
Variables (A B : Type).
Implicit Types R : A->B->Prop.

Lemma rel_incl_eq_forall_impl : forall R1 R2,
  rel_incl R1 R2 = (forall x y, R1 x y -> R2 x y).
Proof using. auto. Qed.

Lemma refl_rel_incl :
  refl (@rel_incl A B).
  (* forall (R:A->B->Prop), rel_incl R R *)
Proof using. unfolds refl, rel_incl. autos*. Qed.

Lemma refl_rel_incl' : forall R,
  rel_incl R R.
Proof using. intros. applys refl_rel_incl. Qed.

Hint Resolve refl_rel_incl refl_rel_incl'.

Lemma antisym_rel_incl :
  antisym (@rel_incl A B).
  (* forall R1 R2, rel_incl R1 R2 -> rel_incl R2 R1 -> R1 = R2. *)
Proof using. unfolds rel_incl. extens*. Qed.
  (* See also extensionality_pred_2 from LibEqual *)

Lemma trans_rel_incl :
  trans (@rel_incl A B).
Proof using. unfold trans, rel_incl. autos*. Qed.
  (* forall R1 R2 R3, rel_incl R1 R2 -> rel_incl R2 R3 ->  rel_incl R1 R3. *)

End Incl.

(* ---------------------------------------------------------------------- *)
(** ** Totality *)

Definition total A (R:binary A) :=
  forall x y, R x y \/ R y x.

Section Total.
Variables (A : Type).
Implicit Types R : binary A.

Lemma total_eq_forall_or : forall R,
  total R = (forall x y, R x y \/ R y x).
Proof using. auto. Qed.

Lemma total_inv : forall x y R,
  total R ->
  R x y \/ R y x.
Proof using. introv H. apply* H. Qed.

Lemma total_inv_not_l : forall x y R,
  total R ->
  ~ R x y ->
  R y x.
Proof using. introv H N. destruct* (H x y). Qed.

Lemma total_inv_not_r : forall x y R,
  total R ->
  ~ R y x ->
  R x y.
Proof using. introv H N. destruct* (H x y). Qed.

End Total.

(* ---------------------------------------------------------------------- *)
(** ** Trichotomy *)

Inductive trichotomy A (R:binary A) : binary A :=
  | trichotomy_left : forall x y,
      R x y ->
      x <> y ->
      ~ R y x ->
      trichotomy R x y
  | trichotomy_eq : forall x,
      ~ R x x ->
      trichotomy R x x
  | trichotomy_right : forall x y,
      ~ R x y ->
      x <> y ->
      R y x ->
      trichotomy R x y.

Definition trichotomous A (R:binary A) :=
  forall x y, trichotomy R x y.

(* ---------------------------------------------------------------------- *)
(** ** Definedness *)

Definition defined A B (R:A->B->Prop) :=
  forall x, exists y, R x y.

Section Defined.
Variables (A : Type).
Implicit Types R : binary A.

Lemma total_eq_forall_exists : forall R,
  defined R = (forall x, exists y, R x y).
Proof using. auto. Qed.

Lemma defined_inv : forall x R,
  defined R ->
  exists y, R x y.
Proof using. introv H. apply* H. Qed.

Lemma defined_inv_not : forall x R,
  defined R ->
  (forall y, ~ R x y) ->
  False.
Proof using. introv H N. forwards* (?&?): H. Qed.

End Defined.

(* ---------------------------------------------------------------------- *)
(** ** Functionality *)

Definition functional A B (R:A->B->Prop) :=
  forall x y z, R x y -> R x z -> y = z.

Section Functional.
Variables (A : Type).
Implicit Types R : binary A.

Lemma functional_eq_forall_eq : forall R,
  functional R = (forall x y z, R x y -> R x z -> y = z).
Proof using. auto. Qed.

Lemma functional_inv : forall x z y R,
  functional R ->
  R x y ->
  R x z ->
  y = z.
Proof using. introv H N1 N2. apply* H. Qed.

End Functional.

(* --TODO: define a tactic "functional_exploit R" that looks for two distinct
   assumptions in the goal of the form [R ?x ?y] and produces [functional R]
   as subgoal, and provides the equality [?y1 = ?y2]. *)

(* ---------------------------------------------------------------------- *)
(** ** Criteria for equality *)

Section Equality.
Variables (A : Type).
Implicit Types R : binary A.

(** If [R1] is defined, [R2] is functional, and [R1] is a subset of [R2],
    then [R1] equals [R2]. In that case, [R1] and [R2] represent the graph
    of a total function. *)

Lemma eq_of_incl_defined_functional : forall R1 R2,
  rel_incl R1 R2 ->
  defined R1 ->
  functional R2 ->
  R1 = R2.
Proof using.
  introv Hincl Hdef Hfun. extens. intros x y. iff M.
  { eauto. }
  { forwards (w'&M1): Hdef x.
    forwards M2: Hincl M1.
    forwards: Hfun M M2. subst*. }
Qed.

End Equality.

(* ---------------------------------------------------------------------- *)
(** ** Properties of the equality relation *)

(** These results are not in [LibEqual] because the definitions from
    [LibRelation] are not yet available from that file. *)

Section Eq.
Variables (A : Type).

Lemma refl_eq :
  refl (@eq A).
Proof using. intros_all; subst~. Qed.

Lemma sym_eq :
  sym (@eq A).
Proof using. intros_all; subst~. Qed.

Lemma trans_eq :
  trans (@eq A).
Proof using. intros_all; subst~. Qed.

Lemma equiv_eq :
  equiv (@eq A).
Proof using. intros. constructor; intros_all; subst~. Qed.

End Eq.

(* ---------------------------------------------------------------------- *)
(** ** Properties of the equality relation *)

(** These results are not in [LibLogic] because the definitions from
    [LibRelation] are not yet available from that file.
    See also [LibOrder] for a package of these properties. *)

Section Pred_incl.
Variables (A : Type).

Lemma refl_pred_incl :
  refl (@pred_incl A).
Proof using. unfold refl, pred_incl. autos*. Qed.

Lemma antisym_pred_incl :
  antisym (@pred_incl A).
Proof using. unfold antisym, pred_incl. extens*. Qed.

Lemma trans_pred_incl :
  trans (@pred_incl A).
Proof using. unfold trans, pred_incl. autos*. Qed.

End Pred_incl.

(* ---------------------------------------------------------------------- *)
(** ** Properties of the equivalence relation *)

(** These results are not in [LibLogic] because the definitions from
    [LibRelation] are not yet available from that file.
    See also [LibOrder] for a package of these properties. *)

Section Iff.

Lemma refl_iff :
  refl iff.
Proof using. unfold refl, iff. autos*. Qed.

Lemma antisym_iff :
  antisym iff.
Proof using. unfold antisym, iff. extens*. Qed.

Lemma trans_iff :
  trans iff.
Proof using. unfold trans, iff. autos*. Qed.

End Iff.

(* ********************************************************************** *)
(** * Basic constructions *)

(** LATER: plan to use typeclasses from LibContainer:
    - empty
    - single
    - in
    - binds
    - union
    - inter
    - incl
    - disjoint
    - restrict
    - remove
    - dom
    - img
*)

(* ---------------------------------------------------------------------- *)
(** ** The empty relation *)

(* --LATER: see also typeclass [empty] *)

Definition empty A : binary A :=
  fun x y => False.

Section Empty.
Variables (A : Type).
Implicit Types x y : A.

Lemma empty_eq : forall x y,
  empty x y = False.
Proof using. auto. Qed.

Lemma empty_inv : forall x y,
  empty x y ->
  False.
Proof using. auto. Qed.

Lemma functional_empty :
  functional (@empty A).
Proof using. unfolds* empty, functional. Qed.

End Empty.

(* ---------------------------------------------------------------------- *)
(** ** Union of two relations  *)

(* --LATER: see also typeclass [union] *)

Definition union A (R1 R2:binary A) : binary A :=
  fun x y => R1 x y \/ R2 x y.

Section Union.
Variables (A : Type).
Implicit Types R : binary A.

Lemma union_l : forall R1 R2 x y,
  R1 x y ->
  union R1 R2 x y.
Proof using. unfold union. eauto. Qed.

Lemma union_r : forall R1 R2 x y,
  R2 x y ->
  union R1 R2 x y.
Proof using. unfold union. eauto. Qed.

Lemma rel_incl_union_l : forall R1 R2,
  rel_incl R1 (union R1 R2).
Proof using. unfold rel_incl, union. eauto. Qed.

Lemma rel_incl_union_r : forall R1 R2,
  rel_incl R2 (union R1 R2).
Proof using. unfold rel_incl, union. eauto. Qed.

Lemma refl_union_l : forall R1 R2,
  refl R1 ->
  refl (union R1 R2).
Proof using. unfold refl, union. eauto. Qed.

Lemma refl_union_r : forall R1 R2,
  refl R2 ->
  refl (union R1 R2).
Proof using. unfold refl, union. eauto. Qed.

Lemma comm_union :
  comm (@union A).
  (* forall R1 R2, union R1 R2 = union R2 R1. *)
Proof using. unfold union. extens*. Qed.

Lemma comm_union_args : forall R1 R2 x y,
  union R2 R1 x y ->
  union R1 R2 x y.
Proof using. intros. rewrite~ comm_union. Qed.

(** Union is functional provided disjoint domains *)
Lemma functional_union : forall R1 R2,
  functional R1 ->
  functional R2 ->
  (forall x y z, R1 x y -> R2 x z -> False) ->
  functional (union R1 R2).
Proof using.
  intros. unfold union. intros x y z Hxy Hxz.
  destruct Hxy; destruct Hxz; auto_false*.
Qed.

(* --TODO: generic definition of covariant? *)
Lemma covariant_union : forall R1 R2 S1 S2,
  rel_incl R1 S1 ->
  rel_incl R2 S2 ->
  rel_incl (union R1 R2) (union S1 S2).
Proof using. unfold rel_incl, union. autos*. Qed.

End Union.

(* ---------------------------------------------------------------------- *)
(** ** Intersection of two relations  *)

(* --LATER: see also typeclass [inter] *)

Definition inter A (R1 R2:binary A) : binary A :=
  fun x y => R1 x y /\ R2 x y.

(* --LATER: add lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Complement of a relation *)

Definition compl A (R:binary A) : binary A :=
  fun x y => ~ R y x.

(* --LATER: add lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Inverse of a relation *)

Definition inverse A (R:binary A) : binary A :=
  fun x y => R y x.

Section Inverse.
Variables (A : Type).
Implicit Types R : binary A.

Lemma inverse_eq_fun : forall R,
  inverse R = (fun x y => R y x).
Proof using. auto. Qed.

Lemma inverse_eq : forall R x y,
  inverse R x y = R y x.
Proof using. auto. Qed.

Lemma injective_inverse :
  injective (@inverse A).
Proof using.
  intros R1 R2 E. extens. intros x y.
  unfolds inverse. rewrite* (fun_eq_2 y x E).
Qed.

Lemma inverse_sym : forall R,
  sym R ->
  inverse R = R.
Proof using. intros. unfold inverse. extens*. Qed.

Lemma inverse_inverse : forall R,
  inverse (inverse R) = R.
Proof using. extens*. Qed.

Lemma inverse_eq_l : forall R2 R1,
  R1 = inverse R2 ->
  inverse R1 = R2.
Proof using. intros. apply injective_inverse. rewrite~ inverse_inverse. Qed.

Lemma inverse_eq_r : forall R2 R1,
  inverse R1 = R2 ->
  R1 = inverse R2.
Proof using. intros. apply injective_inverse. rewrite~ inverse_inverse. Qed.

Lemma refl_inverse : forall R,
  refl R ->
  refl (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma trans_inverse : forall R,
  trans R ->
  trans (inverse R).
Proof using. intros_all. unfolds inverse. eauto. Qed.

Lemma antisym_inverse : forall R,
  antisym R ->
  antisym (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma antisym_wrt_inverse : forall E R,
  antisym_wrt E R ->
  antisym_wrt E (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma asym_inverse : forall R,
  asym R ->
  asym (inverse R).
Proof using. intros_all. unfolds inverse. apply* H. Qed.

Lemma total_inverse : forall R,
  total R ->
  total (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma trichotomous_inverse : forall R,
  trichotomous R ->
  trichotomous (inverse R).
Proof using.
  introv H. intros x y. destruct (H x y).
  apply~ trichotomy_right.
  apply~ trichotomy_eq.
  apply~ trichotomy_left.
Qed.

Lemma inverse_equiv : forall A (E:binary A),
  equiv E ->
  equiv (inverse E).
Proof using.
  introv Equi. unfold inverse. constructor; intros_all;
    dintuition eauto.
Qed.

End Inverse.

(* ---------------------------------------------------------------------- *)
(** ** [preimage] *)

(** Preimage, a.k.a. inverse image *)

Definition rel_preimage (A B:Type) (R:binary B) (f:A->B) : binary A :=
  fun x y => R (f x) (f y).

(* --TODO: lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** [rel_seq] *)

(** Composition of two relations, usually written [R1; R2]. *)

Definition rel_seq (A B C:Type) (R1:A->B->Prop) (R2:B->C->Prop) : A->C->Prop :=
  fun x z => exists y, R1 x y /\ R2 y z.

(** A relation [R] is functional if and only if [inverse R] composed
    with [R] is a subset of the diagonal relation [eq]. *)

Lemma functional_eq_seq_inverse_incl_eq : forall A (R:binary A),
  functional R = rel_incl (rel_seq (inverse R) R) eq.
Proof using.
  unfold functional, rel_incl, rel_seq, inverse. extens. iff M; jauto.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Turning a function into a relation. *)

Definition rel_fun A B (f:A->B) :=
  fun x y => (y = f x).

Section Rel_fun.
Variables (A : Type).
Implicit Types R : binary A.

(* --LATER: properties of [rel_fun] *)

End Rel_fun.

(* ********************************************************************** *)
(** * Products *)

(* ---------------------------------------------------------------------- *)
(** ** Pointwise product *)

Definition prod2 (A1 A2:Type)
  (R1:binary A1) (R2:binary A2)
   : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => match p1,p2 with (x1,x2),(y1,y2) =>
    R1 x1 y1 /\ R2 x2 y2 end.

Definition prod3 (A1 A2 A3:Type)
  (R1:binary A1) (R2:binary A2) (R3:binary A3)
   : binary (A1*A2*A3) :=
  prod2 (prod2 R1 R2) R3.

Definition prod4 (A1 A2 A3 A4:Type)
  (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
   : binary (A1*A2*A3*A4) :=
  prod2 (prod3 R1 R2 R3) R4.

(** Tactics *)

Tactic Notation "unfold_prod" :=
  unfold prod4, prod3, prod2.
Tactic Notation "unfolds_prod" :=
  unfold prod4, prod3, prod2 in *.

(** Equivalence *)

Lemma prod2_equiv : forall A1 A2 (E1:binary A1) (E2:binary A2),
  equiv E1 ->
  equiv E2 ->
  equiv (prod2 E1 E2).
Proof using.
  introv [R1 S1 T1] [R2 S2 T2]. constructor.
  { intros [x1 x2]. simple*. }
  { intros [x1 x2] [y1 y2]. simple*. }
  { intros [x1 x2] [y1 y2] [z1 z2]. simple*. }
Qed.

(* --LATER: other lemmas *)

(* ---------------------------------------------------------------------- *)
(** ** Lexicographical product *)

Definition lexico2 {A1 A2} (R1:binary A1) (R2:binary A2)
   : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => let (x1,x2) := p1 in let (y1,y2) := p2 in
  (R1 x1 y1) \/ (x1 = y1) /\ (R2 x2 y2).

Definition lexico3 {A1 A2 A3}
   (R1:binary A1) (R2:binary A2) (R3:binary A3) : binary (A1*A2*A3) :=
  lexico2 (lexico2 R1 R2) R3.

Definition lexico4 {A1 A2 A3 A4}
   (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
   : binary (A1*A2*A3*A4) :=
  lexico2 (lexico3 R1 R2 R3) R4.

(** Tactics *)

Tactic Notation "unfold_lexico" :=
  unfold lexico4, lexico3, lexico2.
Tactic Notation "unfolds_lexico" :=
  unfold lexico4, lexico3, lexico2 in *.

(** Elimination *)

Section Lexico.
Variables (A1 A2 A3 A4:Type).
Variables (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4).

Lemma lexico2_1 : forall x1 x2 y1 y2,
  R1 x1 y1 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof using. intros. left~. Qed.

Lemma lexico2_2 : forall x1 x2 y1 y2,
  x1 = y1 ->
  R2 x2 y2 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof using. intros. right~. Qed.

Lemma lexico3_1 : forall x1 x2 x3 y1 y2 y3,
  R1 x1 y1 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intros. left. left~. Qed.

Lemma lexico3_2 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 ->
  R2 x2 y2 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intro. left. right~. Qed.

Lemma lexico3_3 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 ->
  x2 = y2 ->
  R3 x3 y3 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intros. right~. Qed.

Lemma lexico4_1 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  R1 x1 y1 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. left. left~. Qed.

Lemma lexico4_2 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 ->
  R2 x2 y2 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. left. right~. Qed.

Lemma lexico4_3 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 ->
  x2 = y2 ->
  R3 x3 y3 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. right~. Qed.

Lemma lexico4_4 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  R4 x4 y4 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. right~. Qed.

End Lexico.

(** Transitivity *)

Lemma trans_lexico2 : forall A1 A2
   (R1:binary A1) (R2:binary A2),
  trans R1 ->
  trans R2 ->
  trans (lexico2 R1 R2).
Proof using.
  introv Tr1 Tr2. intros [x1 x2] [y1 y2] [z1 z2] Rxy Ryz.
  simpls. destruct Rxy as [L1|[Eq1 L1]];
   destruct Ryz as [M2|[Eq2 M2]]; subst*.
Qed.

Lemma trans_lexico3 : forall A1 A2 A3
   (R1:binary A1) (R2:binary A2) (R3:binary A3),
  trans R1 ->
  trans R2 ->
  trans R3 ->
  trans (lexico3 R1 R2 R3).
Proof using.
  introv Tr1 Tr2 Tr3. applys~ trans_lexico2. applys~ trans_lexico2.
Qed.

Lemma trans_lexico4 : forall A1 A2 A3 A4
   (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  trans R1 ->
  trans R2 ->
  trans R3 ->
  trans R4 ->
  trans (lexico4 R1 R2 R3 R4).
Proof using.
  introv Tr1 Tr2 Tr3. applys~ trans_lexico3. applys~ trans_lexico2.
Qed.

(** Inclusion *)

Lemma rel_incl_lexico2 : forall A1 A2
   (R1 R1':binary A1) (R2 R2':binary A2),
  rel_incl R1 R1' ->
  rel_incl R2 R2' ->
  rel_incl (lexico2 R1 R2) (lexico2 R1' R2').
Proof using.
  introv I1 I2. intros [x1 x2] [y1 y2] [H1|[H1 H2]].
  { left~. } { subst. right~. }
Qed.

(* --LATER: other lemmas *)

(* ********************************************************************** *)
(** * Closures *)

(* --LATER: more lemmas about union and inter *)

(* ---------------------------------------------------------------------- *)
(** ** Reflexive closure  *)

Inductive rclosure A (R:binary A) : binary A :=
  | rclosure_once : forall x y,
      R x y ->
      rclosure R x y
  | rclosure_refl : forall x,
      rclosure R x x.

Section Rclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rclosure.

(** Equivalent definition *)

Lemma rclosure_eq_fun : forall R,
  rclosure R = (fun x y => R x y \/ x = y).
Proof using. extens. iff M; destruct M; subst*. Qed.

Lemma rclosure_eq : forall R x y,
  rclosure R x y = (R x y \/ x = y).
Proof using. extens. iff M; destruct M; subst*. Qed.

Lemma rclosure_inv : forall R x y,
  rclosure R x y ->
  R x y \/ x = y.
Proof using. introv M; rewrite* rclosure_eq in M. Qed.

(** Properties *)

Lemma refl_rclosure : forall R,
  refl (rclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rclosure : forall R,
  sym R ->
  sym (rclosure R).
Proof using. unfolds sym. introv M N. destruct* N. Qed.

Lemma antisym_rclosure : forall R,
  antisym R ->
  antisym (rclosure R).
Proof using.
  unfolds antisym. introv M N1 N2.
  destruct N1; destruct N2; subst*.
Qed.

Lemma antisym_wrt_rclosure : forall E R,
  antisym_wrt E R ->
  antisym_wrt (rclosure E) (rclosure R).
Proof using.
  unfolds antisym_wrt. introv M N1 N2.
  destruct N1; destruct N2; subst*.
Qed.

Lemma trans_rclosure : forall R,
  trans R ->
  trans (rclosure R).
Proof using.
  unfolds trans. introv H M1 M2.
  destruct M1; destruct M2; subst*.
Qed.

Lemma total_rclosure : forall R,
  total R ->
  total (rclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma rclosure_eq_of_refl : forall R,
  refl R ->
  rclosure R = R.
Proof using.
  unfolds refl. introv H. extens. iff M.
  { destruct M; subst*. } { auto. }
Qed.

Lemma rclosure_inverse_eq : forall R,
  rclosure (inverse R) = inverse (rclosure R).
Proof using. unfold inverse. extens. iff M; destruct* M. Qed.

(** Constructors *)

(** -- TODO: rename to
   rclosure_of_rclosure_step
   rclosure_of_step_rclosure
   trans_inv_rclosure_step
   trans_inv_step_rclosure *)

Lemma rclosure_trans_l : forall y x z R,
  trans R ->
  rclosure R x y ->
  R y z ->
  rclosure R x z.
Proof using. introv T M N. rewrite rclosure_eq in *. destruct M; subst*. Qed.

Lemma rclosure_trans_r : forall y x z R,
  trans R ->
  R x y ->
  rclosure R y z ->
  rclosure R x z.
Proof using. introv T M N. rewrite rclosure_eq in *. destruct N; subst*. Qed.

Lemma trans_rclosure_l : forall y x z R,
  trans R ->
  rclosure R x y ->
  R y z ->
  R x z.
Proof using. introv T M H. rewrite rclosure_eq in *. destruct M; subst*. Qed.

Lemma trans_rclosure_r : forall y x z R,
  trans R ->
  R x y ->
  rclosure R y z ->
  R x z.
Proof using. introv T M N. rewrite rclosure_eq in *. destruct N; subst*. Qed.

(** Negation *)

Lemma not_rclosure_inv : forall R x y,
  ~ rclosure R x y ->
  ~ R x y /\ x <> y.
Proof using. introv M. rewrite* rclosure_eq in M. Qed.

Lemma not_rclosure_inv_rel : forall R x y,
  ~ rclosure R x y ->
  ~ R x y.
Proof using. introv M. rewrite* rclosure_eq in M. Qed.

Lemma not_rclosure_inv_neq : forall R x y,
  ~ rclosure R x y ->
  x <> y.
Proof using. introv M. rewrite* rclosure_eq in M. Qed.

(** Inclusions *)

Lemma rel_incl_rclosure : forall R,
  rel_incl R (rclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rclosure_of_rel : forall R x y,
  R x y ->
  rclosure R x y.
Proof using. intros. applys* rel_incl_rclosure. Qed.

Lemma covariant_rclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rclosure R1) (rclosure R2).
Proof using. introv H M. destruct* M. Qed.

Lemma rel_incl_rclosure_rclosure : forall R1 R2,
  rel_incl R1 (rclosure R2) ->
  rel_incl (rclosure R1) (rclosure R2).
Proof using. introv H M. destruct* M. Qed.

End Rclosure.

Hint Constructors rclosure : rclosure.
(* --LATER: here and later, add more hints *)

(* ---------------------------------------------------------------------- *)
(** ** Symmetric closure  *)

Inductive sclosure A (R:binary A) : binary A :=
  | sclosure_once : forall x y,
      R x y ->
      sclosure R x y
  | sclosure_sym : forall x y,
      sclosure R y x ->
      sclosure R x y.

Section Sclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors sclosure.

(** Equivalent definition *)

Lemma sclosure_eq : forall R x y,
  sclosure R x y = (R x y \/ R y x).
Proof using.
  extens. iff M.
  { induction* M. }
  { destruct M; subst*. }
Qed.

Lemma sclosure_inv : forall R x y,
  sclosure R x y ->
  R x y \/ R y x.
Proof using. introv M; rewrite* sclosure_eq in M. Qed.

(** Properties *)

Lemma refl_sclosure : forall R,
  refl R ->
  refl (sclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_sclosure : forall R,
  sym (sclosure R).
Proof using. unfolds sym. introv N. destruct* N. Qed.

Lemma total_sclosure : forall R,
  total R ->
  total (sclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma sclosure_eq_of_sym : forall R,
  sym R ->
  sclosure R = R.
Proof using.
  unfolds sym. introv H. extens. intros. rewrite sclosure_eq.
  iff M. { destruct M; subst*. } { auto. }
Qed.

Lemma sclosure_inverse_eq : forall R,
  sclosure (inverse R) = sclosure R.
Proof using.
  unfolds inverse. extens. intros. do 2 rewrite sclosure_eq. autos*.
Qed.

(** Negation *)

Lemma not_sclosure_inv : forall R x y,
  ~ sclosure R x y ->
  ~ R x y /\ ~ R y x.
Proof using. introv M. rewrite* sclosure_eq in M. Qed.

Lemma not_sclosure_inv_l : forall R x y,
  ~ sclosure R x y ->
  R x y ->
  False.
Proof using. introv M. rewrite* sclosure_eq in M. Qed.

Lemma not_sclosure_inv_r : forall R x y,
  ~ sclosure R x y ->
  R y x ->
  False.
Proof using. introv M. rewrite* sclosure_eq in M. Qed.

(** Inclusions *)

Lemma rel_incl_sclosure : forall R,
  rel_incl R (sclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rel_incl_inverse_sclosure : forall R,
  rel_incl (inverse R) (sclosure R).
Proof using. unfolds* rel_incl, inverse. Qed.

Lemma covariant_sclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (sclosure R1) (sclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_sclosure_sclosure : forall R1 R2,
  rel_incl R1 (sclosure R2) ->
  rel_incl (sclosure R1) (sclosure R2).
Proof using. introv H M. induction* M. Qed.

End Sclosure.

Hint Constructors sclosure : sclosure.

(* ---------------------------------------------------------------------- *)
(** ** Reflexive-symmetric closure  *)

Inductive rsclosure A (R:binary A) : binary A :=
  | rsclosure_once : forall x y,
      R x y ->
      rsclosure R x y
  | rsclosure_refl : forall x,
      rsclosure R x x
  | rsclosure_sym : forall x y,
      rsclosure R x y ->
      rsclosure R y x.

Section Rsclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rsclosure.

(** Equivalent definition *)

Lemma rsclosure_eq : forall R x y,
  rsclosure R x y = (R x y \/ R y x \/ x = y).
Proof using.
  extens. iff M.
  { induction* M. }
  { destruct M as [M|[M|M]]; subst*. }
Qed.

Lemma rsclosure_inv : forall R x y,
  rsclosure R x y ->
  R x y \/ R y x \/ x = y.
Proof using. introv M; rewrite* rsclosure_eq in M. Qed.

(** Properties *)

Lemma refl_rsclosure : forall R,
  refl (rsclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rsclosure : forall R,
  sym (rsclosure R).
Proof using. unfolds sym. introv N. destruct* N. Qed.

Lemma total_rsclosure : forall R,
  total R ->
  total (rsclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma rsclosure_inverse_eq : forall R,
  rsclosure (inverse R) = rsclosure R.
Proof using.
  unfold inverse. extens. intros. do 2 rewrite rsclosure_eq. autos*.
Qed.

(** Negation *)

Lemma not_rsclosure_inv : forall R x y,
  ~ rsclosure R x y ->
  ~ R x y /\ ~ R y x /\ ~ x = y.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

Lemma not_rsclosure_inv_l : forall R x y,
  ~ rsclosure R x y ->
  R x y ->
  False.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

Lemma not_rsclosure_inv_r : forall R x y,
  ~ rsclosure R x y ->
  R y x ->
  False.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

Lemma not_rsclosure_inv_neq : forall R x y,
  ~ rsclosure R x y ->
  x <> y.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

(** Inclusions *)

Lemma rel_incl_rsclosure : forall R,
  rel_incl R (rsclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rel_incl_inverse_rsclosure : forall R,
  rel_incl (inverse R) (rsclosure R).
Proof using. unfolds* rel_incl, inverse. Qed.

Lemma covariant_rsclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rsclosure R1) (rsclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_rsclosure_rsclosure : forall R1 R2,
  rel_incl R1 (rsclosure R2) ->
  rel_incl (rsclosure R1) (rsclosure R2).
Proof using. introv H M. induction* M. Qed.

End Rsclosure.

Hint Constructors rsclosure : rsclosure.

(* ---------------------------------------------------------------------- *)
(** ** Transitive closure ( R+ ), defined as [R \o R*] *)

Inductive tclosure A (R:binary A) : binary A :=
  | tclosure_once : forall x y,
      R x y ->
      tclosure R x y
  | tclosure_trans : forall y x z,
      tclosure R x y ->
      tclosure R y z ->
      tclosure R x z.

Section Tclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors tclosure.

(** Properties *)

Lemma refl_tclosure : forall R,
  refl R ->
  refl (tclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_tclosure : forall R,
  sym R ->
  sym (tclosure R).
Proof using. unfolds sym. introv H N. induction* N. Qed.

Lemma trans_tclosure : forall R,
  trans (tclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_tclosure : forall R,
  total R ->
  total (tclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma tclosure_eq_of_trans : forall R,
  trans R ->
  tclosure R = R.
Proof using.
  unfolds trans. introv H. extens. iff M.
  { induction M; subst*. }
  { auto. }
Qed.

Lemma tclosure_inverse_eq : forall R,
  tclosure (inverse R) = inverse (tclosure R).
Proof using.
  unfolds inverse. extens. intros x y. iff M; induction* M.
Qed.

(** Constructors *)

Lemma tclosure_l : forall R y x z,
  R x y ->
  tclosure R y z ->
  tclosure R x z.
Proof using. autos*. Qed.

Lemma tclosure_r : forall R y x z,
  tclosure R x y ->
  R y z ->
  tclosure R x z.
Proof using. autos*. Qed.

(** Inclusions *)

Lemma rel_incl_tclosure : forall R,
  rel_incl R (tclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma covariant_tclosure : forall A (R1 R2 : binary A),
  rel_incl R1 R2 ->
  rel_incl (tclosure R1) (tclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_tclosure_tclosure : forall R1 R2,
  rel_incl R1 (tclosure R2) ->
  rel_incl (tclosure R1) (tclosure R2).
Proof using. introv H M. induction* M. Qed.

(** Induction principle with steps at head or tail *)

Section Ind.

Inductive tclosure'l A (R:binary A) : binary A :=
  | tclosure'l_once : forall x y,
      R x y ->
      tclosure'l R x y
  | tclosure'l_step : forall y x z,
      R x y ->
      tclosure'l R y z ->
      tclosure'l R x z.

Lemma trans_tclosure'l : forall R,
  trans (tclosure'l R).
Proof using.
  Hint Constructors tclosure'l.
  intros R y x z M1. gen z. induction M1; introv M2; autos*.
Qed.

Lemma tclosure_eq_tclosure'l : forall R,
  tclosure R = tclosure'l R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_tclosure'l y. }
  { induction* M. }
Qed.

Lemma tclosure_ind_l : forall R (P : A -> A -> Prop),
  (forall x y, R x y -> P x y) ->
  (forall y x z, R x y -> tclosure R y z -> P y z -> P x z) ->
  (forall x y, tclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite tclosure_eq_tclosure'l in *. induction* M.
Qed.

Inductive tclosure'r A (R:binary A) : binary A :=
  | tclosure'r_once : forall x y,
      R x y ->
      tclosure'r R x y
  | tclosure'r_step : forall y x z,
      tclosure'r R x y ->
      R y z ->
      tclosure'r R x z.

Lemma trans_tclosure'r : forall R,
  trans (tclosure'r R).
Proof using.
  Hint Constructors tclosure'r.
  intros R y x z M1 M2. gen x. induction M2; introv M1; autos*.
Qed.

Lemma tclosure_eq_tclosure'r : forall R,
  tclosure R = tclosure'r R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_tclosure'r y. }
  { induction* M. }
Qed.

Lemma tclosure_ind_r : forall R (P : A -> A -> Prop),
  (forall x y, R x y -> P x y) ->
  (forall y x z, tclosure R x y -> P x y -> R y z -> P x z) ->
  (forall x y, tclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite tclosure_eq_tclosure'r in *. induction* M.
Qed.

(* --LATER: can these induction principles be proved directly? *)

End Ind.

(** Inversion principle with steps at head or tail *)

Lemma tclosure_inv_l : forall R x z,
  tclosure R x z ->
  (R x z) \/ (exists y, R x y /\ tclosure R y z).
Proof using. intros R. applys* tclosure_ind_l. Qed.

Lemma tclosure_inv_r : forall R x z,
  tclosure R x z ->
  (R x z) \/ (exists y, tclosure R x y /\ R y z).
Proof using. intros R. applys* tclosure_ind_r. Qed.

End Tclosure.

Hint Resolve tclosure_once tclosure_l tclosure_r
  : rtclosure.

(* ---------------------------------------------------------------------- *)
(** ** Reflexive-transitive closure ( R* ) *)

Inductive rtclosure A (R:binary A) : binary A :=
  | rtclosure_once : forall x y,
      R x y ->
      rtclosure R x y
  | rtclosure_refl : forall x,
      rtclosure R x x
  | rtclosure_trans : forall y x z,
      rtclosure R x y ->
      rtclosure R y z ->
      rtclosure R x z.

Section Rtclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rtclosure.

(** Properties *)

Lemma refl_rtclosure : forall R,
  refl (rtclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rtclosure : forall R,
  sym R ->
  sym (rtclosure R).
Proof using. unfolds sym. introv M N. induction* N. Qed.

Lemma trans_rtclosure : forall R,
  trans (rtclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_rtclosure : forall R,
  total R ->
  total (rtclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma tclosure_eq_of_refl_trans : forall R,
  refl R ->
  trans R ->
  rtclosure R = R.
Proof using.
  unfolds refl, trans. introv H1 H2. extens. iff M.
  { induction M; subst*. }
  { autos*. }
Qed.

Lemma rtclosure_inverse_eq : forall R,
  rtclosure (inverse R) = inverse (rtclosure R).
Proof using. unfold inverse. extens. iff M; induction* M. Qed.

(** Constructors *)

Lemma rtclosure_l : forall R y x z,
  R x y ->
  rtclosure R y z ->
  rtclosure R x z.
Proof using. autos*. Qed.

Lemma rtclosure_r : forall R y x z,
  rtclosure R x y ->
  R y z ->
  rtclosure R x z.
Proof using. autos*. Qed.

(* Same as above, reformulated to make [eauto] faster *)
Lemma rtclosure_r' : forall R y x z,
  R y z ->
  rtclosure R x y ->
  rtclosure R x z.
Proof using. autos*. Qed.

(** Inclusion *)

Lemma rel_incl_rtclosure : forall R,
  rel_incl R (rtclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma covariant_rtclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rtclosure R1) (rtclosure R2).
Proof using. unfolds rel_incl. introv H M. induction* M. Qed.

(* --TODO: find better name for this one and similar *)
Lemma rel_incl_rtclosure_rtclosure : forall R1 R2,
  rel_incl R1 (rtclosure R2) ->
  rel_incl (rtclosure R1) (rtclosure R2).
Proof using. unfolds rel_incl. introv H M. induction* M. Qed.

Lemma rel_incl_union_rtclosure : forall R1 R2,
  rel_incl (union (rtclosure R1) (rtclosure R2))
           (rtclosure (union R1 R2)).
Proof using.
  hint rel_incl_union_l, rel_incl_union_r. introv [M|M].
  { applys* covariant_rtclosure R1. }
  { applys* covariant_rtclosure R2. }
Qed.

(** Negation *)

Lemma not_rtclosure_inv_neq : forall R x y,
  ~ rtclosure R x y ->
  x <> y.
Proof using. introv M E. subst. induction* M. Qed.

(** Induction principle with steps at head or tail *)

Section Ind.

Inductive rtclosure'l A (R:binary A) : binary A :=
  | rtclosure'l_refl : forall x,
      rtclosure'l R x x
  | rtclosure'l_step : forall y x z,
      R x y ->
      rtclosure'l R y z ->
      rtclosure'l R x z.

Lemma trans_rtclosure'l : forall R,
  trans (rtclosure'l R).
Proof using.
  Hint Constructors rtclosure'l.
  intros R y x z M1. gen z. induction M1; introv M2; autos*.
Qed.

Lemma rtclosure_eq_rtclosure'l : forall R,
  rtclosure R = rtclosure'l R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_rtclosure'l y. }
  { induction* M. }
Qed.

Lemma rtclosure_ind_l : forall R (P : A -> A -> Prop),
  (forall x, P x x) ->
  (forall y x z, R x y -> rtclosure R y z -> P y z -> P x z) ->
  (forall x y, rtclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite rtclosure_eq_rtclosure'l in *. induction* M.
Qed.

Inductive rtclosure'r A (R:binary A) : binary A :=
  | rtclosure'r_refl : forall x,
      rtclosure'r R x x
  | rtclosure'r_step : forall y x z,
      rtclosure'r R x y ->
      R y z ->
      rtclosure'r R x z.

Lemma trans_rtclosure'r : forall R,
  trans (rtclosure'r R).
Proof using.
  Hint Constructors rtclosure'r.
  intros R y x z M1 M2. gen x. induction M2; introv M1; autos*.
Qed.

Lemma rtclosure_eq_rtclosure'r : forall R,
  rtclosure R = rtclosure'r R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_rtclosure'r y. }
  { induction* M. }
Qed.

Lemma rtclosure_ind_r : forall R (P : A -> A -> Prop),
  (forall x, P x x) ->
  (forall y x z, rtclosure R x y -> P x y -> R y z -> P x z) ->
  (forall x y, rtclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite rtclosure_eq_rtclosure'r in *. induction* M.
Qed.

End Ind.

(** Inversion principle with steps at head or tail *)

Lemma rtclosure_inv_l : forall R x z,
  rtclosure R x z ->
  (x = z) \/ (exists y, R x y /\ rtclosure R y z).
Proof using. intros R. applys* rtclosure_ind_l. Qed.

Lemma rtclosure_inv_r : forall R x z,
  rtclosure R x z ->
  (x = z) \/ (exists y, rtclosure R x y /\ R y z).
Proof using. intros R. applys* rtclosure_ind_r. Qed.

End Rtclosure.

Hint Resolve rtclosure_refl rtclosure_once
  rtclosure_l rtclosure_r' : rtclosure.

(* ---------------------------------------------------------------------- *)
(** ** Symmetric-transitive closure *)

Inductive stclosure A (R:binary A) : binary A :=
  | stclosure_once : forall x y,
      R x y ->
      stclosure R x y
  | stclosure_sym : forall x y,
      stclosure R x y ->
      stclosure R y x
  | stclosure_trans : forall y x z,
      stclosure R x y ->
      stclosure R y z ->
      stclosure R x z.

Section Stclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors stclosure.

(** Properties *)

Lemma refl_stclosure : forall R,
  refl R ->
  refl (stclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_stclosure : forall R,
  sym (stclosure R).
Proof using. unfolds sym. introv N. induction* N. Qed.

Lemma trans_stclosure : forall R,
  trans (stclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_stclosure : forall R,
  total R ->
  total (stclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma stclosure_eq_of_sym_trans : forall R,
  sym R ->
  trans R ->
  stclosure R = R.
Proof using.
  unfolds sym, trans. introv H1 H2. extens. iff M.
  { induction M; subst*. }
  { autos*. }
Qed.

Lemma stclosure_inverse_eq : forall R,
  stclosure (inverse R) = inverse (stclosure R).
Proof using.
  unfolds inverse. extens. intros x y. iff M; induction* M.
Qed.

(** Constructors *)

Lemma stclosure_l : forall R y x z,
  R x y ->
  stclosure R y z ->
  stclosure R x z.
Proof using. autos*. Qed.

Lemma stclosure_r : forall R y x z,
  stclosure R x y ->
  R y z ->
  stclosure R x z.
Proof using. autos*. Qed.

(** Inclusion *)

Lemma rel_incl_stclosure : forall R,
  rel_incl R (stclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma covariant_stclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (stclosure R1) (stclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_stclosure_stclosure : forall R1 R2,
  rel_incl R1 (stclosure R2) ->
  rel_incl (stclosure R1) (stclosure R2).
Proof using. introv H M. induction* M. Qed.

End Stclosure.

Hint Constructors stclosure : stclosure.

(* ---------------------------------------------------------------------- *)
(** ** Reflexive-symmetric-transitive closure *)

Inductive rstclosure A (R:binary A) : binary A :=
  | rstclosure_once : forall x y,
      R x y ->
      rstclosure R x y
  | rstclosure_refl : forall x,
      rstclosure R x x
  | rstclosure_sym : forall x y,
      rstclosure R x y ->
      rstclosure R y x
  | rstclosure_trans : forall y x z,
      rstclosure R x y ->
      rstclosure R y z ->
      rstclosure R x z.

Section Rstclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rstclosure.

(** Properties *)

Lemma refl_rstclosure : forall R,
  refl (rstclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rstclosure : forall R,
  sym (rstclosure R).
Proof using. unfolds* sym. Qed.

Lemma trans_rstclosure : forall R,
  trans (rstclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_rstclosure : forall R,
  total R ->
  total (rstclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma rstclosure_eq_of_refl_sym_trans : forall R,
  refl R ->
  sym R ->
  trans R ->
  rstclosure R = R.
Proof using.
  unfolds refl, sym, trans. introv H. extens. iff M.
  { induction M; subst*. }
  { auto. }
Qed.

Lemma rstclosure_inverse_eq : forall R,
  rstclosure (inverse R) = rstclosure R.
Proof using.
  unfolds inverse. extens. intros x y. iff M; induction* M.
Qed.

(** Constructors *)

Lemma rstclosure_l : forall R y x z,
  R x y ->
  rstclosure R y z ->
  rstclosure R x z.
Proof using. autos*. Qed.

Lemma rstclosure_r : forall R y x z,
  rstclosure R x y ->
  R y z ->
  rstclosure R x z.
Proof using. autos*. Qed.

(** Inclusion *)

Lemma rel_incl_rstclosure : forall R,
  rel_incl R (rstclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rel_incl_inverse_rstclosure : forall R,
  rel_incl (inverse R) (rstclosure R).
Proof using. unfolds* rel_incl, inverse. Qed.

Lemma covariant_rstclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rstclosure R1) (rstclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_rstclosure_rstclosure : forall R1 R2,
  rel_incl R1 (rstclosure R2) ->
  rel_incl (rstclosure R1) (rstclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_union_rstclosure : forall R1 R2,
  rel_incl (union (rstclosure R1) (rstclosure R2))
           (rstclosure (union R1 R2)).
Proof using.
  hint rel_incl_union_l, rel_incl_union_r. introv [M|M].
  { applys* covariant_rstclosure R1. }
  { applys* covariant_rstclosure R2. }
Qed.

End Rstclosure.

Hint Constructors rstclosure : rstclosure.

(* ---------------------------------------------------------------------- *)
(** ** Relationship between closures *)

Section ClosuresRel.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rtclosure rsclosure stclosure rstclosure.

(** [rclosure] to [rtclosure] *)

Lemma rtclosure_of_rclosure : forall R x y,
  rclosure R x y ->
  rtclosure R x y.
Proof using. intros. destruct* H. Qed.

Lemma rel_incl_rclosure_rtclosure : forall R,
  rel_incl (rclosure R) (rtclosure R).
Proof using. intros. applys* rtclosure_of_rclosure. Qed.

(** [tclosure] to [rtclosure] *)

Lemma rtclosure_of_tclosure : forall R x y,
  tclosure R x y ->
  rtclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_tclosure_rtclosure : forall R,
  rel_incl (tclosure R) (rtclosure R).
Proof using. intros. applys* rtclosure_of_tclosure. Qed.

(** [rclosure] to [rsclosure] *)

Lemma rsclosure_of_rclosure : forall R x y,
  rclosure R x y ->
  rsclosure R x y.
Proof using. intros. destruct* H. Qed.

Lemma rel_incl_rclosure_rsclosure : forall R,
  rel_incl (rclosure R) (rsclosure R).
Proof using. intros. applys* rsclosure_of_rclosure. Qed.

(** [sclosure] to [rsclosure] *)

Lemma rsclosure_of_sclosure : forall R x y,
  sclosure R x y ->
  rsclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_sclosure_rsclosure : forall R,
  rel_incl (sclosure R) (rsclosure R).
Proof using. intros. applys* rsclosure_of_sclosure. Qed.

(** [sclosure] to [stclosure] *)

Lemma stclosure_of_sclosure : forall R x y,
  sclosure R x y ->
  stclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_slosure_rsclosure : forall R,
  rel_incl (sclosure R) (stclosure R).
Proof using. intros. applys* stclosure_of_sclosure. Qed.

(** [tclosure] to [stclosure] *)

Lemma stclosure_of_tclosure : forall R x y,
  tclosure R x y ->
  stclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_tclosure_stclosure : forall R,
  rel_incl (tclosure R) (stclosure R).
Proof using. intros. applys* stclosure_of_tclosure. Qed.

(** [rclosure] to [rstclosure] *)

Lemma rstclosure_of_rclosure : forall R x y,
  rclosure R x y ->
  rstclosure R x y.
Proof using. intros. destruct* H. Qed.

Lemma rel_incl_rclosure_rstclosure : forall R,
  rel_incl (rclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_rclosure. Qed.

(** [sclosure] to [rstclosure] *)

Lemma rstclosure_of_sclosure : forall R x y,
  sclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_sclosure_rstclosure : forall R,
  rel_incl (sclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_sclosure. Qed.

(** [tclosure] to [tstclosure] *)

Lemma rstclosure_of_tclosure : forall R x y,
  tclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_tclosure_rstclosure : forall R,
  rel_incl (tclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_tclosure. Qed.

(** [rsclosure] to [rstclosure] *)

Lemma rstclosure_of_rsclosure : forall R x y,
  rsclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_rsclosure_rstclosure : forall R,
  rel_incl (rsclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_rsclosure. Qed.

(** [rtclosure] to [rstclosure] *)

Lemma rstclosure_of_rtclosure : forall R x y,
  rtclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_rtclosure_rstclosure : forall R,
  rel_incl (rtclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_rtclosure. Qed.

(** [stclosure] to [rstclosure] *)

Lemma rstclosure_of_stclosure : forall R x y,
  stclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_stclosure_rstclosure : forall R,
  rel_incl (stclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_stclosure. Qed.

End ClosuresRel.

(* ---------------------------------------------------------------------- *)
(** ** Iterated closures *)

Section IterClosures.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rclosure sclosure tclosure
  rtclosure rsclosure stclosure rstclosure.
Hint Resolve sym_tclosure sym_sclosure sym_rclosure
  sym_rtclosure sym_rsclosure sym_rtclosure sym_rstclosure.

Lemma rclosure_sclosure_eq_rsclosure : forall R,
  rclosure (sclosure R) = rsclosure R.
Proof using.
  extens. intros x y. iff M.
  { destruct* M. { applys* rsclosure_of_sclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

Lemma sclosure_rclosure_eq_rsclosure : forall R,
  sclosure (rclosure R) = rsclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rsclosure_of_rclosure. } }
  { induction* M. }
Qed.

Lemma rclosure_tclosure_eq_rtclosure : forall R,
  rclosure (tclosure R) = rtclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rtclosure_of_tclosure. } }
  { induction* M. { destruct IHM1; destruct IHM2; autos*. } }
Qed.

Lemma tclosure_rclosure_eq_rtclosure : forall R,
  tclosure (rclosure R) = rtclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rtclosure_of_rclosure. } }
  { induction* M. }
Qed.

Lemma tclosure_sclosure_eq_stclosure : forall R,
  tclosure (sclosure R) = stclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* stclosure_of_sclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

Lemma rclosure_stclosure_eq_rstclosure : forall R,
  rclosure (stclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_stclosure. } }
  { induction* M.
    { destruct IHM; autos*. }
    { destruct IHM1; destruct IHM2; autos*. } }
Qed.

Lemma stclosure_rclosure_eq_rstclosure : forall R,
  stclosure (rclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_rclosure. } }
  { induction* M. }
Qed.

Lemma rtclosure_sclosure_eq_rstclosure : forall R,
  rtclosure (sclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_sclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

Lemma tclosure_rsclosure_eq_rstclosure : forall R,
  tclosure (rsclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_rsclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

End IterClosures.

(* ---------------------------------------------------------------------- *)
(** ** Other lemmas -- TODO *)

Section EquivClosures.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rclosure sclosure tclosure rsclosure stclosure.

Lemma rsclosure_eq_union_rclosure_sclosure : forall R,
  rsclosure R = union (rclosure R) (sclosure R).
Proof using.
  extens. intros x y. unfold union. iff M.
  { induction* M. destruct* IHM as [H|H]. destruct* H. }
  { destruct* M as [H|H]. destruct* H. applys* rsclosure_of_sclosure. }
Qed.

Lemma rtclosure_eq_union_rclosure_tclosure : forall R,
  rtclosure R = union (rclosure R) (tclosure R).
Proof using.
  extens. intros x y. unfold union. iff M.
  { induction* M. destruct IHM1 as [H1|H1]; destruct IHM2 as [H2|H2].
     { destruct H1; destruct* H2. }
     { destruct* H1. }
     { destruct* H2. }
     { autos*. } }
  { destruct* M.
    { applys* rtclosure_of_rclosure. }
    { applys* rtclosure_of_tclosure. } }
Qed.

Lemma rtclosure_inv_rclosure_or_tclosure : forall R x y,
  rtclosure R x y ->
  x = y \/ tclosure R x y.
Proof using.
  introv M. rewrite rtclosure_eq_union_rclosure_tclosure in M.
  destruct M as [M|M]. { destruct* M. } { auto. }
Qed.

Lemma stclosure_eq_rstclosure_of_refl : forall R,
  refl R ->
  stclosure R = rstclosure R.
Proof using.
  introv H. extens. intros x y. iff M.
  { applys* rstclosure_of_stclosure. }
  { induction* M. }
Qed.

(* --LATER: many lemmas like the above? *)

(* --TODO: rename this lemma *)
Lemma rel_incl_tclosure_stclosure_l : forall R1 R2,
  rel_incl R1 (stclosure R2) ->
  rel_incl (tclosure R1) (stclosure R2).
Proof using. introv H M. induction* M. Qed.

(* --LATER: many lemmas like the above? *)

End EquivClosures.

(* ---------------------------------------------------------------------- *)
(** ** Mixed transitivity between closures *)

Section MixedClosures.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors tclosure.

Lemma tclosure_of_rtclosure_l : forall R x y z,
  rtclosure R x y ->
  R y z ->
  tclosure R x z.
Proof using.
  introv H M. destruct (rtclosure_inv_rclosure_or_tclosure H).
  { subst*. }
  { applys* tclosure_r. }
Qed.

Lemma tclosure_of_rtclosure_r : forall R x y z,
  R x y ->
  rtclosure R y z ->
  tclosure R x z.
Proof using.
  introv M H. destruct (rtclosure_inv_rclosure_or_tclosure H).
  { subst*. }
  { applys* tclosure_l. }
Qed.

Lemma tclosure_of_rtclosure_tclosure : forall R y x z,
  rtclosure R x y ->
  tclosure R y z ->
  tclosure R x z.
Proof using.
  introv H M. destruct (rtclosure_inv_rclosure_or_tclosure H); subst*.
Qed.

Lemma tclosure_of_tclosure_rtclosure : forall R y x z,
  tclosure R x y ->
  rtclosure R y z ->
  tclosure R x z.
Proof using.
  introv M H. destruct (rtclosure_inv_rclosure_or_tclosure H); subst*.
Qed.

End MixedClosures.

(* --LATER: similar lemmas relating [rstclosure] and [stclosure] *)

(* ---------------------------------------------------------------------- *)
(** ** Irreflexive restriction of a relation *)

Definition strict A (R:binary A) : binary A :=
  fun x y => R x y /\ x <> y.

Section Strict.
Variables (A : Type).
Implicit Types R : binary A.
Hint Unfold strict.

Lemma strict_eq_fun : forall R,
  strict R = (fun x y => R x y /\ x <> y).
Proof using. auto. Qed.

Lemma strict_eq : forall R x y,
  strict R x y = (R x y /\ x <> y).
Proof using. auto. Qed.

Lemma inverse_strict : forall R,
  inverse (strict R) = strict (inverse R).
Proof using. intros. unfold inverse, strict. extens*. Qed.

Lemma trans_strict_l : forall y x z R,
  trans R ->
  strict R x y ->
  R y z ->
  R x z.
Proof using. introv T (E&H) H'; subst*. Qed.

Lemma trans_strict_r : forall y x z R,
  trans R ->
  R x y ->
  strict R y z ->
  R x z.
Proof using. introv T H (E&H'); subst*. Qed.

Lemma irrefl_strict : forall R,
  irrefl (strict R).
Proof using. unfold strict, irrefl. intros. rew_logic*. Qed.

Lemma antisym_strict : forall R,
  antisym R ->
  antisym (strict R).
Proof using. unfolds* antisym, strict. Qed.

Lemma trans_strict : forall R,
  trans R ->
  antisym R ->
  trans (strict R).
Proof using.
  introv T S. unfold strict. introv [H1 H2] [H3 H4]. split.
  { apply* T. }
  { intros K. subst. apply H2. apply~ S. }
Qed.

Lemma strict_rclosure : forall R,
  irrefl R ->
  strict (rclosure R) = R.
Proof using.
  unfold strict. extens. intros x y. iff (K1&K2) K.
  { destruct* K1. }
  { split. { left*. } { apply* irrefl_inv_neq. } }
Qed.

Lemma rclosure_strict : forall R,
  refl R ->
  rclosure (strict R) = R.
Proof using.
  Hint Constructors rclosure.
  unfold strict. extens. intros x y. iff K.
  { destruct K; subst*. }
  { tests: (x = y); subst*. }
Qed.

End Strict.

(* ********************************************************************** *)
(** Function to relation *)

(* ---------------------------------------------------------------------- *)
(** ** Inclusion of a function in a relation *)

(** [fun_in_rel f R] asserts that input-output pairs of [f] are
    included in the relation [R]. *)

Definition fun_in_rel A B (f:A->B) (R:A->B->Prop) :=
  forall x, R x (f x).

Section Fun_in_rel.
Variables (A B : Type).
Implicit Type f : A->B.
Implicit Type R : A->B->Prop.

Lemma defined_of_fun_in_rel : forall f R,
  fun_in_rel f R ->
  defined R.
Proof using. unfolds* fun_in_rel, defined. Qed.

(** The relation built from a function [f] is included in a relation
    [R] iff the function [f] is included in [R] *)

Lemma rel_incl_rel_fun_eq_fun_in_rel : forall f R,
  rel_incl (rel_fun f) R = fun_in_rel f R.
Proof using.
  extens. unfold rel_fun, fun_in_rel. iff H; intros x; specializes H x.
  { applys* H. }
  { intros y Hy. subst~. }
Qed.

End Fun_in_rel.

(* ---------------------------------------------------------------------- *)
(** ** Inclusion of a relation in a function *)

(** [rel_in_fun R f] asserts that input-output pairs of [R]
    are input-output for [f]. *)

Definition rel_in_fun A B (R:A->B->Prop) (f:A->B) :=
  forall x y, R x y -> f x = y.

Section Rel_in_fun.
Variables (A B : Type).
Implicit Type f : A->B.
Implicit Type R : A->B->Prop.

Lemma functional_of_rel_in_fun : forall R f,
  rel_in_fun R f ->
  functional R.
Proof using.
  unfold rel_in_fun, functional. introv M N1 N2.
  lets: M N1. lets: M N2. congruence.
Qed.

(* If the relation [R] is functional and if [f] is included in [R],
   then [R] is included in [f], i.e., they coincide. *)

Lemma rel_in_fun_of_fun_in_rel_functional : forall f R,
  fun_in_rel f R ->
  functional R ->
  rel_in_fun R f.
Proof using.
  introv h1 h2. intros a b H. forwards M: h1 a. forwards*: h2 H M.
Qed.

End Rel_in_fun.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (z : natural) (x : natural) : natural :=
  plus lf2 (mult z (Succ x)).


Theorem t1 : forall (P Q : Prop), (P /\ Q) -> (Q /\ P).
intro.
intro.
intro.
destruct H.
split.
apply H0.
apply H.
Qed.

Theorem t2 : forall (P Q : Prop), (P /\ Q) <-> (Q /\ P).
intro.
intro.
split.
apply t1.
apply t1.
Qed.

Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> (P \/ R) -> (Q \/ R).
intro.
intro.
intro.
intro.
intro.
destruct H0.
left.
apply H.
apply H0.
right.
apply H0.
Qed.

Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
intro.
split.
unfold not.
intro.
split.
apply H.
intro.
destruct H0.
unfold not.
intro.
destruct H.
intro.
apply H.
apply H1.
Qed.


Require Import Algebra.AbelianGroup.
Require Import Algebra.CommRing.

Section Modules.
Context {R: Set}(plusR: R -> R -> R)(zeroR: R)(minusR: R -> R).
Context (multR: R -> R -> R)(oneR: R).
Context `{Rcring: CommRing R plusR zeroR minusR multR oneR}.
Context {A: Set}(plusA: A -> A -> A)(zeroA: A)(minusA: A -> A).
Context `{Aagroup: AbelianGroup A plusA zeroA minusA}.
Context (action: R -> A -> A).

Class Module_ := {
  module_distrib_plusA: forall (r: R)(a b: A), action r (plusA a b) = plusA (action r a) (action r b);
  module_distrib_plusR: forall (r s: R)(a: A), action (plusR r s) a = plusA (action r a) (action s a);
  module_distrib_multR: forall (r s: R)(a: A), action (multR r s) a = action r (action s a);
  module_oneR: forall (a: A), action oneR a = a;
}.

Context `{ARmodule: Module_}.

Theorem module_zeroR (a: A):
  action zeroR a = zeroA.
Proof.
  cut (plusA (action zeroR a) (action zeroR a) = action zeroR a).
  { intros H.
    apply (agroup_idemp_zero plusA zeroA minusA).
    assumption. }
  { rewrite <- module_distrib_plusR.
    rewrite (cring_plus_ident plusR zeroR minusR multR oneR).
    reflexivity. }
Qed.

Theorem module_zeroA (r: R):
  action r zeroA = zeroA.
Proof.
  cut (plusA (action r zeroA) (action r zeroA) = action r zeroA).
  { intros H.
    apply (agroup_idemp_zero plusA zeroA minusA).
    assumption. }
  { rewrite <- module_distrib_plusA.
    rewrite (agroup_ident plusA zeroA minusA).
    reflexivity. }
Qed.
End Modules.


Theorem imp_trans: forall P Q R: Prop,
(P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros.
  apply H0.
  apply H.
  assumption.
Qed.

Print imp_trans.

Theorem imp_perm: forall P Q R: Prop,
(P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros.
  apply H.
  assumption.
  assumption.
Qed.

Print imp_perm.

Theorem ignore_Q: forall P Q R: Prop,
(P -> R) -> P -> Q -> R.
Proof.
  intros.
  apply H.
  assumption.
Qed.

Print ignore_Q.

Theorem delta_imp: forall P Q: Prop,
(P -> P -> Q) -> P -> Q.
Proof.
  intros.
  apply H.
  assumption.
  assumption.
Qed.

Print delta_imp.

Theorem delta_impR: forall P Q: Prop,
(P -> Q) -> (P -> P -> Q).
Proof.
  intros.
  apply H.
  assumption.
Qed.

Print delta_impR.

Theorem diamond: forall P Q R S: Prop,
(P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
Proof.
  intros.
  apply H1.
  apply H.
  assumption.
  apply H0.
  assumption.
Qed.

Print diamond.


Require Import XR_Rmax.
Require Import XR_Rmin.
Require Import XR_Rle_dec.
Require Import XR_Rle_antisym.
Require Import XR_Ropp_le_contravar.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y).
Proof.
  intros x y.
  unfold Rmin, Rmax.
  destruct (Rle_dec x y) as [ hmin | hmin ] ;
  destruct (Rle_dec (-x) (-y) ) as [ hmax | hmax ].
  {
    apply Rle_antisym.
    { exact hmax. }
    {
      apply Ropp_le_contravar.
      exact hmin.
    }
  }
  { reflexivity. }
  { reflexivity. }
  {
    apply Rle_antisym.
    {
      left.
      apply Rnot_le_lt.
      exact hmax.
    }
    {
      left.
      apply Ropp_lt_contravar.
      apply Rnot_le_lt.
      exact hmin.
    }
  }
Qed.