(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import List.

Require Import Cpdt.CpdtTactics.
(* end hide *)

(** These exercises were originally included inline in the text, but my latest feeling is that I don't have the time to maintain the exercises at a sufficient quality level to match the level I'm targetting for the rest of the book.  I'm including them in this file for now. *)

(** * From InductiveTypes *)

(** %\begin{enumerate}%#
#

%\item%#
# Define an inductive type [truth] with three constructors, [Yes], [No], and [Maybe].  [Yes] stands for certain truth, [No] for certain falsehood, and [Maybe] for an unknown situation.  Define %``%#"#not,#"#%''% %``%#"#and,#"#%''% and %``%#"#or#"#%''% for this replacement boolean algebra.  Prove that your implementation of %``%#"#and#"#%''% is commutative and distributes over your implementation of %``%#"#or.#"#%''%#
#
 *)

Module ex1.
Inductive truth : Type := Yes | No | Maybe.

Definition not (a : truth) : truth :=
  match a with
  | Yes => No
  | No => Yes
  | Maybe => Maybe
  end.

Check not Yes.

Definition and (a b : truth) : truth :=
match a with
| Yes => b
| No => match b with
       | Maybe => Maybe
       | _ => No
       end
| Maybe => Maybe
end.

Definition or (a b : truth) : truth :=
  match a with
  | Yes => match b with
          | Maybe => Maybe
          | _ => Yes
          end
  | No => b
  | Maybe => Maybe
  end.

Lemma and_comm : forall (a b : truth), and a b = and b a.
  intros; destruct a, b; auto. Qed.
Lemma or_comm : forall (a b : truth), or a b = or b a.
  intros; destruct a, b; auto. Qed.
Lemma or_distr : forall (a b c : truth), or (and a b) c = and (or a c) (or b c).
  intros; destruct a, b, c; auto. Qed.

End ex1.
(**
%\item%#
# Define an inductive type [slist] that implements lists with support for constant-time concatenation.  This type should be polymorphic in a choice of type for data values in lists.  The type [slist] should have three constructors, for empty lists, singleton lists, and concatenation.  Define a function [flatten] that converts [slist]s to [list]s.  (You will want to run [Require Import] %\coqdocconstructor{%#<tt>#List#</tt>#%}%[.] to bring list definitions into scope.)  Finally, prove that [flatten] distributes over concatenation, where the two sides of your quantified equality will use the [slist] and [list] versions of concatenation, as appropriate.  Recall from Chapter 2 that the infix operator [++] is syntactic sugar for the [list] concatenation function [app].#
#
 *)

Module ex2.
Require Import List.
Set Implicit Arguments.
Inductive slist (X : Type) : Type:=
| s_nil : slist X
| s_singleton : X -> slist X
| s_cons : slist X -> slist X -> slist X.

Fixpoint flattern (X : Type) (sl : slist X) : list X :=
  match sl with
  | @s_nil _ => nil
  | s_singleton a => a::nil
  | s_cons sl1 sl2 => (flattern sl1) ++ (flattern sl2)
  end.
Fixpoint s_app (X : Type) (s1 s2 : slist X) : slist X:=
  match s1 with
  | @s_nil _=> s2
  | s_singleton a' as a => s_cons a s2
  | s_cons a s1' => s_cons a (s_app s1' s2)
  end.
Lemma flattern_distr : forall (X : Type) (a b : slist X), flattern (s_app a b) = (flattern a) ++ (flattern b).
  induction a; intuition.
  - simpl. rewrite <- app_assoc. rewrite <- (IHa2 b). reflexivity. Qed.
End ex2.

(**
%\item%#
# Modify the first example language of Chapter 2 to include variables, where variables are represented with [nat].  Extend the syntax and semantics of expressions to accommodate the change.  Your new [expDenote] function should take as a new extra first argument a value of type [var -> nat], where [var] is a synonym for naturals-as-variables, and the function assigns a value to each variable.  Define a constant folding function which does a bottom-up pass over an expression, at each stage replacing every binary operation on constants with an equivalent constant.  Prove that constant folding preserves the meanings of expressions.#
#
 *)

Module ex3.
Inductive binop : Set := Plus | Times.
Inductive var := vvar : nat-> var.
Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp
| Var : var -> exp.

Definition binopDenote (b : binop) :=
match b with
| Plus => plus
| Times => mult
end.

Fixpoint expDenote (ass : var-> nat) (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => (binopDenote b) (expDenote ass e1) (expDenote ass e2)
  | Var v => ass v
  end.

Fixpoint const_fold (e : exp) : exp:=
  match e with
  | Const n => e
  | Var v => e
  | Binop b e1 e2 => match e1, e2 with
                    | Const n1, Const n2 => Const ((binopDenote b) n1 n2)
                    | _, _ => Binop b (const_fold e1) (const_fold e2)
                    end
  end.

Lemma const_fold_correct : forall (e : exp) (ass : var -> nat), expDenote ass e = expDenote ass (const_fold e).
  induction e; intuition; destruct b; induction e1, e2;
    auto; simpl; f_equal; simpl in *; auto. Qed.
End ex3.

(**
%\item%#
# Reimplement the second example language of Chapter 2 to use mutually inductive types instead of dependent types.  That is, define two separate (non-dependent) inductive types [nat_exp] and [bool_exp] for expressions of the two different types, rather than a single indexed type.  To keep things simple, you may consider only the binary operators that take naturals as operands.  Add natural number variables to the language, as in the last exercise, and add an %``%#"#if#"#%''% expression form taking as arguments one boolean expression and two natural number expressions.  Define semantics and constant-folding functions for this new language.  Your constant folding should simplify not just binary operations (returning naturals or booleans) with known arguments, but also %``%#"#if#"#%''% expressions with known values for their test expressions but possibly undetermined %``%#"#then#"#%''% and %``%#"#else#"#%''% cases.  Prove that constant-folding a natural number expression preserves its meaning.#
#
 *)

Module ex4.
  Require Import Arith.
  Inductive nbinop : Set := NPlus | NTimes.
  Inductive bbinop : Set := TEq | TLt.

  Inductive var : Set := vvar : nat -> var.
  Inductive bool_exp : Set:=
  | BEq : nat -> nat -> bool_exp
  | BLt : nat -> nat -> bool_exp
  | BConst : bool -> bool_exp.

  Inductive nat_exp : Set :=
  | NConst : nat -> nat_exp
  | NBinop : nbinop -> nat_exp -> nat_exp -> nat_exp
  | NVar : var -> nat_exp
  | NIf : bool_exp -> nat_exp -> nat_exp -> nat_exp.

  Definition bbinopDenote bb :=
  match bb with
  | TEq => beq_nat
  | TLt => Nat.leb
  end.

  Definition nbinopDenote nb :=
  match nb with
  | NPlus => plus
  | NTimes => mult
  end.

  Fixpoint bexpDenote (e : bool_exp) : bool :=
    match e with
    | BEq n1 n2 => beq_nat n1 n2
    | BLt n1 n2 => Nat.leb n1 n2
    | BConst b => b
    end.

  Fixpoint nexpDenote (ass : var -> nat) (e : nat_exp) : nat :=
    match e with
    | NConst n1 => n1
    | NBinop b e1 e2 => (nbinopDenote b) (nexpDenote ass e1) (nexpDenote ass e2)
    | NVar v => ass v
    | NIf b e1 e2 => if (bexpDenote b) then (nexpDenote ass e1) else (nexpDenote ass e2)
    end.

  Fixpoint fold_const (e : nat_exp) : nat_exp :=
    match e with
    | NBinop b e1 e2 => match e1, e2 with
                       | NConst n1, NConst n2 => NConst ((nbinopDenote b) n1 n2)
                       | _, _ => NBinop b (fold_const e1) (fold_const e2)
                       end
    | NIf b e1 e2 => if (bexpDenote b) then (fold_const e1) else (fold_const e2)
    | _ => e
    end.

  Lemma fold_const_correct : forall (e : nat_exp) (ass : var-> nat),
      nexpDenote ass e = nexpDenote ass (fold_const e).
    induction e; intuition.
    - destruct n; induction e1, e2; auto; simpl; f_equal; simpl in *; auto.
    - destruct b; try destruct b; auto; simpl; intuition; destruct (n <=? n0);
        destruct (n =? n0); auto. Qed.
End ex4.

(**
%\item%#
# Define mutually inductive types of even and odd natural numbers, such that any natural number is isomorphic to a value of one of the two types.  (This problem does not ask you to prove that correspondence, though some interpretations of the task may be interesting exercises.)  Write a function that computes the sum of two even numbers, such that the function type guarantees that the output is even as well.  Prove that this function is commutative.#
#
 *)

Module ex5.
  Inductive even : Set :=
  | O : even
  | SSe : even -> even.
  Inductive odd : Set :=
  | S : even -> odd.
  Fixpoint add (n m:even) : even :=
    match n with
    | O => m
    | SSe n' => SSe (add n' m)
    end.
  Lemma add_r_O : forall n, n = add n O.
    induction n; simpl; try rewrite <- IHn; auto. Qed.

  Hint Rewrite add_r_O.

  Lemma add_n_SSem : forall n m, add n (SSe m) = SSe (add n m).
    induction n; intros; simpl; try rewrite IHn; auto. Qed.

  Hint Rewrite add_n_SSem.

  Lemma add_comm : forall (n m : even), add n m = add m n.
    induction n; intros; simpl; auto.
    - rewrite <- add_r_O with m. reflexivity.
    - rewrite (add_n_SSem m n). rewrite IHn with m. reflexivity. Qed.

End ex5.

(**
%\item%#
# Using a reflexive inductive definition, define a type [nat_tree] of infinitary trees, with natural numbers at their leaves and a countable infinity of new trees branching out of each internal node.  Define a function [increment] that increments the number in every leaf of a [nat_tree].  Define a function [leapfrog] over a natural [i] and a tree [nt].  [leapfrog] should recurse into the [i]th child of [nt], the [i+1]st child of that node, the [i+2]nd child of the next node, and so on, until reaching a leaf, in which case [leapfrog] should return the number at that leaf.  Prove that the result of any call to [leapfrog] is incremented by one by calling [increment] on the tree.#
#
 *)

Module ex6.
(**
every nat_tree has two constructors:
1. Only a leaf, which take a natural;
2. A function that map naturals to nat_trees.
 *)

  Inductive nat_tree : Type :=
  | Leaf : nat -> nat_tree
  | Branch : (nat -> nat_tree) -> nat_tree.

(**
1. return type must be coinductive type;
2. Guard constraint: all recursive call must be in the constructors.
 *)

  Fixpoint increment (t : nat_tree) : nat_tree :=
    match t with
    | Leaf n => Leaf (n+1)
    | Branch f => Branch (fun n => increment (f n))
    end.

  Fixpoint leapfrog (i : nat) (t : nat_tree) : nat :=
    match t with
    | Leaf n => n
    | Branch f => leapfrog (i+1) (f i)
    end.

  Lemma leapfrog_increment : forall (t : nat_tree) (i : nat),
      leapfrog i (increment t) = leapfrog i t + 1.
    induction t; simpl; auto. Qed.
End ex6.

(**
%\item%#
# Define a type of trees of trees of trees of (repeat to infinity).  That is, define an inductive type [trexp], whose members are either base cases containing natural numbers or binary trees of [trexp]s.  Base your definition on a parameterized binary tree type [btree] that you will also define, so that [trexp] is defined as a nested inductive type.  Define a function [total] that sums all of the naturals at the leaves of a [trexp].  Define a function [increment] that increments every leaf of a [trexp] by one.  Prove that, for all [tr], [total (increment tr) >= total tr].  On the way to finishing this proof, you will probably want to prove a lemma and add it as a hint using the syntax [Hint Resolve name_of_lemma.].#
#
 *)

Module ex7.

  Require Import Arith Bool.
  Inductive trexp : Type :=
  | Leaf : nat -> trexp
  | Bin : trexp -> trexp -> trexp.

  Fixpoint total (t : trexp) : nat :=
    match t with
    | Leaf n => n
    | Bin t1 t2 => (total t1) + (total t2)
    end.

  Fixpoint increment (t : trexp) : trexp :=
    match t with
    | Leaf n => Leaf (n+1)
    | Bin t1 t2 => Bin (increment t1) (increment t2)
    end.

  Lemma le_n_1_n : forall (n : nat), n + 1 = S n.
    induction n; simpl; auto. Qed.

  Hint Resolve le_n_1_n.

  Lemma total_increment_add : forall (t : trexp), total (increment t) >= total t.
    induction t; simpl; auto. rewrite (le_n_1_n n). auto.
    apply plus_le_compat; assumption. Qed.

(**
%\item%#
# Prove discrimination and injectivity theorems for the [nat_btree] type defined earlier in this chapter.  In particular, without using the tactics [discriminate], [injection], or [congruence], prove that no leaf equals any node, and prove that two equal nodes carry the same natural number.#
#
 *)

    Lemma inj_leaf_node : forall (n : nat) (t1 t2 : trexp), Leaf n <> Bin t1 t2.
    intros; unfold not; intros; inversion H. Qed.

  Fixpoint nat_in_tree (n : nat) (t : trexp) : bool :=
    match t with
    | Leaf n' => beq_nat n n'
    | Bin t1 t2 => orb (nat_in_tree n t1) (nat_in_tree n t2)
    end.
  Lemma node_equal : forall (t1 t2 : trexp), t1 = t2 -> (forall n : nat, nat_in_tree n t1 = nat_in_tree n t2).
    induction t1, t2; intros; inversion H; simpl; auto. Qed.
End ex7.

(**
#
#%\end{enumerate}% *)

(** * From Predicates *)

(** %\begin{enumerate}%#
#

%\item%#
# Prove these tautologies of propositional logic, using only the tactics [apply], [assumption], %\coqdockw{%#<tt>#constructor#</tt>#%}%, [destruct], [intro], [intros], %\coqdockw{%#<tt>#left#</tt>#%}%, %\coqdockw{%#<tt>#right#</tt>#%}%, [split], and [unfold].
  %\begin{enumerate}%#
#
    %\item%#
# [(][True \/ False) /\ (][False \/ True)]#
#
    %\item%#
# [P -> ~ ~ P]#
#
    %\item%#
# [P /\ (][Q \/ R) -> (][P /\ Q) \/ (][P /\ R)]#
#
  #

#%\end{enumerate}%
 *)

Module ex8.
  Lemma ex1 : (True \/ False ) /\ ( False \/ True ).
    split; [ left | right ]; constructor. Qed.

  Lemma ex2 : forall P : Prop, P -> ~ ~ P.
    unfold not; intros;
      match goal with
      | [ H: _ |- False ] => apply H
      end; assumption. Qed.

  Lemma ex3 : forall (P Q R : Prop), P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R).
    intros P Q R H; destruct H;
      match goal with
      | [ H : ?H1 \/ ?H2 |- _ ] => destruct H
      end; [left | right]; split; repeat assumption. Qed.
End ex8.

(**
  %\item%#
# Prove the following tautology of first-order logic, using only the tactics [apply], [assert], [assumption], [destruct], [eapply], %\coqdockw{%#<tt>#eassumption#</tt>#%}%, and %\coqdockw{%#<tt>#exists#</tt>#%}%.  You will probably find the [assert] tactic useful for stating and proving an intermediate lemma, enabling a kind of %``%#"#forward reasoning,#"#%''% in contrast to the %``%#"#backward reasoning#"#%''% that is the default for Coq tactics.  The tactic %\coqdockw{%#<tt>#eassumption#</tt>#%}% is a version of [assumption] that will do matching of unification variables.  Let some variable [T] of type [Set] be the set of individuals.  [x] is a constant symbol, [p] is a unary predicate symbol, [q] is a binary predicate symbol, and [f] is a unary function symbol.
%\begin{enumerate}%#
#
    %\item%#
# [p x -> (][forall x, p x -> exists y, q x y) -> (][forall x y, q x y -> q y (f y)) -> exists z, q z (f z)]#
#
  #

#%\end{enumerate}%
 *)

Module ex9.
  Lemma ex1 : forall (T : Type) p q f (x y z : T),
    p x -> (forall x, p x -> exists y, q x y) ->
    (forall x y, q x y -> q y (f y)) ->
    exists z, q z (f z).
    intros. destruct (H x). assumption.
    exists x0. eapply H0. eassumption. Qed.
End ex9.

(**
%\item%#
# Define an inductive predicate capturing when a natural number is an integer multiple of either 6 or 10.  Prove that 13 does not satisfy your predicate, and prove that any number satisfying the predicate is not odd.  It is probably easiest to prove the second theorem by indicating %``%#"#odd-ness#"#%''% as equality to [2 * n + 1] for some [n].#
#
 *)

Module ex10.
  Inductive six : nat -> Prop :=
  | six_O : six O
  | sixS : forall n, six n -> six (S (S (S (S (S (S n)))))).
  Inductive ten : nat -> Prop :=
  | ten_O : ten O
  | tenS : forall n, ten n -> ten (S (S (S (S (S (S (S (S (S (S n)))))))))).

  Inductive six_ten : nat -> Prop :=
  | Six : forall n, six n -> six_ten n
  | Ten : forall n, ten n -> six_ten n.

  Ltac finisher :=
    unfold not; intros H; inversion H; subst;
    repeat match goal with
           | [ H: six _ |- _ ] => inversion H; subst
           | [ H: ten _ |- _ ] => inversion H; subst
           end.
  Lemma not_13_six_tem : ~ ( six_ten 13).
    finisher. Qed.

  Require Import Arith Plus Nat.

  Lemma six_ten_not_odd : forall n, six_ten n -> (odd n = false).
    assert (H1 : forall n, six n -> (odd n = false)).
    { intros n H; induction H; auto. }
    assert (H2 : forall n, ten n -> (odd n = false)).
    { intros n H; induction H; auto. }
    intros n H; destruct H; auto. Qed.
End ex10.

(**
%\item%#
# Define a simple programming language, its semantics, and its typing rules, and then prove that well-typed programs cannot go wrong.  Specifically:
  %\begin{enumerate}%#
#
    %\item%#
# Define [var] as a synonym for the natural numbers.#
#
    %\item%#
# Define an inductive type [exp] of expressions, containing natural number constants, natural number addition, pairing of two other expressions, extraction of the first component of a pair, extraction of the second component of a pair, and variables (based on the [var] type you defined).#
#
    %\item%#
# Define an inductive type [cmd] of commands, containing expressions and variable assignments.  A variable assignment node should contain the variable being assigned, the expression being assigned to it, and the command to run afterward.#
#
    %\item%#
# Define an inductive type [val] of values, containing natural number constants and pairings of values.#
#
    %\item%#
# Define a type of variable assignments, which assign a value to each variable.#
#
    %\item%#
# Define a big-step evaluation relation [eval], capturing what it means for an expression to evaluate to a value under a particular variable assignment.  %``%#"#Big step#"#%''% means that the evaluation of every expression should be proved with a single instance of the inductive predicate you will define.  For instance, %``%#"#[1 + 1] evaluates to [2] under assignment [va]#"#%''% should be derivable for any assignment [va].#
#
    %\item%#
# Define a big-step evaluation relation [run], capturing what it means for a command to run to a value under a particular variable assignment.  The value of a command is the result of evaluating its final expression.#
#
    %\item%#
# Define a type of variable typings, which are like variable assignments, but map variables to types instead of values.  You might use polymorphism to share some code with your variable assignments.#
#
    %\item%#
# Define typing judgments for expressions, values, and commands.  The expression and command cases will be in terms of a typing assignment.#
#
    %\item%#
# Define a predicate [varsType] to express when a variable assignment and a variable typing agree on the types of variables.#
#
    %\item%#
# Prove that any expression that has type [t] under variable typing [vt] evaluates under variable assignment [va] to some value that also has type [t] in [vt], as long as [va] and [vt] agree.#
#
    %\item%#
# Prove that any command that has type [t] under variable typing [vt] evaluates under variable assignment [va] to some value that also has type [t] in [vt], as long as [va] and [vt] agree.#
#
  #

#%\end{enumerate}%
  A few hints that may be helpful:
  %\begin{enumerate}%#
#
    %\item%#
# One easy way of defining variable assignments and typings is to define both as instances of a polymorphic map type.  The map type at parameter [T] can be defined to be the type of arbitrary functions from variables to [T].  A helpful function for implementing insertion into such a functional map is [eq_nat_dec], which you can make available with [Require Import Arith.].  [eq_nat_dec] has a dependent type that tells you that it makes accurate decisions on whether two natural numbers are equal, but you can use it as if it returned a boolean, e.g., [if eq_nat_dec n m then E1 else E2].#
#
    %\item%#
# If you follow the last hint, you may find yourself writing a proof that involves an expression with [eq_nat_dec] that you would like to simplify.  Running [destruct] on the particular call to [eq_nat_dec] should do the trick.  You can automate this advice with a piece of Ltac: [[
match goal with
  | [ |- context[eq_nat_dec ?X ?Y] ] => destruct (eq_nat_dec X Y)
end
]]
    #
#
    %\item%#
# You probably do not want to use an inductive definition for compatibility of variable assignments and typings.#
#
    %\item%#
# The [CpdtTactics] module from this book contains a variant [crush'] of [crush].  [crush'] takes two arguments.  The first argument is a list of lemmas and other functions to be tried automatically in %``%#"#forward reasoning#"#%''% style, where we add new facts without being sure yet that they link into a proof of the conclusion.  The second argument is a list of predicates on which inversion should be attempted automatically.  For instance, running [crush' (lemma1, lemma2) pred] will search for chances to apply [lemma1] and [lemma2] to hypotheses that are already available, adding the new concluded fact if suitable hypotheses can be found.  Inversion will be attempted on any hypothesis using [pred], but only those inversions that narrow the field of possibilities to one possible rule will be kept.  The format of the list arguments to [crush'] is that you can pass an empty list as [tt], a singleton list as the unadorned single element, and a multiple-element list as a tuple of the elements.#
#
    %\item%#
# If you want [crush'] to apply polymorphic lemmas, you may have to do a little extra work, if the type parameter is not a free variable of your proof context (so that [crush'] does not know to try it).  For instance, if you define a polymorphic map insert function [assign] of some type [forall T : Set, ...], and you want particular applications of [assign] added automatically with type parameter [U], you would need to include [assign] in the lemma list as [assign U] (if you have implicit arguments off) or [assign (T := U)] or [@assign U] (if you have implicit arguments on).#
#
  #

#%\end{enumerate}%

#
#

#
#%\end{enumerate}% *)

Module ex11.
  Definition var := nat.

  Inductive exp : Type :=
  | Const : nat -> exp
  | Plus : nat -> nat -> exp
  | Pair : exp -> exp -> exp
  | Fst : exp -> exp
  | Snd : exp -> exp
  | Var : var -> exp.

  Inductive cmd : Type :=
  | Cmd : var -> exp -> cmd.

  Inductive val : Type :=
  | NumVal : nat -> val
  | PairVar : val -> val -> val.

  Inductive ass : Type :=
  | Ass : var -> exp -> ass.

End ex11.

(** * From Coinductive *)

(** %\begin{enumerate}%#
#

%\item%#
# %\begin{enumerate}%#
#
  %\item%#
# Define a co-inductive type of infinite trees carrying data of a fixed parameter type.  Each node should contain a data value and two child trees.#
#
  %\item%#
# Define a function [everywhere] for building a tree with the same data value at every node.#
#
  %\item%#
# Define a function [map] for building an output tree out of two input trees by traversing them in parallel and applying a two-argument function to their corresponding data values.#
#
  %\item%#
# Define a tree [falses] where every node has the value [false].#
#
  %\item%#
# Define a tree [true_false] where the root node has value [true], its children have value [false], all nodes at the next have the value [true], and so on, alternating boolean values from level to level.#
#
  %\item%#
# Prove that [true_false] is equal to the result of mapping the boolean %``%#"#or#"#%''% function [orb] over [true_false] and [falses].  You can make [orb] available with [Require Import Bool.].  You may find the lemma [orb_false_r] from the same module helpful.  Your proof here should not be about the standard equality [=], but rather about some new equality relation that you define.#
#
#
#%\end{enumerate}% #
#

#
#%\end{enumerate}% *)

Module ex12.
  CoInductive cotree (X : Type) : Type :=
  | Node : X -> cotree X -> cotree X -> cotree X.

  CoFixpoint everywhere (X : Type) (a : X) : cotree X :=
    Node X a (everywhere X a) (everywhere X a).

  CoFixpoint map (X : Type) (Y : Type) (f : X -> X -> Y) (t1 t2 : cotree X) : cotree Y :=
    match t1, t2 with
    | Node _ a1 t11 t12, Node _ a2 t21 t22 =>
      Node Y (f a1 a2) (map X Y f t11 t21) (map X Y f t12 t22)
    end.

  Definition falses := everywhere _ false.

  CoFixpoint true_false :=
    Node _ true false_true false_true
  with false_true :=
         Node _ false true_false true_false.

  CoInductive co_equal (X : Type)  : cotree X -> cotree X -> Prop:=
  | Eq : forall l1 l2 r1 r2 e1 e2,
      co_equal X l1 l2 ->
      co_equal X r1 r2 -> e1 = e2 ->
      co_equal X (Node _ e1 l1 r1) (Node _ e2 l2 r2).
  Lemma orb_false_r : forall x, orb x false = x.
    intros; destruct x; auto. Qed.
  Hint Resolve orb_false_r.

  Definition frob (X : Type) (t : cotree X) :=
  match t with
  | Node _ a t1 t2 => Node _ a t1 t2
  end.

  Lemma frob_eq : forall (X : Type) (t : cotree X), t = frob _ t.
    destruct t; auto. Qed.

  Hint Resolve frob_eq.

(**
The next Lemma if very important, a little difficult.
 *)

  Lemma f : co_equal _ true_false (map _ _ orb true_false falses).
    cofix. rewrite (frob_eq _ (map bool bool orb true_false falses)),
           (frob_eq _ true_false). simpl. constructor; try reflexivity.
    rewrite (frob_eq _ (map bool bool orb false_true (everywhere bool false))),
    (frob_eq _ false_true); simpl; constructor; fold falses; auto.
    rewrite (frob_eq _ (map bool bool orb false_true (everywhere bool false))),
    (frob_eq _ false_true); simpl; constructor; auto. Qed.
End ex12.

(** * From Subset *)

(** All of the notations defined in this chapter, plus some extras, are available for import from the module [MoreSpecif] of the book source.

%\begin{enumerate}%#
#
%\item%#
# Write a function of type [forall n m : nat, {][n <= m} + {][n > m}].  That is, this function decides whether one natural is less than another, and its dependent type guarantees that its results are accurate.#
#
 *)
Module ex13.
  Require Import Specif.
  Require Import Arith.
  Require Import Peano.

  Notation "'LE'" := (left _ _ ).
  Notation "'GT'" := (right _ _).
  Notation "'Reduce' x" := (if x then LE else GT) (at level 50).

  Definition le_nat : forall n m : nat, { n <= m } + { n > m }.
    refine (fix f (n m : nat) : { n <= m } + { n > m} :=
           match n, m with
           | O, _ => LE
           | S _, O => GT
           | S n', S m' => Reduce (f n' m')
           end);
      [ apply le_0_n |
        apply gt_Sn_O|
        apply le_n_S; assumption |
        apply gt_n_S; assumption ].
  Defined.

  Eval compute in le_nat 99 100.

End ex13.

(**
%\item%#
# %\begin{enumerate}%#
#
  %\item%#
# Define [var], a type of propositional variables, as a synonym for [nat].#
#
  %\item%#
# Define an inductive type [prop] of propositional logic formulas, consisting of variables, negation, and binary conjunction and disjunction.#
#
  %\item%#
# Define a function [propDenote] from variable truth assignments and [prop]s to [Prop], based on the usual meanings of the connectives.  Represent truth assignments as functions from [var] to [bool].#
#
  %\item%#
# Define a function [bool_true_dec] that checks whether a boolean is true, with a maximally expressive dependent type.  That is, the function should have type [forall b, {b = true} + {b = true -> False}]. #
#
  %\item%#
# Define a function [decide] that determines whether a particular [prop] is true under a particular truth assignment.  That is, the function should have type [forall (truth : var -> bool) (p : prop), {propDenote truth p} + {~ propDenote truth p}].  This function is probably easiest to write in the usual tactical style, instead of programming with [refine].  The function [bool_true_dec] may come in handy as a hint.#
#
  %\item%#
# Define a function [negate] that returns a simplified version of the negation of a [prop].  That is, the function should have type [forall p : prop, {p' : prop | forall truth, propDenote truth p <-> ~ propDenote truth p'}].  To simplify a variable, just negate it.  Simplify a negation by returning its argument.  Simplify conjunctions and disjunctions using De Morgan's laws, negating the arguments recursively and switching the kind of connective.  Your [decide] function may be useful in some of the proof obligations, even if you do not use it in the computational part of [negate]'s definition.  Lemmas like [decide] allow us to compensate for the lack of a general Law of the Excluded Middle in CIC.#
#
#
#%\end{enumerate}% #
#
 *)

Module ex14.
  Inductive var : Type :=
  | Var : nat -> var.
  Inductive prop : Type :=
  | PVar : var -> prop
  | PNot : prop -> prop
  | PConj : prop -> prop -> prop
  | PDisj : prop -> prop -> prop.

  Fixpoint propDenote (f : var -> bool) (p : prop) : Prop :=
    match p with
    | PVar v => if (f v) then True else False
    | PNot p => ~ (propDenote f p)
    | PConj p1 p2 => (propDenote f p1) /\ (propDenote f p2)
    | PDisj p1 p2 => (propDenote f p1) \/ (propDenote f p2)
    end.

  Definition bool_true_dec := forall b, { b = true } + { ~ ( b = true) }.

  Definition decide := forall ( truth : var -> bool) (p : prop), { propDenote truth p} + { ~ propDenote truth p}.

  Definition negate := forall p : prop, { p' : prop | forall truth, propDenote truth p <-> ~ propDenote truth p' }.

End ex14.

(**
%\item%#
# Implement the DPLL satisfiability decision procedure for boolean formulas in conjunctive normal form, with a dependent type that guarantees its correctness.  An example of a reasonable type for this function would be [forall f : formula, {truth : tvals | formulaTrue truth f} + {][forall truth, ~ formulaTrue truth f}].  Implement at least %``%#"#the basic backtracking algorithm#"#%''% as defined here:
  %\begin{center}\url{http://en.wikipedia.org/wiki/DPLL_algorithm}\end{center}%
  #
http://en.wikipedia.org/wiki/DPLL_algorithm
#
It might also be instructive to implement the unit propagation and pure literal elimination optimizations described there or some other optimizations that have been used in modern SAT solvers.#
#

#
#%\end{enumerate}% *)

(** * From MoreDep *)

(** %\begin{enumerate}%#
#

%\item%#
# Define a kind of dependently typed lists, where a list's type index gives a lower bound on how many of its elements satisfy a particular predicate.  In particular, for an arbitrary set [A] and a predicate [P] over it:
%\begin{enumerate}%#
#
  %\item%#
# Define a type [plist : nat -> Set].  Each [plist n] should be a list of [A]s, where it is guaranteed that at least [n] distinct elements satisfy [P].  There is wide latitude in choosing how to encode this.  You should try to avoid using subset types or any other mechanism based on annotating non-dependent types with propositions after-the-fact.#
#
  %\item%#
# Define a version of list concatenation that works on [plist]s.  The type of this new function should express as much information as possible about the output [plist].#
#
  %\item%#
# Define a function [plistOut] for translating [plist]s to normal [list]s.#
#
  %\item%#
# Define a function [plistIn] for translating [list]s to [plist]s.  The type of [plistIn] should make it clear that the best bound on [P]-matching elements is chosen.  You may assume that you are given a dependently typed function for deciding instances of [P].#
#
  %\item%#
# Prove that, for any list [ls], [plistOut (plistIn ls) = ls].  This should be the only part of the exercise where you use tactic-based proving.#
#
  %\item%#
# Define a function [grab : forall n (ls : plist (][S n)), sig P].  That is, when given a [plist] guaranteed to contain at least one element satisfying [P], [grab] produces such an element.  The type family [sig] is the one we met earlier for sigma types (i.e., dependent pairs of programs and proofs), and [sig P] is extensionally equivalent to [{][x : A | P x}], though the latter form uses an eta-expansion of [P] instead of [P] itself as the predicate.#
#
#
#%\end{enumerate}% #
#

#
#%\end{enumerate}% *)

(** * From DataStruct *)

(** remove printing * *)

(** Some of the type family definitions and associated functions from this chapter are duplicated in the [DepList] module of the book source.  Some of their names have been changed to be more sensible in a general context.

%\begin{enumerate}%#
#

%\item%#
# Define a tree analogue of [hlist].  That is, define a parameterized type of binary trees with data at their leaves, and define a type family [htree] indexed by trees.  The structure of an [htree] mirrors its index tree, with the type of each data element (which only occur at leaves) determined by applying a type function to the corresponding element of the index tree.  Define a type standing for all possible paths from the root of a tree to leaves and use it to implement a function [tget] for extracting an element of an [htree] by path.  Define a function [htmap2] for %``%#"#mapping over two trees in parallel.#"#%''%  That is, [htmap2] takes in two [htree]s with the same index tree, and it forms a new [htree] with the same index by applying a binary function pointwise.

  Repeat this process so that you implement each definition for each of the three definition styles covered in this chapter: inductive, recursive, and index function.#
#

%\item%#
# Write a dependently typed interpreter for a simple programming language with ML-style pattern-matching, using one of the encodings of heterogeneous lists to represent the different branches of a [case] expression.  (There are other ways to represent the same thing, but the point of this exercise is to practice using those heterogeneous list types.)  The object language is defined informally by this grammar:
  [[
t ::= bool | t + t
p ::= x | b | inl p | inr p
e ::= x | b | inl e | inr e | case e of [p => e]* | _ => e
]]

  The non-terminal [x] stands for a variable, and [b] stands for a boolean constant.  The production for [case] expressions means that a pattern-match includes zero or more pairs of patterns and expressions, along with a default case.

  Your interpreter should be implemented in the style demonstrated in this chapter.  That is, your definition of expressions should use dependent types and de Bruijn indices to combine syntax and typing rules, such that the type of an expression tells the types of variables that are in scope.  You should implement a simple recursive function translating types [t] to [Set], and your interpreter should produce values in the image of this translation.#
#

#
#%\end{enumerate}% *)

(** * From Equality *)

(** %\begin{enumerate}%#
#

%\item%#
# Implement and prove correct a substitution function for simply typed lambda calculus.  In particular:
%\begin{enumerate}%#
#
  %\item%#
# Define a datatype [type] of lambda types, including just booleans and function types.#
#
  %\item%#
# Define a type family [exp : list type -> type -> Type] of lambda expressions, including boolean constants, variables, and function application and abstraction.#
#
  %\item%#
# Implement a definitional interpreter for [exp]s, by way of a recursive function over expressions and substitutions for free variables, like in the related example from the last chapter.#
#
  %\item%#
# Implement a function [subst : forall t' ts t, exp (t' :: ts) t -> exp ts t' -> exp ts t].  The type of the first expression indicates that its most recently bound free variable has type [t'].  The second expression also has type [t'], and the job of [subst] is to substitute the second expression for every occurrence of the %``%#"#first#"#%''% variable of the first expression.#
#
  %\item%#
# Prove that [subst] preserves program meanings.  That is, prove
  [[
forall t' ts t (e : exp (t' :: ts) t) (e' : exp ts t') (s : hlist typeDenote ts),
  expDenote (subst e e') s = expDenote e (expDenote e' s ::: s)
  ]]
  where [:::] is an infix operator for heterogeneous %``%#"#cons#"#%''% that is defined in the book's [DepList] module.#
#
#
#%\end{enumerate}%
  The material presented up to this point should be sufficient to enable a good solution of this exercise, with enough ingenuity.  If you get stuck, it may be helpful to use the following structure.  None of these elements need to appear in your solution, but we can at least guarantee that there is a reasonable solution based on them.
%\begin{enumerate}%#
#
  %\item%#
# The [DepList] module will be useful.  You can get the standard dependent list definitions there, instead of copying-and-pasting from the last chapter.  It is worth reading the source for that module over, since it defines some new helpful functions and notations that we did not use last chapter.#
#
  %\item%#
# Define a recursive function [liftVar : forall ts1 ts2 t t', member t (ts1 ++ ts2) -> member t (ts1 ++ t' :: ts2)].  This function should %``%#"#lift#"#%''% a de Bruijn variable so that its type refers to a new variable inserted somewhere in the index list.#
#
  %\item%#
# Define a recursive function [lift' : forall ts t (e : exp ts t) ts1 ts2 t', ts = ts1 ++ ts2 -> exp (ts1 ++ t' :: ts2) t] which performs a similar lifting on an [exp].  The convoluted type is to get around restrictions on [match] annotations.  We delay %``%#"#realizing#"#%''% that the first index of [e] is built with list concatenation until after a dependent [match], and the new explicit proof argument must be used to cast some terms that come up in the [match] body.#
#
  %\item%#
# Define a function [lift : forall ts t t', exp ts t -> exp (t' :: ts) t], which handles simpler top-level lifts.  This should be an easy one-liner based on [lift'].#
#
  %\item%#
# Define a recursive function [substVar : forall ts1 ts2 t t', member t (ts1 ++ t' :: ts2) -> (t' = t) + member t (ts1 ++ ts2)].  This function is the workhorse behind substitution applied to a variable.  It returns [inl] to indicate that the variable we pass to it is the variable that we are substituting for, and it returns [inr] to indicate that the variable we are examining is _not_ the one we are substituting for.  In the first case, we get a proof that the necessary typing relationship holds, and, in the second case, we get the original variable modified to reflect the removal of the substitutee from the typing context.#
#
  %\item%#
# Define a recursive function [subst' : forall ts t (e : exp ts t) ts1 t' ts2, ts = ts1 ++ t' :: ts2 -> exp (ts1 ++ ts2) t' -> exp (ts1 ++ ts2) t].  This is the workhorse of substitution in expressions, employing the same proof-passing trick as for [lift'].  You will probably want to use [lift] somewhere in the definition of [subst'].#
#
  %\item%#
# Now [subst] should be a one-liner, defined in terms of [subst'].#
#
  %\item%#
# Prove a correctness theorem for each auxiliary function, leading up to the proof of [subst] correctness.#
#
  %\item%#
# All of the reasoning about equality proofs in these theorems follows a regular pattern.  If you have an equality proof that you want to replace with [eq_refl] somehow, run [generalize] on that proof variable.  Your goal is to get to the point where you can [rewrite] with the original proof to change the type of the generalized version.  To avoid type errors (the infamous %``%#"#second-order unification#"#%''% failure messages), it will be helpful to run [generalize] on other pieces of the proof context that mention the equality's lefthand side.  You might also want to use [generalize dependent], which generalizes not just one variable but also all variables whose types depend on it.  [generalize dependent] has the sometimes-helpful property of removing from the context all variables that it generalizes.  Once you do manage the mind-bending trick of using the equality proof to rewrite its own type, you will be able to rewrite with [UIP_refl].#
#
  %\item%#
# The [ext_eq] axiom from the end of this chapter is available in the Coq standard library as [functional_extensionality] in module [FunctionalExtensionality], and you will probably want to use it in the [lift'] and [subst'] correctness proofs.#
#
  %\item%#
# The [change] tactic should come in handy in the proofs about [lift] and [subst], where you want to introduce %``%#"#extraneous#"#%''% list concatenations with [nil] to match the forms of earlier theorems.#
#
  %\item%#
# Be careful about [destruct]ing a term %``%#"#too early.#"#%''%  You can use [generalize] on proof terms to bring into the proof context any important propositions about the term.  Then, when you [destruct] the term, it is updated in the extra propositions, too.  The [case_eq] tactic is another alternative to this approach, based on saving an equality between the original term and its new form.#
#
#
#%\end{enumerate}%
#
#

#
#%\end{enumerate}% *)

(** * From LogicProg *)

(** printing * $\cdot$ *)

(** %\begin{enumerate}%#
#

%\item%#
# I did a Google search for group theory and found ##a page that proves some standard theorems##%\footnote{\url{http://dogschool.tripod.com/housekeeping.html}}%.  This exercise is about proving all of the theorems on that page automatically.

  For the purposes of this exercise, a group is a set [G], a binary function [f] over [G], an identity element [e] of [G], and a unary inverse function [i] for [G].  The following laws define correct choices of these parameters.  We follow standard practice in algebra, where all variables that we mention are quantified universally implicitly at the start of a fact.  We write infix [*] for [f], and you can set up the same sort of notation in your code with a command like [Infix "*" := f.].

  %\begin{itemize}%#
#
    %\item%#
# %\textbf{%##Associativity##%}%: [(a * b) * c = a * (b * c)]#
#
    %\item%#
# %\textbf{%##Right Identity##%}%: [a * e = a]#
#
    %\item%#
# %\textbf{%##Right Inverse##%}%: [a * i a = e]#
#
  #

#%\end{itemize}%

  The task in this exercise is to prove each of the following theorems for all groups, where we define a group exactly as above.  There is a wrinkle: every theorem or lemma must be proved by either a single call to [crush] or a single call to [eauto]!  It is allowed to pass numeric arguments to [eauto], where appropriate.  Recall that a numeric argument sets the depth of proof search, where 5 is the default.  Lower values can speed up execution when a proof exists within the bound.  Higher values may be necessary to find more involved proofs.

  %\begin{itemize}%#
#
    %\item%#
# %\textbf{%##Characterizing Identity##%}%: [a * a = a -> a = e]#
#
    %\item%#
# %\textbf{%##Left Inverse##%}%: [i a * a = e]#
#
    %\item%#
# %\textbf{%##Left Identity##%}%: [e * a = a]#
#
    %\item%#
# %\textbf{%##Uniqueness of Left Identity##%}%: [p * a = a -> p = e]#
#
    %\item%#
# %\textbf{%##Uniqueness of Right Inverse##%}%: [a * b = e -> b = i a]#
#
    %\item%#
# %\textbf{%##Uniqueness of Left Inverse##%}%: [a * b = e -> a = i b]#
#
    %\item%#
# %\textbf{%##Right Cancellation##%}%: [a * x = b * x -> a = b]#
#
    %\item%#
# %\textbf{%##Left Cancellation##%}%: [x * a = x * b -> a = b]#
#
    %\item%#
# %\textbf{%##Distributivity of Inverse##%}%: [i (a * b) = i b * i a]#
#
    %\item%#
# %\textbf{%##Double Inverse##%}%: [i (][i a) = a]#
#
    %\item%#
# %\textbf{%##Identity Inverse##%}%: [i e = e]#
#
  #

#%\end{itemize}%

  One more use of tactics is allowed in this problem.  The following lemma captures one common pattern of reasoning in algebra proofs: *)

(* begin hide *)
Variable G : Set.
Variable f : G -> G -> G.
Infix "*" := f.
(* end hide *)

Lemma mult_both : forall a b c d1 d2,
  a * c = d1
  -> b * c = d2
  -> a = b
  -> d1 = d2.
  crush.
Qed.

(** That is, we know some equality [a = b], which is the third hypothesis above.  We derive a further equality by multiplying both sides by [c], to yield [a * c = b * c].  Next, we do algebraic simplification on both sides of this new equality, represented by the first two hypotheses above.  The final result is a new theorem of algebra.

   The next chapter introduces more details of programming in Ltac, but here is a quick teaser that will be useful in this problem.  Include the following hint command before you start proving the main theorems of this exercise: *)

Hint Extern 100 (_ = _) =>
  match goal with
    | [ _ : True |- _ ] => fail 1
    | _ => assert True by constructor; eapply mult_both
  end.

(** This hint has the effect of applying [mult_both] _at most once_ during a proof.  After the next chapter, it should be clear why the hint has that effect, but for now treat it as a useful black box.  Simply using [Hint Resolve mult_both] would increase proof search time unacceptably, because there are just too many ways to use [mult_both] repeatedly within a proof.

   The order of the theorems above is itself a meta-level hint, since I found that order to work well for allowing the use of earlier theorems as hints in the proofs of later theorems.

   The key to this problem is coming up with further lemmas like [mult_both] that formalize common patterns of reasoning in algebraic proofs.  These lemmas need to be more than sound: they must also fit well with the way that [eauto] does proof search.  For instance, if we had given [mult_both] a traditional statement, we probably would have avoided %``%#"#pointless#"#%''% equalities like [a = b], which could be avoided simply by replacing all occurrences of [b] with [a].  However, the resulting theorem would not work as well with automated proof search!  Every additional hint you come up with should be registered with [Hint Resolve], so that the lemma statement needs to be in a form that [eauto] understands %``%#"#natively.#"#%''%

   I recommend testing a few simple rules corresponding to common steps in algebraic proofs.  You can apply them manually with any tactics you like (e.g., [apply] or [eapply]) to figure out what approaches work, and then switch to [eauto] once you have the full set of hints.

   I also proved a few hint lemmas tailored to particular theorems, but which do not give common algebraic simplification rules.  You will probably want to use some, too, in cases where [eauto] does not find a proof within a reasonable amount of time.  In total, beside the main theorems to be proved, my sample solution includes 6 lemmas, with a mix of the two kinds of lemmas.  You may use more in your solution, but I suggest trying to minimize the number.

#
#%\end{enumerate}% *)

(** * From Match *)

(** %\begin{enumerate}%#
#

   %\item%#
# An anonymous Coq fan from the Internet was excited to come up with this tactic definition shortly after getting started learning Ltac: *)

Ltac deSome :=
  match goal with
    | [ H : Some _ = Some _ |- _ ] => injection H; clear H; intros; subst; deSome
    | _ => reflexivity
  end.

(** Without lifting a finger, exciting theorems can be proved: *)

Theorem test : forall (a b c d e f g : nat),
  Some a = Some b
  -> Some b = Some c
  -> Some e = Some c
  -> Some f = Some g
  -> c = a.
  intros; deSome.
Qed.

(** Unfortunately, this tactic exhibits some degenerate behavior.  Consider the following example: *)

Theorem test2 : forall (a x1 y1 x2 y2 x3 y3 x4 y4 x5 y5 x6 y6 : nat),
  Some x1 = Some y1
  -> Some x2 = Some y2
  -> Some x3 = Some y3
  -> Some x4 = Some y4
  -> Some x5 = Some y5
  -> Some x6 = Some y6
  -> Some a = Some a
  -> x1 = x2.
  intros.
  Time try deSome.
Abort.

(* begin hide *)
Reset test.
(* end hide *)

(** This (failed) proof already takes about one second on my workstation.  I hope a pattern in the theorem statement is clear; this is a representative of a class of theorems, where we may add more matched pairs of [x] and [y] variables, with equality hypotheses between them.  The running time of [deSome] is exponential in the number of such hypotheses.

   The task in this exercise is twofold.  First, figure out why [deSome] exhibits exponential behavior for this class of examples and record your explanation in a comment.  Second, write an improved version of [deSome] that runs in polynomial time.#
#

   %\item%#
# Sometimes it can be convenient to know that a proof attempt is doomed because the theorem is false.  For instance, here are three non-theorems about lists: *)

Theorem test1 : forall A (ls1 ls2 : list A), ls1 ++ ls2 = ls2 ++ ls1.
(* begin hide *)
Abort.
(* end hide *)

Theorem test2 : forall A (ls1 ls2 : list A), length (ls1 ++ ls2) = length ls1 - length ls2.
(* begin hide *)
Abort.
(* end hide *)

Theorem test3 : forall A (ls : list A), length (rev ls) - 3 = 0.
(* begin hide *)
Abort.
(* end hide *)

(** The task in this exercise is to write a tactic that disproves these and many other related %``%#"#theorems#"#%''% about lists.  Your tactic should follow a simple brute-force enumeration strategy, considering all [list bool] values with length up to some bound given by the user, as a [nat] argument to the tactic.  A successful invocation should add a new hypothesis of the negation of the theorem (guaranteeing that the tactic has made a sound decision about falsehood).

   A few hints: A good starting point is to pattern-match the conclusion formula and use the [assert] tactic on its negation.  An [assert] invocation may include a [by] clause to specify a tactic to use to prove the assertion.

   The idea in this exercise is to disprove a quantified formula by finding instantiations for the quantifiers that make it manifestly false.  Recall the [specialize] tactic for specializing a hypothesis to particular quantifier instantiations.  When you have instantiated quantifiers fully, [discriminate] is a good choice to derive a contradiction.  (It at least works for the three examples above and is smart enough for this exercise's purposes.)  The [type of] Ltac construct may be useful to analyze the type of a hypothesis to choose how to instantiate its quantifiers.

   To enumerate all boolean lists up to a certain length, it will be helpful to write a recursive tactic in continuation-passing style, where the continuation is meant to be called on each candidate list.

   Remember that arguments to Ltac functions may not be type-checked in contexts large enough to allow usual implicit argument inference, so instead of [nil] it will be useful to write [@][nil bool], which specifies the usually implicit argument explicitly.

   %\item%#
# Some theorems involving existential quantifiers are easy to prove with [eauto]. *)

Theorem test1 : exists x, x = 0.
  eauto.
Qed.

(** Others are harder.  The problem with the next theorem is that the existentially quantified variable does not appear in the rest of the theorem, so [eauto] has no way to deduce its value.  However, we know that we had might as well instantiate that variable to [tt], the only value of type [unit]. *)

Theorem test2 : exists x : unit, 0 = 0.
(* begin hide *)
  eauto.
Abort.
(* end hide *)

(** We also run into trouble in the next theorem, because [eauto] does not understand the [fst] and [snd] projection functions for pairs. *)

Theorem test3 : exists x : nat * nat, fst x = 7 /\ snd x = 2 + fst x.
(* begin hide *)
  eauto.
Abort.
(* end hide *)

(** Both problems show up in this monster example. *)

Theorem test4 : exists x : (unit * nat) * (nat * bool),
  snd (fst x) = 7 /\ fst (snd x) = 2 + snd (fst x) /\ snd (snd x) = true.
(* begin hide *)
  eauto.
Abort.
(* end hide *)

(** The task in this problem is to write a tactic that preprocesses such goals so that [eauto] can finish them.  Your tactic should serve as a complete proof of each of the above examples, along with the wide class of similar examples.  The key smarts that your tactic will bring are: first, it introduces separate unification variables for all the %``%#"#leaf types#"#%''% of compound types built out of pairs; and second, leaf unification variables of type [unit] are simply replaced by [tt].

   A few hints: The following tactic is more convenient than direct use of the built-in tactic [evar], for generation of new unification variables: *)

Ltac makeEvar T k := let x := fresh in
  evar (x : T); let y := eval unfold x in x in clear x; k y.

(** remove printing exists *)

(** This is a continuation-passing style tactic.  For instance, when the goal begins with existential quantification over a type [T], the following tactic invocation will create a new unification variable to use as the quantifier instantiation:

[makeEvar T ltac:(][fun x => exists x)] *)

(** printing exists $\exists$ *)

(** Recall that [exists] formulas are desugared to uses of the [ex] inductive family.  In particular, a pattern like the following can be used to extract the domain of an [exists] quantifier into variable [T]:

[| ]#[#%[%[ |- ex (][A := ?][T) _ ]#]#%]%[ => ...]

    The [equate] tactic used as an example in this chapter will probably be useful, to unify two terms, for instance if the first is a unification variable whose value you want to set.
[[
Ltac equate E1 E2 := let H := fresh in
  assert (H : E1 = E2) by reflexivity; clear H.
]]

    Finally, there are some minor complications surrounding overloading of the [*] operator for both numeric multiplication and Cartesian product for sets (i.e., pair types).  To ensure that an Ltac pattern is using the type version, write it like this:

[| (?T1 * ?T2)%][type => ...]#
#

%\item%#
# An exercise in the last chapter dealt with automating proofs about rings using [eauto], where we must prove some odd-looking theorems to push proof search in a direction where unification does all the work.  Algebraic proofs consist mostly of rewriting in equations, so we might hope that the [autorewrite] tactic would yield more natural automated proofs.  Indeed, consider this example within the same formulation of ring theory that we dealt with last chapter, where each of the three axioms has been added to the rewrite hint database [cpdt] using [Hint Rewrite]:
[[
Theorem test1 : forall a b, a * b * i b = a.
  intros; autorewrite with cpdt; reflexivity.
Qed.
]]

So far so good.  However, consider this further example:
[[
Theorem test2 : forall a, a * e * i a * i e = e.
  intros; autorewrite with cpdt.
]]

The goal is merely reduced to [a * (][i a * i e) = e], which of course [reflexivity] cannot prove.  The essential problem is that [autorewrite] does not do backtracking search.  Instead, it follows a %``%#"#greedy#"#%''% approach, at each stage choosing a rewrite to perform and then never allowing that rewrite to be undone.  An early mistake can doom the whole process.

The task in this problem is to use Ltac to implement a backtracking version of [autorewrite] that works much like [eauto], in that its inputs are a database of hint lemmas and a bound on search depth.  Here our search trees will have uses of [rewrite] at their nodes, rather than uses of [eapply] as in the case of [eauto], and proofs must be finished by [reflexivity].

An invocation to the tactic to prove [test2] might look like this:
[[
  rewriter (right_identity, (right_inverse, tt)) 3.
]]

The first argument gives the set of lemmas to consider, as a kind of list encoded with pair types.  Such a format cannot be analyzed directly by Gallina programs, but Ltac allows us much more freedom to deconstruct syntax.  For example, to case analyze such a list found in a variable [x], we need only write:
[[
  match x with
    | (?lemma, ?more) => ...
  end
]]

In the body of the case analysis, [lemma] will be bound to the first lemma, and [more] will be bound to the remaining lemmas.  There is no need to consider a case for [tt], our stand-in for [nil].  This is because lack of any matching pattern will trigger failure, which is exactly the outcome we would like upon reaching the end of the lemma list without finding one that applies.  The tactic will fail, triggering backtracking to some previous [match].

There are different kinds of backtracking, corresponding to different sorts of decisions to be made.  The examples considered above can be handled with backtracking that only reconsiders decisions about the order in which to apply rewriting lemmas.  A full-credit solution need only handle that kind of backtracking, considering all rewriting sequences up to the length bound passed to your tactic.  A good test of this level of applicability is to prove both [test1] and [test2] above.  However, some theorems could only be proved using a smarter tactic that considers not only order of rewriting lemma uses, but also choice of arguments to the lemmas.  That is, at some points in a proof, the same lemma may apply at multiple places within the goal formula, and some choices may lead to stuck proof states while others lead to success.  For an extra challenge (without any impact on the grade for the problem), you might try beefing up your tactic to do backtracking on argument choice, too.#
#

#
#%\end{enumerate}% *)

(** * Exercises *)

(** remove printing * *)

(** %\begin{enumerate}%#
#

%\item%#
# Implement a reflective procedure for normalizing systems of linear equations over rational numbers.  In particular, the tactic should identify all hypotheses that are linear equations over rationals where the equation righthand sides are constants.  It should normalize each hypothesis to have a lefthand side that is a sum of products of constants and variables, with no variable appearing multiple times.  Then, your tactic should add together all of these equations to form a single new equation, possibly clearing the original equations.  Some coefficients may cancel in the addition, reducing the number of variables that appear.

To work with rational numbers, import module [QArith] and use [Local Open Scope Q_scope].  All of the usual arithmetic operator notations will then work with rationals, and there are shorthands for constants 0 and 1.  Other rationals must be written as [num # den] for numerator [num] and denominator [den].  Use the infix operator [==] in place of [=], to deal with different ways of expressing the same number as a fraction.  For instance, a theorem and proof like this one should work with your tactic:
[[
  Theorem t2 : forall x y z, (2 # 1) * (x - (3 # 2) * y) == 15 # 1
    -> z + (8 # 1) * x == 20 # 1
    -> (-6 # 2) * y + (10 # 1) * x + z == 35 # 1.
    intros; reifyContext; assumption.
  Qed.
]]

  Your solution can work in any way that involves reifying syntax and doing most calculation with a Gallina function.  These hints outline a particular possible solution.  Throughout, the [ring] tactic will be helpful for proving many simple facts about rationals, and tactics like [rewrite] are correctly overloaded to work with rational equality [==].

%\begin{enumerate}%#
#
  %\item%#
# Define an inductive type [exp] of expressions over rationals (which inhabit the Coq type [Q]).  Include variables (represented as natural numbers), constants, addition, subtraction, and multiplication.#
#
  %\item%#
# Define a function [lookup] for reading an element out of a list of rationals, by its position in the list.#
#
  %\item%#
# Define a function [expDenote] that translates [exp]s, along with lists of rationals representing variable values, to [Q].#
#
  %\item%#
# Define a recursive function [eqsDenote] over [list (exp * Q)], characterizing when all of the equations are true.#
#
  %\item%#
# Fix a representation [lhs] of flattened expressions.  Where [len] is the number of variables, represent a flattened equation as [ilist Q len].  Each position of the list gives the coefficient of the corresponding variable.#
#
  %\item%#
# Write a recursive function [linearize] that takes a constant [k] and an expression [e] and optionally returns an [lhs] equivalent to [k * e].  This function returns [None] when it discovers that the input expression is not linear.  The parameter [len] of [lhs] should be a parameter of [linearize], too.  The functions [singleton], [everywhere], and [map2] from [DepList] will probably be helpful.  It is also helpful to know that [Qplus] is the identifier for rational addition.#
#
  %\item%#
# Write a recursive function [linearizeEqs : list (exp * Q) -> option (lhs * Q)].  This function linearizes all of the equations in the list in turn, building up the sum of the equations.  It returns [None] if the linearization of any constituent equation fails.#
#
  %\item%#
# Define a denotation function for [lhs].#
#
  %\item%#
# Prove that, when [exp] linearization succeeds on constant [k] and expression [e], the linearized version has the same meaning as [k * e].#
#
  %\item%#
# Prove that, when [linearizeEqs] succeeds on an equation list [eqs], then the final summed-up equation is true whenever the original equation list is true.#
#
  %\item%#
# Write a tactic [findVarsHyps] to search through all equalities on rationals in the context, recursing through addition, subtraction, and multiplication to find the list of expressions that should be treated as variables.  This list should be suitable as an argument to [expDenote] and [eqsDenote], associating a [Q] value to each natural number that stands for a variable.#
#
  %\item%#
# Write a tactic [reify] to reify a [Q] expression into [exp], with respect to a given list of variable values.#
#
  %\item%#
# Write a tactic [reifyEqs] to reify a formula that begins with a sequence of implications from linear equalities whose lefthand sides are expressed with [expDenote].  This tactic should build a [list (exp * Q)] representing the equations.  Remember to give an explicit type annotation when returning a nil list, as in [constr:(][@][nil (exp * Q))].#
#
  %\item%#
# Now this final tactic should do the job:
[[
  Ltac reifyContext :=
    let ls := findVarsHyps in
      repeat match goal with
               | [ H : ?e == ?num # ?den |- _ ] =>
                 let r := reify ls e in
                   change (expDenote ls r == num # den) in H;
                   generalize H
             end;
      match goal with
        | [ |- ?g ] => let re := reifyEqs g in
            intros;
              let H := fresh "H" in
              assert (H : eqsDenote ls re); [ simpl in *; tauto
                | repeat match goal with
                           | [ H : expDenote _ _ == _ |- _ ] => clear H
                         end;
                generalize (linearizeEqsCorrect ls re H); clear H; simpl;
                  match goal with
                    | [ |- ?X == ?Y -> _ ] =>
                      ring_simplify X Y; intro
                  end ]
      end.
]]

#
#%\end{enumerate}%
#
#

#
#%\end{enumerate}% *)


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path order bigop.
From favssr Require Import prelude.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section InsertionSort.
Context {disp : unit} {T : orderType disp}.

(* Definition *)

Fixpoint insort (x : T) xs :=
  if xs is y :: xs' then
    if x <= y then x :: y :: xs' else y :: insort x xs'
    else [:: x].

Fixpoint isort xs :=
  if xs is x :: xs' then insort x (isort xs') else [::].

(* Functional Correctness *)

Lemma perm_insort x xs : perm_eq (insort x xs) (x :: xs).
Proof.
elim: xs=>//= y xs IH; case: (_ <= _)=>//.
rewrite -(perm_cons y) in IH.
apply: perm_trans; first by exact: IH.
by apply/permP=>/=?; rewrite addnCA.
Qed.

Lemma perm_isort xs : perm_eq (isort xs) xs.
Proof.
elim: xs=>//= x xs IH.
apply: perm_trans; first by apply: perm_insort.
by rewrite perm_cons.
Qed.

Lemma sorted_insort a xs : sorted <=%O (insort a xs) = sorted <=%O xs.
Proof.
elim: xs=>//= x xs IH.
case H: (_ <= _)=>/=; first by rewrite H.
rewrite !path_sortedE; try by exact: le_trans.
rewrite (perm_all _ (perm_insort _ _)) /= IH.
suff: x <= a by move=>->.
by rewrite leNgt lt_neqAle H andbF.
Qed.

Lemma sorted_isort xs : sorted <=%O (isort xs).
Proof. by elim: xs=>//= x xs; rewrite sorted_insort. Qed.

(* Time complexity *)

Fixpoint T_insort (x : T) (xs : seq T) : nat :=
  if xs is y :: xs' then
    (if x <= y then 0 else T_insort x xs').+1
    else 1.

Fixpoint T_isort xs : nat :=
  if xs is x :: xs' then (T_isort xs' + T_insort x (isort xs')).+1 else 1.

Lemma T_insort_size x xs : T_insort x xs <= (size xs).+1.
Proof.
elim: xs=>//=y xs IH.
by case: (x <= y).
Qed.

(* This seems to be unused *)
Lemma size_insort x xs: size (insort x xs) = (size xs).+1.
Proof. by move/perm_size: (perm_insort x xs). Qed.

Lemma size_isort xs : size (isort xs) = size xs.
Proof. by move/perm_size: (perm_isort xs). Qed.

Lemma T_isort_size xs : T_isort xs <= (size xs).+1 ^ 2.
Proof.
elim: xs=>// x xs IH.
rewrite -addn1 sqrnD /= -addn1 -!addnA.
apply: leq_add=>//; rewrite exp1n muln1 addnC leq_add2l.
apply: leq_trans; first by exact: T_insort_size.
by rewrite size_isort; apply: leq_pmull.
Qed.

(* Exercise 2.1 *)

Lemma isort_beh (f : seq T -> seq T) xs :
  perm_eq (f xs) xs -> sorted <=%O (f xs) -> f xs = isort xs.
Proof.
Admitted.

(* Exercise 2.2.1 *)

Lemma T_isort_optimal xs : sorted <=%O xs -> T_isort xs = (2 * size xs).+1.
Proof.
Admitted.

End InsertionSort.

Section InsertionSortNat.

(* uphalf_addn from prelude might come in handy here *)
(* Exercise 2.2.2 *)
Lemma T_isort_worst n : T_isort (rev (iota 0 n)) = uphalf ((n.+1)*(n.+2)).
Proof.
Admitted.

End InsertionSortNat.

Section QuickSort.
Context {disp : unit} {T : orderType disp}.

(* Definition *)

Equations? quicksort (xs : seq T) : seq T by wf (size xs) lt :=
quicksort [::]    => [::];
quicksort (x::xs) => quicksort (filter (< x) xs) ++ [:: x] ++
                     quicksort (filter (>= x) xs).
Proof.
- by rewrite size_filter /=; apply/ssrnat.ltP/count_size.
by rewrite size_filter /=; apply/ssrnat.ltP/count_size.
Qed.

(* Functional Correctness *)

Lemma perm_quicksort xs : perm_eq (quicksort xs) xs.
Proof.
apply_funelim (quicksort xs)=>//=x {}xs Hl Hg.
rewrite perm_catC cat_cons perm_cons perm_sym -(perm_filterC (>= x)) perm_sym.
apply: perm_cat=>//.
rewrite (eq_in_filter (a2 := < x)) //= =>y _.
by rewrite ltNge.
Qed.

Lemma sorted_quicksort xs : sorted <=%O (quicksort xs).
Proof.
apply_funelim (quicksort xs)=>//= x {}xs Hl Hg.
have Hx : sorted <=%O [:: x] by [].
move: (merge_sorted le_total Hx Hg)=>{Hx}/=.
rewrite allrel_merge; last first.
- by rewrite allrel1l (perm_all _ (perm_quicksort _)) filter_all.
move/(merge_sorted le_total Hl); rewrite allrel_merge //=.
apply/allrelP=>y z.
rewrite (perm_mem (perm_quicksort _) y) inE
  (perm_mem (perm_quicksort _) z) !mem_filter /=.
case/andP=>Hy _; case/orP=>[/eqP ->|/andP [Hz _]];
rewrite le_eqVlt; apply/orP; right=>//.
by apply/lt_le_trans/Hz.
Qed.

(* Exercise 2.3 *)

Equations? quicksort2 (xs ys : seq T) : seq T by wf (size xs) lt :=
quicksort2 xs ys => ys. (* FIXME *)
Proof.
Qed.

Lemma quick2_quick xs ys : quicksort2 xs ys = quicksort xs ++ ys.
Proof.
Admitted.

(* Exercise 2.4 *)

Definition partition3 (x : T) (xs : seq T) : seq T * seq T * seq T :=
  (filter (< x) xs, filter (pred1 x) xs, filter (> x) xs).

Equations? quicksort3 (xs : seq T) : seq T by wf (size xs) lt :=
quicksort3 [::]    => [::];
quicksort3 (x::xs) with inspect (partition3 x xs) => {
  | (ls, es, gs) eqn: eq => quicksort3 ls ++ x :: es ++ quicksort3 gs
}.
Proof.
- by apply/ssrnat.ltP; rewrite size_filter; apply: count_size.
by apply/ssrnat.ltP; rewrite size_filter; apply: count_size.
Qed.

(* this is the main part *)
Lemma quick_filter_ge x xs :
  quicksort (filter (>= x) xs) = filter (pred1 x) xs ++ quicksort (filter (> x) xs).
Proof.
Admitted.

Lemma quick3_quick xs : quicksort3 xs = quicksort xs.
Proof.
Admitted.

(* Exercise 2.5.1 *)

Fixpoint T_filter {A} (ta : A -> nat) (s : seq A) : nat :=
  if s is x :: s' then ta x + T_filter ta s' + 1 else 1.

Lemma T_filter_size {A} (xs : seq A) ta :
  T_filter ta xs = \sum_(x<-xs) (ta x) + size xs + 1.
Proof.
elim: xs=>/=; first by rewrite big_nil.
by move=>x xs ->; rewrite big_cons -(addn1 (size _)) !addnA.
Qed.

Equations? T_quicksort (xs : seq T) : nat by wf (size xs) lt :=
T_quicksort [::]    => 1;
T_quicksort (x::xs) => T_quicksort (filter (< x) xs) +
                       T_quicksort (filter (>= x) xs) +
                       2 * T_filter (fun => 1%N) xs + 1.
Proof.
- by apply/ssrnat.ltP; rewrite size_filter; apply: count_size.
by apply/ssrnat.ltP; rewrite size_filter; apply: count_size.
Qed.

(* FIXME replace these with concrete numbers *)
Parameters (a b c : nat).

Lemma quicksort_quadratic xs : sorted <=%O xs -> T_quicksort xs = a * size xs ^ 2 + b * size xs + c.
Proof.
Admitted.

(* Exercise 2.5.2 *)

Lemma quicksort_worst xs : T_quicksort xs <= a * size xs ^ 2 + b * size xs + c.
Proof.
Admitted.

End QuickSort.

Section TopDownMergeSort.
Context {disp : unit} {T : orderType disp}.

(* reusing `merge` from mathcomp.path *)

Equations? msort (xs : seq T) : seq T by wf (size xs) lt :=
msort [::]  => [::];
msort [::x] => [::x];
msort xs    => let n := size xs in
               merge <=%O (msort (take n./2 xs))
                          (msort (drop n./2 xs)).
Proof.
- by apply/ssrnat.ltP; rewrite size_take /= !ltnS !half_le.
by apply/ssrnat.ltP; rewrite size_drop /= /leq subSS subnAC subnn.
Qed.

(* Functional Correctness *)

Lemma perm_msort xs : perm_eq (msort xs) xs.
Proof.
funelim (msort xs)=>//=.
rewrite perm_merge -{3}(cat_take_drop (size l)./2 (s0::l)) -cat_cons.
by apply: perm_cat.
Qed.

Lemma sorted_msort xs : sorted <=%O (msort xs).
Proof. by funelim (msort xs)=>//=; apply: merge_sorted. Qed.

(* Running Time Analysis *)

Fixpoint C_merge (s1 : seq T) :=
  if s1 is x1 :: s1' then
    let fix C_merge_s1 (s2 : seq T) :=
      if s2 is x2 :: s2' then
        (if x1 <= x2 then C_merge s1' s2 else C_merge_s1 s2').+1
      else 0 in
    C_merge_s1
  else fun => 0.

Equations? C_msort (xs : seq T) : nat by wf (size xs) lt :=
C_msort [::]  => 0;
C_msort [::x] => 0;
C_msort xs    => let n := (size xs) in
                 let ys := take n./2 xs in
                 let zs := drop n./2 xs in
                 C_msort ys + C_msort zs + C_merge (msort ys) (msort zs).
Proof.
- by apply/ssrnat.ltP; rewrite size_take /= !ltnS !half_le.
by apply/ssrnat.ltP; rewrite size_drop /= /leq subSS subnAC subnn.
Qed.

Lemma C_merge_leq xs ys : (C_merge xs ys <= size xs + size ys)%N.
Proof.
elim: xs ys=>//= x xs IH1; elim=>//= y ys IH2.
case: ifP=>_.
- rewrite -addn1 -!(addn1 (size _)) addnA leq_add2r addnAC.
  apply: leq_trans; first by apply: IH1.
  by rewrite addn1 addnS.
by rewrite addnS ltnS; apply: IH2.
Qed.

Lemma C_msort_leq xs k: size xs = 2^k -> (C_msort xs <= k * 2^k)%N.
Proof.
elim: k xs=>/=.
- by move=>xs; rewrite expn0 =>/size1 [x] ->; simp C_msort.
move=>k IH xs H.
have Hs1 : (size xs > 1)%N by rewrite H -{1}(expn0 2); apply: ltn_exp2l.
case: (size2 _ Hs1)=> x[y][ys] He; rewrite He /= in H *; simp C_msort=>/=.
have Hp : (size ys)./2.+1 = ((size ys).+2)./2 by rewrite -addn2 halfD andbF /= addn1.
have Ht : size (x :: take (size ys)./2 (y :: ys)) = 2^k.
- by rewrite /= size_take /= ltnS half_le Hp H expnS mul2n half_double.
have Hd : size (drop (size ys)./2 (y :: ys)) = 2^k.
- rewrite size_drop /= subSn; last by apply: half_le.
  by rewrite half_subn uphalf_half -addnS Hp H expnS mul2n half_double odd2 H oddX.
apply: leq_trans;
  first by exact: (leq_add (leq_add (IH _ Ht) (IH _ Hd)) (C_merge_leq _ _)).
rewrite !(perm_size (perm_msort _)) Ht Hd.
by rewrite !addnn -!muln2 -mulnA -!expnSr -{3}(addn1 k) mulnDl mul1n.
Qed.

(* Exercise 2.6 *)

Fixpoint halve {A: Type} (xs ys zs : seq A) : seq A * seq A :=
  ([::],[::]). (* FIXME *)

Equations? msort2 (xs : seq T) : seq T by wf (size xs) lt :=
msort2 [::]  => [::];
msort2 [::x] => [::x];
msort2 xs with inspect (halve xs [::] [::]) := {
  | (ys1, ys2) eqn: eq => merge <=%O (msort2 ys1) (msort2 ys2)
}.
Proof.
(* FIXME *)
- by apply/ssrnat.ltP.
by apply/ssrnat.ltP.
Qed.

Lemma perm_msort2 xs : perm_eq (msort2 xs) xs.
Proof.
Admitted.

Lemma sorted_msort2 xs : sorted <=%O (msort2 xs).
Proof.
Admitted.

End TopDownMergeSort.

Section BottomUpMergeSort.
Context {disp : unit} {T : orderType disp}.

Equations merge_adj : seq (seq T) -> seq (seq T) :=
merge_adj [::]          => [::];
merge_adj [::xs]        => [::xs];
merge_adj (xs::ys::zss) => merge <=%O xs ys :: merge_adj zss.

Lemma size_merge_adj xss : size (merge_adj xss) = uphalf (size xss).
Proof. by funelim (merge_adj xss)=>//=; congr S. Qed.

Equations? merge_all (xss : seq (seq T)) : seq T by wf (size xss) lt :=
merge_all [::]   => [::];
merge_all [::xs] => xs;
merge_all xss    => merge_all (merge_adj xss).
Proof.
by apply/ssrnat.ltP; rewrite size_merge_adj /= !ltnS; apply: uphalf_le.
Qed.

Definition msort_bu (xs : seq T) : seq T :=
  merge_all (map (fun x => [::x]) xs).

(* Functional Correctness *)

Lemma perm_merge_adj xss : perm_eq (flatten (merge_adj xss)) (flatten xss).
Proof.
funelim (merge_adj xss)=>//=.
rewrite catA; apply: perm_cat=>//.
by rewrite perm_merge.
Qed.

Lemma perm_merge_all xss : perm_eq (merge_all xss) (flatten xss).
Proof.
funelim (merge_all xss)=>//=; first by rewrite cats0.
by apply/(perm_trans H)/perm_merge_adj.
Qed.

Lemma perm_msort_bu xs : perm_eq (msort_bu xs) xs.
Proof.
rewrite /msort_bu; apply: (perm_trans (perm_merge_all _)).
by rewrite flatten_map1 map_id.
Qed.

Lemma sorted_merge_adj xss :
  all (sorted <=%O) xss -> all (sorted <=%O) (merge_adj xss).
Proof.
funelim (merge_adj xss)=>//= /and3P [Hs1 Hs2] /H ->; rewrite andbT.
by apply: merge_sorted.
Qed.

Lemma sorted_merge_all xss :
  all (sorted <=%O) xss -> sorted <=%O (merge_all xss).
Proof.
funelim (merge_all xss)=>//=; first by rewrite andbT.
move: H; simp merge_adj=>/= H.
case/and3P=>Hs1 Hs2 Hs; apply/H/andP.
by split; [apply: merge_sorted | apply: sorted_merge_adj].
Qed.

Lemma sorted_msort_bu xs : sorted <=%O (msort_bu xs).
Proof.
rewrite /msort_bu; apply: sorted_merge_all; rewrite all_map.
by elim: xs.
Qed.

(* Running Time Analysis *)

Equations C_merge_adj : seq (seq T) -> nat :=
C_merge_adj [::]          => 0;
C_merge_adj [::xs]        => 0;
C_merge_adj (xs::ys::zss) => C_merge xs ys + C_merge_adj zss.

Equations? C_merge_all (xss : seq (seq T)) : nat by wf (size xss) lt :=
C_merge_all [::]   => 0;
C_merge_all [::xs] => 0;
C_merge_all xss    => C_merge_adj xss + C_merge_all (merge_adj xss).
Proof.
by apply/ssrnat.ltP; rewrite size_merge_adj /= !ltnS; apply: uphalf_le.
Qed.

Definition C_msort_bu (xs : seq T) : nat :=
  C_merge_all (map (fun x => [::x]) xs).

Lemma merge_adj_sizes xss m :
  ~~ odd (size xss) -> all (fun xs => size xs == m) xss ->
  all (fun xs => size xs == m.*2) (merge_adj xss).
Proof.
funelim (merge_adj xss)=>//=; rewrite negbK=>Ho /and3P [/eqP Hx /eqP Hy Ha]; apply/andP.
split; last by rewrite (H _ Ho Ha).
by rewrite size_merge size_cat Hx Hy addnn.
Qed.

Lemma C_merge_adj_leq xss m :
  all (fun xs => size xs == m) xss -> C_merge_adj xss <= m * size xss.
Proof.
funelim (C_merge_adj xss)=>//= /and3P [/eqP Hx /eqP Hy Ha].
rewrite -add2n mulnDr muln2 -addnn; apply/leq_add/H=>//.
by rewrite -{1}Hx -Hy; apply: C_merge_leq.
Qed.

Lemma C_merge_all_leq xss m k :
  all (fun xs => size xs == m) xss -> size xss = 2 ^ k ->
  C_merge_all xss <= m * k * 2^k.
Proof.
funelim (C_merge_all xss)=>//= /and3P [/eqP Hx /eqP Hy Ha] Hs.
move: H; simp merge_adj C_merge_adj=>/= H. (* slow for some reason *)
have [k0 Hk] : { k0 | k = k0.+1 } by move: Hs; case: k=>//=k0 _; exists k0.
have He : ~~ odd (size l1) by rewrite odd2 Hs oddX Hk.
rewrite Hk expnS mulnS mulnDl in Hs *; apply: leq_add.
- rewrite -Hs -addn2 mulnDr addnC.
  apply: leq_add; first by apply: C_merge_adj_leq.
  by rewrite muln2 -addnn -{1}Hx -Hy; apply: C_merge_leq.
rewrite mulnCA !mulnA mul2n; apply: H.
- apply/andP; split; last by apply: merge_adj_sizes.
  by rewrite size_merge size_cat Hx Hy addnn.
apply/eqP; rewrite size_merge_adj -addn1 -(eqn_pmul2r (m:=2)) // mulnDl muln2.
have -> : (uphalf (size l1)).*2 = size l1
  by rewrite -[in RHS](odd_double_half (size l1)) uphalf_half (negbTE He).
by rewrite addn2 mulnC Hs.
Qed.

Lemma C_msort_bu_leq xs k : size xs = 2^k -> C_msort_bu xs <= k * 2^k.
Proof.
move=>H; rewrite -(mul1n (_ * _)) mulnA; apply: C_merge_all_leq.
- by rewrite all_map; elim: {H}xs.
by rewrite size_map.
Qed.

End BottomUpMergeSort.

Section NaturalMergeSort.
Context {disp : unit} {T : orderType disp}.

Fixpoint runs_fix (a : T) (xs : seq T) : seq (seq T) :=
  if xs is b::bs
    then if b < a then desc b [:: a] bs else asc b (cons a) bs
    else [::[::a]]
with asc (x : T) (xs : seq T -> seq T) (ys : seq T) : seq (seq T) :=
  if ys is y::ys'
    then if x <= y then asc y (xs \o cons x) ys' else xs [::x] :: runs_fix y ys'
    else [:: xs [::x]]
with desc (x : T) (xs : seq T) (ys : seq T) : seq (seq T) :=
  if ys is y::ys'
     then if y < x then desc y (x :: xs) ys' else (x :: xs) :: runs_fix y ys'
     else [:: (x :: xs)].

Definition runs (xs : seq T) : seq (seq T) :=
  if xs is x::xs' then runs_fix x xs' else [::].

Definition nmsort xs := merge_all (runs xs).

(* Functional Correctness *)

Definition is_dlist (f : seq T -> seq T) := forall ps qs, f (ps ++ qs) = f ps ++ qs.

Lemma perm_runs_asc_desc x xs ys f :
     perm_eq (flatten (runs_fix x ys)) (x :: ys)
  /\ perm_eq (flatten (desc x xs ys)) (x::xs ++ ys)
  /\ (is_dlist f ->
       perm_eq (flatten (asc x f ys)) (x :: f [::] ++ ys)).
Proof.
elim: ys x xs f=>/=.
- move=>x xs f; do!split=>//.
  by move=>H; move: (H [::] [::x])=>/=; rewrite !cats0=>->; rewrite perm_catC.
move=>b bs IH x xs f; do!split.
- case: ifP=>_.
  - apply: perm_trans; first by case: (IH b [::x] f)=>_ [+ _]; apply.
    by move: (perm_catCA [::b] [::x] bs)=>/=->.
  apply: perm_trans; first by case: (IH b [::x] (cons x))=>_ [_] /=; apply.
  by move: (perm_catCA [::b] [::x] bs)=>/=->.
- case: ifP=>_.
  - apply: perm_trans; first by case: (IH b (x::xs) f)=>_ [+ _]; apply.
    by move: (perm_catCA [::b] (x::xs) bs)=>/=->.
  rewrite /= -!cat_cons perm_cat2l.
  by case: (IH b xs f)=>+ _; apply.
move=>H; case: ifP=>_.
- apply: perm_trans.
  - case: (IH b xs (f \o cons x))=>_ [_] /=; apply=>ps qs.
    by rewrite /= -cat_cons; apply: H.
  move: (H [::] [::x])=>/=->; move: (perm_catCA [::b] (f [::] ++ [::x]) bs)=>/=->.
  by rewrite -cat_cons perm_cat2r perm_catC.
move: (H [::] [::x])=>/=->; rewrite -cat_cons.
apply: perm_cat; first by rewrite perm_catC.
by case: (IH b xs f)=>+ _; apply.
Qed.

Lemma perm_runs xs : perm_eq (flatten (runs xs)) xs.
Proof.
case: xs=>//=x xs.
by case: (perm_runs_asc_desc x [::] xs id).
Qed.

Lemma perm_nmsort xs : perm_eq (nmsort xs) xs.
Proof.
rewrite /nmsort; apply/perm_trans/perm_runs.
by apply: perm_merge_all.
Qed.

Lemma sorted_runs_asc_desc x xs ys f :
     all (sorted <=%O) (runs_fix x ys)
  /\ (sorted <=%O xs -> all (>= x) xs -> all (sorted <=%O) (desc x xs ys))
  /\ (is_dlist f -> sorted <=%O (f [::]) -> all (<= x) (f [::]) ->
      all (sorted <=%O) (asc x f ys)).
Proof.
elim: ys x xs f=>/=.
- move=>x xs f; do!split.
  - by move=>Hs Ha; rewrite andbT (path_sortedE le_trans); apply/andP.
  move=>Hd Hs Ha; rewrite andbT; move: (Hd [::] [::x])=>/=->.
  by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
move=>b ys IH x xs f; do!split.
- case: ifP=>Ho.
  - case: (IH b [::x] id)=>_ [+ _]; apply=>//.
    by rewrite all_seq1 le_eqVlt Ho orbT.
  case: (IH b xs (cons x))=>_ [_]; apply=>//.
  by rewrite all_seq1 /= leNgt; apply/negbT.
- move=>Hs Ha; case: ifP=>Ho /=.
  - case: (IH b (x::xs) id)=>_ [+ _]; apply=>/=.
    - by rewrite (path_sortedE le_trans); apply/andP.
    rewrite le_eqVlt Ho orbT /=; apply/sub_all/Ha=>z.
    by apply/le_trans; rewrite le_eqVlt Ho orbT.
  apply/andP; split; first by rewrite (path_sortedE le_trans); apply/andP.
  by case: (IH b xs f)=>+ _; apply.
move=>Hd Hs Ha; case: ifP=>Ho /=.
- case: (IH b xs (f \o cons x))=>_ [_] /=; apply.
  - by move=>ps qs /=; rewrite -cat_cons; apply: Hd.
  - move: (Hd [::] [::x])=>/=->.
    by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
  move: (Hd [::] [::x])=>/=->.
  rewrite cats1 all_rcons /= Ho /=.
  by apply/sub_all/Ha=>z /= Hx; apply/le_trans/Ho.
apply/andP; split.
- move: (Hd [::] [::x])=>/=->.
  by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
by case: (IH b xs id)=>+ _; apply.
Qed.

Lemma sorted_runs xs : all (sorted <=%O) (runs xs).
Proof. by case: xs=>//=x xs; case: (sorted_runs_asc_desc x [::] xs id). Qed.

Lemma sorted_nmsort xs : sorted <=%O (nmsort xs).
Proof. by rewrite /nmsort; apply/sorted_merge_all/sorted_runs. Qed.

(* Running Time Analysis *)

Fixpoint C_runs_fix a xs : nat :=
  if xs is b::bs
    then (if b < a then C_desc b bs else C_asc b bs).+1
    else 0
with C_asc (a : T) (xs : seq T) : nat :=
  if xs is b::bs
    then (if a <= b then C_asc b bs else C_runs_fix b bs).+1
    else 0
with C_desc (a : T) (xs : seq T) : nat :=
  if xs is b::bs
     then (if b < a then C_desc b bs else C_runs_fix b bs).+1
     else 0.

Definition C_runs (xs : seq T) : nat :=
  if xs is x::xs' then C_runs_fix x xs' else 0.

Definition C_nmsort (xs : seq T) : nat :=
  C_runs xs + C_merge_all (runs xs).

Lemma C_merge_adj_flat (xss : seq (seq T)) : C_merge_adj xss <= size (flatten xss).
Proof.
funelim (C_merge_adj xss)=>//=; rewrite catA !size_cat.
by apply: leq_add=>//; apply: C_merge_leq.
Qed.

Lemma merge_adj_flat (xss : seq (seq T)) :
  size (flatten (merge_adj xss)) = size (flatten xss).
Proof.
funelim (merge_adj xss)=>//=.
by rewrite catA !size_cat H size_merge size_cat.
Qed.

Lemma C_merge_adj_log2 (xss : seq (seq T)) : C_merge_all xss <= size (flatten xss) * log2n (size xss).
Proof.
funelim (C_merge_all xss)=>//=; move: H; simp C_merge_adj merge_adj.
rewrite /= !size_cat merge_adj_flat size_merge_adj size_merge size_cat =>IH.
rewrite log2n_half //= mulnS !addnA; apply: leq_add=>//.
by apply/leq_add/C_merge_adj_flat/C_merge_leq.
Qed.

Lemma size_runs_asc_desc x xs ys f :
      size (flatten (runs_fix x ys)) = (size ys).+1
  /\  size (flatten (desc x xs ys)) = (size xs + size ys).+1
  /\ (is_dlist f ->
      size (flatten (asc x f ys)) = (size (f [::]) + size ys).+1).
Proof.
elim: ys x xs f=>/=.
- move=>x xs f; do!split; first by rewrite cats0 addn0.
  by move=>H; move: (H [::] [::x])=>/=; rewrite !cats0=>->; rewrite size_cat addn0 /= addn1.
move=>b bs IH x xs f; do!split.
- case: ifP=>_.
  - by case: (IH b [::x] id)=>_ [+ _]; rewrite /= addnC addn1.
  case: (IH b [::x] (cons x))=>_ [_] /=; rewrite /= addnC addn1; apply.
  by move=>??; rewrite cat_cons.
- case: ifP=>_ /=.
  - by case: (IH b (x::xs) id)=>_ [+ _]; rewrite /= addSnnS.
  by case: (IH b xs f)=>+ _; rewrite size_cat=>->.
move=>H; case: ifP=>_ /=.
- case: (IH b xs (f \o cons x))=>_ [_] /=.
  move: (H [::] [::x])=>/=->; rewrite size_cat /= addnAC -addnA addn1; apply.
  by move=>?? /=; rewrite -cat_cons; apply: H.
move: (H [::] [::x])=>/=->; rewrite !size_cat /=.
by case: (IH b xs f)=>+ _; rewrite addnAC addn1=>->.
Qed.

Lemma size_runs xs : size (flatten (runs xs)) = size xs.
Proof. by case: xs=>//=x xs; case: (size_runs_asc_desc x [::] xs id). Qed.

Lemma size_runs_asc_desc_leq x xs ys f :
      (size (runs_fix x ys) <= (size ys).+1)%N
  /\  (size (desc x xs ys) <= (size ys).+1)%N
  /\ (is_dlist f ->
      (size (asc x f ys) <= (size ys).+1)%N).
Proof.
elim: ys x xs f=>//= b bs IH x xs f; do!split.
- case: ifP=>_.
  - by apply: leqW; case: (IH b [::x] id)=>_ [+ _].
  apply: leqW; case: (IH b [::x] (cons x))=>_ [_]; apply.
  by move=>??; rewrite cat_cons.
- case: ifP=>_ /=.
  - by apply: leqW; case: (IH b (x::xs) id)=>_ [+ _].
  by rewrite ltnS; case: (IH b xs f)=>+ _ /=.
move=>H; case: ifP=>_ /=.
- apply: leqW; case: (IH b xs (f \o cons x))=>_ [_] /=; apply.
  by move=>?? /=; rewrite -cat_cons; apply: H.
by rewrite ltnS; case: (IH b xs f)=>+ _.
Qed.

Lemma size_runs_leq xs : (size (runs xs) <= size xs)%N.
Proof. by case: xs=>//=x xs; case: (size_runs_asc_desc_leq x [::] xs id). Qed.

Lemma C_size_runs_asc_desc_leq x ys :
     (C_runs_fix x ys <= size ys)%N
  /\ (C_desc x ys <= size ys)%N
  /\ (C_asc x ys <= size ys)%N.
Proof.
elim: ys x=>//=b bs IH x.
by do!split; case: ifP=>_; rewrite ltnS; case: (IH b)=>+ [].
Qed.

Lemma C_size_runs_leq xs : (C_runs xs <= (size xs).-1)%N.
Proof. by case: xs=>//=x xs; case: (C_size_runs_asc_desc_leq x xs). Qed.

Lemma C_merge_runs_leq xs n : size xs = n -> (C_merge_all (runs xs) <= n * log2n n)%N.
Proof.
move=>H; apply: leq_trans; first by apply: C_merge_adj_log2.
rewrite size_runs H leq_mul2l; apply/orP.
case: n H=>[H|n H]; first by left.
right; apply: leq_log2n; rewrite -H.
by apply: size_runs_leq.
Qed.

Lemma C_nmsort_leq xs n : size xs = n -> (C_nmsort xs <= n + n * log2n n)%N.
Proof.
move=>H; rewrite /C_nmsort; apply/leq_add/C_merge_runs_leq=>//.
apply: leq_trans; first by apply: C_size_runs_leq.
by rewrite H; exact: leq_pred.
Qed.

End NaturalMergeSort.

Section Stability.
Context {disp : unit} {A : eqType} {K : orderType disp}.

(* Definition *)

Fixpoint insort_key (f : A -> K) (x : A) xs : seq A :=
  if xs is y :: xs' then
    if f x <= f y then x :: y :: xs' else y :: insort_key f x xs'
    else [:: x].

Fixpoint isort_key f xs :=
  if xs is x :: xs' then insort_key f x (isort_key f xs') else [::].

Lemma perm_insort_key f x xs : perm_eq (insort_key f x xs) (x :: xs).
Proof.
elim: xs=>//= y xs IH; case: (_ <= _)=>//.
rewrite -(perm_cons y) in IH.
apply: perm_trans; first by exact: IH.
by apply/permP=>/=?; rewrite addnCA.
Qed.

Lemma perm_isort_key f xs : perm_eq (isort_key f xs) xs.
Proof.
elim: xs=>//= x xs IH.
apply: perm_trans; first by apply: perm_insort_key.
by rewrite perm_cons.
Qed.

Lemma sorted_insort_key f a xs :
  sorted <=%O (map f (insort_key f a xs)) = sorted <=%O (map f xs).
Proof.
elim: xs=>//= x xs IH.
case H: (_ <= _)=>/=; first by rewrite H.
rewrite !path_sortedE; try by exact: le_trans.
rewrite !all_map (perm_all _ (perm_insort_key _ _ _)) /= IH.
suff: f x <= f a by move=>->.
by rewrite leNgt lt_neqAle H andbF.
Qed.

Lemma sorted_isort_key f xs : sorted <=%O (map f (isort_key f xs)).
Proof. by elim: xs=>//=x xs; rewrite sorted_insort_key. Qed.

Lemma insort_key_cons f a xs :
  all (fun x => f a <= f x) xs -> insort_key f a xs = a :: xs.
Proof. by case: xs=>//=x xs /andP [-> _]. Qed.

Lemma filter_not_insort_key (p : pred A) f x xs :
  ~~ p x -> filter p (insort_key f x xs) = filter p xs.
Proof.
move/negbTE=>Hp; elim: xs=>/=; first by rewrite Hp.
move=>y xs IH; case: ifP=>_ /=; first by rewrite Hp.
by rewrite IH.
Qed.

Lemma filter_insort_key (p : pred A) f x xs :
  sorted <=%O (map f xs) -> p x ->
  filter p (insort_key f x xs) = insort_key f x (filter p xs).
Proof.
move/[swap]=>Hp; elim: xs=>/=; first by rewrite Hp.
move=>y xs IH; rewrite (path_sortedE le_trans)=>/andP [Ha Hs].
case: ifP=>Hf /=.
- rewrite Hp; case: ifP=>/=; first by rewrite Hf.
  rewrite insort_key_cons //.
  rewrite all_map in Ha; rewrite all_filter; apply/sub_all/Ha.
  by move=>z /= Hf2; apply/implyP=>_; apply/le_trans/Hf2.
case: ifP=>/=; rewrite (IH Hs) //.
by rewrite Hf.
Qed.

Lemma isort_key_stable f k xs :
  filter (fun y => f y == k) (isort_key f xs) = filter (fun y => f y == k) xs.
Proof.
elim: xs=>//=x xs IH; case: ifP; last first.
- by move/negbT=>Hk; rewrite filter_not_insort_key.
move=>Hk; rewrite filter_insort_key //; last by apply: sorted_isort_key.
rewrite IH insort_key_cons // all_filter (eq_in_all (a2:=predT)) ?all_predT //.
by move=>z _ /=; apply/implyP; move/eqP: Hk=>->/eqP->.
Qed.

End Stability.


Require Export GeoCoq.Tarski_dev.Ch03_bet.

Section T3.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma l4_2 : forall A B C D A' B' C' D', IFSC A B C D A' B' C' D' -> Cong B D B' D'.
Proof.
unfold IFSC.
intros.
spliter.

induction (eq_dec_points A C).

treat_equalities;assumption.

assert (exists E, Bet A C E /\ C <> E)
 by apply point_construction_different.
ex_and H6 E.
prolong A' C' E' C E.

assert  (Cong E D E' D')
 by (
  apply (five_segment_with_def A C E D A' C' E' D');[
  unfold OFSC;  repeat split;Cong|
  assumption]).

apply (five_segment_with_def E C B D E' C' B' D').
unfold OFSC.
repeat split; try solve [eBetween| Cong ].
auto.
Qed.

Lemma l4_3 : forall A B C A' B' C',
  Bet A B C -> Bet A' B' C' -> Cong A C A' C' -> Cong B C B' C' -> Cong A B A' B'.
Proof.
intros.
apply cong_commutativity.
apply (l4_2 A B C A A' B' C' A').
unfold IFSC.
repeat split;Cong.
Qed.

Lemma l4_3_1 : forall A B C A' B' C',
 Bet A B C -> Bet A' B' C' -> Cong A B A' B' -> Cong A C A' C' -> Cong B C B' C'.
Proof.
    intros.
    apply cong_commutativity.
    eapply l4_3;eBetween;Cong.
Qed.

Lemma l4_5 : forall A B C A' C',
  Bet A B C -> Cong A C A' C' ->
  exists B', Bet A' B' C' /\ Cong_3 A B C A' B' C'.
Proof.
intros.
unfold Cong_3.

assert (exists D', Bet C' A' D' /\ A' <> D')
 by (apply point_construction_different).
ex_and H1 x'.
prolong x' A' B' A B.
prolong x' B' C'' B C.

assert (Bet A' B' C'') by eBetween.

assert (C'' = C').
eapply (construction_uniqueness x' A' ).

auto.
eBetween.

apply (l2_11 A' B' C'' A B C);Between.

eBetween.
Cong.

subst C''.
exists B'.
repeat split;Cong.
Qed.

Lemma l4_6 : forall A B C A' B' C', Bet A B C -> Cong_3 A B C A' B' C' -> Bet A' B' C'.
Proof.
unfold Cong_3.
intros.
assert (exists B'', Bet A' B'' C' /\ Cong_3 A B C A' B'' C')
  by (eapply l4_5;intuition).
ex_and H1 x.
unfold Cong_3 in *;spliter.

assert (Cong_3 A' x C' A' B' C').
  unfold Cong_3;repeat split; Cong.
  apply cong_transitivity with A B; Cong.
  apply cong_transitivity with B C; Cong.
unfold Cong_3 in H7;spliter.

assert (IFSC A' x C' x  A' x C' B')
 by (unfold IFSC;repeat split;Cong).
assert (Cong x x x B')
 by (eapply l4_2;apply H10).
Between.
Qed.

Lemma cong3_bet_eq : forall  A B C X,
 Bet A B C -> Cong_3 A B C A X C -> X = B.
Proof.
unfold Cong_3.
intros.
spliter.
assert (IFSC A B C B A B C X)
 by (unfold IFSC;intuition).
assert (Cong B B B X)
 by (apply (l4_2 _ _ _ _ _ _ _ _ H3)).
Between.
Qed.

End T3.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export ZArithRing.
Require Arith.

Parameters (prime_divisor : nat->nat)
           (prime : nat->Prop)
           (divides : nat->nat->Prop).

(** Tests:

Check prime (prime_divisor 220).

Check divides (prime_divisor 220) 220.

Check divides 3.

*)

Parameter binary_word : nat->Set.

Definition short : Set := binary_word 32.
Definition long : Set := binary_word 64.

(** Tests :

Check ~ divides 3 81.

Check (let d := prime_divisor 220 in prime d /\ divides d 220).

*)

Parameters (decomp : nat -> list nat)
           (decomp2 : nat->nat*nat).

(** Tests :

Check decomp 220.

Check decomp2 284.

Check forall n:nat, 2<=n ->
       prime (prime_divisor n) /\
       divides (prime_divisor n) n.
*)

Parameter
  prime_divisor_correct :
     forall n:nat, 2 <= n ->
       let d := prime_divisor n in prime d /\ divides d n.

Parameter
  binary_word_concat :
     forall n p:nat,
       binary_word n -> binary_word p -> binary_word (n+p).

(* Tests :

Check (forall A B :Set, A->B->A*B).

*)

Definition le_36_37 := le_S 36 36 (le_n 36).

Definition le_36_38 : 36 <= 38 := le_S 36 37 le_36_37.

(** Tests :

Check (le_S _ _ (le_S _ _ (le_n 36))).

Check prime_divisor_correct 220.

*)

Fixpoint iterate (A:Type)(f:A->A)(n:nat)(x:A) : A :=
  match n with
  | O => x
  | S p => f (iterate A f p x)
  end.

(** Tests :
Check iterate nat.

Check iterate  _ (mult 2).

Check (iterate _ (mult 2) 10).

Compute iterate _ (mult 2) 10 1.

Check binary_word_concat 32.

Check binary_word_concat 32 32.
*)

Arguments iterate {A} _ _ _.
Arguments binary_word_concat {n p} _ _.
Arguments le_S {n m} _.

Definition binary_word_duplicate (n:nat)(w:binary_word n)
 : binary_word (n+n) :=
  binary_word_concat  w w.

Definition short_concat : short -> short -> long
                        := @binary_word_concat 32 32.
Print short_concat.

Theorem le_i_SSi : forall i:nat, i <= S (S i).
Proof (fun i:nat => le_S  (le_S  (le_n i))).

Definition compose {A B C : Type} :  (A->B)->(B->C)->A->C
   := fun f g x => g (f x).

(** Tests :

Check fun (A:Type)(f:Z->A) => compose  Z_of_nat f.

Check compose  Zabs_nat (plus 78) 45%Z.

Check le_i_SSi 1515.

Check le_S  (le_i_SSi 1515).

Check compose (C := Z) S.

Check @le_S 45.

*)

Definition thrice {A:Type} (f:A->A) := compose f (compose f f).

Lemma thrice_as_iter_3 {A:Type} (f: A -> A): thrice f = iterate f 3.
Proof. reflexivity. Qed.

Lemma thrice_thrice {A:Type} (f: A -> A): thrice (thrice f) = iterate f 9.
Proof. reflexivity. Qed.

Definition my_plus : nat->nat->nat := iterate  S.

Definition my_mult (n p:nat) : nat := iterate  (my_plus n) p 0.

Definition my_expt (x n:nat) : nat := iterate (my_mult x) n 1.

Definition ackermann (n:nat) : nat->nat :=
  iterate (fun (f:nat->nat)(p:nat) => iterate  f (S p) 1)
          n
          S.

Print ackermann.
Parameter f : nat->nat.
Parameter p : nat.
Check (f (S p)).
Compute (f (S p)).
Check iterate.
Check (iterate f ).
Check iterate.
Check (fun (f:nat->nat)(p:nat) => iterate  f (S p) 1).

(** Tests :
Compute my_plus 9 7.

Compute my_expt 2 5.

*)

(** Tests :

Check forall P:Prop, P->P.

Check fun (P:Prop)(p:P) => p.

Check @refl_equal.
*)

Theorem ThirtySix : 9*4=6*6.
Proof (refl_equal 36).

Definition eq_sym  {A:Type}{x y:A}(h : x=y) : y=x :=
 eq_ind  x (fun z => z=x) (refl_equal x) y h.

(** Tests :
 Check eq_sym  ThirtySix.

Check conj.

Check or_introl.

Check or_intror.

Check and_ind.
*)

Theorem conj3 : forall P Q R:Prop, P->Q->R->P/\Q/\R.
Proof fun P Q R p q r => conj p (conj q r).

Theorem disj4_3 : forall P Q R S:Prop, R -> P\/Q\/R\/S.
Proof
 fun P Q R S r => or_intror _ (or_intror _ (or_introl _ r)).

Definition proj1' :  forall A B:Prop, A/\B->A :=
 fun (A B:Prop)(H:A/\B) => and_ind (fun (H0:A)(_:B) => H0) H.

(** Tests :

Check ex (fun z:Z => (z*z <= 37 /\ 37 < (z+1)*(z+1))%Z).

Check ex_intro.

Check ex_ind.

Check and.

*)

Check ex_ind.
Check ex_intro.

Theorem mhy : forall (P : nat -> Prop) (x : nat) , exists x, P x.
Proof.
  eapply ex_ind. Abort.

Theorem trivialProof : exists n, n = 3.
Proof
(* @ex_intro nat (fun n => n = 3) 3 eq_refl. *)
ex_intro (fun n => n = 3) 3 eq_refl.

Check eq_refl.

Check nil.

Fail Check (cons 655 (cons (-273)%Z nil)).

(*The same term with all the implicit arguments given would have had the following form*)
Fail Check (cons (A:=nat) 655 (cons (A:=Z) (-273)%Z (nil (A:=Z)))).