(** * 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".
Require Export Basics.
(** Require Export Lists.
Require Export Induction.
 *)
(*** 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.

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

End MumbleGrumble.

(* ----------------------------------------------------------------- *)
(** *** 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 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 t l.
  induction l as [|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 t l m n.
  induction l.
  - simpl.
    reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_length_helper : forall A (l1 l2 : list A),
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros t l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite -> IHl1'. reflexivity.  Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros t l1 l2.
  induction l2.
  - rewrite app_nil_r. simpl.
    rewrite<-plus_n_O. reflexivity.
  - simpl. rewrite app_length_helper. 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 t l1 l2.
  induction l1 as [|h tail Hpre].
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite Hpre. rewrite app_assoc. reflexivity.
Qed.
Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intro x.
  intros l.
  induction l as [|h t Hpre].
  - reflexivity.
  - simpl. rewrite rev_app_distr.  rewrite Hpre. 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
  | nil => ([],[])
  | hp::tail => ((fst hp)::(fst (split tail)),
                 (snd hp)::(snd (split tail)))
  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: *)

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
  :=
  match l with
  | nil => None
  | h::t => Some h
  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 x => andb (evenb x) (negb (leb x 7))) l.

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

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

(** **** Exercise: 3 stars (partition)  *)
(** Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list. *)

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

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

(* ================================================================= *)
(** ** Map *)

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

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

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

Example test_map1: map (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. *)

Theorem map_rev_helper : forall (X Y:Type) (f : X->Y) (l1:list X) (a:X),
  map f (l1 ++ [a]) = map f l1 ++ [f a].
Proof.
  intros X Y f l1 a.
  induction l1 as [|h t Hpre].
  - reflexivity.
  - simpl. rewrite<-Hpre. 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 [|h t Hpre].
  - reflexivity.
  - simpl. rewrite<-Hpre. rewrite map_rev_helper. 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
  | nil => []
  | 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.
(** [] *)

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

Compute (fold (fun x y=> andb (leb x 10) y) [1;2;11;4] true).

(** [] *)

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

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

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

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

(* 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
  := f (fst p) (snd p).

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

Induction on n.
1. When n=0, length 1=0 -> l=[], then n_th returns None.
2. When n=n'+1, length l = length (h::l') = 1 + length l' = 1 + n',
    thus length l' = n'.
   nth_error l n = nth_error l' n'.
   Since length l'=n' -> nth_error l' n' = None.
   So length l = n -> @nth_error X l n = 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 (fun a=>m X f a) 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) (x : X) =>
     (m (X->X) (fun y => (fun z => (n X y z))) f) x.

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

End Exercises.

(** $Date: 2018-01-23 20:16:07 -0600 (Tue, 23 Jan 2018) $ *)


(*****************************************************************)
(******       M1 Preuves Assistées par Ordinateur          *******)
(****** Projet : compilation d'expressions avec sommations *******)
(******               Pierre Letouzey                      *******)
(*****************************************************************)

Require Import String Datatypes Arith NPeano List Lia.
Open Scope string_scope.
Open Scope list_scope.
Open Scope nat_scope.

(** Travail demandé :
    a) Enlever l'axiome TODO et remplacer ses usages par du code
       convenable.
    b) Remplacer tous les Admitted par de véritables preuves. *)
Axiom TODO : forall {A:Type}, A.

(** I) Bibliotheque *)

(** Comparaisons d'entiers

    En Coq, la comparaison a <= b est une affirmation logique
    (dans Prop). On ne peut pas s'en servir pour un test dans
    un programme. Pour cela il faut utiliser la comparaison
    booléenne a <=? b (correspondant à la constante Nat.leb,
    définie dans le module NPeano). Voici le lien entre ces
    deux notions. *)

Lemma leb_le x y : (x <=? y) = true <-> x <= y.
Proof.
 apply Nat.leb_le.
Qed.

Lemma leb_gt x y : (x <=? y) = false <-> y < x.
Proof.
 rewrite Nat.lt_nge, <- leb_le. destruct (x <=? y); intuition.
Qed.

(** Une soustraction sans arrondi.

    Sur les entiers naturels, la soustraction usuelle de Coq
    est tronquée : lorsque a < b, alors a - b = 0.
    Ici on utilise None pour signaler ce cas, et Some pour
    indiquer une soustraction "réussie". *)

Fixpoint safe_minus a b : option nat :=
 match b, a with
   | 0, _ => Some a
   | S b, 0 => None
   | S b, S a => safe_minus a b
 end.

Lemma safe_minus_spec a b :
 match safe_minus a b with
 | Some c => a = b + c
 | None => a < b
 end.
Proof.
 revert b; induction a; destruct b; simpl; auto with arith.
 specialize (IHa b). destruct (safe_minus a b); auto with arith.
Qed.

(** Accès au n-ieme élement d'une liste

   NB: list_get existe aussi dans la bibliothèque standard,
   c'est List.nth_error. *)

Fixpoint list_get {A} (l:list A) i : option A :=
  match i,l with
    | 0,   x::_ => Some x
    | S j, _::l => list_get l j
    | _, _ => None
  end.

Definition option_map {A B} (f:A->B) (o:option A) :=
  match o with
    | Some a => Some (f a)
    | None => None
  end.

Fixpoint list_set {A} (l:list A) i x : option (list A) :=
  match i,l with
    | 0, _::l => Some (x::l)
    | S j, a::l => option_map (cons a) (list_set l j x)
    | _, _ => None
  end.

Lemma get_app_l {A} (l l':list A)(n:nat) : n < length l ->
  list_get (l++l') n = list_get l n.
Proof.
 revert l.
 induction n; destruct l; simpl; auto with arith; inversion 1.
Qed.

Lemma get_app_r {A} (l l':list A)(n:nat) :
  list_get (l++l') (length l + n) = list_get l' n.
Proof.
 induction l; auto.
Qed.

Lemma get_app_r0 {A} (l l':list A)(n:nat) : n = length l ->
  list_get (l++l') n = list_get l' 0.
Proof.
  intros. rewrite <- (get_app_r l l'). f_equal. lia.
Qed.

Lemma get_app_r' {A} (l l':list A)(n:nat) : length l <= n ->
  list_get (l++l') n = list_get l' (n-length l).
Proof.
 intros. rewrite <- (get_app_r l l'). f_equal. lia.
Qed.

Lemma get_None {A} (l:list A) n :
 list_get l n = None <-> length l <= n.
Proof.
 revert n. induction l; destruct n; simpl; rewrite ?IHl; split;
  auto with arith; inversion 1.
Qed.

Lemma get_Some {A} (l:list A) n x :
 list_get l n = Some x -> n < length l.
Proof.
 revert n. induction l; destruct n; simpl; try discriminate.
  - auto with arith.
  - intros. apply IHl in H. auto with arith.
Qed.

(** Equivalent de List.assoc, spécialisé aux string *)

Fixpoint lookup {A}(s:string)(l:list (string*A))(default:A) :=
  match l with
    | nil => default
    | (x,d)::l => if string_dec s x then d else lookup s l default
  end.

(** Index d'un element dans une liste, spécialisé aux string *)

Fixpoint index (s:string)(l:list string) :=
  match l with
    | nil => 0
    | x::l => if string_dec s x then 0 else S (index s l)
  end.

(** Opérateur de sommation : sum f x n = f x + ... + f (x+n).
    Attention, il y a (n+1) termes dans cette somme.
    En particulier sum f 0 n = f 0 + ... + f n. *)

Fixpoint sum f x k :=
  match k with
    | 0 => f x
    | S n' => f x + sum f (S x) n'
  end.

Compute sum (fun _ => 1) 0 10. (* 11 *)
Compute sum (fun x => x) 0 10. (* 0 + 1 + ... + 10 = 55 *)

(** II) Expressions arithmétiques avec sommations *)

(** Les expressions *)

Definition var := string.

Inductive op := Plus | Minus | Mult.

Inductive expr :=
  | EInt : nat -> expr
  | EVar : var -> expr
  | EOp  : op -> expr -> expr -> expr
  | ESum : var -> expr -> expr -> expr.

(** (ESum var max body) est la somme des valeurs de body
    lorsque var prend successivement les valeurs de 0 jusqu'à max
    (inclus). Par exemple, voici la somme des carrés de 0 à 10,
    ce qu'on écrit sum(x^2,x=0..10) en Maple ou encore
    $\sum_{x=0}^{10}{x^2}$ en LaTeX. *)

Definition test1 :=
  ESum "x" (EInt 10) (EOp Mult (EVar "x") (EVar "x")).

(** Un peu plus complexe, une double sommation:
    sum(sum(x*y,y=0..x),x=0..10) *)

Definition test2 :=
  ESum "x" (EInt 10)
   (ESum "y" (EVar "x")
     (EOp Mult (EVar "x") (EVar "y"))).

(** Evaluation d'expression *)

Definition eval_op o :=
  match o with
    | Plus => plus
    | Minus => minus
    | Mult => mult
  end.

Fixpoint eval (env:list (string*nat)) e :=
  match e with
    | EInt n => n
    | EVar v => lookup v env 0
    | EOp o e1 e2 => eval_op o (eval env e1) (eval env e2)
    | ESum v efin ecorps => sum (fun i =>eval ((v,i)::env) ecorps) 0 (eval env efin)
  end.

Compute (eval nil test1). (* 385 attendu: n(n+1)(2n+1)/6 pour n=10 *)
Compute (eval nil test2). (* 1705 attendu *)

(** III) Machine à pile *)

(** Notre machine est composée de deux piles : une pile principale
    (pour les calculs) et une pile de variables. Les instructions
    sont stockées à part. *)

Record machine :=
  Mach {
      (** Pointeur de code *)
      pc : nat;
      (** Pile principale *)
      stack : list nat;
      (** Pile de variables *)
      vars : list nat
    }.

Definition initial_machine := Mach 0 nil nil.

Inductive instr :=
  (** Pousse une valeur entière sur la pile. *)
  | Push : nat -> instr
  (** Enleve la valeur au sommet de la pile. *)
  | Pop : instr
  (** Dépile deux valeurs et empile le resultat de l'operation binaire. *)
  | Op : op -> instr
  (** Crée une nouvelle variable en haut de la pile des variables,
      contenant initialement 0. *)
  | NewVar : instr
  (** Enleve la variable en haut de la pile des variables.
      Sa valeur actuelle est perdue. *)
  | DelVar : instr
  (** Pousse la valeur de la i-eme variable sur la pile. *)
  | GetVar : nat -> instr
  (** Enlève la valeur au sommet de la pile et donne-la à la i-eme variable. *)
  | SetVar : nat -> instr
  (** Jump offset: retire offset au pointeur de code si la première
      variable est inférieure ou égale au sommet de pile.
      Pile et variables sont gardées à l'identique. *)
  | Jump : nat -> instr.

(* NB: il n'y a pas d'instruction Halt, on s'arrête quand
   pc arrive au delà du code. *)

(* Sémantique de référence des instructions,
   définie via une relation inductive *)

Inductive Stepi : instr -> machine -> machine -> Prop :=
| SPush pc stk vs n :
    Stepi (Push n) (Mach pc stk vs) (Mach (S pc) (n::stk) vs)
| SPop pc stk vs x :
    Stepi Pop (Mach pc (x::stk) vs) (Mach (S pc) stk vs)
| SOp pc stk vs o y x :
    Stepi (Op o) (Mach pc (y::x::stk) vs)
                 (Mach (S pc) (eval_op o x y :: stk) vs)
| SNewVar pc stk vs :
    Stepi NewVar (Mach pc stk vs) (Mach (S pc) stk (0::vs))
| SDelVar pc stk vs x :
    Stepi DelVar (Mach pc stk (x::vs)) (Mach (S pc) stk vs)
| SGetVar pc stk vs i x :
    list_get vs i = Some x ->
    Stepi (GetVar i) (Mach pc stk vs) (Mach (S pc) (x::stk) vs)
| SSetVar pc stk vs vs' i x :
    list_set vs i x = Some vs' ->
    Stepi (SetVar i) (Mach pc (x::stk) vs)
                     (Mach (S pc) stk vs')
| SJumpYes pc stk vs v x off : off <= pc -> v <= x ->
    Stepi (Jump off) (Mach pc (x::stk) (v::vs))
                     (Mach (pc-off) (x::stk) (v::vs))
| SJumpNo pc stk vs v x off : x < v ->
    Stepi (Jump off) (Mach pc (x::stk) (v::vs))
                     (Mach (S pc) (x::stk) (v::vs)).

Definition Step (code:list instr) (m m' : machine) : Prop :=
 match list_get code m.(pc) with
  | Some instr => Stepi instr m m'
  | None => False
 end.

Inductive Steps (code:list instr) : machine -> machine -> Prop :=
 | NoStep m : Steps code m m
 | SomeSteps m1 m2 m3 :
     Step code m1 m2 -> Steps code m2 m3 -> Steps code m1 m3.

(** state : état d'une machine, c'est à dire sa pile de calcul
    et sa pile de variables, mais pas son pc. *)

Definition state := (list nat * list nat)%type.

(** Une execution complète va de pc=0 à pc=(length code) *)

Definition Exec code '(stk, vs) '(stk', vs') :=
  Steps code (Mach 0 stk vs) (Mach (length code) stk' vs').

(** Run : relation entre un code et le résultat de son exécution. *)

Definition Run code res := Exec code (nil,nil) (res::nil,nil).

(** Petit exemple d'usage de cette sémantique *)

Lemma Run_example :
  Run (Push 7 :: Push 3 :: Op Minus :: nil) 4.
Proof.
 repeat econstructor.
Qed.

(** Propriétés basiques de Steps : transitivité, ... *)

Hint Constructors Steps.

Lemma Steps_trans code m1 m2 m3 :
 Steps code m1 m2 -> Steps code m2 m3 -> Steps code m1 m3.
Proof.
  intros.
  induction H.
  -assumption.
  -eapply SomeSteps.
  eassumption.
  apply IHSteps.
  easy.
Qed.

Lemma OneStep code st st' : Step code st st' -> Steps code st st'.
Proof.
  intros.
  eapply SomeSteps.
  -eassumption.
  -apply NoStep.
Qed.

(** Décalage de pc dans une machine *)

Definition shift_pc k (p:machine) :=
 let '(Mach pc vars stk) := p in
 (Mach (k+pc) vars stk).

Lemma pc_shift n m : (shift_pc n m).(pc) = n + m.(pc).
Proof.
 now destruct m.
Qed.

(** Ajout de code devant / derriere la zone intéressante *)

Hint Resolve get_Some.

Lemma Step_extend code code' m m' :
 Step code m m' -> Step (code++code') m m'.
Proof.
  intros.
  unfold Step in *.
  destruct (list_get code (pc m)) eqn : Heq.
  -rewrite get_app_l.
    +rewrite Heq. easy.
    +eapply get_Some in Heq. easy.
  -easy.
Qed.
  (*
  assert (list_get (@nil instr) (pc m) = None).
   *)
Lemma Steps_extend code code' m m' :
 Steps code m m' -> Steps (code++code') m m'.
Proof.
  intros.
  induction H.
  -eapply NoStep.
  -eapply Steps_trans in IHSteps.
    +eassumption.
    +eapply OneStep. eapply Step_extend. easy.
Qed.

Hint Constructors Stepi.

Lemma Stepi_shift instr n m m' :
 Stepi instr m m' ->
 Stepi instr (shift_pc n m) (shift_pc n m').
Proof.
  intros.
  destruct H.
  -simpl. rewrite Nat.add_succ_r. eapply SPush.
  -simpl. rewrite Nat.add_succ_r. eapply SPop.
  -simpl. rewrite Nat.add_succ_r. eapply SOp.
  -simpl. rewrite Nat.add_succ_r. eapply SNewVar.
  -simpl. rewrite Nat.add_succ_r. eapply SDelVar.
  -simpl. rewrite Nat.add_succ_r. eapply SGetVar. easy.
  -simpl. rewrite Nat.add_succ_r. eapply SSetVar. easy.
  -simpl. rewrite Nat.add_sub_assoc.
    +eapply SJumpYes.
      *lia.
      *lia.
    +lia.
  -simpl. rewrite Nat.add_succ_r. eapply SJumpNo. lia.
Qed.

Lemma Step_shift code0 code m m' (n := List.length code0) :
 Step code m m' ->
 Step (code0 ++ code) (shift_pc n m) (shift_pc n m').
Proof.

  intros.
  unfold Step in *.
  destruct (list_get code (pc m)) eqn : Heq.
  -rewrite get_app_r'.
    +rewrite pc_shift. rewrite Nat.add_comm.
    rewrite <- Nat.add_sub_assoc.
      *subst n.
      rewrite Nat.sub_diag. rewrite Nat.add_0_r.
      rewrite Heq. eapply Stepi_shift. easy.
      *lia.
    +subst n. eapply get_Some in Heq. rewrite pc_shift. lia.
  -easy.
Qed.

Lemma Steps_shift code0 code  m m' (n := List.length code0) :
 Steps code m m' ->
 Steps (code0 ++ code) (shift_pc n m) (shift_pc n m').
Proof.
  intros.
  induction H.
  -apply NoStep.
  -eapply Step_shift in H. eapply OneStep in H.
  eapply Steps_trans in IHSteps.
    +eassumption.
    +eassumption.
Qed.

(** Composition d'exécutions complètes *)

Lemma Exec_trans code1 code2 stk1 vars1 stk2 vars2 stk3 vars3 :
 Exec code1 (stk1, vars1) (stk2, vars2) ->
 Exec code2 (stk2, vars2) (stk3, vars3) ->
 Exec (code1 ++ code2) (stk1, vars1) (stk3, vars3).
Proof.
  unfold Exec.
  intros.
  -eapply Steps_trans.
    +eapply Steps_extend. eassumption.
    +eapply Steps_shift in H0. simpl in H0. rewrite Nat.add_0_r in H0.
    rewrite app_length. eassumption.
Qed.

(** Correction des sauts lors d'une boucle

    - La variable 0 est la variable de boucle a,
    - La variable 1 est l'accumulateur acc
    - Le haut de pile est la limite haute b de la variable de boucle

    On montre d'abord que si un code ajoute f(a) à acc et
    incrémente a, alors la répétition de ce code (via un Jump
    ultérieur) ajoutera (sum f a (b-a)) à acc.
    La variable N (valant b-a) est le nombre de tours à faire.
*)

(* Ce lemme est difficile. N'hésitez pas à le sauter et à y revenir
   après avoir fini la partie IV. *)

Hint Resolve le_n_S le_plus_r.

Lemma Steps_jump code n (f:nat->nat) stk vars b :
  length code = n ->
  (forall a acc,
   Steps code
         (Mach 0 (b::stk) (a::acc::vars))
         (Mach n (b::stk) ((S a)::(acc + f a)::vars)))
  ->
  forall N a acc,
    b = N + a ->
    Steps (code++(Jump n)::nil)
          (Mach 0 (b::stk) (a::acc::vars))
          (Mach (S n) (b::stk) ((S b)::(acc + sum f a N)::vars)).
Proof.
  (* intros.
  eapply Steps_extend. *)

Admitted.

(** Version spécialisée du résultat précédent, avec des
    Exec au lieu de Step, et 0 comme valeur initiale des variables
    de boucle et d'accumulateurs. *)

Lemma Exec_jump code (f:nat->nat) stk vars b :
  (forall a acc,
     Exec code (b::stk, a::acc::vars)
               (b::stk, (S a)::(acc + f a)::vars))
  ->
  Exec (code++(Jump (length code))::nil)
      (b::stk, 0::0::vars)
      (b::stk, (S b)::(sum f 0 b)::vars).
Proof.
  intros.
  simpl.
  unfold Exec in  *.
  eapply Steps_jump with (acc:=0) (N:= b) (a:= 0) in H.
  -rewrite last_length. eassumption.
  -easy.
  -lia.
Qed.

(** IV) Le compilateur

    On transforme une expression en instructions pour
    notre machine à pile.

    Conventions:
     - à chaque entrée dans une boucle, on crée deux variables,
       la variable de boucle et l'accumulateur.
     - on s'arrange pour que les variables de boucles aient
       des indices pairs dans la pile des variables
     - l'environnement de compilation cenv ne contient que les
       variables de boucles.
    Voir également l'invariant EnvsOk ci-dessous. *)
Fixpoint comp (cenv:list string) e :=
  match e with
    | EInt n => Push n :: nil
    | EVar v => GetVar (index v cenv*2) :: nil
    | EOp o e1 e2 => (comp cenv e1)++(comp cenv e2) ++ Op o :: nil
    | ESum v efin ecorps =>
      let prologue :=(comp cenv efin)++NewVar::NewVar::nil in
      let corps := (comp (v::cenv) ecorps)++GetVar 1:: Op Plus ::SetVar 1:: Push 1::GetVar 0::Op Plus ::SetVar 0 ::nil in
      let boucle := corps ++ Jump (length corps) :: nil in
      let epilogue := Pop:: GetVar 1::DelVar :: DelVar :: nil in
      prologue ++ boucle ++ epilogue
  end.

Definition compile e := comp nil e.

(** Variables libres d'une expression *)

Inductive FV (v:var) : expr -> Prop :=
| FVVar : FV v (EVar v)
| FVSum e1 e2 v0: FV v e1 \/ FV v e2 /\  v<>v0 ->FV v (ESum v0 e1 e2)
| FVOp e1 e2 o: FV v e1 \/ FV v e2 -> FV v (EOp o e1 e2).

Hint Constructors FV.

Definition Closed e := forall v, ~ FV v e.

(** Invariants sur les environnements.
    env : environnement d'evaluation (list (string*nat))
    cenv : environnement de compilation (list string)
    vars : pile de variables pour nos machines *)

Definition EnvsOk e env cenv vars :=
 forall v, FV v e ->
   In v cenv /\
   list_get vars (index v cenv * 2) = Some (lookup v env 0).

Hint Unfold EnvsOk.

Lemma EnvsOk_ESum v e1 e2 env cenv vars a b :
  EnvsOk (ESum v e1 e2) env cenv vars ->
  EnvsOk e2 ((v,a)::env) (v::cenv) (a::b::vars).
Proof.
  unfold EnvsOk.
  intros.
  simpl.
  destruct (string_dec v0 v).
  -simpl. split.
    +rewrite e. left. easy.
    +easy.
  -simpl. split.
    +right. apply H. apply FVSum. right. easy.
    +apply H. apply FVSum. right. easy.
  Qed.

(** Correction du compilateur *)

Ltac basic_exec :=
  (* Cette tactique prouve des buts (Exec code m m')
     quand le code et la machine m sont connus en détail. *)
  unfold Exec; repeat (eapply SomeSteps; [constructor|]);
   try apply NoStep; try reflexivity.

(* Si vous avez l'impression de prouver quelque chose d'impossible,
   peut-être est-ce le signe que vous vous êtes trompé dans la définition
   de comp. *)

Theorem comp_ok e env cenv vars stk :
 EnvsOk e env cenv vars ->
 Exec (comp cenv e) (stk,vars) (eval env e :: stk, vars).
Proof.
  revert stk.
  revert cenv.
  revert vars.
  revert env.
  induction e.
  -intros. basic_exec.
  -intros. basic_exec. eapply H. eapply FVVar.
  -intros.
  change (comp cenv (EOp o e1 e2)) with ((comp cenv e1)++(comp cenv e2)
  ++ Op o :: nil).
  eapply Exec_trans.
    +eapply IHe1. unfold EnvsOk in *. auto.
    +eapply Exec_trans.
      *eapply IHe2. unfold EnvsOk in *. auto.
      *basic_exec.
  -intros.
  change (comp cenv (ESum v e1 e2)) with (let prologue :=(comp cenv e1)++NewVar::NewVar::nil in
  let corps := (comp (v::cenv) e2)++ GetVar 1:: Op Plus ::SetVar 1::Push 1::GetVar 0::Op Plus ::SetVar 0 ::nil in
  let boucle := corps ++ Jump (length corps) :: nil in
  let epilogue := Pop::GetVar 1::DelVar :: DelVar :: nil in
  prologue ++ boucle ++ epilogue).
  eapply Exec_trans.
    +eapply Exec_trans.
      *eapply IHe1. auto.
      *basic_exec.
    +eapply Exec_trans.
      *eapply Exec_jump. intros. eapply Exec_trans.
        **eapply IHe2. eapply EnvsOk_ESum. eassumption.
        **basic_exec. simpl. rewrite Nat.add_comm. easy.
      *basic_exec.
 Qed.

Theorem compile_ok e : Closed e -> Run (compile e) (eval nil e).
Proof.
  unfold Closed.
  unfold Run.
  intros.
  eapply comp_ok.
  unfold EnvsOk.
  intros.
  destruct (H v).
  easy.
  Qed.

(** V) Sémantique exécutable

    A la place des relations précédentes (Step*, Exec, Run...),
    on cherche maintenant à obtenir une fonction calculant
    le résultat de l'exécution d'une machine à pile. *)

(* Cette partie est nettement plus difficile que les précédentes
   et est complètement optionnelle. *)

Inductive step_result : Type :=
  | More : machine -> step_result (* calcul en cours *)
  | Stop : machine -> step_result (* calcul fini (pc hors code) *)
  | Bug : step_result. (* situation illégale, machine plantée *)

(** Pour la fonction [step] ci-dessous, ces deux opérateurs
    monadiques peuvent aider (même si c'est essentiellement
    une affaire de goût). *)

Definition option_bind {A} (o:option A) (f : A -> step_result) :=
  match o with
    | None => Bug
    | Some x => f x
  end.

Infix ">>=" := option_bind (at level 20, left associativity).

Definition list_bind {A} (l:list A) (f:A->list A->step_result) :=
 match l with
  | nil => Bug
  | x::l => f x l
 end.

Infix "::>" := list_bind (at level 20, left associativity).

(** Un pas de calcul *)

Definition step code (m:machine) : step_result :=
  let '(Mach pc stk vars) := m in
  (** réponse usuelle: *)
  let more := fun stk vars => More (Mach (S pc) stk vars) in
  match list_get code pc with
    | None => Stop m
    | Some instr => match instr with
      | Push n => more (n::stk) vars
      | Pop => TODO
      | Op o => TODO
      | NewVar => TODO
      | DelVar => TODO
      | GetVar i => TODO
      | SetVar i => TODO
      | Jump off => TODO
      end
    end.

(** La fonction [steps] itère [step] un nombre [count] de fois
    (ou moins si [Stop _] ou [Bug] sont atteints). *)

Fixpoint steps count (code:list instr)(m:machine) :=
  match count with
    | 0 => More m
    | S count' => TODO
  end.

(** La function [run] exécute un certain code à partir
    de la machine initiale, puis extrait le résultat obtenu.
    On répond [None] si le calcul n'est pas fini au bout
    des [count] étapes indiquées, ou bien en cas d'anomalies
    lors de l'exécution ou à la fin (p.ex. pile finale vide,
    variables finales non vides, etc). *)

Definition run (count:nat)(code : list instr) : option nat :=
  TODO.

Compute (run 1000 (compile test1)). (* attendu: Some 385 *)
Compute (run 1000 (compile test2)). (* attendu: Some 1705 *)

(** Equivalence entre sémantiques *)

(** TODO: dans cette partie, à vous de formuler les
    lemmes intermédiaires. *)

Lemma run_equiv code res :
 Run code res <-> exists count, run count code = Some res.
Proof.
Admitted.

(** Le theorème principal, formulé pour run *)

Theorem run_compile e :
 Closed e ->
 exists count, run count (compile e) = Some (eval nil e).
Proof.
Admitted.


From Coq Require Import ZArith Lia.
From Coq Require Import Int63.
From Coq Require Bool.

From EVM Require Import Arith2 UInt63 Nibble.

Definition uint64 := (bool * int)%type.
Definition t := uint64.

Local Open Scope Z_scope.

Definition Z_of_uint64 (a: uint64)
:= match a with
   | (false, n) => Int63.to_Z n
   | (true , n) => Int63.to_Z n + Int63.wB
   end.

Definition Z_of_uint64_lor (a: uint64)
:= match a with
   | (false, n) => Int63.to_Z n
   | (true , n) => Z.lor (Int63.to_Z n) Int63.wB
   end.

Lemma Z_of_uint64_lor_ok (a: uint64):
  Z_of_uint64_lor a = Z_of_uint64 a.
Proof.
unfold Z_of_uint64_lor.
destruct a as (b, n).
rewrite<- Arith2.Z_add_nocarry_lor. { trivial. }
apply Arith2.Z_land_pow2_small. { apply to_Z_bounded. }
apply Nat2Z.is_nonneg.
Qed.

Definition Z_of_uint64_lxor (a: uint64)
:= match a with
   | (false, n) => Int63.to_Z n
   | (true , n) => Z.lxor (Int63.to_Z n) Int63.wB
   end.

Lemma Z_of_uint64_lxor_ok (a: uint64):
  Z_of_uint64_lxor a = Z_of_uint64 a.
Proof.
unfold Z_of_uint64_lxor.
destruct a as (b, n).
rewrite<- Z.add_nocarry_lxor. { trivial. }
apply Arith2.Z_land_pow2_small. { apply to_Z_bounded. }
apply Nat2Z.is_nonneg.
Qed.

Lemma Z_of_uint64_lower (a: uint64):
  0 <= Z_of_uint64 a.
Proof.
destruct a as (hi, lo).
assert(B := Int63.to_Z_bounded lo).
destruct B as (L, H).
destruct hi; unfold Z_of_uint64; lia.
Qed.

Lemma Z_of_uint64_upper (a: uint64):
  Z_of_uint64 a < 2^64.
Proof.
destruct a as (hi, lo).
assert(B := Int63.to_Z_bounded lo).
destruct B as (_, H).
assert (E: Int63.wB = 2^63). { unfold Int63.wB. f_equal. }
destruct hi; unfold Z_of_uint64; lia.
Qed.

Definition Z_of_uint64' (a: uint64)
:= let (b, n) := a in
   Int63.to_Z n + (if b then 1 else 0) * Int63.wB.

Lemma Z_of_uint64_alt (a: uint64):
  Z_of_uint64' a = Z_of_uint64 a.
Proof.
unfold Z_of_uint64'. unfold Z_of_uint64.
destruct a as (b, n). destruct b; lia.
Qed.

Definition Z_of_uint64_lor' (a: uint64)
:= let (b, n) := a in
   Z.lor (Int63.to_Z n) ((if b then 1 else 0) * Int63.wB).

Lemma Z_of_uint64_lor'_ok (a: uint64):
  Z_of_uint64_lor' a = Z_of_uint64' a.
Proof.
unfold Z_of_uint64_lor'.
destruct a as (b, n).
rewrite<- Arith2.Z_add_nocarry_lor. { trivial. }
destruct b.
{
  rewrite Z.mul_1_l. apply Arith2.Z_land_pow2_small.
  { apply to_Z_bounded. } apply Nat2Z.is_nonneg.
}
rewrite Z.mul_0_l. rewrite Z.land_0_r. trivial.
Qed.

Definition uint64_of_Z (z: Z)
                        (lower: 0 <= z)
                        (upper: z < 2^64)
: uint64
:= (2^63 <=? z, Int63.of_Z z).

Lemma uint64_of_Z_of_uint64 (a: uint64):
  uint64_of_Z (Z_of_uint64 a) (Z_of_uint64_lower a) (Z_of_uint64_upper a) = a.
Proof.
assert (E: Int63.wB = 2^63). { unfold Int63.wB. f_equal. }
destruct a as (hi, lo).
assert(B := Int63.to_Z_bounded lo).
destruct hi; unfold Z_of_uint64; unfold uint64_of_Z.
{
  rewrite E. f_equal.
  { rewrite Z.leb_le. lia. }
  rewrite<- E. clear E.
  apply Int63.to_Z_inj. rewrite Int63.of_Z_spec.
  rewrite Z.add_comm.
  rewrite<- Zplus_mod_idemp_l.
  rewrite Z_mod_same_full.
  rewrite Z.add_0_l.
  remember (Int63.to_Z lo) as n. clear Heqn.
  exact (Z.mod_small _ _ B).
}
rewrite<- E.
f_equal. { rewrite Z.leb_gt. tauto. }
apply Int63.of_to_Z.
Qed.

Lemma Z_of_uint64_of_Z (z: Z)
                        (lower: 0 <= z)
                        (upper: z < 2^64):
  Z_of_uint64 (uint64_of_Z z lower upper) = z.
Proof.
assert (E: Int63.wB = 2^63). { unfold Int63.wB. f_equal. }
unfold Z_of_uint64. unfold uint64_of_Z.
remember (2 ^ 63 <=? z) as is_high.
rewrite Int63.of_Z_spec.
symmetry in Heqis_high.
destruct is_high.
{
  rewrite Z.leb_le in Heqis_high.
  rewrite E. clear E.
  remember (z - 2^63) as y.
  assert (YL: 0 <= y) by lia.
  assert (YU: y < 2^63) by lia.
  assert (R: z mod 2^63 = y mod 2^63).
  {
    subst.
    rewrite<- Zminus_mod_idemp_r.
    rewrite Z_mod_same_full.
    rewrite Z.sub_0_r.
    trivial.
  }
  rewrite R.
  rewrite (Z.mod_small _ _ (conj YL YU)).
  lia.
}
rewrite Z.leb_gt in Heqis_high.
apply Z.mod_small. tauto.
Qed.

Definition uint64_of_Z_mod (z: Z)
: uint64
:= (Z.testbit z 63, Int63.of_Z z).

Lemma uint64_mod_pos_bound (a: Z):
  0 <= a mod 2^64 < 2^64.
Proof.
apply Z.mod_pos_bound.
rewrite<- Z.ltb_lt.
trivial.
Qed.

Lemma uint64_of_Z_mod_ok (z: Z):
  uint64_of_Z_mod z = uint64_of_Z (z mod 2^64)
                                  (proj1 (uint64_mod_pos_bound z))
                                  (proj2 (uint64_mod_pos_bound z)).
Proof.
unfold uint64_of_Z. unfold uint64_of_Z_mod.
f_equal.
{
  rewrite<- (Z.mod_pow2_bits_low z 64 63) by now rewrite<- Z.ltb_lt.
  assert (B := uint64_mod_pos_bound z).
  remember (z mod 2 ^ 64) as x. clear Heqx.
  rewrite (Z.testbit_odd x 63).
  rewrite Z.shiftr_div_pow2 by now rewrite<- Z.leb_le.
  remember (2 ^ 63 <=? x) as f. symmetry in Heqf.
  destruct f.
  {
    rewrite Z.leb_le in Heqf.
    assert(L: 1 <= x / 2 ^ 63).
    {
      rewrite<- (Z.div_same (2^63)) by discriminate.
      apply Z.div_le_mono. { rewrite<- Z.ltb_lt. trivial. }
      assumption.
    }
    assert (U: x / 2^63 <= (2 ^ 64 - 1) / 2 ^ 63).
    {
      apply Z.div_le_mono. { rewrite<- Z.ltb_lt. trivial. }
      lia.
    }
    replace ((2 ^ 64 - 1) / 2 ^ 63) with 1 in U by trivial.
    assert (E: x / 2 ^ 63 = 1) by lia.
    now rewrite E.
  }
  rewrite (Logic2.b_false (Z.leb_le _ _)) in Heqf.
  apply Z.nle_gt in Heqf.
  replace (x / 2 ^ 63) with 0. 2:{ symmetry. apply Z.div_small. tauto. }
  trivial.
}
apply to_Z_inj.
repeat rewrite of_Z_spec.
apply Znumtheory.Zmod_div_mod; try rewrite<- Z.ltb_lt; trivial.
replace (2^64) with (2 * wB) by trivial.
apply Z.divide_factor_r.
Qed.

Lemma Z_of_uint64_of_Z_mod (z: Z):
  Z_of_uint64 (uint64_of_Z_mod z) = z mod 2^64.
Proof.
rewrite uint64_of_Z_mod_ok.
rewrite Z_of_uint64_of_Z.
trivial.
Qed.

Definition uint64_0: uint64 := (false, 0%int63).
Lemma uint64_0_ok:
  Z_of_uint64 uint64_0 = 0.
Proof. trivial. Qed.
Definition uint64_1: uint64 := (false, 1%int63).
Lemma uint64_1_ok:
  Z_of_uint64 uint64_1 = 1.
Proof. trivial. Qed.
Definition uint64_max_value: uint64 := (true, max_int).
Lemma uint64_max_value_ok:
  Z_of_uint64 uint64_max_value = 2^64 - 1.
Proof. trivial. Qed.

(*******************************************************************************)

Definition add (a b: uint64)
: uint64
:= let (ha, la) := a in
   let (hb, lb) := b in
   let x := xorb ha hb in
   match Int63.addc la lb with
   | DoubleType.C0 c => (x, c)
   | DoubleType.C1 c => (negb x, c)
   end.

Ltac wB_up
:= repeat (rewrite (Z.add_comm _ Int63.wB)
        || rewrite (Z.add_comm _ (_ * Int63.wB)));
   repeat rewrite Z.add_assoc;
   repeat rewrite<- Z.mul_add_distr_r.

Lemma mod_wB (x: Z):
  (x * Int63.wB) mod 2 ^ 64 = if Z.odd x then Int63.wB else 0.
Proof.
remember (Z.odd x) as last_bit.
rewrite (Zdiv2_odd_eqn x). subst.
rewrite Z.mul_add_distr_r.
replace (2 * Z.div2 x) with (Z.div2 x * 2) by apply Z.mul_comm.
rewrite<- Z.mul_assoc.
replace (2 * Int63.wB) with (2 ^ 64)%Z by trivial.
rewrite Z.add_comm. rewrite Z.mod_add by discriminate.
now destruct (Z.odd x).
Qed.

Lemma add_ok (a b: uint64):
  Z_of_uint64 (add a b) = ((Z_of_uint64 a + Z_of_uint64 b) mod 2^64).
Proof.
assert (L := Z_of_uint64_lower (add a b)).
assert (U := Z_of_uint64_upper (add a b)).
repeat rewrite<- Z_of_uint64_alt in *.
rewrite<- (Z.mod_small (Z_of_uint64' (add a b)) (2 ^ 64)) by tauto.
unfold add. destruct a as (ha, la). destruct b as (hb, lb).
assert (R := Int63.addc_spec la lb).
cbn in L. cbn in U.
unfold DoubleType.interp_carry in R.
remember (Int63.addc la lb) as x. clear Heqx.
unfold Z_of_uint64'.
destruct x;
  [rewrite R | try rewrite Z.mul_1_l in R;
               replace (Int63.to_Z i) with (Int63.to_Z la + Int63.to_Z lb + (-1) * Int63.wB) by lia];
  wB_up; wB_up; repeat rewrite<- Z.add_assoc;
  apply Z_mod_add_r;
  destruct ha, hb; rewrite mod_wB; trivial.
Qed.

(*******************************************************************************)

Definition shr_uint63 (a: uint64) (sh: uint63)
: uint64
:= if (sh == 0)%int63
     then a
     else let (hi, lo) := a in
       (false, if hi
                 then (((1 << 62) >> (sh - 1)) lor (lo >> sh))%int63
                 else lsr lo sh).

Lemma shr_uint63_ok (a: uint64) (sh: uint63):
  Z_of_uint64 (shr_uint63 a sh) = Z.shiftr (Z_of_uint64 a) (Int63.to_Z sh).
Proof.
unfold shr_uint63.
remember ((sh == 0)%int63) as sh0 eqn:Sh0. symmetry in Sh0. destruct sh0.
{ rewrite Int63.eqb_spec in Sh0. now subst. }
assert(BS := to_Z_bounded sh). remember (to_Z sh) as s.
assert(SPos: 0 < s).
{
  enough (s <> 0) by lia.
  intro H. subst.
  replace 0 with (to_Z 0) in H by trivial.
  apply to_Z_inj in H.
  apply eqb_spec in H.
  rewrite H in Sh0.
  discriminate.
}
destruct a as (hi, lo).
destruct hi; unfold Z_of_uint64.
2:{
  (* low case *)
  rewrite Int63.lsr_spec.
  rewrite Z.shiftr_div_pow2 by tauto.
  now subst.
}
(* high case *)
rewrite Int63.lor_spec'.
rewrite Int63.lsr_spec.
rewrite Int63.lsr_spec.
rewrite Int63.lsl_spec.
rewrite Int63.sub_spec.
replace (to_Z 1) with 1 by trivial.
replace (to_Z 62) with 62 by trivial.
rewrite<- Heqs.
clear Sh0 Heqs.
assert(BN := to_Z_bounded lo). remember (to_Z lo) as n. clear Heqn.
rewrite Z.mul_1_l. rewrite Z.shiftr_div_pow2 by tauto.
replace (2 ^ 62 mod wB) with (2 ^ 62) by trivial.
replace ((s - 1) mod wB) with (s - 1). 2:{ symmetry. apply Z.mod_small. lia. }
assert (CS: 64 <= s \/ s <= 63) by lia.
case CS; clear CS; intro CS.
{
  (* large shift, everything is 0 *)
  replace (n / 2 ^ s) with 0.
  2:{
    symmetry. apply Z.div_small.
    split. { tauto. }
    replace Int63.wB with (2 ^ 63) in * by trivial.
    apply (Z.lt_trans n (2^63) (2^s)). { tauto. }
    apply Z.pow_lt_mono_r; lia.
  }
  rewrite Z.lor_0_r.
  rewrite Z.div_small.
  2:{
    split. { lia. }
    apply Z.pow_lt_mono_r; lia.
  }
  rewrite Z.div_small. { trivial. }
  split. { lia. }
  apply (Z.lt_le_trans _ (2^64) (2^s)).
  { replace (2 ^ 64) with (wB + wB) by trivial. lia. }
  apply Z.pow_le_mono_r; lia.
}
replace (2 ^ 62 / 2 ^ (s - 1)) with (2 ^ 63 / 2 ^ s).
2:{
  replace (2 ^ 63) with (2 * (2 ^ 62)) by trivial.
  replace (2 ^ s) with ((2 ^ (1 + (s - 1)))) by now replace (1 + (s - 1)) with s by lia.
  rewrite Z.pow_add_r; try lia.
  rewrite Z.div_mul_cancel_l; try lia.
  apply Z.pow_nonzero; lia.
}
repeat rewrite<- Z.shiftr_div_pow2 by tauto.
rewrite<- Z.shiftr_lor.
f_equal.
rewrite<- Arith2.Z_add_nocarry_lor. { apply Z.add_comm. }
rewrite Z.land_comm.
apply Arith2.Z_land_pow2_small. { tauto. }
now rewrite<- Z.leb_le.
Qed.

(*******************************************************************************)

Definition shl_uint63 (a: uint64) (sh: uint63)
: uint64
:= if (sh == 0)%int63
     then a
     else let (hi, lo) := a in
       (get_digit lo (63 - sh), lsl lo sh).

Lemma shl_uint63_ok (a: uint64) (sh: uint63):
  Z_of_uint64 (shl_uint63 a sh) = (Z.shiftl (Z_of_uint64 a) (Int63.to_Z sh) mod 2^64)%Z.
Proof.
repeat rewrite<- Z_of_uint64_alt. repeat rewrite<- Z_of_uint64_lor'_ok.
unfold shl_uint63.
remember ((sh == 0)%int63) as sh0 eqn:Sh0. symmetry in Sh0. destruct sh0.
{
  rewrite Int63.eqb_spec in Sh0. subst. rewrite Z.shiftl_0_r.
  symmetry. apply Z.mod_small.
  rewrite Z_of_uint64_lor'_ok.
  rewrite Z_of_uint64_alt.
  split. { apply Z_of_uint64_lower. } apply Z_of_uint64_upper.
}
assert(BS := to_Z_bounded sh). remember (to_Z sh) as s.
assert(SPos: 0 < s).
{
  enough (s <> 0) by lia.
  intro H. subst.
  replace 0 with (to_Z 0) in H by trivial.
  apply to_Z_inj in H.
  apply eqb_spec in H.
  rewrite H in Sh0.
  discriminate.
}
destruct a as (hi, lo).
rewrite uint63_testbit_Z.
unfold Z_of_uint64_lor'.
rewrite Int63.lsl_spec.
apply Z.bits_inj'. intros k Knonneg.
rewrite Z.lor_spec.
rewrite<- Z.shiftl_mul_pow2 by now subst.
rewrite<- Heqs.
assert (BN := to_Z_bounded lo). remember (to_Z lo) as n.
rewrite Z.shiftl_lor.
replace wB with (2^63) by trivial.
repeat rewrite<- Z.land_ones.
rewrite Z.land_lor_distr_l.
replace (Z.land (Z.shiftl ((if hi then 1 else 0) * 2 ^ 63) s) (Z.ones 64)) with 0.
3-4: now rewrite<- Z.leb_le.
2:{
  destruct hi. 2:{ rewrite Z.mul_0_l. rewrite Z.shiftl_0_l. rewrite Z.land_0_l. trivial. }
  symmetry.
  rewrite Z.mul_1_l.
  rewrite Z.shiftl_mul_pow2 by tauto.
  rewrite Z.land_ones by now rewrite<- Z.leb_le.
  rewrite<- Z.pow_add_r; try lia.
  replace (2 ^ (63 + s)) with (2^(s - 1) * 2^64).
  2:{ rewrite<- Z.pow_add_r; try f_equal; lia. }
  apply Z_mod_mult.
}
rewrite Z.lor_0_r.
repeat rewrite Z.land_spec.
repeat rewrite Z.testbit_ones_nonneg; try lia.
remember (Z.testbit (Z.shiftl n s) k) as x.
assert (CK: k <> 63 \/ k = 63) by lia.
case CK; clear CK; intro CK.
{
  replace (Z.testbit ((if Z.testbit n (to_Z (63 - sh)%int63) then 1 else 0) * 2 ^ 63) k) with false.
  2:{
    symmetry.
    destruct (Z.testbit n (to_Z (63 - sh)%int63)); [ rewrite Z.mul_1_l | rewrite Z.mul_0_l ].
    { apply Z.pow2_bits_false. lia. }
    apply Z.bits_0.
  }
  rewrite Bool.orb_false_r.
  f_equal.
  rewrite Arith2.Z_ltb_lt_quad. split; lia.
}
subst k x.
replace (63 <? 63) with false by trivial.
replace (63 <? 64) with true by trivial.
rewrite Bool.andb_false_r. rewrite Bool.orb_false_l. rewrite Bool.andb_true_r.
rewrite Arith2.Z_testbit_flag_mul_pow2 by lia.
rewrite Z.shiftl_spec by lia.
rewrite sub_spec. replace (to_Z 63) with 63 by trivial.
rewrite<- Heqs.
assert (WB63: 63 < wB) by now rewrite<- Z.ltb_lt.
assert (Q: (63 - s) mod wB = 63 - s \/ 63 < (63 - s) mod wB).
{
  assert(B: -wB < 63 - s) by lia.
  assert(WBNZ: wB <> 0) by discriminate.
  assert(D := Z.div_mod (63 - s) wB WBNZ).
  assert(WBPos: 0 < wB) by lia.
  assert(BQ := Z.mod_pos_bound (63 - s) wB WBPos).
  remember ((63 - s) mod wB) as q.
  clear Heqq.
  assert (L: -1 <= (63 - s) / wB) by nia.
  assert (U: (63 - s) / wB <= 0) by nia.
  assert (T: (63 - s) / wB = 0 \/ (63 - s) / wB = -1) by lia.
  case T; clear T; intro T; lia.
}
case Q; clear Q; intro Q. { now rewrite Q. }
assert (S63: 63 < s).
{
  apply Z.nle_gt. intro H.
  replace ((63 - s) mod wB) with (63 - s) in *.
  2:{
    rewrite Z.mod_small. { trivial. }
    lia.
  }
  lia.
}
rewrite (Z.testbit_neg_r n (63 - s)) by lia.
apply Arith2.Z_testbit_small. { tauto. }
refine (Z.lt_trans n wB _ _ _). { tauto. }
replace wB with (2^63) by trivial.
apply Z.pow_lt_mono_r; try lia.
apply Z.mod_pos_bound.
trivial. apply Q.
Qed.

(*******************************************************************************)

Definition bitwise_or (a b: uint64)
: uint64
:= ((fst a || fst b)%bool,  Int63.lor (snd a) (snd b)).

Lemma bitwise_or_ok (a b: uint64):
  Z_of_uint64 (bitwise_or a b) = (Z.lor (Z_of_uint64 a) (Z_of_uint64 b)).
Proof.
repeat rewrite<- Z_of_uint64_lor_ok.
destruct a as (a_hi, a_lo).
destruct b as (b_hi, b_lo).
unfold Z_of_uint64_lor. unfold bitwise_or.
destruct a_hi, b_hi;
  match goal with
  |- (if ?cond then _ else _) = ?rhs  => remember cond as c; cbn in Heqc; subst
  end;
  repeat rewrite lor_spec';
  replace (snd (_, a_lo)) with a_lo by trivial;
  replace (snd (_, b_lo)) with b_lo by trivial;
  remember (to_Z a_lo) as x;
  remember (to_Z b_lo) as y;
  repeat rewrite Z.lor_assoc; trivial.
{
  (* goal: Z.lor (Z.lor x y) wB = Z.lor (Z.lor (Z.lor x wB) y) wB *)
  repeat rewrite<- Z.lor_assoc. f_equal.
  rewrite Z.lor_comm.
  rewrite Z.lor_assoc.
  now replace (Z.lor wB wB) with wB by trivial.
}
(* goal: Z.lor (Z.lor x y) wB = Z.lor (Z.lor x wB) y *)
repeat rewrite<- Z.lor_assoc. f_equal.
apply Z.lor_comm.
Qed.

(*******************************************************************************)

Definition bitwise_xor (a b: uint64)
: uint64
:= (xorb (fst a) (fst b),  Int63.lxor (snd a) (snd b)).

Lemma bitwise_xor_ok (a b: uint64):
  Z_of_uint64 (bitwise_xor a b) = (Z.lxor (Z_of_uint64 a) (Z_of_uint64 b)).
Proof.
repeat rewrite<- Z_of_uint64_lxor_ok.
destruct a as (a_hi, a_lo).
destruct b as (b_hi, b_lo).
unfold Z_of_uint64_lxor. unfold bitwise_xor.
destruct a_hi, b_hi;
  match goal with
  |- (if ?cond then _ else _) = ?rhs  => remember cond as c; cbn in Heqc; subst
  end;
  repeat rewrite lxor_spec';
  replace (snd (_, a_lo)) with a_lo by trivial;
  replace (snd (_, b_lo)) with b_lo by trivial;
  remember (to_Z a_lo) as x;
  remember (to_Z b_lo) as y;
  repeat rewrite Z.lxor_assoc; trivial.
{
  (* goal: Z.lxor x y = Z.lxor x (Z.lxor wB (Z.lxor y wB)) *)
  rewrite (Z.lxor_comm y wB). f_equal.
  rewrite<- Z.lxor_assoc.
  now replace (Z.lor wB wB) with wB by trivial.
}
f_equal. apply Z.lxor_comm.
Qed.

(*******************************************************************************)

Definition bitwise_and (a b: uint64)
: uint64
:= ((fst a && fst b)%bool,  Int63.land (snd a) (snd b)).

Lemma bitwise_and_ok (a b: uint64):
  Z_of_uint64 (bitwise_and a b) = (Z.land (Z_of_uint64 a) (Z_of_uint64 b)).
Proof.
repeat rewrite<- Z_of_uint64_lor_ok.
destruct a as (a_hi, a_lo).
destruct b as (b_hi, b_lo).
unfold Z_of_uint64_lor. unfold bitwise_and.
destruct a_hi, b_hi;
  match goal with
  |- (if ?cond then _ else _) = ?rhs  => remember cond as c; cbn in Heqc; subst
  end;
  repeat rewrite land_spec';
  replace (snd (_, a_lo)) with a_lo by trivial;
  replace (snd (_, b_lo)) with b_lo by trivial;
  remember (to_Z a_lo) as x;
  remember (to_Z b_lo) as y;
  repeat rewrite Z.land_assoc; trivial.
{ apply Z.lor_land_distr_l. }
{
  rewrite Z.land_lor_distr_l.
  replace (Z.land wB y) with 0. { now rewrite Z.lor_0_r. }
  symmetry. rewrite Z.land_comm. apply Arith2.Z_land_pow2_small.
  { subst. apply to_Z_bounded. }
  rewrite<- Z.leb_le. trivial.
}
rewrite Z.land_lor_distr_r.
replace (Z.land x wB) with 0. { now rewrite Z.lor_0_r. }
symmetry. apply Arith2.Z_land_pow2_small.
{ subst. apply to_Z_bounded. }
rewrite<- Z.leb_le. trivial.
Qed.

(*******************************************************************************)

Definition bitwise_not (a: uint64)
: uint64
:= (negb (fst a),  Int63.lxor (snd a) (of_Z (-1))).

Lemma bitwise_not_via_xor (a: uint64):
  bitwise_not a = bitwise_xor a uint64_max_value.
Proof.
trivial.
Qed.

Lemma bitwise_not_ok (a: uint64):
  Z_of_uint64 (bitwise_not a) = (Z.lnot (Z_of_uint64 a)) mod 2^64.
Proof.
rewrite bitwise_not_via_xor. rewrite bitwise_xor_ok.
rewrite<- Z.lxor_m1_r. rewrite<- Z.land_ones. 2: { now rewrite<- Z.leb_le. }
assert (L := Z_of_uint64_lower a).
assert (U := Z_of_uint64_upper a).
remember (Z_of_uint64 a) as x. clear Heqx.
rewrite uint64_max_value_ok.
replace (2 ^ 64 - 1) with (Z.ones 64) by trivial.
rewrite Z_land_lxor_distr_l.
f_equal.
symmetry. apply Z.land_ones_low. { assumption. }
apply Arith2.Z_log2_lt_pow2; try assumption.
now rewrite<- Z.ltb_lt.
Qed.

(*******************************************************************************)

Definition uint64_of_be_bytes (b: byte * byte * byte * byte * byte * byte * byte * byte)
: uint64
:= match b with
   | (b7, b6, b5, b4, b3, b2, b1, b0) =>
       bitwise_or (shl_uint63 (false, int_of_byte b7) 56%int63)
                  (false, ((int_of_byte b6 << 48) lor (int_of_byte b5 << 40) lor (int_of_byte b4 << 32)
                       lor (int_of_byte b3 << 24) lor (int_of_byte b2 << 16) lor (int_of_byte b1 << 8)
                       lor int_of_byte b0)%int63)
   end.

Definition uint64_to_be_bytes (a: uint64)
: byte * byte * byte * byte * byte * byte * byte * byte
:= let (f, i) := a in
    (byte_of_int (snd (shr_uint63 a 56)),
     byte_of_int (i >> 48),
     byte_of_int (i >> 40),
     byte_of_int (i >> 32),
     byte_of_int (i >> 24),
     byte_of_int (i >> 16),
     byte_of_int (i >> 8),
     byte_of_int i)%int63.

Definition uint64_to_le_bytes (a: uint64)
: byte * byte * byte * byte * byte * byte * byte * byte
:= let (f, i) := a in
    (byte_of_int i,
     byte_of_int (i >> 8),
     byte_of_int (i >> 16),
     byte_of_int (i >> 24),
     byte_of_int (i >> 32),
     byte_of_int (i >> 40),
     byte_of_int (i >> 48),
     byte_of_int (snd (shr_uint63 a 56)))%int63.


Require Import Arith Sorted Permutation List DivConq msort.
Import List.ListNotations.
Open Scope list_scope.

Require Extraction.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.

Extraction Language OCaml.
Set Extraction AccessOpaque.

Definition sorted := Sorted le.
Definition permutation := @Permutation nat.

Section PermSplitPivot.

Variable A : Type.
Variable le: A -> A -> Prop.
Variable le_dec: forall (x y: A), {le x y} + {~le x y}.
Implicit Type l : list A.

Lemma Permutation_split_pivot: forall (a : A) l,
  Permutation (fst (split_pivot A le le_dec a l)
    ++ snd (split_pivot A le le_dec a l)) l.
Proof.
induction l; simpl; auto.
destruct (split_pivot A le le_dec a l); simpl in *.
destruct (le_dec a0 a); simpl; auto;
rewrite <- Permutation_middle; constructor; auto.
Defined.

End PermSplitPivot.

Lemma qsort_prog :
  forall (l : list nat), {l' : list nat | sorted l' /\ permutation l' l}.
Proof.
unshelve eapply div_conq_pivot. exact le. exact le_dec.
- exists []; split; constructor.
- intros; destruct H,H0,a0,a1; exists (merge x (a :: x0)); split.
  + apply merge_sorted; auto; constructor; auto.
    assert (Forall (le a) x0).
    eapply Permutation_Forall. apply Permutation_sym; apply H2.
    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.

Extraction "extraction/qsort.ml" qsort_prog.


Require Export P05.

(** **** Exercise: 4 stars, advanced (ev_alternate)  *)
(** In general, there may be multiple ways of defining a
    property inductively.  For example, here's a (slightly contrived)
    alternative definition for [ev]: *)

(*
Inductive ev' : nat -> Prop :=
| ev'_0 : ev' 0
| ev'_2 : ev' 2
| ev'_sum : forall n m, ev' n -> ev' m -> ev' (n + m).
*)

(** Prove that this definition is logically equivalent to
    the old one. *)

Theorem ev'_ev : forall n, ev' n <-> ev n.
Proof.
  intros n. split.
  - intros H. induction H.
    + constructor.
    + repeat constructor.
    + apply ev_sum; assumption.
  - intros H. induction H.
    + constructor.
    + apply ev'_sum with (n := 2) (m := n). constructor. assumption.
Qed.