Inductive bool : Type :=
    | true : bool
    | false : bool.

Definition negb (b:bool) : bool :=
    match b with
    | true => false
    | false => true
    end.

Definition andb (b1:bool) (b2:bool) : bool :=
    match b1 with
    | true => b2
    | false => false
    end.

Definition orb (b1:bool) (b2:bool) : bool :=
    match b1 with
    | true => true
    | false => b2
    end.

Example test_orb1: (orb true false) = true.
Proof. reflexivity. Qed.

Example test_orb2: (orb false false) = false.
Proof. reflexivity. Qed.

Example test_orb3: (orb false true) = true.
Proof. reflexivity. Qed.

Example test_orb4: (orb true true) = true.
Proof. reflexivity. Qed.

Definition nandb (b1:bool) (b2:bool) : bool :=
    match b1 with
    | false => true
    | true => negb b2
    end.

Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
    match b1 with
    | true => andb b2 b3
    | false => false
    end.

Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.

Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.

Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.

Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.


(*|
######################
Coq inference behavior
######################

:Link: https://stackoverflow.com/q/36996020
|*)

(*|
Question
********

I'm trying to write the following Agda snippet in Coq.

.. code-block:: agda

    open import Data.Fin using (Fin; suc; zero)
    open import Data.Nat using (ℕ; suc; zero)

    thin : {n : ℕ} -> Fin (suc n) -> Fin n -> Fin (suc n)
    thin zero    y       = suc y
    thin (suc x) zero    = zero
    thin (suc x) (suc y) = suc (thin x y)

I thought this could be straightforwardly translated to Coq as:
|*)

Inductive Fin : nat -> Type :=
| fz {n : nat} : Fin (S n)
| fs {n : nat} : Fin n -> Fin (S n).

Fail Fixpoint thin {n : nat} (x : Fin (S n)) (y : Fin n) : Fin (S n) :=
  match x, y with
  | fz,    y' => fs y'
  | fs x', fz => fz
  | fs x', fs y' => fs (thin x' y')
  end. (* .fails *)

(*|
I believe Coq should be able to figure out the implicit parameter
``n`` so I have no idea what is going on. I think I am unaware of a
difference between the type systems of Agda and Coq since the former
typechecks fine.
|*)

(*|
Answer
******

When pattern matching with dependent types, Coq does not usually
consider some essential relations between the variables in the context
and the variables introduced in the branches.

The easiest solution is to define the function in proof mode, at least
to understand what is going on.

This gives:
|*)

Fixpoint thin {n : nat} (x : Fin (S n)) (y : Fin n) : Fin (S n).
Proof.
  remember (S n) as n1. (* trick to keep the information when destructing *)
  destruct x; apply eq_add_S in Heqn1; subst n0.
  - apply fs. assumption.
  - destruct y.
    + apply fz.
    + apply fs. apply thin; assumption.
Defined. (* to create a transparent constant, as given by a classic Fixpoint *)

(*|
You can then print the value and read the lambda term to understand
how to define it directly. This could give:
|*)

Print thin. (* .unfold .messages *)

(*|
The ``return`` clauses of the pattern matchings is used to solve the
problem presented above: they connect the variables introduced in the
branches and the ones in the context. This is discussed more deeply
here: http://adam.chlipala.net/cpdt/html/MoreDep.html.

Also note that this particular inductive type was discussed a few
weeks ago on the coq-club mailing list. See
https://sympa.inria.fr/sympa/arc/coq-club/2016-03/msg00206.html.

----

**Q:** This helps a lot, thanks! I should have finished Chlipala's
book before actually trying to do stuff in Coq. One more question I
have: is it considered bad practice to define functions in proof mode?

**A:** I don't really know. Usually, I do that to check the lambda
term and write it myself. Anyway, I try to use mostly low-level
tactics to create a readable lambda term. Tactics like ``inversion``
create

**A:** Tactics like ``inversion`` create non-natural terms and should
be avoided. Maybe other users have stronger opinions on this
particular subject.
|*)


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rle.
Require Export XR_Rtotal_order.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1.
Proof.
intros x y.
destruct (Rtotal_order x y) as [ hxy | [ heq | hyx ] ].
{ left. unfold "<=". left. exact hxy. }
{ subst y. left. unfold "<=". right. reflexivity. }
{ right. exact hyx. }
Qed.


(** * Hoare2: Hoare Logic, Part II *)

Require Export Hoare.

(* ####################################################### *)
(** * Decorated Programs *)

(** The beauty of Hoare Logic is that it is _compositional_ --
    the structure of proofs exactly follows the structure of programs.
    This suggests that we can record the essential ideas of a proof
    informally (leaving out some low-level calculational details) by
    decorating programs with appropriate assertions around each
    statement.  Such a _decorated program_ carries with it
    an (informal) proof of its own correctness. *)

(** For example, here is a complete decorated program: *)
(**
      {{ True }} ->>
      {{ m = m }}
    X ::= m;
      {{ X = m }} ->>
      {{ X = m /\ p = p }}
    Z ::= p;
      {{ X = m /\ Z = p }} ->>
      {{ Z - X = p - m }}
    WHILE X <> 0 DO
        {{ Z - X = p - m /\ X <> 0 }} ->>
        {{ (Z - 1) - (X - 1) = p - m }}
      Z ::= Z - 1;
        {{ Z - (X - 1) = p - m }}
      X ::= X - 1
        {{ Z - X = p - m }}
    END;
      {{ Z - X = p - m /\ ~ (X <> 0) }} ->>
      {{ Z = p - m }} ->>
*)

(** Concretely, a decorated program consists of the program text
    interleaved with assertions.  To check that a decorated program
    represents a valid proof, we check that each individual command is
    _locally consistent_ with its accompanying assertions in the
    following sense: *)

(**
    - [SKIP] is locally consistent if its precondition and
      postcondition are the same:
          {{ P }}
          SKIP
          {{ P }}
    - The sequential composition of [c1] and [c2] is locally
      consistent (with respect to assertions [P] and [R]) if [c1] is
      locally consistent (with respect to [P] and [Q]) and [c2] is
      locally consistent (with respect to [Q] and [R]):
          {{ P }}
          c1;
          {{ Q }}
          c2
          {{ R }}

    - An assignment is locally consistent if its precondition is
      the appropriate substitution of its postcondition:
          {{ P [X |-> a] }}
          X ::= a
          {{ P }}
    - A conditional is locally consistent (with respect to assertions
      [P] and [Q]) if the assertions at the top of its "then" and
      "else" branches are exactly [P /\ b] and [P /\ ~b] and if its "then"
      branch is locally consistent (with respect to [P /\ b] and [Q])
      and its "else" branch is locally consistent (with respect to
      [P /\ ~b] and [Q]):
          {{ P }}
          IFB b THEN
            {{ P /\ b }}
            c1
            {{ Q }}
          ELSE
            {{ P /\ ~b }}
            c2
            {{ Q }}
          FI
          {{ Q }}

    - A while loop with precondition [P] is locally consistent if its
      postcondition is [P /\ ~b] and if the pre- and postconditions of
      its body are exactly [P /\ b] and [P]:
          {{ P }}
          WHILE b DO
            {{ P /\ b }}
            c1
            {{ P }}
          END
          {{ P /\ ~b }}

    - A pair of assertions separated by [->>] is locally consistent if
      the first implies the second (in all states):
          {{ P }} ->>
          {{ P' }}

      This corresponds to the application of [hoare_consequence] and
      is the only place in a decorated program where checking if
      decorations are correct is not fully mechanical and syntactic,
      but involves logical and/or arithmetic reasoning.
*)

(** We have seen above how _verifying_ the correctness of a
    given proof involves checking that every single command is locally
    consistent with the accompanying assertions.  If we are instead
    interested in _finding_ a proof for a given specification we need
    to discover the right assertions. This can be done in an almost
    automatic way, with the exception of finding loop invariants,
    which is the subject of in the next section.  In the reminder of
    this section we explain in detail how to construct decorations for
    several simple programs that don't involve non-trivial loop
    invariants. *)

(* ####################################################### *)
(** ** Example: Swapping Using Addition and Subtraction *)

(** Here is a program that swaps the values of two variables using
    addition and subtraction (instead of by assigning to a temporary
    variable).
  X ::= X + Y;
  Y ::= X - Y;
  X ::= X - Y
    We can prove using decorations that this program is correct --
    i.e., it always swaps the values of variables [X] and [Y]. *)

(**
 (1)     {{ X = m /\ Y = n }} ->>
 (2)     {{ (X + Y) - ((X + Y) - Y) = n /\ (X + Y) - Y = m }}
        X ::= X + Y;
 (3)     {{ X - (X - Y) = n /\ X - Y = m }}
        Y ::= X - Y;
 (4)     {{ X - Y = n /\ Y = m }}
        X ::= X - Y
 (5)     {{ X = n /\ Y = m }}
    The decorations were constructed as follows:
      - We begin with the undecorated program (the unnumbered lines).
      - We then add the specification -- i.e., the outer
        precondition (1) and postcondition (5). In the precondition we
        use auxiliary variables (parameters) [m] and [n] to remember
        the initial values of variables [X] and respectively [Y], so
        that we can refer to them in the postcondition (5).
      - We work backwards mechanically starting from (5) all the way
        to (2). At each step, we obtain the precondition of the
        assignment from its postcondition by substituting the assigned
        variable with the right-hand-side of the assignment. For
        instance, we obtain (4) by substituting [X] with [X - Y]
        in (5), and (3) by substituting [Y] with [X - Y] in (4).
      - Finally, we verify that (1) logically implies (2) -- i.e.,
        that the step from (1) to (2) is a valid use of the law of
        consequence. For this we substitute [X] by [m] and [Y] by [n]
        and calculate as follows:
            (m + n) - ((m + n) - n) = n /\ (m + n) - n = m
            (m + n) - m = n /\ m = m
            n = n /\ m = m

    (Note that, since we are working with natural numbers, not
    fixed-size machine integers, we don't need to worry about the
    possibility of arithmetic overflow anywhere in this argument.)
*)

(* ####################################################### *)
(** ** Example: Simple Conditionals *)

(** Here is a simple decorated program using conditionals:
 (1)     {{True}}
       IFB X <= Y THEN
 (2)       {{True /\ X <= Y}} ->>
 (3)       {{(Y - X) + X = Y \/ (Y - X) + Y = X}}
         Z ::= Y - X
 (4)       {{Z + X = Y \/ Z + Y = X}}
       ELSE
 (5)       {{True /\ ~(X <= Y) }} ->>
 (6)       {{(X - Y) + X = Y \/ (X - Y) + Y = X}}
         Z ::= X - Y
 (7)       {{Z + X = Y \/ Z + Y = X}}
       FI
 (8)     {{Z + X = Y \/ Z + Y = X}}

These decorations were constructed as follows:
  - We start with the outer precondition (1) and postcondition (8).
  - We follow the format dictated by the [hoare_if] rule and copy the
    postcondition (8) to (4) and (7). We conjoin the precondition (1)
    with the guard of the conditional to obtain (2). We conjoin (1)
    with the negated guard of the conditional to obtain (5).
  - In order to use the assignment rule and obtain (3), we substitute
    [Z] by [Y - X] in (4). To obtain (6) we substitute [Z] by [X - Y]
    in (7).
  - Finally, we verify that (2) implies (3) and (5) implies (6). Both
    of these implications crucially depend on the ordering of [X] and
    [Y] obtained from the guard. For instance, knowing that [X <= Y]
    ensures that subtracting [X] from [Y] and then adding back [X]
    produces [Y], as required by the first disjunct of (3). Similarly,
    knowing that [~(X <= Y)] ensures that subtracting [Y] from [X] and
    then adding back [Y] produces [X], as needed by the second
    disjunct of (6). Note that [n - m + m = n] does _not_ hold for
    arbitrary natural numbers [n] and [m] (for example, [3 - 5 + 5 =
    5]). *)

(** **** Exercise: 2 stars (if_minus_plus_reloaded) *)
(** Fill in valid decorations for the following program:
   {{ True }}
  IFB X <= Y THEN
      {{                         }} ->>
      {{                         }}
    Z ::= Y - X
      {{                         }}
  ELSE
      {{                         }} ->>
      {{                         }}
    Y ::= X + Z
      {{                         }}
  FI
    {{ Y = X + Z }}
*)

(* ####################################################### *)
(** ** Example: Reduce to Zero (Trivial Loop) *)

(** Here is a [WHILE] loop that is so simple it needs no
    invariant (i.e., the invariant [True] will do the job).
 (1)      {{ True }}
        WHILE X <> 0 DO
 (2)        {{ True /\ X <> 0 }} ->>
 (3)        {{ True }}
          X ::= X - 1
 (4)        {{ True }}
        END
 (5)      {{ True /\ X = 0 }} ->>
 (6)      {{ X = 0 }}
The decorations can be constructed as follows:
  - Start with the outer precondition (1) and postcondition (6).
  - Following the format dictated by the [hoare_while] rule, we copy
    (1) to (4). We conjoin (1) with the guard to obtain (2) and with
    the negation of the guard to obtain (5). Note that, because the
    outer postcondition (6) does not syntactically match (5), we need a
    trivial use of the consequence rule from (5) to (6).
  - Assertion (3) is the same as (4), because [X] does not appear in
    [4], so the substitution in the assignment rule is trivial.
  - Finally, the implication between (2) and (3) is also trivial.
*)

(** From this informal proof, it is easy to read off a formal proof
    using the Coq versions of the Hoare rules.  Note that we do _not_
    unfold the definition of [hoare_triple] anywhere in this proof --
    the idea is to use the Hoare rules as a "self-contained" logic for
    reasoning about programs. *)

Definition reduce_to_zero' : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    X ::= AMinus (AId X) (ANum 1)
  END.

Theorem reduce_to_zero_correct' :
  {{fun st => True}}
  reduce_to_zero'
  {{fun st => st X = 0}}.
Proof.
  unfold reduce_to_zero'.
  (* First we need to transform the postcondition so
     that hoare_while will apply. *)
  eapply hoare_consequence_post.
  apply hoare_while.
  Case "Loop body preserves invariant".
    (* Need to massage precondition before [hoare_asgn] applies *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    (* Proving trivial implication (2) ->> (3) *)
    intros st [HT Hbp]. unfold assn_sub. apply I.
  Case "Invariant and negated guard imply postcondition".
    intros st [Inv GuardFalse].
    unfold bassn in GuardFalse. simpl in GuardFalse.
    (* SearchAbout helps to find the right lemmas *)
    SearchAbout [not true].
    rewrite not_true_iff_false in GuardFalse.
    SearchAbout [negb false].
    rewrite negb_false_iff in GuardFalse.
    SearchAbout [beq_nat true].
    apply beq_nat_true in GuardFalse.
    apply GuardFalse. Qed.

(* ####################################################### *)
(** ** Example: Division *)

(** The following Imp program calculates the integer division and
    remainder of two numbers [m] and [n] that are arbitrary constants
    in the program.
  X ::= m;
  Y ::= 0;
  WHILE n <= X DO
    X ::= X - n;
    Y ::= Y + 1
  END;
    In other words, if we replace [m] and [n] by concrete numbers and
    execute the program, it will terminate with the variable [X] set
    to the remainder when [m] is divided by [n] and [Y] set to the
    quotient. *)

(** In order to give a specification to this program we need to
    remember that dividing [m] by [n] produces a reminder [X] and a
    quotient [Y] so that [n * Y + X = m /\ X > n].

    It turns out that we get lucky with this program and don't have to
    think very hard about the loop invariant: the invariant is the
    just first conjunct [n * Y + X = m], so we use that to decorate
    the program.

 (1)    {{ True }} ->>
 (2)    {{ n * 0 + m = m }}
      X ::= m;
 (3)    {{ n * 0 + X = m }}
      Y ::= 0;
 (4)    {{ n * Y + X = m }}
      WHILE n <= X DO
 (5)      {{ n * Y + X = m /\ n <= X }} ->>
 (6)      {{ n * (Y + 1) + (X - n) = m }}
        X ::= X - n;
 (7)      {{ n * (Y + 1) + X = m }}
        Y ::= Y + 1
 (8)      {{ n * Y + X = m }}
      END
 (9)    {{ n * Y + X = m /\ X < n }}

    Assertions (4), (5), (8), and (9) are derived mechanically from
    the invariant and the loop's guard. Assertions (8), (7), and (6)
    are derived using the assignment rule going backwards from (8) to
    (6). Assertions (4), (3), and (2) are again backwards applications
    of the assignment rule.

    Now that we've decorated the program it only remains to check that
    the two uses of the consequence rule are correct -- i.e., that (1)
    implies (2) and that (5) implies (6).  This is indeed the case, so
    we have a valid decorated program.
*)

(* ####################################################### *)
(** * Finding Loop Invariants *)

(** Once the outermost precondition and postcondition are chosen, the
    only creative part in verifying programs with Hoare Logic is
    finding the right loop invariants.  The reason this is difficult
    is the same as the reason that doing inductive mathematical proofs
    requires creativity: strengthening the loop invariant (or the
    induction hypothesis) means that you have a stronger assumption to
    work with when trying to establish the postcondition of the loop
    body (complete the induction step of the proof), but it also means
    that the loop body postcondition itself is harder to prove!

    This section is dedicated to teaching you how to approach the
    challenge of finding loop invariants using a series of examples
    and exercises. *)

(** ** Example: Slow Subtraction *)

(** The following program subtracts the value of [X] from the value of
    [Y] by repeatedly decrementing both [X] and [Y]. We want to verify its
    correctness with respect to the following specification:
             {{ X = m /\ Y = n }}
           WHILE X <> 0 DO
             Y ::= Y - 1;
             X ::= X - 1
           END
             {{ Y = n - m }}

    To verify this program we need to find an invariant [I] for the
    loop. As a first step we can leave [I] as an unknown and build a
    _skeleton_ for the proof by applying backward the rules for local
    consistency. This process leads to the following skeleton:
    (1)      {{ X = m /\ Y = n }}  ->>     (a)
    (2)      {{ I }}
           WHILE X <> 0 DO
    (3)        {{ I /\ X <> 0 }}  ->>      (c)
    (4)        {{ I[X |-> X-1][Y |-> Y-1] }}
             Y ::= Y - 1;
    (5)        {{ I[X |-> X-1] }}
             X ::= X - 1
    (6)        {{ I }}
           END
    (7)      {{ I /\ ~(X <> 0) }}  ->>         (b)
    (8)      {{ Y = n - m }}

    By examining this skeleton, we can see that any valid [I] will
    have to respect three conditions:
    - (a) it must be weak enough to be implied by the loop's
      precondition, i.e. (1) must imply (2);
    - (b) it must be strong enough to imply the loop's postcondition,
      i.e. (7) must imply (8);
    - (c) it must be preserved by one iteration of the loop, i.e. (3)
      must imply (4). *)

(** These conditions are actually independent of the particular
    program and specification we are considering. Indeed, every loop
    invariant has to satisfy them. One way to find an invariant that
    simultaneously satisfies these three conditions is by using an
    iterative process: start with a "candidate" invariant (e.g. a
    guess or a heuristic choice) and check the three conditions above;
    if any of the checks fails, try to use the information that we get
    from the failure to produce another (hopefully better) candidate
    invariant, and repeat the process.

    For instance, in the reduce-to-zero example above, we saw that,
    for a very simple loop, choosing [True] as an invariant did the
    job. So let's try it again here!  I.e., let's instantiate [I] with
    [True] in the skeleton above see what we get...
    (1)      {{ X = m /\ Y = n }} ->>       (a - OK)
    (2)      {{ True }}
           WHILE X <> 0 DO
    (3)        {{ True /\ X <> 0 }}  ->>    (c - OK)
    (4)        {{ True }}
             Y ::= Y - 1;
    (5)        {{ True }}
             X ::= X - 1
    (6)        {{ True }}
           END
    (7)      {{ True /\ X = 0 }}  ->>       (b - WRONG!)
    (8)      {{ Y = n - m }}

    While conditions (a) and (c) are trivially satisfied,
    condition (b) is wrong, i.e. it is not the case that (7) [True /\
    X = 0] implies (8) [Y = n - m].  In fact, the two assertions are
    completely unrelated and it is easy to find a counterexample (say,
    [Y = X = m = 0] and [n = 1]).

    If we want (b) to hold, we need to strengthen the invariant so
    that it implies the postcondition (8).  One very simple way to do
    this is to let the invariant _be_ the postcondition.  So let's
    return to our skeleton, instantiate [I] with [Y = n - m], and
    check conditions (a) to (c) again.
    (1)      {{ X = m /\ Y = n }}  ->>          (a - WRONG!)
    (2)      {{ Y = n - m }}
           WHILE X <> 0 DO
    (3)        {{ Y = n - m /\ X <> 0 }}  ->>   (c - WRONG!)
    (4)        {{ Y - 1 = n - m }}
             Y ::= Y - 1;
    (5)        {{ Y = n - m }}
             X ::= X - 1
    (6)        {{ Y = n - m }}
           END
    (7)      {{ Y = n - m /\ X = 0 }}  ->>      (b - OK)
    (8)      {{ Y = n - m }}

    This time, condition (b) holds trivially, but (a) and (c) are
    broken. Condition (a) requires that (1) [X = m /\ Y = n]
    implies (2) [Y = n - m].  If we substitute [X] by [m] we have to
    show that [m = n - m] for arbitrary [m] and [n], which does not
    hold (for instance, when [m = n = 1]).  Condition (c) requires that
    [n - m - 1 = n - m], which fails, for instance, for [n = 1] and [m =
    0]. So, although [Y = n - m] holds at the end of the loop, it does
    not hold from the start, and it doesn't hold on each iteration;
    it is not a correct invariant.

    This failure is not very surprising: the variable [Y] changes
    during the loop, while [m] and [n] are constant, so the assertion
    we chose didn't have much chance of being an invariant!

    To do better, we need to generalize (8) to some statement that is
    equivalent to (8) when [X] is [0], since this will be the case
    when the loop terminates, and that "fills the gap" in some
    appropriate way when [X] is nonzero.  Looking at how the loop
    works, we can observe that [X] and [Y] are decremented together
    until [X] reaches [0].  So, if [X = 2] and [Y = 5] initially,
    after one iteration of the loop we obtain [X = 1] and [Y = 4];
    after two iterations [X = 0] and [Y = 3]; and then the loop stops.
    Notice that the difference between [Y] and [X] stays constant
    between iterations; initially, [Y = n] and [X = m], so this
    difference is always [n - m].  So let's try instantiating [I] in
    the skeleton above with [Y - X = n - m].
    (1)      {{ X = m /\ Y = n }}  ->>               (a - OK)
    (2)      {{ Y - X = n - m }}
           WHILE X <> 0 DO
    (3)        {{ Y - X = n - m /\ X <> 0 }}  ->>    (c - OK)
    (4)        {{ (Y - 1) - (X - 1) = n - m }}
             Y ::= Y - 1;
    (5)        {{ Y - (X - 1) = n - m }}
             X ::= X - 1
    (6)        {{ Y - X = n - m }}
           END
    (7)      {{ Y - X = n - m /\ X = 0 }}  ->>       (b - OK)
    (8)      {{ Y = n - m }}

    Success!  Conditions (a), (b) and (c) all hold now.  (To
    verify (c), we need to check that, under the assumption that [X <>
    0], we have [Y - X = (Y - 1) - (X - 1)]; this holds for all
    natural numbers [X] and [Y].) *)

(* ####################################################### *)
(** ** Exercise: Slow Assignment *)

(** **** Exercise: 2 stars (slow_assignment) *)
(** A roundabout way of assigning a number currently stored in [X] to
    the variable [Y] is to start [Y] at [0], then decrement [X] until
    it hits [0], incrementing [Y] at each step. Here is a program that
    implements this idea:
      {{ X = m }}
    Y ::= 0;
    WHILE X <> 0 DO
      X ::= X - 1;
      Y ::= Y + 1;
    END
      {{ Y = m }}
    Write an informal decorated program showing that this is correct. *)

(* FILL IN HERE *)
(** [] *)

(* ####################################################### *)
(** ** Exercise: Slow Addition *)

(** **** Exercise: 3 stars, optional (add_slowly_decoration) *)
(** The following program adds the variable X into the variable Z
    by repeatedly decrementing X and incrementing Z.
  WHILE X <> 0 DO
     Z ::= Z + 1;
     X ::= X - 1
  END

    Following the pattern of the [subtract_slowly] example above, pick
    a precondition and postcondition that give an appropriate
    specification of [add_slowly]; then (informally) decorate the
    program accordingly. *)

(* FILL IN HERE *)
(** [] *)

(* ####################################################### *)
(** ** Example: Parity *)

(** Here is a cute little program for computing the parity of the
    value initially stored in [X] (due to Daniel Cristofani).
    {{ X = m }}
  WHILE 2 <= X DO
    X ::= X - 2
  END
    {{ X = parity m }}
    The mathematical [parity] function used in the specification is
    defined in Coq as follows: *)

Fixpoint parity x :=
  match x with
  | 0 => 0
  | 1 => 1
  | S (S x') => parity x'
  end.

(** The postcondition does not hold at the beginning of the loop,
    since [m = parity m] does not hold for an arbitrary [m], so we
    cannot use that as an invariant.  To find an invariant that works,
    let's think a bit about what this loop does.  On each iteration it
    decrements [X] by [2], which preserves the parity of [X].  So the
    parity of [X] does not change, i.e. it is invariant.  The initial
    value of [X] is [m], so the parity of [X] is always equal to the
    parity of [m]. Using [parity X = parity m] as an invariant we
    obtain the following decorated program:
    {{ X = m }} ->>                              (a - OK)
    {{ parity X = parity m }}
  WHILE 2 <= X DO
      {{ parity X = parity m /\ 2 <= X }}  ->>    (c - OK)
      {{ parity (X-2) = parity m }}
    X ::= X - 2
      {{ parity X = parity m }}
  END
    {{ parity X = parity m /\ X < 2 }}  ->>       (b - OK)
    {{ X = parity m }}

    With this invariant, conditions (a), (b), and (c) are all
    satisfied. For verifying (b), we observe that, when [X < 2], we
    have [parity X = X] (we can easily see this in the definition of
    [parity]).  For verifying (c), we observe that, when [2 <= X], we
    have [parity X = parity (X-2)]. *)

(** **** Exercise: 3 stars, optional (parity_formal) *)
(** Translate this proof to Coq. Refer to the reduce-to-zero example
    for ideas. You may find the following two lemmas useful: *)

Lemma parity_ge_2 : forall x,
  2 <= x ->
  parity (x - 2) = parity x.
Proof.
  induction x; intro. reflexivity.
  destruct x. inversion H. inversion H1.
  simpl. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma parity_lt_2 : forall x,
  ~ 2 <= x ->
  parity (x) = x.
Proof.
  intros. induction x. reflexivity. destruct x. reflexivity.
    apply ex_falso_quodlibet. apply H. omega.
Qed.

Theorem parity_correct : forall m,
    {{ fun st => st X = m }}
  WHILE BLe (ANum 2) (AId X) DO
    X ::= AMinus (AId X) (ANum 2)
  END
    {{ fun st => st X = parity m }}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ####################################################### *)
(** ** Example: Finding Square Roots *)

(** The following program computes the square root of [X]
    by naive iteration:
      {{ X=m }}
    Z ::= 0;
    WHILE (Z+1)*(Z+1) <= X DO
      Z ::= Z+1
    END
      {{ Z*Z<=m /\ m<(Z+1)*(Z+1) }}
*)

(** As above, we can try to use the postcondition as a candidate
    invariant, obtaining the following decorated program:
 (1)  {{ X=m }}  ->>           (a - second conjunct of (2) WRONG!)
 (2)  {{ 0*0 <= m /\ m<1*1 }}
    Z ::= 0;
 (3)  {{ Z*Z <= m /\ m<(Z+1)*(Z+1) }}
    WHILE (Z+1)*(Z+1) <= X DO
 (4)    {{ Z*Z<=m /\ (Z+1)*(Z+1)<=X }}  ->>           (c - WRONG!)
 (5)    {{ (Z+1)*(Z+1)<=m /\ m<(Z+2)*(Z+2) }}
      Z ::= Z+1
 (6)    {{ Z*Z<=m /\ m<(Z+1)*(Z+1) }}
    END
 (7)  {{ Z*Z<=m /\ m<(Z+1)*(Z+1) /\ X<(Z+1)*(Z+1) }}  ->> (b - OK)
 (8)  {{ Z*Z<=m /\ m<(Z+1)*(Z+1) }}

    This didn't work very well: both conditions (a) and (c) failed.
    Looking at condition (c), we see that the second conjunct of (4)
    is almost the same as the first conjunct of (5), except that (4)
    mentions [X] while (5) mentions [m]. But note that [X] is never
    assigned in this program, so we should have [X=m], but we didn't
    propagate this information from (1) into the loop invariant.

    Also, looking at the second conjunct of (8), it seems quite
    hopeless as an invariant -- and we don't even need it, since we
    can obtain it from the negation of the guard (third conjunct
    in (7)), again under the assumption that [X=m].

    So we now try [X=m /\ Z*Z <= m] as the loop invariant:
      {{ X=m }}  ->>                                      (a - OK)
      {{ X=m /\ 0*0 <= m }}
    Z ::= 0;
      {{ X=m /\ Z*Z <= m }}
    WHILE (Z+1)*(Z+1) <= X DO
        {{ X=m /\ Z*Z<=m /\ (Z+1)*(Z+1)<=X }}  ->>        (c - OK)
        {{ X=m /\ (Z+1)*(Z+1)<=m }}
      Z ::= Z+1
        {{ X=m /\ Z*Z<=m }}
    END
      {{ X=m /\ Z*Z<=m /\ X<(Z+1)*(Z+1) }}  ->>           (b - OK)
      {{ Z*Z<=m /\ m<(Z+1)*(Z+1) }}

    This works, since conditions (a), (b), and (c) are now all
    trivially satisfied.

    Very often, if a variable is used in a loop in a read-only
    fashion (i.e., it is referred to by the program or by the
    specification and it is not changed by the loop) it is necessary
    to add the fact that it doesn't change to the loop invariant. *)

(* ####################################################### *)
(** ** Example: Squaring *)

(** Here is a program that squares [X] by repeated addition:

    {{ X = m }}
  Y ::= 0;
  Z ::= 0;
  WHILE  Y  <>  X  DO
    Z ::= Z + X;
    Y ::= Y + 1
  END
    {{ Z = m*m }}
*)

(** The first thing to note is that the loop reads [X] but doesn't
    change its value. As we saw in the previous example, in such cases
    it is a good idea to add [X = m] to the invariant. The other thing
    we often use in the invariant is the postcondition, so let's add
    that too, leading to the invariant candidate [Z = m * m /\ X = m].
      {{ X = m }} ->>                            (a - WRONG)
      {{ 0 = m*m /\ X = m }}
    Y ::= 0;
      {{ 0 = m*m /\ X = m }}
    Z ::= 0;
      {{ Z = m*m /\ X = m }}
    WHILE Y <> X DO
        {{ Z = Y*m /\ X = m /\ Y <> X }} ->>     (c - WRONG)
        {{ Z+X = m*m /\ X = m }}
      Z ::= Z + X;
        {{ Z = m*m /\ X = m }}
      Y ::= Y + 1
        {{ Z = m*m /\ X = m }}
    END
      {{ Z = m*m /\ X = m /\ Y = X }} ->>         (b - OK)
      {{ Z = m*m }}

    Conditions (a) and (c) fail because of the [Z = m*m] part.  While
    [Z] starts at [0] and works itself up to [m*m], we can't expect
    [Z] to be [m*m] from the start.  If we look at how [Z] progesses
    in the loop, after the 1st iteration [Z = m], after the 2nd
    iteration [Z = 2*m], and at the end [Z = m*m].  Since the variable
    [Y] tracks how many times we go through the loop, we derive the
    new invariant candidate [Z = Y*m /\ X = m].
      {{ X = m }} ->>                               (a - OK)
      {{ 0 = 0*m /\ X = m }}
    Y ::= 0;
      {{ 0 = Y*m /\ X = m }}
    Z ::= 0;
      {{ Z = Y*m /\ X = m }}
    WHILE Y <> X DO
        {{ Z = Y*m /\ X = m /\ Y <> X }} ->>        (c - OK)
        {{ Z+X = (Y+1)*m /\ X = m }}
      Z ::= Z + X;
        {{ Z = (Y+1)*m /\ X = m }}
      Y ::= Y + 1
        {{ Z = Y*m /\ X = m }}
    END
      {{ Z = Y*m /\ X = m /\ Y = X }} ->>           (b - OK)
      {{ Z = m*m }}

    This new invariant makes the proof go through: all three
    conditions are easy to check.

    It is worth comparing the postcondition [Z = m*m] and the [Z =
    Y*m] conjunct of the invariant. It is often the case that one has
    to replace auxiliary variabes (parameters) with variables -- or
    with expressions involving both variables and parameters (like
    [m - Y]) -- when going from postconditions to invariants. *)

(* ####################################################### *)
(** ** Exercise: Factorial *)

(** **** Exercise: 3 stars (factorial) *)
(** Recall that [n!] denotes the factorial of [n] (i.e. [n! =
    1*2*...*n]).  Here is an Imp program that calculates the factorial
    of the number initially stored in the variable [X] and puts it in
    the variable [Y]:
    {{ X = m }} ;
  Y ::= 1
  WHILE X <> 0
  DO
     Y ::= Y * X
     X ::= X - 1
  END
    {{ Y = m! }}

    Fill in the blanks in following decorated program:
    {{ X = m }} ->>
    {{                                      }}
  Y ::= 1;
    {{                                      }}
  WHILE X <> 0
  DO   {{                                      }} ->>
       {{                                      }}
     Y ::= Y * X;
       {{                                      }}
     X ::= X - 1
       {{                                      }}
  END
    {{                                      }} ->>
    {{ Y = m! }}
*)

(** [] *)

(* ####################################################### *)
(** ** Exercise: Min *)

(** **** Exercise: 3 stars (Min_Hoare) *)
(** Fill in valid decorations for the following program.
  For the => steps in your annotations, you may rely (silently) on the
  following facts about min

  Lemma lemma1 : forall x y,
  (x=0 \/ y=0) -> min x y = 0.
  Lemma lemma2 : forall x y,
  min (x-1) (y-1) = (min x y) - 1.

  plus, as usual, standard high-school algebra.

  {{ True }} ->>
  {{                    }}
  X ::= a;
  {{                       }}
  Y ::= b;
  {{                       }}
  Z ::= 0;
  {{                       }}
  WHILE (X <> 0 /\ Y <> 0) DO
  {{                                     }} ->>
  {{                                }}
  X := X - 1;
  {{                            }}
  Y := Y - 1;
  {{                        }}
  Z := Z + 1;
  {{                       }}
  END
  {{                            }} ->>
  {{ Z = min a b }}
*)

(** **** Exercise: 3 stars (two_loops) *)
(** Here is a very inefficient way of adding 3 numbers:
  X ::= 0;
  Y ::= 0;
  Z ::= c;
  WHILE X <> a DO
    X ::= X + 1;
    Z ::= Z + 1
  END;
  WHILE Y <> b DO
    Y ::= Y + 1;
    Z ::= Z + 1
  END

    Show that it does what it should by filling in the blanks in the
    following decorated program.

    {{ True }} ->>
    {{                                        }}
  X ::= 0;
    {{                                        }}
  Y ::= 0;
    {{                                        }}
  Z ::= c;
    {{                                        }}
  WHILE X <> a DO
      {{                                        }} ->>
      {{                                        }}
    X ::= X + 1;
      {{                                        }}
    Z ::= Z + 1
      {{                                        }}
  END;
    {{                                        }} ->>
    {{                                        }}
  WHILE Y <> b DO
      {{                                        }} ->>
      {{                                        }}
    Y ::= Y + 1;
      {{                                        }}
    Z ::= Z + 1
      {{                                        }}
  END
    {{                                        }} ->>
    {{ Z = a + b + c }}
*)

(* ####################################################### *)
(** ** Exercise: Power Series *)

(** **** Exercise: 4 stars, optional (dpow2_down) *)
(** Here is a program that computes the series:
    [1 + 2 + 2^2 + ... + 2^m = 2^(m+1) - 1]
  X ::= 0;
  Y ::= 1;
  Z ::= 1;
  WHILE X <> m DO
    Z ::= 2 * Z;
    Y ::= Y + Z;
    X ::= X + 1;
  END
    Write a decorated program for this. *)

(* FILL IN HERE *)

(* ####################################################### *)
(** * Weakest Preconditions (Advanced) *)

(** Some Hoare triples are more interesting than others.
    For example,
      {{ False }}  X ::= Y + 1  {{ X <= 5 }}
    is _not_ very interesting: although it is perfectly valid, it
    tells us nothing useful.  Since the precondition isn't satisfied
    by any state, it doesn't describe any situations where we can use
    the command [X ::= Y + 1] to achieve the postcondition [X <= 5].

    By contrast,
      {{ Y <= 4 /\ Z = 0 }}  X ::= Y + 1 {{ X <= 5 }}
    is useful: it tells us that, if we can somehow create a situation
    in which we know that [Y <= 4 /\ Z = 0], then running this command
    will produce a state satisfying the postcondition.  However, this
    triple is still not as useful as it could be, because the [Z = 0]
    clause in the precondition actually has nothing to do with the
    postcondition [X <= 5].  The _most_ useful triple (for a given
    command and postcondition) is this one:
      {{ Y <= 4 }}  X ::= Y + 1  {{ X <= 5 }}
    In other words, [Y <= 4] is the _weakest_ valid precondition of
    the command [X ::= Y + 1] for the postcondition [X <= 5]. *)

(** In general, we say that "[P] is the weakest precondition of
    command [c] for postcondition [Q]" if [{{P}} c {{Q}}] and if,
    whenever [P'] is an assertion such that [{{P'}} c {{Q}}], we have
    [P' st] implies [P st] for all states [st].  *)

Definition is_wp P c Q :=
  {{P}} c {{Q}} /\
  forall P', {{P'}} c {{Q}} -> (P' ->> P).

(** That is, [P] is the weakest precondition of [c] for [Q]
    if (a) [P] _is_ a precondition for [Q] and [c], and (b) [P] is the
    _weakest_ (easiest to satisfy) assertion that guarantees [Q] after
    executing [c]. *)

(** **** Exercise: 1 star, optional (wp) *)
(** What are the weakest preconditions of the following commands
   for the following postconditions?
  1) {{ ? }}  SKIP  {{ X = 5 }}

  2) {{ ? }}  X ::= Y + Z {{ X = 5 }}

  3) {{ ? }}  X ::= Y  {{ X = Y }}

  4) {{ ? }}
     IFB X == 0 THEN Y ::= Z + 1 ELSE Y ::= W + 2 FI
     {{ Y = 5 }}

  5) {{ ? }}
     X ::= 5
     {{ X = 0 }}

  6) {{ ? }}
     WHILE True DO X ::= 0 END
     {{ X = 0 }}
*)
(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (is_wp_formal) *)
(** Prove formally using the definition of [hoare_triple] that [Y <= 4]
   is indeed the weakest precondition of [X ::= Y + 1] with respect to
   postcondition [X <= 5]. *)

Theorem is_wp_example :
  is_wp (fun st => st Y <= 4)
    (X ::= APlus (AId Y) (ANum 1)) (fun st => st X <= 5).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (hoare_asgn_weakest) *)
(** Show that the precondition in the rule [hoare_asgn] is in fact the
    weakest precondition. *)

Theorem hoare_asgn_weakest : forall Q X a,
  is_wp (Q [X |-> a]) (X ::= a) Q.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced, optional (hoare_havoc_weakest) *)
(** Show that your [havoc_pre] rule from the [himp_hoare] exercise
    in the [Hoare] chapter returns the weakest precondition. *)
Module Himp2.
Import Himp.

Lemma hoare_havoc_weakest : forall (P Q : Assertion) (X : id),
  {{ P }} HAVOC X {{ Q }} ->
  P ->> havoc_pre X Q.
Proof.
(* FILL IN HERE *) Admitted.
End Himp2.
(** [] *)

(* ####################################################### *)
(** * Formal Decorated Programs (Advanced) *)

(** The informal conventions for decorated programs amount to a way of
    displaying Hoare triples in which commands are annotated with
    enough embedded assertions that checking the validity of the
    triple is reduced to simple logical and algebraic calculations
    showing that some assertions imply others.  In this section, we
    show that this informal presentation style can actually be made
    completely formal and indeed that checking the validity of
    decorated programs can mostly be automated.  *)

(** ** Syntax *)

(** The first thing we need to do is to formalize a variant of the
    syntax of commands with embedded assertions.  We call the new
    commands _decorated commands_, or [dcom]s. *)

Inductive dcom : Type :=
  | DCSkip :  Assertion -> dcom
  | DCSeq : dcom -> dcom -> dcom
  | DCAsgn : id -> aexp ->  Assertion -> dcom
  | DCIf : bexp ->  Assertion -> dcom ->  Assertion -> dcom
           -> Assertion-> dcom
  | DCWhile : bexp -> Assertion -> dcom -> Assertion -> dcom
  | DCPre : Assertion -> dcom -> dcom
  | DCPost : dcom -> Assertion -> dcom.

Tactic Notation "dcom_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Skip" | Case_aux c "Seq" | Case_aux c "Asgn"
  | Case_aux c "If" | Case_aux c "While"
  | Case_aux c "Pre" | Case_aux c "Post" ].

Notation "'SKIP' {{ P }}"
      := (DCSkip P)
      (at level 10) : dcom_scope.
Notation "l '::=' a {{ P }}"
      := (DCAsgn l a P)
      (at level 60, a at next level) : dcom_scope.
Notation "'WHILE' b 'DO' {{ Pbody }} d 'END' {{ Ppost }}"
      := (DCWhile b Pbody d Ppost)
      (at level 80, right associativity) : dcom_scope.
Notation "'IFB' b 'THEN' {{ P }} d 'ELSE' {{ P' }} d' 'FI' {{ Q }}"
      := (DCIf b P d P' d' Q)
      (at level 80, right associativity)  : dcom_scope.
Notation "'->>' {{ P }} d"
      := (DCPre P d)
      (at level 90, right associativity)  : dcom_scope.
Notation "{{ P }} d"
      := (DCPre P d)
      (at level 90)  : dcom_scope.
Notation "d '->>' {{ P }}"
      := (DCPost d P)
      (at level 80, right associativity)  : dcom_scope.
Notation " d ;; d' "
      := (DCSeq d d')
      (at level 80, right associativity)  : dcom_scope.

Delimit Scope dcom_scope with dcom.

(** To avoid clashing with the existing [Notation] definitions
    for ordinary [com]mands, we introduce these notations in a special
    scope called [dcom_scope], and we wrap examples with the
    declaration [% dcom] to signal that we want the notations to be
    interpreted in this scope.

    Careful readers will note that we've defined two notations for the
    [DCPre] constructor, one with and one without a [->>].  The
    "without" version is intended to be used to supply the initial
    precondition at the very top of the program. *)

Example dec_while : dcom := (
  {{ fun st => True }}
  WHILE (BNot (BEq (AId X) (ANum 0)))
  DO
    {{ fun st => True /\ st X <> 0}}
    X ::= (AMinus (AId X) (ANum 1))
    {{ fun _ => True }}
  END
  {{ fun st => True /\ st X = 0}} ->>
  {{ fun st => st X = 0 }}
) % dcom.

(** It is easy to go from a [dcom] to a [com] by erasing all
    annotations. *)

Fixpoint extract (d:dcom) : com :=
  match d with
  | DCSkip _           => SKIP
  | DCSeq d1 d2        => (extract d1 ;; extract d2)
  | DCAsgn X a _       => X ::= a
  | DCIf b _ d1 _ d2 _ => IFB b THEN extract d1 ELSE extract d2 FI
  | DCWhile b _ d _    => WHILE b DO extract d END
  | DCPre _ d          => extract d
  | DCPost d _         => extract d
  end.

(** The choice of exactly where to put assertions in the definition of
    [dcom] is a bit subtle.  The simplest thing to do would be to
    annotate every [dcom] with a precondition and postcondition.  But
    this would result in very verbose programs with a lot of repeated
    annotations: for example, a program like [SKIP;SKIP] would have to
    be annotated as
        {{P}} ({{P}} SKIP {{P}}) ;; ({{P}} SKIP {{P}}) {{P}},
    with pre- and post-conditions on each [SKIP], plus identical pre-
    and post-conditions on the semicolon!

    Instead, the rule we've followed is this:

       - The _post_-condition expected by each [dcom] [d] is embedded in [d]

       - The _pre_-condition is supplied by the context. *)

(** In other words, the invariant of the representation is that a
    [dcom] [d] together with a precondition [P] determines a Hoare
    triple [{{P}} (extract d) {{post d}}], where [post] is defined as
    follows: *)

Fixpoint post (d:dcom) : Assertion :=
  match d with
  | DCSkip P                => P
  | DCSeq d1 d2             => post d2
  | DCAsgn X a Q            => Q
  | DCIf  _ _ d1 _ d2 Q     => Q
  | DCWhile b Pbody c Ppost => Ppost
  | DCPre _ d               => post d
  | DCPost c Q              => Q
  end.

(** Similarly, we can extract the "initial precondition" from a
    decorated program. *)

Fixpoint pre (d:dcom) : Assertion :=
  match d with
  | DCSkip P                => fun st => True
  | DCSeq c1 c2             => pre c1
  | DCAsgn X a Q            => fun st => True
  | DCIf  _ _ t _ e _       => fun st => True
  | DCWhile b Pbody c Ppost => fun st => True
  | DCPre P c               => P
  | DCPost c Q              => pre c
  end.

(** This function is not doing anything sophisticated like calculating
    a weakest precondition; it just recursively searches for an
    explicit annotation at the very beginning of the program,
    returning default answers for programs that lack an explicit
    precondition (like a bare assignment or [SKIP]). *)

(** Using [pre] and [post], and assuming that we adopt the convention
    of always supplying an explicit precondition annotation at the
    very beginning of our decorated programs, we can express what it
    means for a decorated program to be correct as follows: *)

Definition dec_correct (d:dcom) :=
  {{pre d}} (extract d) {{post d}}.

(** To check whether this Hoare triple is _valid_, we need a way to
    extract the "proof obligations" from a decorated program.  These
    obligations are often called _verification conditions_, because
    they are the facts that must be verified to see that the
    decorations are logically consistent and thus add up to a complete
    proof of correctness. *)

(** ** Extracting Verification Conditions *)

(** The function [verification_conditions] takes a [dcom] [d] together
    with a precondition [P] and returns a _proposition_ that, if it
    can be proved, implies that the triple [{{P}} (extract d) {{post d}}]
    is valid. *)

(** It does this by walking over [d] and generating a big
    conjunction including all the "local checks" that we listed when
    we described the informal rules for decorated programs.  (Strictly
    speaking, we need to massage the informal rules a little bit to
    add some uses of the rule of consequence, but the correspondence
    should be clear.) *)

Fixpoint verification_conditions (P : Assertion) (d:dcom) : Prop :=
  match d with
  | DCSkip Q          =>
      (P ->> Q)
  | DCSeq d1 d2      =>
      verification_conditions P d1
      /\ verification_conditions (post d1) d2
  | DCAsgn X a Q      =>
      (P ->> Q [X |-> a])
  | DCIf b P1 d1 P2 d2 Q =>
      ((fun st => P st /\ bassn b st) ->> P1)
      /\ ((fun st => P st /\ ~ (bassn b st)) ->> P2)
      /\ (Q <<->> post d1) /\ (Q <<->> post d2)
      /\ verification_conditions P1 d1
      /\ verification_conditions P2 d2
  | DCWhile b Pbody d Ppost      =>
      (* post d is the loop invariant and the initial precondition *)
      (P ->> post d)
      /\ (Pbody <<->> (fun st => post d st /\ bassn b st))
      /\ (Ppost <<->> (fun st => post d st /\ ~(bassn b st)))
      /\ verification_conditions Pbody d
  | DCPre P' d         =>
      (P ->> P') /\ verification_conditions P' d
  | DCPost d Q        =>
      verification_conditions P d /\ (post d ->> Q)
  end.

(** And now, the key theorem, which states that
    [verification_conditions] does its job correctly.  Not
    surprisingly, we need to use each of the Hoare Logic rules at some
    point in the proof. *)
(** We have used _in_ variants of several tactics before to
    apply them to values in the context rather than the goal. An
    extension of this idea is the syntax [tactic in *], which applies
    [tactic] in the goal and every hypothesis in the context.  We most
    commonly use this facility in conjunction with the [simpl] tactic,
    as below. *)

Theorem verification_correct : forall d P,
  verification_conditions P d -> {{P}} (extract d) {{post d}}.
Proof.
  dcom_cases (induction d) Case; intros P H; simpl in *.
  Case "Skip".
    eapply hoare_consequence_pre.
      apply hoare_skip.
      assumption.
  Case "Seq".
    inversion H as [H1 H2]. clear H.
    eapply hoare_seq.
      apply IHd2. apply H2.
      apply IHd1. apply H1.
  Case "Asgn".
    eapply hoare_consequence_pre.
      apply hoare_asgn.
      assumption.
  Case "If".
    inversion H as [HPre1 [HPre2 [[Hd11 Hd12]
                                  [[Hd21 Hd22] [HThen HElse]]]]].
    clear H.
    apply IHd1 in HThen. clear IHd1.
    apply IHd2 in HElse. clear IHd2.
    apply hoare_if.
      eapply hoare_consequence_pre; eauto.
      eapply hoare_consequence_post; eauto.
      eapply hoare_consequence_pre; eauto.
      eapply hoare_consequence_post; eauto.
  Case "While".
    inversion H as [Hpre [[Hbody1 Hbody2] [[Hpost1 Hpost2]  Hd]]];
    subst; clear H.
    eapply hoare_consequence_pre; eauto.
    eapply hoare_consequence_post; eauto.
    apply hoare_while.
    eapply hoare_consequence_pre; eauto.
  Case "Pre".
    inversion H as [HP Hd]; clear H.
    eapply hoare_consequence_pre. apply IHd. apply Hd. assumption.
  Case "Post".
    inversion H as [Hd HQ]; clear H.
    eapply hoare_consequence_post. apply IHd. apply Hd. assumption.
Qed.

(** ** Examples *)

(** The propositions generated by [verification_conditions] are fairly
    big, and they contain many conjuncts that are essentially trivial. *)

Eval simpl in (verification_conditions (fun st => True) dec_while).
(**
==>
(((fun _ : state => True) ->> (fun _ : state => True)) /\
 ((fun _ : state => True) ->> (fun _ : state => True)) /\
 (fun st : state => True /\ bassn (BNot (BEq (AId X) (ANum 0))) st) =
 (fun st : state => True /\ bassn (BNot (BEq (AId X) (ANum 0))) st) /\
 (fun st : state => True /\ ~ bassn (BNot (BEq (AId X) (ANum 0))) st) =
 (fun st : state => True /\ ~ bassn (BNot (BEq (AId X) (ANum 0))) st) /\
 (fun st : state => True /\ bassn (BNot (BEq (AId X) (ANum 0))) st) ->>
 (fun _ : state => True) [X |-> AMinus (AId X) (ANum 1)]) /\
(fun st : state => True /\ ~ bassn (BNot (BEq (AId X) (ANum 0))) st) ->>
(fun st : state => st X = 0)
*)

(** In principle, we could certainly work with them using just the
    tactics we have so far, but we can make things much smoother with
    a bit of automation.  We first define a custom [verify] tactic
    that applies splitting repeatedly to turn all the conjunctions
    into separate subgoals and then uses [omega] and [eauto] (a handy
    general-purpose automation tactic that we'll discuss in detail
    later) to deal with as many of them as possible. *)

Lemma ble_nat_true_iff : forall n m : nat,
  ble_nat n m = true <-> n <= m.
Proof.
  intros n m. split. apply ble_nat_true.
  generalize dependent m. induction n; intros m H. reflexivity.
    simpl. destruct m. inversion H.
    apply le_S_n in H. apply IHn. assumption.
Qed.

Lemma ble_nat_false_iff : forall n m : nat,
  ble_nat n m = false <-> ~(n <= m).
Proof.
  intros n m. split. apply ble_nat_false.
  generalize dependent m. induction n; intros m H.
    apply ex_falso_quodlibet. apply H. apply le_0_n.
    simpl. destruct m. reflexivity.
    apply IHn. intro Hc. apply H. apply le_n_S. assumption.
Qed.

Tactic Notation "verify" :=
  apply verification_correct;
  repeat split;
  simpl; unfold assert_implies;
  unfold bassn in *; unfold beval in *; unfold aeval in *;
  unfold assn_sub; intros;
  repeat rewrite update_eq;
  repeat (rewrite update_neq; [| (intro X; inversion X)]);
  simpl in *;
  repeat match goal with [H : _ /\ _ |- _] => destruct H end;
  repeat rewrite not_true_iff_false in *;
  repeat rewrite not_false_iff_true in *;
  repeat rewrite negb_true_iff in *;
  repeat rewrite negb_false_iff in *;
  repeat rewrite beq_nat_true_iff in *;
  repeat rewrite beq_nat_false_iff in *;
  repeat rewrite ble_nat_true_iff in *;
  repeat rewrite ble_nat_false_iff in *;
  try subst;
  repeat
    match goal with
      [st : state |- _] =>
        match goal with
          [H : st _ = _ |- _] => rewrite -> H in *; clear H
        | [H : _ = st _ |- _] => rewrite <- H in *; clear H
        end
    end;
  try eauto; try omega.

(** What's left after [verify] does its thing is "just the interesting
    parts" of checking that the decorations are correct. For very
    simple examples [verify] immediately solves the goal (provided
    that the annotations are correct). *)

Theorem dec_while_correct :
  dec_correct dec_while.
Proof. verify. Qed.

(** Another example (formalizing a decorated program we've seen
    before): *)

Example subtract_slowly_dec (m:nat) (p:nat) : dcom := (
    {{ fun st => st X = m /\ st Z = p }} ->>
    {{ fun st => st Z - st X = p - m }}
  WHILE BNot (BEq (AId X) (ANum 0))
  DO   {{ fun st => st Z - st X = p - m /\ st X <> 0 }} ->>
       {{ fun st => (st Z - 1) - (st X - 1) = p - m }}
     Z ::= AMinus (AId Z) (ANum 1)
       {{ fun st => st Z - (st X - 1) = p - m }} ;;
     X ::= AMinus (AId X) (ANum 1)
       {{ fun st => st Z - st X = p - m }}
  END
    {{ fun st => st Z - st X = p - m /\ st X = 0 }} ->>
    {{ fun st => st Z = p - m }}
) % dcom.

Theorem subtract_slowly_dec_correct : forall m p,
  dec_correct (subtract_slowly_dec m p).
Proof. intros m p. verify. (* this grinds for a bit! *) Qed.

(** **** Exercise: 3 stars, advanced (slow_assignment_dec) *)

(** In the [slow_assignment] exercise above, we saw a roundabout way
    of assigning a number currently stored in [X] to the variable [Y]:
    start [Y] at [0], then decrement [X] until it hits [0],
    incrementing [Y] at each step.

    Write a _formal_ version of this decorated program and prove it
    correct. *)

Example slow_assignment_dec (m:nat) : dcom :=
(* FILL IN HERE *) admit.

Theorem slow_assignment_dec_correct : forall m,
  dec_correct (slow_assignment_dec m).
Proof. (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, advanced (factorial_dec)  *)
(** Remember the factorial function we worked with before: *)

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

(** Following the pattern of [subtract_slowly_dec], write a decorated
    program that implements the factorial function and prove it
    correct. *)

(* FILL IN HERE *)
(** [] *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Lists.List Coq.Arith.Arith.
Require Import Cava.Util.List.
Require Import Psatz.

Section Spec.
  Context {byte : Type}.
  Local Notation word := (list byte) (only parsing).
  Local Notation state := (list word) (only parsing).

  Definition shift_row_once (w : word) :=
    match w with
    | nil => nil
    | h :: t => t ++ h :: nil
    end.

  Fixpoint shift_row (w : word) (r : nat) :=
    match r with
    | O => w
    | S r' => shift_row (shift_row_once w) r'
    end.

  Definition shift_rows_start (st : state) (n : nat) :=
    map2 shift_row st (List.seq n (length st)).

  Definition shift_rows (st : state) :=
    shift_rows_start st 0.

  Definition inv_shift_row (w : word) (r : nat) :=
    rev (shift_row (rev w) r).

  Definition inv_shift_rows (st : state) :=
    map2 inv_shift_row st (List.seq 0 (length st)).

  Section Properties.
    Lemma shift_row_nil : forall shift,
      shift_row nil shift = nil.
    Proof.
      induction shift; [reflexivity|].
      simpl.
      rewrite IHshift.
      reflexivity.
    Qed.

    Lemma inv_shift_row_hd w h : inv_shift_row (w ++ h :: nil) 1 = h :: w.
    Proof.
      unfold inv_shift_row.
      rewrite rev_app_distr.
      simpl.
      rewrite rev_app_distr.
      simpl.
      rewrite rev_involutive.
      reflexivity.
    Qed.

    Lemma inv_shift_row_O w : inv_shift_row w 0 = w.
    Proof.
      unfold inv_shift_row.
      simpl.
      apply rev_involutive.
    Qed.

    Lemma shift_row_plus x a b : shift_row x (a + b) = shift_row (shift_row x a) b.
      generalize dependent x.
      generalize dependent a.
      induction a; intros.
      { simpl.
        reflexivity. }
      { simpl.
        rewrite IHa.
        reflexivity. }
    Qed.

    Lemma inv_shift_row_plus x a b : inv_shift_row x (a + b) = inv_shift_row (inv_shift_row x a) b.
      unfold inv_shift_row.
      rewrite rev_involutive.
      rewrite shift_row_plus.
      reflexivity.
    Qed.

    Lemma inverse_shift_row_1 a : inv_shift_row (shift_row a 1) 1 = a.
      induction a; [reflexivity|].
      simpl.
      rewrite inv_shift_row_hd.
      reflexivity.
    Qed.

    Lemma inverse_shift_row a n : inv_shift_row (shift_row a n) n = a.
    Proof.
      generalize dependent a.
      induction n; intros.
      { simpl.
        rewrite inv_shift_row_O.
        reflexivity. }
      { replace (S n) with (n+1) by lia.
        rewrite shift_row_plus.
        rewrite Nat.add_comm.
        rewrite inv_shift_row_plus.
        rewrite inverse_shift_row_1.
        apply IHn. }
    Qed.

    Theorem inverse_shift_rows (x : state) : inv_shift_rows (shift_rows x) = x.
    Proof.
      unfold shift_rows.
      unfold inv_shift_rows.
      unfold shift_rows_start.

      rewrite map2_length.
      rewrite seq_length.
      rewrite Min.min_idempotent.

      rewrite map2_map2_r.
      erewrite map2_ext by (intros; rewrite inverse_shift_row; reflexivity).
      refine (map2_id_l _ _ _).
      rewrite seq_length.
      lia.
    Qed.

    Theorem shift_rows_length_outer (x : state) :
      length (shift_rows x) = length x.
    Proof.
      cbv [shift_rows shift_rows_start].
      autorewrite with push_length.
      lia.
    Qed.

    Lemma shift_row_once_length (row : list byte) :
      length (shift_row_once row) = length row.
    Proof.
      cbv [shift_row_once]. destruct row; length_hammer.
    Qed.

    Lemma shift_row_length (row : list byte) n :
      length (shift_row row n) = length row.
    Proof.
      revert row; induction n; intros; [ reflexivity | ].
      cbn [shift_row]. rewrite IHn, shift_row_once_length.
      reflexivity.
    Qed.

    Theorem shift_rows_length_inner (x : state) n :
      (forall r, In r x -> length r = n) ->
      forall r, In r (shift_rows x) -> length r = n.
    Proof.
      cbv [shift_rows shift_rows_start]; intros Hx ? Hin.
      apply in_map2_impl in Hin. destruct Hin as [? [? ?]].
      intuition; subst.
      rewrite shift_row_length. auto.
    Qed.

  End Properties.
End Spec.
#[export] Hint Resolve shift_rows_length_inner shift_rows_length_outer : length.

Section BasicTests.
  Import ListNotations.

  (* use nat as the "byte" type so shifting is easy to read *)
  Definition nat_rows := [[0; 1; 2; 3]; [4; 5; 6; 7]; [8; 9; 10; 11]; [12; 13; 14; 15]].
  Definition shifted_nat_rows := [[0; 1; 2; 3]; [5; 6; 7; 4]; [10; 11; 8; 9]; [15; 12; 13; 14]].

  Goal (shift_rows nat_rows = shifted_nat_rows).
  Proof. vm_compute. reflexivity. Qed.

  Goal (inv_shift_rows shifted_nat_rows = nat_rows).
  Proof. vm_compute. reflexivity. Qed.

  Goal (inv_shift_rows (shift_rows nat_rows) = nat_rows).
  Proof. vm_compute. reflexivity. Qed.

  (* and do 3x4 to make sure col/row indices aren't ever switched, which can complicated proofs *)
  Definition nat_rows' := [[0; 1; 2; 3]; [4; 5; 6; 7]; [8; 9; 10; 11]].
  Definition shifted_nat_rows' := [[0; 1; 2; 3]; [5; 6; 7; 4]; [10; 11; 8; 9]].

  Goal (shift_rows nat_rows' = shifted_nat_rows').
  Proof. vm_compute. reflexivity. Qed.

  Goal (inv_shift_rows shifted_nat_rows' = nat_rows').
  Proof. vm_compute. reflexivity. Qed.

  (* and 4x3 as well *)
  Definition nat_rows'' := [[0; 1; 2]; [4; 5; 6]; [8; 9; 10]; [12; 13; 14]].
  Definition shifted_nat_rows'' := [[0; 1; 2]; [5; 6; 4]; [10; 8; 9]; [12; 13; 14]].

  Goal (shift_rows nat_rows'' = shifted_nat_rows'').
  Proof. vm_compute. reflexivity. Qed.

  Goal (inv_shift_rows shifted_nat_rows'' = nat_rows'').
  Proof. vm_compute. reflexivity. Qed.

End BasicTests.


(* -*- mode: coq; mode: visual-line -*-  *)
(** * Truncatedness *)

Require Import
  Basics.Overture
  Basics.Contractible
  Basics.Equivalences
  Basics.Tactics
  Basics.Nat.
Local Open Scope trunc_scope.
Local Open Scope path_scope.
Generalizable Variables A B m n f.

(** ** Notation for truncation-levels. *)
Open Scope trunc_scope.

(* Increase a truncation index by a natural number. *)
Fixpoint trunc_index_inc (k : trunc_index) (n : nat)
  : trunc_index
  := match n with
      | O => k
      | S m => (trunc_index_inc k m).+1
    end.

(* This is a variation that inserts the successor operations in
   the other order.  This is sometimes convenient. *)
Fixpoint trunc_index_inc' (k : trunc_index) (n : nat)
  : trunc_index
  := match n with
      | O => k
      | S m => (trunc_index_inc' k.+1 m)
    end.

Definition trunc_index_inc'_succ (n : nat) (k : trunc_index)
  : trunc_index_inc' k.+1 n = (trunc_index_inc' k n).+1.
Proof.
  revert k; induction n; intro k.
  - reflexivity.
  - apply (IHn k.+1).
Defined.

Definition trunc_index_inc_agree (k : trunc_index) (n : nat)
  : trunc_index_inc k n = trunc_index_inc' k n.
Proof.
  induction n.
  - reflexivity.
  - simpl.
    refine (ap _ IHn @ _).
    symmetry; apply trunc_index_inc'_succ.
Defined.

Definition nat_to_trunc_index (n : nat) : trunc_index
  := (trunc_index_inc minus_two n).+2.

Coercion nat_to_trunc_index : nat >-> trunc_index.

Definition int_to_trunc_index (v : Decimal.int) : option trunc_index
  := match v with
     | Decimal.Pos d => Some (nat_to_trunc_index (Nat.of_uint d))
     | Decimal.Neg d => match Nat.of_uint d with
                        | 2%nat => Some minus_two
                        | 1%nat => Some (minus_two.+1)
                        | 0%nat => Some (minus_two.+2)
                        | _ => None
                        end
     end.

Definition num_int_to_trunc_index (v : Numeral.int) : option trunc_index :=
  match v with
  | Numeral.IntDec v => int_to_trunc_index v
  | Numeral.IntHex _ => None
  end.

Fixpoint trunc_index_to_little_uint n acc :=
  match n with
  | minus_two => acc
  | minus_two.+1 => acc
  | minus_two.+2 => acc
  | trunc_S n => trunc_index_to_little_uint n (Decimal.Little.succ acc)
  end.

Definition trunc_index_to_int n :=
  match n with
  | minus_two => Decimal.Neg (Nat.to_uint 2)
  | minus_two.+1 => Decimal.Neg (Nat.to_uint 1)
  | n => Decimal.Pos (Decimal.rev (trunc_index_to_little_uint n Decimal.zero))
  end.

Definition trunc_index_to_num_int n :=
  Numeral.IntDec (trunc_index_to_int n).

Number Notation trunc_index num_int_to_trunc_index trunc_index_to_num_int
  : trunc_scope.

(** ** Arithmetic on truncation-levels. *)
Fixpoint trunc_index_add (m n : trunc_index) : trunc_index
  := match m with
       | -2 => n
       | m'.+1 => (trunc_index_add m' n).+1
     end.

Notation "m +2+ n" := (trunc_index_add m n) : trunc_scope.

Definition trunc_index_add_minus_two m
  : m +2+ -2 = m.
Proof.
  induction m.
  1: reflexivity.
  cbn; apply ap.
  assumption.
Defined.

Definition trunc_index_add_succ m n
  : m +2+ n.+1 = (m +2+ n).+1.
Proof.
  revert m.
  induction n; induction m.
  1,3: reflexivity.
  all: cbn; apply ap.
  all: assumption.
Defined.

Fixpoint trunc_index_leq (m n : trunc_index) : Type0
  := match m, n with
       | -2, _ => Unit
       | m'.+1, -2 => Empty
       | m'.+1, n'.+1 => trunc_index_leq m' n'
     end.

Existing Class trunc_index_leq.

Notation "m <= n" := (trunc_index_leq m n) : trunc_scope.

Global Instance trunc_index_leq_minus_two_n n : -2 <= n := tt.

Global Instance trunc_index_leq_succ n : n <= n.+1.
Proof.
  by induction n as [|n IHn] using trunc_index_ind.
Defined.

Definition trunc_index_pred : trunc_index -> trunc_index.
Proof.
  intros [|m].
  1: exact (-2).
  exact m.
Defined.

Notation "n '.-1'" := (trunc_index_pred n) : trunc_scope.
Notation "n '.-2'" := (n.-1.-1) : trunc_scope.

Definition trunc_index_leq_minus_two {n}
  : n <= -2 -> n = -2.
Proof.
  destruct n.
  1: reflexivity.
  contradiction.
Defined.

Definition trunc_index_leq_succ' n m
  : n <= m -> n <= m.+1.
Proof.
  revert m.
  induction n as [|n IHn] using trunc_index_ind.
  1: exact _.
  intros m p; cbn.
  induction m as [|m IHm] using trunc_index_ind.
  1: destruct p.
  apply IHn, p.
Defined.

Global Instance trunc_index_leq_refl
  : Reflexive trunc_index_leq.
Proof.
  intro n.
  by induction n as [|n IHn] using trunc_index_ind.
Defined.

Global Instance trunc_index_leq_transitive
  : Transitive trunc_index_leq.
Proof.
  intros a b c p q.
  revert b a c p q.
  induction b as [|b IHb] using trunc_index_ind.
  { intros a c p.
    by destruct (trunc_index_leq_minus_two p). }
  induction a as [|a IHa] using trunc_index_ind;
  induction c as [|c IHc] using trunc_index_ind.
  all: intros.
  1,2: exact tt.
  1: contradiction.
  cbn in p, q; cbn.
  by apply IHb.
Defined.

Fixpoint trunc_index_min (n m : trunc_index)
  : trunc_index.
Proof.
  destruct n.
  1: exact (-2).
  destruct m.
  1: exact (-2).
  exact (trunc_index_min n m).+1.
Defined.

Definition trunc_index_min_minus_two n
  : trunc_index_min n (-2) = -2.
Proof.
  by destruct n.
Defined.

Definition trunc_index_min_swap n m
  : trunc_index_min n m = trunc_index_min m n.
Proof.
  revert m.
  induction n.
  { intro.
    symmetry.
    apply trunc_index_min_minus_two. }
  induction m.
  1: reflexivity.
  cbn; apply ap, IHn.
Defined.

Definition trunc_index_min_path n m
  : (trunc_index_min n m = n) + (trunc_index_min n m = m).
Proof.
  revert m.
  induction n.
  1: by intro; apply inl.
  induction m.
  1: by apply inr.
  destruct (IHn m).
  1: apply inl.
  2: apply inr.
  1,2: cbn; by apply ap.
Defined.

Definition trunc_index_min_leq_left (n m : trunc_index)
  : trunc_index_min n m <= n.
Proof.
  revert n m.
  refine (trunc_index_ind _ _ _); [ | intros n IHn ].
  all: refine (trunc_index_ind _ _ _); [ | intros m IHm ].
  all: try exact tt.
  exact (IHn m).
Defined.

Definition trunc_index_min_leq_right (n m : trunc_index)
  : trunc_index_min n m <= m.
Proof.
  revert n m.
  refine (trunc_index_ind _ _ _); [ | intros n IHn ].
  all: refine (trunc_index_ind _ _ _); [ | intros m IHm ].
  all: try exact tt.
  exact (IHn m).
Defined.

(** ** Truncatedness proper. *)

(** A contractible space is (-2)-truncated, by definition. This function is the identity, so there is never any need to actually use it, but it exists to be found in searches. *)
Definition contr_istrunc_minus_two `{H : IsTrunc (-2) A} : Contr A
  := H.

(** Truncation levels are cumulative. *)
Global Instance istrunc_succ `{IsTrunc n A}
  : IsTrunc n.+1 A | 1000.
Proof.
  generalize dependent A.
  simple_induction n n IH; simpl; intros A H x y.
  - apply contr_paths_contr.
  - apply IH, H.
Defined.

(** This could be an [Instance] (with very high priority, so it doesn't get applied trivially).  However, we haven't given typeclass search any hints allowing it to solve goals like [m <= n], so it would only ever be used trivially.  *)
Definition istrunc_leq {m n} (Hmn : m <= n) `{IsTrunc m A}
  : IsTrunc n A.
Proof.
  generalize dependent A; generalize dependent m.
  simple_induction n n' IH;
    intros [ | m'] Hmn A ? .
  - (* -2, -2 *) assumption.
  - (* S m', -2 *) destruct Hmn.
  - (* -2, S n' *) apply @istrunc_succ, (IH (-2)); auto.
  - (* S m', S n' *) intros x y; apply (IH m');
                     auto with typeclass_instances.
Defined.

(** In particular, a contractible type, hprop, or hset is truncated at all higher levels.  We don't allow these to be used as idmaps, since there would be no point to it. *)

Definition istrunc_contr {n} {A} `{Contr A} : IsTrunc n.+1 A
  := (@istrunc_leq (-2) n.+1 tt _ _).

Definition istrunc_hprop {n} {A} `{IsHProp A} : IsTrunc n.+2 A
  := (@istrunc_leq (-1) n.+2 tt _ _).

Definition istrunc_hset {n} {A} `{IsHSet A}
  : IsTrunc n.+3 A
  := (@istrunc_leq 0 n.+3 tt _ _).

(** Consider the preceding definitions as instances for typeclass search, but only if the requisite hypothesis is already a known assumption; otherwise they result in long or interminable searches. *)
#[export] Hint Immediate istrunc_contr : typeclass_instances.
#[export] Hint Immediate istrunc_hprop : typeclass_instances.
#[export] Hint Immediate istrunc_hset : typeclass_instances.

(** Equivalence preserves truncation (this is, of course, trivial with univalence).
   This is not an [Instance] because it causes infinite loops. *)
Definition istrunc_isequiv_istrunc A {B} (f : A -> B)
  `{IsTrunc n A} `{IsEquiv A B f}
  : IsTrunc n B.
Proof.
  generalize dependent B; generalize dependent A.
  simple_induction n n IH; simpl; intros A ? B f ?.
  - exact (contr_equiv _ f).
  - intros x y.
    exact (IH (f^-1 x = f^-1 y) (H (f^-1 x) (f^-1 y))
      (x = y) ((ap (f^-1))^-1) _).
Defined.

Definition istrunc_equiv_istrunc A {B} (f : A <~> B) `{IsTrunc n A}
  : IsTrunc n B
  := istrunc_isequiv_istrunc A f.

(** ** Truncated morphisms *)

Class IsTruncMap (n : trunc_index) {X Y : Type} (f : X -> Y)
  := istruncmap_fiber : forall y:Y, IsTrunc n (hfiber f y).

Global Existing Instance istruncmap_fiber.

Notation IsEmbedding := (IsTruncMap (-1)).

(** ** Universes of truncated types *)

(** It is convenient for some purposes to consider the universe of all n-truncated types (within a given universe of types).  In particular, this allows us to state the important fact that each such universe is itself (n+1)-truncated. *)

Record TruncType (n : trunc_index) := {
  trunctype_type : Type ;
  trunctype_istrunc : IsTrunc n trunctype_type
}.

Arguments Build_TruncType _ _ {_}.
Arguments trunctype_type {_} _.
Arguments trunctype_istrunc [_] _.

Coercion trunctype_type : TruncType >-> Sortclass.
Global Existing Instance trunctype_istrunc.

Notation "n -Type" := (TruncType n) : type_scope.
Notation HProp := (-1)-Type.
Notation HSet := 0-Type.

Notation Build_HProp := (Build_TruncType (-1)).
Notation Build_HSet := (Build_TruncType 0).

(** This is (as of October 2014) the only [Canonical Structure] in the library.  It would be nice to do without it, in the interests of minimizing the number of fancy Coq features that the reader needs to know about. *)
Canonical Structure default_TruncType := fun n T P => (@Build_TruncType n T P).

(** ** Facts about hprops *)

(** An inhabited proposition is contractible.
   This is not an [Instance] because it causes infinite loops.
   *)
Lemma contr_inhabited_hprop (A : Type) `{H : IsHProp A} (x : A)
  : Contr A.
Proof.
  exists x.
  intro y.
  apply center, H.
Defined.

(** If inhabitation implies contractibility, then we have an h-proposition.  We probably won't often have a hypothesis of the form [A -> Contr A], so we make sure we give priority to other instances. *)
Global Instance hprop_inhabited_contr (A : Type)
  : (A -> Contr A) -> IsHProp A | 10000.
Proof.
  intros H x y.
  pose (C := H x).
  apply contr_paths_contr.
Defined.

(** Any two points in an hprop are connected by a path. *)
Theorem path_ishprop `{H : IsHProp A}
  : forall x y : A, x = y.
Proof.
  apply H.
Defined.

(** Conversely, this property characterizes hprops. *)
Theorem hprop_allpath (A : Type)
  : (forall (x y : A), x = y) -> IsHProp A.
  intros H x y.
  pose (C := Build_Contr A x (H x)).
  apply contr_paths_contr.
Defined.

(** Two propositions are equivalent as soon as there are maps in both directions. *)
Definition isequiv_iff_hprop `{IsHProp A} `{IsHProp B}
  (f : A -> B) (g : B -> A)
  : IsEquiv f.
Proof.
  apply (isequiv_adjointify f g);
    intros ?; apply path_ishprop.
Defined.

Definition equiv_iff_hprop_uncurried `{IsHProp A} `{IsHProp B}
  : (A <-> B) -> (A <~> B).
Proof.
  intro fg.
  apply (equiv_adjointify (fst fg) (snd fg));
    intros ?; apply path_ishprop.
Defined.

Definition equiv_iff_hprop `{IsHProp A} `{IsHProp B}
  : (A -> B) -> (B -> A) -> (A <~> B)
  := fun f g => equiv_iff_hprop_uncurried (f, g).

Corollary iff_contr_hprop (A : Type) `{IsHProp A}
  : Contr A <-> A.
Proof.
  split.
  - apply center.
  - rapply contr_inhabited_hprop.
Defined.

Corollary equiv_contr_hprop (A : Type) `{Funext} `{IsHProp A}
  : Contr A <~> A.
Proof.
  exact (equiv_iff_hprop_uncurried (iff_contr_hprop A)).
Defined.

(** Truncatedness is an hprop. *)
Global Instance ishprop_istrunc `{Funext} (n : trunc_index) (A : Type)
  : IsHProp (IsTrunc n A) | 0.
Proof.
  apply hprop_inhabited_contr.
  revert A.
  simple_induction n n IH; unfold IsTrunc; simpl.
  - intros A ?.
    exact _.
  - intros A AH1.
    exists AH1.
    intro AH2.
    apply path_forall; intro x.
    apply path_forall; intro y.
    apply @path_contr.
    apply IH, AH1.
Qed.

(** By [trunc_hprop], it follows that [IsTrunc n A] is also [m]-truncated for any [m >= -1]. *)

(** Similarly, a map being truncated is also a proposition. *)
Global Instance ishprop_istruncmap `{Funext} (n : trunc_index) {X Y : Type} (f : X -> Y)
: IsHProp (IsTruncMap n f).
Proof.
  apply hprop_allpath; intros s t.
  apply path_forall; intros x.
  apply path_ishprop.
Defined.

(** If you are looking for a theorem about truncation, you may want to read the note "Finding Theorems" in "STYLE.md". *)


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Field algebra structure
  author    : ZhengPu Shi
  date      : 2021.05
*)

Require Export Ring Field.
Require QcExt RExt RAST.

(* ######################################################################### *)
(** * Field Signature, also mixed with a ring structure *)

(** New scope for field. "X" was chosen to prevent conflicts with other names *)
Declare Scope X_scope.
Delimit Scope X_scope with X.
Open Scope X_scope.

(** Signature for field *)
Module Type FieldSig.

  (** Carrier *)
  Parameter X : Type.

  (** Operations *)
  Parameter X0 X1 : X.
  Parameter Xadd Xmul : X -> X -> X.
  Parameter Xopp Xinv : X -> X.
  Parameter Xeqb : X -> X -> bool.

  (** Notations *)
  Notation "0" := X0 : X_scope.
  Notation "1" := X1 : X_scope.
  Infix "+" := Xadd : X_scope.
  Infix "*" := Xmul : X_scope.
  Notation "- a" := (Xopp a) : X_scope.
  Notation "/ a" := (Xinv a) : X_scope.
  Notation Xsub := (fun x y => x + -y).
  Notation Xdiv := (fun x y => x * /y).
  Infix "-" := Xsub : X_scope.
  Infix "/" := Xdiv : X_scope.
  Notation "a =? b" := (Xeqb a b) (at level 70) : X_scope.

  (** Bind something to the scope *)
  Bind Scope X_scope with X X0 X1 Xadd Xmul Xopp Xinv Xeqb.

  (** Properties *)

  (** Equality is decidable *)
  Parameter Xeqdec : forall (x y : X), {x = y} + {x <> y}.

  (** Reflection of Aeq and Aeqb *)
  Parameter Xeqb_true_iff : forall x y, (x =? y = true) <-> x = y.
  Parameter Xeqb_false_iff : forall x y, (x =? y = false) <-> (x <> y).

  (** 1 <> 0. *)
  Parameter X1_neq_X0 : X1 <> X0.

  (** Ring theory *)
  Parameter Ring_thy : ring_theory X0 X1 Xadd Xmul Xsub Xopp eq.
  Add Ring Ring_thy_inst : Ring_thy.

  (** Field Theory *)
  Parameter Field_thy: field_theory X0 X1 Xadd Xmul Xsub Xopp Xdiv Xinv eq.
  Add Field Field_thy_inst : Field_thy.

End FieldSig.

(* ######################################################################### *)
(** * Field theory *)

Module FieldThy (F : FieldSig).

  Export F.

  Open Scope X_scope.

  Lemma add_comm : forall a b, a + b = b + a.
  Proof. intros. ring. Qed.

  Lemma add_assoc : forall a b c, (a + b) + c = a + (b + c).
  Proof. intros. ring. Qed.

  Lemma add_0_l : forall a, 0 + a = a.
  Proof. intros. ring. Qed.

  Lemma add_0_r : forall a, a + 0 = a.
  Proof. intros. ring. Qed.

  Lemma add_opp_l : forall a, -a + a = 0.
  Proof. intros. ring. Qed.

  Lemma add_opp_r : forall a, a - a = 0.
  Proof. intros. ring. Qed.

  Lemma opp_opp : forall a, - - a = a.
  Proof. intros. ring. Qed.

  Lemma add_cancel_l : forall a b1 b2, a + b1 = a + b2 -> b1 = b2.
  Proof.
    intros.
    rewrite <- (add_0_l b1).
    rewrite <- (add_0_l b2).   (* 0 + b1 = 0 + b2  *)
    rewrite <- (add_opp_l a).  (* -a + a + b1 = -a + a + b1 *)
    rewrite ?add_assoc.        (* -a + (a + b1) = -a + (a + b2) *)
    rewrite H. reflexivity.
  Qed.

  Lemma add_cancel_r : forall a1 a2 b, a1 + b = a2 + b -> a1 = a2.
  Proof.
    intros. rewrite <- (add_0_r a1). rewrite <- (add_0_r a2).
    rewrite <- (add_opp_r b). rewrite <- ?add_assoc. rewrite H. auto.
  Qed.

  Lemma mul_comm : forall a b, a * b = b * a.
  Proof. intros. ring. Qed.

  Lemma mul_assoc : forall a b c, (a * b) * c = a * (b * c).
  Proof. intros. ring. Qed.

  Lemma mul_0_l : forall a, 0 * a = 0.
  Proof. intros. ring. Qed.

  Lemma mul_0_r : forall a, a * 0 = 0.
  Proof. intros. ring. Qed.

  Lemma mul_1_l : forall a, 1 * a = a.
  Proof. intros. ring. Qed.

  Lemma mul_1_r : forall a, a * 1 = a.
  Proof. intros. ring. Qed.

  Lemma mul_inv_l : forall a, a <> 0 -> /a * a = 1.
  Proof. intros. field. auto. Qed.

  Lemma mul_inv_r : forall a, a <> 0 -> a / a = 1.
  Proof. intros. field. auto. Qed.

  Lemma inv_inv : forall a, a <> 0 -> //a = a.
  Proof. intros. field. split; auto. apply X1_neq_X0. Qed.

  Lemma mul_cancel_l : forall a b1 b2, a <> 0 -> a * b1 = a * b2 -> b1 = b2.
  Proof.
    intros. rewrite <- (mul_1_l b1). rewrite <- (mul_1_l b2).
    rewrite <- (mul_inv_l a); auto. rewrite ?mul_assoc. f_equal. auto.
  Qed.

  Lemma mul_cancel_r : forall a1 a2 b, b <> 0 -> a1 * b = a2 * b -> a1 = a2.
  Proof.
    intros. rewrite <- (mul_1_r a1). rewrite <- (mul_1_r a2).
    rewrite <- (mul_inv_r b); auto. rewrite <- ?mul_assoc. f_equal. auto.
  Qed.

End FieldThy.

(* ######################################################################### *)
(** * Field on Qc *)

Module FieldQc.

  Export QcExt.
  Open Scope Qc_scope.

  Module Export FieldDefQc : FieldSig
    with Definition X := Qc
    with Definition X0 := 0
    with Definition X1 := 1
    with Definition Xadd := Qcplus
    with Definition Xopp := Qcopp
    with Definition Xmul := Qcmult
    with Definition Xinv := Qcinv
    with Definition Xeqb := Qceqb.

    Definition X := Qc.
    Definition X0 := 0.
    Definition X1 := 1.
    Definition Xadd := Qcplus.
    Definition Xopp := Qcopp.
    Definition Xmul := Qcmult.
    Definition Xinv := Qcinv.
    Definition Xeqb := Qceqb.
    Definition Xeqdec := Qceqdec.
    Definition Xeqb_true_iff := Qceqb_true_iff.
    Definition Xeqb_false_iff := Qceqb_false_iff.

    Lemma X1_neq_X0 : X1 <> X0.
    Proof. intro. discriminate. Qed.

    Lemma Ring_thy : ring_theory X0 X1 Xadd Xmul Qcminus Xopp eq.
    Proof.
      constructor; intros; try auto.
      apply Qcplus_0_l. apply Qcplus_comm. apply Qcplus_assoc.
      apply Qcmult_1_l. apply Qcmult_comm. apply Qcmult_assoc.
      apply Qcmult_plus_distr_l. apply Qcplus_opp_r.
    Qed.
    Add Ring Ring_thy_inst : Ring_thy.

    Lemma Field_thy : field_theory X0 X1 Xadd Xmul Qcminus Xopp Qcdiv
      Xinv eq.
    Proof.
      constructor; try easy. apply Ring_thy.
      intros. rewrite Qcmult_comm,Qcmult_inv_r; auto.
    Qed.
    Add Field Field_thy_inst : Field_thy.

  End FieldDefQc.

End FieldQc.

(** Test *)
Section test.

  Import FieldQc.
(*   Open Scope X_scope. *)

  Goal forall a b c : X, (c<>0) -> (a + b) / c = a / c + b / c.
  Proof. intros. field. auto. Qed.

End test.

(* ######################################################################### *)
(** * Field on R *)

Module FieldR.

  Export RExt.
  Open Scope R_scope.

  Module Export FieldDefR : FieldSig
    with Definition X := R
    with Definition X0 := 0
    with Definition X1 := 1
    with Definition Xadd := Rplus
    with Definition Xopp := Ropp
    with Definition Xmul := Rmult
    with Definition Xinv := Rinv
    with Definition Xeqb := Reqb.

    Definition X := R.
    Definition X0 := 0.
    Definition X1 := 1.
    Definition Xadd := Rplus.
    Definition Xopp := Ropp.
    Definition Xmul := Rmult.
    Definition Xinv := Rinv.
    Definition Xeqb := Reqb.
    Definition Xeqdec := Req_EM_T.
    Definition Xeqb_true_iff := Reqb_true_iff.
    Definition Xeqb_false_iff := Reqb_false_iff.

    Lemma X1_neq_X0 : X1 <> X0.
    Proof. intro. auto with R. Qed.

    Lemma Ring_thy : ring_theory X0 X1 Xadd Xmul Rminus Xopp eq.
    Proof. constructor; intros; cbv; ring. Qed.
    Add Ring Ring_thy_inst : Ring_thy.

    Lemma Field_thy : field_theory X0 X1 Xadd Xmul Rminus Xopp Rdiv Xinv eq.
    Proof.
      constructor; try easy. apply Ring_thy. apply X1_neq_X0.
      intros; cbv; field; auto.
    Qed.
    Add Field Field_thy_inst : Field_thy.

  End FieldDefR.

End FieldR.

(** Test *)
Section test.

  Import FieldR.
(*   Open Scope X_scope. *)

  Goal forall a b c : X, (c<>0) -> (a + b) / c = a / c + b / c.
  Proof. intros. field. auto. Qed.

End test.

(* ######################################################################### *)
(** * Field on T *)

Module FieldT.

  Export RAST.
  Open Scope T_scope.

  Module Export FieldDefT : FieldSig
    with Definition X := T
    with Definition X0 := T0
    with Definition X1 := T1
    with Definition Xadd := Tadd
    with Definition Xopp := Topp
    with Definition Xmul := Tmul
    with Definition Xinv := Tinv
    with Definition Xeqb := Teqb.

    Axiom Teqb_true_iff : forall x y : T, (x =? y)%T = true <-> x = y.
    Axiom Teqb_false_iff : forall x y : T, (x =? y)%T = false <-> x <> y.

    Definition X := T.
    Definition X0 := T0.
    Definition X1 := T1.
    Definition Xadd := Tadd.
    Definition Xopp := Topp.
    Definition Xmul := Tmul.
    Definition Xinv := Tinv.
    Definition Xeqb := Teqb.
    Definition Xeqdec := Teqdec.
    Definition Xeqb_true_iff := Teqb_true_iff.
    Definition Xeqb_false_iff := Teqb_false_iff.

    Lemma X1_neq_X0 : X1 <> X0.
    Proof. intro. easy. Qed.

    Lemma Ring_thy : ring_theory X0 X1 Xadd Xmul Tsub Xopp eq.
    Proof. constructor; intros; cbv; ring. Qed.
    Add Ring Ring_thy_inst : Ring_thy.

    Lemma Field_thy : field_theory X0 X1 Xadd Xmul Tsub Xopp Tdiv Xinv eq.
    Proof.
      constructor; try easy. apply Ring_thy.
      intros; cbv; field; auto.
    Qed.
    Add Field Field_thy_inst : Field_thy.

  End FieldDefT.

  Module Export FieldThyT := FieldThy FieldDefT.

End FieldT.

(** Test *)
Section test.

  Import FieldT.
(*   Open Scope X_scope. *)

  Goal forall a b c : X, (c<>0) -> (a + b) / c = a / c + b / c.
  Proof. intros. field. auto. Qed.

End test.


Require Import Definitions.

(** ** PCP reduces to BPCP *)

(* natural numbers n to bitstrings of the form 1^n *)

Definition to_bitstring (n : nat) : string bool := Nat.iter n (cons true) [].

Lemma bitstring_false a : ~ false el to_bitstring a.
Proof.
  induction a; cbn; firstorder.
Qed.

(* strings of natural numbers to bitstrings, [ n1, ... n2 ] |-> 1^n1 0 ... 1^n2 0 *)
Fixpoint f_s (x : string nat) : string bool :=
  match x with
  | nil => nil
  | a :: x => to_bitstring a ++ [false] ++ f_s x
  end.

Lemma f_s_app x y : f_s (x ++ y) = f_s x ++ f_s y.
Proof.
  induction x; cbn.
  - reflexivity.
  - rewrite IHx. now simpl_list.
Qed.

(* extension to cards and stacks *)
Definition f_c '(x,y) := (f_s x, f_s y).
Definition f (P : SRS) : BSRS :=
  map f_c P.

Lemma tau1_f A : tau1 (f A) = f_s (tau1 A).
Proof.
  induction A as [ | (x,y) ]; cbn.
  - reflexivity.
  - unfold f in IHA. now rewrite IHA, f_s_app.
Qed.

Lemma tau2_f A : tau2 (f A) = f_s (tau2 A).
Proof.
  induction A as [ | (x,y) ]; cbn.
  - reflexivity.
  - unfold f in IHA. now rewrite IHA, f_s_app.
Qed.

(* interpretation of a bitstring as list of natural numbers *)
Fixpoint g_s' (x : string bool) (n : nat) : string nat :=
  match x with
  | nil => nil
  | true :: x' => g_s' x' (S n)
  | false :: x' => n :: g_s' x' 0
  end.

Lemma g_s'_app n x y :
  g_s' (f_s x ++ y) n = match x with nil => g_s' y n | m :: x => n + m :: x ++ g_s' y 0 end.
Proof.
  revert n y. induction x as [ | m]; intros; cbn in *.
  - reflexivity.
  - revert n; induction m; intros; cbn in *.
    + destruct x.
      * do 2 f_equal. omega.
      * rewrite IHx. f_equal. omega.
    + rewrite IHm. f_equal. omega.
Qed.

Definition g_s x := g_s' x 0.

Lemma f_g_s'_inv x : g_s (f_s x) = x.
Proof.
  unfold g_s. setoid_rewrite <- app_nil_r at 2. rewrite g_s'_app.
  destruct x; now simpl_list.
Qed.

(* extension to cards and stacks *)
Definition g_c '(x,y) := (g_s x, g_s y).
Definition g (P : BSRS) : SRS :=
  map g_c P.

(* Invariants *)

Lemma tau1_g A B : A <<= f B -> tau1 (g A) = g_s (tau1 A).
Proof.
  induction A as [ | (x,y)]; cbn.
  - reflexivity.
  - unfold g in IHA. intros. rewrite !IHA.
    assert ( x /y el map f_c B) as ((x',y') & ? & ?) % in_map_iff by firstorder; inv H0.
    rewrite g_s'_app. destruct x'.
    + cbn. reflexivity.
    + rewrite f_g_s'_inv. cbn. reflexivity.
    + firstorder.
Qed.

Lemma tau2_g A B : A <<= f B -> tau2 (g A) = g_s (tau2 A).
Proof.
  induction A as [ | (x,y)]; cbn.
  - reflexivity.
  - unfold g in IHA. intros. rewrite !IHA.
    assert ( x /y el map f_c B) as ((x',y') & ? & ?) % in_map_iff by firstorder; inv H0.
    rewrite g_s'_app. destruct y'.
    + cbn. reflexivity.
    + rewrite f_g_s'_inv. cbn. reflexivity.
    + firstorder.
Qed.

Lemma f_subset B A : A <<= B -> f A <<= f B.
Proof.
  induction A in B |- *; intros H; cbn.
  * firstorder.
  * intros ? [| H0]; subst.
    -- unfold f. eapply in_map_iff. eauto.
    -- eapply IHA in H0; eauto.
Qed.

Lemma f_g_subset B A : A <<= f B -> g A <<= B.
Proof.
  revert B; induction A; intros B H; cbn.
  * firstorder.
  * assert (a el f B) by firstorder.
    unfold f in H0. eapply in_map_iff in H0 as ((x,y) & ? & ?). inv H0.
    intros ? [|]; subst. cbn. now rewrite !f_g_s'_inv. firstorder.
Qed.

Lemma PCP_BPCP : PCP ⪯  BPCP.
Proof.
  exists f. intros B. split.
  - intros (A & HP & He & H). exists (f A). repeat split.
    + now eapply f_subset.
    + destruct A; cbn; congruence.
    + unfold f, f_c, f_s. setoid_rewrite tau1_f. setoid_rewrite tau2_f. now rewrite H.
  - intros (A & HP & He & H). exists (g A). repeat split.
    + eapply f_g_subset; eauto.
    + destruct A; cbn; congruence.
    + erewrite tau1_g, tau2_g, H; eauto.
Qed.


From iris.program_logic Require Export hoare.
From iris.heap_lang Require Import proofmode.
From iris_examples.barrier Require Export barrier.
From iris_examples.barrier Require Import proof.
Set Default Proof Using "Type".
Import uPred.

Section spec.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !barrierG Σ}.

Lemma barrier_spec (N : namespace) :
  ∃ recv send : loc → iPropO Σ -n> iPropO Σ,
    (∀ P, {{ True }} newbarrier #()
                     {{ v, ∃ l : loc, ⌜v = #l⌝ ∗ recv l P ∗ send l P }}) ∧
    (∀ l P, {{ send l P ∗ P }} signal #l {{ _, True }}) ∧
    (∀ l P, {{ recv l P }} wait #l {{ _, P }}) ∧
    (∀ l P Q, recv l (P ∗ Q) ={↑N}=> recv l P ∗ recv l Q) ∧
    (∀ l P Q, (P -∗ Q) -∗ recv l P -∗ recv l Q).
Proof.
  exists (λ l, OfeMor (recv N l)), (λ l, OfeMor (send N l)).
  split_and?; simpl.
  - iIntros (P) "!# _". iApply (newbarrier_spec _ P with "[]"); [done..|].
    iNext. eauto.
  - iIntros (l P) "!# [Hl HP]". iApply (signal_spec with "[$Hl $HP]"). by eauto.
  - iIntros (l P) "!# Hl". iApply (wait_spec with "Hl"). eauto.
  - iIntros (l P Q) "!#". by iApply recv_split.
  - apply recv_weaken.
Qed.
End spec.


Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.

Definition Opposite `(C : Category) : Category := {|
  obj     := @obj C;
  hom     := fun x y => @hom C y x;
  homset  := fun x y => @homset C y x;
  id      := @id C;
  compose := fun _ _ _ f g => g ∘ f;

  compose_respects := fun x y z f g fg h i hi =>
    @compose_respects C z y x h i hi f g fg;

  id_left  := fun x y f => @id_right C y x f;
  id_right := fun x y f => @id_left C y x f;

  comp_assoc := fun x y z w f g h => @comp_assoc_sym C w z y x h g f;
  comp_assoc_sym := fun x y z w f g h => @comp_assoc C w z y x h g f
|}.

Notation "C ^op" := (@Opposite C)
  (at level 7, format "C ^op", left associativity) : category_scope.

Lemma op_invol {C : Category} : (C^op)^op = C.
Proof.
  unfold Opposite; simpl.
  destruct C; simpl.
  f_equal.
Qed.

Definition op   {C : Category} {x y} (f : y ~{C}~> x) : x ~{C^op}~> y := f.
Definition unop {C : Category} {x y} (f : x ~{C^op}~> y) : y ~{C}~> x := f.

(* If two objects are isomorphic in C, then they are also isomorphic in C^op,
   just the conversion arrows are flipped. *)

Require Import Category.Theory.Isomorphism.

#[export]
Program Instance Isomorphism_Opposite {C : Category} {x y : C}
       (iso : @Isomorphism C x y) :
  @Isomorphism (C^op) x y := {
  to := from iso;
  from := to iso;
  iso_to_from := iso_to_from iso;
  iso_from_to := iso_from_to iso
}.


Module Boolean.

Inductive bool :=
  | true
  | false.

(*** Bool Functions ***)
Definition negate : bool -> bool :=
  fun (b:bool) =>
  match b with
     true => false
   | false => true
end.

Definition and (b b' : bool) : bool :=
  match b with
  | true => b'
  | false => false
end.

Definition or (b b' : bool) : bool :=
  match b with
  | false => b'
  | true => true
end.

Definition nand (b b' : bool) : bool :=
  match b with
  | false => true
  | true => match b' with
            | false => true
            | true => false
            end
end.

Definition nor (b b' : bool) : bool :=
  match b with
  | true => false
  | false => match b' with
             | true => false
             | false => true
             end
end.

(*** Bool Notation ***)
Notation "x && y" := (and x y).
Notation "x || y" := (or x y).

(*** Bool Proofs ***)

(* && Proofs *)
Example test_and_tt : true && true = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_and_tf : true && false = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_and_ft : false && true = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_and_ff : false && false = false.
Proof.
  simpl.
  reflexivity.
Qed.

(* || Proofs *)
Example test_or_tt : true || true = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_or_tf : true || false = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_or_ft : false || true = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_or_ff : false || false = false.
Proof.
  simpl.
  reflexivity.
Qed.

(* NAND Proofs *)
Example test_nand_tt : (nand true true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nand_tf : (nand true false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nand_ft : (nand false true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nand_ff : (nand false false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

(* NOR Proofs *)
Example test_nor_tt : (nor true true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nor_tf : (nor true false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nor_ft : (nor false true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nor_ff : (nor false false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

End Boolean.

Inductive byte :=
  Byte(b7 b6 b5 b4 b3 b2 b1 b0 : bool).

Definition negate_byte : byte -> byte :=
  fun (b : byte) =>
  match b with
    Byte b7 b6 b5 b4 b3 b2 b1 b0 =>
    Byte (negate b7) (negate b6) (negate b5) (negate b4)
         (negate b3) (negate b2) (negate b1) (negate b0)
end.

Compute negate_byte (Byte true true true true false false false false).

Inductive string :=
  | EmptyString
  | NonEmptyString (head : byte) (tail : string).

Definition h : byte := Byte false true true false true false false false.
Definition i : byte := Byte false true true false true false false true.

Definition concat : string -> (string -> string) :=
  (* Must add a fixpoint operator to recursively call concat/f *)
  fix f(s1 : string) {struct s1}: string -> string :=
  fun (s2 : string) =>
  match s1 with
    EmptyString => s2
  | NonEmptyString b s => NonEmptyString b ((f s) s2)
end.

Inductive list (A : Type) :=
    nil
  | cons (head : A) (tail : list A).

Definition hi_as_a_list : list byte :=
  cons byte h (cons byte i (nil byte)).

(*Fixpoint append (A : Type) (ls1 ls2 : list A) {struct ls1} : list A :=*)

Definition append (A : Type) : list A -> list A -> list A :=
fix f (ls1: list A) {struct ls1} : list A -> list A :=
fun (ls2: list A) =>
  match ls1 with
    nil _ => ls2
  | cons _ h t => cons A h ((f t) ls2)
end.

Definition hi : string := NonEmptyString (h : byte) (NonEmptyString (i : byte) (EmptyString)).

Compute concat (NonEmptyString h EmptyString) (NonEmptyString i EmptyString).


Require Export prosa.util.bigcat.

Require Import prosa.classic.util.tactics prosa.classic.util.notation prosa.classic.util.bigord.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Lemmas about the big concatenation operator. *)
Section BigCatLemmas.

  Lemma mem_bigcat_ord:
    forall (T: eqType) x n (j: 'I_n) (f: 'I_n -> list T),
      j < n ->
      x \in (f j) ->
      x \in \cat_(i < n) (f i).
  Proof.
    intros T x n j f LE IN; rewrite (big_mkord_ord nil).
    rewrite -(big_mkord (fun x => true)).
    apply mem_bigcat_nat with (j := j);
      [by apply/andP; split | by rewrite eq_fun_ord_to_nat].
  Qed.

  Lemma mem_bigcat_ord_exists :
    forall (T: eqType) x n (f: 'I_n -> list T),
      x \in \cat_(i < n) (f i) ->
      exists i, x \in (f i).
  Proof.
    intros T x n f IN.
    induction n; first by rewrite big_ord0 in_nil in IN.
    {
      rewrite big_ord_recr /= mem_cat in IN.
      move: IN => /orP [HEAD | TAIL].
      {
        apply IHn in HEAD; destruct HEAD as [x0 IN].
        by eexists (widen_ord _ x0); apply IN.
      }
      {
        by exists ord_max; desf.
      }
    }
  Qed.

  Lemma bigcat_ord_uniq :
    forall (T: eqType) n (f: 'I_n -> list T),
      (forall i, uniq (f i)) ->
      (forall x i1 i2,
         x \in (f i1) -> x \in (f i2) -> i1 = i2) ->
      uniq (\cat_(i < n) (f i)).
  Proof.
    intros T n f SINGLE UNIQ.
    induction n; first by rewrite big_ord0.
    {
      rewrite big_ord_recr cat_uniq; apply/andP; split.
      {
        apply IHn; first by done.
        intros x i1 i2 IN1 IN2.
        exploit (UNIQ x);
          [by apply IN1 | by apply IN2 | intro EQ; inversion EQ].
        by apply ord_inj.
      }
      apply /andP; split; last by apply SINGLE.
      {
        rewrite -all_predC; apply/allP; intros x INx.

        simpl; apply/negP; unfold not; intro BUG.
        rewrite -big_ord_narrow in BUG.
        rewrite big_mkcond /= in BUG.
        have EX := mem_bigcat_ord_exists T x n.+1 _.
        apply EX in BUG; clear EX; desf.
        apply UNIQ with (i1 := ord_max) in BUG; last by done.
        by desf; unfold ord_max in *; rewrite /= ltnn in Heq.
      }
    }
  Qed.

  Lemma map_bigcat_ord {T} {T'} n (f: 'I_n -> seq T) (g: T -> T') :
    map g (\cat_(i < n) (f i)) = \cat_(i < n) (map g (f i)).
  Proof.
    destruct n; first by rewrite 2!big_ord0.
    induction n; first by rewrite 2!big_ord_recr 2!big_ord0.
    rewrite big_ord_recr [\cat_(cpu < n.+2)_]big_ord_recr /=.
    by rewrite map_cat; f_equal; apply IHn.
  Qed.

  Lemma size_bigcat_ord {T} n (f: 'I_n -> seq T) :
    size (\cat_(i < n) (f i)) = \sum_(i < n) (size (f i)).
  Proof.
    destruct n; first by rewrite 2!big_ord0.
    induction n; first by rewrite 2!big_ord_recr 2!big_ord0 /= add0n.
    rewrite big_ord_recr [\sum_(i0 < n.+2)_]big_ord_recr size_cat /=.
    by f_equal; apply IHn.
  Qed.

  Lemma size_bigcat_ord_max {T} n (f: 'I_n -> seq T) m :
    (forall x, size (f x) <= m) ->
    size (\cat_(i < n) (f i)) <= m*n.
  Proof.
    intros SIZE.
    rewrite size_bigcat_ord.
    apply leq_trans with (n := \sum_(i0 < n) m);
      last by rewrite big_const_ord iter_addn addn0.
    by apply leq_sum; ins; apply SIZE.
  Qed.

End BigCatLemmas.


Require Export D.

Theorem distr_rev : forall l1 l2 : natlist,
  rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros. induction l1.
  induction l2. reflexivity.
  simpl.
  Lemma any_app_nul : forall l:natlist,
    l = l ++ [].
  Proof. intros. induction l. reflexivity. simpl. rewrite <- IHl. reflexivity. Qed.
  rewrite <- any_app_nul. reflexivity.
  simpl. rewrite -> IHl1. simpl.
  Lemma snoc_app_input : forall n:nat, forall l1 l2:natlist,
    snoc (l1 ++ l2) n = l1 ++ snoc l2 n.
  Proof.
    intros. induction l1. reflexivity.
    simpl. rewrite -> IHl1. reflexivity. Qed.
    rewrite -> snoc_app_input. reflexivity.

Qed.


(* Each ? must be replaced by 1 tactic, hypotheis or reserved character *)
Variable term:Type.
Variable P : term -> term -> Prop.
Hypothesis Hqd : forall a b : term, P a b <-> (exists c : term, (P a c \/ P c a) /\ (P c b \/ P b c)).
Hypothesis Hrd : forall a : term, P a a.
Variable d0 : term.
(*ex1*)
Lemma QAL1 : forall a b : term, P a b <-> P b a.
Proof.
intros.
split.
intros.
apply Hqd.
exists a.
split.
- right. apply H.
- left. apply Hrd.
- intros.
apply Hqd.
exists a.
split.
left. apply Hrd.
right. apply H.
Qed.
Print QAL1.
(*ex2*)
Theorem QAL2: forall a b c : term, exists d : term, (P a d /\ P b d /\ P c d) -> (P a b /\ P b c /\ P a c).
Proof.
intros.
exists d0.
intros.
(* In the following line of code each ? must be replaced by 1 character or one hypothesis *)
destruct H as [ d [ l e ] ].
split.
- apply Hqd. exists d0. split. left. exact d. right. exact l.
- split. apply Hqd. exists d0. split. left. exact l. right. exact e.
apply Hqd.
exists d0.
split.
left.
apply d.
right.
apply e.
Qed.
Print QAL2.


Theorem abcd_c : forall (A:Type) (a b c d:A),
    a = c \/ b = c \/ c = c \/ d = c.
Proof.
 intros A a b c d; right; right; left; reflexivity.
Qed.


Require Import XR_Rminus_Int_part1.
Require Import XR_Rplus_eq_compat_l.
Require Import XR_Rplus_eq_compat_r.

Local Open Scope R_scope.

Lemma Rminus_fp1 :
  forall r1 r2:R,
    frac_part r2 <= frac_part r1 ->
    frac_part (r1 - r2) = frac_part r1 - frac_part r2.
Proof.
  intros x y.
  unfold frac_part.
  intro h.
  assert (ip:=Rminus_Int_part1).
  specialize (ip x y).
  unfold frac_part in ip.
  specialize (ip h).
  rewrite ip.
  unfold Rminus.
  repeat rewrite Rplus_assoc.
  apply Rplus_eq_compat_l.
  rewrite minus_IZR.
  unfold Rminus.
  repeat rewrite Ropp_plus_distr.
  repeat rewrite Ropp_involutive.
  repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  rewrite Rplus_comm.
  reflexivity.
Qed.