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

Require Export Lists.

(* ###################################################### *)
(** * 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 things of type [X]. *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End MumbleGrumble.

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

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

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

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

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

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

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks, 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 *)

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

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

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

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

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

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

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

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

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

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

(** In fact, we can go further.  To avoid having to sprinkle [_]'s
    throughout our programs, we can tell Coq _always_ to infer the
    type argument(s) of a given function. 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 it is often the case for constructors, they can be
    marked with a wildcard pattern [_]. *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.

(** Now, we don't have to supply type arguments for these functions: *)

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

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

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

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [length'']; indeed, it is invalid to provide
    one.)  We will use this style whenever possible, although we will
    continue to use use explicit [Argument] declarations for
    [Inductive] constructors. The reason for that is that marking the
    parameter of an inductive type as implicit causes it to become
    implicit for the type itself, not just 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, we can't write an expression such as [list' nat],
    which is almost never what we want. *)

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

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: Polymorphic Lists *)

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

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
 match count with
  | O => []
  | S count' => n :: repeat n count'
end.

Example test_repeat1:
  repeat true 2 = cons true (cons true nil).
 (* FILL IN HERE *) Admitted.

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** 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.
  (* FILL IN HERE *) Admitted.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

Arguments pair {X} {Y} _ _.

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

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

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

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

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

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

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

(** Note that the pair notation can also be used in patterns... *)

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

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

(** The following function takes two lists and combines them
    into a list of pairs.  In many functional programming languages,
    it is called [zip].  We call it [combine] for consistency with
    Coq's standard library. *)

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.

Eval compute in combine [1;2] [3;4].

(** **** 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?   []
*)

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

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

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
(* FILL IN HERE *) admit.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

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

(** 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 :=
  (* FILL IN HERE *) admit.

(** 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.
 (* FILL IN HERE *) Admitted.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
 (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(* ###################################################### *)
(** ** 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 useful higher-order function, which takes a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filters" the list, returning a new list containing just those
    elements for which the predicate returns [true]. *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Definition filter_even_gt7 (l : list nat) : list nat :=
  (* FILL IN HERE *) admit.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
 (* FILL IN HERE *) Admitted.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** **** 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 :=
(* FILL IN HERE *) admit.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
(* FILL IN HERE *) Admitted.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
(* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

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

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

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

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

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

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

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

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  (* FILL IN HERE *) admit.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** 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))).
    Here are some more examples:
*)

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

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

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

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

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

(* ###################################################### *)
(** ** Functions That Construct Functions *)

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

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

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

Definition ftrue := constfun true.

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

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

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

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

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

Definition plus3 := plus 3.
Check plus3.

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

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

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** 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 :=
(* FILL IN HERE *) admit.

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

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

(** **** 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 :=
  (* FILL IN HERE *) admit.

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

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** 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
(* FILL IN HERE *)
*)
(** [] *)

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

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 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 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 :=
  (* FILL IN HERE *) admit.

Example succ_1 : succ zero = one.
Proof. (* FILL IN HERE *) Admitted.

Example succ_2 : succ one = two.
Proof. (* FILL IN HERE *) Admitted.

Example succ_3 : succ two = three.
Proof. (* FILL IN HERE *) Admitted.

(** Addition of two natural numbers: *)

Definition plus (n m : nat) : nat :=
  (* FILL IN HERE *) admit.

Example plus_1 : plus zero one = one.
Proof. (* FILL IN HERE *) Admitted.

Example plus_2 : plus two three = plus three two.
Proof. (* FILL IN HERE *) Admitted.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. (* FILL IN HERE *) Admitted.

(** Multiplication: *)

Definition mult (n m : nat) : nat :=
  (* FILL IN HERE *) admit.

Example mult_1 : mult one one = one.
Proof. (* FILL IN HERE *) Admitted.

Example mult_2 : mult zero (plus three three) = zero.
Proof. (* FILL IN HERE *) Admitted.

Example mult_3 : mult two three = plus three three.
Proof. (* FILL IN HERE *) Admitted.

(** 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 :=
  (* FILL IN HERE *) admit.

Example exp_1 : exp two two = plus two two.
Proof. (* FILL IN HERE *) Admitted.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. (* FILL IN HERE *) Admitted.

Example exp_3 : exp three zero = one.
Proof. (* FILL IN HERE *) Admitted.

End Church.
(** [] *)

End Exercises.

(** $Date: 2016-01-11 13:15:02 -0500 (Mon, 11 Jan 2016) $ *)


From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.

Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.

Import ListNotations.
Import HListNotations.

Require Import Coq.ZArith.BinInt.

Section ZFOL.
  Inductive sorts: Set :=
  | ZS
  | BS.

  Scheme Equality for sorts.

  Inductive funs: arity sorts -> sorts -> Type :=
  | ZLit: forall (z: Z), funs [] ZS
  | BLit: forall (b: bool), funs [] BS
  | Neg: funs [ZS] ZS
  | Sub: funs [ZS; ZS] ZS
  | Plus: funs [ZS; ZS] ZS
  | Mul: funs [ZS; ZS] ZS
  | Div: funs [ZS; ZS] ZS
  | Mod: funs [ZS; ZS] ZS
  | Abs: funs [ZS] ZS
  | Lte: funs [ZS; ZS] BS
  | Lt: funs [ZS; ZS] BS
  | Gte: funs [ZS; ZS] BS
  | Gt: funs [ZS; ZS] BS.

  Inductive rels: arity sorts -> Type :=.

  Definition sig: signature :=
    {| sig_sorts := sorts;
      sig_funs := funs;
      sig_rels := rels |}.

  Definition fm ctx := FirstOrder.fm sig ctx.
  Definition tm ctx := FirstOrder.tm sig ctx.

  Definition mod_sorts (s: sig_sorts sig) : Type :=
    match s with
    | ZS => Z
    | BS => bool
    end.

  Obligation Tactic := idtac.
  Equations
    mod_fns params ret (f: sig_funs sig params ret) (args: HList.t mod_sorts params)
    : mod_sorts ret :=
    { mod_fns _ _ (BLit b) _ := b;
      mod_fns _ _ (ZLit z) _ := z;
      mod_fns _ _ Neg (x ::: _) := Z.opp x;
      mod_fns _ _ Sub (l ::: r ::: _) := Z.sub l r;
      mod_fns _ _ Plus (l ::: r ::: _) := Z.add l r;
      mod_fns _ _ Mul (l ::: r ::: _) := Z.mul l r;
      mod_fns _ _ Div (l ::: r ::: _) := Z.div l r;
      mod_fns _ _ Mod (l ::: r ::: _) := Z.modulo l r;
      mod_fns _ _ Abs (x ::: _) := Z.abs x;
      mod_fns _ _ Lte (l ::: r ::: _) := Z.leb l r;
      mod_fns _ _ Lt (l ::: r ::: _) := Z.ltb l r;
      mod_fns _ _ Gte (l ::: r ::: _) := Z.geb l r;
      mod_fns _ _ Gt (l ::: r ::: _) := Z.gtb l r;
    }.

  Definition mod_rels params
    (args: sig_rels sig params)
    (env: HList.t mod_sorts params) : Prop :=
    match args with
    end.

  Definition fm_model : model sig := {|
    FirstOrder.mod_sorts := mod_sorts;
    FirstOrder.mod_fns := mod_fns;
    FirstOrder.mod_rels := mod_rels;
  |}.

End ZFOL.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** Iteration of binary relations *)

Require Import Arith Nat Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums.

Set Implicit Arguments.

Section rel_iter.

  Variable (X : Type) (R : X -> X -> Prop).

  Fixpoint rel_iter n :=
    match n with
      | 0   => eq
      | S n => fun x z => exists y, R x y /\ rel_iter n y z
    end.

  Fact rel_iter_plus n m x y : rel_iter (n+m) x y <-> exists a, rel_iter n x a /\ rel_iter m a y.
  Proof.
    revert x y; induction n as [ | n IHn ]; intros x y; simpl.
    + split.
      * exists x; split; auto.
      * intros (? & ? & ?); subst; auto.
    + split.
      * intros (a & H1 & H2).
        apply IHn in H2.
        destruct H2 as (b & H2 & H3).
        exists b; split; auto; exists a; auto.
      * intros (a & (b & H1 & H2) & H3).
        exists b; split; auto.
        apply IHn; exists a; auto.
  Qed.

  Fact rel_iter_1 x y : rel_iter 1 x y <-> R x y.
  Proof.
    simpl; split.
    * intros (? & ? & ?); subst; auto.
    * exists y; auto.
  Qed.

  Fact rel_iter_S n x y : rel_iter (S n) x y <-> exists a, rel_iter n x a /\ R a y.
  Proof.
    replace (S n) with (n+1) by lia.
    rewrite rel_iter_plus.
    split; intros (a & H1 & H2); exists a; revert H1 H2;
      rewrite rel_iter_1; auto.
  Qed.

  Fact rel_iter_sequence n x y : rel_iter n x y <-> exists f, f 0 = x /\ f n = y /\ forall i, i < n -> R (f i) (f (S i)).
  Proof.
    split.
    * revert x y; induction n as [ | n IHn ]; simpl; intros x y.
      + intros; subst y; exists (fun _ => x); repeat split; auto; intros; lia.
      + intros (a & H1 & H2).
        destruct IHn with (1 := H2) as (f & H3 & H4 & H5).
        exists (fun i => match i with 0 => x | S i => f i end); repeat split; auto.
        intros [ | i ] Hi; subst; auto.
        apply H5; lia.
    * intros (f & H1 & H2 & H3); subst x y.
      induction n as [ | n IHn ].
      + simpl; auto.
      + rewrite rel_iter_S.
        exists (f n); split; auto.
  Qed.

End rel_iter.

Local Notation power := (mscal mult 1).

Definition is_digit c q i y := y < q /\ exists a b, c = (a*q+y)*power i q+b /\ b < power i q.

Fact is_digit_fun c q i x y : is_digit c q i x -> is_digit c q i y -> x = y.
Proof.
   intros (H1 & a1 & b1 & H3 & H4) (H2 & a2 & b2 & H5 & H6).
   rewrite H3 in H5.
   apply div_rem_uniq, proj1 in H5; auto; try lia.
   apply div_rem_uniq, proj2 in H5; auto; lia.
Qed.

Definition is_seq (R : nat -> nat -> Prop) c q n := forall i, i < n -> exists y y', is_digit c q i y /\ is_digit c q (1+i) y' /\ R y y'.

Section rel_iter_bound.

  Variable (R : nat -> nat -> Prop) (k : nat) (Hk1 : forall x y, R x y -> y <= k*x).

  Let Hk' : forall x y, R x y -> y <= (S k)*x.
  Proof. intros x y H; apply le_trans with (1 := Hk1 H), mult_le_compat_r; lia. Qed.

  (* q represents a basis big enough so that all the sequence x=x0 R x1 R ... R xn = y can be
      encoded as the digits of c in base q

      Since the growth of R is controlled by k, we can find a simple diophantine constraint
      on x n q such that q is big enough. *)

  Definition rel_iter_bound n x y := exists q c, x*power n (S k) < q /\ is_seq R c q n /\ is_digit c q 0 x /\ is_digit c q n y.

  Lemma rel_iter_bound_iter n x y : rel_iter_bound n x y -> rel_iter R n x y.
  Proof.
    revert y; induction n as [ | n IHn ]; intros y.
    * intros (q & c & H1 & H2 & H3 & H4).
      red in H2.
      rewrite power_0 in H1; auto.
      revert H3 H4; apply is_digit_fun.
    * rewrite rel_iter_S.
      intros (q & c & H1 & H2 & H3 & H4).
      assert (0 < q) as Hq.
      { revert H1; generalize (x*power (S n) (S k)); intros; lia. }
      assert (exists z, is_digit c q n z) as H6.
      { exists (rem (div c (power n q)) q).
        split.
        + apply div_rem_spec2; lia.
        + exists (div (div c (power n q)) q), (rem c (power n q)); split.
          2: apply div_rem_spec2; red; rewrite power_0_inv; lia.
          rewrite <- div_rem_spec1 with (p := q).
          apply div_rem_spec1. }
      destruct H6 as (z & H6); exists z; split.
      + apply IHn.
        exists q, c; repeat (split; auto).
        - apply le_lt_trans with (2 := H1), mult_le_compat; auto.
          simpl.
          replace (power n (S k)) with (1*power n (S k)) at 1 by lia.
          apply mult_le_compat; auto; lia.
        - intros i Hi; apply H2; lia.
      + destruct (H2 n) as (u & v & G1 & G2 & G3); auto.
        rewrite is_digit_fun with (1 := H4) (2 := G2),
                is_digit_fun with (1 := H6) (2 := G1); auto.
  Qed.

  Notation power := (mscal mult 1).
  Notation "∑" := (msum plus 0).

  Lemma rel_iter_iter_bound n x y : rel_iter R n x y -> rel_iter_bound n x y.
  Proof.
    intros H.
    apply rel_iter_sequence in H.
    destruct H as (f & H1 & H2 & H3).
    assert (forall i, i <= n -> f i <= power i (S k) * x) as Hf.
    { induction i as [ | i IHi ]; intros Hi; simpl; try lia.
      specialize (H3 _ Hi).
      apply Hk' in H3.
      apply le_trans with (1 := H3).
      rewrite power_S, <- mult_assoc.
      apply mult_le_compat; auto.
      apply IHi; lia. }
    set (q := S (x * power n (S k))).
    assert (q <> 0) as Hq by discriminate.
    assert (forall i, i <= n -> f i < q) as Hfq.
    { unfold q; intros i Hi.
      apply le_n_S, le_trans with (1 := Hf _ Hi).
      rewrite mult_comm; apply mult_le_compat; auto.
      apply power_mono; auto; lia. }
    set (c := ∑ (S n) (fun i => f i * power i q)).
    assert (forall i, i <= n -> is_digit c q i (f i)) as Hc.
    { intros i Hi; split; auto.
      + exists (∑ (n-i) (fun j => f (1+i+j) * power j q)),
               (∑  i    (fun i => f i * power i q)); split.
        2: apply sum_power_lt; auto; intros; apply Hfq; lia.
        unfold c; replace (S n) with (i+S (n - i)) by lia.
        rewrite msum_plus, plus_comm; f_equal; auto.
        rewrite msum_ext with (g := fun k => power i q*(f (i+k)*power k q)).
        * rewrite sum_0n_scal_l, mult_comm; f_equal.
          rewrite msum_S, plus_comm; f_equal.
          2: simpl; rewrite Nat.mul_1_r; f_equal; lia.
          rewrite (mult_comm _ q), <- sum_0n_scal_l.
          apply msum_ext.
          intros j _.
          replace (i+S j) with (1+i+j) by lia.
          rewrite power_S; ring.
        * intros j _; rewrite power_plus; ring. }
    exists q, c; split; [ | split; [ | split ] ].
    + unfold q; auto.
    + intros i Hi; exists (f i), (f (S i)).
      split; [ | split ].
      * apply Hc; lia.
      * apply Hc; lia.
      * apply H3; auto.
    + rewrite <- H1; apply Hc; lia.
    + rewrite <- H2; apply Hc; lia.
  Qed.

  Hint Resolve rel_iter_bound_iter rel_iter_iter_bound : core.

  (* A characterization of fun n x y => rel_iter R n x y with a diophantine formula
     (to be proved in dio_expo.v) when the relation R does not grow more that linearly *)

  Theorem rel_iter_bound_equiv n x y : rel_iter R n x y <-> rel_iter_bound n x y.
  Proof. split; auto. Qed.

End rel_iter_bound.

Section rel_iter_seq.

  Variable (R : nat -> nat -> Prop).

  (* q represents a basis big enough so that all the sequence x=x0 R x1 R ... R xn = y can be
      encoded as the digits of c in base q *)

  Definition rel_iter_seq n x y := exists q c, is_seq R c q n /\ is_digit c q 0 x /\ is_digit c q n y.

  Lemma rel_iter_seq_iter n x y : rel_iter_seq n x y -> rel_iter R n x y.
  Proof.
    revert y; induction n as [ | n IHn ]; intros y.
    * intros (q & c & H2 & H3 & H4).
      red in H2.
      simpl; revert H3 H4; apply is_digit_fun.
    * rewrite rel_iter_S.
      intros (q & c & H2 & H3 & H4).
      red in H2.
      assert (0 < q) as Hq.
      { destruct H3; lia. }
      assert (exists z, is_digit c q n z) as H6.
      { exists (rem (div c (power n q)) q).
        split.
        + apply div_rem_spec2; lia.
        + exists (div (div c (power n q)) q), (rem c (power n q)); split.
          2: apply div_rem_spec2; red; rewrite power_0_inv; lia.
          rewrite <- div_rem_spec1 with (p := q).
          apply div_rem_spec1. }
      destruct H6 as (z & H6); exists z; split.
      + apply IHn.
        exists q, c; msplit 2; auto.
        intros i Hi; apply H2; lia.
      + destruct (H2 n) as (u & v & G1 & G2 & G3); auto.
        rewrite is_digit_fun with (1 := H4) (2 := G2),
                is_digit_fun with (1 := H6) (2 := G1); auto.
  Qed.

  Notation power := (mscal mult 1).
  Notation "∑" := (msum plus 0).

  Lemma rel_iter_iter_seq n x y : rel_iter R n x y -> rel_iter_seq n x y.
  Proof.
    intros H.
    apply rel_iter_sequence in H.
    destruct H as (f & H1 & H2 & H3).
    assert (exists q, forall i, i <= n -> f i < q) as Hq.
    { clear H1 H2 H3.
      revert f; induction n as [ | n IHn ]; intros f.
      + exists (S (f 0)); intros [ | ] ?; lia.
      + destruct IHn with (f := fun i => (f (S i))) as (q & Hq).
        exists (1+f 0+q); intros [ | i ] Hi; try lia.
        generalize (Hq i); intros; lia. }
    destruct Hq as (q & Hfq).
    assert (q <> 0) as Hq.
    { generalize (Hfq 0); intros; lia. }
    set (c := ∑ (S n) (fun i => f i * power i q)).
    assert (forall i, i <= n -> is_digit c q i (f i)) as Hc.
    { intros i Hi; split; auto.
      + exists (∑ (n-i) (fun j => f (1+i+j) * power j q)),
               (∑  i    (fun i => f i * power i q)); split.
        2: apply sum_power_lt; auto; intros; apply Hfq; lia.
        unfold c; replace (S n) with (i+S (n - i)) by lia.
        rewrite msum_plus, plus_comm; f_equal; auto.
        rewrite msum_ext with (g := fun k => power i q*(f (i+k)*power k q)).
        * rewrite sum_0n_scal_l, mult_comm; f_equal.
          rewrite msum_S, plus_comm; f_equal.
          2: simpl; rewrite Nat.mul_1_r; f_equal; lia.
          rewrite (mult_comm _ q), <- sum_0n_scal_l.
          apply msum_ext.
          intros j _.
          replace (i+S j) with (1+i+j) by lia.
          rewrite power_S; ring.
        * intros j _; rewrite power_plus; ring. }
    exists q, c; msplit 2.
    + intros i Hi; exists (f i), (f (S i)).
      split; [ | split ].
      * apply Hc; lia.
      * apply Hc; lia.
      * apply H3; auto.
    + rewrite <- H1; apply Hc; lia.
    + rewrite <- H2; apply Hc; lia.
  Qed.

  Hint Resolve rel_iter_seq_iter rel_iter_iter_seq : core.

  (* A characterization of fun n x y => rel_iter R n x y with a diophantine formula *)

  Theorem rel_iter_seq_equiv n x y : rel_iter R n x y <-> rel_iter_seq n x y.
  Proof. split; auto. Qed.

End rel_iter_seq.


(*********************************************************************************

 Biadjunctions of bicategories

 We define the notion of biadjunction. To do so, we use the formulation with units
 and counits. We don't require the biadjunctions to be coherent: the swallowtail
 equations do not have to be satisfied.

 Contents
 1. Definition
 2. Equivalence on hom-categories

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.Modifications.Modification.

Local Open Scope cat.

(**
 1. Definition
 *)
Definition left_biadj_unit_counit
           {B₁ B₂ : bicat}
           (L : psfunctor B₁ B₂)
  := ∑ (R : psfunctor B₂ B₁),
     (pstrans
       (id_psfunctor B₁)
       (comp_psfunctor R L))
     ×
     (pstrans
        (comp_psfunctor L R)
        (id_psfunctor B₂)).

Section BiadjunctionProjections.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_unit_counit L).

  Definition biadj_right_adjoint
    : psfunctor B₂ B₁
    := pr1 R.

  Definition biadj_unit
    : pstrans
        (id_psfunctor B₁)
        (comp_psfunctor biadj_right_adjoint L)
    := pr12 R.

  Definition biadj_counit
    : pstrans
        (comp_psfunctor L biadj_right_adjoint)
        (id_psfunctor B₂)
    := pr22 R.
End BiadjunctionProjections.

Coercion biadj_right_adjoint : left_biadj_unit_counit >-> psfunctor.

Section BiadjunctionTriangleLaws.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_unit_counit L).

  Let η : pstrans (id_psfunctor B₁) (comp_psfunctor R L)
    := biadj_unit R.
  Let ε : pstrans (comp_psfunctor L R) (id_psfunctor B₂)
    := biadj_counit R.

  Definition biadj_triangle_l_lhs
    : pstrans L L
    := comp_pstrans
         (rinvunitor_pstrans L)
         (comp_pstrans
            (L ◅ η)
            (comp_pstrans
               (lassociator_pstrans L R L)
               (comp_pstrans
                  (ε ▻ L)
                  (lunitor_pstrans L)))).

  Definition biadj_triangle_l_law
    : UU
    := invertible_modification
         biadj_triangle_l_lhs
         (id_pstrans L).

  Definition biadj_triangle_r_lhs
    : pstrans R R
    := comp_pstrans
         (linvunitor_pstrans R)
         (comp_pstrans
            (η ▻ R)
            (comp_pstrans
               (rassociator_pstrans R L R)
                    (comp_pstrans
                       (R ◅ ε)
                       (runitor_pstrans R)))).

  Definition biadj_triangle_r_law
    : UU
    := invertible_modification
         biadj_triangle_r_lhs
         (id_pstrans R).
End BiadjunctionTriangleLaws.

Definition left_biadj_data
           {B₁ B₂ : bicat}
           (L : psfunctor B₁ B₂)
  : UU
  := ∑ (R : left_biadj_unit_counit L),
     biadj_triangle_l_law R × biadj_triangle_r_law R.

Section BiadjunctionDataProjections.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_data L).

  Definition left_biadj_data_to_left_biadj_unit_counit
    : left_biadj_unit_counit L
    := pr1 R.

  Definition biadj_triangle_l
    : invertible_modification
        (biadj_triangle_l_lhs (pr1 R))
        (id_pstrans L)
    := pr12 R.

  Definition biadj_triangle_r
    : invertible_modification
        (biadj_triangle_r_lhs (pr1 R))
        (id_pstrans (pr1 R))
    := pr22 R.
End BiadjunctionDataProjections.

Coercion left_biadj_data_to_left_biadj_unit_counit
  : left_biadj_data >-> left_biadj_unit_counit.

Definition make_biadj_unit_counit
           {B₁ B₂ : bicat}
           {L : psfunctor B₁ B₂}
           (R : psfunctor B₂ B₁)
           (η : pstrans
                  (id_psfunctor B₁)
                  (comp_psfunctor R L))
           (ε : pstrans
                  (comp_psfunctor L R)
                  (id_psfunctor B₂))
  : left_biadj_unit_counit L
  := R ,, η ,, ε.

Definition make_biadj_data
           {B₁ B₂ : bicat}
           {L : psfunctor B₁ B₂}
           (R : left_biadj_unit_counit L)
           (tl : biadj_triangle_l_law R)
           (tr : biadj_triangle_r_law R)
  : left_biadj_data L
  := R ,, tl ,, tr.

(**
 2. Equivalence on hom-categories
 *)
Section BiadjunctionHom.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_data L)
          (X : B₁) (Y : B₂).

  Let η : pstrans (id_psfunctor B₁) (comp_psfunctor R L)
    := biadj_unit R.
  Let ε : pstrans (comp_psfunctor L R) (id_psfunctor B₂)
    := biadj_counit R.

  Local Definition biadj_left_hom_data
    : functor_data (hom X (R Y)) (hom (L X) Y).
  Proof.
    use make_functor_data.
    - exact (λ f, #L f · ε Y).
    - exact (λ f g α, (##L α) ▹ ε Y).
  Defined.

  Local Definition biadj_left_hom_is_functor
    : is_functor biadj_left_hom_data.
  Proof.
    split.
    - intros f.
      cbn in f ; cbn.
      rewrite psfunctor_id2, id2_rwhisker.
      apply idpath.
    - intros f g h α β.
      cbn in f, g, h, α, β ; cbn.
      rewrite rwhisker_vcomp, psfunctor_vcomp.
      apply idpath.
  Qed.

  Definition biadj_left_hom
    : hom X (R Y) ⟶ hom (L X) Y.
  Proof.
    use make_functor.
    - exact biadj_left_hom_data.
    - exact biadj_left_hom_is_functor.
  Defined.

  Definition biadj_right_hom_data
    : functor_data (hom (L X) Y) (hom X (R Y)).
  Proof.
    use make_functor_data.
    - exact (λ f, η X · #R f).
    - exact (λ f g α, η X ◃ ##R α).
  Defined.

  Definition biadj_right_hom_is_functor
    : is_functor biadj_right_hom_data.
  Proof.
    split.
    - intros f.
      cbn in f ; cbn.
      rewrite psfunctor_id2, lwhisker_id2.
      apply idpath.
    - intros f g h α β.
      cbn in f, g, h, α, β ; cbn.
      rewrite psfunctor_vcomp, lwhisker_vcomp.
      apply idpath.
  Qed.

  Definition biadj_right_hom
    : hom (L X) Y ⟶ hom X (R Y).
  Proof.
    use make_functor.
    - exact biadj_right_hom_data.
    - exact biadj_right_hom_is_functor.
  Defined.

  Definition biadj_hom_left_right_data
    : nat_trans_data
        (functor_identity (hom X (R Y)))
        (biadj_left_hom ∙ biadj_right_hom).
  Proof.
    intros f.
    exact ((rinvunitor f)
             • (f ◃ (((invertible_modcomponent_of (biadj_triangle_r R) Y)^-1)
                       • lunitor _
                       • (_ ◃ (lunitor _ • runitor _))))
             • lassociator _ _ _
             • ((psnaturality_of η f)^-1 ▹ _)
             • rassociator _ _ _
             • (_ ◃ psfunctor_comp R (#L f) (ε Y))).
  Defined.

  Definition biadj_hom_left_right_is_nat_trans
    : is_nat_trans _ _ biadj_hom_left_right_data.
  Proof.
    intros f g α.
    cbn in f, g, α ; cbn.
    unfold biadj_hom_left_right_data ; simpl.
    etrans.
    {
      rewrite !vassocr.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocl.
    do 2 apply maponpaths.
    etrans.
    {
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      apply idpath.
    }
    apply maponpaths.
    rewrite lwhisker_vcomp.
    rewrite psfunctor_rwhisker.
    rewrite <- lwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite rwhisker_lwhisker_rassociator.
    rewrite !vassocr.
    apply maponpaths_2.
    use vcomp_move_L_pM.
    { is_iso. }
    simpl.
    rewrite !vassocr.
    use vcomp_move_R_Mp.
    { is_iso. }
    simpl.
    rewrite !rwhisker_vcomp.
    apply maponpaths.
    exact (!(psnaturality_natural η _ _ f g α)).
  Qed.

  Definition biadj_hom_left_right
    : (functor_identity (hom X (R Y)))
        ⟹
        biadj_left_hom ∙ biadj_right_hom.
  Proof.
    use make_nat_trans.
    - exact biadj_hom_left_right_data.
    - exact biadj_hom_left_right_is_nat_trans.
  Defined.

  Definition biadj_hom_right_left_data
    : nat_trans_data
        (biadj_right_hom ∙ biadj_left_hom)
        (functor_identity (hom (L X) Y)).
  Proof.
    intros f.
    exact (((psfunctor_comp L (η X) (#R f))^-1 ▹ (ε Y))
             • rassociator _ _ _
             • (#L (η X) ◃ (psnaturality_of ε f)^-1)
             • lassociator _ _ _
             • (((_ ◃ (rinvunitor _ • linvunitor _))
                   • linvunitor _
                   • (invertible_modcomponent_of (biadj_triangle_l R) X)) ▹ f)
             • lunitor f).
  Defined.

  Definition biadj_hom_right_left_is_nat_trans
    : is_nat_trans _ _ biadj_hom_right_left_data.
  Proof.
    intros f g α.
    cbn in f, g, α ; cbn.
    unfold biadj_hom_right_left_data.
    simpl.
    refine (!_).
    etrans.
    {
      rewrite !vassocl.
      do 4 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!(vcomp_lunitor f _ α)).
      }
      rewrite !vassocr.
      rewrite vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocr.
    do 2 apply maponpaths_2.
    rewrite !vassocl.
    rewrite <- lwhisker_lwhisker.
    rewrite !vassocr.
    apply maponpaths_2.
    use vcomp_move_L_Mp.
    { is_iso. }
    simpl.
    rewrite !vassocl.
    use vcomp_move_R_pM.
    { is_iso. }
    simpl.
    rewrite !lwhisker_vcomp.
    etrans.
    {
      do 2 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        exact (psnaturality_natural ε _ _ _ _ α).
      }
      rewrite !vassocr.
      rewrite vcomp_linv, id2_left.
      apply idpath.
    }
    rewrite rwhisker_lwhisker_rassociator.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !rwhisker_vcomp.
    apply maponpaths.
    refine (!_).
    rewrite psfunctor_lwhisker.
    rewrite !vassocl.
    rewrite vcomp_rinv, id2_right.
    apply idpath.
  Qed.

  Definition biadj_hom_right_left
    : (biadj_right_hom ∙ biadj_left_hom)
        ⟹
        (functor_identity (hom (L X) Y)).
  Proof.
    use make_nat_trans.
    - exact biadj_hom_right_left_data.
    - exact biadj_hom_right_left_is_nat_trans.
  Defined.

  Definition biadj_hom_equivalence
    : equivalence_of_cats (hom X (R Y)) (hom (L X) Y).
  Proof.
    use tpair.
    - use tpair.
      + exact biadj_left_hom.
      + use tpair.
        * exact biadj_right_hom.
        * split.
          ** exact biadj_hom_left_right.
          ** exact biadj_hom_right_left.
    - split ; simpl.
      + intro a.
        apply is_inv2cell_to_is_z_iso.
        unfold biadj_hom_left_right_data.
        is_iso.
        apply property_from_invertible_2cell.
      + intro a.
        apply is_inv2cell_to_is_z_iso.
        unfold biadj_hom_right_left_data.
        is_iso.
        apply property_from_invertible_2cell.
  Defined.

  Definition biadj_hom_equiv
    : adj_equivalence_of_cats biadj_left_hom.
  Proof.
    exact (adjointificiation biadj_hom_equivalence).
  Defined.
End BiadjunctionHom.


(** A datatype to coerce from [Type] to [Prop]. The essence is that
    [squash {x:A|P x}] is equivalent to [exists x:A, P x], however,
    for instance, [squash (forall x:A, {y:B|P x y})] isn't equivalent
    to [forall x:A, exists y:B, P x y] (the former is stronger than
    the latter). In fact [(forall x:A, squash P x) -> squash (forall
    x:A,P x)] is an equivalent for of the axiom of choice [(forall
    x:A, exists y:B, P x y) -> (exists f:A->B, forall x:A, P x (f x))]. *)

Inductive squash (A:Type) : Prop :=
| squash_intro (a:A) : squash A
.

Lemma squash_map {A B} : (A->B) -> squash A -> squash B.
Proof.
  intros ? [?]; constructor; eauto.
Qed.

Lemma squash_unit {A} : A -> squash A.
Proof.
  intros ?; constructor; assumption.
Qed.

Lemma squash_join {A} : squash (squash A) -> squash A.
Proof.
  intros [?]; assumption.
Qed.

Lemma squash_counit {P:Prop} : squash P -> P.
Proof.
  intros [?]; assumption.
Qed.

Lemma squash_and {A B} : squash (A*B) -> (squash A) /\ (squash B).
Proof.
  intros [[h₁ h₂]].
  split; constructor; assumption.
Qed.

(** The binary case of finite choice. *)
Lemma and_squash {A B} : (squash A) /\ (squash B) -> squash (A*B).
Proof.
  intros [[h₁][h₂]].
  constructor;split;assumption.
Qed.

(** The zero-ary case of finite choice. *)
Lemma squash_top : squash unit.
Proof. do 2 constructor. Qed.

(** In the general case, of dependent product, only this direction is available. *)
Lemma squash_forall {A B} : squash (forall x:A, B x) -> forall x, squash (B x).
Proof.
  intros h x.
  destruct h as [h].
  constructor; eauto.
Qed.

(** Index types [A] where the converse of [squash_forall] is true are
    said to support choice. The property can be read in a familiar
    way: products over A of inhabited types is inhabited. Types
    supporting choice consist essentially of types for which a list of
    the element exist. It cannot be proved though, as some forms of
    choice are consistent. *)
Definition has_choice A :=
  forall B:A->Type, (forall x,squash (B x)) -> squash (forall x:A, B x)
.

(** Types supporting choice can hoist existentials out. *)
Lemma choice_exists A : has_choice A ->
  forall (B:A->Type) (P:forall x:A, B x -> Prop),
  (forall x:A, exists y:B x, P x y) ->
  exists f:(forall x:A,B x), forall x:A, P x (f x).
Proof.
  intros choice * h.
  assert (forall x:A, squash { y:B x & P x y }) as h'.
  { intros x; specialize (h x).
    destruct h as [ y h ].
    repeat econstructor; eauto. }
  apply choice in h'.
  destruct h' as [h'].
  exists (fun x => projT1 (h' x)).
  intros x.
  apply (projT2 (h' x)).
Qed.

(** A few type supporting choice from the standard library. *)
(** Equivalent to Lemma [squash_top]. *)
Lemma empty_has_choice : has_choice Empty_set.
Proof.
  unfold has_choice.
  intros B f.
  constructor; intros [].
Qed.

Lemma unit_has_choice : has_choice unit.
Proof.
  unfold has_choice.
  intros B f.
  specialize (f tt); destruct f as [f].
  constructor; intros [].
  assumption.
Qed.

(** Equivalent to Lemma [and_squash] *)
Lemma bool_has_choice : has_choice bool.
Proof.
  unfold has_choice.
  intros B f.
  generalize (f true); intros [h₁].
  generalize (f false); intros [h₂].
  constructor; intros [|]; assumption.
Qed.


Require Import List.
Parameter A : Set.
Parameter B : Set.
Definition assoc_list := list (A * B)%type.
Parameter eq_dec : forall (x:A) (y:A),{x=y}+{x<>y}.

Definition spec (x:A) (l:list (A*B)) r :=
  match r with
    | Some y => In (x,y) l
    | None => forall y:B, ~In (x,y) l
  end.

Fixpoint assoc (x:A) (l:list (A*B)) {struct l}  : option B :=
  match l with
    | nil => None
    | ((x',y)::t) =>
      match eq_dec x x' with
	| left p => Some y
	| right p => assoc x t
      end
  end.

Lemma assoc' : forall (x:A) (l:list (A*B)), option B.
Proof.
  intros x l.
  induction l.
  apply None.
  case_eq (eq_dec x (fst a)).
  intros.
  apply (Some (snd a)).
  intros ; apply IHl.
Defined.

Extraction assoc'.

(* prints out:
assoc' =
fun (x : A) (l : list (A * B)) =>
list_rec (fun _ : list (A * B) => option B) None
  (fun (a : A * B) (_ : list (A * B)) (IHl : option B) =>
   match eq_dec x (fst a) as s return (eq_dec x (fst a) = s -> option B) with
   | left e => fun _ : eq_dec x (fst a) = left (x <> fst a) e => Some (snd a)
   | right n => fun _ : eq_dec x (fst a) = right (x = fst a) n => IHl
   end (eq_refl (eq_dec x (fst a)))) l
     : A -> list (A * B) -> option B

(** val assoc' : a -> (a, b) prod list -> b option **)

let rec assoc' x = function
| Nil -> None
| Cons (y, l0) ->
  (match eq_dec x (fst y) with
   | Left -> Some (snd y)
   | Right -> assoc' x l0)

*)

(*
And then solve the obligations with:

Solve Obligations using intros; clear H0; subst; try (destruct (assoc x t); compute in *; destruct x0); firstorder; congruence.

*)


Require Import ct00.
(* ct00 contains the original conjecture. *)

Require Import ct22.
(* ct16 contains all necessary divide-and-conquer tactics *)

Require Import ct02 ct15 ct18 ct25.
(* ct02 ct15 ct18 ct25 contains the following proven lemmas:
 * - sort_prog_base
 * - permutation_merge_concat
 * - merge_sorted
 * - permutation_split_pivot
 *)

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if (le_lt_dec a1 a2) then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

Lemma sort_prog_pivot : forall (a : nat) (l l' l'0: list nat),
     sorted l' -> permutation l' (snd (split_pivot nat le le_dec a l))
  -> sorted l'0 -> permutation l'0 (fst (split_pivot nat le le_dec a l))
  -> {l'1 : list nat | sorted l'1 /\ permutation l'1 (a :: l)}.
Proof.
intros; exists (merge l'0 (a :: l')); split.
+ apply merge_sorted; auto; constructor; auto.
  assert (Forall (le a) l').
  eapply Permutation_Forall. apply Permutation_sym; apply H0.
  apply Forall_snd_split_pivot; intros;
  apply not_le, gt_le_S,le_Sn_le in H3; auto.
  inversion H3; auto.
+ rewrite permutation_merge_concat, <- Permutation_middle; constructor;
  rewrite H0, H2; apply permutation_split_pivot.
Defined.

Lemma qsort_prog :
  forall (l : list nat), {l' : list nat | sorted l' /\ permutation l' l}.
Proof.
unshelve div_conq_pivot. exact le. exact le_dec.
- apply sort_prog_base.
- intros; destruct H,H0,a0,a1; eapply sort_prog_pivot.
  exact H1. assumption. exact H. assumption.
Defined.

(*---------------------------------Extraction---------------------------------*)

Require Extraction.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.
(* Suppose all the packages above are embedded in some trans *)

Extraction Language OCaml.
Set Extraction AccessOpaque.

Extraction "extraction/qsort.ml" qsort_prog.

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


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst |  Cons : natural -> lst -> lst.

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

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

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

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma qreva_rev : forall (x y : lst), qreva x y = append (rev x) y.
Proof.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (qreva (qreva x y) Nil) (append (rev y) x).
Proof.
   induction x.
   - intros. simpl. rewrite qreva_rev. reflexivity.
   - intros.  simpl.  rewrite IHx.  simpl. lfind.  simpl.  reflexivity.
Admitted.


Require Import init.

Require Import nat.
Require Export mult.
Require Import set.

Require Import int_plus.

Notation "a ⊗ b" :=
    (fst a * fst b + snd a * snd b, fst a * snd b + snd a * fst b)
    (at level 40, left associativity) : int_scope.

(* begin hide *)
Open Scope int_scope.

Lemma int_mult_wd : ∀ a b c d, a ~ b → c ~ d → a ⊗ c ~ b ⊗ d.
Proof.
    intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] ab cd.
    simpl in *.
    pose proof (rmult c1 ab) as eq1.
    pose proof (rmult c2 ab) as eq2.
    pose proof (lmult b1 cd) as eq3.
    pose proof (lmult b2 cd) as eq4.
    symmetry in eq2.
    symmetry in eq4.
    pose proof (lrplus eq1 eq2) as eq5.
    pose proof (lrplus eq3 eq4) as eq6.
    pose proof (lrplus eq5 eq6) as eq.
    clear ab cd eq1 eq2 eq3 eq4 eq5 eq6.
    repeat rewrite ldist in eq.
    repeat rewrite rdist in eq.
    plus_cancel_right (b2 * c1) in eq.
    plus_cancel_right (b1 * c2) in eq.
    plus_cancel_right (b1 * c1) in eq.
    plus_cancel_right (b2 * c2) in eq.
    plus_bring_left (a1 * c2).
    plus_bring_left (a2 * c1).
    repeat rewrite plus_assoc.
    exact eq.
Qed.

Global Instance int_mult : Mult int := {
    mult := binary_op (binary_self_wd int_mult_wd);
}.

Lemma int_mult_comm : ∀ a b, a * b = b * a.
Proof.
    intros a b.
    equiv_get_value a b.
    unfold mult; simpl; equiv_simpl.
    destruct a as [a1 a2], b as [b1 b2].
    simpl.
    do 2 rewrite (mult_comm b1 _).
    do 2 rewrite (mult_comm b2 _).
    rewrite (plus_comm (a2 * b1)).
    reflexivity.
Qed.

Global Instance int_mult_comm_class : MultComm int := {
    mult_comm := int_mult_comm;
}.

Lemma int_mult_assoc : ∀ a b c, a * (b * c) = (a * b) * c.
Proof.
    intros a b c.
    equiv_get_value a b c.
    unfold mult; simpl; equiv_simpl.
    destruct a as [a1 a2], b as [b1 b2], c as [c1 c2]; simpl.
    repeat rewrite ldist, rdist.
    repeat rewrite mult_assoc.
    plus_cancel_left (a1 * b1 * c1)%nat.
    plus_cancel_left (a1 * b1 * c2)%nat.
    plus_cancel_left (a1 * b2 * c1)%nat.
    plus_cancel_left (a1 * b2 * c2)%nat.
    plus_cancel_left (a2 * b1 * c1)%nat.
    plus_cancel_left (a2 * b1 * c2)%nat.
    reflexivity.
Qed.

Global Instance int_mult_assoc_class : MultAssoc int := {
    mult_assoc := int_mult_assoc;
}.

Lemma int_ldist : ∀ a b c, a * (b + c) = a * b + a * c.
Proof.
    intros a b c.
    equiv_get_value a b c.
    unfold plus, mult; simpl; equiv_simpl.
    destruct a as [a1 a2], b as [b1 b2], c as [c1 c2]; simpl.
    do 4 rewrite ldist.
    plus_cancel_left (a1 * b1)%nat.
    plus_cancel_left (a1 * c1)%nat.
    plus_cancel_left (a2 * b2)%nat.
    plus_cancel_left (a2 * c2)%nat.
    plus_cancel_left (a2 * b1)%nat.
    plus_cancel_left (a1 * c2)%nat.
    reflexivity.
Qed.

Global Instance int_ldist_class : Ldist int := {
    ldist := int_ldist;
}.

Global Instance int_one : One int := {
    one := to_equiv int_equiv (1, 0);
}.

Lemma int_mult_lid : ∀ a, 1 * a = a.
Proof.
    intros a.
    equiv_get_value a.
    unfold mult, one; simpl; equiv_simpl.
    destruct a as [a1 a2]; simpl.
    repeat rewrite mult_lanni.
    repeat rewrite plus_rid.
    do 2 rewrite mult_lid.
    reflexivity.
Qed.

Global Instance int_mult_lid_class : MultLid int := {
    mult_lid := int_mult_lid;
}.
(* end hide *)
Theorem int_mult_0 : ∀ {a b}, 0 = a * b → 0 = a ∨ 0 = b.
Proof.
    intros a b eq.
    equiv_get_value a b.
    unfold mult, zero in *; simpl in *.
    equiv_simpl in eq.
    equiv_simpl.
    destruct a as [a1 a2], b as [b1 b2]; simpl in *.
    repeat rewrite plus_rid in *.
    repeat rewrite plus_lid in *.
    pose proof (trichotomy a1 a2) as comps.
    destruct comps as [comps|comp].
    destruct comps as [comp|comp].
    { (* a1 < a2 *)
        apply nat_lt_ex in comp as [c c_eq].
        rewrite <- c_eq in eq.
        do 2 rewrite rdist in eq.
        do 2 rewrite plus_assoc in eq.
        rewrite (plus_comm (a1 * b2)) in eq.
        apply plus_lcancel in eq.
        apply mult_lcancel in eq; [>|apply nat_zero_suc].
        right; symmetry; exact eq.
    }
    { (* a1 = a2 *)
        left; symmetry; exact comp.
    }
    { (* a1 > a2 *)
        apply nat_lt_ex in comp as [c c_eq].
        rewrite <- c_eq in eq.
        do 2 rewrite rdist in eq.
        rewrite plus_comm in eq.
        rewrite (plus_comm _ (a2 * b2)) in eq.
        do 2 rewrite plus_assoc in eq.
        rewrite (plus_comm (a2 * b1)) in eq.
        apply plus_lcancel in eq.
        apply mult_lcancel in eq; [>|apply nat_zero_suc].
        right; exact eq.
    }
Qed.

(* begin hide *)
Lemma int_mult_lcancel : ∀ a b c, 0 ≠ c → c * a = c * b → a = b.
Proof.
    intros a b c c_neq_0 eq.
    apply plus_0_anb_a_b in eq.
    rewrite <- mult_rneg in eq.
    rewrite <- ldist in eq.
    destruct (int_mult_0 eq) as [eq2|eq2]; try contradiction.
    rewrite plus_0_anb_a_b in eq2.
    exact eq2.
Qed.

Global Instance int_mult_lcancel_class : MultLcancel int := {
    mult_lcancel := int_mult_lcancel;
}.

Lemma int_not_trivial : 0 ≠ 1.
Proof.
    unfold zero, one; simpl.
    equiv_simpl.
    intro eq.
    inversion eq.
Qed.

Global Instance int_not_trivial_class : NotTrivial int := {
    not_trivial := int_not_trivial;
}.

Close Scope int_scope.
(* end hide *)
Theorem nat_to_int_mult : ∀ a b,
        nat_to_int (a * b) = nat_to_int a * nat_to_int b.
Proof.
    intros a b.
    unfold mult at 2, nat_to_int; simpl; equiv_simpl; simpl.
    do 2 rewrite mult_lanni.
    rewrite mult_ranni.
    do 3 rewrite plus_rid.
    reflexivity.
Qed.


Require Import Undecidability.Synthetic.Definitions.
From Undecidability.L Require Import L Functions.Eval Util.L_facts.
Import L_Notations.

(* Halting problem for call-by-value lambda-calculus *)
Definition HaltLclosed (s : {s : term | closed s}) := exists t, eval (proj1_sig s) t.

Lemma reduction : HaltL ⪯ HaltLclosed.
Proof.
  unshelve eexists.
  - intros s. exists (Eval (enc s)). unfold Eval. Lproc.
  - cbn. intros s. unfold HaltL. split; intros (t & Ht).
    + eapply eval_converges. edestruct Eval_converges. eapply H.
      eapply eval_iff in Ht. eauto.
    + setoid_rewrite eval_iff. eapply eval_converges.
      eapply Eval_converges. eapply Seval.eval_converges. eauto.
Qed.


From Undecidability.L Require Import L .
From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import Lists LNat.
From Complexity.NP.SAT Require Export SharedSAT.
Require Import Lia Nat.

(** * Formula Satisfiability: the satisfiability problem on arbitrary Boolean formulas *)

Inductive formula : Type :=
  | Ftrue : formula
  | Fvar : var -> formula
  | Fand : formula -> formula -> formula
  | For : formula -> formula -> formula
  | Fneg : formula -> formula.

Notation "a ∧ b" := (Fand a b) (at level 40).
Notation "a ∨ b" := (For a b) (at level 40).
Notation "¬ a" := (Fneg a) (at level 10).
Coercion Fvar : var >-> formula.

Notation "⋁ [ x , .. , z , y ]" := (For x .. (For z y) ..).
Notation "⋀ [ x , .. , z , y ]" := (Fand x .. (Fand z y) ..).

(** assignments: we list the variables which are assigned the value true; all other variables are assigned the value false *)
Implicit Types (a : assgn) (f : formula) (v : var).

Fixpoint evalFormula a f :=
  match f with
  | Ftrue => true
  | Fvar v => evalVar a v
  | Fand f1 f2 => evalFormula a f1 && evalFormula a f2
  | For f1 f2 => evalFormula a f1 || evalFormula a f2
  | Fneg f => negb (evalFormula a f)
  end.

Lemma evalFormula_and_iff a f1 f2 : evalFormula a (f1 ∧ f2) = true <-> evalFormula a f1 = true /\ evalFormula a f2 = true.
Proof. cbn. now rewrite andb_true_iff. Qed.

Lemma evalFormula_and_iff' f1 f2 a: evalFormula a (f1 ∧ f2) = false <-> evalFormula a f1 = false \/ evalFormula a f2 = false.
Proof.
  cbn.  destruct (evalFormula a f1), (evalFormula a f2); cbn; tauto.
Qed.

Lemma evalFormula_or_iff a f1 f2 : evalFormula a (f1 ∨ f2) = true <-> evalFormula a f1 = true \/ evalFormula a f2 = true.
Proof. cbn. now rewrite orb_true_iff. Qed.

Lemma evalFormula_not_iff a f : evalFormula a (¬ f) = true <-> not (evalFormula a f = true).
Proof.
  cbn. rewrite negb_true_iff. split; intro H.
  - rewrite H. discriminate.
  - destruct (evalFormula a f).
    + now contradiction H.
    + reflexivity.
Qed.

Lemma evalFormula_prim_iff a v : evalFormula a v = true <-> v el a.
Proof. cbn. unfold evalVar. rewrite list_in_decb_iff; [easy | intros ]. now rewrite Nat.eqb_eq. Qed.

(** satisfaction of formulas *)
Definition satisfies a f := evalFormula a f = true.
Definition FSAT f := exists a, satisfies a f.

(** bounds on the number of used variables *)
Inductive varInFormula (v : var) : formula -> Prop :=
  | varInFormulaV : varInFormula v v
  | varInFormuAndL f1 f2: varInFormula v f1 -> varInFormula v (f1 ∧ f2)
  | varInFormulaAndR f1 f2 : varInFormula v f2 -> varInFormula v (f1 ∧ f2)
  | varInFormulaOrL f1 f2 : varInFormula v f1 -> varInFormula v (f1 ∨ f2)
  | varInFormulaOrR f1 f2 : varInFormula v f2 -> varInFormula v (f1 ∨ f2)
  | varInFormulaNot f : varInFormula v f -> varInFormula v (¬ f).
#[export]
  Hint Constructors varInFormula : core.

Definition formula_varsIn (p : nat -> Prop) f := forall v, varInFormula v f -> p v.

(** A computable notion of boundedness *)
Fixpoint formula_maxVar (f : formula) := match f with
  | Ftrue => 0
  | Fvar v => v
  | Fand f1 f2 => Nat.max (formula_maxVar f1) (formula_maxVar f2)
  | For f1 f2 => Nat.max (formula_maxVar f1) (formula_maxVar f2)
  | Fneg f => formula_maxVar f
end.

Lemma formula_maxVar_varsIn f : formula_varsIn (fun n => n < S (formula_maxVar f)) f.
Proof.
  unfold formula_varsIn.
  induction f.
  - intros v H. inv H.
  - intros v H. inv H. now cbn.
  - intros v H. inv H.
    + apply IHf1 in H1. cbn. lia.
    + apply IHf2 in H1. cbn. lia.
  - intros v H. inv H.
    + apply IHf1 in H1. cbn. lia.
    + apply IHf2 in H1. cbn. lia.
  - intros v H. inv H. apply IHf in H1. cbn. lia.
Qed.

Lemma formula_varsIn_bound f c : formula_varsIn (fun n => n <= c) f -> formula_maxVar f <= c.
Proof.
  unfold formula_varsIn. intros H. induction f; cbn.
  - lia.
  - now apply H.
  - apply Nat.max_lub; [apply IHf1 | apply IHf2]; eauto.
  - apply Nat.max_lub; [apply IHf1 | apply IHf2]; eauto.
  - apply IHf; eauto.
Qed.

(** size of formulas *)
Fixpoint formula_size (f : formula) := match f with
  | Ftrue => 1
  | Fvar _ => 1
  | For f1 f2 => formula_size f1 + formula_size f2 + 1
  | Fand f1 f2 => formula_size f1 + formula_size f2 + 1
  | Fneg f => formula_size f + 1
end.

(** ** extraction *)
From Undecidability.L.Datatypes Require Import LNat.
From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import  LProd LOptions LBool LUnit.
From Complexity.Libs.CookPrelim Require Import PolyBounds.

MetaCoq Run (tmGenEncode "formula_enc" formula).
#[export]
Hint Resolve formula_enc_correct : Lrewrite.

Lemma formula_enc_size f: size (enc f) = match f with
  | Ftrue => 10
  | Fvar v => 10 + size (enc v )
  | Fand f1 f2 => 10 + size (enc f1) + size (enc f2)
  | For f1 f2 => 9 + size (enc f1) + size (enc f2)
  | Fneg f => 7 + size (enc f)
  end.
Proof.
  set (g:=enc (X:= formula)). unfold enc in g;cbn in g.
  destruct f; cbn; try lia.
Qed.

#[export]
Instance term_Fvar : computableTime' Fvar (fun v _ => (1, tt)).
Proof.
  extract constructor. solverec.
Qed.

#[export]
Instance term_Fand : computableTime' Fand (fun f1 _ => (1, fun f2 _ => (1, tt))).
Proof.
  extract constructor. solverec.
Qed.

#[export]
Instance term_For : computableTime' For (fun f1 _ => (1, fun f2 _ => (1, tt))).
Proof.
  extract constructor. solverec.
Qed.

#[export]
Instance term_Fneg : computableTime' Fneg (fun f _ => (1, tt)).
Proof.
  extract constructor. solverec.
Qed.

(** the encoding size of a formula is bounded linearly by formula_size f * formula_maxVar f *)
Definition c__formulaBound1 := c__natsizeS.
Definition c__formulaBound2 := size (enc Ftrue) + 10 + c__natsizeO.
Lemma formula_enc_size_bound : forall f, size (enc f) <= c__formulaBound1 * formula_size f * formula_maxVar f + c__formulaBound2 * formula_size f.
Proof.
  induction f; rewrite formula_enc_size.
  - unfold c__formulaBound2. cbn. nia.
  - rewrite size_nat_enc. unfold c__formulaBound1, c__formulaBound2. cbn -[Nat.add Nat.mul]. lia.
  - cbn -[Nat.mul Nat.add].
    rewrite IHf1, IHf2. unfold c__formulaBound2. cbn. nia.
  - cbn -[Nat.mul Nat.add].
    rewrite IHf1, IHf2. unfold c__formulaBound2. cbn. nia.
  - cbn -[Nat.mul Nat.add].
    rewrite IHf. unfold c__formulaBound2. nia.
Qed.

(** conversely, we can only obtain a quadratic bound due to the overapproximation provided by maxVar *)

Lemma formula_size_enc_bound f : formula_size f <= size (enc f).
Proof.
  induction f; rewrite formula_enc_size; cbn -[Nat.add Nat.mul]; try lia.
Qed.

Lemma formula_maxVar_enc_bound f : formula_maxVar f <= size (enc f).
Proof.
  induction f; rewrite formula_enc_size; cbn -[Nat.add Nat.mul]; try lia.
  rewrite (size_nat_enc_r n) at 1. unfold enc. cbn. nia.
Qed.

Lemma formula_total_size_enc_bound f : formula_size f * formula_maxVar f <= size (enc f) * size (enc f).
Proof.
  rewrite formula_size_enc_bound, formula_maxVar_enc_bound. lia.
Qed.

(**extraction of formula_maxVar *)

Definition c__formulaMaxVar := 13 + c__max1.
Fixpoint formula_maxVar_time (f : formula) := match f with
  | Ftrue => 0
  | Fvar _ => 0
  | Fand f1 f2 => formula_maxVar_time f1 + formula_maxVar_time f2 + max_time (formula_maxVar f1) (formula_maxVar f2)
  | For f1 f2 => formula_maxVar_time f1 + formula_maxVar_time f2 + max_time (formula_maxVar f1) (formula_maxVar f2)
  | Fneg f => formula_maxVar_time f
  end + c__formulaMaxVar.
#[export]
Instance term_formula_maxVar : computableTime' formula_maxVar (fun f _ => (formula_maxVar_time f, tt)).
Proof.
  extract. solverec.
  - now unfold c__formulaMaxVar.
  - now unfold c__formulaMaxVar.
  - fold formula_maxVar. unfold c__formulaMaxVar; solverec.
  - fold formula_maxVar. unfold c__formulaMaxVar; solverec.
  - unfold c__formulaMaxVar; solverec.
Qed.

Definition c__formulaMaxVarBound1 := c__formulaMaxVar + c__max2.
Definition poly__formulaMaxVar n := (n+1) * (n + 1) * c__formulaMaxVarBound1.
Lemma formula_maxVar_time_bound (f : formula) : formula_maxVar_time f <= poly__formulaMaxVar (size (enc f)).
Proof.
  induction f; cbn -[Nat.add Nat.mul].
  - unfold poly__formulaMaxVar, c__formulaMaxVarBound1; nia.
  - unfold poly__formulaMaxVar, c__formulaMaxVarBound1; nia.
  - rewrite IHf1, IHf2. unfold max_time. rewrite Nat.le_min_l.
    rewrite formula_maxVar_enc_bound. setoid_rewrite formula_enc_size at 4.
    unfold poly__formulaMaxVar, c__formulaMaxVarBound1. leq_crossout.
  - rewrite IHf1, IHf2. unfold max_time. rewrite Nat.le_min_l.
    rewrite formula_maxVar_enc_bound. setoid_rewrite formula_enc_size at 4.
    unfold poly__formulaMaxVar, c__formulaMaxVarBound1. leq_crossout.
  - rewrite IHf. setoid_rewrite formula_enc_size at 2. unfold poly__formulaMaxVar, c__formulaMaxVarBound1. leq_crossout.
Qed.
Lemma formula_maxVar_poly : monotonic poly__formulaMaxVar /\ inOPoly poly__formulaMaxVar.
Proof.
  split; unfold poly__formulaMaxVar; smpl_inO.
Qed.