From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

(** (If you encounter warning messages when importing these files, don't worry:
    they are probably harmless. Ssreflect redefines some of the basic Coq
    definitions, which sometimes causes Coq to print warnings.)

    The next commands turn on options that make programming in Coq a bit easier;
    it is usually a good idea to include those at the beginning of your
    files. The first two allow us to omit arguments that can be automatically
    inferred by Coq (usually, type parameters for polymorphic functions); the
    last one instructs Coq's printer to omit these arguments when printing
    terms. If this sounds a bit mysterious to you, don't worry -- you don't need
    to understand what they do right now. We will come back to them later. *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Defining a Data Type

    In this chapter, we introduce the most basic features of Coq with a simple
    case study: using _binary search trees_ to represent sets of numbers.
    First, we define a Coq data type of binary search trees: *)

Inductive tree : Type :=
| Leaf
| Node of tree & nat & tree.

(** This command declares a new type [tree] with two kinds of values: a value
    can be either [Leaf], which represents an empty tree, or of the form [Node
    t1 n t2], which represents a nonempty tree that stores a natural number [n]
    at its root and has two subtrees, [t1] and [t2].

    If you are familiar with functional programming languages, such as Haskell,
    OCaml, or Scala, it might help to know that the [Inductive] command is very
    similar to how we define data types in those languages.  In any case, it is
    worth analyzing this definition in some more detail.  In Coq, we call [Leaf]
    and [Node] the _constructors_ of the [tree] type.  A type declaration such
    as the one above can have as many constructors as we want, each listed after
    a vertical bar ([|]).  We see that there are two kinds of constructors:
    those that take arguments and those that don't.  The [Leaf] constructor does
    not take any arguments; we can use it directly to create a [tree] value.
    For instance: *)

Definition empty_tree : tree :=
  Leaf.

(** This command declares a new constant [empty_tree] of type [tree] that is
    defined as [Leaf].  (Note that Coq commands usually begin with an uppercase
    letter and are terminated by a period ([.]).)

    If we want to define a nonempty tree, we must apply the [Node] constructor
    to some arguments: *)

Definition nonempty_tree : tree :=
  Node Leaf 0 Leaf.

(** When Coq sees a list of expressions separated by white space, it understands
    that the first one is a function, and that the others are arguments to that
    function.  Note that the second argument, [0], is a value of the predefined
    [nat] representing natural numbers (non-negative integers). Thus, this
    definition represents a nonempty tree that stores [0] at its root and has
    empty children.

    Coq is a _typed_ language, and it always checks expressions to ensure that
    everything make sense.  For instance, the definition of [tree] says the
    second argument of [Node] must be an element of [nat].  When Coq sees
    anything that does not match what it expects, it complains: *)

Fail Definition nonempty_tree_wrong : tree :=
  Node Leaf Leaf Leaf.

(** (The [Fail] keyword allows us to enter commands that cause errors; Coq
    simply ignores them.)

    We can also combine previous definitions to write new ones: *)

Definition nonempty_tree' : tree :=
  Node nonempty_tree 0 empty_tree.

(** * Functions

    Like in other programming languages, we can define functions in Coq.  The
    following function checks whether a tree is empty. *)

Definition is_empty (t : tree) : bool :=
  match t with
  | Leaf         => true
  | Node t1 n t2 => false
  end.

(** This code says that [is_empty] takes one argument [t] of type [tree] and
    returns a Boolean. (The type [bool] of Booleans is already defined for us in
    Coq.) The body of the function analyzes the possible shapes that [t] can
    have using the [match] expression. Each clause after a [|] sign is called a
    _branch_, and describes the value of the expression when [t] has the
    corresponding shape; [t] is known as the _scrutinee_. Paraphrasing this
    definition, if [t] is a [Leaf], the function returns [true]; otherwise, if
    it is a [Node], it returns [false].  In Coq, every function that we write
    must be _total_; that is, defined for all inputs.  This means that the
    branches of a [match] must cover every possible shape that [t] may have.
    Since [tree] was defined with two constructors, these two branches already
    cover all cases.  Had we omitted one of them, Coq would complain. *)

Fail Definition is_empty_wrong (t : tree) : bool :=
  match t with
  | Leaf => true
  end.

(** Note that in the [Node] branch of [is_empty] we were able to give names to
    the of the constructor.  These names can be used in the return value, as in
    the next function, which returns the left child of a nonempty tree, or
    [Leaf] if the tree is empty: *)

Definition left_child (t : tree) : tree :=
  match t with
  | Leaf       => Leaf
  | Node t _ _ => t
  end.

(** As this example shows, when an argument to a function or to a [match] branch
    is not used, we can name it [_] instead. *)

(** ** Exercise

    Based on [left_child], write a [right_child] that extracts the right child
    of a tree. *)

(** We can test the behavior of Coq functions using the [Compute] command.  It
    simply takes a Coq expression as input and prints the result of fully
    evaluating it. *)

Compute is_empty empty_tree.
Compute is_empty nonempty_tree.
Compute left_child nonempty_tree.
Compute left_child nonempty_tree'.

(** We can also write functions of multiple arguments, and analyze multiple
    scrutinees in a single [match]: *)

Definition are_both_empty (t1 : tree) (t2 : tree) : bool :=
  match t1, t2 with
  | Leaf, Leaf => true
  | _   , _    => false
  end.

(** This last example shows that a branch can cover multiple constructors. When
    we give [_] instead of a constructor name, Coq understands that that branch
    corresponds to any cases that are not covered by the previous ones; here,
    those would be the ones where at least one of the trees is a [Node].  We can
    check that this function has the expected behavior: *)

Compute are_both_empty Leaf Leaf.
Compute are_both_empty Leaf nonempty_tree.

(** As a shorthand, when consecutive arguments of a function have the same type,
    we can group them together, like this: *)

Definition are_both_empty' (t1 t2 : tree) : bool :=
  match t1, t2 with
  | Leaf, Leaf => true
  | _   , _    => false
  end.

(** We saw earlier that Coq is a typed language, and that it rejects definitions
    that do not follow its typing rules.  Functions, like anything else, also
    have types.  We can query their types with the [Check] command, like this: *)

Check is_empty.
Check are_both_empty.

(** (It is usually preferable to avoid including [Check] commands in Coq files,
    since they only make sense interactively; we add them here for explanation
    purposes. You can avoid writing [Check] when using Coq interactively by
    issuing the appropriate command in your Coq environment. In Proof General,
    for instance, you can hit [C-c C-a C-c].)

    Types to the left of an arrow ([->]) specify the types of the arguments that
    a function expects; the right-most type is the return type.  The type of
    [is_empty], [tree -> bool], shows that that function expects one argument of
    type [tree] and produces a result of type [bool].  The type of
    [are_both_empty], [tree -> tree -> bool], shows that that function expects
    two arguments of type [tree] and produces a result of type [bool].

    Note that data-type constructors that take arguments are just another
    instance of functions, and are treated as such by Coq.  For instance, the
    type of [Node] is [tree -> nat -> tree -> tree], reflecting the arguments it
    takes and the result it produces; try checking it yourself!

    * Preexisting Definitions

    Before moving on to more interesting definitions, it is worth spending some
    time overviewing basic ones that are already provided by Coq.  Besides types
    such as [nat] and [bool], there are also many predefined functions on those
    types.  The [addn] function, as its name says, adds two natural numbers: *)

Check addn.
Compute addn 3 4.

(** Coq provides convenient infix syntax for such operators; the expression [n +
    m] is just a shorthand for [addn n m].  It is also possible to define our
    own custom notations in Coq, although we will defer this discussion for
    later. *)

Check 3 + 4.
Compute 3 + 4.

(** Other operations include subtraction ([subn]), and multiplication ([muln]),
    each with its own infix notation.  Note that subtraction on natural numbers
    is _truncated_: [n - m] equals [0] whenever [m] is greater than [n]. *)

Compute 4 - 3.
Compute 3 - 4.
Compute 3 * 4.

(** The [leq] function tests if its first argument is smaller than or equal to
    its second argument; the corresponding infix notation is [<=].  To test
    numbers for equality, we use [eq_op] (infix [==]). *)

Compute 3 <= 4.
Compute 4 <= 3.
Compute 4 == 4.
Compute 3 == 4.

(** If we ask Coq for the types of these operators, the answers we get are
    mostly unsurprising.  For instance, [addn] has type [nat -> nat -> nat]. *)

Check addn.

(** The exception to the rule is [eq_op]: Coq tells us that it has type [rel
    ?T], where [?T : eqType].  Although puzzling, this simply means that [eq_op]
    is a _polymorphic_ operator that can be used with any type that is provided
    with an equality test.  Basic types such as [nat] or [bool] already have
    predefined equality tests, so we don't have to worry about this; later, we
    will discuss how polymorphism works in Coq and how to define equality
    operators for our own types.

    For Booleans, besides equality testing, we also have the basic logic
    operations: [andb] ([&&]), [orb] ([||]), and [negb] ([~~], prefix).  As
    expected, we can combine these operations to express complex conditions. *)

Compute (3 <= 4) && ~~ (4 == 5).
Compute false || (3 + 4 <= 8).

(** We can abbreviate [~~ (a == b)] as [a != b]: *)

Compute (3 <= 4) && (4 != 5).

(** As in other functional programming languages, we can make our definition
    more generic, by allowing our trees to store elements of any type [T] that
    we want: *)

Inductive tree (T : Type) : Type :=
| Leaf
| Node of color & tree T & T & tree T.

(** Now, when we check the types of [Leaf] and [Node], we see that they are
    prefixed with a [forall], which allows us to choose what type the contents
    of our tree should have. *)

Check Leaf.
Check Node.

(** One thing that makes Coq different from other functional languages is that
    polymorphism is _explicit_: each use of a polymorphic value must be
    annotated with the type we want to instantiate it with, as if it were the
    argument to a function. For instance, this is how we use [Leaf] to construct
    an empty [tree] of [nat] elements: *)

Check Leaf nat.

(** Providing these annotations can be cumbersome, so Coq provides a
    shorthand. We can specify that the value of [T] should be inferred every
    time [Leaf] is used. This feature is known as _implicit arguments_. *)

Arguments Leaf {T}.

(** The curly braces around [T] in the above command declare that type as being
    implicit. In some cases, type parameters can be deduced from the type of the
    arguments of a term. For instance, the third argument of the [Node]
    constructor has exactly the type that is used as a parameter to
    [Node]. Hence, if we know the type of that argument, we know what [T] should
    be. The [Set Implicit Arguments] directive we used earlier instructs Coq to
    always declare such arguments as implicit. This allows us to write
    expressions such as the following: *)

Check Node Red Leaf 0 Leaf.
Check Node Black (Node Red Leaf 0 Leaf) 1 Leaf.

(** We can also turn off implicit arguments temporarily by prefixing an
    identifier with [@]. This is useful in situations where Coq doesn't have
    enough information to determine what the value of some type parameter should
    be. *)

Check @Node nat Red Leaf 0 (@Leaf nat).

(** Before we move on, a small comment: the [of] and [&] symbols are part of
    ssreflect. Here is what the previous declaration would look like in usual
    Coq syntax: *)

Inductive tree' (T : Type) : Type :=
| Leaf' : tree' T
| Node' : color -> tree' T -> T -> tree' T -> tree' T.

(** We have replaced the type and constructor names above to avoid clashes, but
    the two declarations are otherwise equivalent.

    * Definitions

    We can give names to values and functions with the [Definition] command. For
    instance: *)

Definition singleton (T : Type) (x : T) : tree T :=
  Node Red Leaf x Leaf.

(** The above declaration defines a function [singleton] that takes one
    argument, an element [x] of some type [T], which can be chosen
    arbitrarily. Its result is a [tree T] consisting of one internal node
    colored [Red] that contains [x]. We can see that this is reflected in the
    type of [singleton]: *)

Check singleton.

(** The syntax for applying functions is the same as for data constructors: *)

Check singleton 0.

(** Note that the above definition has type annotations in them. We can usually
    omit some or all of them, since Coq can infer them most of the time. Here,
    for instance, we don't annotate the result type of [three_times], and omit
    the type of [T]: *)

Definition three_times T (x : T) :=
  Node Black (singleton x) x (singleton x).

(** Nevertheless, it is often a good idea to include type annotations, since
    they can improve readability and serve as good documentation.

    We can use the [Compute] command to evaluate an expression: *)

Compute three_times 0.

(** We define recursive functions using the [Fixpoint] command. For instance,
    here is a function [tsize] that computes the number of elements stored in a
    tree: *)

Fixpoint tsize T (t : tree T) : nat :=
  match t with
  | Leaf => 0
  | Node _ t1 _ t2 => tsize t1 + 1 + tsize t2
  end.

(** Notice that this definition uses the addition operation on natural numbers,
    [+]. The [ssrnat] library of ssreflect comes with many other predefined
    functions on [nat], including multiplication, subtraction, etc. The [nat]
    type is used extensively in Coq developments, and we will encounter it
    often.

    Here is another recursive function: one for mirroring a tree. *)

Fixpoint tmirror T (t : tree T) : tree T :=
  match t with
  | Leaf => Leaf
  | Node c t1 x t2 => Node c (tmirror t2) x (tmirror t1)
  end.

(** * Proof by simplification

    After writing simple programs in Coq's functional language, let's turn our
    attention to stating and proving properties about these programs. For
    example, we might want to claim that [singleton x] has size [1] for all
    possible values of [x]. In Coq, this is done with the [Lemma] command: *)

Lemma tsize1 T (x : T) : tsize (singleton x) = 1.

(** By issuing this commmand, we declare that we want to prove a lemma called
    [tsize1], whose statement is a direct translation of the above claim. This
    causes Coq to enter _proof mode_, where it expects us to provide a proof for
    that statement. We can now see a new window which displays the current state
    of our proof. This window is split by a horizontal line. Below that line is
    the _goal_, which says what else remains to be proved; above that line is a
    list of local variables and hypotheses. Proofs are written with special
    commands called _tactics_. Each tactic transforms the goal a little bit,
    applying inference steps that (hopefully) bring us towards a state where our
    claim becomes obvious enough to be accepted by Coq. Coq checks each argument
    that we try to enter according to the rules of its logic, rejecting any
    invalid proofs. This ensures that, whenever a proof is accepted by Coq, we
    can have a high degree of confidence that it is correct.

    We start proofs with the [Proof] command: *)

Proof.

(** Our first tactic is [rewrite /=], which attempts to simplify the current
    goal according to the computation rules of Coq's logic. *)

rewrite /=.

(** We can see that [rewrite /=] replaced [tsize (singleton x) = 1] by [0 + 1 +
    0 = 1]. At this point, the statement is obvious enough that Coq can accept
    that it is true without further help. We can complete the proof with the
    [done] tactic: *)

done.

(** Coq now tells us that there are no more subgoals, which means that our proof
    is complete. The [Qed.] command causes Coq to exit proof mode once the proof
    is complete. *)

Qed.

(** We can now refer to the theorem we just proved by its name. The [forall]
    annotation given in the statement of the checked lemma means (as you may
    guess) that [x] is universally quantified and may be instantiated
    arbitrarily. *)

Check tsize1.

(** To better understand how simplification is performed, we can write a
    step-by-step version of the previous proof, showing intermediate
    simplification steps that are omitted by Coq. *)

Lemma tsize1' T (x : T) : tsize (singleton x) = 1.
Proof.

(** Writing [rewrite -[x]/(y)] instructs Coq to replace all occurrences of [x]
    by [y] in the current goal, provided that both expressions are equivalent
    according to the computation rules of Coq's logic. In the line below, Coq
    understands that both terms are equal because the second is exactly what we
    gave for the definition of [singleton]. *)

rewrite -[singleton x]/(Node Red Leaf x Leaf).

(** Here, we can see that [rewrite] is a more general tactic that takes many
    possible actions as arguments, which have slightly different effects.

    We can perform a similar exercise for [tsize], and replace the call to it by
    its definition. *)

rewrite -[tsize _]/(match Node Red Leaf x Leaf with
                    | Leaf => 0
                    | Node _ t1 _ t2 => tsize t1 + 1 + tsize t2
                    end).

(** Notice that we didn't specify the argument that was given to [tsize], and
    just said [_] instead. Coq can often understand these incomplete patterns
    from the context where they are used.

    Simplifying the [match] expression is easy: since Coq knows the first
    constructor used in the discriminee, it knows which branch to take. Here, we
    use the [LHS] (short for _left-hand side_) pattern instead of writing the
    entire term. *)

rewrite -[LHS]/(tsize Leaf + 1 + tsize Leaf).

(** Similar simplification steps show that [tsize Leaf] evaluates to [0]. *)

rewrite -[tsize Leaf]/(0).

(** At this point, we can conclude. *)

done.
Qed.

(** Calling [done] after a tactic is so common that ssreflect offers special
    syntax for it: if [t] is a tactic, then [by t] tries to execute [t] and to
    conclude the proof afterwards by calling [done]. If the proof cannot be
    complete, Coq raises an error. *)

Lemma tsize1'' T (x : T) : tsize (singleton x) = 1.
Proof. by rewrite /=. Qed.

(** As a matter of fact, the above proof is so simple that we don't even need to
    tell Coq to simplify the goal; [done] alone suffices. Alternatively, we can
    also write [by []] (that is, [by] with an "empty" first tactic) as a synonym
    for [done]: *)

Lemma tsize1''' T (x : T) : tsize (singleton x) = 1.
Proof. done. Qed.

Lemma tsize1'''' T (x : T) : tsize (singleton x) = 1.
Proof. by []. Qed.

(** Before we move on to more interesting proofs, it is worth leaving a small
    note on naming conventions: ssreflect tries to follow very consistent naming
    conventions for its lemmas, which we will try to emulate here. The [1]
    suffix on [tsize1], for instance, signals that this lemma relates [tsize] to
    something of size [1]; in this case, a singleton tree. We will point to
    other naming conventions as we progress.

    * Using sections

    Coq provides another mechanism for alleviating the burden of annotations:
    _sections_. Sections allow us to declare certain parameters as being common
    to all definitions and lemmas enclosed within it. Inside the section, these
    parameters don't have to be redeclared and applied; when the section is
    closed, on the other hand, all parameters become explicit.

    Sections are opened with the [Section] keyword. Each section must be given a
    name (in this case, [Ex]). *)

Section Ex.

(** Once we are inside a section, we can use the [Variable] command to declare a
    parameter that will be shared by all definitions in the section. *)

Variable T : Type.

(** We can also associate variable names to certain types. After the following
    command, Coq assumes that [x] has type [T], unless otherwise specified. This
    has the same effect for variables with "similar" names, such as [x0] and
    [x']. *)

Implicit Type x : T.

(** We can now write statements such as this one: *)

Lemma tsize1''''' x : tsize (singleton x) = 1.
Proof. by []. Qed.

(** Notice that [x] had to be declared in the statement of the lemma, but that
    we didn't have to supply its type. [T], on the other hand, didn't have to be
    declared again.

    If we check the lemma we just proved, we see that [T] is "fixed" (that is,
    not universally quantified): *)

Check tsize1'''''.

(** Once we close the [Ex] section, we see that [T] becomes explicitly
    quantified: *)

End Ex.

Check tsize1'''''.

(** We will enclose some of the remaining material in a section with some
    variable declarations and implicit types, to make our lives easier. *)

Section Basic.

Variable T : Type.

Implicit Type (t : tree T) (x : T) (c : color).

(** * Proof by case analysis

    Often, simplification is not enough to complete a proof. For instance,
    suppose that we have the following function [tcolor] which computes the
    color of the root of a tree (by convention, empty trees are colored black):
    *)

Definition tcolor t : color :=
  match t with
  | Leaf => Black
  | Node c _ _ _ => c
  end.

(** Clearly, the [tmirror] function defined above does not change the color of
    the tree it is applied to. Let's try to convince Coq of this fact: *)

Lemma tcolor_tmirror t : tcolor (tmirror t) = tcolor t.
Proof.

(** We can try to simplify the goal, but Coq won't be able to make any
    progress. We can also try to use [done], to see if Coq accepts this fact on
    its own, but it raises an error instead: *)

rewrite /=. (* Nothing happens... *)
(* done. *) (* Cannot finish the proof. *)

(** The reason why simplification worked on the previous example, but cannot
    make any progress here, is that Coq knew exactly what shape the result of
    [singleton] has, because its definition started with a [Node]
    constructor. In the current lemma, however, we are trying to prove something
    about an _arbitrary_ tree [t], without any further information about what
    [t] is. What we need is a way to consider all possible forms that [t] can
    have, which we can accomplish with the [case] tactic: *)

case: t.

(** The [case: t] call instructs Coq to do a proof by cases. The proof state now
    shows that we need to complete two subgoals: one where [t] is replaced by
    [Leaf], and another one where it is replaced by a tree that starts with the
    [Node] constructor. We can proceed by proving each of the subgoals in
    sequence. Following the ssreflect convention, we indent the proof of the
    first subgoal by two spaces. Its proof follows by simplification. *)

  rewrite /=.
  by [].

(** The second subgoal looks a little bit different: besides not mentioning [t]
    anymore, our goal now contains additional universally quantified variables,
    the arguments to the [Node] constructor. We can introduce these variables,
    bringing them from the goal into the context by using the [move] tactic: *)

move=> c t1 x t2.

(** Each name given after the [=>] operator is used to name one universally
    quantified variable present in the goal. We can now simplify our goal as
    before and conclude. *)

rewrite /=.
by [].
Qed.

(** Ssreflect allows us to combine some of these steps into a single tactic. For
    instance, we can use [case] to name all constructor arguments and perform a
    simplification automatically, like this: *)

Lemma tcolor_tmirror' t : tcolor (tmirror t) = tcolor t.
Proof.
case: t => [|c t1 x t2] /=.

(** The pattern enclosed by square brackets in the above tactic names the
    arguments resulting from each constructor of [tree]. In the general case,
    each group of variables separated by [|] corresponds to one
    constructor. Since the [Leaf] constructor doesn't take any arguments, its
    corresponding part in the pattern doesn't contain any variables.

    The [/=] symbol tells Coq to attempt to simplify the goal _after_ doing case
    analysis on [t]. We can see that the resulting goals can be solved
    immediately: *)

  by [].
by [].
Qed.

(** As a matter of fact, we didn't even have to name the constructor arguments,
    since the [done] tactic is smart enough to do this by itself. *)

Lemma tcolor_tmirror'' t : tcolor (tmirror t) = tcolor t.
Proof. by case: t. Qed.

(** Of course, in many cases we _do_ have to perform non-trivial reasoning steps
    after calling [case]. We will encounter many examples of such proofs as we
    make progress.

    * Proof by rewriting

    So far, we have done simple proofs showing that certain equations between
    two expressions hold. We can also use these equations in other proofs to
    show more results. This process is known as _rewriting_.

    The [rewrite] tactic can be used not only with the [/=] symbol, which
    performs simplification by computation, but also with any previously proved
    equation. As a simple example, we can try to prove the following variant of
    [tcolor_tmirror]: *)

Lemma tcolor_tmirror2 t : tcolor (tmirror (tmirror t)) = tcolor t.
Proof.

(** This result is simple enough that a single call to [case] would suffice to
    solve it, as in [tcolor_tmirror]. However, we can take a slightly different
    approach, using [tcolor_tmirror] instead to rewrite on the left-hand side of
    the equation. *)

rewrite tcolor_tmirror.
rewrite tcolor_tmirror.
by [].
Qed.

(** As we can see, each call to [rewrite] instantiated the [tcolor_tmirror]
    lemma with a different tree value, successively removing calls to
    [tmirror]. In the first rewrite, the tree value was instantiated to [tmirror
    t], while in the second one, it was instantiated with [t] itself. Coq
    performs unification to find out how to instantiate each lemma given to
    [rewrite], but we can also explicitly instantiate our lemma by passing the
    value we want to use as an argument to the theorem. This is useful when
    there are multiple possible instantiations and Coq doesn't choose the one we
    want by itself. *)

Lemma tcolor_tmirror2' t : tcolor (tmirror (tmirror t)) = tcolor t.
Proof.
rewrite (tcolor_tmirror (tmirror t)).
rewrite (tcolor_tmirror t).
by [].
Qed.

(** It is also possible to perform several rewrite steps at once: *)

Lemma tcolor_tmirror2'' t : tcolor (tmirror (tmirror t)) = tcolor t.
Proof. by rewrite tcolor_tmirror tcolor_tmirror. Qed.

(** Alternatively, we can use the [!] flag to rewrite with a lemma as many times
    as possible: *)

Lemma tcolor_tmirror2''' t : tcolor (tmirror (tmirror t)) = tcolor t.
Proof. by rewrite !tcolor_tmirror. Qed.

(** Finally, we can prefix a lemma with a minus sign [-] to indicate that we
    want to rewrite in the opposite direction: *)

Lemma tcolor_tmirror2'''' t : tcolor (tmirror (tmirror t)) = tcolor t.
Proof.

(* Replace [tcolor t] by [tcolor (tmirror t)] *)
rewrite -(tcolor_tmirror t).

(* Replace [tcolor (tmirror t)] by [tcolor (tmirror (tmirror t))] *)
rewrite -(tcolor_tmirror (tmirror t)).

by [].
Qed.

(** * Proof by induction

    Coq is not smart enough to come up with its own inductive proofs. These are
    done with the [elim] tactic.

    At its simplest form, [elim] is just a more powerful version of [case] that
    generates induction hypothesis for structurally smaller terms. Here's an
    example. Suppose that we wanted to show that [tmirror] is its own
    inverse. *)

Lemma tmirrorK t : tmirror (tmirror t) = t.
Proof.

(** The [K] suffix in the name of this lemma stands for "cancellation", and is a
    convention used by ssreflect to name similar results.

    As with [case], when we call [elim: t], we get to provide names for the
    arguments of each constructor. The difference is that every recursive
    argument also generates an induction hypothesis, saying that the result we
    are trying to prove is valid for that argument. Thus, in the tactic below,
    [IH1] and [IH2] stand for the induction hypotheses that correspond to [t1]
    and [t2]. Notice that we use the [/=] flag to simplify both subgoals. *)

elim: t => [|c t1 IH1 x t2 IH2] /=.

(** The first subgoal corresponds to the [t = Leaf] case, and can be solved by
    Coq automatically. *)

  by [].

(** When attacking the second subgoal, where [t] has the form [Node c t1 x t2],
    we can see that our context looks a bit different. Besides the usual
    arguments, it also contains the induction hypotheses [IH1] and [IH2], which
    state that [tmirror (tmirror t1) = t1] and [tmirror (tmirror t2) = t2]. To
    conclude this subgoal, we can rewrite with these hypotheses, as if they were
    normal lemmas: *)

rewrite IH1 IH2.

(** Now, both sides of the equation are equal, and Coq accepts our proof. *)

by [].
Qed.

(** Ssreflect provides nice syntax for simplifying this proof. Since many cases
    in a proof follow directly by simplification, we can use the [//] flag with
    [elim] to tell Coq to try to close all goals it can with the [done]
    tactic. *)

Lemma tmirrorK' t : tmirror (tmirror t) = t.
Proof.
elim: t => [|c t1 IH1 x t2 IH2] // /=.
by rewrite IH1 IH2.
Qed.

(** Both [//] and [/=] can be combined in a single flag, [//=]. *)

Lemma tmirrorK'' t : tmirror (tmirror t) = t.
Proof.
elim: t => [|c t1 IH1 x t2 IH2] //=.
by rewrite IH1 IH2.
Qed.

(** We can further condense this proof by performing some of the rewriting steps
    directly after calling [elim]. When [->] is given as a name for a
    hypothesis, this tells Coq to try to rewrite with that hypothesis. This
    leads to the following proof: *)

Lemma tmirrorK''' t : tmirror (tmirror t) = t.
Proof. by elim: t => [|/= c t1 -> x t2 ->]. Qed.

(** Notice that, before rewriting with the induction hypotheses in the [Node]
    branch, we perform a simplification step with [/=], so that Coq can find the
    terms [tmirror (tmirror t1)] and [tmirror (tmirror t2)] in the goal.

    * Propositions are first-class values

    One interesting aspect of Coq's theory is that propositions are first-class
    values that can be manipulated according to the same rules that are used for
    other objects of the language. In particular, since Coq is a _typed_
    language, all propositions have a type: [Prop]. For instance: *)

Check 1 = 1.

(** Note that being a syntatically well-formed proposition does not imply that
    this proposition is true. Hence, [0 = 1] also has type [Prop], even though
    it corresponds to a false claim. *)

Check 0 = 1.
(** Coq comes with a rich language for writing propositions. So far, we have
    encountered the equality operator [=], and universal quantification
    [forall], but there are many more. We will introduce more of them as we go
    along.

    We can define functions that return propositions, allowing us to develop
    convenient abbreviations for common patterns.

    As an example, we can define a function [cancel] that takes in two functions
    [f] and [g] as arguments, and states that [g] is the left inverse of
    [f]. Since [cancel] is already provided by ssreflect, we restate the
    definition here with a different name, to avoid clashes. *)

Definition cancel' (S R : Type) (f : S -> R) (g : R -> S) : Prop :=
  forall x : S, g (f x) = x.

(** Notice that the [S] and [R] types are explicitly given as arguments to
    [cancel]. However, because of the "implicit arguments" option we enabled at
    the beginning of the file, we don't have to provide them most of the
    time. For instance: *)

Lemma tmirrorK'''' : cancel (@tmirror T) (@tmirror T).
Proof.

(** To understand what's going on, it is sometimes useful to unfold the
    definition of [cancel]. Simplification by default does not perform this kind
    of unfolding, because it would create bigger and harder-to-understand proof
    contexts. To unfold a term [foo], we use the [/foo] rewrite flag. For
    instance (even though it won't affect the rest of the proof): *)

rewrite /cancel.

(** Since [cancel] has an explicitly quantified variable [x] in its definition,
    we need to bring it into the context, much like we did after doing case
    analysis. Of course, we can give [x] any name we like: *)

move=> t.
by elim: t => [|/= c t1 -> x t2 ->].
Qed.

(** In situations like this, where we want our tactic to act on the first
    quantified value on the goal, we can just call that tactic directly, without
    having to introduce that value directly. In other words, tactics such as
    [case] and [elim] always act implicitly on the first universally quantified
    value in our goal, in stack-like fashion. *)

Lemma tmirrorK''''' : involutive (@tmirror T).
Proof. by elim=> [|/= c t1 -> x t2 ->]. Qed.

(** Notice that we have used [involutive tmirror] instead of [tcancel tmirror
    tmirror]. [involutive foo] is defined exactly as [cancel foo foo].

    The reason we wrote [: t] on previous calls to [elim] is simple: the [:] is
    actually a tactic operator, whose effect is to put some variables in the
    context back in the goal. In this sense, it is the inverse of the [=>]
    introduction operator. For instance: *)

Lemma tmirrorK'''''' : involutive (@tmirror T).
Proof.
move=> t.
move: t.
Abort.

(** * Using previous results

    Coq and ssreflect come with many definitions and lemmas about them. In order
    to make effective use of Coq, it is important to know how to reuse this
    infrastructure. Here is a simple example. Suppose that we wanted to prove
    that mirroring a tree does not change its size. *)

Lemma tsize_tmirror t : tsize (tmirror t) = tsize t.
Proof.

(** We could try to prove this by induction: *)

elim: t => [|/= c t1 -> x t2 ->] //.

(** Here, we see that Coq was able to discharge the base case by itself, with
    [//]. However, it was not able to get rid of the second one. Indeed, we can
    see that the order of the summands on both sides is different:

    [tsize t2 + 1 + tsize t1 = tsize t1 + 1 + tsize t2]

    Unfortunately, ssreflect's [done] tactic does not perform this kind of
    arithmetic reasoning by itself, and we must find previous results that will
    allow us to show that these two terms are equal. Coq comes with a
    [SearchAbout] command that can be used for looking up lemmas that mention
    certain definitions. In this case, we want to be able to argue about
    commutativity and associativity of [+]. As it turns out, ssreflect already
    these notions for us: *)

Print commutative. (* [C-c C-a C-p] in Proof General *)
Print associative.

(** We can then try to use [SearchAbout] to find lemmas that may help us
    here. *)

SearchAbout "+" commutative. (* [C-c C-a C-a] in Proof General *)
SearchAbout "+" associative.

(** Running these commands shows us that there are two lemmas, [addnC] and
    [addnA], that we can use. You will notice that both lemmas mention a
    function [addn] instead of the [+] operator. Coq comes with a notation
    mechanism for changing the syntax of certain constructs. Thus, natural
    number addition is actually defined as a function [addn], and only later we
    issue a [Notation] command for using the nice infix syntax. Notice also that
    we had to enclose [+] in quotes so that Coq can understand that we are
    referring to a notation as opposed to a normal identifier. We will not
    discuss the details of the [Notation] command right now, though, as it is a
    bit complicated to explain. *)

by rewrite addnC (addnC _ 1) addnA.
Qed.

(** * Hypothetical statements

    So far, we have seen how to prove facts that are always true. In many cases,
    however, we are interested in facts that are only valid when certain
    hypotheses hold. In Coq, we can express such hypothetical statements with
    the implication operator [->]. For example: *)

Lemma tmirror_leaf t : tmirror t = Leaf -> t = Leaf.

(** Each formula preceeding an arrow is a hypothesis that needs to be met for
    the conclusion of the statement (the formula after [->]) to hold. In this
    case, the lemma says that if the result of [tmirror t] is [Leaf], then [t]
    itself must be equal to [Leaf].

    We can use the [=>] operator to name hypotheses that appear in the goal and
    bring them into the context. This allows us to use a hypothesis like we used
    previous lemmas or induction hypotheses: *)

Proof.
move=> e.

(** We can use [tmirrorK] to replace [t] by [tmirror (tmirror t)]. *)

rewrite -(tmirrorK t).

(** Thanks to our hypothesis, we can now bring the goal to a more palatable
    form. *)

rewrite e.

(** Since [tmirror Leaf] is equal to [Leaf] by simplification, Coq can conclude
    directly. *)

by [].
Qed.

(** This shows how to prove hypothetical results. It is also possible to use
    hypothetical results to prove other statements; this in turn requires that
    we prove separately each hypothesis in that statement. *)

Lemma tmirror_leaf2 t : tmirror (tmirror t) = Leaf -> t = Leaf.
Proof.
move=> e.

(** Since the [tmirror_leaf] lemma used below has a hypothesis, the rewrite
    below generates two subgoals: [Leaf = Leaf] and [tmirror t = Leaf]. The
    first one is trivial, and can be discharged directly with [//]. Notice*)

rewrite (@tmirror_leaf t) //.

(** Alternatively, if the goal matches exactly the conclusion of a lemma or
    hypothesis in the context, we can use the [apply] tactic. Once again, if the
    result we apply has any hypotheses, we will have to solve them as separate
    subgoals. *)

apply: tmirror_leaf.
by [].

(** In this case, choosing between [rewrite] and [apply] was (almost) just a
    matter of style. It is important to notice, however, that both tactics are
    usually not interchangeable. [rewrite] only works with statements whose
    conclusions are equalities, and performs a small modification on the
    goal. [apply], on the other hand, works with goals that involve _arbitrary_
    logical constructs, not just equalities. It will be more useful once we
    learn more about Coq's logic.

    Besides using lemmas as functions to specify the value of universally
    quantified variables, we can use function application syntax to supply
    hypotheses. We can use this feature to prove the previous theorem with a
    single call to [apply]. *)

Restart.
move=> e.
by apply: (tmirror_leaf (tmirror_leaf e)).

(** Instead of using [by apply], we can also use [exact]. There are subtle
    differences between the two, but for now we can think of [exact] as a
    shorter version of [by apply]. *)

Restart.
move=> e.
exact: (tmirror_leaf (tmirror_leaf e)).
Qed.

(** * Forward reasoning tactics

    Coq's primary style of interaction is backwards: we progressively simplify
    the goal, until it reaches a state where it can be solved trivially. Often,
    it is more convenient to reason _forward_ instead: progressively deduce more
    and more complex facts from the hypotheses that we have, until some of them
    can apply directly to the goal.

    In ssreflect, the two primary forward-reasoning tactics are [have] and
    [suffices]. When we write [have e: P], Coq adds a new intermediate subgoal
    where it asks for a proof of [P]. Once we complete the proof, it resumes the
    original subgoal, enriching the context with a new hypotheses [e : P]. We
    can use [have] to write an alternative proof of [tmirror_leaf2]: *)

Lemma tmirror_leaf2' t : tmirror (tmirror t) = Leaf -> t = Leaf.
Proof.
move=> e.
have e': tmirror t = Leaf.
  by apply: tmirror_leaf.
by apply: (tmirror_leaf e').

(** It is important to notice that the [:] symbol used in [have] is unrelated to
    the use of [:] in tactics such as [apply], [move] and [case]: in [have], its
    purpose is to state the intermediate result we want to prove, while in the
    other tactics we have seen it moves variables and hypotheses from the
    context into the goal.

    If the intermediate proof used with [have] is short, we can condense it into
    a single tactic, using the [by] keyword. *)

Restart.
move=> e.
have e': tmirror t = Leaf by apply: tmirror_leaf.
by apply: (tmirror_leaf e').

(** The [suffices] tactic is similar to [have]. Its main difference is that it
    reverses the order of the generated subgoals: the first subgoal is augmented
    with the new fact, while the second one asks of the proof of that auxiliary
    fact. Compare: *)

Restart.
move=> e.
suffices e': tmirror t = Leaf.
  by apply: (tmirror_leaf e').
by apply: tmirror_leaf.

(** We are also allowed to merge the proof of the first subgoal into the call to
    [suffices]: *)

Restart.
move=> e.
suffices e': tmirror t = Leaf by apply: (tmirror_leaf e').
by apply: tmirror_leaf.
Qed.

(** The [suffices] tactic is useful when the proof of the auxiliary statement is
    more complicated than the part that uses it. Its name is meant to mimic the
    usual pattern seen in mathematical proofs: "To show A, it suffices to show
    B, because [short argument follows]. Let's then prove B." *)

End Basic.

(** Before discussing more interesting operations on trees, it is worth having a
    tour of some of the basic types and operations provided by Coq and
    ssreflect.

    * Booleans

    Coq defines [bool] as an inductive data type with two constructors: [true]
    and [false]. In that sense, it is equivalent to the definition of the
    [color] type above. *)

Print bool.

(** We can perform case analysis on a boolean with the familiar if-then-else
    syntax: *)

Compute if true then 1 else 2.

(** This form is just a shorthand to an explicit [match]: *)

Compute match true with true => 1 | false => 2 end.

(** Many standard boolean operations are already defined for us. We write [&&],
    [||] and [~~] for the "and", "or", and "not" functions. *)

Check true && true.
Check true || ~~ false.

(** The [case] tactic can be used to do a proof by cases on members of any
    inductively defined type, including [bool]. *)

Lemma andbF' b : b && false = false.
Proof.

(** Coq cannot solve this goal by itself because [&&] is defined by case
    analysis on its first argument: *)

Print andb.

(** If we do case on [b], on the other hand, the goal becomes trivial. We can
    see that [b] is replaced by [true] and [false] on each generated subgoal: *)

case: b.
  by [].
by [].
Qed.

(** Ssreflect provides an [andbF] lemma whose statement is similar to the one
    above. The name [andbF] means that the lemma talks about what happens when
    we compute the [and] of an arbitrary boolean [b] and [false] ([F]). (Can you
    guess what [andFb] states? What about [andbT]?).

    * Natural numbers

    We have already seen some definitions involving natural numbers. Unlike
    other languages, where numeric types are often primitive, [nat] in Coq is
    just another inductive data type. It is defined as the type having one
    constructor [O], representing zero, and one constructor [S : nat -> nat],
    which represents the successor of a number. *)

Print nat.

(** Coq allows us to write elements of [nat] with conventional arabic
    notation. This feature is just for making programming with [nat] more
    convenient: internally, natural numbers are still represented with [S] and
    [O]. *)

Check 2.
Check S (S O).

(** Additionally, ssreflect uses [n.+1] as special syntax for [S n]: *)

Check 0.+1.+1.

(** We can also use [n.+2], [n.+3] and [n.+4]. *)

Check 0.+2.

(** For instance, here's how we can define a function for computing the
    Fibonacci numbers: *)

Fixpoint fib_aux n acc1 acc2 :=
  if n is n'.+1 then fib_aux n' acc2 (acc1 + acc2)
  else acc2.

Definition fib n := fib_aux n 0 1.

Compute fib 8.

(** This definition also uses a different syntax for doing pattern matching. [if
    e is p then e1 else e2] is just a synonym for [match e with p => e1 | _ =>
    e2]. If it is not obvious for you that this function defines the Fibonacci
    numbers, check the exercise at the end of the chapter.

    We can subtract two numbers by using the [subn] function, written as the
    familiar infix operator [-]. It is worth noting that, because [nat] doesn't
    contain negative values, subtraction on [nat] is _truncated_: if [n] is less
    than [m], then [n - m = 0]. *)

Compute 2 - 4.

(** We can test whether a number is less than other with the [<=] operator: *)

Compute 2 <= 4.
Compute 4 <= 2.

(** We can also write [n < m], which is just special syntax for [n.+1 <= m]. *)

Check (2 + 3).+1 <= 5.

(** When used with a [nat], the [case] tactic behaves similarly to [tree] or
    [bool]: it generates subgoals corresponding to the [O] and [S]
    constructors. The [elim] tactic also works with members of [nat], generating
    an induction hypothesis for the [S] case. Here is a proof of the [addnA]
    lemma we have used above. *)

Lemma addnA' : associative addn.
Proof.
move=> n m p.
elim: n => [|n IH] //=.
rewrite addSn IH.
by [].
Qed.

(** * Sequences

    Like other functional programming languages, ssreflect provides a data type
    [seq] of finite sequences, or lists. To use it, you must import the
    [Ssreflect.seq] library. This type is parameterized over the type of
    elements contained in the sequence; hence, elements of [seq nat] are
    sequences of natural numbers, while elements of [seq bool] are sequences of
    booleans.

    As in other languages, the [seq] type is generated by two constructors:
    [nil], which denotes an empty sequence, and [cons], which adds an element at
    the beginning of some other sequence. For those, Ssreflect provides the
    notations [[::]] and [::]. For example, the sequence consisting of the
    natural numbers [1], [2], and [3] is written as follows: *)

Check 1 :: 2 :: 3 :: [::].

(** Notice that Coq prints the above expression in a slightly different form. In
    ssreflect, we can refer to a literal sequence [e1 :: .. :: en :: [::]] using
    the notation [[:: e1; .. ; en]]: *)

Check [:: 1; 2; 3].

(** The [++] operator concatenates two sequences. *)

Check [:: true; false] ++ [:: true].

(** The [seq] library defines many common operations on sequences for us. The
    familiar [map] function applies some function [f] to all elements of a
    sequence [s]. Here, the [fun n => e] expression is Coq's syntax for an an
    _anonymous function_ that takes [n] as an argument and produces [e] as its
    result. *)

Check map (fun n => [:: n]) [:: 1; 2; 3].

(** Ssreflect has support for a limited form of _list comprehension_ syntax,
    similar to Haskell's. We can see that the above expression is printed
    slightly different by Coq when we execute [Check]: *)

Check [seq [:: n] | n <- [:: 1; 2; 3]].

(** Unfortunately, Coq's notation mechanism is not powerful enough to define a
    flexible, generic equivalent of the list comprehension syntax. Thus,
    ssreflect defines special syntax for only a handful of expressions involving
    sequences. You can read more about them in the documentation of the [seq]
    library.

    Since [seq] is generated by [nil] and [cons], doing case analysis or
    induction on a sequence will generate two cases: one for [nil] and one for
    [cons]. For example: *)

Lemma catA' T : associative (@cat T).
Proof.
move=> s1 s2 s3.
elim: s1 => [|x s1 IH] /=.
  by []. (* [nil] case *)
by rewrite IH. (* [cons] case *)
Qed.

(** (Can you make the above proof shorter?)

    Finally, ssreflect provides an operator [\in] for testing whether an element
    occurs in a sequence. *)

Check 1 \in [:: 1; 2; 3].

(** The [\in] operator is actually defined not just for sequences, but for any
    type supporting a "membership test" operation. In the case of sequences, we
    can only test for membership of elements of some [eqType], which is a Coq
    type equipped with a boolean operation for testing equality. We will come
    back to [eqType] in more detail later; for now, you only need to know that
    ssreflect defines such operations for many basic types, including [nat],
    [seq], among others.

    * Reasoning about constructors

    Intuitively, there are two properties that we expect to hold of data
    constructors. The first one is that constructors are _disjoint_: if we
    construct two values using different constructors, the two values must be
    different. The second one is that constructors are _injective_: whenever two
    expressions involving the same constructor are equal, we can conclude that
    the arguments given to the constructors are equal. These principles are
    validated by Coq's logic, and are useful for proving many results; we
    discuss a few examples here to show how they work.

    Suppose we wanted to prove the following result: *)

Lemma eq_map_nil T S (f : T -> S) s :
  [seq f x | x <- s] = [::] ->
  s = [::].

(** We can argue by case analysis. Since [seq] is generated by [nil] and [cons],
    [s] can have to forms: [[::]] and [x :: s'], for some values [x] and
    [s']. *)

Proof.
case: s=> [|x s'] /=.

(** We can see that the first case was reduced to [[::] = [::] -> [::] =
    [::]]. Since the conclusion is trivial, [done] suffices: *)

  by [].

(** The second case is more interesting: our goal wants us to conclude
    that [x :: s' = [::]], which is clearly false. However, the
    hypothesis in our goal now equates two expressions that start with
    different constructors:

    [f x :: [seq f x' | x' <- s'] = [::]]

    This hypothesis is now absurd, which means that this case can actually never
    occur. The [done] tactic can detect this situation and remove the case from
    further consideration, allowing us to conclude. In logic jargon, this is a
    particular instance of the _principle of explosion_, which states that a
    contradiction entails anything. *)

by [].
Qed.

(** (Can you make this proof shorter?)

    The second principle, injectivity, is not handled by [done] by
    default. Instead, ssreflect provides an introduction form for decomposing an
    equality between expressions with constructors in terms of the arguments
    that appear in it. Here is a simple example: *)

Lemma inj_ex T (x1 x2 y1 y2 : T) :
  [:: x1; y1] = [:: x2; y2] -> x1 = x2.

(** We have seen that we can use the [=>] tactic operator to name hypotheses and
    bring them into the context. If instead of giving it a single name, we give
    a _list_ of names enclosed in brackets [[]], Coq will enumerate all
    equations between arguments that it can infer from that fact, from left to
    right, and name them according to the given list. Thus, the call *)

Proof.
move=> [ex ey].

(** converts the [[:: x1; y1] = [:: x2; y2]] hypothesis into two equations [ex]
    and [ey], asserting [x1 = x2] and [y1 = y2]. The syntax tries to mimic the
    one for case-analysis patterns on purpose. On a data value, the pattern has
    the effect of enumerating all constructors that could have been used to
    produce that value. On an equality, the pattern enumerates all equalities
    that must hold for that one to be valid.

    At this point, we can conclude by rewriting with [e1], or by using
    [done] directly: *)

by [].
Qed.

(** (Can you make this proof shorter?)

    * Using booleans as propositions

    We often want to state facts as an equality between booleans. For instance,
    here's is how we might say that the number [1] occurs in the sequence [[::
    1; 2; 3]]: *)

Lemma bool_prop_ex1 : (1 \in [:: 1; 2; 3]) = true.

(** Since the [\in] operator is defined by a function that computes a boolean,
    Coq can attest that this claim is valid by computation. *)

Proof. by []. Qed.

(** This pattern is so common that ssreflect provides a shorthand for it:
    whenever an expression [e] of type [bool] is used in a context that expects
    an expression of type [Prop], [e] is implicitly converted to [Prop] by
    mapping it to [e = true]. *)

Lemma bool_prop_ex2 : 1 \in [:: 1; 2; 3].

(** This is an instance of a generic feature of Coq called _implicit coercions_,
    which allows certain functions to be implicitly inserted in an expression to
    convert from one type to another. We can have a better sense of what is
    going on by telling Coq to show all coercions that are applied: *)

Set Printing Coercions.

(** We can see that the goal we were trying to prove is actually [is_true (1 \in
    [:: 1; 2; 3])], where [is_true b] is defined as [b = true]. *)

Unset Printing Coercions.

(** Coq treats [is_true b] as if it were an equality. For instance, it can solve
    trivial goals involving [is_true] with [done]. *)

Proof. by []. Qed.

(** It can also rewrite with hypotheses of the form [is_true b], which
    has the effect of replacing [b] by [true]. For instance, we can
    prove the following fact about the boolean "and" operator [&&]: *)

Lemma bool_prop_ex3 (b c : bool) : b -> b && c = c.
Proof. by move=> ->. Qed.

(** Since different constructors are disjoint, we know that [false] cannot occur
    in a hypothesis, because that is synonym with [false = true]. The [done]
    tactic can detect this and similar hypotheses in our context and discharge
    the current goal automatically. Consider the following result: *)

Lemma bool_prop_ex4 n : n <= 0 -> n = 0.
Proof.

(** To put the goal in a shape that can be simplified, we can perform case
    analysis on [n]: *)

case: n => [|n] /=.

(** In the first subgoal, we have to prove [0 = 0], which is trivial: *)

  by [].

(** In the second one, we are left with a contradictory hypothesis, stating that
    [n < 0] (recall that [n < 0] is just notation for [n.+1 <= 0]). We can
    rewrite with [ltn0] lemma from [ssrnat] to replace that hypothesis by
    [false], allowing us to conclude.. *)

rewrite ltn0.
by [].

(** As a matter of fact, we don't even need to call [rewrite], because [n < 0]
    can be "forced" to simplify to [false]: *)

Restart.
by case: n.
Qed.

(** We may also use a boolean to state that a certain proposition is not
    valid. For instance: *)

Lemma bool_prop_ex5 : (4 < 2) = false.
Proof. by []. Qed.

(** However, because of how the coercion from [bool] to [Prop] is defined,
    ssreflect prefers statements of the form [~~ b = true]: *)

Lemma bool_prop_ex6 : ~~ (4 < 2).
Proof. by []. Qed.

(** * Generalizing the induction hypothesis *)

Module Rev.

Section Rev.

Variable T : Type.

Implicit Type s : seq T.

Fixpoint rev s :=
  match s with
  | [::] => [::]
  | x :: s => rev s ++ [:: x]
  end.

Fixpoint tr_rev_aux s acc :=
  match s with
  | [::] => acc
  | x :: s => tr_rev_aux s (x :: acc)
  end.

Definition tr_rev s := tr_rev_aux s [::].

Lemma tr_revE s : tr_rev s = rev s.
Proof.
rewrite /tr_rev -[RHS]cats0.
elim: s [::] => [|x s IH] //= acc.
by rewrite IH -catA.
Qed.

End Rev.

End Rev.

(** * Specifying and verifying a tree operation

    We can use sequences to specify and verify our first interesting tree
    operation: a [tmember] function, that tests whether some element [x] occurs
    on a tree [t], assuming that [t] is a binary search tree -- that is, that
    any element on a node is greater than those on its left subtree and smaller
    than those on its right subtree.

    It would be possible to program [tmember] for any type of elements with a
    comparison operator. However, we will begin with something simpler, and
    define [tmember] only for trees of natural numbers, taking advantage of the
    usual comparison operator [<] defined in the [ssrnat] library. Notice that
    our definition uses [if] expressions, which are defined in the obvious way
    in terms of [match]. *)

Fixpoint tmember (x : nat) (t : tree nat) : bool :=
  match t with
  | Leaf => false
  | Node _ t1 x' t2 =>
    if x < x' then tmember x t1
    else if x' < x then tmember x t2
    else true
  end.

(** We will state the specification of [tmember] in terms of a [telems]
    function, which lists all elements that appear in the tree from left to
    right. *)

Fixpoint telems T (t : tree T) : seq T :=
  match t with
  | Leaf => [::]
  | Node _ t1 x t2 => telems t1 ++ x :: telems t2
  end.

(** In order to fully specify the behavior of [tmember], we would have to reason
    about the search-tree invariant. Before getting there, however, we start
    with something simpler: showing that if [tmember x t] is true, then [x] must
    occur in [telems t]. *)

Lemma tmember_sound x t : tmember x t -> x \in telems t.
Proof.

(** It seems a good idea to try to prove this result by induction. *)

elim: t => [|c t1 IH1 x' t2 IH2] /=.

(** In the first case ([t = Leaf]), we have to prove that [x] occurs in the
    empty sequence (that is, [telems Leaf]), assuming that [tmember x Leaf] is
    true. While [x] cannot occur in an empty sequence, we can remark that
    [tmember x Leaf] is [false] by definition. This means that we never have to
    consider this case because it can never occur. The [done] tactic can detect
    this and remove this case from consideration for us.  *)

  by [].

(** The second case is more interesting, as we have to consider all possible
    outcomes of comparing [x'] and [x]. The [case] variant below can be used to
    perform case analysis on a value while generating an equation for that
    case. For reasons that soon will become apparent, we will need these
    additional equations later. *)

case e1: (x < x').

(** In the first generated subgoal, we have an additional hypothesis [e1]
    stating [(x < x') = true], and the original compliated premise has been
    simplified to [tmember x t1]. *)

  rewrite mem_cat => e.
  by rewrite (IH1 e).

case e2: (x' < x).

  rewrite mem_cat /= inE.

Admitted.

(** * Exercises: *)

Lemma negbK' : involutive negb.
Proof. Admitted.

Lemma eq_add_0L n m : n + m = 0 -> n = 0.
Proof. Admitted.

Lemma eq_add_0R n m : n + m = 0 -> m = 0.
Proof. Admitted.

(** Hint: The [drop_size_cat] lemma might come in handy. *)
Lemma cat_fact T (s : seq T) : s ++ s = s -> s = [::].
Proof. Admitted.

(** Hint: What is the value of [fib_aux n (x1 + x2) (y1 + y2)]? *)
Lemma fib2 n : fib n.+2 = fib n.+1 + fib n.
Proof. Admitted.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype finfun bigop prime binomial ssralg.
From mathcomp Require Import finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb Rbigop proba entropy.

(** * Asymptotic Equipartition Property (AEP) *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope proba_scope.
Local Open Scope entropy_scope.
Local Open Scope tuple_ext_scope.

Local Open Scope ring_scope.

Definition map_mlog A n (P : dist A) : 'rV[rvar A]_n :=
  \row_(i < n) --log P.

Local Open Scope vec_ext_scope.

Section map_mlog_prop.

Variable A : finType.
Variable P : dist A.

Lemma E_map_mlog k i : `E ((map_mlog k.+1 P) ``_ i) = `H P.
Proof.
rewrite ExE /entropy (big_morph _ morph_Ropp oppR0).
apply eq_bigr=> a _; by rewrite mxE /= mulNR mulRC.
Qed.

Definition aep_sigma2 := (\rsum_(a in A) P a * (log (P a))^2 - (`H P)^2)%R.

Lemma V_map_mlog k i : `V ((map_mlog k.+1 P) ``_ i) = aep_sigma2.
Proof.
rewrite /Var E_trans_id_rem E_map_mlog.
rewrite ExE /aep_sigma2 /map_mlog.
rewrite mxE /= -/(_ ^ 2).
transitivity
  (\rsum_(a in A) ((- log (P a))^2 * P a - 2 * `H P * - log (P a) * P a + `H P ^ 2 * P a))%R.
  apply eq_bigr => a _; by field.
rewrite big_split /= big_split /= -big_distrr /= (pmf1 P) mulR1.
set s := (\rsum_(a in A) - _)%R.
have {s}-> : s = (- (2 * `H P ^ 2))%R.
  rewrite /s -{1}(big_morph _ morph_Ropp oppR0).
  f_equal.
  rewrite [X in X = _](_ : _ = \rsum_(a in A) (2 * `H P) * (- (P a * log (P a))))%R; last first.
    apply eq_bigr => a _; by rewrite -!mulRA (mulRC (P a)) mulNR.
  by rewrite -big_distrr /= -{1}(big_morph _ morph_Ropp oppR0) -/(entropy P) mulR1 mulRA.
set s := \rsum_(a in A ) _.
rewrite (_ : \rsum_(a in A) _ = s); last by rewrite /s; apply eq_bigr => a _; field.
by field.
Qed.

Lemma aep_sigma2_pos : 0 <= aep_sigma2.
Proof.
rewrite -(@V_map_mlog O ord0) /Var; apply Ex_nonneg => ?; exact: pow_even_ge0.
Qed.

End map_mlog_prop.

Definition sum_mlog_prod A (P : dist A) n : rvar [finType of 'rV[A]_n] :=
  mkRvar (P `^ n) (fun t => \rsum_(i < n) - log (P t ``_ i))%R.

Lemma sum_mlog_prod_isum_map_mlog A (P : dist A) : forall n,
  sum_mlog_prod P n.+1 \=isum map_mlog n.+1 P.
Proof.
elim.
- move: (@isum_n_1 A (\row_i --log P)).
  set mlogP := cast_rv _.
  move=> HmlogP.
  set mlogprodP := sum_mlog_prod _ _.
  suff -> : mlogprodP = mlogP.
    rewrite [X in _ \=isum X](_ : _ = \row_i --log P); last by apply val_inj.
    by apply isum_n_1.
  rewrite /mlogprodP /mlogP /sum_mlog_prod /cast_rv /=.
  rewrite mxE /=.
  congr mkRvar.
  apply FunctionalExtensionality.functional_extensionality => ta.
  by rewrite big_ord_recl big_ord0 addR0.
- move=> n IHn.
  rewrite [X in _ \=isum X](_ : _ = row_mx (\row_(i < 1) (--log P)) (map_mlog n.+1 P)); last first.
    apply/matrixP => a b; rewrite {a}(ord1 a) !mxE.
    case: splitP.
      move=> a; rewrite {a}(ord1 a) => _; by rewrite mxE.
    move=> k _; by rewrite mxE.
  eapply isum_n_cons; first by apply IHn.
  + rewrite /sum; split.
    * by apply joint_prod_n.
    * move=> ta.
      rewrite /= big_ord_recl /=.
      congr (_ + _)%R.
      apply eq_bigr => i _; by rewrite mxE.
  + rewrite /inde_rv => /= x y.
    have : id_dist P (map_mlog n.+2 P).
      rewrite /id_dist => i.
      by rewrite mxE /=.
    move/(inde_rv_tuple_pmf_dist x y) => Htmp.
    eapply trans_eq.
      eapply trans_eq; last by apply Htmp.
      apply Pr_ext; apply/setP => ta; rewrite 2!inE /=.
      apply andb_id2l => _.
      congr (_ == _).
      apply eq_bigr => i _.
      by rewrite !mxE /mlog_rv /=.
    congr (_ * _)%R.
    apply Pr_ext; apply/setP => ta /=; rewrite 2!inE.
    congr (_ == _).
    apply eq_bigr => i _; by rewrite !mxE /=.
Qed.

(** Constant used in the statement of AEP: *)

Section aep_k0_constant.

Variable A : finType.
Variable P : dist A.

Definition aep_bound epsilon := (aep_sigma2 P / epsilon ^ 3)%R.

Lemma aep_bound_pos e (_ : 0 < e) : 0 <= aep_bound e.
Proof. apply divR_ge0; [exact: aep_sigma2_pos | exact/pow_lt]. Qed.

Lemma aep_bound_decreasing e e' : 0 < e' <= e -> aep_bound e <= aep_bound e'.
Proof.
case=> Oe' e'e.
apply leR_wpmul2l; first exact: aep_sigma2_pos.
apply leR_inv => //; first exact/pow_lt.
apply pow_incr => //; split; [exact/ltRW | exact/e'e ].
Qed.

End aep_k0_constant.

Section AEP.

Variable A : finType.
Variable P : dist A.
Variable n : nat.
Variable epsilon : R.
Hypothesis Hepsilon : 0 < epsilon.

Lemma aep : aep_bound P epsilon <= INR n.+1 ->
  Pr (P `^ n.+1) [set t | (0 <b P `^ n.+1 t) &&
    (`| (--log (P `^ n.+1) '/ n.+1) t - `H P | >b= epsilon) ] <= epsilon.
Proof.
move=> Hbound.
apply (@leR_trans (aep_sigma2 P / (INR n.+1 * epsilon ^ 2))%R); last first.
  rewrite /aep_bound in Hbound.
  apply (@leR_wpmul2r (epsilon / INR n.+1)) in Hbound; last first.
    apply divR_ge0; [exact/ltRW/Hepsilon | exact/ltR0n].
  rewrite [in X in _ <= X]mulRCA mulRV ?INR_eq0' // ?mulR1 in Hbound.
  apply/(leR_trans _ Hbound)/Req_le; field.
  split; [by rewrite INR_eq0 | exact: gtR_eqF].
move: (sum_mlog_prod_isum_map_mlog P n) => Hisum.
move: (wlln (@E_map_mlog _ P n) (@V_map_mlog _ P n) Hisum Hepsilon) => law_large.
apply: (leR_trans _ law_large).
apply Pr_incl; apply/subsetP => ta; rewrite 2!inE.
case/andP => H1.
rewrite [--log _]lock /= -lock.
set p1 := (_ * _)%R.
set p2 := (_ * _)%R.
suff : p1 = p2 by move=> <-.
rewrite /p1 /p2 {p1 p2}.
congr (_ * _)%R.
rewrite /map_mlog /=.
rewrite TupleDist.dE.
apply log_rmul_rsum_mlog, (rprodr_gt0_inv (dist_ge0 P)).
move: H1; by rewrite TupleDist.dE => /ltRP.
Qed.

End AEP.


(** * Bitstrings.v : Bitstring type and operators *)

Require Export Bvector.
Require Export EqdepFacts.
Require Export Eqdep_dec.
Require Export Peano_dec.
Require Export BaseDef.
Require Export List.
Require Export Types.

Set Implicit Arguments.

(* Boolean equality on [Bvector k] *)
Fixpoint Veqb k (v1 v2:Bvector k) : bool :=
 match k as k0 return Bvector k0 -> Bvector k0 -> bool with
 | O => fun _ _ => true
 | S k0 => fun x1 x2 =>
   if Bool.eqb (Blow k0 x1) (Blow k0 x2) then
    Veqb (Bhigh k0 x1) (Bhigh k0 x2)
    else false
 end v1 v2.

Lemma Veqb_spec : forall k (v1 v2:Bvector k),
 if Veqb v1 v2 then v1 = v2 else v1 <> v2.
Proof.
 induction k; simpl; intros.
 rewrite (V0_eq bool v1), (V0_eq bool v2); trivial.
 rewrite (VSn_eq bool k v1); rewrite (VSn_eq bool k v2); simpl.
 case_eq (Bool.eqb (Vhead bool k v1) (Vhead bool k v2)).
 generalize (IHk (Vtail bool k v1) (Vtail bool k v2));
  destruct Veqb; intros.
 rewrite H, (eqb_prop _ _ H0); trivial.
 intro Heq; injection Heq; intros.
 apply H; apply (inj_pair2_eq_dec _ eq_nat_dec _ _ _ _ H1).
 intros H Heq; injection Heq; intros.
 rewrite H1 in H; rewrite eqb_reflx in H; discriminate.
Qed.

Lemma Veqb_sym : forall k (x y:Bvector k), Veqb x y = Veqb y x.
Proof.
 induction k; simpl; intros.
 trivial.
 rewrite eqb_sym; rewrite IHk; trivial.
Qed.

Lemma Veqb_refl : forall k (x:Bvector k), Veqb x x.
Proof.
 induction k; simpl; intros.
 trivial.
 rewrite eqb_reflx; trivial.
Qed.

Lemma Veqb_true : forall k (x y:Bvector k), Veqb x y = true -> x = y.
Proof.
 intros; generalize (Veqb_spec x y); rewrite H; trivial.
Qed.

(** Support for uniform bitstring distribution *)
Fixpoint bs_support (k:nat) : list (Bvector k) :=
 match k as k0 return list (Bvector k0) with
 | O => Vnil bool :: nil
 | S k =>
   let l := bs_support k in
   map (Vcons bool false k) l ++
   map (Vcons bool true k) l
 end.

Lemma bs_support_not_nil : forall k, bs_support k <> nil.
Proof.
 induction k; simpl.
 intro; discriminate.
 destruct (bs_support k).
 elim IHk; trivial.
 intro; discriminate.
Qed.

Lemma bs_length_add : forall k p,
 length (bs_support (k + p)) = (length (bs_support k) * length (bs_support p))%nat.
Proof.
 induction k; simpl; intros.
 ring.
 repeat (rewrite app_length || rewrite map_length || rewrite IHk).
 fold Bvector; ring.
Qed.

Opaque Vextend.

Lemma bs_support_sum : forall k p f,
 mu (sum_support (Bvect_false (k+p)) (bs_support (k+p))) f ==
 mu (sum_support (Bvect_false k) (bs_support k))
 (fun v1 => mu (sum_support (Bvect_false p) (bs_support p))
  (fun v2 => f (Vextend bool k p v1 v2))).
Proof.
 intros; apply Oeq_trans with
  (finite_sum
   (fun v1 => finite_sum
    (fun a  => [1/]1+pred (length (bs_support (k+p))) * f (Vextend bool k p v1 a))
    (bs_support p)) (bs_support k)).
 change  (mu (sum_support (Bvect_false (k + p)) (bs_support (k + p))) f) with
  (sum_dom (Bvect_false (k + p)) (bs_support (k + p)) f).
 rewrite sum_dom_finite.
 fold (Bvector (k+p)); generalize k p (length (bs_support (k + p))) f; clear k p f.
 induction k; simpl; intros.
 Usimpl; apply finite_sum_Perm.
 apply PermutP_refl; intros; trivial.
 repeat rewrite finite_sum_app.
 repeat rewrite finite_sum_map.
 repeat rewrite IHk; trivial.
 change
  (mu (sum_support (Bvect_false k) (bs_support k))
   (fun v1 : vector bool k =>
    mu (sum_support (Bvect_false p) (bs_support p))
    (fun v2 : vector bool p => f (Vextend bool k p v1 v2)))) with
  (sum_dom (Bvect_false k) (bs_support k)
   (fun v1 : vector bool k =>
    sum_dom (Bvect_false p) (bs_support p)
    (fun v2 : vector bool p => f (Vextend bool k p v1 v2)))).
 rewrite sum_dom_finite.
 apply finite_sum_Perm; apply PermutP_refl. intros v1 _.
 rewrite <- (sum_dom_stable_mult (Bvect_false p) (bs_support p) ([1/]1+pred (length (bs_support k)))).
 unfold fmult; rewrite sum_dom_finite.
 apply finite_sum_Perm; apply PermutP_refl; intros v2 _.
 rewrite Umult_assoc, Unth_prod.
 apply Umult_eq_compat_left.
 fold Bvector; rewrite <- (S_pred (length (bs_support p)) 0).
 rewrite <- (S_pred (length (bs_support k)) 0).
 rewrite mult_comm, bs_length_add; trivial.
 generalize (@bs_support_not_nil k); destruct (bs_support k); simpl; intros; auto with arith.
 elim H; trivial.
 generalize (@bs_support_not_nil p); destruct (bs_support p); simpl; intros; auto with arith.
 elim H; trivial.
Qed.

Lemma full_support : forall k (bs:Bvector k), In bs (bs_support k).
Proof.
 induction bs.
 left; trivial.
 simpl; apply in_or_app.
 destruct a;[right | left]; rewrite in_map_iff; exists bs; auto.
Qed.

Lemma bs_support_NoDup : forall k, NoDup (bs_support k).
Proof.
 induction k; simpl.
 constructor.
 intro; simpl; trivial.
 constructor.
 apply NoDup_app.
 apply NoDup_map_inj; intros; trivial.
 change (Vtail _ _ (Vcons bool false k x) = Vtail _ _ (Vcons bool false k y)).
 rewrite H1; trivial.
 apply NoDup_map_inj; intros; trivial.
 change (Vtail _ _ (Vcons bool true k x) = Vtail _ _ (Vcons bool true k y)).
 rewrite H1; trivial.
 intros; intro.
 rewrite in_map_iff in H, H0.
 destruct H as (y1, (Heq1, _)); destruct H0 as (y2, (Heq2, _)); subst.
 inversion Heq2.
Qed.

Section FINV_SPEC.

 Variables (T : Type) (f f_inv : T -> T) (d : list T).

 Hypothesis f_perm :  PermutP (@eq _) d (map f d).

 Hypothesis f_spec : forall x, f_inv (f x) = x.

 Lemma f_inv_spec : forall x, In x d -> f (f_inv x) = x.
 Proof.
  intros.
  assert (In x (map f d)).
  apply PermutP_In with (d1:=d); trivial.
  rewrite in_map_iff in H0.
  destruct H0 as [y [Hy _] ].
  rewrite <- Hy, f_spec; trivial.
 Qed.

End FINV_SPEC.

Section FINV_SPEC_BS.

 Variables (k : nat) (f f_inv : Bvector k -> Bvector k).

 Hypothesis f_perm : PermutP (@eq _) (bs_support k) (map f (bs_support k)).

 Hypothesis f_spec : forall x, f_inv (f x) = x.

 Lemma f_inv_spec_bs : forall x, f (f_inv x) = x.
 Proof.
  intros; apply f_inv_spec with (1:= f_perm); trivial.
  apply full_support.
 Qed.

End FINV_SPEC_BS.

(* Lemmas about [BVxor] *)
Lemma BVxor_comm : forall n v1 v2, BVxor n v1 v2 = BVxor n v2 v1.
Proof.
 intros; rewrite <- Ndigits.N2Bv_Bv2N, Ndigits.Nxor_BVxor, Ndigits.Nxor_comm.
 rewrite <- Ndigits.Nxor_BVxor, Ndigits.N2Bv_Bv2N; trivial.
Qed.

Lemma BVxor_assoc : forall n v1 v2 v3, BVxor n (BVxor n v1 v2) v3 = BVxor n v1 (BVxor n v2 v3).
Proof.
 intros; do 2 rewrite <- Ndigits.N2Bv_Bv2N, Ndigits.Nxor_BVxor.
 rewrite <- Ndigits.Nxor_assoc.
 do 2 rewrite <- Ndigits.Nxor_BVxor, Ndigits.N2Bv_Bv2N; trivial.
Qed.

Lemma Bv2N_Bvect_false : forall n, Ndigits.Bv2N _ (Bvect_false n) = N0.
Proof.
 induction n; simpl; trivial.
 unfold Bvect_false in IHn.
 rewrite IHn; trivial.
Qed.

Lemma BVxor_nilpotent : forall n v, BVxor n v v = Bvect_false n.
Proof.
 intros.
 rewrite <- Ndigits.N2Bv_Bv2N; symmetry; rewrite <- Ndigits.N2Bv_Bv2N, Ndigits.Nxor_BVxor.
 rewrite Ndigits.Nxor_nilpotent,Bv2N_Bvect_false; trivial.
Qed.

Lemma BVxor_0_l : forall n v, BVxor n (Bvect_false n) v = v.
Proof.
 intros; symmetry; rewrite <- Ndigits.N2Bv_Bv2N, Ndigits.Nxor_BVxor.
 rewrite Bv2N_Bvect_false,Ndigits.Nxor_neutral_left.
 symmetry; apply Ndigits.N2Bv_Bv2N.
Qed.

Lemma BVxor_0_r : forall n v, BVxor n v (Bvect_false n) = v.
Proof.
 intros; symmetry; rewrite <- Ndigits.N2Bv_Bv2N, Ndigits.Nxor_BVxor.
 rewrite Bv2N_Bvect_false,Ndigits.Nxor_neutral_right.
 symmetry; apply Ndigits.N2Bv_Bv2N.
Qed.

Lemma BVxor_bij : forall n (v x : vector bool n), BVxor n (BVxor n x v) v = x.
Proof.
 intros; rewrite BVxor_assoc, BVxor_nilpotent, BVxor_0_r; trivial.
Qed.

Lemma bs_support_length : forall k, length (bs_support k) = (2 ^ k)%nat.
Proof.
 induction k; simpl; trivial.
 rewrite app_length, map_length, map_length.
 unfold Bvector in *; rewrite IHk; ring.
Qed.

Lemma bs_support_pow : forall k,
 [1/]1+pred (length (bs_support k)) == [1/2]^k.
Proof.
 intros; rewrite bs_support_length.
 symmetry; apply Unth_pow.
Qed.

Lemma Pr_bs_support : forall k (default v:Bvector k) f,
 (forall x, x <> v -> f v x == 0) ->
 f v v == 1 ->
 mu (sum_support default (bs_support k)) (f v) == [1/2]^k.
Proof.
 Opaque sum_dom.
 intros; simpl.
 rewrite (sum_dom_finite default (bs_support k) (f v)).
 rewrite (@finite_sum_full _ v).
 rewrite H0; Usimpl; apply bs_support_pow.
 intros; rewrite H; auto.
 apply full_support.
 apply bs_support_NoDup.
Qed.

Module NatDec.

 Definition U := nat.

 Lemma eq_dec : forall x y:U, {x = y} + {x <> y}.
 Proof.
  unfold U; auto with arith.
 Qed.

End NatDec.

Module NatEqDep := DecidableEqDep NatDec.

(** Lemmas about [Vextend] (concatenation of bitstrings) *)
Transparent Vextend.

Lemma Vextend_inj : forall n p (v1 v2 : vector bool n) (w1 w2 : vector bool p),
 Vextend bool n p v1 w1 = Vextend bool n p v2 w2 ->
 v1 = v2 /\ w1 = w2.
Proof.
 induction n; intros p v1 v2 w1 w2.
 rewrite (V0_eq bool v1), (V0_eq bool v2); simpl; auto.
 rewrite (VSn_eq bool n v1), (VSn_eq bool n v2); simpl; intros.
 injection H; clear H; intros.
 rewrite H0.
 destruct (IHn p (Vtail bool n v1)(Vtail bool n v2) w1 w2).
 rewrite (NatEqDep.inj_pairT2 _ _ _ _ H); trivial.
 rewrite H1, H2; auto.
Qed.

Lemma PermutP_bs_support_xor : forall n v,
 PermutP (fun v1 v2 => v1 = BVxor n v2 v) (bs_support n) (bs_support n).
Proof.
 intros; apply PermutP_NoDup with (f_inv := fun v2 => BVxor n v2 v); intros.
 apply bs_support_NoDup.
 apply bs_support_NoDup.
 apply BVxor_bij.
 apply BVxor_bij.
 apply full_support.
 apply full_support.
Qed.

Opaque BVxor Vextend bs_support.


(** * POPLmark Part 1a + 2a

    The #POPLmark#
    challenge is a set of benchmark problems to evaluate approaches to the
    formalization of syntactic theories. We solve parts 1a and 2a, that is,
    progress and preservation of System F with subtyping.

    The formalization in this file does not follow the paper proofs as closely,
    and in particular does not contain well-formedness assumptions.
 *)

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import AutosubstSsr Context.

(** **** Syntax *)

Inductive type : Type :=
| TyVar (x : var)
| Top
| Arr (A1 A2 : type)
| All (A1 : type) (A2 : {bind type}).

Inductive term :=
| TeVar (x : var)
| Abs (A : type) (s : {bind term})
| App (s t : term)
| TAbs (A : type) (s : {bind type in term})
| TApp (s : term) (A : type).

(** **** Substitutions *)

Instance Ids_type : Ids type. derive. Defined.
Instance Rename_type : Rename type. derive. Defined.
Instance Subst_type : Subst type. derive. Defined.
Instance SubstLemmas_type : SubstLemmas type. derive. Qed.
Instance HSubst_term : HSubst type term. derive. Defined.
Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.
Instance HSubstLemmas_term : HSubstLemmas type term. derive. Qed.
Instance SubstHSubstComp_type_term : SubstHSubstComp type term. derive. Qed.
Instance SubstLemmas_term : SubstLemmas term. derive. Qed.

(** **** Subtyping *)

Notation "Gamma `_ x" := (dget Gamma x) (at level 2).
Notation "Gamma ``_ x" := (get Gamma x) (at level 3, x at level 2,
  left associativity, format "Gamma ``_ x").

Reserved Notation "'SUB' Gamma |- A <: B"
  (at level 68, A at level 99, no associativity).
Inductive sub (Gamma : list type) : type -> type -> Prop :=
| sub_top A :
    SUB Gamma |- A <: Top
| sub_var_refl x :
    SUB Gamma |- TyVar x <: TyVar x
| sub_var_trans x A :
    x < size Gamma -> SUB Gamma |- Gamma`_x <: A -> SUB Gamma |- TyVar x <: A
| sub_fun A1 A2 B1 B2 :
    SUB Gamma |- B1 <: A1 -> SUB Gamma |- A2 <: B2 ->
    SUB Gamma |- Arr A1 A2 <: Arr B1 B2
| sub_all A1 A2 B1 B2 :
    SUB Gamma |- B1 <: A1 -> SUB (B1 :: Gamma) |- A2 <: B2 ->
    SUB Gamma |- All A1 A2 <: All B1 B2
where "'SUB' Gamma |- A <: B" := (sub Gamma A B).

Lemma sub_refl Gamma A : SUB Gamma |- A <: A.
Proof. elim: A Gamma; eauto using sub. Qed.
Hint Resolve sub_refl.

Lemma sub_ren Gamma Delta xi A B :
  (forall x, x < size Gamma -> xi x < size Delta) ->
  (forall x, x < size Gamma -> Delta`_(xi x) = (Gamma`_x).[ren xi]) ->
  SUB Gamma |- A <: B -> SUB Delta |- A.[ren xi] <: B.[ren xi].
Proof.
  move=> sub eqn ty. elim: ty Delta xi sub eqn => {Gamma A B} Gamma //=;
    eauto using sub.
  - move=> x A lt _ ih Delta xi sub eqn. apply: sub_var_trans. exact: sub.
    rewrite eqn //. exact: ih.
  - move=> A1 A2 B1 B2 _ ih1 _ ih2 Delta xi sub eqn. apply: sub_all.
    exact: ih1. asimpl. apply: ih2. by move=> [|x /sub].
    move=> [_|x /eqn/=->]; autosubst.
Qed.

Lemma sub_weak Gamma A B C :
  SUB Gamma |- A <: B -> SUB (C :: Gamma) |- A.[ren (+1)] <: B.[ren (+1)].
Proof. exact: sub_ren. Qed.

Definition transitivity_at (B : type) := forall Gamma A C xi,
  SUB Gamma |- A <: B.[ren xi] -> SUB Gamma |- B.[ren xi] <: C ->
  SUB Gamma |- A <: C.

Lemma transitivity_proj Gamma A B C :
  transitivity_at B ->
  SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof. move=> /(_ Gamma A C id). autosubst. Qed.
Hint Resolve transitivity_proj.

Lemma transitivity_ren B xi : transitivity_at B -> transitivity_at B.[ren xi].
Proof. move=> h Gamma A C zeta. asimpl. exact: h. Qed.

Lemma sub_narrow_t Gamma Delta A B :
  (forall x, x < size Gamma -> x < size Delta) ->
  (forall x, x < size Gamma -> SUB Delta |- Delta`_x <: Gamma`_x) ->
  (forall x, x < size Gamma ->
    Delta`_x = Gamma`_x \/ transitivity_at (Gamma`_x)) ->
  SUB Gamma |- A <: B -> SUB Delta |- A <: B.
Proof with eauto using sub.
  move=> h1 h2 h3 ty. elim: ty Delta h1 h2 h3 => {Gamma A B} /=...
  - move=> Gamma x A lt _ ih Delta h1 h2 h3. apply: sub_var_trans...
    case: (h3 x lt) => [->|]...
  - move=> Gamma A1 A2 B1 B2 _ ih1 _ ih2 Delta h1 h2 h3. apply: sub_all...
    apply: ih2 => [[|x /h1]|[|x /h2/sub_weak]|[_|x /h3[|]]] //=...
    move=>->... move=> tr. right. exact: transitivity_ren.
Qed.

Definition is_var (A : type) : bool := if A is TyVar _ then true else false.

Lemma sub_trans_snoc Gamma B C :
  (forall A, ~~is_var A ->
    SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C) ->
  forall A, SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof with eauto using sub.
  move=> h A ty. elim: ty C h =>{Gamma A B}... move=> Gamma A C h1 h2. inv h2...
Qed.

Lemma sub_trans_t B : transitivity_at B.
Proof with eauto using sub.
  elim: B => [x||B1 ih1 B2 ih2|B1 ih1 B2 ih2] Gamma A C xi; asimpl...
  - apply: sub_trans_snoc A => A e ty. by inv ty.
  - move=> t1 t2. inv t2...
  - apply: sub_trans_snoc A => A e ty1 ty2. inv ty1 => //. inv ty2...
  - apply: sub_trans_snoc A => A e ty1 ty2. inv ty1 => //. inv ty2...
    apply: sub_all... eapply ih2... move: H3. apply: sub_narrow_t...
    + case=> //= _. exact: sub_weak.
    + move=> [|x] _... right => /=. asimpl. exact: transitivity_ren.
Qed.

Corollary sub_trans Gamma A B C :
  SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof. move: (sub_trans_t B); eauto. Qed.

Corollary sub_narrow Gamma A B C1 C2 :
  SUB Gamma |- C1 <: C2 -> SUB C2 :: Gamma |- A <: B ->
  SUB C1 :: Gamma |- A <: B.
Proof.
  move=> ty. apply: sub_narrow_t => //.
  - case=> //= _. exact: sub_weak.
  - move=> [_/=|x]; eauto. right. apply: transitivity_ren. exact: sub_trans_t.
Qed.

Lemma sub_subst Gamma Delta A B sigma :
  (forall x, x < size Gamma -> SUB Delta |- sigma x <: (Gamma`_x).[sigma]) ->
  SUB Gamma |- A <: B -> SUB Delta |- A.[sigma] <: B.[sigma].
Proof with eauto using sub.
  move=> h ty. elim: ty Delta sigma h => {Gamma A B} Gamma...
  - move=> x A lt _ ih Delta sigma h /=. apply: sub_trans (h _ lt) _. exact: ih.
  - move=> A1 A2 B1 B2 _ ih1 _ ih2 Delta sigma h /=. apply: sub_all...
    apply: ih2 => -[_|x /h/sub_weak]. apply: sub_var_trans => //. autosubst.
    autosubst.
Qed.

(** **** Typing *)

Reserved Notation "'TY' Delta ; Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Delta ; Gamma  |-  A  :  B").
Inductive ty (Delta Gamma : list type) : term -> type -> Prop :=
| ty_var x :
    x < size Gamma ->
    TY Delta;Gamma |- TeVar x : Gamma``_x
| ty_abs A B s :
    TY Delta;A::Gamma |- s : B ->
    TY Delta;Gamma |- Abs A s : Arr A B
| ty_app A B s t:
    TY Delta;Gamma |- s : Arr A B -> TY Delta;Gamma |- t : A ->
    TY Delta;Gamma |- App s t : B
| ty_tabs A B s :
    TY A::Delta;Gamma..[ren (+1)] |- s : B ->
    TY Delta;Gamma |- TAbs A s : All A B
| ty_tapp A B C s :
    TY Delta;Gamma |- s : All A B -> SUB Delta |- C <: A ->
    TY Delta;Gamma |- TApp s C : B.[C/]
| ty_sub A B s :
    TY Delta;Gamma |- s : A -> SUB Delta |- A <: B ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (ty Delta Gamma s A).

Definition value (s : term) : bool :=
  match s with Abs _ _ | TAbs _ _ => true | _ => false end.

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'   s  =>  t").
Inductive eval : term -> term -> Prop :=
| E_AppAbs A s t : EV App (Abs A s) t => s.[t/]
| E_TAppTAbs A s B : EV TApp (TAbs A s) B => s.|[B/]
| E_AppFun s s' t :
     EV s => s' ->
     EV App s t => App s' t
| E_AppArg s s' v:
     EV s => s' -> value v ->
     EV App v s => App v s'
| E_TypeFun s s' A :
     EV s => s' ->
     EV TApp s A => TApp s' A
where "'EV' s => t" := (eval s t).

Lemma ty_evar Delta Gamma x A :
  A = Gamma``_x -> x < size Gamma -> TY Delta;Gamma |- TeVar x : A.
Proof. move->. exact: ty_var. Qed.

Lemma ty_etapp Delta Gamma A B C D s :
  D = B.[C/] ->
  TY Delta;Gamma |- s : All A B -> SUB Delta |- C <: A ->
  TY Delta;Gamma |- TApp s C : D.
Proof. move->. exact: ty_tapp. Qed.

(** **** Preservation *)

Lemma ty_ren Delta Gamma1 Gamma2 s A xi :
  (forall x, x < size Gamma1 -> xi x < size Gamma2) ->
  (forall x, x < size Gamma1 -> Gamma2``_(xi x) = Gamma1``_x) ->
  TY Delta;Gamma1 |- s : A -> TY Delta;Gamma2 |- s.[ren xi] : A.
Proof with eauto using ty.
  move=> h1 h2 ty. elim: ty Gamma2 xi h1 h2 => {Delta Gamma1 s A} /=...
  - move=> Delta Gamma1 x lt Gamma2 xi h1 h2. rewrite -h2 //. apply: ty_var...
  - move=> Delta Gamma1 A B s _ ih Gamma2 xi h1 h2. asimpl. apply: ty_abs.
    by apply: ih => [[|x/h1]|[|x/h2]].
  - move=> Delta Gamma1 A B s _ ih Gamma2 xi h1 h2. apply: ty_tabs.
    apply: ih => x. by rewrite !size_map => /h1. rewrite !size_map => lt.
    rewrite !get_map ?h2 //. exact: h1.
Qed.

Lemma ty_weak Delta Gamma s A B :
  TY Delta;Gamma |- s : A -> TY Delta; B :: Gamma |- s.[ren (+1)] : A.
Proof. exact: ty_ren. Qed.

Lemma ty_hsubst Delta1 Delta2 Gamma s A sigma :
  (forall x, x < size Delta1 -> SUB Delta2 |- sigma x <: (Delta1`_x).[sigma]) ->
  TY Delta1;Gamma |- s : A -> TY Delta2;Gamma..[sigma] |- s.|[sigma] :A.[sigma].
Proof with eauto using ty.
  move=> h ty. elim: ty Delta2 sigma h => {Delta1 Gamma s A}/=...
  - move=> Delta1 Gamma x lt Delta2 sigma h. apply: ty_evar. by rewrite get_map.
    by rewrite size_map.
  - move=> Delta1 Gamma A B s _ ih Delta2 sigma h. apply: ty_tabs.
    specialize (ih (A.[sigma] :: Delta2) (up sigma)). move: ih. asimpl.
    apply. move=> [_|x/h/sub_weak] /=. apply: sub_var_trans => //. autosubst.
    autosubst.
  - move=> Delta1 Gamma A B C s _ ih sub Delta2 sigma h. asimpl.
    eapply ty_etapp. Focus 2. by eapply ih. autosubst. exact: sub_subst sub.
  - move=> Delta1 Gamma A B s _ ih sub Delta2 sigma h.
    eapply ty_sub. by eapply ih. exact: sub_subst sub.
Qed.

Lemma ty_tweak Delta Gamma s A B :
  TY Delta;Gamma |- s : A ->
  TY B :: Delta; Gamma..[ren (+1)] |- s.|[ren (+1)] : A.[ren (+1)].
Proof. apply: ty_hsubst => x /= lt. exact: sub_var_trans. Qed.

Lemma ty_subst Delta Gamma1 Gamma2 s A sigma :
  (forall x, x < size Gamma1 -> TY Delta;Gamma2 |- sigma x : Gamma1``_x) ->
  TY Delta;Gamma1 |- s : A -> TY Delta;Gamma2 |- s.[sigma] : A.
Proof with eauto using ty.
  move=> h ty. elim: ty Gamma2 sigma h => {Delta Gamma1 s A}/=...
  - move=> Delta Gamma1 A B s _ ih Gamma2 sigma h /=. apply: ty_abs.
    apply: ih. move=> [_|x/h/ty_weak]... autosubst.
  - move=> Delta Gamma1 A B s _ ih Gamma2 sigma h. apply: ty_tabs. apply: ih.
    move=> x. rewrite size_map => lt. rewrite get_map //=. exact/ty_tweak/h.
Qed.

Lemma ty_narrow Delta Gamma s A B1 B2 :
  TY Delta;B2::Gamma |- s : A -> SUB Delta |- B1 <: B2 ->
  TY Delta;B1::Gamma |- s : A.
Proof.
  move=> ty sub. rewrite -[s]subst_id. apply: ty_subst ty => -[_/=|x lt];
    [apply: ty_sub sub|]; exact: ty_var.
Qed.

Lemma ty_beta Delta Gamma s t A B :
  TY Delta;Gamma |- t : A -> TY Delta;A::Gamma |- s : B ->
  TY Delta;Gamma |- s.[t/] : B.
Proof.
  move=> ty. apply: ty_subst => -[|n lt] //=. exact: ty_var.
Qed.

Lemma ty_narrowT Delta Gamma s A B1 B2 :
  TY B2::Delta;Gamma |- s : A -> SUB Delta |- B1 <: B2 ->
  TY B1::Delta;Gamma |- s : A.
Proof.
  move=> ty sub. cut (TY B1::Delta;Gamma..[ids] |- s.|[ids] : A.[ids]).
  autosubst. apply: ty_hsubst ty => -[_|x lt]; asimpl.
  apply: sub_var_trans => //=. exact: sub_weak. exact: sub_var_trans.
Qed.

Lemma ty_betaT Delta Gamma s A B C :
  SUB Delta |- C <: A -> TY A :: Delta;Gamma..[ren (+1)] |- s : B ->
  TY Delta;Gamma |- s.|[C/] : B.[C/].
Proof.
  move=> subt ty.
  cut (TY Delta;Gamma..[ren(+1)]..[C/] |- s.|[C/] : B.[C/]). autosubst.
  apply: ty_hsubst ty => -[_|x lt]; asimpl => //. exact: sub_var_trans.
Qed.

Lemma ty_inv_abs' Delta Gamma A A' B T s :
  TY Delta;Gamma |- Abs A s : T -> SUB Delta |- T <: Arr A' B ->
  TY Delta;A'::Gamma |- s : B.
Proof.
  move e:(Abs A s) => t ty. elim: ty A A' B s e => {Delta Gamma t T} //.
  - move=> Delta Gamma A B s h _ A' A'' B' s' [e1 e2]. subst => sub. inv sub.
    apply: ty_narrow H2. exact: ty_sub h _.
  - move=> Delta Gamma A B s _ ih sub1 A' A'' B' s' eqn sub2. apply: ih eqn _.
    eapply (sub_trans _ _ _ _ sub1 sub2).
Qed.

Lemma ty_inv_abs Delta Gamma A A' B s :
  TY Delta;Gamma |- Abs A s : Arr A' B -> TY Delta;A'::Gamma |- s : B.
Proof. move=> ty. apply: ty_inv_abs' ty _. eapply sub_refl. Qed.

Lemma ty_inv_tabs' Delta Gamma A A' B T s :
  TY Delta;Gamma |- TAbs A s : T -> SUB Delta |- T <: All A' B ->
  TY A'::Delta;Gamma..[ren(+1)] |- s : B.
Proof.
  move e:(TAbs A s) => t ty. elim: ty A A' B s e => {Delta Gamma t T} //.
  - move=> Delta Gamma  A B s ty _ A' A'' B' s' [e1 e2] sub. subst. inv sub.
    apply: ty_sub H4. exact: ty_narrowT ty _.
  - move=> Delta Gamma A B s _ ih sub1 A' A'' B' s' e sub2. apply: ih e _.
    exact: sub_trans sub1 sub2.
Qed.

Lemma ty_inv_tabs Delta Gamma A A' B s :
  TY Delta;Gamma |- TAbs A s : All A' B ->
  TY A'::Delta;Gamma..[ren(+1)] |- s : B.
Proof. move=> ty. exact: ty_inv_tabs' ty _. Qed.

Theorem preservation Delta Gamma s t A :
  TY Delta;Gamma |- s : A -> EV s => t -> TY Delta;Gamma |- t : A.
Proof with eauto using ty.
  move=> ty. elim: ty t => {Delta Gamma s A}...
  - move=> Delta Gamma x _ t ev. by inv ev.
  - move=> Delta Gamma A B s _ i t ev. by inv ev.
  - move=> Delta Gamma A B s t ty1 ih1 ty2 ih2 u ev. inv ev...
    move: ty1 => /ty_inv_abs. exact: ty_beta.
  - move=> Delta Gamma A B s _ _ t ev. by inv ev.
  - move=> Delta Gamma A B C s ty ih sub t ev. inv ev.
    + move: ty => /ty_inv_tabs. exact: ty_betaT.
    + apply: ty_tapp sub. exact: ih.
Qed.

(** **** Progress *)

Definition is_abs s := if s is Abs _ _ then true else false.
Definition is_tabs s := if s is TAbs _ _ then true else false.

Lemma canonical_arr' Delta Gamma s T A B :
  TY Delta;Gamma |- s : T -> SUB Delta |- T <: Arr A B -> value s -> is_abs s.
Proof.
  move=> ty. elim: ty A B => //={Delta Gamma s T} Delta Gamma A B s.
  - move=> ty _ A' B' sub. by inv sub.
  - move=> _ ih /sub_trans h A' B' /h. exact: ih.
Qed.

Lemma canonical_arr Delta Gamma s A B :
  TY Delta;Gamma |- s : Arr A B -> value s -> is_abs s.
Proof.
  move=> ty. apply: canonical_arr' ty (sub_refl _ _).
Qed.

Lemma canonical_all' Delta Gamma s T A B :
  TY Delta;Gamma |- s : T -> SUB Delta |- T <: All A B -> value s -> is_tabs s.
Proof.
  move=> ty. elim: ty A B => //={Delta Gamma s T} Delta Gamma A B s.
  - move=> _ _ A' B' sub. by inv sub.
  - move=> _ ih /sub_trans h A' B' /h. exact: ih.
Qed.

Lemma canonical_all Delta Gamma s A B :
  TY Delta;Gamma |- s : All A B -> value s -> is_tabs s.
Proof.
  move=> ty. apply: canonical_all' ty (sub_refl _ _).
Qed.

Lemma ev_progress' Delta Gamma s A :
  TY Delta;Gamma |- s : A -> Gamma = [::] -> value s \/ exists t, EV s => t.
Proof with eauto using eval.
  elim=> {Delta Gamma s A} /=; try solve [intuition].
  - move=> _ Gamma x lt eqn. by subst.
  - move=> Delta Gamma A B s t ty1 ih1 _ ih2 eqn. right.
    case: (ih1 eqn) => {ih1} [vs|[s' h1]]...
    case: (ih2 eqn) => {ih2 eqn} [vt|[t' h2]]...
    case: s {ty1 vs} (canonical_arr _ _ _ _ _ ty1 vs) => //...
  - move=> Delta Gamma A B C s ty ih sub eqn. right.
    case: (ih eqn) => {ih eqn}[vs|[s' h]]...
    case: s {ty vs} (canonical_all _ _ _ _ _ ty vs) => //...
Qed.

Theorem ev_progress s A:
  TY nil;nil |- s : A -> value s \/ exists t,  EV s => t.
Proof. move=> ty. exact: ev_progress' ty _. Qed.

(* Local Variables: *)
(* coq-load-path: (("." "Ssr") ("../../theories" "Autosubst")) *)
(* End: *)


(* "Todo homem é mortal. Sócrates é um homem. Logo, Sócrates é mortal". *)

Hypothesis U : Set.
Hypothesis Men : U -> Prop.
Hypothesis Mortals : U -> Prop.

Lemma ex12 : (forall man : U, Men man -> Mortals man) -> (forall man : U, Men man) -> (forall man : U, Mortals man).
Proof.
  intro HApq.
  intro HAp.
  intro socrates.
  apply HApq.
  apply HAp.
Qed.