(** * Poly: Polymorphism and Higher-Order Functions *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).
*)

Require Export Lists.

(* ###################################################### *)
(** * Polymorphism *)
(* ###################################################### *)
(** ** Polymorphic Lists *)

(** For the last couple of chapters, we've been working just
    with lists of numbers.  Obviously, interesting programs also need
    to be able to manipulate lists with elements from other types --
    lists of strings, lists of booleans, lists of lists, etc.  We
    _could_ just define a new inductive datatype for each of these,
    for example... *)

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.)  for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the header, and the occurrences of
    [natlist] in the types of the constructors have been replaced by
    [list X].  (We can re-use the constructor names [nil] and [cons]
    because the earlier definition of [natlist] was inside of a
    [Module] definition that is now out of scope.) *)

(** What sort of thing is [list] itself?  One good way to think
    about it is that [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it another way, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is an [Inductive]ly defined set of lists whose
    elements are things of type [X]. *)

(** With this definition, when we use the constructors [nil] and
    [cons] to build lists, we need to tell Coq the type of the
    elements in the lists we are building -- that is, [nil] and [cons]
    are now _polymorphic constructors_.  Observe the types of these
    constructors: *)

Check nil.
(* ===> nil : forall X : Type, list X *)
Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** (Side note on notation: In .v files, the "forall" quantifier is
    spelled out in letters.  In the generated HTML files, [forall] is
    usually typeset as the usual mathematical "upside down A," but
    you'll see the spelled-out "forall" in a few places.  This is just
    a quirk of typesetting: there is no difference in meaning. *)

(** The "[forall X]" in these types can be read as an additional
    argument to the constructors that determines the expected types of
    the arguments that follow.  When [nil] and [cons] are used, these
    arguments are supplied in the same way as the others.  For
    example, the list containing [2] and [1] is written like this: *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** (We've gone back to writing [nil] and [cons] explicitly here
    because we haven't yet defined the [ [] ] and [::] notations for
    the new version of lists.  We'll do that in a bit.) *)

(** We can now go back and make polymorphic (or "generic")
    versions of all the list-processing functions that we wrote
    before.  Here is [length], for example: *)

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length X t)
  end.

(** Note that the uses of [nil] and [cons] in [match] patterns
    do not require any type annotations: we already know that the list
    [l] contains elements of type [X], so there's no reason to include
    [X] in the pattern.  (More precisely, the type [X] is a parameter
    of the whole definition of [list], not of the individual
    constructors.  We'll come back to this point later.)

    As with [nil] and [cons], we can use [length] by applying it first
    to a type and then to its list argument: *)

Example test_length1 :
    length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity.  Qed.

(** To use our length with other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity.  Qed.

(** Let's close this subsection by re-implementing a few other
    standard list functions on our new polymorphic lists: *)

Fixpoint app (X : Type) (l1 l2 : list X)
                : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons X h (app X t l2)
  end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil      => cons X v (nil X)
  | cons h t => cons X h (snoc X t v)
  end.

Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
  | nil      => nil X
  | cons h t => snoc X (rev X t) h
  end.

Example test_rev1 :
    rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity.  Qed.

Module MumbleBaz.
(** **** Exercise: 2 stars (mumble_grumble) *)
(** Consider the following two inductively defined types. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.
Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]
(*
well-typed:
[d mumble (b a 5)]
[d bool (b a 5)]
[e bool true]
[e mumble (b c 0)]
[c]
*)
[] *)

(** **** Exercise: 2 stars (baz_num_elts) *)
(** Consider the following inductive definition: *)

Inductive baz : Type :=
   | x : baz -> baz
   | y : baz -> bool -> baz.

(** How _many_ elements does the type [baz] have?
(* 0: there is no base type. *)
[] *)

End MumbleBaz.

(* ###################################################### *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [app] again, but this time we won't
    specify the types of any of the arguments. Will Coq still accept
    it? *)

Fixpoint app' X l1 l2 : list X :=
  match l1 with
  | nil      => l2
  | cons h t => cons X h (app' X t l2)
  end.

(** Indeed it will.  Let's see what type Coq has assigned to [app']: *)

Check app'.
(* ===> forall X : Type, list X -> list X -> list X *)
Check app.
(* ===> forall X : Type, list X -> list X -> list X *)

(** It has exactly the same type type as [app].  Coq was able to
    use a process called _type inference_ to deduce what the types of
    [X], [l1], and [l2] must be, based on how they are used.  For
    example, since [X] is used as an argument to [cons], it must be a
    [Type], since [cons] expects a [Type] as its first argument;
    matching [l1] with [nil] and [cons] means it must be a [list]; and
    so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks.  You should try to find a balance in your own code between
    too many type annotations (so many that they clutter and distract)
    and too few (which forces readers to perform type inference in
    their heads in order to understand your code). *)

(* ###################################################### *)
(** *** Type Argument Synthesis *)

(** Whenever we use a polymorphic function, we need to pass it
    one or more types in addition to its other arguments.  For
    example, the recursive call in the body of the [length] function
    above must pass along the type [X].  But just like providing
    explicit type annotations everywhere, this is heavy and verbose.
    Since the second argument to [length] is a list of [X]s, it seems
    entirely obvious that the first argument can only be [X] -- why
    should we have to write it explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write the "implicit argument"
    [_], which can be read as "Please figure out for yourself what
    type belongs here."  More precisely, when Coq encounters a [_], it
    will attempt to _unify_ all locally available information -- the
    type of the function being applied, the types of the other
    arguments, and the type expected by the context in which the
    application appears -- to determine what concrete type should
    replace the [_].

    This may sound similar to type annotation inference -- and,
    indeed, the two procedures rely on the same underlying mechanisms.
    Instead of simply omitting the types of some arguments to a
    function, like
      app' X l1 l2 : list X :=
    we can also replace the types with [_], like
      app' (X : _) (l1 l2 : _) : list X :=
    which tells Coq to attempt to infer the missing information, just
    as with argument synthesis.

    Using implicit arguments, the [length] function can be written
    like this: *)

Fixpoint length' (X:Type) (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length' _ t)
  end.

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference can be significant.  For
    example, suppose we want to write down a list containing the
    numbers [1], [2], and [3].  Instead of writing this... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use argument synthesis to write this: *)

Definition list123' := cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ###################################################### *)
(** *** Implicit Arguments *)

(** If fact, we can go further.  To avoid having to sprinkle [_]'s
    throughout our programs, we can tell Coq _always_ to infer the
    type argument(s) of a given function. *)

Implicit Arguments nil [[X]].
Implicit Arguments cons [[X]].
Implicit Arguments length [[X]].
Implicit Arguments app [[X]].
Implicit Arguments rev [[X]].
Implicit Arguments snoc [[X]].

(* note: no _ arguments required... *)
Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

(** Alternatively, we can declare an argument to be implicit while
    defining the function itself, by surrounding the argument in curly
    braces.  For example: *)

Fixpoint length'' {X:Type} (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length'' t)
  end.

(** (Note that we didn't even have to provide a type argument to
    the recursive call to [length''].)  We will use this style
    whenever possible, although we will continue to use use explicit
    [Implicit Argument] declarations for [Inductive] constructors. *)

(** One small problem with declaring arguments [Implicit] is
    that, occasionally, Coq does not have enough local information to
    determine a type argument; in such cases, we need to tell Coq that
    we want to give the argument explicitly this time, even though
    we've globally declared it to be [Implicit].  For example, suppose we
    write this: *)

(* Definition mynil := nil. *)

(** If we uncomment this definition, Coq will give us an error,
    because it doesn't know what type argument to supply to [nil].  We
    can help it by providing an explicit type declaration (so that Coq
    has more information available when it gets to the "application"
    of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

Check @nil.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** Now lists can be written just the way we'd hope: *)

Definition list123''' := [1, 2, 3].

(* ###################################################### *)
(** *** Exercises: Polymorphic Lists *)

(** **** Exercise: 2 stars, optional (poly_exercises) *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Fill in the definitions
    and complete the proofs below. *)

Fixpoint repeat (X : Type) (n : X) (count : nat) : list X :=
match count with
| 0 => @nil X
| S n' => n :: (repeat X n n')
end.
Example test_repeat1:
  repeat bool true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X:Type, forall l:list X,
  app [] l = l.
Proof.
intros X l.
reflexivity. Qed.

Theorem rev_snoc : forall X : Type,
                     forall v : X,
                     forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
intros X v s.
induction s as [| n s'].
Case "s = []".
reflexivity.
Case "s = n :: s'".
simpl.
rewrite -> IHs'.
reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
intros X l.
induction l  as [| n l'].
Case "l = []".
reflexivity.
Case "l = n::l'".
simpl.
rewrite -> rev_snoc.
rewrite -> IHl'.
reflexivity. Qed.

Theorem snoc_with_append : forall X : Type,
                         forall l1 l2 : list X,
                         forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
intros X l1 l2 v.
induction l1 as [| n l1'].
Case "l1 = []".
reflexivity.
Case "l1 = n :: l1'".
simpl.
rewrite -> IHl1'.
reflexivity. Qed.

(** [] *)

(* ###################################################### *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the type definition we gave in
    the last chapter for pairs of numbers can be generalized to
    _polymorphic pairs_ (or _products_): *)

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Implicit Arguments pair [[X] [Y]].

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

Notation "( x , y )" := (pair x y).

(** We can also use the [Notation] mechanism to define the standard
    notation for pair _types_: *)

Notation "X * Y" := (prod X Y) : type_scope.

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should be used when parsing types.  This avoids a clash with the
    multiplication symbol.) *)

(** A note of caution: it is easy at first to get [(x,y)] and
    [X*Y] confused.  Remember that [(x,y)] is a _value_ built from two
    other values; [X*Y] is a _type_ built from two other types.  If
    [x] has type [X] and [y] has type [Y], then [(x,y)] has type
    [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with (x,y) => y end.

(** The following function takes two lists and combines them
    into a list of pairs.  In many functional programming languages,
    it is called [zip].  We call it [combine] for consistency with
    Coq's standard library. *)
(** Note that the pair notation can be used both in expressions and in
    patterns... *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match (lx,ly) with
  | ([],_) => []
  | (_,[]) => []
  | (x::tx, y::ty) => (x,y) :: (combine tx ty)
  end.

(** Indeed, when no ambiguity results, we can even drop the enclosing
    parens: *)

Fixpoint combine' {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx,ly with
  | [],_ => []
  | _,[] => []
  | x::tx, y::ty => (x,y) :: (combine' tx ty)
  end.

(** **** Exercise: 1 star, optional (combine_checks) *)
(** Try answering the following questions on paper and
    checking your answers in coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does
        Eval simpl in (combine [1,2] [false,false,true,true]).
      print?   []
*)

(** **** Exercise: 2 stars (split) *)
(** The function [split] is the right inverse of combine: it takes a
    list of pairs and returns a pair of lists.  In many functional
    programing languages, this function is called [unzip].

    Uncomment the material below and fill in the definition of
    [split].  Make sure it passes the given unit tests. *)

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X)*(list Y) :=
match l with
 | [] => ([], [])
 | (x, y) :: tl => match split tl with (lx, ly) => (x :: lx, y :: ly)
end
end.

Example test_split:
  split [(1,false),(2,false)] = ([1,2],[false,false]).
Proof. reflexivity.  Qed.

(** (If you're reading the HTML version of this file, note that
    there's an unresolved typesetting problem in the example: several
    square brackets are missing.  Refer to the .v file for the correct
    version. *)
(** [] *)

(* ###################################################### *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_.
    The type declaration generalizes the one for [natoption] in the
    previous chapter: *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Implicit Arguments Some [[X]].
Implicit Arguments None [[X]].

(** We can now rewrite the [index] function so that it works
    with any type of lists. *)

Fixpoint index {X : Type} (n : nat)
               (l : list X) : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Example test_index1 :    index 0 [4,5,6,7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index  1 [[1],[2]]  = Some [2].
Proof. reflexivity.  Qed.
Example test_index3 :    index  2 [true]  = None.
Proof. reflexivity.  Qed.

(** **** Exercise: 1 star, optional (hd_opt_poly) *)
(** Complete the definition of a polymorphic version of the
    [hd_opt] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_opt {X : Type} (l : list X)  : option X :=
match l with
| nil => None
| h :: tl => Some h
end.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1,2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2 :   hd_opt  [[1],[2]]  = Some [1].
Proof. reflexivity. Qed.
(** [] *)

(* ###################################################### *)
(** * Functions as Data *)
(* ###################################################### *)
(** ** Higher-Order Functions *)

(** Like many other modern programming languages -- including
    all _functional languages_ (ML, Haskell, Scheme, etc.) -- Coq
    treats functions as first-class citizens, allowing functions to be
    passed as arguments to other functions, returned as results,
    stored in data structures, etc.

    Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Partial Application *)

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Each [->] in this expression is actually a _binary_ operator
    on types.  (This is the same as saying that Coq primitively
    supports only one-argument functions -- do you see why?)  This
    operator is _right-associative_, so the type of [plus] is really a
    shorthand for [nat -> (nat -> nat)] -- i.e., it can be read as
    saying that "[plus] is a one-argument function that takes a [nat]
    and returns a one-argument function that takes another [nat] and
    returns a [nat]."  In the examples above, we have always applied
    [plus] to both of its arguments at once, but if we like we can
    supply just the first.  This is called _partial application_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Digression: Currying *)

(** **** Exercise: 2 stars, advanced (currying) *)
(** In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
match p with (x,y) => f x y end.

(** (Thought exercise: before running these commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]?) *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
intros X Y Z f x y.
reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
intros X Y Z f p.
destruct p.
reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** ** Filter *)

(** Here is a useful higher-order function, which takes a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filters" the list, returning a new list containing just those
    elements for which the predicate returns [true]. *)

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

Example test_filter1: filter evenb [1,2,3,4] = [2,4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity.  Qed.

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1,0,3,1,4,5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0,2,4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Anonymous Functions *)

(** It is a little annoying to be forced to define the function
    [length_is_1] and give it a name just to be able to pass it as an
    argument to [filter], since we will probably never use it again.
    Moreover, this is not an isolated example.  When using
    higher-order functions, we often want to pass as arguments
    "one-off" functions that we will never use again; having to give
    each of these functions a name would be tedious.

    Fortunately, there is a better way. It is also possible to
    construct a function "on the fly" without declaring it at the top
    level or giving it a name; this is analogous to the notation we've
    been using for writing down constant lists, natural numbers, and
    so on. *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

(** Here is the motivating example from before, rewritten to use
    an anonymous function. *)

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars (filter_even_gt7) *)

(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat :=
filter (ble_nat 7) (filter evenb l).

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
Proof. reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars (partition) *)
(** Use [filter] to write a Coq function [partition]:
  partition : forall X : Type,
              (X -> bool) -> list X -> list X * list X
   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list.
*)

Definition partition {X : Type} (test : X -> bool) (l : list X)
                     : list X * list X :=
(filter test l, filter (fun x => negb (test x)) l).

Example test_partition1: partition oddb [1,2,3,4,5] = ([1,3,5], [2,4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5,9,0] = ([], [5,9,0]).
Proof. reflexivity. Qed.
(** [] *)

(* ###################################################### *)
(** ** Map *)

(** Another handy higher-order function is called [map]. *)

Fixpoint map {X Y:Type} (f:X->Y) (l:list X)
             : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

Example test_map1: map (plus 3) [2,0,2] = [5,3,5].
Proof. reflexivity.  Qed.

(** The element types of the input and output lists need not be
    the same ([map] takes _two_ type arguments, [X] and [Y]).  This
    version of [map] can thus be applied to a list of numbers and a
    function from numbers to booleans to yield a list of booleans: *)

Example test_map2: map oddb [2,1,2,5] = [false,true,false,true].
Proof. reflexivity.  Qed.

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a list of lists of booleans: *)

Example test_map3:
    map (fun n => [evenb n,oddb n]) [2,1,2,5]
  = [[true,false],[false,true],[true,false],[false,true]].
Proof. reflexivity.  Qed.

(** **** Exercise: 3 stars (map_rev) *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Lemma map_snoc : forall (X Y : Type) (f :  X -> Y) (l :  list X) (n : X),
  map f (snoc l n) = snoc (map f l) (f n).
Proof.
intros X Y f l n.
induction l as [| x l'].
Case "l = []".
reflexivity.
Case "l = x :: l'".
simpl.
rewrite -> IHl'.
reflexivity. Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
intros X Y f l.
induction l as [| n l'].
Case "l = []".
reflexivity.
Case "l = n :: l'".
simpl.
rewrite <- IHl'.
rewrite <- map_snoc.
reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars (flat_map) *)
(** The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:
        flat_map (fun n => [n,n+1,n+2]) [1,5,10]
      = [1, 2, 3, 5, 6, 7, 10, 11, 12].
*)

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
match l with
| nil => nil
| hd :: tl => app (f hd) (flat_map f tl)
end.

Example test_flat_map1:
  flat_map (fun n => [n,n,n]) [1,5,4]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
Proof. reflexivity. Qed.
(** [] *)

(** Lists are not the only inductive type that we can write a
    [map] function for.  Here is the definition of [map] for the
    [option] type: *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(** **** Exercise: 2 stars, optional (implicit_args) *)
(** The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)  [] *)

(* ###################################################### *)
(** ** Fold *)

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

(* /TERSE *)

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1,2,3,4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,
   fold plus [1,2,3,4] 0
    yields
   1 + (2 + (3 + (4 + 0))).
    Here are some more examples:
*)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 : fold mult [1,2,3,4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true,true,false,true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold app  [[1],[],[2,3],[4]] [] = [1,2,3,4].
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, advanced (fold_types_different) *)
(** Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

(* ###################################################### *)
(** ** Functions For Constructing Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as _arguments_.  Now let's look at some
    examples involving _returning_ functions as the results of other
    functions.

    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** Similarly, but a bit more interestingly, here is a function
    that takes a function [f] from numbers to some type [X], a number
    [k], and a value [x], and constructs a function that behaves
    exactly like [f] except that, when called with the argument [k],
    it returns [x]. *)

Definition override {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if beq_nat k k' then x else f k'.

(** For example, we can apply [override] twice to obtain a
    function from numbers to booleans that returns [false] on [1] and
    [3] and returns [true] on all other arguments. *)

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star (override_example) *)
(** Before starting to work on the following proof, make sure you
    understand exactly what the theorem is saying and can paraphrase
    it in your own words.  The proof itself is straightforward. *)

Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
Proof.
  intros b.
  destruct b.
  Case "b = true".
  reflexivity.
  Case "b = false".
  reflexivity.
  Qed.

(** [] *)

(** We'll use function overriding heavily in parts of the rest of the
    course, and we will end up needing to know quite a bit about its
    properties.  To prove these properties, though, we need to know
    about a few more of Coq's tactics; developing these is the main
    topic of the next chapter.  For now, though, let's introduce just
    one very useful tactic that will also help us with proving
    properties of some of the other functions we have introduced in
    this chapter. *)

(* ###################################################### *)
(** * The [unfold] Tactic *)

(** Sometimes, a proof will get stuck because Coq doesn't
    automatically expand a function call into its definition.  (This
    is a feature, not a bug: if Coq automatically expanded everything
    possible, our proof goals would quickly become enormous -- hard to
    read and slow for Coq to manipulate!) *)

Theorem unfold_example_bad : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  (* At this point, we'd like to do [rewrite -> H], since
     [plus3 n] is definitionally equal to [3 + n].  However,
     Coq doesn't automatically expand [plus3 n] to its
     definition. *)
  Admitted.

(** The [unfold] tactic can be used to explicitly replace a
    defined name by the right-hand side of its definition.  *)

Theorem unfold_example : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.  Qed.

(** Now we can prove a first property of [override]: If we
    override a function at some argument [k] and then look up [k], we
    get back the overridden value. *)

Theorem override_eq : forall {X:Type} x k (f:nat->X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.  Qed.

(** This proof was straightforward, but note that it requires
    [unfold] to expand the definition of [override]. *)

(** **** Exercise: 2 stars (override_neq) *)
Theorem override_neq : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
 intros X x1 x2 k1 k2.
 intros f H.
 unfold override.
 intros H'.
 rewrite -> H'.
 rewrite -> H.
 reflexivity.
 Qed.

(** [] *)

(** As the inverse of [unfold], Coq also provides a tactic
    [fold], which can be used to "unexpand" a definition.  It is used
    much less often. *)

(* ##################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 2 stars (fold_length) *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternate definition of [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4,7,0] = 3.
Proof. reflexivity. Qed.

(** Prove the correctness of [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  unfold fold_length.
  induction l as [| n l'].
  Case "l = []".
  reflexivity.
  Case "l = n :: l'".
  simpl.
  rewrite -> IHl'.
  reflexivity.
  Qed.

(** [] *)

(** **** Exercise: 3 stars (fold_map) *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
fold (fun x list => (f x) :: list) l [].

(** Write down a theorem in Coq stating that [fold_map] is correct,
    and prove it. *)

Theorem fold_map_correct : forall X Y (l : list X) (f : X -> Y),
  fold_map f l = map f l.
Proof.
  intros X Y l f.
  unfold fold_map.
  induction l as [| n l'].
  Case "l = []".
  reflexivity.
  Case "l = n :: l'".
  simpl.
  rewrite -> IHl'.
  reflexivity.
  Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (index_informal) *)
(** Recall the definition of the [index] function:
   Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
     match l with
     | [] => None
     | a :: l' => if beq_nat n O then Some a else index (pred n) l'
     end.
   Write an informal proof of the following theorem:
   forall X n l, length l = n -> @index X (S n) l = None.
(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 4 stars, advanced (church_numerals) *)

Module Church.

(** In this exercise, we will explore an alternative way of defining
    natural numbers, using the so-called _Church numerals_, named
    after mathematician Alonzo Church. We can represent a natural
    number [n] as a function that takes a function [f] as a parameter
    and returns [f] iterated [n] times. More formally, *)

Definition nat := forall X : Type, (X -> X) -> X -> X.

(** Let's see how to write some numbers with this notation. Any
    function [f] iterated once shouldn't change. Thus, *)

Definition one : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

(** [two] should apply [f] twice to its argument: *)

Definition two : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

(** [zero] is somewhat trickier: how can we apply a function zero
    times? The answer is simple: just leave the argument untouched. *)

Definition zero : nat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

(** More generally, a number [n] will be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f]. Notice in particular
    how the [doit3times] function we've defined previously is actually
    just the representation of [3]. *)

Definition three : nat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** Successor of a natural number *)

Definition succ (n : nat) : nat :=
fun (X : Type) (f: X -> X) (x : X) => f(n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

(** Addition of two natural numbers *)

Definition plus (n m : nat) : nat :=
fun (X : Type) (f : X -> X) (x : X) => (n X f (m X f x)).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

(** Multiplication *)

Definition mult (n m : nat) : nat :=
fun (X : Type) (f : X -> X) (x : X) => (n X (m X f) x).

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

(** Exponentiation *)

(** Hint: polymorphism plays a crucial role here. *)

Definition exp (n m : nat) : nat :=
fun (X : Type) (f : X -> X) (x : X) =>  (m (X -> X) (n X) f) x.

Check exp.
Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

Example exp_3 : exp three zero = one.
Proof. reflexivity. Qed.

End Church.

(** [] *)

(* $Date: 2013-01-23 16:48:29 -0500 (Wed, 23 Jan 2013) $ *)


From LF Require Import exercise1.
From LF Require Import exercise2.

Module NatList.

Inductive natprod : Type :=
  | pair (n1 n2 : nat).

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | pair x y => pair y x
  end.

Notation "( x , y )" := (pair x y).

Theorem surjective_pairing : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof. reflexivity. Qed.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p. destruct p. reflexivity.
Qed.

(** **** Exercise: 1 star, standard (snd_fst_is_swap) *)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p. destruct p. simpl. reflexivity.
Qed.

(** **** Exercise: 1 star, standard, optional (fst_swap_is_snd) *)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p. destruct p. simpl. reflexivity.
Qed.

Inductive natlist: Type :=
  | nil
  | cons (n: nat) (l: natlist).

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint repeat (n count: nat) : natlist :=
  match count with
  | O => nil
  | S c' => cons (n) (repeat n c')
  end.

Fixpoint length (l : natlist) : nat :=
  match l with
  | nil => O
  | cons _ l' => 1 + length l'
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | cons n l => cons n (app l l2)
  end.

Notation "x ++ y" := (app x y) (right associativity, at level 60).

(* Here are two smaller examples of programming with lists. The hd function returns the first element (the "head") of the list, while tl returns everything but the first element (the "tail"). Since the empty list has no first element, we pass a default value to be returned in that case. *)
Definition hd (default : nat) (l : natlist) : nat :=
  match l with
  | nil => default
  | cons n _ => n
  end.

Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons _ l' => l'
  end.

(** **** Exercise: 2 stars, standard, especially useful (list_funs) *)
(* Complete the definitions of nonzeros, oddmembers, and countoddmembers below.
Have a look at the tests to understand what these functions should do. *)
(* Returns all non-zero elements. *)
Fixpoint nonzeros (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons O l'     => nonzeros l'
  | cons n l' => cons n (nonzeros l')
  end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. simpl. reflexivity. Qed.

(* Returns all odd elements. *)
Fixpoint oddmembers (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons n l' => match even n with
                 | true => oddmembers l'
                 | false => cons n (oddmembers l')
                 end
  end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. simpl. reflexivity. Qed.

(* For countoddmembers, we're giving you a header that uses keyword Definition instead of Fixpoint. The point of stating the question this way is to encourage you to implement the function by using already-defined functions, rather than writing your own recursive definition. *)
Definition countoddmembers (l : natlist) : nat :=
  match l with
  | nil => O
  | cons n l' => match even n with
                 | true => length ( oddmembers l' )
                 | false => length ( oddmembers l' ) + 1
                 end
  end.

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof. simpl. reflexivity. Qed.
Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof. simpl. reflexivity. Qed.
Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof. simpl. reflexivity. Qed.

(** **** Exercise: 3 stars, advanced (alternate) *)
(* Complete the following definition of alternate, which interleaves two lists into one, alternating
between elements taken from the first list and elements from the second. See the tests below for more
specific examples.
Hint: there is an elegant way of writing alternate that fails to satisfy Coq's requirement that all
Fixpoint definitions be structurally recursing, as mentioned in Basics. If you encounter that
difficulty, consider pattern matching against both lists at the same time with the "multiple pattern"
syntax we've seen before. *)
Fixpoint alternate (l1 l2 : natlist) : natlist :=
  (* Pick exactly one element from each list alternately. *)
  match l1, l2 with
  | nil, nil => nil
  | _, nil => l1
  | nil, _ => l2
  | (cons n1 l1'), (cons n2 l2') => [n1;n2] ++ (alternate l1' l2')
  end.

Compute alternate [1;2;3] [4;5;6].

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. simpl. reflexivity. Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof. simpl. reflexivity. Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof. simpl. reflexivity. Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof. simpl. reflexivity. Qed.

Definition bag := natlist.

(** **** Exercise: 3 stars, standard, especially useful (bag_functions) *)
(* Complete the following definitions for the functions count, sum, add, and member for bags. *)
Fixpoint count (v : nat) (s : bag) : nat :=
  match s with
  | nil => O
  | cons n l' => match eqb n v with
                 | true => 1 + (count v l')
                 | false => (count v l')
                 end
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. simpl. reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. simpl. reflexivity. Qed.

Definition sum (lhs rhs : bag) : bag :=
  match lhs, rhs with
  | _, _ => lhs ++ rhs
  end.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. simpl. reflexivity. Qed.

Definition add (v : nat) (s : bag) : bag :=
  match s with
  | nil => [v]
  | cons _ _ => [v] ++ s
  end.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. simpl. reflexivity. Qed.
Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. simpl. reflexivity. Qed.

Fixpoint member (v : nat) (s : bag) : bool :=
  match s with
  | nil => false
  | cons v' s' => match eqb v' v with
                  | false => (member v s')
                  | true => true
                  end
  end.

Example test_member1: member 1 [1;4;1] = true.
Proof. simpl. reflexivity. Qed.
Example test_member2: member 2 [1;4;1] = false.
Proof. simpl. reflexivity. Qed.

(** **** Exercise: 3 stars, standard, optional (bag_more_functions) *)
(* Here are some more bag functions for you to practice with.
When remove_one is applied to a bag without the number to remove, it should return the same bag
unchanged. *)
Fixpoint remove_one (v : nat) (s : bag) : bag :=
  match s with
  | nil => s
  | cons v' s' => match eqb v' v with
                  | true => s'
                  | false => cons v' (remove_one v s')
                  end
  end.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. simpl. reflexivity. Qed.
Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. simpl. reflexivity. Qed.

Fixpoint remove_all (v : nat) (s : bag) : bag :=
  match s with
  | nil => s
  | cons v' s' => match eqb v' v with
                  | true => (remove_all v s')
                  | false => cons v' (remove_all v s')
                  end
  end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. simpl. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. simpl. reflexivity. Qed.

Fixpoint included (s1 : bag) (s2 : bag) : bool :=
  match s1 with
  | nil => true
  | cons n s' => match member n s2 with
                 | true => included s' (remove_one n s2)
                 | false => false
                 end
  end.

Example test_included1: included [1;2] [2;1;4;1] = true.
Proof. simpl. reflexivity. Qed.
Example test_included2: included [1;2;2] [2;1;4;1] = false.
Proof. simpl. reflexivity. Qed.

(** **** Exercise: 2 stars, standard, especially useful (add_inc_count) *)
(* Adding a value to a bag should increase the value's count by one.
   State this as a theorem and prove it. *)
Theorem add_inc_count : forall (n : nat) (s : bag),
  count n (add n s) = count n s + 1.
Proof.
  intros n s. destruct s.
  - simpl. rewrite eqb_refl. reflexivity.
  - simpl. rewrite eqb_refl. rewrite <- plus_n_Sm. rewrite add_0_r. reflexivity.
Qed.

(* ++ is defined right associative.. *)
Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint rev (l : natlist) : natlist :=
  match l with
  | nil => nil
  | cons n l' => app (rev l') [n]
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

(* For something a bit more challenging than the proofs we've seen so far, let's prove that reversing a
list does not change its length. Our first attempt gets stuck in the successor case... *)
Lemma app_length: forall l1 l2 : natlist,
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros l1 l2. induction l1 as [| n l' H].
  - reflexivity.
  - simpl.  rewrite -> H. reflexivity.
Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' H].
  - reflexivity.
  - simpl. rewrite -> app_length. rewrite -> H. apply add_one_right.
Qed.

(** **** Exercise: 3 stars, standard (list_exercises) *)
Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l. induction l as [ | n l' H].
  - reflexivity.
  - simpl. rewrite -> H. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2. induction l1 as [| n l' H].
  - rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> H. rewrite -> app_assoc. reflexivity.
Qed.

(* An involution is a function that is its own inverse. That is, applying the function twice yield the
original input. *)
Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l as [| n l' H].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> H. reflexivity.
Qed.

(* There is a short solution to the next one. If you find yourself getting tangled up, step back and try
to look for a simpler way. *)
Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  (* Apply association twice. *)
  intros.
  rewrite <- app_assoc. rewrite <- app_assoc. reflexivity.
Qed.

(* An exercise about your implementation of nonzeros: *)
Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2. induction l1 as [| n l' H].
  - simpl. reflexivity.
  - simpl. rewrite -> H. destruct l2.
    + rewrite -> app_nil_r. simpl. rewrite -> app_nil_r. reflexivity.
    + simpl. destruct n.
      * reflexivity.
      * reflexivity.
Qed.

(** **** Exercise: 2 stars, standard (eqblist) *)
(* Fill in the definition of eqblist, which compares lists of numbers for equality. Prove that eqblist l
l yields true for every list l. *)
Fixpoint eqblist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | nil, nil => true
  | _, nil => false
  | nil, _ => false
  | cons n1 l1', cons n2 l2' =>
    match eqb n1 n2 with
      | true => (eqblist l1' l2')
      | false => false
    end
  end.

Example test_eqblist1 :
  (eqblist nil nil = true).
Proof. simpl. reflexivity. Qed.
Example test_eqblist2 :
  eqblist [1;2;3] [1;2;3] = true.
  Proof. simpl. reflexivity. Qed.
Example test_eqblist3 :
  eqblist [1;2;3] [1;2;4] = false.
Proof. simpl. reflexivity. Qed.

Theorem eqblist_refl : forall l : natlist,
  true = eqblist l l.
Proof.
  intros l. induction l.
  - reflexivity.
  - simpl. rewrite <- IHl. rewrite eqb_refl. reflexivity.
Qed.

(** **** Exercise: 1 star, standard (count_member_nonzero) *)
Theorem count_member_nonzero : forall (s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
  intros s. destruct s.
  - reflexivity.
  - reflexivity.
Qed.

(* The following lemma about leb might help you in the next exercise (it will also be useful in later
chapters). *)
Theorem leb_n_Sn : forall n : nat,
  n <=? (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite IHn'. reflexivity.
  Qed.

(** **** Exercise: 3 stars, advanced (remove_does_not_increase_count) *)
Theorem remove_does_not_increase_count: forall (s : bag),
  (count 0 (remove_one 0 s)) <=? (count 0 s) = true.
Proof.
  intros s. induction s as [| n s' H].
  - reflexivity.
  - simpl. rewrite <- H. destruct n.
    + rewrite eqb_refl. rewrite leb_n_Sn. rewrite H. reflexivity.
    + reflexivity.
Qed.

(** **** Exercise: 3 stars, standard, optional (bag_count_sum) *)
(* Write down an interesting theorem bag_count_sum about bags involving the functions count and sum, and
prove it using Coq. (You may find that the difficulty of the proof depends on how you defined count!
Hint: If you defined count using =? you may find it useful to know that destruct works on arbitrary
expressions, not just simple identifiers.) *)
Theorem bag_count_sum: forall s1 s2 : bag,
  count 0 (sum s1 s2) = (count 0 s1) + (count 0 s2).
Proof.
  intros. induction s1 as [| n s1' H].
  - reflexivity.
  - destruct n.
    + simpl. rewrite H. reflexivity.
    + simpl. apply H.
Qed.

(** **** Exercise: 3 stars, advanced (involution_injective) *)
(* Prove that every involution is injective. Involutions were defined above in rev_involutive. An involution injective function is one-to-one: it maps distinct inputs to distinct outputs, without any collisions. *)
Theorem involution_injective : forall (f : nat -> nat),
  (forall n : nat, n = f (f n)) -> (forall n1 n2 : nat, f n1 = f n2 -> n1 = n2).
Proof.
  intros f H0 n1 n2.
  intros H1.
  rewrite H0. rewrite <- H1. apply H0.
Qed.

(** **** Exercise: 2 stars, advanced (rev_injective) *)
(* Prove that rev is injective. Do not prove this by induction -- that would be hard. Instead, re-use
the same proof technique that you used for involution_injective. Do not try to use that exercise
directly as a lemma: the types are not the same. *)
Theorem rev_injective : forall (l1 l2 : natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive. rewrite <- H. rewrite -> rev_involutive. reflexivity.
Qed.

Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Fixpoint nth_error (l : natlist) (n : nat) : natoption :=
  match l with
  | nil => None
  | cons n' l'
    => match n with
       | 0 => (Some n')
       | S next => (nth_error l' next)
       end
  end.

(* unwrap_or *)
Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

Definition hd_error (l : natlist) : natoption :=
  match l with
  | nil => None
  | cons n _ => Some n
  end.

Example test_hd_error1 : hd_error [] = None.
Proof. simpl. reflexivity. Qed.
Example test_hd_error2 : hd_error [1] = Some 1.
Proof. simpl. reflexivity. Qed.
Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. simpl. reflexivity. Qed.

(** **** Exercise: 1 star, standard, optional (option_elim_hd) *)
(* This exercise relates your new hd_error to the old hd. *)
Theorem option_elim_hd : forall (l : natlist) (default : nat),
  hd default l = option_elim default (hd_error l).
Proof.
  intros. destruct l.
  - reflexivity.
  - reflexivity.
Qed.

End NatList.

Inductive id : Type :=
  | Id (n : nat).

Definition eqb_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => n1 =? n2
  end.

(** **** Exercise: 1 star, standard (eqb_id_refl) *)
Theorem eqb_id_refl : forall x,
  eqb_id x x = true.
Proof.
  intros x. destruct x as [n].
  destruct n as [| n'].
  - reflexivity.
  - simpl. rewrite eqb_refl. reflexivity.
Qed.

Module PartialMap.
Export NatList.

Inductive partial_map : Type :=
  | empty
  | record (i : id) (v : nat) (m : partial_map).

(* The update function overrides the entry for a given key in a partial map by shadowing it with a new one
(or simply adds a new entry if the given key is not already present). *)
Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty => None
  | record y v d' => if eqb_id x y
                      then Some v
                      else find x d'
  end.

(* Exercise: 1 star, standard (update_eq) *)
Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
  intros. simpl. rewrite -> eqb_id_refl. reflexivity.
Qed.

(** **** Exercise: 1 star, standard (update_neq) *)
Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    eqb_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros. simpl. rewrite -> H. reflexivity.
Qed.

End PartialMap.


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

Require Import List.
Import ListNotations.

(** * Induction, inductive types, families & predicates *)

(**

You spent high-school doing "proofs by induction" over natural
numbers. Working in a proof assistant is a bit like going back to
high-school excepted that we shall be reasoning by induction on more
structured objects: inductive types, families and/or predicates.

 *)

(** ** Motivation *)

(** *** Practical limitations *)

(**

In Coq, we can define the following datatype and, for example, a
reversal function:

 *)

Inductive rosetree :=
| rosenode : nat -> list rosetree -> rosetree.

Fixpoint rev_rosetree (t: rosetree): rosetree :=
  match t with
  | rosenode n ts =>
    rosenode n (fold_left
                  (fun xs t => rev_rosetree t :: xs) ts [])
  end.

Compute (rev_rosetree (rosenode 1 [rosenode 2 []; rosenode 3 []])).

(**

However, the induction principle automatically generated by Coq is
rather unsettling:

 *)

Check rosetree_rect.

(**

Let us try to use to prove a property of [rev_rosetree]:

*)

Lemma rev_rev_rosetree:
  forall t, rev_rosetree (rev_rosetree t) = t.
Proof. induction t. (* WTF?! *) Abort.

(** **** Exercise: 5 stars (rosetree_ind')  *)
(**

Implement a valid induction principle of [rosetree] and prove the
above lemma.

*)

(** *** Theoretical limitations *)

(**

Why is the following definition rejected?

 *)

Fail Inductive term :=
| App : term -> term -> term
| Abs : (term -> term) -> term.

(*
Error: Non strictly positive occurrence
of "term" in "(term -> term) -> term".
*)

(** ** Inductive types *)

(** *** Signatures *)

(**

The (little known) origins of inductive types is rooted in the
mathematical study of (universal) algebra
[http://dx.doi.org/10.1145/321992.321997]. We can therefore establish
a dictionary between the programming world and the mathematical world
and exploit this connection to reason abstractly about datatypes as
programmers manipulate them:

  - an (algebraic) "datatype" corresponds to a "signature"
  - a "constructor" corresponds to an "operation"
  - a "recursive argument" in a constructor corresponds to its "arity"

*)

(** **** Exercise: 1 star (fml) *)
(**

Implement a datatype [Fml] of propositional formulas parameterized
over [P : Set] that implements the following description found in
"Mathematical logic" (Cori & Lascar):

    ``The set [Fml] of propositional formulas over [P] is the
      smallest set that

    - contains [P]
    - contains [¬ F], for every formula [F] it contains
    - contains [F ∧ G], [F ∨ G] and [F ⇒ G], for
      every [F] and [G] it contains''

*)

(**

In this section, we consider the familiar datatype of binary trees:

*)

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

(** **** Exercise: 1 star (tree)  *)
(** What is the arity of the [Leaf] constructor? What is the arity of
the [Node] constructor? *)

(**

In fact, given an inductive type, such as [tree] above, we can
_always_ decompose it into a non-recursive signature ([sigma_tree],
below) and a generic fixpoint operator ([tree'], below):

 *)

Inductive sigma_tree (X: Type): Type :=
| OpLeaf : sigma_tree X
| OpNode : nat -> X -> X -> sigma_tree X.

Inductive tree' : Type :=
  | Constr : sigma_tree tree' -> tree' .

(**

The non-recursive definition [sigma_tree] is generally called the
"signature functor" of the inductive type. It is built from a fixed
grammar of type operators: product, sums and functions. Put another
way, algebraic datatypes are said to be defined by "sums of
products". The generic fixpoint operator is said to "tie the knot" by
defining [tree'] through a layer of [sigma_tree] applied to [tree']
itself.

*)

(** **** Exercise: 1 star (iso_tree_tree')  *)

(** Implement a pair of functions [phi : tree -> tree'] and [psi :
tree' -> tree] witnessing the fact that the types [tree'] and [tree]
are isomorphic. *)

Axiom phi: tree -> tree'. (* XXX: implement me! *)
Axiom psi: tree' -> tree. (* XXX: implement me! *)

(** **** Exercise: 2 stars (psi_phi)  *)
(** Prove the following lemma: *)

Lemma psi_phi: forall t, psi (phi t) = t.
Proof.
  admit.
Qed.

(** **** Exercise: 5 stars (phi_psi)  *)
(** Prove the following lemma: *)

Lemma phi_psi: forall t, phi (psi t) = t.
Proof.
  admit.
Qed.

(** *** Initiality *)

Section List.

Variable A X: Type.

(** **** Exercise: 2 stars (sigma_list)  *)

(** Decompose the datatype [list A] into a signature [sigma_list] and
its fixpoint [list']. Convince yourself (or prove) that [list A] is
isomorphic to [list']. *)

Inductive sigma_list (X: Type) :=
.

Inductive list' : Type :=
.

(** We assume that we are given an _algebra_ [alpha] over lists: *)

Variable alpha : sigma_list X -> X.

(** **** Exercise: 3 stars (fold_list)  *)

(** Using [alpha], implement a function [fold_list] of type [list A ->
X]. You may find some inspiration by using [Print] on Coq's
implementation of [fold_right]. *)

End List.

(** **** Exercise: 3 stars (fold_length)  *)
(** By defining a suitable algebra [alpha_length], implement the
function [length : list A -> nat] using [fold_list]. *)

Section FoldTree.

Variable X: Type.

(** **** Exercise: 4 stars (fold_tree)  *)
(** Using [alpha], implement a function [fold_tree] of type [tree ->
X]. *)

Axiom fold_tree : forall (alpha : sigma_tree X -> X), tree -> X. (* XXX: implement me! *)

(**

We can show (in meta-mathematics, not in Coq), that every algebra
[alpha : sigma_tree X -> X] induces a unique function [tree -> X]: this
is called the _initial algebra semantics_ of inductive types. This is
the equivalent of a Design Pattern for functional programmers: it is a
general principle for understanding recursion.

*)

End FoldTree.

(** **** Exercise: 3 stars (fold_height)  *)
(** By defining a suitable algebra [alpha_height], implement the
function [height : tree -> nat] using [fold_tree]. *)

(** *** Interlude: visitor pattern *)

(** Object-oriented programmers will recognize a familiar (if more
verbose) pattern in [fold_tree]: *)

(**
<<
interface TreeVisitor {
    void visit(Node n);
    void visit(Leaf l);
}

interface TreeElement {
    void accept(TreeVisitor visitor);
}

class Node implements TreeElement {
    private int x;
    print TreeElement l, r;

    public void accept(TreeVisitor visitor) {
        l.accept(visitor); visitor.visit(this);
        r.accept(visitor);
    }
    (...)
}
>>
*)

(** ** Induction over inductive types *)

(**

Let us consider the skeleton of a high-school proof by induction:

  - Statement:
    "We show by recurrence the following property: ``for all n, P(n)''"
  - Initialization:
    "We show that the property is true for n = 0, ie. P(0)."
  - Heredity:
    "Assume that the property is true at m, ie. P(m). We show that the
     property is true at P(m+1)."
  - Conclusion:
    "By recurrence, we conclude that the property is true for all n."

In type theory, this translates to:

*)

Section TestInd.

Hypothesis P: nat -> Type.              (** Statement *)
Hypothesis init: P 0.                (** Initialization *)
Hypothesis step: forall m, P m -> P (S m). (** Heredity *)
Check (nat_rect P init step).        (** Conclusion *)

End TestInd.

(**

However, induction is not limited to natural numbers! In particular,
in lecture 2, we shall see that we can perform induction on semantics
judgements (ie. inductively defined relations). To understand
induction more generally, we consider the datatype of trees, whose
induction principle (automatically generated by Coq) is instructive:

*)

Check tree_rect.
(* tree_rect
     : forall P : tree -> Type,
       P Leaf ->
       (forall (n : nat) (t : tree), P t -> forall t0 : tree, P t0 -> P (Node n t t0)) ->
       forall t : tree, P t
*)

(** This type signature exhibits some similarity with the type
signature of the recursion principle over trees [fold_tree]. To
simplify our study of induction principles, we adopt a _uniform_
treatment of the inductive hypothesis, using a gadget similar to
[sigma_tree]. *)

Section Tree_rect'.

Hypothesis P: tree -> Type.

(** **** Exercise: 3 stars (sigma_ind_tree)  *)
(** Define a non-recursive predicate [sigma_ind_tree : tree -> Type]
that asserts that [P] holds in every subtree of the given tree. Do you
identify any similarity with [sigma_tree]? *)

Inductive sigma_ind_tree: tree -> Type :=
.

(** [sigma_ind_tree] is called the _predicate lifting_: it applies the
predicate [P] to all subtrees of a given node. *)

(** **** Exercise: 5 stars (tree_rect')  *)
(** Implement the uniform induction principle [tree_rect'] *)

Definition tree_rect':
 (forall t, sigma_ind_tree t -> P t) -> forall t : tree, P t.
Proof.
  admit.
Defined.

(** The function of type [forall t, sigma_ind_tree t -> P t] required by the
induction principle is genuinely a (uniformly presented) _induction
step_: we must explain how we can transport an invariant [P] holding
on subtrees to an invariant holding on the whole node. *)

End Tree_rect'.

(** **** Exercise: 4 stars (nat_rect')  *)
(** Following the previous example, implement the uniform induction
principle [nat_rect'] over natural numbers. *)

(** *** Induction vs. recursion *)

(** There is a striking similarity between the recursion principles *)

Check sigma_tree.
Check fold_tree.

(** and the induction principles. *)

Check sigma_ind_tree.
Check tree_rect'.

(** Unsurprisingly, we can emulate recursion if we have induction. *)

(** **** Exercise: 4 stars (recursion_from_induction)  *)

(** Implement [fold_tree' : forall X : Type, (sigma_tree X -> X) -> tree -> X]
using _only_ [tree_rect'] (in particular, you are not allowed to
[match] on a tree) *)

(* Phantom type, to know where computations come from: *)
Definition fold_tree'_def : tree -> Type -> Type := fun t X => X.

Definition fold_tree' : forall X : Type, (sigma_tree X -> X) -> tree -> X.
intros X IH t.
change X with (fold_tree'_def t X).
induction t using tree_rect'.
  admit.
Defined.

Section TryInd.

Hypothesis P: tree -> Type.
Hypothesis init: P Leaf.
Hypothesis step: forall n l r, P l -> P r -> P (Node n l r).

(** Sadly, the converse is impossible: ``Induction is not derivable in
$\lambda$P2'', [http://repository.tue.nl/661317]. The best we can do
is to define an algebra on _pairs_ of the term and its predicate. *)

(** **** Exercise: 5 stars (dep_algebra)  *)
(** Define an algebra [alg (xs: sigma_tree { t : tree & P t }): { t :
tree & P t }] for which the pseudo-induction principle [tree_ind'] is
"correct" (see next exercise for the meaning of "correctness" in this
case). *)

Axiom alg: sigma_tree { t : tree & P t } -> { t : tree & P t }. (* XXX: implement me! *)

Definition tree_ind' (t: tree): { t : tree & P t } :=
  fold_tree alg t.

(** **** Exercise: 4 stars (induction_from_recursion)  *)
(** Prove that your pseudo-induction principle is correct, ie. that we have: *)
Lemma tree_ind'_correct: forall t, projT1 (tree_ind' t) = t.
Proof.
  admit.
Qed.

End TryInd.

(** ** Inductive families *)

(**

Once we have understood inductive types, their recursion schemes and
their induction principles, inductive families come with no
surprises. In terms of universal algebra, we are merely going from
mono-sorted signatures to multi-sorted signatures. For example, the
definition of well-formed red-black trees below is basically a binary
tree whose operations and arities carry an information about the arity
at which these objects exist/must be:

*)

Unset Implicit Arguments. (* being fully explicit may help see the details *)

Inductive color := red | black.

Inductive rbt: color -> nat -> Type :=
| bleaf:
    nat -> rbt black 0
| rnode: forall n,
    rbt black n -> rbt black n -> rbt red n
| bnode: forall c1 c2 n,
    rbt c1 n -> rbt c2 n -> rbt black (S n).

(** The induction principle may look slightly intimidating but, in fact,
the same principles govern the definition of the (uniform) induction
principle of red-black trees. *)

Check rbt_rect.
(* rbt_rect:
  forall P : forall c n, rbt c n -> Type,
    (forall n : nat, P black 0 (bleaf n)) ->
    (forall n l r,
         P black n l -> P black n r
       -> P red n (rnode n l r)) ->
    (forall c1 c2 n l r,
        P c1 n l -> P c2 n r
      -> P black (S n) (bnode c1 c2 n l r)) ->
    forall c n t, P c n t
*)

Section RBTRect'.

Hypothesis P: forall c n, rbt c n -> Type.

(** **** Exercise: 2 stars (rbt_sigma_ind)  *)
(** Define the predicate lifting of red-black trees: *)
Inductive rbt_sigma_ind : forall c n, rbt c n -> Type :=
.

(** **** Exercise: 4 stars (rbt_rect')  *)
(** Using the predicate lifting, implement the induction principle for
red-black trees: *)
Definition rbt_rect':
  (forall c n t, rbt_sigma_ind c n t -> P c n t) ->
  forall c n (t: rbt c n), P c n t.
Proof.
  admit.
Defined.

End RBTRect'.

Section VecRect'.

Variable A : Type.

(** **** Exercise: 1 star (vect)  *)
(** Define the inductive family [vect : nat -> Type] which is such that
inhabitants of [vect n] are the lists containing [n] elements of [A],
by construction (and only those lists).  *)

Inductive vect : nat -> Type :=
.

Hypothesis P : forall n, vect n -> Type.

(** **** Exercise: 2 star (vect_sigma_ind)  *)
(** Implement the predicate lifting [vect_sigma_ind : forall n, vect n ->
Type] of vectors. *)

Inductive vect_sigma_ind : forall n, vect n -> Type :=
.

(** **** Exercise: 3 star (vect_rect')  *)
(** Deduce its uniform induction principle. *)

Axiom vect_rect' :
         forall (IH: forall n t, vect_sigma_ind n t -> P n t)
         {n} (t: vect n), P n t. (* XXX: implement me! *)

(** ** Mutual induction *)

(** Having developed a good understanding of inductive definitions and
induction, we can revisit the motivation for this lecture, ie. the
inappropriate induction principle generated by Coq for [rosetree]. We
may be tempted to manually unfold the definition of [list rosetree]
into a mutually-inductive definition, without much luck. *)

Reset rosetree.

Inductive rosetree :=
| rosenode:
    nat -> list_rosetree -> rosetree
with list_rosetree :=
| rosenil:
    list_rosetree
| rosecons:
    rosetree -> list_rosetree -> list_rosetree.

Check rosetree_rect.
(* rosetree_rect
     : forall P : rosetree -> Type,
       (forall (n : nat) (l : list_rosetree), P (rosenode n l)) -> forall r : rosetree, P r
*)

Reset rosetree.

(** **** Exercise: 2 star (rosetreeIx)  *)
(** One way to effectively sidestep Coq's limitation is to define an
indexed family [rosetreeIx: bool -> Type] which is equivalent to
[rosetree]. Could this pattern be generalized to any
mutually-inductive definition? *)

Inductive rosetreeIx: bool -> Type :=
.

Check rosetreeIx_rect.

(** Alternatively, the command [Combined Scheme] could have worked as
well. *)

(** ** Strict positivity *)

Section StrictPositivity.

Variable A : Type.

(** Some inductive definitions, such as the following, are rightfully
rejected by Coq *)

Fail Inductive T :=
| c : (T -> A) -> T.

(** because, if we were to accept such definition, we could write the
following programs that build an inhabitant of _any_ type [A], thus
including [False], which ought to be impossible. *)

(*
<<
Definition funny (t: T)(x: T): A :=
  match t with
  | c f => f x
  end.

Definition haha (t: T): A := funny t t.

Definition bottom: A := haha (c haha).
>> *)

(** A _strictly positive_ definition admits "no recursion to the left
of an arrow": the intuition is that if we were to allow a recursive
argument to appear on the left of an arrow, we could suddenly encode a
diagonal argument, as we did above in [haha]. Coq only allows you to
write strictly-positive inductive definitions. Being a syntactic
check, it is necessarily conservative: sometimes you may need to
massage your definitions to convince Coq that they are legitimate. *)

End StrictPositivity.

(** ** Conclusion *)

(** Today, you have learned:
      - About Inductive definitions:
        + Non-indexed ⊆ indexed
        + Mutual ≈ indexed
        + Positivity criteria
      - About Induction
        + Induction = recursion + proof
        + Mechanically derivable from signature
        + Not always fully supported by Coq...
*)

(** Take-aways:
      - Recursion: for any inductive type, you are able to
          + define its signature functor
          + switch between uniform and specialized recursion
          + implement a uniform recursion operator

      - Induction: for any inductive type or inductive family, you are able to
          + define its predicate lifting
          + switch between uniform and specialized induction
          + implement a uniform induction operator
*)


Require Export List.
Require Export ListSet.
Set Implicit Arguments.
Unset Strict Implicit.

(*********************************************************************)
(*                  Some List Functions                              *)
(*********************************************************************)

Definition front (A : Set) (l : list A) : list A := rev (tail (rev l)).

Definition last (A : Set) (l : list A) := head (rev l).

Fixpoint take (A : Set) (n : nat) (l : list A) {struct l} :
 list A :=
  match l with
  | nil => nil (A:=A)
  | a :: l' => match n with
               | O => nil (A:=A)
               | S m => a :: take m l'
               end
  end.

Fixpoint allunique (A : Set) (l : list A) {struct l} : Prop :=
  match l with
  | nil => True
  | x :: l' => IF In x l' then False else allunique l'
  end.

(*********************************************************************)
(*                  Some Functions for ListSet                       *)
(*********************************************************************)

Definition IsEmpty (A : Set) (B : set A) := forall x : A, ~ set_In x B.

Definition Included (A : Set) (B C : set A) :=
  forall x : A, set_In x B -> set_In x C.

Lemma AllWaysIncluded : forall (A : Set) (B : set A), Included B B.
intros.
unfold Included in |- *.
auto.

Qed.

(*********************************************************************)
(*                  Some Results about ListSet                       *)
(*********************************************************************)
Section ListSetLemmas.

Variable A : Set.

Hypothesis Aeq_dec : forall x y : A, {x = y} + {x <> y}.

Lemma Set_union1 :
 forall (B C : set A) (x : A),
 set_In x (set_union Aeq_dec B C) -> ~ set_In x B -> set_In x C.
intros.
cut (set_In x B \/ set_In x C).
intro H1; elim H1.
tauto.

auto.

eapply (set_union_elim Aeq_dec); auto.

Qed.

Lemma Set_union2 :
 forall (B C : set A) (x : A),
 set_In x (set_union Aeq_dec B C) -> set_In x (set_union Aeq_dec C B).
intros.
cut (set_In x C \/ set_In x B).
intro; apply set_union_intro.
auto.

cut (set_In x B \/ set_In x C).
tauto.

eapply (set_union_elim Aeq_dec).
auto.

Qed.

Lemma Set_remove2 :
 forall (B : set A) (x y : A),
 set_In x (set_remove Aeq_dec y B) -> set_In x B.
intro; intro; intro.
induction  B as [| a B HrecB].
auto.

simpl in |- *.
elim (Aeq_dec y a).
intros.
right.
auto.

simpl in |- *.
intro.
intro.
elim H.
intro.
left; auto.

intro.
right.
auto.
Qed.

Lemma Set_add1 :
 forall (B : set A) (x y : A),
 set_In x (set_add Aeq_dec y B) -> x <> y -> set_In x B.
intros.
cut (x = y \/ set_In x B).
intro.
elim H1.
intro.
absurd (x = y).
auto.

auto.

intro.
auto.

eapply (set_add_elim (A:=A) Aeq_dec).
auto.

Qed.

Lemma Set_add2 :
 forall (B : set A) (x y : A),
 x <> y -> ~ set_In x B -> ~ set_In x (set_add Aeq_dec y B).
intros.
intro.
apply H0.
eapply (Set_add1 (B:=B) (x:=x) (y:=y)); auto.

Qed.

End ListSetLemmas.

Hint Unfold IsEmpty Included.
Hint Resolve Set_remove2 Set_add1 AllWaysIncluded Set_union1 Set_union2
  Set_add2.

Lemma Listeq_dec :
 forall A : Set,
 (forall a b : A, {a = b} + {a <> b}) ->
 forall x y : list A, {x = y} + {x <> y}.
simple induction x.
simple induction y.
auto.

intros.
right.
unfold not in |- *; intro D; discriminate D.

intros.
induction  y as [| a0 y Hrecy].
right; unfold not in |- *; intro D; discriminate D.

elim (H0 y).
intro.
rewrite a1.
elim (H a a0).
intro.
rewrite a2.
left; auto.

intro.
right.
unfold not in |- *.
unfold not in b.
intro; apply b.
injection H1.
auto.

unfold not in |- *; intro.
right.
intro; apply b.
injection H1.
auto.

Qed.

Hint Resolve Listeq_dec.

Lemma Prodeq_dec :
 forall A B : Set,
 (forall x y : A, {x = y} + {x <> y}) ->
 (forall v w : B, {v = w} + {v <> w}) ->
 forall c d : A * B, {c = d} + {c <> d}.
intros.
elim c.
elim d.
intros.
elim (H a a0); intro.
rewrite a1.
elim (H0 b b0); intro.
rewrite a2.
left; auto.

right.
intro.
apply b1.
injection H1; auto.

right; intro; apply b1.
injection H1; auto.

Qed.

Hint Resolve Prodeq_dec.


Require Import Comparison.
Require Import ComparisonDecOrd.

Module natComparision <: ComparisonSig.

Definition A := nat.

Fixpoint compare (a b : nat) {struct a} : comparison :=
match a,b with
| O, O => Eq
| O, _ => Lt
| _, O => Gt
| (S a'), (S b') => compare a' b'
end.

Infix "?=" := compare (at level 70) : nat_scope.

Lemma compare_refl : forall a b, a ?= b = Eq <-> a = b.
Proof.
intros.
split.
generalize b.
clear b.
induction a; induction b; intros; try discriminate H.
reflexivity.
rewrite IHa with b.
reflexivity.
apply H.
intros.
subst.
induction b.
reflexivity.
apply IHb.
Qed.

Lemma compare_antisym : forall a b, CompOpp (a ?= b) = (b ?= a).
Proof.
induction a; induction b; intros; try reflexivity.
simpl.
apply IHa.
Qed.

Lemma compare_trans : forall a b c,
(a ?= b) = (b ?= c) -> (a ?= b) = (a ?= c) /\ (b ?= c) = (a ?= c).
Proof.
apply trans_simp.
induction x; induction y; induction z; intros; auto.
rewrite <- (compare_antisym 0 (S y)) in H.
destruct (0 ?= S y); try discriminate H.
auto.
discriminate H.
simpl.
apply IHx.
apply H.
Qed.

End natComparision.

Module natDecOrd <: DecidableOrder.Sig := CompareDecOrd natComparision.
Export natDecOrd.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_s_n_ncol_col.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_n_col_ncol :
	forall A B C,
	~ Col A B C ->
	nCol A B C.
Proof.
	intros A B C.
	intros n_Col_A_B_C.
	assert (~ ~ nCol A B C) as nn_nCol_A_B_C.
	{
		intros n_nCol_A_B_C.

		pose proof (lemma_s_n_ncol_col _ _ _ n_nCol_A_B_C) as Col_A_B_C.

		contradict Col_A_B_C.
		exact n_Col_A_B_C.
	}
	apply Classical_Prop.NNPP in nn_nCol_A_B_C.
	exact nn_nCol_A_B_C.
Qed.

End Euclid.


Require Import Tac.
Require Export Coq.Logic.Classical.

Definition excluded_middle := classic.

Lemma double_neg :
  forall P,
  ~~ P <-> P.
Proof. intuition tauto. Qed.

Lemma contrapositive :
  forall P Q,
  (~ Q -> ~ P) ->
  P -> Q.
Proof. intros. pose proof (excluded_middle Q) as HQ. inverts1 HQ; tauto. Qed.

Lemma not_iff :
  forall P Q,
  (P <-> Q) <-> (~ P <-> ~ Q).
Proof. intuition tauto. Qed.

Lemma not_and__or :
  forall P Q,
  ~ (P /\ Q) <-> ~ P \/ ~ Q.
Proof. intuition tauto. Qed.

Lemma not_or__and :
  forall P Q,
  ~ (P \/ Q) <-> ~ P /\ ~ Q.
Proof. intuition tauto. Qed.

Lemma imply__or :
  forall (P Q : Prop),
  (P -> Q) <-> (~ P \/ Q).
Proof. intuition tauto. Qed.

Lemma not_imply__and :
  forall (P Q : Prop),
  ~ (P -> Q) <-> (P /\ ~ Q).
Proof. intuition tauto. Qed.

Lemma not_forall__exists_not :
  forall A (P : A -> Prop),
  ~ (forall x, P x) <-> (exists x, ~ P x).
Proof.
  intros. split.
  - apply contrapositive. rewrite double_neg. intros. destruct (classic (P x)).
    * assumption.
    * exfalso. eauto.
  - iauto.
Qed.

Lemma forall_not__exists :
  forall A (P : A -> Prop),
  (forall x, P x) <-> ~ (exists x, ~ P x).
Proof.
  intros. rewrite not_iff. rewrite double_neg. apply not_forall__exists_not.
Qed.


Require Import Nat Arith.

Inductive lst : Type := Nil : lst | Cons : nat -> lst -> lst.

Inductive queue : Type := Queue : lst -> lst -> queue.

Fixpoint len (len_arg0 : lst) : nat
           := match len_arg0 with
              | Nil => 0
              | Cons x y => plus 1 (len y)
              end.

Definition qlen (qlen_arg0 : queue) : nat
           := let 'Queue x y := qlen_arg0 in
              plus (len x) (len y).

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Definition amortizeQueue (amortizeQueue_arg0 : lst) (amortizeQueue_arg1 : lst) : queue
           := match amortizeQueue_arg0, amortizeQueue_arg1 with
              | x, y => if leb (len y) (len x) then Queue x y else Queue (append x (rev y)) Nil
              end.

Definition qpush (qpush_arg0 : queue) (qpush_arg1 : nat) : queue
           := match qpush_arg0, qpush_arg1 with
              | Queue x y, n => amortizeQueue x (Cons n y)
              end.

Definition queue_to_lst (queue_to_lst_arg0 : queue) : lst
           := let 'Queue x y := queue_to_lst_arg0 in
              append x (rev y).

Lemma append_nil : forall (l : lst), append l Nil = l.
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Theorem theorem0 : forall (q : queue) (n : nat), eq (append (queue_to_lst q) (Cons n Nil)) (queue_to_lst (qpush q n)).
Proof.
  intros.
  destruct q.
  induction l.
  - simpl. rewrite append_nil. reflexivity.
  - simpl. simpl in IHl. rewrite IHl. unfold amortizeQueue. simpl. destruct (len l) eqn:?.
    + simpl. destruct (len l0 <=? 0) eqn:?.
      * simpl. rewrite append_nil. reflexivity.
      * simpl. reflexivity.
    + destruct (len l0 <=? n1) eqn:?.
      * simpl. apply Nat.leb_le in Heqb. apply le_S in Heqb. rewrite <- Nat.leb_le in Heqb. rewrite Heqb. simpl. reflexivity.
      * destruct (len l0 <=? S n1) eqn:?.
        -- simpl. rewrite append_nil. reflexivity.
        -- simpl. reflexivity.
Qed.