(** * 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,-deprecated-hint-without-locality".
From LF 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 chapter, we've been working with lists
    containing just numbers.  Obviously, interesting programs also
    need to be able to manipulate lists with elements from other
    types -- 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
  | bool_cons (b : bool) (l : 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.) and all
    their properties ([rev_length], [app_assoc], 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
  | cons (x : X) (l : 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 function header on the first line,
    and the occurrences of [natlist] in the types of the constructors
    have been replaced by [list X].

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

Check list : Type -> Type.

(** The [X] in the definition of [list] automatically becomes a
    parameter to the constructors [nil] and [cons] -- that is, [nil]
    and [cons] are now polymorphic constructors; when we use them, we
    must now provide a first argument that is the type of the list
    they are building. For example, [nil nat] constructs the empty
    list of type [nat]. *)

Check (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)) : 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 : 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 : forall X : Type, X -> list X -> list X.

(** (A side note on notations: In .v files, the "forall"
    quantifier is spelled out in letters.  In the corresponding HTML
    files (and in the way some IDEs show .v files, depending on the
    settings of their display controls), [forall] is usually typeset
    as the standard mathematical "upside down A," though 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 every single use of a
    list constructor would be rather burdensome; we will soon see ways
    of reducing this annotation burden. *)

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

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

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

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

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

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

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

(** **** Exercise: 2 stars, standard, optional (mumble_grumble)

    Consider the following two inductively defined types. *)

Module MumbleGrumble.

Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.

Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?  (Add YES or NO to each line.)
      - [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 [repeat] again, but this time we
    won't specify the types of any of the arguments.  Will Coq still
    accept it? *)

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

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

Check repeat'
  : forall X : Type, X -> nat -> list X.
Check repeat
  : forall X : Type, X -> nat -> list X.

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

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations can still be quite useful as documentation and sanity
    checks, so we will continue to use them much of the time. *)

(* ----------------------------------------------------------------- *)
(** *** 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 a "hole" [_], 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 -- and, 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 holes

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

    to tell Coq to attempt to infer the missing information.

    Using holes, 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
    this... *)

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

(** ...we can use holes to write this: *)

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

(* ----------------------------------------------------------------- *)
(** *** Implicit Arguments *)

(** In fact, 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 the (leading) argument names to be
    treated as implicit, each surrounded by curly braces. *)

Arguments nil {X}.
Arguments cons {X}.
Arguments repeat {X}.

(** Now we don't have to supply any type arguments at all in the example: *)

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, because Coq is not expecting it.)

    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'
  | cons' (x : X) (l : 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, once in a while, 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 : forall X : Type, list X.

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, standard (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.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity. Qed.

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

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

(** **** Exercise: 2 stars, standard (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.
  induction l1.
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1. rewrite app_assoc. reflexivity. Qed.

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

(* ================================================================= *)
(** ** Polymorphic Pairs *)

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

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : 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_ (i.e., the types of pairs): *)

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

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should only be used when parsing types, not when parsing
    expressions.  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, standard, 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, standard (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 => (nil, nil)
  | z :: t => ((fst z :: fst (split t)), (snd z :: snd (split t)))
  end.

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

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

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

Module OptionPlayground.

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

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

End OptionPlayground.

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

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  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, standard, 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
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

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

Check @hd_error : forall X : Type, list X -> option X.

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 most modern programming languages -- especially other
    "functional" languages, including OCaml, Haskell, Racket, 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 : 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 [even]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

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

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (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 odd 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 => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

(** **** Exercise: 2 stars, standard (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 even (filter (fun n => eqb 0 (minus 8 n)) l) .

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
  reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
  reflexivity. Qed.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (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 predicate 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 => match (test x) with
                  | false => true
                  | true => false
                  end) l).

Example test_partition1: partition odd [1;2;3;4;5] = ([1;3;5], [2;4]).
reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
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 odd [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 => [even n;odd n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

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

(** **** Exercise: 3 stars, standard (map_rev)

    Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Lemma map_dist : forall (X Y : Type) (f : X -> Y) (l k : list X),
  map f (l ++ k) = map f l ++ map f k.
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity. Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite map_dist. simpl. rewrite IHl. reflexivity.  Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (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
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

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 for which [map] makes sense.
    Here is a [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, standard, 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) : 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, standard, optional (fold_types_different)

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

(* FILL IN HERE

    [] *)

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

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, standard (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].  (Hint: It may help to
    know that [reflexivity] simplifies expressions a bit more
    aggressively than [simpl] does -- i.e., you may find yourself in a
    situation where [simpl] does nothing but [reflexivity] solves the
    goal.) *)

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

(** **** Exercise: 3 stars, standard, optional (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 z => cons (f z) ) l nil.

(** Write down a theorem [fold_map_correct] in Coq stating that
    [fold_map] is correct, and prove it.  (Hint: again, remember that
    [reflexivity] simplifies expressions a bit more aggressively than
    [simpl].) *)

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

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

(** **** Exercise: 2 stars, advanced (currying)

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

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

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

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

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

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** 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.
  (* 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 n =? O then Some a else nth_error l' (pred n)
     end.

   Write a careful informal proof of the following theorem:

   forall X l n, length l = n -> @nth_error X l n = None

   Make sure to state the induction hypothesis _explicitly_.
*)
(* FILL IN HERE *)

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

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

Module Church.
Definition cnat := 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 : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

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

Definition two : cnat :=
  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 : cnat :=
  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 : cnat := @doit3times.

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

(** **** Exercise: 1 star, advanced (church_succ) *)

(** Successor of a natural number: given a Church numeral [n],
    the successor [succ n] is a function that iterates its
    argument once more than [n]. *)
Definition succ (n : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

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.

(** [] *)

(** **** Exercise: 1 star, advanced (church_plus) *)

(** Addition of two natural numbers: *)
Definition plus (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

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.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_mult) *)

(** Multiplication: *)
Definition mult (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

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.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_exp) *)

(** 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.  Iterating over [cnat] itself is usually problematic.) *)

Definition exp (n m : cnat) : cnat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

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

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

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

(** [] *)

End Church.
End Exercises.

(* 2022-01-20 13:18 *)


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * matrix_ext: additional properties of matrices *)

Require Import kleene normalisation ordinal sups.
Require Export matrix.
Set Implicit Arguments.

(** * [mx_scal] is an homomorphism  *)

Instance mx_scal_leq `{lattice.laws}: Proper (leq ==> leq) (@mx_scal X).
Proof. intros ? ? H'. apply H'. Qed.
Instance mx_scal_weq `{lattice.laws}: Proper (weq ==> weq) (@mx_scal X) := op_leq_weq_1.

Lemma mx_scal_zer `{lattice.laws}: mx_scal bot == bot.
Proof. reflexivity.  Qed.

Lemma mx_scal_one `{laws} n: mx_scal 1 == one n.
Proof. reflexivity.  Qed.

Lemma mx_scal_pls `{lattice.laws} (M N: mx X 1 1):
  mx_scal (M \cup N) == mx_scal M \cup mx_scal N.
Proof. reflexivity.  Qed.

Lemma mx_scal_dot `{laws} `{BOT+CUP<<l} u (M N: mx (X u u) 1 1):
  mx_scal (M * N) == mx_scal M * mx_scal N.
Proof. apply cupxb. Qed.

Lemma mx_scal_str `{laws} `{BKA<<l} u (M: mx (X u u) 1 1):
  mx_scal (M^*) == mx_scal M ^*.
Proof.
  apply str_weq. unfold mx_scal, sub00_mx, tsub_mx, lsub_mx. simpl.
  setoid_rewrite ord0_unique. apply cupxb.
Qed.

(** * [scal_mx] preserves inclusions/equalities  *)

Instance scal_mx_leq `{lattice.laws}: Proper (leq ==> leq) (@scal_mx X).
Proof. now repeat intro. Qed.
Instance scal_mx_weq `{lattice.laws}: Proper (weq ==> weq) (@scal_mx X) := op_leq_weq_1.

(** * extracting components of block matrices *)

Lemma mx_tsub_col `{lattice.laws} n1 n2 m M1 M2:
  tsub_mx (@col_mx X n1 n2 m M1 M2) == M1.
Proof. intros i j. unfold tsub_mx, col_mx. now rewrite split_lshift. Qed.
Lemma mx_bsub_col `{lattice.laws} n1 n2 m M1 M2:
  bsub_mx (@col_mx X n1 n2 m M1 M2) == M2.
Proof. intros i j. unfold bsub_mx, col_mx. now rewrite split_rshift. Qed.
Lemma mx_lsub_row `{lattice.laws} n m1 m2 M1 M2:
  lsub_mx (@row_mx X n m1 m2 M1 M2) == M1.
Proof. intros i j. unfold lsub_mx, row_mx. now rewrite split_lshift. Qed.
Lemma mx_rsub_row `{lattice.laws} n m1 m2 M1 M2:
  rsub_mx (@row_mx X n m1 m2 M1 M2) == M2.
Proof. intros i j. unfold rsub_mx, row_mx. now rewrite split_rshift. Qed.

Lemma mx_sub00_blk `{lattice.laws} n1 n2 m1 m2 a b c d:
  sub00_mx (@blk_mx X n1 n2 m1 m2 a b c d) == a.
Proof. setoid_rewrite mx_tsub_col. apply mx_lsub_row. Qed.
Lemma mx_sub01_blk `{lattice.laws} n1 n2 m1 m2 a b c d:
  sub01_mx (@blk_mx X n1 n2 m1 m2 a b c d) == b.
Proof. setoid_rewrite mx_tsub_col. apply mx_rsub_row. Qed.
Lemma mx_sub10_blk `{lattice.laws} n1 n2 m1 m2 a b c d:
  sub10_mx (@blk_mx X n1 n2 m1 m2 a b c d) == c.
Proof. setoid_rewrite mx_bsub_col. apply mx_lsub_row. Qed.
Lemma mx_sub11_blk `{lattice.laws} n1 n2 m1 m2 a b c d:
  sub11_mx (@blk_mx X n1 n2 m1 m2 a b c d) == d.
Proof. setoid_rewrite mx_bsub_col. apply mx_rsub_row. Qed.

(** sub-matrices of the empty matrix are empty *)
Lemma blk_mx_0 `{laws} u n1 n2 m1 m2 a b c d: @blk_mx (X u u) n1 n2 m1 m2 a b c d == 0 ->
  a==0 /\ b==0 /\ c==0 /\ d==0.
Proof.
  intro Z. split; [|split; [|split]].
  rewrite <-(mx_sub00_blk a b c d). intros ? ?. apply Z.
  rewrite <-(mx_sub01_blk a b c d). intros ? ?. apply Z.
  rewrite <-(mx_sub10_blk a b c d). intros ? ?. apply Z.
  rewrite <-(mx_sub11_blk a b c d). intros ? ?. apply Z.
Qed.

(** * Kleene star of a block matrix *)
Section h.
Context `{L:laws} `{Hl:BKA<<l} (u: ob X).

Local Instance mx_bka_laws: laws BKA (mx_ops X u) := mx_laws (L:=lower_laws) _.

Lemma mx_str_blk' n m (M: mx (X u u) (n+m) (n+m)):
  M^* == mx_str_build X u n m (mx_str _ _ _) (mx_str _ _ _) M.
Proof.
  apply str_unique'.
   apply mx_str_build_unfold_l; apply mx_str_unfold_l.
   apply mx_str_build_ind_l; intros ? ? ?; apply mx_str_ind_l.
Qed.

(** general result *)
Lemma mx_str_blk n1 n2
  (a: mx (X u u) n1 n1) (b: mx (X u u) n1 n2)
  (c: mx (X u u) n2 n1) (d: mx (X u u) n2 n2):
  let e := d^* in
  let f := (a+(b*e)*c)^* in
  blk_mx a b c d ^* == blk_mx f (f*(b*e)) ((e*c)*f) (e+(e*c*f)*(b*e)).
Proof.
  intros e f. rewrite mx_str_blk'. unfold mx_str_build.
  ra_fold (mx_ops X). now rewrite mx_sub00_blk, mx_sub01_blk, mx_sub10_blk, mx_sub11_blk.
Qed.

(** specialisation to trigonal block matrices *)
Lemma mx_str_trigonal n1 n2
  (a: mx (X u u) n1 n1) (b: mx (X u u) n1 n2)
                        (d: mx (X u u) n2 n2):
  blk_mx a b 0 d ^* == blk_mx (a^*) (a^**(b*d^*)) 0 (d^*).
Proof. rewrite mx_str_blk. apply blk_mx_weq; ra. Qed.

(** and to diagonal block matrices *)
Lemma mx_str_diagonal n1 n2
  (a: mx (X u u) n1 n1) (d: mx (X u u) n2 n2):
  blk_mx a 0 0 d ^* == blk_mx (a^*) 0 0 (d^*).
Proof. rewrite mx_str_trigonal. apply blk_mx_weq; trivial; ra. Qed.

Lemma mx_str_1 (M: mx (X u u) 1 1): M^* == scal_mx (mx_scal M ^*).
Proof.
  intros i j. setoid_rewrite ord0_unique. simpl.
  unfold mx_str_build, blk_mx, col_mx, row_mx, ordinal.split; simpl.
  unfold mx_scal, scal_mx, mx_dot, sub00_mx, tsub_mx, lsub_mx; simpl.
  setoid_rewrite ord0_unique. ra.
Qed.

(** * induction schemes for proving properties of the Kleene star of a matrix *)
(** (used to show that epsilon and derivatives commute with matrix star in [rmx]) *)

Lemma mx_str_ind (P: forall n, mx (X u u) n n -> mx (X u u) n n -> Prop):
  (forall n, Proper (weq ==> weq ==> iff) (P n)) ->
  (forall M, P O M M) ->
  (forall M, P _ M (scal_mx (mx_scal M ^*))) ->
  (forall n m,
    (forall M, P n M (M^*)) ->
    (forall M, P m M (M^*)) ->
     forall M, P _ M (mx_str_build _ _ n m (fun M => M^*) (fun M => M^*) M)) ->
  forall n M, P n M (M^*).
Proof.
  intros HP HO H1 Hplus n M. induction n as [|n IHn].
   apply HO.
   change (M^*) with (mx_str _ _ _ M). unfold mx_str, mx_str_build. ra_fold (mx_ops X).
   setoid_rewrite <-mx_str_1.
   revert M; refine (Hplus (S O) n _ _); intro M.
   rewrite mx_str_1. apply H1.
   apply IHn.
Qed.

Lemma mx_str_ind' (P: forall n, mx (X u u) n n -> mx (X u u) n n -> Prop):
  (forall n, Proper (weq ==> weq ==> iff) (P n)) ->
  (forall M, P O M M) ->
  (forall M, P _ M (scal_mx (mx_scal M ^*))) ->
  (forall n m a b c d,
    let e := d^* in
    let be := b*e in
    let ec := e*c in
    let f := (a+be*c)^* in
    let fbe := f*be in
    let ecf := ec*f in
    P m d e ->
    P n (a+be*c) f ->
    P _ (blk_mx a b c d) (blk_mx f fbe ecf (e+ecf*be))) ->
  forall n M, P n M (M^*).
Proof.
  intros HP HO H1 Hplus. apply (mx_str_ind P HP HO H1).
  intros n m Hn Hm M. rewrite (to_blk_mx M) at 1. now apply Hplus.
Qed.

End h.

(** * pointwise extension of a funcion to matrices *)

Definition mx_map X Y (f: X -> Y) n m (M: mx X n m): mx Y n m := fun i j => f (M i j).

Instance mx_map_leq {X Y: lattice.ops} {f: X -> Y}
  {Hf: Proper (leq ==> leq) f} n m: Proper (leq ==> leq) (@mx_map _ _ f n m).
Proof. intros M N H i j. apply Hf, H. Qed.

Instance mx_map_weq {X Y: lattice.ops} {f: X -> Y}
  {Hf: Proper (weq ==> weq) f} n m: Proper (weq ==> weq) (@mx_map _ _ f n m).
Proof. intros M N H i j. apply Hf, H. Qed.

Lemma mx_map_blk {X Y l} {HY: lattice.laws l Y} (f: X -> Y) n1 n2 m1 m2 a b c d:
  mx_map f (@blk_mx _ n1 n2 m1 m2 a b c d) ==
  blk_mx (mx_map f a) (mx_map f b) (mx_map f c) (mx_map f d).
Proof.
  intros i j. unfold mx_map, blk_mx, col_mx, row_mx.
  case split; case split; reflexivity.
Qed.

Lemma mx_map_scal {X Y} (f: X -> Y) x: mx_map f (scal_mx x) = scal_mx (f x).
Proof. reflexivity. Qed.

Lemma scal_mx_map {X} {Y: lattice.ops} (f: X -> Y) M: f (mx_scal M) = mx_scal (mx_map f M).
Proof. reflexivity. Qed.

(** * `functional' matrices, with exactly one [z] per line, and [0] everywhere else *)

Definition mx_fun {X: lattice.ops} n m f z: mx X n m :=
  fun x y => if eqb_ord y (f x) then z else bot.

Lemma mx_dot_fun `{laws} `{BSL<<l} u n m f z p (M: mx (X u u) m p) i j:
  (mx_fun (n:=n) f z * M) i j == z * M (f i) j.
Proof.
  simpl. unfold mx_dot. apply antisym.
  apply leq_supx. intros j' _. unfold mx_fun. case eqb_ord_spec.
   intros ->. ra.
   intros _. ra.
  rewrite <- (leq_xsup _ _ (f i)). 2: apply in_seq.
  unfold mx_fun. now rewrite eqb_refl.
Qed.

Lemma mx_dot_kfun1 `{laws} `{BSL<<l} u n m i p (M: mx (X u u) m p):
  (mx_fun (n:=n) (fun _ => i) 1 * M) == fun _ j => M i j.
Proof. intros j k. rewrite mx_dot_fun. apply dot1x. Qed.

Lemma mx_map_fun {X Y: lattice.ops} {l} {HY: lattice.laws l Y} n m f z g:
  g bot == bot -> mx_map g (@mx_fun X n m f z) == @mx_fun Y n m f (g z).
Proof. intros Hg i j. unfold mx_map, mx_fun. now case eqb_ord. Qed.


(* Classical関連の切り出し *)

(* 古典論理における書き換えをiffにして、rewriteで使えるようにしている *)

From mathcomp Require Import ssreflect.

Require Export Classical_Prop.

Lemma not_or_and: forall P Q, ~ (P \/ Q) <-> ~ P /\ ~ Q.
Proof.
move=> P Q.
split.
- by apply not_or_and.
- by apply and_not_or.
Qed.

Lemma not_and_or: forall P Q, ~ (P /\ Q) <-> ~ P \/ ~Q.
Proof.
move=> P Q.
split.
- by apply not_and_or.
- by apply or_not_and.
Qed.

Lemma not_imply: forall P Q: Prop, ~ (P -> Q) <-> P /\ ~Q.
Proof.
move=> P Q.
split => H.
- by apply imply_to_and.
- inversion H => HPQ.
  by apply /H1 /HPQ.
Qed.

Lemma not_iff: forall P Q, ~ (P <-> Q) <-> (~P /\ Q) \/ (P /\ ~Q).
Proof.
move=> P Q.
rewrite {2}/iff.
rewrite not_and_or.
rewrite 2!not_imply.
by rewrite or_comm {1}and_comm.
Qed.

Lemma forall_iff_not_exists_not: forall {A} (F: A -> Prop),
  (forall x: A, F x) <-> ~ (exists x: A, ~ F x).
Proof.
move=> A F.
split.
- move=> Hforall.
  case => x Hnot.
  by move: (Hforall x).
- move=> Hexists x.
  apply NNPP => Hnot.
  apply Hexists.
  by exists x.
Qed.

Lemma exists_iff_not_forall_not: forall {A} (F: A -> Prop),
  (exists x: A, F x) <-> ~ (forall x: A, ~ F x).
Proof.
move=> A F.
split.
- move=> Hexists Hforall.
  move: Hexists.
  case => x HF.
  by move: (Hforall x).
- move=> Hforall.
  apply NNPP => Hexists.
  apply Hforall => x HF.
  apply Hexists.
  by exists x.
Qed.


(*|
####################################################
SF Volume 1: Logic: How to prove ``tr_rev <-> rev``?
####################################################

:Link: https://stackoverflow.com/q/69360955
|*)

(*|
Question
********

From Software Foundations Volume 1, chapter Logic we see a tail
recursive definition of list reversal. It goes like so:

.. coq:: none
|*)

Require Import Lists.List Logic.FunctionalExtensionality.
Import ListNotations.

(*||*)

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X} (l : list X) : list X :=
  rev_append l [].

(*|
We're, then, asked to prove the equivalence of ``tr_rev`` and ``rev``
which, well, is pretty obvious that they are the same. I'm having a
hard time completing the induction, though. Would appreciate if the
community would provide any hints as to how to approach this case.

Here's as far as I got:
|*)

Theorem tr_rev_correct : forall X, @tr_rev X = @rev X.
Proof.
  intros X. (* Introduce the type *)
  apply functional_extensionality. (* Apply extensionality axiom *)
  intros l. (* Introduce the list *)
  induction l as [| x l']. (* start induction on the list *)
  - reflexivity. (* base case for the empty list is trivial *)
  - (* inductive case seems simple too. We unfold the definition *)
    unfold tr_rev. simpl. (* simplify it *)
    unfold tr_rev in IHl'. (* unfold definition in the Hypothesis *)
    rewrite <- IHl'. (* .unfold *) (* rewrite based on the hypothesis *)
Abort. (* .none *)

(*|
Now, ``[] ++ [x]`` is obviously the same as ``[x]`` but ``simpl``
can't simplify it and I couldn't come up with a ``Lemma`` that would
help me here. I *did* prove ``app_nil_l`` (i.e. ``forall (X : Type) (x
: X) (l : list X), [] ++ [x] = [x]``) but when I try to rewrite with
``app_nil_l`` it'll rewrite both sides of the equation.

I could just define that to be an axiom, but I feel like that's
cheating :-p

Thanks
|*)

(*|
Answer
******

Proving things about definitions with accumulators has a specific
trick to it. The thing is, facts about ``tr_rev`` must necessarily be
facts about ``rev_append``, but ``rev_append`` is defined on two
lists, while ``tr_rev`` is defined on only one. The computation of
``rev_append`` depends on these two lists, and thus the induction
hypothesis needs to be general enough to include both of these lists.
However, if you fix the second input of ``rev_append`` to always be
the empty list (which you implicitly do by stating your result only
for ``tr_rev``), then the induction hypothesis will always be too
weak.

The way around this is to first prove a general result for
``rev_append`` by induction on ``l1`` (and generalizing on ``l2``),
and then specializing this result for the case of ``tr_rev``.
|*)


(*This file contains the proof that if we reduce a formula F to a graph G,
**and G is colorable, then F is satisfiable under valid environments*)
Require Import ThreeSatReduction.

(*collect the free variables of a graph*)
Fixpoint graphFVs G :=
  match G with
    |emptyGraph => []
    |newEdge u v G => u::v::graphFVs G
    |gunion G1 G2 => graphFVs G1 ++ graphFVs G2
  end.

(*solve a goal of the form In ?x ?y*)
Ltac solveIn :=
  match goal with
      | |- In ?x (?a ++ ?b) => rewrite in_app_iff;
                            solve[left; solveIn|right; solveIn]
      | |- In ?a ?b \/ In ?c ?d => simpl in *; solve[left; solveIn | right; solveIn]
      | |- In ?a (?b::?c) => simpl; solve[left; auto|right; solveIn]
      | |- _ => eauto
  end.

(*color a graph with a smaller environment if the part being removed
**does not occur free in the graph being colored*)
Theorem colorStrengthening : forall eta1 eta2 i c j K Gamma C eta G,
                               setVertices Gamma C 0 eta1 eta ->
                               setCs eta1 i K eta2 eta ->
                               coloring (eta1++(j,c)::eta2) G C ->
                               ~ In j (graphFVs G) ->
                               coloring (eta1++eta2) G C.
Proof.
  intros. remember (eta1++(j,c)::eta2). induction H1.
  {constructor. }
  {simpl in H2. subst. rewrite in_app_iff in H1. rewrite in_app_iff in H3.
   inv H1; inv H3.
   {econstructor; try solveIn; try omega. eapply IHcoloring; eauto. }
   {econstructor; try solveIn; try omega. simpl in H1. inv H1. invertTupEq.
    exfalso. apply H2. auto. solveIn. apply IHcoloring; auto. }
   {simpl in H8. inv H8. invertTupEq. exfalso. apply H2. auto.
    econstructor; try solveIn. apply IHcoloring; auto. }
   {simpl in *. inv H8. invertTupEq. exfalso. apply H2. auto. inv H1. invertTupEq.
    exfalso. apply H2. auto. econstructor; try solveIn. apply IHcoloring; auto. }
  }
  {constructor. apply IHcoloring1; auto. intros contra. apply H2. simpl.
   solveIn. apply IHcoloring2; auto. intros contra. apply H2. simpl. solveIn. }
Qed.

Theorem notInDistribute : forall (A:Type) (x:A) L1 L2, ~ In x L1 -> ~ In x L2 ->
                                                  ~ In x (L1++L2).
Proof. intros. rewrite in_app_iff. rewrite notDistr. auto.
Qed.

(*If a mapping from u_i to its vertex variables is in Gamma, then x_i is less than the length of Gamma + i*)
Theorem inGammaLT : forall Gamma C i eta eta' u, In (u,3*u,3*u+1,3*u+2) Gamma -> setVertices Gamma C i eta' eta ->
                                         3 * u + 2 < 3 * (length Gamma + i).
Proof.
  intros. induction H0.
  {inv H.
   {invertTupEq. simpl. omega. }
   {eapply IHsetVertices in H2. simpl. omega. }
  }
  {inv H.
   {invertTupEq. simpl. omega. }
   {eapply IHsetVertices in H2. simpl. omega. }
  }
  {inv H. }
Qed.

(*if j is less than the convert_base index, then j is not in the free variables of G*)
Theorem notInConvertBase : forall Gamma Delta i G j eta C eta',
                             setVertices Gamma C 0 eta' eta -> j < i -> j >= 3 * length Gamma ->
                             convert_base Gamma Delta i G ->
                             ~ In j (graphFVs G).
Proof.
  intros. induction H2.
  {intros c. inv c. }
  {simpl. repeat rewrite notDistr; repeat split; try omega.
   eapply inGammaLT in H2; eauto; simpl in *. repeat rewrite plus_0_r in *.
   apply lt_le_trans with(p:=j) in H2; auto. omega.
   eapply inGammaLT in H2; eauto. simpl in *. repeat rewrite plus_0_r in *.
   apply lt_le_trans with(p:=j) in H2; auto. omega. auto. }
Qed.

(*if j is less than the convStack index and greater than everything in Gamma, then it
**is not in the free variables of G*)
Theorem notInFV : forall Gamma C eta1 eta Delta G j K i eta2,
                    setVertices Gamma C 0 eta1 eta -> setCs eta1 i K eta2 eta ->
                    j >= 3 * length Gamma -> j < i -> convStack i Gamma Delta K G -> ~ In j (graphFVs G).
Proof.
  intros. genDeps {{ j; eta; eta1; eta2 }}. induction H3; intros.
  {intros c. inv c. }
  {simpl. apply notInDistribute. inv H1; eapply IHconvStack; eauto;
   rewrite plus_comm; eauto. destruct F. destruct p. inv H. simpl.
   destruct e1. destruct e2. destruct e3. simpl.
   repeat rewrite notDistr; repeat split. inv H12; omega. eapply inGammaLT in H8; eauto.
   inv H12. simpl in *. repeat rewrite plus_0_r in H8. rewrite plus_0_r in H2.
   assert(3*u+2 < j). simpl. rewrite plus_0_r. eapply lt_le_trans with(p:=j) in H8. Focus 2.
   auto. auto. omega. simpl in *. eapply lt_le_trans with (p:=j) in H8. Focus 2.
   repeat rewrite plus_0_r in *. auto. omega. inv H18; omega. eapply inGammaLT in H9; eauto. inv H18;
   eapply lt_le_trans with (p:=j) in H9; simpl in *; repeat rewrite plus_0_r in *; auto;
   omega. inv H20; omega. eapply inGammaLT in H10; eauto.
   inv H20; eapply lt_le_trans with (p:=j) in H10; simpl in *; repeat rewrite plus_0_r in *; auto; omega.
   eapply notInConvertBase; eauto. }
Qed.

(*If F reduces to G and G is colorable, then F is satisfiable*)
Theorem colorImpliesSAT : forall Gamma C eta eta' i U eta'' Delta F G,
                            setVertices Gamma C 0 eta' eta -> setCs eta' i F eta'' eta ->
                            coloring (eta'++eta'') G C -> i >= 3 * length Gamma ->
                            unique U Delta ->
                            convStack i Gamma Delta F G -> SAT' eta F.
Proof.
  intros. genDeps {{ U; eta; eta'; eta''; C }}. induction H4; intros.
  {constructor. }
  {destruct F. destruct p. inv H3.
   {inv H13.
    {constructor. left. constructor. auto. eapply IHconvStack. omega. Focus 3.
     rewrite plus_comm. eauto. Focus 3. eauto. Focus 2. eauto.
     eapply colorStrengthening; eauto. inv H1. eauto. eapply notInFV; eauto.
     rewrite plus_comm in H4. eauto. }
    {constructor. left. constructor. auto. eapply IHconvStack. Focus 4.
     rewrite plus_comm. eauto. Focus 3. eauto. Focus 2. eauto.
     eapply colorStrengthening; eauto. inv H1. eauto. eapply notInFV; eauto.
     rewrite plus_comm in H4. eauto. omega. eauto. }
   }
   {inv H13.
    {constructor. right. left. constructor. auto. eapply IHconvStack. Focus 4.
     rewrite plus_comm. eauto. Focus 3. eauto. Focus 2. eauto.
     eapply colorStrengthening; eauto. inv H1. eauto. eapply notInFV; eauto.
     rewrite plus_comm in H4. eauto. omega. eauto. }
    {constructor. right. left. constructor. auto. eapply IHconvStack. Focus 4.
     rewrite plus_comm. eauto. omega. Focus 3. eauto. Focus 2. eauto.
     eapply colorStrengthening; eauto. inv H1. eauto. eapply notInFV; eauto.
     rewrite plus_comm in H4. eauto. }
   }
   {inv H13.
    {constructor. right. right. constructor. auto. eapply IHconvStack. Focus 4.
     rewrite plus_comm. eauto. Focus 3. eauto. Focus 3. eauto. omega.
      eapply colorStrengthening; eauto. inv H1. eauto. eapply notInFV; eauto.
     rewrite plus_comm in H4. eauto. }
    {constructor. right. right. constructor. auto. eapply IHconvStack. Focus 4.
     rewrite plus_comm. eauto. Focus 4. eauto. Focus 3. eauto. omega.
      eapply colorStrengthening; eauto. inv H1. eauto. eapply notInFV; eauto.
     rewrite plus_comm in H4. eauto. }
   }
  }
Qed.


Require Import Arith Program.Equality.

Inductive le' : nat -> nat -> Prop :=
| le'_0 (n : nat) : le' 0 n
| le'_S (n m : nat) : le' n m -> le' (S n) (S m).

Fixpoint le'_irrelevant (n m : nat) (p q : le' n m) : p = q.
Proof.
  dependent destruction p; dependent destruction q.
  - reflexivity.
  - f_equal; apply le'_irrelevant.
Defined.


Require Export ZArith_base.
Require Export XRdefinitions.

Fixpoint IPR_2 (p:positive) : R :=
  match p with
  | xH => R1 + R1
  | xO p => (R1 + R1) * IPR_2 p
  | xI p => (R1 + R1) * (R1 + IPR_2 p)
  end.

Definition IPR (p:positive) : R :=
  match p with
  | xH => R1
  | xO p => IPR_2 p
  | xI p => R1 + IPR_2 p
  end.
Arguments IPR p%positive : simpl never.

Definition IZR (z:Z) : R :=
  match z with
  | Z0 => R0
  | Zpos n => IPR n
  | Zneg n => - IPR n
  end.
Arguments IZR z%Z : simpl never.


Set Implicit Arguments.
Require Export List.
Require Export Ltree.

Require Export ZArith.

Open Scope positive_scope.

CoFixpoint PosTree (p:positive) : LTree positive :=
  LBin p (PosTree (xO p)) (PosTree (xI p)).

Eval compute in (LTree_label (PosTree 1) (d0 :: d1 :: nil)).

Eval compute in (LTree_label (PosTree 1) (d0 :: d1 :: d1 :: nil)).

Eval compute in (LTree_label (PosTree 1)
                             (d0 :: d1 :: d1 :: d0 :: d0 ::d1 :: nil)).

CoFixpoint graft (A:Set) (t t':LTree A) : LTree A :=
  match t with
  | LLeaf => t'
  | LBin n t1 t2 => LBin n (graft t1 t') (graft t2 t')
  end.


(* Exercise 61 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_061 : (exists x, ~ R x x) -> (exists x, exists y, ~ R x y).
Proof.
imp_i a1.
exi_e (exists x:D, ~R x x) a a2.
hyp a1.
exi_i a.
exi_i a.
hyp a2.
Qed.


Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Require Import HMAC_functional_prog_new.
Require Import Integers.
Require Import Coqlib.

(* Require Import List. Import ListNotations. *)

Definition Blist := list bool.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0%nat =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Section HMAC.

SearchAbout Bvector.
Print Bvector.
Check Bvector 10.
Check [true].

  Variable c p : nat.
  (* b is block size, c is digest (output) size, p is padding *)
  Definition b := (c + p)%nat.
  Check b.

  (* The compression function *)
  (* hash_blocks: registers -> block -> registers *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  (* TODO: is the IV standardized in the spec? does it need to have certain properties for
   the proof? *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  (* TODO check how this corresponds to SHA *)
  Definition hash_words := h_star iv.
Check hash_words.
Check h_star.

  Variable splitAndPad : Blist -> list (Bvector b).

  (* TODO examine this hypothesis *)
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* constant-length padding. *)
  Variable fpad : Bvector p.

  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x fpad).
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in (* concat earlier, then split *)
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

  (* b + b comes from ( *)
  Definition HMAC_2K (k : Bvector (b + b)) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

Check HMAC_2K.
(* HMAC_2K
     : Bvector (b + b) -> Blist -> Bvector c *)
SearchAbout Bvector.
(* Bvector (b + b) -> Blist -> BVector c *)

Print splitVector.

Theorem test : forall (k : Bvector (b + b)) (m : Blist),
  HMAC_2K k m = HMAC_2K k m.
Proof.
  intros k m.
  unfold HMAC_2K.               (* splitAndPad is abstract *)
  unfold GHMAC_2K.
  unfold hash_words.
  unfold h_star.
  (* unfold splitVector. *)
Abort.

Print Bvector.                  (* Vector.t bool : nat -> Set *)
(* Check [true]%(Bvector 1). *)
(* Cannot compute since Variables are not instantiated  -- TODO, how to instantiate
(e.g. with SHA256? does it have the right type?
SHA256 : list Z -> list Z *)
(* Eval compute in HMAC_2K [true; true] [false]. *)

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Bvector b. (* c + p *)
  Definition GHMAC (k : Bvector b) :=
    GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Print BVxor.

  (* Doesn't seem to take into account the hash function's input block size (see mkKey in P. spec) *)
  Definition HMAC (k : Bvector b) :=
    HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Check HMAC.                     (*  : Bvector b -> Blist -> Bvector c *)

  (* Bvector or Blist? *)
Check HMAC_2K.                  (* TODO confirm that this is actually the right version *)

End HMAC.

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

Require Import HMAC_functional_prog_2.

(* How to get the other HMAC? *)
(* TODO: compile HMAC_functional_prog_2 *)
Check HMAC_FUN.HMAC.            (* list Z -> list Z -> list Z *)

(* Bvector (plus c p)  *)

(* relationship between a list Z (of bytes) and a Bvector of size (c + p):
toBvector (bytes_to_bits k) = K?
(don't actually need the Bvector, just c + p, or its length) <-- deprecated,
want equality
 *)
Inductive bytes_bits_vector (c p : nat) (k : list Z) : Bvector (plus c p) -> Prop :=
  | test_n : forall (K : Bvector (plus c p)), bytes_bits_vector c p k K (* ?? TODO *)
.

(* relating list Z to Blist
bytes_to_bits m = length M

TODO: big-endian, little-endian?
*)
Inductive bytes_bits_lists (m : list Z) : Blist -> Prop :=
  | test_n' : forall M : Blist, bytes_bits_lists m M
.

(* the hashes are "the same": list Z vs Bvector c

toBvector (bytes_to_bits h) = H
this is *almost* the same as bytes_bits_vector, except just c, not c + p
 *)
Inductive bytes_bits_vector' (c : nat) (h : list Z) : Bvector c -> Prop :=
  | test_n'' : forall (H : Bvector c), bytes_bits_vector' h H
.
(* TODO: compare to rel1. How do dependent types and inductive props work? *)

(* TODO:
Definition convertByteBits (b: byte) (B: Bvector 8): Prop :=
  exists b0, ... b7 (*all of type bool*),
   B = [b0, b1, ... b7] /\
   b = (asZ b0) + 2 * (asZ b1) * 4 * (asZ b2) + .. + 128 * (asZ b7).

where Definition asZ (x:bool):Z := if x then 1 else 0.
*)

Check bytes_bits_vector.
Check HMAC_FUN.HMAC.
Check HMAC_SHA256.HMAC.         (* ? *)
Check HMAC.
(* HMAC
     : forall c p : nat,
       (Bvector c -> Bvector (b c p) -> Bvector c) ->   // compression function h
       Bvector c ->                          // iv, h's initialization vector
       (Blist -> list (Bvector (b c p))) ->  // splitAndPad (e.g. generate_and_pad)
       Bvector p ->                          // fpad, constant-length padding
       Bvector (b c p) ->                    // opad
       Bvector (b c p) ->                    // ipad

^ Note: this has to do with the internals of SHA256 and HMAC too
SHA's compression function, iv, generate_and_pad (with block vectors),
HMAC's key padding function, HMAC's opad and ipad

How to convert?

Bvector (b c p) -> Blist -> Bvector c        // key, message, outputted hash
k is of length b
b = block size
c = output size
c + p = output size padded to block size

why pad the key? why not just let it be size b?
 *)

(* Is this the theorem we want? Is it useful for the rest of the proofs?
Should it be more abstract?

also, no key padding
add assumption that the key is padded to the right length (b)
password of length b
modify?
*)

Print Blist.

(* maybe bvector of length 8, convert to Blist later?
TODO big-endian vs. little-endian *)
(* Parameter byte_to_bits : Z -> Bvector 8. *)
  (* Vector.nil bool. TODO *)
SearchAbout Vector.t.

(* Bvector is little-endian (least significant bit at head; list Z are just translated
from the string (ascii -> nat -> Z); but Int are packed big-endian (with 4 Z -> 1 Int)

each Z is one byte (8 bits) *

bytes -> bits is ok
bits -> bytes is not ok
*)
(*
Don't have an assurance that 0 <= byte < 256
TODO: add isbyteZ (from SHA256.v), 0 <= i <= 256

1 2 3 4 5 6 7 8
*)

SearchAbout Z.
Eval compute in zle 5 10.
Check zle.
Check zle_true.
SearchAbout nat.
Check N.

(* TODO: finish this

The term "Vector.append (iterate n' num_new) [bool_digit]" has type
 "Vector.t bool (n' + 1)" while it is expected to have type
"Bvector (S n')".

Function with proof of equivalence? see hash_blocks
 *)

(*
Fixpoint iterate (n : nat) (byte : nat) : Bvector n :=
  match n as x return Bvector x with
    | O => Vector.nil bool
    | S n' =>
      let byte_subtract := (byte - NPeano.pow 2 (n - 1))%nat in
      let bool_digit := leb byte_subtract 0 in
      let num_new := if bool_digit then byte_subtract else byte in
      Vector.append (iterate n' num_new) [bool_digit] (* could reverse instead *)
  end.

(* reverse?
0 <= byte < 256, integer

[0, 1, 2, 3, 4, 5, 6, 7] <-- bool
*)
Fixpoint byte_to_bits (byte : Z) : Bvector 8 :=
  let max_pow_two := 7 in
  iterate (max_pow_two + 1) (nat_of_Z byte).    (* or iterate 8? *)
*)

Parameter byte_to_bits : Z -> Bvector 8.

(* Or: concatMap byte_to_bit bytes *)
Check Bvector.
SearchAbout Bvector.
Print Vector.t.

(* how to prove that it's length bytes * 8? *)
(* list of bytes? (type) *)
Fixpoint bytes_to_bits (bytes : list Z) : Bvector (length bytes * 8) :=
  match bytes as x return Bvector (length x * 8) with (* CPDT *)
    | nil => Vector.nil bool
    | x :: xs => Vector.append (byte_to_bits x) (bytes_to_bits xs)
  end.

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

Parameter sha_iv : Bvector (8 * SHA256_.DigestLength).

(* Definition sha_h : list Z -> list Z := SHA256_.Hash. *)
Parameter sha_h : forall (c p : nat) (b:nat -> nat -> nat),
                    Bvector c -> Bvector (b c p) -> Bvector c.
(* due to implicit parameters, only requires c or p, and b *)

(* corresponds to block size, b = plus *)

(* TODO: email adam about fpad: it's not padding the key *)

(*  "Blist -> list (Bvector (b SHA256_.DigestLength c))" *)
Parameter sha_splitandpad_vector :
  forall (p : nat), Blist -> list (Bvector ((SHA256_.DigestLength * 8) + p)).

Parameter fpad : forall (p : nat), Bvector p.

(* want Bvector b = 512 bits *)
Print Byte.int.
Print Byte.repr.
Check HMAC_SHA256.sixtyfour HMAC_SHA256.Opad.
Check Byte.unsigned.
Definition opad := bytes_to_bits
                     (map Byte.unsigned (HMAC_SHA256.sixtyfour HMAC_SHA256.Opad)).
Definition ipad := bytes_to_bits
                     (map Byte.unsigned (HMAC_SHA256.sixtyfour HMAC_SHA256.Ipad)).

Check HMAC.

(*
Email Adam about fpad
Figure out what parameters are
Fill in the relations
Byte to bits

New theorem
Parametrize C HMAC by OPAD and IPAD + they need to be different in at least one bit
   (does adam need this?)

Now, write individual functions (e.g. sha_h, which is still abstract)
and prove them equivalent? different types....

Lennart: update spec, ipad and opad
email andrew about lennart coming to meeting + hmac refactoring

 *)

Check sha_h.

Module Equiv.
Definition c := (8 * SHA256_.DigestLength)%nat.
Variable p : nat.
Check HMAC (sha_h c plus).
Check HMAC (sha_h c plus) sha_iv.

(* c needs to be not forall, should be 8 * digest length *)
Theorem HMAC_spec_equiv : forall
                            (c p : nat)
                            (k m h : list Z)
                            (K : Bvector (plus c p)) (M : Blist) (H : Bvector c),

                            (* assuming k is already padded? *)
  (8 * (length (HMAC_FUN.mkKey k)))%nat = (c + p)%nat ->
  bytes_bits_vector c p k K -> bytes_bits_lists m M ->
  HMAC (sha_h c plus) sha_iv (sha_splitandpad_vector c p) (fpad p) opad ipad K M = H ->
  HMAC_FUN.HMAC k m = h ->
  (* TODO fix HMAC h iv splitAndPad fpad opad ipad K M *)
  bytes_bits_vector' h H.
Proof.

Abort.


Require Import Problem ZArith ZArith.Znumtheory.

Theorem solution : task.
Proof.
  unfold task.
  intros.
  unfold Square; unfold Square in H2.
  remember (Z.sqrt (n * m)) as k.
  remember (Z.gcd k m) as x.
  remember (Z.gcd k n) as y.
  apply (proj2 (Zgcd_1_rel_prime n m)) in H1.

  assert (y * k = n * x).
  subst x y.
  rewrite <- Z.gcd_mul_mono_l_nonneg; [|omega].
  rewrite <- Z.gcd_mul_mono_r_nonneg; [|subst k; apply Z.sqrt_nonneg].
  rewrite H2.
  rewrite Z.gcd_comm.
  auto.

  assert (Z.gcd x y = 1).
  subst x y.
  rewrite <- Z.gcd_assoc.
  rewrite (Z.gcd_comm m).
  rewrite <- Z.gcd_assoc.
  rewrite H1.
  repeat rewrite Z.gcd_1_r.
  auto.

  assert (n = y * Z.gcd k n).
  rewrite <- Z.gcd_mul_mono_l_nonneg; [|subst y; apply Z.gcd_nonneg].
  rewrite H3; clear H3.
  rewrite Z.mul_comm.
  rewrite Z.gcd_mul_mono_r_nonneg; [|omega].
  rewrite H4; clear H4.
  omega.

  rewrite <- Heqy in H5.
  replace (Z.sqrt n) with y; [auto|].
  specialize (Z.gcd_nonneg k n); intro.
  rewrite <- Heqy in H6.
  rewrite <- (Z.sqrt_square y H6).
  subst n; auto.
Qed.


Require Import Arith.
Require Import Lia.
Require Export FOPL.FOPL.
Require Export FOPL.Deduction.
Require Export FOPL.SetoidL.
Require Export FOPL.Tactics.

Definition theory {L : Lang} (T : Th) := fun p => T ||- p.

Definition sentence_th {L : Lang} T := sfT T ≡ T.

Inductive Null {L : Lang} : Th :=.
Definition null {L : Lang} (T : Th) := forall p, ~ T p.

Fixpoint Fal {L : Lang} n0 p :=
  match n0 with
  | 0 => p
  | S n => [fal](Fal n p)
  end.

Section deduction_facts2.
  Variable L : Lang.

  Lemma nullNull : null Null.
  Proof.
    unfold null.
    intros. intro.
    destruct H.
  Qed.

  Lemma nullT_nullsfT : forall T, null (sfT T) <-> null T.
  Proof.
    unfold null.
    intros.
    split.
    intros.
    specialize(H (sf p)).
    contradict H.
    auto.
    intros. intro.
    destruct H0.
    specialize (H p).
    contradiction.
  Qed.

  Lemma null_sfT : forall T, null T -> T ≡ (sfT T).
  Proof.
    intros.
    unfold eqvT, incT.
    split.
    intros.
    specialize (H p).
    contradiction.
    intros.
    rewrite <- nullT_nullsfT in H.
    specialize(H p).
    contradiction.
  Qed.

  Lemma fal_Fal : forall p n, [fal] Fal n p = Fal n ([fal] p).
  Proof.
    induction n.
    simpl. auto.
    simpl.
    rewrite IHn.
    auto.
  Qed.

  Lemma Genp_ps : forall T p s, T ||- (Fal (Ar p) p) [->] p.[s].
  Proof.
    assert(forall T n p s, Ar p <= n -> T ||- (Fal n p) [->] p.[s]).
    - induction n.
      + simpl.
        intros.
        rewrite <- sentence_rew.
        auto.
        lia.
      + simpl.
        intros.
        rewrite fal_Fal.
        ftrans (([fal]p).[fun x :nat => s (S x)]).
        apply IHn.
        simpl. lia.
        simpl.
        fintro.
        Tpp.
        fspecialize H0 (s 0).
        rewrite nested_rew in H0.
        assert(p.[ fun x => rewc (s 0; \0) (('0; fun x0 => sfc (s (S x0))) x)] = p.[s]). {
          apply rew_rew. unfold sfc.
          intros. simpl.
          destruct n0.
          simpl. auto.
          simpl.
          rewrite nested_rewc.
          simpl.
          symmetry.
          apply rewc_id.
        }
        rewrite H1 in H0.
        auto.
    - intros.
      apply H.
      lia.
  Qed.

  Lemma Null_psfp : forall T p, null T -> (T ||- p) -> (T ||- sf p).
  Proof.
    intros.
    assert(forall n, T ||- Fal n p).
    - induction n.
      simpl. auto.
      simpl.
      GEN.
      apply TInclusion with (T:=T).
      apply null_sfT. auto.
      auto.
    - MP (Fal (Ar p) p). auto.
      unfold sf.
      apply Genp_ps.
  Qed.

  Inductive Array (f : nat -> Formula) (n0 : nat) : Th :=
  | array : forall n, n < n0 -> Array f n0 (f n).

  Fixpoint Sum (f : nat -> Formula) (n0 : nat) : Th :=
    match n0 with
    | 0 => Null
    | S n => (Sum f n) ¦ (f n)
    end.

  Lemma Sump : forall f n p, (Sum f n p) -> exists m, m < n /\ p = f m.
  Proof.
    induction n.
    - simpl. intros.
      destruct H.
    - simpl.
      intros.
      destruct H.
      exists n.
      auto.
      specialize (IHn q H).
      destruct IHn as [n0].
      destruct H0.
      exists n0. auto.
  Qed.

  Lemma Sump_inv : forall f n m, m < n -> Sum f n (f m).
  Proof.
    induction n.
    - simpl. intros.
      lia.
    - simpl.
      intros.
      unfold lt in H.
      apply le_S_n in H.
      apply le_lt_or_eq in H.
      destruct H.
      auto.
      rewrite H.
      auto.
  Qed.

  Lemma sfSumsfp : forall f n p, (Sum f n ||- p) -> (sfT (Sum f n) ||- sf p).
  Proof.
    induction n.
    - simpl. intros.
      apply TInclusion with (T:=Null).
      unfold incT.
      intros.
      contradiction.
      apply Null_psfp.
      apply nullNull.
      auto.
    - simpl. intros.
      apply sf_dsb.
      apply deduction_inv.
      assert(sf(f n [->] p) = sf(f n)[->]sf p). unfold sf. simpl. auto.
      rewrite <- H0.
      apply IHn.
      fintro.
      auto.
  Qed.

  Lemma sfTSum : forall f n p, (Sum (fun x => sf (f x)) n ||- p) -> (sfT (Sum f n) ||- p).
  Proof.
    induction n.
    - simpl.
      intros.
      apply TInclusion with (T:=Null).
      apply null_sfT.
      apply nullNull.
      auto.
    - simpl.
      intros.
      apply sf_dsb.
      apply deduction_inv.
      apply IHn.
      fintro.
      auto.
  Qed.

  Lemma seq_comp :
    forall f0 f1 n0 n1,
    let f := (fun x : nat => if x <? n0 then f0 x else f1 (x - n0)) in
    Sum f0 n0 ⊆ Sum f (n0 + n1) /\
    Sum f1 n1 ⊆ Sum f (n0 + n1).
  Proof.
    intros.
    unfold incT.
    split.
    - intros.
      apply Sump in H.
      destruct H as [m].
      destruct H.
      assert(f m = f0 m). {
        rewrite <- Nat.ltb_lt in H.
        unfold f.
        rewrite H.
        auto.
      }
      rewrite H0.
      rewrite <- H1.
      apply Sump_inv.
      lia.
    - intros.
      apply Sump in H.
      destruct H as [m].
      destruct H.
      assert(f (n0 + m) = f1 m). {
        assert(n0 + m <? n0 = false).
        rewrite <- Bool.not_true_iff_false.
        intro.
        rewrite Nat.ltb_lt in H1.
        lia.
        unfold f.
        rewrite H1.
        assert(n0 + m - n0 = m). lia.
        rewrite H2.
        auto.
      }
      rewrite H0.
      rewrite <- H1.
      apply Sump_inv.
      lia.
  Qed.

  Lemma proof_compact : forall T p, (T ||- p) -> exists f n, (Sum f n ⊆ T) /\ (Sum f n ||- p).
  Proof.
    assert(forall T p, (T ||- p) -> exists f n, (forall m, m < n -> T (f m)) /\ (Sum f n ||- p)).
    intros.
    induction H.
    - destruct IHprovable as [f].
      destruct H0 as [n].
      destruct H0.
      exists (fun n => alt (f n)).
      exists n.
      split.
      intros.
      specialize (H0 m H2).
      destruct H0.
      rewrite alt_sf.
      auto.
      GEN.
      apply sfTSum.
      apply TInclusion with (T:=Sum f n). {
        unfold incT. intros.
        apply Sump in H2.
        destruct H2 as [m].
        destruct H2.
        pose (s := fun x => sf (alt (f x))).
        fold s.
        assert(s m = f m). {
          specialize(H0 m H2).
          unfold s.
          destruct H0.
          rewrite alt_sf.
          auto.
        }
        rewrite H3.
        rewrite <- H4.
        apply Sump_inv. auto.
      }
      auto.
    - destruct IHprovable1 as [f0].
      destruct H1 as [n0].
      destruct H1.
      destruct IHprovable2 as [f1].
      destruct H3 as [n1].
      destruct H3.
      pose (f := (fun x : nat => if x <? n0 then f0 x else f1 (x - n0))).
      exists f. exists (n0 + n1).
      split.
      + intros.
        unfold f.
        assert(lem := classic (m <? n0 = true)). destruct lem.
        rewrite H6. apply H1.
        rewrite <- Nat.ltb_lt. auto.
        rewrite Bool.not_true_iff_false in H6.
        rewrite H6. apply H3.
        rewrite <- Bool.not_true_iff_false in H6.
        apply NNPP.
        contradict H6.
        rewrite Nat.ltb_lt. lia.
      + assert(Sum f0 n0 ⊆ Sum f (n0 + n1) /\ Sum f1 n1 ⊆ Sum f (n0 + n1)). {
          unfold f. apply seq_comp.
        }
        destruct H5.
        MP p.
        apply TInclusion with (T:=Sum f0 n0). auto. auto.
        apply TInclusion with (T:=Sum f1 n1). auto. auto.
    - exists(fun _ => p).
      exists 1.
      split. auto.
      simpl. auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - exists(fun _ => [O][=][O]).
      exists 0.
      split. lia.
      auto.
    - intros.
      specialize (H T p H0).
      destruct H as [f].
      destruct H as [n].
      exists f.
      exists n.
      unfold incT.
      destruct H.
      split.
      intros.
      apply Sump in H2. destruct H2.
      destruct H2.
      rewrite H3. auto.
      auto.
  Qed.

  Lemma sfT_inc : forall T U, (T ⊆ U) -> (sfT T ⊆ sfT U).
  Proof.
    unfold incT.
    intros.
    destruct H0.
    auto.
  Qed.

  Lemma sf_add : forall T p, (T ||- p) -> (sfT T ||- sf p).
  Proof.
    intros.
    apply proof_compact in H.
    destruct H as [f].
    destruct H as [n].
    destruct H.
    apply sfSumsfp in H0.
    apply TInclusion with (T:=sfT (Sum f n)).
    apply sfT_inc. auto.
    auto.
  Qed.

  Lemma sfT_MP : forall T p q, (T ||- p) -> (sfT T ¦ sf p ||- q) -> (sfT T ||- q).
  Proof.
    intros.
    MP (sf p).
    apply sf_add. auto.
    fintro.
    auto.
  Qed.

  Lemma fal_repl : forall T p,
    ([fal][fal]p) ==(T) ([fal][fal]p.['1;('0;fun x => '(S (S x)))]).
  Proof.
    assert(forall T p, T ||- ([fal][fal]p)[->]([fal][fal]p.['1;('0;fun x => '(S (S x)))])).
    - intros.
      fintro.
      GEN.
      GEN.
      assert(p.['0;('1;fun x => '(4 + x))]/('1, '0) = p.['1;('0;fun x => '(S (S x)))]). {
        rewrite nested_rew.
        apply rew_rew.
        intros.
        destruct n.
        auto.
        destruct n.
        auto. auto.
      }
      rewrite <- H.
      apply fal_R2.
      assert(sf (sf ([fal][fal]p)) = ([fal][fal]p.['0; ('1; fun x => '(4 + x))])). {
        unfold sf. simpl.
        apply fal_eq.
        apply fal_eq.
        rewrite nested_rew.
        apply rew_rew.
        intros. unfold sfc. simpl.
        destruct n. auto.
        destruct n. auto.
        auto.
      }
      rewrite <- H0.
      auto.
    - intros.
      fsplit.
      auto.
      assert(p = p.['1;('0;fun x => '(S (S x)))].['1;('0;fun x => '(S (S x)))]). {
        rewrite -> rew_id at 1.
        rewrite nested_rew.
        apply rew_rew.
        intros.
        destruct n. auto. simpl.
        destruct n. auto.
        auto.
      }
      rewrite -> H0 at 2.
      auto.
  Qed.

  Lemma neq_symm : forall T t u, (T ||- t[=/=]u) -> (T ||- u[=/=]t).
  Proof.
    intros.
    RAA (t[=]u).
    fsymmetry. auto.
    WL. auto.
  Qed.

  Lemma DNE : forall T p, p ==(T) [~][~]p.
  Proof.
    unfold equiv. simpl. unfold priff.
    intros.
    fsplit.
    apply pr_NN.
    apply pr_NNPP.
  Qed.

End deduction_facts2.

Ltac MPsf h := repeat WL; apply (@sfT_MP _ _ h _).


(*** Barrett Reduction *)
(** This file implements a slightly-generalized version of Barrett
    Reduction on [Z].  This version follows the Handbook of Applied
    Cryptography (Algorithm 14.42) rather closely; the only deviations
    are that we generalize from [k ± 1] to [k ± offset] for an
    arbitrary offset, and we weaken the conditions on the base [b] in
    [bᵏ] slightly.  Contrasted with some other versions, this version
    does reduction modulo [b^(k+offset)] early (ensuring that we don't
    have to carry around extra precision), but requires more stringint
    conditions on the base ([b]), exponent ([k]), and the [offset]. *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Hints.
Require Import Crypto.Util.ZUtil.ZSimplify.

Local Open Scope Z_scope.

Section barrett.
  (** Quoting the Handbook of Applied Cryptography <http://cacr.uwaterloo.ca/hac/about/chap14.pdf>: *)
  (** Barrett reduction (Algorithm 14.42) computes [r = x mod m] given
      [x] and [m]. The algorithm requires the precomputation of the
      quantity [µ = ⌊b²ᵏ/m⌋]; it is advantageous if many reductions
      are performed with a single modulus. For example, each RSA
      encryption for one entity requires reduction modulo that
      entity’s public key modulus. The precomputation takes a fixed
      amount of work, which is negligible in comparison to modular
      exponentiation cost.  Typically, the radix [b] is chosen to be
      close to the word-size of the processor. Hence, assume [b > 3] in
      Algorithm 14.42 (see Note 14.44 (ii)). *)

  (** * Barrett modular reduction *)
  Section barrett_modular_reduction.
    Context (m b x k μ offset : Z)
            (m_pos : 0 < m)
            (base_pos : 0 < b)
            (k_good : m < b^k)
            (μ_good : μ = b^(2*k) / m) (* [/] is [Z.div], which is truncated *)
            (x_nonneg : 0 <= x)
            (offset_nonneg : 0 <= offset)
            (k_big_enough : offset <= k)
            (x_small : x < b^(2*k))
            (m_small : 3 * m <= b^(k+offset))
            (** We also need that [m] is large enough; [m] larger than
                [bᵏ⁻¹] works, but we ask for something more precise. *)
            (m_large : x mod b^(k-offset) <= m).

    Let q1 := x / b^(k-offset). Let q2 := q1 * μ. Let q3 := q2 / b^(k+offset).
    Let r1 := x mod b^(k+offset). Let r2 := (q3 * m) mod b^(k+offset).
    (** At this point, the HAC says "If [r < 0] then [r ← r + bᵏ⁺¹]".
        This is equivalent to reduction modulo [b^(k+offset)], as we
        prove below.  The version involving modular reduction has the
        benefit of being cheaper to implement, and making the proofs
        simpler, so we primarily use that version. *)
    Let r_mod_3m      := (r1 - r2) mod b^(k+offset).
    Let r_mod_3m_orig := let r := r1 - r2 in
                         if r <? 0 then r + b^(k+offset) else r.

    Lemma r_mod_3m_eq_orig : r_mod_3m = r_mod_3m_orig.
    Proof using base_pos k_big_enough m_pos m_small offset_nonneg r1 r2.
      assert (0 <= r1 < b^(k+offset)) by (subst r1; auto with zarith).
      assert (0 <= r2 < b^(k+offset)) by (subst r2; auto with zarith).
      subst r_mod_3m r_mod_3m_orig; cbv zeta.
      break_match; Z.ltb_to_lt.
      { symmetry; apply (Zmod_unique (r1 - r2) _ (-1)); lia. }
      { symmetry; apply (Zmod_unique (r1 - r2) _ 0); lia. }
    Qed.

    (** 14.43 Fact By the division algorithm (Definition 2.82), there
        exist integers [Q] and [R] such that [x = Qm + R] and [0 ≤ R <
        m]. In step 1 of Algorithm 14.42 (Barrett modular reduction),
        the following inequality is satisfied: [Q - 2 ≤ q₃ ≤ Q]. *)
    (** We prove this by providing a more useful form for [q₃]. *)
    Let Q := x / m.
    Let R := x mod m.
    Lemma q3_nice : { b : bool * bool | q3 = Q + (if fst b then -1 else 0) + (if snd b then -1 else 0) }.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg x_nonneg x_small μ_good.
      assert (0 < b^(k+offset)) by Z.zero_bounds.
      assert (0 < b^(k-offset)) by Z.zero_bounds.
      assert (x / b^(k-offset) <= b^(2*k) / b^(k-offset)) by auto with zarith lia.
      assert (x / b^(k-offset) <= b^(k+offset)) by (autorewrite with pull_Zpow zsimplify in *; assumption).
      subst q1 q2 q3 Q r_mod_3m r_mod_3m_orig r1 r2 R μ.
      rewrite (Z.div_mul_diff_exact' (b^(2*k)) m (x/b^(k-offset))) by auto with lia zero_bounds.
      rewrite (Z_div_mod_eq_full (_ * b^(2*k) / m) (b^(k+offset))).
      autorewrite with push_Zmul push_Zopp zsimplify zstrip_div zdiv_to_mod.
      rewrite Z.div_sub_mod_cond, !Z.div_sub_small; auto with zero_bounds zarith.
      eexists (_, _); reflexivity.
    Qed.

    Fact q3_in_range : Q - 2 <= q3 <= Q.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg q2 x_nonneg x_small μ_good.
      rewrite (proj2_sig q3_nice).
      break_match; lia.
    Qed.

    (** 14.44 Note (partial justification of correctness of Barrett reduction) *)
    (** (i) Algorithm 14.42 is based on the observation that [⌊x/m⌋]
            can be written as [Q =
            ⌊(x/bᵏ⁻¹)(b²ᵏ/m)(1/bᵏ⁺¹)⌋]. Moreover, [Q] can be
            approximated by the quantity [q₃ = ⌊⌊x/bᵏ⁻¹⌋µ/bᵏ⁺¹⌋].
            Fact 14.43 guarantees that [q₃] is never larger than the
            true quotient [Q], and is at most 2 smaller. *)
    Lemma x_minus_q3_m_in_range : 0 <= x - q3 * m < 3 * m.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg q2 x_nonneg x_small μ_good.
      clear k_good.
      pose proof q3_in_range.
      assert (0 <= R < m) by (subst R; auto with zarith).
      assert (0 <= (Q - q3) * m + R < 3 * m) by nia.
      subst Q R; autorewrite with push_Zmul zdiv_to_mod in *; lia.
    Qed.

    Lemma r_mod_3m_eq_alt : r_mod_3m = x - q3 * m.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg q2 x_nonneg x_small μ_good.
      pose proof x_minus_q3_m_in_range.
      subst r_mod_3m r_mod_3m_orig r1 r2.
      autorewrite with pull_Zmod zsimplify; reflexivity.
    Qed.

    (** This version uses reduction modulo [b^(k+offset)]. *)
    Theorem barrett_reduction_equivalent
      : r_mod_3m mod m = x mod m.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg r1 r2 x_nonneg x_small μ_good.
      rewrite r_mod_3m_eq_alt.
      autorewrite with zsimplify push_Zmod; reflexivity.
    Qed.

    (** This version, which matches the original in the HAC, uses
        conditional addition of [b^(k+offset)]. *)
    Theorem barrett_reduction_orig_equivalent
      : r_mod_3m_orig mod m = x mod m.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg r_mod_3m x_nonneg x_small μ_good. rewrite <- r_mod_3m_eq_orig; apply barrett_reduction_equivalent. Qed.

    Lemma r_small : 0 <= r_mod_3m < 3 * m.
    Proof using Q R base_pos k_big_enough m_large m_pos m_small offset_nonneg q3 x_nonneg x_small μ_good.
      pose proof x_minus_q3_m_in_range.
      subst Q R r_mod_3m r_mod_3m_orig r1 r2.
      autorewrite with pull_Zmod zsimplify; lia.
    Qed.

    (** This version uses reduction modulo [b^(k+offset)]. *)
    Theorem barrett_reduction_small (r := r_mod_3m)
      : x mod m = let r := if r <? m then r else r-m in
                  let r := if r <? m then r else r-m in
                  r.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg r1 r2 x_nonneg x_small μ_good.
      pose proof r_small. cbv zeta.
      destruct (r <? m) eqn:Hr, (r-m <? m) eqn:?; subst r; rewrite !r_mod_3m_eq_alt, ?Hr in *; Z.ltb_to_lt; try lia.
      { symmetry; eapply (Zmod_unique x m q3); lia. }
      { symmetry; eapply (Zmod_unique x m (q3 + 1)); lia. }
      { symmetry; eapply (Zmod_unique x m (q3 + 2)); lia. }
    Qed.

    (** This version, which matches the original in the HAC, uses
        conditional addition of [b^(k+offset)]. *)
    Theorem barrett_reduction_small_orig (r := r_mod_3m_orig)
      : x mod m = let r := if r <? m then r else r-m in
                  let r := if r <? m then r else r-m in
                  r.
    Proof using base_pos k_big_enough m_large m_pos m_small offset_nonneg r_mod_3m x_nonneg x_small μ_good. subst r; rewrite <- r_mod_3m_eq_orig; apply barrett_reduction_small. Qed.
  End barrett_modular_reduction.
End barrett.


Require Export Basics.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
        match reverse goal with
        | H : _ |- _ => try move x after H
        end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
        let H := fresh in
        assert (x = v) as H by reflexivity;
        clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
        first [
          set (x := name); move_to_top x
        | assert_eq x name; move_to_top x
        | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1: forall b c : bool,
        andb b c = true -> b = true.
Proof.
        intros b c H.
        destruct b.
        Case "b = true".
        reflexivity.
        Case "b = false".
        rewrite <- H.
        reflexivity.
Qed.

Theorem nadb_true_elim2: forall b c: bool,
        andb b c = true -> c = true.
Proof.
        intros b c H.
        destruct c.
        Case "c = true".
        reflexivity.
        Case "c = false".
        rewrite <- H.
        destruct b.
        SCase "b = true".
        reflexivity.
        SCase "b = false".
        reflexivity.
Qed.

Theorem plus_0_r: forall n: nat, n + 0 = n.
Proof.
        intros n.
        induction n as [| n'].
        Case "n = 0". reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem minus_diag: forall n: nat, minus n n = 0.
Proof.
        intros n.
        induction n as [| n'].
        Case "n = 0". reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mult_0_r: forall n: nat, n * 0 = 0.
Proof.
        intros n.
        induction n as [| n'].
        Case "n = 0". reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_n_Sm: forall n m: nat, S (n + m) = n + (S m).
Proof.
        intros n m.
        induction n as [| n'].
        Case "n = 0". simpl. reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_comm: forall n m: nat, n + m = m + n.
Proof.
        intros n m.
        induction n as [| n'].
        Case "n = 0". simpl. rewrite -> plus_0_r. reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc: forall n m p: nat, n + (m + p) = (n + m) + p.
Proof.
        intros n m p.
        induction n as [| n'].
        Case "n = 0". simpl. reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. reflexivity.
Qed.

Fixpoint double (n: nat) :=
        match n with
        | O => O
        | S n' => S (S (double n'))
        end.
Lemma double_plus: forall n: nat, double n = n + n.
Proof.
        intros n.
        induction n as [| n'].
        Case "n = 0". reflexivity.
        Case "n = S n'". simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem plus_swap: forall n m p: nat, n + (m + p) = m + (n + p).
Proof.
        intros n m p.
        assert (HA: n + (m + p) = (n + m) + p).
                rewrite -> plus_assoc. reflexivity.
        rewrite -> HA.
        assert (HB: (n + m) = (m + n)).
                rewrite -> plus_comm. reflexivity.
        rewrite -> HB.
        rewrite -> plus_assoc.
        reflexivity.
Qed.

Theorem mult_n_Sm: forall n m: nat, n + (n * m) = n * (S m).
Proof.
        intros n m.
        induction n as [| n'].
        Case "n = 0". simpl. reflexivity.
        Case "n = S n'". simpl. rewrite -> plus_swap. rewrite -> IHn'. reflexivity.
Qed.
Theorem mult_comm: forall m n: nat, m * n = n * m.
Proof.
        intros n m.
        induction n as [| n'].
        rewrite -> mult_0_r. reflexivity.
        simpl.
        rewrite <- mult_n_Sm. rewrite -> IHn'. reflexivity.
Qed.