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

(* Final reminder: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export Lists_done.

(* ################################################################# *)
(** * Polymorphism *)

(** 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).  We begin with 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 of type [X]. *)

Check list.
(* ===> list : Type -> Type *)

(** The parameter [X] in the definition of [list] becomes a parameter
    to the constructors [nil] and [cons] -- that is, [nil] and [cons]
    are now polymorphic constructors, that need to be supplied with
    the type of the list they are building. As an example, [nil nat]
    constructs the empty list of type [nat]. *)

Check (nil nat).
(* ===> nil nat : list nat *)

(** Similarly, [cons nat] adds an element of type [nat] to a list of
    type [list nat]. Here is an example of forming a list containing
    just the natural number 3.*)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

(** What might the type of [nil] be? We can read off the type [list X]
    from the definition, but this omits the binding for [X] which is
    the parameter to [list]. [Type -> list X] does not explain the
    meaning of [X]. [(X : Type) -> list X] comes closer. Coq's
    notation for this situation is [forall X : Type, list X]. *)

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

(** Similarly, the type of [cons] from the definition looks like
    [X -> list X -> list X], but using this convention to explain the
    meaning of [X] results in the type [forall X, X -> list X -> 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 and in the
    way various IDEs show .v files (with certain settings of their
    display controls), [forall] is usually typeset as the usual
    mathematical "upside down A," but you'll still see the spelled-out
    "forall" in a few places.  This is just a quirk of typesetting:
    there is no difference in meaning.) *)

(** Having to supply a type argument for each use of a list
    constructor may seem an awkward burden, but we will soon see
    ways of reducing that burden. *)

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

(** (We've written [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 versions of all the
    list-processing functions that we wrote before.  Here is [repeat],
    for example: *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

(** As with [nil] and [cons], we can use [repeat] by applying it
    first to a type and then to an element of this type (and a number): *)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

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

Module MumbleGrumble.

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)] no
      - [d mumble (b a 5)] yes
      - [d bool (b a 5)] yes
      - [e bool true] yes
      - [e mumble (b c 0)] yes
      - [e bool (b c 0)] no
      - [c] no *)
End MumbleGrumble.

(* Do not modify the following line: *)
Definition manual_grade_for_mumble_grumble : option (prod nat string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Type Annotation Inference *)

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

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

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

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

(** It has exactly the same type as [repeat].  Coq was able
    to use _type inference_ to deduce what the types of [X], [x], and
    [count] 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 [count]
    with [0] and [S] means it must be a [nat]; 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, so we will continue to use them most of the time.  You
    should try to find a balance in your own code between too many
    type annotations (which can 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 *)

(** To 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 [repeat] function above must
    pass along the type [X].  But since the second argument to
    [repeat] is an element of [X], 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 try to figure out for yourself
    what 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 -- indeed, the
    two procedures rely on the same underlying mechanisms.  Instead of
    simply omitting the types of some arguments to a function, like

      repeat' X x count : list X :=

    we can also replace the types with [_]

      repeat' (X : _) (x : _) (count : _) : list X :=

    to tell Coq to attempt to infer the missing information.

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

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference in both keystrokes and
    readability is nontrivial.  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 *)

(** We can go further and even avoid writing [_]'s in most cases by
    telling Coq _always_ to infer the type argument(s) of a given
    function.

    The [Arguments] directive specifies the name of the function (or
    constructor) and then lists its argument names, with curly braces
    around any arguments to be treated as implicit.  (If some
    arguments of a definition don't have a name, as is often the case
    for constructors, they can be marked with a wildcard pattern
    [_].) *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** Now, we don't have to supply type arguments at all: *)

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

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

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [repeat''']; indeed, it would be invalid to
    provide one!)

    We will use the latter style whenever possible, but we will
    continue to use explicit [Argument] declarations for [Inductive]
    constructors.  The reason for this is that marking the parameter
    of an inductive type as implicit causes it to become implicit for
    the type itself, not just for its constructors.  For instance,
    consider the following alternative definition of the [list]
    type: *)

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

(** Because [X] is declared as implicit for the _entire_ inductive
    definition including [list'] itself, we now have to write just
    [list'] whether we are talking about lists of numbers or booleans
    or anything else, rather than [list' nat] or [list' bool] or
    whatever; this is a step too far. *)

(** Let's finish 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 h (app t l2)
  end.

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

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

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

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

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

(* ----------------------------------------------------------------- *)
(** *** Supplying Type Arguments Explicitly *)

(** 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 just this time.  For
    example, suppose we write this: *)

Fail Definition mynil := nil.

(** (The [Fail] qualifier that appears before [Definition] can be
    used with _any_ command, and is used to ensure that that command
    indeed fails when executed. If the command does fail, Coq prints
    the corresponding error message, but continues processing the rest
    of the file.)

    Here, Coq gives 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 *)

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

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l.
  - simpl. reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl. reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
(** Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l.
  - simpl. reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl. simpl. 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_, often called _products_: *)

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

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 product _types_: *)

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

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

(** 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,
    while [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 other functional languages, it is often
    called [zip]; we call it [combine] for consistency with Coq's
    standard library. *)

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

        Compute (combine [1;2] [false;false;true;true]).

      print? *)
Check @combine.
Compute (combine [1;2] [false;false;true;true]).

(** **** Exercise: 2 stars, recommended (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
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (a, b) :: t => ((a :: fst (split t)), (b :: snd (split t)))
  end.

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

(* ================================================================= *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_,
    which generalize [natoption] from the previous chapter.  (We put
    the definition inside a module because the standard library
    already defines [option] and it's this one that we want to use
    below.) *)

Module OptionPlayground.

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

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

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

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

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

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

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | a :: _ => Some a
  end.

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

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. reflexivity. Qed.
(** [] *)

(* ################################################################# *)
(** * Functions as Data *)

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

(* ================================================================= *)
(** ** Higher-Order Functions *)

(** 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.

(* ================================================================= *)
(** ** Filter *)

(** Here is a more useful higher-order function, taking a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filtering" 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 arguably a little sad, in the example just above, 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.  We can construct a function
    "on the fly" without declaring it at the top level or giving it a
    name. *)

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

(** The expression [(fun n => n * n)] can be read as "the function
    that, given a number [n], yields [n * n]." *)

(** Here is the [filter] example, 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 (fun n => (negb (leb n 7)) && evenb n) 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 n => negb (test n)) 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 (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** The element types of the input and output lists need not be
    the same, since [map] takes _two_ type arguments, [X] and [Y]; it
    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.

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

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

Lemma map_distr_app : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2.
  induction l1.
  - simpl. reflexivity.
  - simpl. rewrite IHl1. 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.
  - simpl. reflexivity.
  - simpl. rewrite map_distr_app. simpl. rewrite IHl. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, recommended (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
  | [] => []
  | a :: t => f a ++ flat_map f t
  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.

(** 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))).

    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? *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_fold_types_different : option (prod nat string) := None.
(** [] *)

(* ================================================================= *)
(** ** Functions That Construct Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as arguments.  Let's look at some examples that
    involve _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.

(** 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 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.

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

Module Exercises.

(** **** Exercise: 2 stars (fold_length)  *)
(** Many common functions on lists can be implemented in terms of
    [fold].  For example, here is an alternative 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]. *)

Lemma fold_cons_S : forall (X : Type) (x : X) (l : list X),
  fold_length (x :: l) = S (fold_length l).
Proof.
  intros X x l.
  destruct l.
  - reflexivity.
  - reflexivity.
Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l.
  - reflexivity.
  - rewrite fold_cons_S. 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 acc => f x :: acc) l [].

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

Theorem fold_dist_cons : forall X Y (f : X -> Y -> Y) (x : X) (l : list X) (acc : Y),
  fold f (x :: l) acc = f x (fold f l acc).
Proof.
  intros X Y f x l acc.
  destruct l.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem fold_map_dist_cons : forall X Y (f : X -> Y) (x : X) (l : list X),
  fold_map f (x :: l) = f x :: fold_map f l.
Proof.
  intros X Y f x l.
  destruct l.
  - reflexivity.
  - reflexivity.
Qed.

Theorem fold_map_correct : forall X Y (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  intros X Y f l.
  induction l.
  - simpl. reflexivity.
  - simpl. rewrite fold_map_dist_cons. rewrite IHl. reflexivity.
Qed.

(* Do not modify the following line: *)
Definition manual_grade_for_fold_map : option (prod nat string) := None.
(** [] *)

(** **** 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
  | (a, b) => f a b
  end.

(** As a (trivial) example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

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

(** Thought exercise: before running the following 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.
(** [] *)

(** **** Exercise: 2 stars, advanced (nth_error_informal)  *)
(** Recall the definition of the [nth_error] function:

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

   Write an informal proof of the following theorem:

   forall X n l, length l = n -> @nth_error X l n = None
*)
(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (prod nat string) := None.
(** [] *)

(** **** Exercise: 4 stars, advanced (church_numerals)  *)
(** This exercise explores 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. *)

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

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

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

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

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

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

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

(** More generally, a number [n] can 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 Church 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.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type: [nat] itself is usually problematic.) *)

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

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.

(* Do not modify the following line: *)
Definition manual_grade_for_succ_plus_mult_exp : option (prod nat string) := None.
(** [] *)

End Exercises.


(*
 * Source: https://github.com/christ2go/gherkin/blob/main/gentree.v
 *
 *)

Require Import Nat.
Require Import List.
Import ListNotations.
Require Import Relations.
Require Import PeanoNat.

(** MTrees are the trees we pickle into
 *)
Inductive Ntree : Type := NLeaf: nat -> Ntree | NBranch:  nat -> list Ntree -> Ntree.

Section correct_ntree_ind.

Variables
  (A : Set)(P : Ntree -> Prop).
Hypotheses
  (H : forall (a:nat)(l:list (Ntree)), (forall x, In x l -> P x) -> P (NBranch a l))

 (H1 : forall t:Ntree, P t -> forall l:list (Ntree), (forall x, In x l -> P x) -> (forall x, In x (cons t l) -> P x))
 (H2: forall (n: nat), P(NLeaf n)).
Lemma  H0: forall x, In x [] -> P x.
  intros x H4.  destruct H4.
  Qed.
Fixpoint ntree_ind2 (t:Ntree) : P t :=
  match t as x return P x with
  | NBranch a l =>
      H a l
        (((fix l_ind (l':list (Ntree)) : (forall x, In x l' -> P x) :=
             match l' as x return forall y, In y x -> P y with
             | nil => H0
             | cons t1 tl => H1 t1 (ntree_ind2 t1) tl (l_ind tl)
             end)) l)
  | NLeaf x => H2 x
  end.

End correct_ntree_ind.
Definition list_eq (A: Type) (f: A -> A -> bool) (l1 l2: list A) :=
  let fll := fix gh (l1 l2:list A) :=
                 match (l1, l2) with
                   (nil ,nil) => true
                 | (a::xr1, b::xr2) => if f a b then gh xr1 xr2 else false
                 | _ => false end
             in fll l1 l2.
Fixpoint ntree_eq_dec (n1 n2: Ntree) : bool :=
  match (n1, n2) with
    (NLeaf a ,NLeaf b) => if Nat.eq_dec a b then true else false
  | (NBranch a xr1, NBranch b xr2) => if Nat.eq_dec a b then list_eq Ntree ntree_eq_dec xr1 xr2 else false
  | _ => false end.

(**
   Note: I know that this proof is quite ugly, sorry :-(
 **)

Definition ntree_equal_dec_lemma: forall (x1 x2: Ntree), x1 = x2 <-> (ntree_eq_dec x1 x2) = true .
Proof.
  intro.
  induction x1 using ntree_ind2.
  - intro x2. destruct x2.
    split.
    + intro. congruence.
    + intro.   simpl ntree_eq_dec in H1.  congruence.
    + split.
      intro.
      inversion H1.
      simpl ntree_eq_dec.
      destruct (Nat.eq_dec n n). subst l0. induction l. simpl.  reflexivity.
      simpl list_eq. enough (ntree_eq_dec a0 a0 = true).
      rewrite H2. apply IHl. intros x H4. apply H. right. assumption.
      rewrite H3.
      reflexivity.
      apply H.
      left. auto.
      reflexivity.
      congruence.
      intro H1.
      simpl ntree_eq_dec in H1.
      destruct (Nat.eq_dec a n).
      enough (l = l0).
      subst a.  subst l. reflexivity.
      assert (forall (l' l'': list Ntree), (forall x, In x l' -> In x l) -> list_eq Ntree ntree_eq_dec l' l'' = true <-> l' = l'').
      intro l'.
      induction l'.
      *  intro l''. intro Hx. destruct l''. firstorder eauto.
         split. intro. simpl list_eq in H2.  congruence.  intro. inversion H2.
      *  intros l'' H2. split.
         destruct l''.
         intro. simpl in  H3.  congruence.
         intro. assert (l' = l'').
         apply IHl'. intros. apply H2. right. auto.
         simpl in  H3. destruct (ntree_eq_dec a0 n0). auto.  congruence.
         assert (a0 = n0).  apply H.  apply H2.  left. auto.
         simpl in H3. destruct ( ntree_eq_dec a0 n0). reflexivity. congruence.  rewrite H4.  rewrite H5.
         reflexivity.
         destruct l''.
         intro. congruence.
         intro.
         simpl list_eq.
         inversion H3.
         enough((ntree_eq_dec n0 n0) = true).
         rewrite H4.
         inversion H3.  rewrite<- H6.
         apply IHl'. intros x H10. apply H2. right. auto.
         reflexivity.
         apply H. rewrite<- H5.
         apply H2. left. auto.
         reflexivity.
      *   apply H2.   intro. auto.
          auto.
      *      congruence.
  -    intro.       destruct H1.
       subst x1_2.
       apply IHx1_1.
       apply H.  auto.
  -  intro.
     destruct x2.
     + split.
       intro.
       inversion H.
       simpl ntree_eq_dec.  destruct (Nat.eq_dec n0 n0).  reflexivity.
       congruence.
       simpl ntree_eq_dec. destruct (Nat.eq_dec n n0). subst n. firstorder eauto.
       intro. congruence.
     +  split. intro. congruence.
        intro. simpl ntree_eq_dec in H. congruence.
Defined.

(*
  * We can embed Ltrees / Gentrees (Ltrees are just gentrees with nat as a type)
  * into lists of (nat * nat) + nat.
  * The proofs of this equivalence are based on proofs from the stdpp library.
  *)
Definition flatten {A: Type} (l: list (list A)) : list A :=
  List.fold_right (@app A) [] l.

Fixpoint ntree_to_list (t : Ntree ) : list ((nat *  nat) + nat) :=
  match t with
  | NLeaf x => [inr x]
  | NBranch n ts =>  (flatten (List.map ntree_to_list ts )) ++ [ @inl (nat*nat) nat (length ts, n) ]
  end.

Fixpoint ntree_of_list
    (k : list (Ntree)) (l : list (nat * nat + nat)) : option (Ntree) :=
  match l with
  | [] => head k
  | inr x :: l => ntree_of_list (NLeaf x :: k) l
  | inl (len,n) :: l =>
     ntree_of_list (NBranch n (rev' (firstn len k)) :: skipn len k) l
  end.

Tactic Notation "trans" constr(A) := transitivity A.

Lemma take_app_alt {A: Type} (l: list A) k :  firstn (length l) (l ++ k) = l.
Proof.
  induction l.
  - reflexivity.
  - simpl firstn.  rewrite IHl. reflexivity.
Qed.

Lemma drop_app_alt {A: Type} (l: list A) k :  skipn (length l) (l ++ k) = k.
Proof.
  induction l.
  - reflexivity.
  - simpl skipn.  rewrite IHl. reflexivity.
Qed.

Lemma ntree_of_to_list k l (t : Ntree) :
  ntree_of_list k (ntree_to_list t ++ l) = ntree_of_list (t :: k) l.
Proof.
  revert t k l. fix FIX 1. intros [|n ts] k l; simpl; auto.
    trans (ntree_of_list (rev' ts ++ k) ([inl (length ts, n)] ++ l)).
  -   rewrite<- app_assoc. revert k. generalize ([inl (length ts, n)] ++ l).
      induction ts as [|t ts'' IH]; intros k ts'''; simpl; auto.
      unfold rev. simpl rev_append.   rewrite<- app_assoc.  rewrite FIX. rewrite IH.
      unfold rev' at 2. simpl rev_append. rewrite rev_append_rev. rewrite<- app_assoc. simpl app at 3.  repeat rewrite<- app_assoc.  unfold rev'.
     rewrite rev_append_rev. rewrite app_nil_r . reflexivity.
  -  simpl.
     enough ((length ts) = length (rev' ts)).
     rewrite H.
     rewrite take_app_alt.
     rewrite drop_app_alt.
     unfold rev'.
     rewrite rev_append_rev.
     rewrite<- rev_alt.
     rewrite rev_involutive.
     enough (ts++[] = ts).
     rewrite H1.
     reflexivity.
     induction ts. simpl. reflexivity. simpl. rewrite IHts.  reflexivity.
     unfold rev'.
     rewrite rev_append_rev.
     enough ((rev ts)++[] = rev ts).
     rewrite H1.
     symmetry. apply rev_length.
     induction (rev ts). simpl. reflexivity. simpl. rewrite IHl0.  reflexivity.
     symmetry. unfold rev'.
     rewrite rev_append_rev. rewrite app_nil_r .  apply rev_length.
Qed.

Require Import List.
Import ListNotations.

Definition cumulative {X} (L: nat -> list X) :=
  forall n, exists A, L (S n) = L n ++ A.
  Global Hint Extern 0 (cumulative _) => intros ?; cbn; eauto : core.

Lemma cum_ge {X} {L: nat -> list X} {n m} :
  cumulative L -> m >= n -> exists A, L m = L n ++ A.
Proof.
  induction 2 as [|m _ IH].
  - exists nil. now rewrite app_nil_r.
  - destruct (H m) as (A&->), IH as [B ->].
    exists (B ++ A). now rewrite app_assoc.
Qed.

Lemma cum_ge' {X} {L: nat -> list X} {x n m} :
  cumulative L -> In x (L n) -> m >= n -> In x (L m).
Proof.
  intros ? H [A ->] % (cum_ge (L := L)). apply in_app_iff. eauto. eauto.
Qed.

Definition list_enumerator {X} (L: nat -> list X) (p : X -> Prop) :=
  forall x, p x <-> exists m, In x (L m).
Definition list_enumerable {X} (p : X -> Prop) :=
  exists L, list_enumerator L p.

Definition list_enumerator__T' X f := forall x : X, exists n : nat, In x (f n).
Notation list_enumerator__T f X := (list_enumerator__T' X f).
Definition list_enumerable__T X := exists f : nat -> list X, list_enumerator__T f X.
Definition inf_list_enumerable__T X := { f : nat -> list X | list_enumerator__T f X }.

Section enumerator_list_enumerator.
  Variable X : Type.
  Variable p : X -> Prop.
  Variables (e : nat -> option X).

  Let T (n : nat) : list X :=  match e n with Some x => [x] | None => [] end.

  Lemma enumerator_to_list_enumerator : forall x, (exists n, e n = Some x) <-> (exists n, In x (T n)).
  Proof.
    split; intros [n H].
    - exists n. unfold T. rewrite H. firstorder.
    - unfold T in *. destruct (e n) eqn:E. inversion H; subst. eauto. destruct H1.  destruct H.
  Qed.

End enumerator_list_enumerator.

Definition enumerable {X} (p : X -> Prop) := exists f, forall x, p x <-> exists n : nat, f n = Some x.
Definition enumerable__T X := exists f : nat -> option X, forall x, exists n, f n = Some x.

Lemma enumerable_list_enumerable {X} {p : X -> Prop} :
  enumerable p -> list_enumerable p.
Proof.
  intros [f Hf]. eexists.
  unfold list_enumerator.
  intros x. rewrite <- enumerator_to_list_enumerator.
  eapply Hf.
Qed.

Lemma enumerable__T_list_enumerable {X} :
  enumerable__T X -> list_enumerable__T X.
Proof.
  intros [f Hf]. eexists.
  unfold list_enumerator.
  intros x. rewrite <- enumerator_to_list_enumerator.
  eapply Hf.
Qed.
(* bijection from nat * nat to nat *)
Definition embed '(x, y) : nat :=
  y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)).

(* bijection from nat to nat * nat *)
Definition unembed (n : nat) : nat * nat :=
  nat_rec _ (0, 0) (fun _ '(x, y) => match x with S x => (x, S y) | _ => (S y, 0) end) n.

Lemma embedP {xy: nat * nat} : unembed (embed xy) = xy.
Proof.
  assert (forall n, embed xy = n -> unembed n = xy).
    intro n. revert xy. induction n as [|n IH].
      intros [[|?] [|?]]; intro H; inversion H; reflexivity.
    intros [x [|y]]; simpl.
      case x as [|x]; simpl; intro H.
        inversion H.
      rewrite (IH (0, x)); [reflexivity|].
      inversion H; simpl. rewrite Nat.add_0_r. reflexivity.
    intro H. rewrite (IH (S x, y)); [reflexivity|].
    inversion H. simpl. rewrite Nat.add_succ_r. reflexivity.
  apply H. reflexivity.
Qed.

Lemma unembedP {n: nat} : embed (unembed n) = n.
Proof.
  induction n as [|n IH]; [reflexivity|].
  simpl. revert IH. case (unembed n). intros x y.
  case x as [|x]; intro Hx; rewrite <- Hx; simpl.
    rewrite Nat.add_0_r. reflexivity.
  rewrite ?Nat.add_succ_r. simpl. rewrite ?Nat.add_succ_r. reflexivity.
Qed.
Arguments embed : simpl never.

Module EmbedNatNotations.
  Notation "⟨ a , b ⟩" := (embed (a, b)) (at level 0).
End EmbedNatNotations.
Section enumerator_list_enumerator.

  Variable X : Type.
  Variables (T : nat -> list X).

  Let e (n : nat) : option X :=
    let (n, m) := unembed n in
    nth_error (T n) m.

  Lemma list_enumerator_to_enumerator : forall x, (exists n, e n = Some x) <-> (exists n, In x (T n)).
  Proof.
    split; intros [k H].
    - unfold e in *.
      destruct (unembed k) as (n, m).
      exists n. eapply (nth_error_In _ _ H).
    - unfold e in *.
      eapply In_nth_error in H as [m].
      exists (embed (k, m)). now rewrite embedP, H.
  Qed.

End enumerator_list_enumerator.

Definition enumerator {X} (f : nat -> option X) (P : X -> Prop) : Prop :=
	  forall x, P x <-> exists n, f n = Some x.

Lemma list_enumerator_enumerator {X} {p : X -> Prop} {T} :
  list_enumerator T p -> enumerator (fun n => let (n, m) := unembed n in
    nth_error (T n) m) p.
Proof.
  unfold list_enumerator.
  intros H x. rewrite list_enumerator_to_enumerator. eauto.
Qed.

Lemma list_enumerable_enumerable {X} {p : X -> Prop} :
  list_enumerable p -> enumerable p.
Proof.
  intros [T HT]. eexists.
  unfold list_enumerator.
  intros x. rewrite list_enumerator_to_enumerator.
  eapply HT.
Qed.

Lemma list_enumerable__T_enumerable {X} :
  list_enumerable__T X -> enumerable__T X.
Proof.
  intros [T HT]. eexists.
  unfold list_enumerator.
  intros x. rewrite list_enumerator_to_enumerator.
  eapply HT.
Qed.

Lemma enum_enumT {X} :
  enumerable__T X <-> list_enumerable__T X.
Proof.
  split.
  eapply enumerable__T_list_enumerable.
  eapply list_enumerable__T_enumerable.
Qed.

Definition to_cumul {X} (L : nat -> list X) := fix f n :=
  match n with 0 => [] | S n => f n ++ L n end.

Lemma to_cumul_cumulative {X} (L : nat -> list X) :
  cumulative (to_cumul L).
Proof.
  eauto.
Qed.

Lemma to_cumul_spec {X} (L : nat -> list X) x :
  (exists n, In x (L n)) <-> exists n, In x (to_cumul L n).
Proof.
  split.
  - intros [n H].
    exists (S n). cbn. eapply in_app_iff. eauto.
  - intros [n H].
    induction n; cbn in *.
    + inversion H.
    + eapply in_app_iff in H as [H | H]; eauto.
Qed.

Lemma cumul_In {X} (L : nat -> list X) x n :
  In x (L n) -> In x (to_cumul L (S n)).
Proof.
  intros H. cbn. eapply in_app_iff. eauto.
Qed.

Lemma In_cumul {X} (L : nat -> list X) x n :
  In x (to_cumul L n) -> exists n, In x (L n).
Proof.
  intros H. eapply to_cumul_spec. eauto.
Qed.

Lemma Cumul_Step {X} (L : nat -> list X) x n :
  forall m, n < m -> In x (L n) -> In x (to_cumul L m).
Proof.
  intros m. intros E. induction E. firstorder eauto.  apply cumul_In. assumption.
  intro. simpl to_cumul. apply in_app_iff. left. apply IHE. assumption.
Qed.

Global Hint Resolve cumul_In In_cumul : core.

Lemma list_enumerator_to_cumul {X} {p : X -> Prop} {L} :
  list_enumerator L p -> list_enumerator (to_cumul L) p.
Proof.
  unfold list_enumerator.
  intros. rewrite H.
  eapply to_cumul_spec.
Qed.

Lemma cumul_spec__T {X} {L} :
  list_enumerator__T L X -> list_enumerator__T (to_cumul L) X.
Proof.
  unfold list_enumerator__T.
  intros. now rewrite <- to_cumul_spec.
Qed.

Lemma cumul_spec {X} {L} {p : X -> Prop} :
  list_enumerator L p -> list_enumerator (to_cumul L) p.
Proof.
  unfold list_enumerator.
  intros. now rewrite <- to_cumul_spec.
Qed.

Module ListAutomationNotations.

  Notation "x 'el' L" := (In x L) (at level 70).
  Notation "A '<<=' B" := (incl A B) (at level 70).

  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).

End ListAutomationNotations.
Import ListAutomationNotations.

Ltac in_app n :=
  (match goal with
  | [ |- In _ (_ ++ _) ] =>
    match n with
    | 0 => idtac
    | 1 => eapply in_app_iff; left
    | S ?n => eapply in_app_iff; right; in_app n
    end
  | [ |- In _ (_ :: _) ] => match n with 0 => idtac | 1 => left | S ?n => right; in_app n end
  end) || (repeat (try right; eapply in_app_iff; right)).

Require Import Lia Arith.
Local Set Implicit Arguments.
Local Unset Strict Implicit.

Global Hint Extern 4 =>
match goal with
|[ H: ?x el nil |- _ ] => destruct H
end : core.

Global Hint Extern 4 =>
match goal with
|[ H: False |- _ ] => destruct H
|[ H: true=false |- _ ] => discriminate H
|[ H: false=true |- _ ] => discriminate H
end : core.
Lemma incl_nil X (A : list X) :
  nil <<= A.
Proof. intros x []. Qed.

Hint Rewrite <- app_assoc : list.
Hint Rewrite rev_app_distr map_app prod_length : list.
Global Hint Resolve in_eq in_nil in_cons in_or_app : core.
Global Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app incl_nil : core.

Lemma app_incl_l X (A B C : list X) :
A ++ B <<= C -> A <<= C.
Proof.
firstorder eauto.
Qed.

Lemma app_incl_R X (A B C : list X) :
A ++ B <<= C -> B <<= C.
Proof.
firstorder eauto.
Qed.

Lemma cons_incl X (a : X) (A B : list X) : a :: A <<= B -> A <<= B.
Proof.
intros ? ? ?. eapply H. firstorder.
Qed.

Lemma incl_sing X (a : X) A : a el A -> [a] <<= A.
Proof.
now intros ? ? [-> | [] ].
Qed.

Global Hint Resolve app_incl_l app_incl_R cons_incl incl_sing : core.

Global Hint Extern 4 (_ el map _ _) => eapply in_map_iff : core.
Global Hint Extern 4 (_ el filter _ _) => eapply filter_In : core.

Section Inclusion.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma incl_nil_eq A :
    A <<= nil -> A=nil.

  Proof.
    intros D. destruct A as [|x A].
    - reflexivity.
    - exfalso. apply (D x). auto.
  Qed.

  Lemma incl_shift x A B :
    A <<= B -> x::A <<= x::B.

  Proof. auto. Qed.

  Lemma incl_lcons x A B :
    x::A <<= B <-> x el B /\ A <<= B.
  Proof.
    split.
    - intros D. split; hnf; auto.
    - intros [D E] z [F|F]; subst; auto.
  Qed.

  Lemma incl_rcons x A B :
    A <<= x::B -> ~ x el A -> A <<= B.

  Proof. intros C D y E. destruct (C y E) as [F|F]; congruence. Qed.

  Lemma incl_lrcons x A B :
    x::A <<= x::B -> ~ x el A -> A <<= B.

  Proof.
    intros C D y E.
    assert (F: y el x::B) by auto.
    destruct F as [F|F]; congruence.
  Qed.

  Lemma incl_app_left A B C :
    A ++ B <<= C -> A <<= C /\ B <<= C.
  Proof.
    firstorder.
  Qed.

End Inclusion.

Require Import Setoid Morphisms.

Instance incl_preorder X :
  PreOrder (@incl X).
Proof.
  constructor; hnf; unfold incl; auto.
Qed.

Definition equi X (A B : list X) : Prop := incl A B /\ incl B A.
Local Notation "A === B" := (equi A B) (at level 70).
Global Hint Unfold equi : core.

Instance equi_Equivalence X :
  Equivalence (@equi X).
Proof.
  constructor; hnf; firstorder.
Qed.

Instance incl_equi_proper X :
  Proper (@equi X ==> @equi X ==> iff) (@incl X).
Proof.
  hnf. intros A B D. hnf. firstorder.
Qed.

Instance cons_incl_proper X x :
  Proper (@incl X ==> @incl X) (@cons X x).
Proof.
  hnf. apply incl_shift.
Qed.

Instance cons_equi_proper X x :
  Proper (@equi X ==> @equi X) (@cons X x).
Proof.
  hnf. firstorder.
Qed.

Instance in_incl_proper X x :
  Proper (@incl X ==> Basics.impl) (@In X x).
Proof.
  intros A B D. hnf. auto.
Qed.

Instance in_equi_proper X x :
  Proper (@equi X ==> iff) (@In X x).
Proof.
  intros A B D. firstorder.
Qed.

Instance app_incl_proper X :
  Proper (@incl X ==> @incl X ==> @incl X) (@app X).
Proof.
  intros A B D A' B' E. auto.
Qed.

Instance app_equi_proper X :
  Proper (@equi X ==> @equi X ==> @equi X) (@app X).
Proof.
  hnf. intros A B D. hnf. intros A' B' E.
  destruct D, E; auto.
Qed.
Notation cumul := (to_cumul).

Ltac inv H := inversion H; subst; clear H.

Definition dec (X: Prop) : Type := {X} + {~ X}.

Coercion dec2bool P (d: dec P) := if d then true else false.
Definition is_true (b : bool) := b = true.

Existing Class dec.

Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Lemma Dec_reflect (X: Prop) (d: dec X) :
  is_true (Dec X) <-> X.
Proof.
  destruct d as [A|A]; cbv in *; intuition congruence.
Qed.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> is_true (Dec X).
Proof.
  destruct d as [A|A]; cbn; intuition congruence.
Qed.

(* Lemma Dec_auto_not (X: Prop) (d: dec X) : *)
(*   ~ X -> ~ Dec X. *)
(* Proof. *)
(*   destruct d as [A|A]; cbn; tauto. *)
(* Qed. *)

(* Hint Resolve Dec_auto Dec_auto_not : core. *)
Global Hint Extern 4 =>  (* Improves type class inference *)
match goal with
  | [  |- dec ((fun _ => _) _) ] => cbn
end : typeclass_instances.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

Lemma Dec_true P {H : dec P} : dec2bool (Dec P) = true -> P.
Proof.
  decide P; cbv in *; firstorder.
Qed.

Lemma Dec_false P {H : dec P} : dec2bool (Dec P) = false -> ~P.
Proof.
  decide P; cbv in *; firstorder.
Qed.

Global Hint Extern 4 =>
match goal with
  [ H : dec2bool (Dec ?P) = true  |- _ ] => apply Dec_true in  H
| [ H : dec2bool (Dec ?P) = true |- _ ] => apply Dec_false in H
end : core.

(* Decided propositions behave classically *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

(* Propagation rules for decisions *)

Fact dec_transfer P Q :
  P <-> Q -> dec P -> dec Q.
Proof.
  unfold dec. tauto.
Qed.

Instance True_dec :
  dec True.
Proof.
  unfold dec; tauto.
Qed.

Instance False_dec :
  dec False.
Proof.
  unfold dec; tauto.
Qed.

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec; tauto.
Qed.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Qed.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Qed.

(* Coq standard modules make "not" and "iff" opaque for type class inference,
   can be seen with Print HintDb typeclass_instances. *)

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. firstorder eauto.
Qed.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. firstorder eauto.
Qed.

(* Discrete types *)
Require Import PslBase.EqDec.

Structure eqType := EqType {
  eqType_X :> Type;
  eqType_dec : eq_dec eqType_X }.

Arguments EqType X {_} : rename.

Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.

Existing Instance eqType_dec.

Instance unit_eq_dec :
  eq_dec unit.
Proof.
  unfold dec. decide equality.
Qed.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  unfold dec. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  unfold dec. decide equality.
Defined.

Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold dec. decide equality.
Defined.

Instance sum_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance option_eq_dec X :
  eq_dec X -> eq_dec (option X).
Proof.
  unfold dec. decide equality.
Defined.

Instance Empty_set_eq_dec:
  eq_dec Empty_set.
Proof.
  unfold dec. decide equality.
Qed.

Instance True_eq_dec:
  eq_dec True.
Proof.
  intros x y. destruct x,y. now left.
Qed.

Instance False_eq_dec:
  eq_dec False.
Proof.
  intros [].
Qed.

  Notation "[ s | p ∈ A ',' P ]" :=
    (map (fun p => s) (filter (fun p => Dec P) A)) (p pattern).

Section L_list_def.
  Context {X : Type}.
  Variable (L : nat -> list X).
  Import ListAutomationNotations.
  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

  Fixpoint L_list (n : nat) : list (list X) :=
	  match n
	  with
	  | 0 => [ [] ]
	  | S n => L_list n ++ [x :: L | (x,L) ∈ (cumul L n × L_list n)]
	  end.

End L_list_def.

Lemma L_list_cumulative {X} L : cumulative (@L_list X L).
Proof.
  intros ?; cbn; eauto.
Qed.

Ltac in_collect a :=
  eapply in_map_iff; exists a; split; [ eauto | match goal with
                                              _ => try (rewrite !in_prod_iff; repeat split) end ].

Lemma enumerator__T_list {X} L :
  list_enumerator__T L X -> list_enumerator__T (L_list L) (list X).
Proof.
  intros H l.
  induction l.
  - exists 0. cbn. eauto.
  - destruct IHl as [n IH].
    destruct (cumul_spec__T H a) as [m ?].
    exists (1 + n + m). cbn. intros. in_app 2.
    in_collect (a,l).
    all: eapply cum_ge'; eauto using L_list_cumulative; lia.
Qed.

Section L_sum_def.
  Context {X1 X2 : Type}.
  Variables (L1 : nat -> list X1) (L2: nat -> list X2).
  Import ListAutomationNotations.
  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

  Definition L_sum_list (n : nat) : list (X1+X2) :=
	  (List.map inl (L1 n)) ++ (List.map inr (L2 n))
	 .

End L_sum_def.

Lemma enumerator_sum_list {X1 X2} L1 L2 :
  list_enumerator__T L1 X1 -> list_enumerator__T L2 X2 -> list_enumerator__T (L_sum_list L1 L2) (X1+X2).
Proof.
  intros H1 H2.
  intro.
  destruct x.
  - destruct (H1 x) as [n1 Hn1].
   exists n1.  unfold L_sum_list. rewrite in_app_iff.
    left. apply in_map_iff. exists x. firstorder eauto.
  - destruct (H2 x).    unfold L_sum_list. exists x0. rewrite in_app_iff.
    right. apply in_map_iff.  exists x. split; firstorder eauto.
Qed.

(* Pickles X1 * X2 *)
Section L_prod_def.
  Context {X1 X2 : Type}.
  Variables (L1 : nat -> list X1) (L2: nat -> list X2).
  Import ListAutomationNotations.
  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

  Definition L_prod_list (n : nat) : list (X1*X2) :=
	   ((L1 n) × (L2 n)).

End L_prod_def.

  Fact list_prod_spec X Y l m c : In c (@list_prod X Y l m) <-> In (fst c) l /\ In (snd c) m.
  Proof.
    revert c; induction l as [ | x l IHl ]; intros c; simpl; try tauto.
    rewrite in_app_iff, IHl, in_map_iff; simpl.
    split.
    + intros [ (y & <- & ?) | (? & ?) ]; simpl; auto.
    + intros ([ -> | ] & ? ); destruct c; simpl; firstorder.
  Qed.

Lemma enumerator_prod_list {X1 X2} L1 L2 :
  list_enumerator__T L1 X1 -> list_enumerator__T L2 X2 -> list_enumerator__T (L_prod_list (to_cumul L1) (to_cumul L2)) (X1*X2).
Proof.
  intros H1 H2.
  intro.
  destruct x as [x1 x2].
  specialize (H1 x1). specialize (H2 x2).
  destruct H1 as [n1 Hn1]. destruct H2 as [n2 Hn2].
  exists (S(Nat.max n1 n2)).

  apply list_prod_spec.
  split.
  simpl fst.
  apply Cumul_Step with n1.
  lia.
  auto.

  apply Cumul_Step with n2.
  lia.
  exact Hn2.
Qed.

Lemma  enumerable_list {X} : list_enumerable__T X -> list_enumerable__T (list X).
Proof.
  intros [L H].
  eexists. now eapply enumerator__T_list.
Qed.

Lemma  enumerable_sum {X1 X2} : list_enumerable__T X1 -> list_enumerable__T X2 -> list_enumerable__T (X1+X2).
Proof.
  intros [L1 H1]. intros  [L2 H2].

  eexists. now eapply enumerator_sum_list.
Qed.

Lemma  enumerable_prod {X1 X2} : list_enumerable__T X1 -> list_enumerable__T X2 -> list_enumerable__T (X1*X2).
Proof.
  intros [L1 H1]. intros  [L2 H2].

  eexists. now eapply enumerator_prod_list.
Qed.
Lemma enumNatNat: enumerable__T ((nat*nat)+nat).
Proof.
  enough (H: enumerable__T nat).
  apply enum_enumT.
  apply enumerable_sum.
  apply enum_enumT.
  apply enum_enumT.

  apply enumerable_prod. apply enum_enumT. apply H.
  apply enum_enumT. apply H. apply enum_enumT. apply H.
  unfold enumerable__T.
  exists (fun x => Some x).  intro. eauto.
Defined.
Lemma enumerableDecodeEncode (A B: Type)
      (code: A -> B)
      (decode: B -> option A)
      (H1: forall a, (decode (code a)) = Some a)
      (enumB: enumerable__T B)
  : enumerable__T A.
Proof.
  unfold enumerable__T.
  destruct enumB as [fb Hb].
  exists (fun n => match (fb n) with None => None | Some x => (decode x) end).
  intro a. specialize (H1 a).
  specialize (Hb (code a)).
  destruct Hb. exists x. rewrite H. apply H1.
Defined.

Lemma enumLtree: enumerable__T Ntree.
Proof.
  apply (@enumerableDecodeEncode Ntree (list ((nat*nat)+nat)) ntree_to_list (ntree_of_list [])  ).
  intro.
  pose (ntree_of_to_list [] [] a).
  rewrite app_nil_r in e.
  rewrite e.
  simpl ntree_of_list.
  reflexivity.
  apply  enum_enumT.
  apply enumerable_list.
  apply enum_enumT.
  apply enumNatNat.
Defined.

(** Ntrees are decidable **)
Instance Ntree_eq_dec :
  eq_dec Ntree.
Proof.
  intros x y.
  destruct ((ntree_eq_dec x y)) eqn:H.
  left.
  apply ntree_equal_dec_lemma.
  auto.
  right. intro.  apply ntree_equal_dec_lemma in H1. congruence.
Defined.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.bachmann_s_lotschnittaxiom_variant.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section weak_inverse_projection_postulate_bachmann_s_lotschnittaxiom.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Formalization of a proof from Bachmann's article "Zur Parallelenfrage" *)

Lemma weak_inverse_projection_postulate__bachmann_s_lotschnittaxiom_aux :
  weak_inverse_projection_postulate -> forall A1 A2 B1 B2 C1 C2 Q P R M,
  Perp A1 A2 B1 B2 -> Perp A1 A2 C1 C2 -> Col A1 A2 Q -> Col B1 B2 Q ->
  Col A1 A2 P -> Col C1 C2 P -> Col B1 B2 R ->
  Coplanar Q P R C1 -> Coplanar Q P R C2 -> ~ Col Q P R ->
  InAngle M P Q R -> CongA M Q P M Q R ->
  Par_strict B1 B2 C1 C2 /\ exists S, Out Q M S /\ Col C1 C2 S.
Proof.
intro hrap.
intros A1 A2 B1 B2 C1 C2 Q P R M HPerpAB HPerpAC.
intros HCol1 HCol2 HCol3 HCol4 HCol5 HCop1 HCop2 HNC HM1 HM2.
assert_diffs.
assert (HNCol1 : ~ Col A1 A2 R) by (intro; apply HNC, (col3 A1 A2); auto).
assert (HNCol2 : ~ Col B1 B2 P) by (intro; apply HNC, (col3 B1 B2); auto).
assert (HPar : Par_strict B1 B2 C1 C2).
  {
  apply par_not_col_strict with P; Col.
  assert (Col A1 P Q /\ Col A2 P Q /\ Col B1 R Q /\ Col B2 R Q)
    by (repeat split; [apply col_transitivity_1 with A2|apply (col_transitivity_2 A1)
                      |apply col_transitivity_1 with B2|apply (col_transitivity_2 B1)]; auto).
  spliter.
  assert (Coplanar Q P R A1) by Cop.
  assert (Coplanar Q P R A2) by Cop.
  assert (Coplanar Q P R B1) by Cop.
  assert (Coplanar Q P R B2) by Cop.
  apply l12_9 with A1 A2; Perp; apply coplanar_pseudo_trans with Q P R; assumption.
  }
split; [assumption|].
assert (HNCol3 : ~ Col Q C1 C2) by (apply par_not_col with B1 B2; Par; Col).
assert (Per P Q R).
  {
  apply perp_per_2, perp_col2 with A1 A2; Col;
  apply perp_sym, perp_col2 with B1 B2; Col; Perp.
  }
assert (HSuma : SumA P Q M P Q M P Q R).
  assert_diffs; apply conga3_suma__suma with P Q M M Q R P Q R; CongA; SumA.
assert (HAcute : Acute P Q M).
{ apply nbet_sams_suma__acute with P Q R; auto.
    intro; apply HNC; Col.
  assert (LeA P Q M P Q R) by Lea.
  apply sams_lea2__sams with P Q R P Q R; SumA.
}
assert (HC3 : exists C3, Col C1 C2 C3 /\ OS P Q R C3).
{ destruct (diff_col_ex3 C1 C2 P) as [C0]; Col; spliter.
  destruct (cop_not_par_same_side P Q C0 P P R) as [C3 []]; Col.
    intro; apply HNCol3; ColR.
    apply coplanar_perm_1, col_cop2__cop with C1 C2; Col; Cop.
  exists C3; split; [ColR|assumption].
}
destruct HC3 as [C3 [HCol6 HOS]].
destruct (hrap P Q M P Q R P C3) as [S [HS1 HS2]]; trivial;
  [apply out_trivial; auto|apply os_distincts in HOS; spliter; auto|
  |apply coplanar_trans_1 with R; Col; Cop|].
{ assert (HP := HPerpAC); destruct HP as [P' [_ [_ [HP1 [HP2 HP3]]]]].
  assert (P = P'); [|treat_equalities; apply HP3; Col].
  elim (perp_not_col2 _ _ _ _ HPerpAC); intro;
  [apply l6_21 with A1 A2 C1 C2|apply l6_21 with A1 A2 C2 C1]; Col.
}
exists S; split; [assumption|ColR].
Qed.

Lemma weak_inverse_projection_postulate__bachmann_s_lotschnittaxiom :
  weak_inverse_projection_postulate -> bachmann_s_lotschnittaxiom.
Proof.
intro hrap.
apply bachmann_s_lotschnittaxiom_aux.
intros A1 A2 B1 B2 C1 C2 D1 D2 Q P R HQP HQR HPerpAB HPerpAC HPerpBD.
intros HCol1 HCol2 HCol3 HCol4 HCol5 HCol6 HCop1 HCop2 HCop3 HCop4.
assert (HNC : ~ Col P Q R).
  apply per_not_col; auto; apply perp_per_1, (perp_col4 A1 A2 B1 B2); auto.
destruct (angle_bisector P Q R) as [M [HM1 HM2]]; auto.
assert (HSuma : SumA P Q M P Q M P Q R).
  assert_diffs; apply conga3_suma__suma with P Q M M Q R P Q R; CongA; SumA.
assert (HAcute : Acute P Q M).
  {
  apply nbet_sams_suma__acute with P Q R; auto.
    intro; apply HNC; Col.
  assert (LeA P Q M P Q R) by Lea.
  assert (Per P Q R)
    by (apply perp_per_2, perp_col2 with A1 A2; Col; apply perp_sym, perp_col2 with B1 B2; Col; Perp).
  apply sams_lea2__sams with P Q R P Q R; SumA.
  }
destruct (weak_inverse_projection_postulate__bachmann_s_lotschnittaxiom_aux
    hrap A1 A2 B1 B2 C1 C2 Q P R M) as [HParB [S [HS1 HS2]]]; Col.
destruct (weak_inverse_projection_postulate__bachmann_s_lotschnittaxiom_aux
    hrap B1 B2 A1 A2 D1 D2 Q R P M) as [HParA [T [HT1 HT2]]]; [trivial..|]; [Perp|Cop..|Col| |CongA|].
  apply l11_24, HM1.
destruct (col_dec C1 C2 T).
  exists T; split; Col.
destruct (col_dec D1 D2 S).
  exists S; split; Col.
assert (HOut : Out Q S T) by (apply l6_7 with M; Out).
clear dependent M.
destruct HOut as [HSQ [HTQ [HBet|HBet]]].
- assert (HTS : TS C1 C2 R T).
  { apply l9_8_2 with Q.
      repeat split; [apply par_not_col with B1 B2; Par| |exists S; split]; Col.
    apply l12_6, par_strict_col2_par_strict with B1 B2; Par; Col.
  }
  destruct HTS as [_ [_ [I [HI1 HI2]]]].
  assert (T <> R).
    intro; treat_equalities; Col.
  exists I; split; ColR.
- assert (HTS : TS D1 D2 P S).
  { apply l9_8_2 with Q.
      repeat split; [apply par_not_col with A1 A2; Par| |exists T; split]; Col.
    apply l12_6, par_strict_col2_par_strict with A1 A2; Par; Col.
  }
  destruct HTS as [_ [_ [I [HI1 HI2]]]].
  assert (P <> S).
    intro; treat_equalities; Col.
  exists I; split; ColR.
Qed.

End weak_inverse_projection_postulate_bachmann_s_lotschnittaxiom.


 (* Bruno PICOLO ORTIZ Elyan POUJOL *)

Require Import Bool.
Require Import List.
Import ListNotations.
Set Implicit Arguments.

(* Ecriture de la spécification *)

Module Type TABLE.
Parameter Key: Type.
Parameter Val: Type.
Parameter table: Type.
Parameter empty: table.
Parameter put: table -> Key -> Val -> table.
Parameter get: table -> Key -> Val -> Val.
Parameter member: table -> Key -> bool.
Axiom get_empty: forall key def, get empty key def = def.
Axiom get_put_eq: forall key val def t, get (put t key val) key def = val.
Axiom get_put_neq: forall key1 key2 val def t,
    key1<>key2 -> get (put t key1 val) key2 def = get t key2 def.
Axiom empty_mem: forall key, member empty key = false.
Axiom mem_put_eq: forall key val t, member (put t key val) key = true.
Axiom mem_put_neq: forall key1 key2 val t,
    key1<>key2 -> member (put t key1 val) key2 = member t key2.
End TABLE.

Require Import Ascii. (* pour utiliser des caractères *)
Module Test(T:TABLE with Definition Key:=list ascii with Definition Val:=nat).
  Local Open Scope char_scope. (* pour pouvoir écrire "a" *)
  Definition test :=
    let t := T.put T.empty ["a"; "b"; "c"] 10 in
    if T.member t ["a"; "b"; "c"] then
      T.get t ["a"; "b"; "c"] 0
    else
      0.
End Test.

(* Implémentation de la spécification *)

Module Type ALPHA.
  Parameter lettre: Type.
  Parameter eq: forall (x y:lettre), {x=y}+{x<>y}.
End ALPHA.

Module Type TYPE.
  Parameter t: Type.
End TYPE.

Module Trie (A:ALPHA) (T:TYPE) <:
  TABLE with Definition Key := list A.lettre with Definition Val := T.t.
    Definition Key := list A.lettre.
    Definition Val := T.t.
    Inductive trie :=
        Leaf (val: option Val)
      | Node (val: option Val) (reste: A.lettre -> trie).

    Definition table := trie.
    Definition empty := Leaf None.
    Definition isDefined T (v: option T) := (* teste si v <> None *)
      match v with
          None => false
        | _ => true
      end.

    Definition getValue T (v: option T) def := (* valeur dans Some, def sinon *)
      match v with
          None => def
        | Some u => u
      end.

    Fixpoint put t key val :=
      match t with
        | Leaf v =>
            match key with
              | [] => Leaf (Some val)
              | e::k =>
                  let t' := put (Leaf None) k val in
                  Node v ( fun x => if A.eq x e then t' else (Leaf None))
            end
        | Node v r =>
            match key with
              | [] => Node (Some val) r
              | e::k =>
                  let t' := put (r e) k val in
                  Node v (fun x => if A.eq x e then t' else r e)
            end
      end.

    Fixpoint get t key val :=
      match t with
        | Leaf v =>
            match key with
              | [] => getValue v val
              | e::k => val
            end
        | Node v r =>
            match key with
              | [] => getValue v val
              | e::k => get (r e) k val
            end
      end.

    Fixpoint member t key :=
      match key with
      | [] =>
          match t with
            | Leaf None
            | Node None _ => false
            | _ => true
          end
      | e::k =>
          match t with
            | Leaf _=> false
            | Node _ r => member (r e) k
          end
      end.

    Theorem empty_mem: forall key, member empty key = false.
    Proof.
    destruct key; try tauto.
    Qed.
    Print empty_mem.

    Theorem get_empty: forall key def, get empty key def = def.
    Proof.
    destruct key; try tauto.
    Qed.
    Print get_empty.

    Theorem mem_put_eq: forall key val t, member (put t key val) key = true.
    Proof.
    induction key.
    destruct t; try tauto.
    destruct t; try tauto.
    simpl.
    destruct A.eq; try tauto.
    rewrite IHkey. auto.
    simpl.
    destruct A.eq; try tauto.
    rewrite IHkey. auto.
    Qed.
    Print mem_put_eq.

    Theorem get_put_eq: forall key val def t, get (put t key val) key def = val.
    Proof.
    induction key.
    destruct t; try tauto.
    destruct t; try tauto.
    simpl.
    destruct A.eq; try tauto.
    rewrite IHkey; try tauto.
    simpl.
    destruct A.eq; try tauto.
    rewrite IHkey; try tauto.
    Qed.
    Print get_put_eq.

    Theorem mem_put_neq: forall key1 key2 val t,
      key1<>key2 -> member (put t key1 val) key2 = member t key2.
    Proof.
    induction key1.
    destruct key2; try tauto.
    destruct t; try tauto.
    simpl.
    destruct t; try tauto.
    destruct (A.eq a a); try tauto.
    destruct val0.
    destruct key2; try tauto.
    simpl.
    destruct A.eq; try tauto.
    rewrite IHkey1; try tauto.
    destruct key2; try tauto.
    intro.
    subst key1.
    subst l.
    Admitted.

    Theorem get_put_neq: forall key1 key2 val def t,
      key1<>key2 -> get (put t key1 val) key2 def = get t key2 def.
    Proof.
    induction key1.
    destruct t; try tauto.
    destruct key2; try tauto.
    destruct key2; try tauto.
    simpl.
    destruct key2; try tauto.
    destruct t; try tauto.
    destruct t; try tauto.
    destruct val0; try tauto.
    simpl.
    destruct A.eq; try tauto.
    subst l.
    rewrite IHkey1; try tauto.
    intros.
    destruct key2; try tauto.
    intro.
    Admitted.
End Trie.

Inductive option T :=
  Some (valeur: T)
  | None.

Module StrK.
  Definition lettre := ascii.
  Definition eq := ascii_dec.
End StrK.

Module NatV.
  Definition t := nat.
End NatV.

Module TrieStrNat := Trie StrK NatV.
Module TestTrieStrNat := Test TrieStrNat.

Eval compute in TestTrieStrNat.test.


(*
Set Warnings "-notation-overridde,-parsing".
*)
Require Export Lists.

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

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

Check list.
Check (nil nat).
Check (cons nat 3 (nil nat)).
Check nil.
Check cons.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => (cons X x (repeat X x count'))
  end.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

Module MumbleGrumble.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X : Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

Check b a 5. (* mumble *)
Check d. (* forall X : Type, mumble -> grumble X *)
(* Check d (b a 5). expecting mumble type, not mumble element *)
Check d mumble (b a 5). (* grumble mumble *)
Check d bool (b a 5). (* grumble bool *)
Check e bool true. (* grumble bool *)
Check b c 0. (* mumble *)
Check e mumble (b c 0). (* grumble mumble *)
(* Check e bool (b c 0). expecting bool, gets mumble *)
Check c. (* mumble *)

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'. (* forall X : Type, X -> nat -> list X *)
Check repeat.  (* same type *)

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

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

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

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

(* list' not good because now cannot say list' nat *)

Inductive list' {X : Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

(* Do the type inference at the function level, not the datatype level *)

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

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

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

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

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

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

Fail Definition mynil := nil. (* cannot infer type here *)
Definition mynil : list nat := nil. (* enough info *)
Check @nil. (* force implicit to explicity *)
Definition mynil' := @nil nat.

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).

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

Theorem app_assoc : forall (X : Type),
  forall (l1 l2 l3 : list X),
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros X l1 l2 l3.
  induction l1 as [| x l1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem app_nil_r : forall (X : Type),
 forall l : list X, l ++ [] = l.
Proof.
  intros X l. induction l as [| x l' IHl'].
  - reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_length : forall (X : Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1 as [| x l1' IHl1'].
  - reflexivity.
  - simpl. rewrite <- IHl1'. reflexivity.
Qed.

Theorem rev_app_distr : forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1 as [| x l1' IHl1'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite <- app_assoc, IHl1'. reflexivity.
Qed.

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

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

Arguments pair {X} {Y} _ _.
Notation "( x , y )" := (pair x y). (* element of pair type *)
Notation "X * Y" := (prod X Y) : type_scope. (* pair type *)

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.

Fixpoint combine {X Y : Type} (l1 : list X) (l2 : list Y) : list (X*Y) :=
  match l1,l2 with
  | [],_ => []
  | _,[] => []
  | hx::tx, hy::ty  => cons (hx,hy) (combine tx ty)
  end.

Check @combine. (* forall X Y : Type, list X -> list Y -> list X * Y *)

Compute (combine [1;2] [false; false; true; true]).

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X)*(list Y) :=
  match l with
  | [] => ([],[])
  | h::t => ( (fst h)::(fst (split t)), (snd h)::(snd (split t)) )
  end.

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

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

Arguments Some {X} _.
Arguments None {X}. Search beq_nat.

(*
Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
  match l with
  | [] => None
  | h::t => match n with
            | 0 => Some h
            | S n' => nth_error t n'
            end
  end.
*)

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
  match l with
  | [] => None
  | h::t => if (beq_nat 0 n) then Some h else nth_error t (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | h::t => Some h
  end.

Check @hd_error.
Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

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

Check @doit3times.

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

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

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.

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.

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.

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

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.

Compute (3 <= 4).

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | 0 => true
  | S n' => if (beq_nat m 0) then false else ble_nat n' (pred m)
  end.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (ble_nat 8 n) (evenb n)) 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.

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

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.

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

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

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

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.

Compute rev [1;2;3].

Theorem map_distr : forall (X Y: Type) (l1 l2 : list X) (f:X->Y),
  (map f l1) ++ (map f l2) = (map f (l1 ++ l2)).
Proof.
  intros X Y l1 l2 f. induction l1 as [|n l1' IHl1'].
  - reflexivity.
  - simpl. rewrite <- IHl1'. 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' IHl'].
  - reflexivity.
  - simpl. rewrite <- IHl'. rewrite <- map_distr. reflexivity.
Qed.

Fixpoint flat_map {X Y : Type} (f:X->list Y) (l:list X) : list Y :=
  match l with
  | [] => []
  | h :: t => f h ++ (flat_map f t)
  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.

Fixpoint map_option {X Y : Type} (f:X->Y) (x : option X) : option Y :=
  match x with
  | None => None
  | Some n => Some (f n)
  end.

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

Compute fold plus [1;2;3;4] 0.
Check (fold andb).

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.

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

Definition ftrue := constfun true.
Check ftrue.
Compute ftrue 3.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Check plus.

Definition plus3 := plus 3.

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.

Module Exercises.

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.

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

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

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

Definition prod_curry {X Y Z : Type} (f:(X*Y)->Z) (a:X) (b:Y) : Z :=
  f (a,b).
Definition prod_uncurry {X Y Z : Type} (f:X->Y->Z) (p:X*Y) : Z :=
  f (fst p) (snd p).

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

Check @prod_curry. (* : forall (X Y Z : Type), (X*Y->Z)->(X->Y->Z). *)
Check @prod_uncurry. (* : forall (X Y Z : Type), (X->Y->Z)->(X*Y->Z). *)

Theorem pair_parts : forall (X Y : Type) (p:X*Y),
  (fst p, snd p) = p.
Proof.
  intros X Y p. destruct p. simpl. reflexivity.
Qed.

Theorem uncurry_curry : 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.
  unfold prod_curry, prod_uncurry. rewrite -> pair_parts. reflexivity.
Qed.

Module Church.
Definition nat := forall X : Type, (X -> X) -> X -> X.
Definition one : nat :=
  fun (X : Type) (f:X->X) (x:X) => f x.
Definition two : nat :=
  fun (X : Type) (f:X->X) (x:X) => f (f x).
Definition zero : nat :=
  fun (X : Type) (f:X->X) (x:X) => x.

Definition three : nat := @doit3times.

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.

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.

Check fun n:nat => plus three n.
Compute succ (succ zero).
Compute (plus three) two.
Compute (plus three zero).
Compute (plus three).

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.

Compute fun (X : Type) (f:X->X) => three X f.

End Church.
End Exercises.