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

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

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

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

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

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

(** It has exactly the same type 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 to be 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 X.
  induction l as [| n l'].
  - reflexivity.
  - simpl. rewrite -> IHl'.
    reflexivity.
Qed.

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

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1 as [| n l1' IHl1'].
  - 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 X l1 l2.
  induction l1.
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl1. rewrite -> app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l.
  - 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, especially useful (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
     | (m, n) :: l' => (m :: fst (split l'), n :: snd (split l'))
     | nil          => ([], [])
     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
  := match l with
     | nil    => None
     | h :: _ => Some h
     end.

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

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

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

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

(** Like 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 (fun n => (even n) && (leb 7 n)) l.

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

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

(** **** Exercise: 3 stars, standard (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 n => negb (test n)) l).

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

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

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

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

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

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

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

Example test_map2:
  map 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 app_map : forall (X Y : Type) (f : X -> Y) (l : list X) (x : X),
  app (map f l) [f x] = map f (app l [x]).
Proof.
  intros X Y f l x.
  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 X Y f l.
  induction l as [|x l'].
  - (* l = nil *)
    reflexivity.
  - (* l = n :: l' *)
    simpl. rewrite <- IHl'. simpl.
    rewrite -> app_map. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, especially useful (flat_map)

    The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
*)

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : list Y
  := match l with
     | nil     => nil
     | x :: l' => (f x) ++ flat_map f l'
     end.

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

(** Lists are not the only inductive type 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? *)

Definition flat_map' {X : Type} (l : list (list X)) : list X
  := fold app l [].

(* ================================================================= *)
(** ** 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 X l.
  induction l as [| x l' IHl'].
  reflexivity. simpl. rewrite <- IHl'.
  simpl. reflexivity.
Qed.
(** [] *)

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

    We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

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

(** 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),
  map f l = fold_map f l.
Proof.
  intros X Y f l.
  induction l as [|x l'].
  reflexivity.
  simpl. rewrite -> IHl'.
  simpl. reflexivity.
Qed.

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

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

    The type [X -> Y -> Z] can be read as describing functions that
    take two arguments, one of type [X] and another of type [Y], and
    return an output of type [Z]. Strictly speaking, this type is
    written [X -> (Y -> Z)] when fully parenthesized.  That is, if we
    have [f : X -> Y -> Z], and we give [f] an input of type [X], it
    will give us as output a function of type [Y -> Z].  If we then
    give that function an input of type [Y], it will return an output
    of type [Z]. That is, every function in Coq takes only one input,
    but some functions return a function as output. This is precisely
    what enables partial application, as we saw above with [plus3].

    By contrast, functions of type [X * Y -> Z] -- which when fully
    parenthesized is written [(X * Y) -> Z] -- require their single
    input to be a pair.  Both arguments must be given at once; there
    is no possibility of partial application.

    It is possible to convert a function between these two types.
    Converting from [X * Y -> Z] to [X -> Y -> Z] is called
    _currying_, in honor of the logician Haskell Curry.  Converting
    from [X -> Y -> Z] to [X * Y -> Z] is called _uncurrying_.  *)

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

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

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

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

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

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

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

Check @prod_curry.
Check @prod_uncurry.

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

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

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

    Recall the definition of the [nth_error] function:

   Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if 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.
(** [] *)

(* ================================================================= *)
(** ** Church Numerals (Advanced) *)

(** The following exercises explore an alternative way of defining
    natural numbers using the _Church numerals_, which are named after
    their inventor, the 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].  Let's informally
    notate that as [fun X f x => f^n x], with the convention that [f^0 x]
    is just [x]. Note how the [doit3times] function we've defined
    previously is actually just the Church representation of [3]. *)

Definition three : cnat := @doit3times.

(** So [n X f x] represents "do it [n] times", where [n] is a Church
    numerals and "it" means applying [f] starting with [x].

    Another way to think about the Church representation is that
    function [f] represents the successor operation on [X], and value
    [x] represents the zero element of [X].  We could even rewrite
    with those names to make it clearer: *)

Definition zero' : cnat :=
  fun (X : Type) (succ : X -> X) (zero : X) => zero.
Definition one' : cnat :=
  fun (X : Type) (succ : X -> X) (zero : X) => succ zero.
Definition two' : cnat :=
  fun (X : Type) (succ : X -> X) (zero : X) => succ (succ zero).

(** If we passed in [S] as [succ] and [O] as [zero], we'd even get the Peano
    naturals as a result: *)

Example zero_church_peano : zero nat S O = 0.
Proof. reflexivity. Qed.

Example one_church_peano : one nat S O = 1.
Proof. reflexivity. Qed.

Example two_church_peano : two nat S O = 2.
Proof. reflexivity. Qed.

(** But the intellectually exciting implication of the Church numerals
    is that we don't strictly need the natural numbers to be built-in
    to a functional programming language, or even to be definable with
    an inductive data type. It's possible to represent them purely (if
    not efficiently) with functions.

    Of course, it's not enough to represent numerals; we need to be
    able to do arithmetic with them. Show that we can by completing
    the definitions of the following functions. Make sure that the
    corresponding unit tests pass by proving them with
    [reflexivity]. *)

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

(** Define a function that computes the successor of a Church numeral.
    Given a Church numeral [n], its successor [scc n] should iterate
    its function argument once more than [n]. That is, given [fun X f x
    => f^n x] as input, [scc] should produce [fun X f x => f^(n+1) x] as
    output. In other words, do it [n] times, then do it once more. *)

Definition scc (n : cnat) : cnat
  := fun (X : Type) (f : X -> X) (x : X) => n X f (f x).

Example scc_1 : scc zero = one.
Proof. reflexivity. Qed.

Example scc_2 : scc one = two.
Proof. reflexivity. Qed.

Example scc_3 : scc two = three.
Proof. reflexivity. Qed.

(** [] *)

(** **** Exercise: 3 stars, advanced (church_plus) *)

(** Define a function that computes the addition of two Church
    numerals.  Given [fun X f x => f^n x] and [fun X f x => f^m x] as
    input, [plus] should produce [fun X f x => f^(n + m) x] as output.
    In other words, do it [n] times, then do it [m] more times.

    Hint: the "zero" argument to a Church numeral need not be just
    [x]. *)

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

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

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

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

(** [] *)

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

(** Define a function that computes the multiplication of two Church
    numerals.

    Hint: the "successor" argument to a Church numeral need not be
    just [f].

    Warning: Coq will not let you pass [cnat] itself as the type [X]
    argument to a Church numeral; you will get a "Universe
    inconsistency" error. That is Coq's way of preventing a paradox in
    which a type contains itself. So leave the type argument
    unchanged. *)

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

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

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

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

(** [] *)

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

(** Exponentiation: *)

(** Define a function that computes the exponentiation of two Church
    numerals.

    Hint: the type argument to a Church numeral need not just be [X].
    But again, you cannot pass [cnat] itself as the type argument.
    Finding the right type can be tricky. *)

Definition exp (n m : cnat) : cnat
  := fun (X : Type) => m (X -> X) (n X).

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

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

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

(** [] *)

End Church.
End Exercises.

(* 2022-08-08 17:13 *)


Require Import Program.Basics.

Open Scope program_scope.

(* typeclass and laws *)

Class Profunctor (p : Type -> Type -> Type) :=
{ dimap {A A' B B'} (f : A' -> A) (g : B -> B') : p A B -> p A' B'
; lmap {A A' B} (f : A' -> A) : p A B -> p A' B := dimap f id
; rmap {A B B'} (f : B -> B') : p A B -> p A B' := dimap id f
}.

Class ProfunctorDec p `{Profunctor p} :=
{ profunctor_id : forall A B (pab : p A B), dimap id id pab = pab
; profunctor_comp : forall A A' A'' B B' B'' (pab : p A B)
                          (f : A'' -> A') (f' : A' -> A)
                          (g' : B -> B') (g : B' -> B''),
    dimap (f' ∘ f) (g ∘ g') pab = (dimap f g ∘ dimap f' g') pab
}.

(* cartesian profunctor *)

Class Cartesian p `{ProfunctorDec p} :=
{ first  {A B C} (pab : p A B) : p (prod A C) (prod B C)
; second {A B C} (pab : p A B) : p (prod C A) (prod C B)
}.

(* auxiliar defs to define cartesian laws *)

Definition r1  {A} (a1 : prod A unit) : A := fst a1.
Definition r1' {A} (a: A) : prod A unit := (a, tt).

Definition assoc {A B C} (a_bc : prod A (prod B C)) : prod (prod A B) C :=
  match a_bc with | pair a (pair b c) => pair (pair a b) c end.
Definition assoc' {A B C} (ab_c : prod (prod A B) C) : prod A (prod B C) :=
  match ab_c with | pair (pair a b) c => pair a (pair b c) end.

Class CartesianDec p `{Cartesian p} :=
{ cartesian_unit : forall A B (h : p A B), dimap r1 r1' h = first h
; cartesian_assoc : forall A B C (h : p A A),
                           dimap assoc assoc' (first (first h)) = @first p _ _ _ A A (prod B C) h
}.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

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

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

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

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
   + intros. reflexivity.
   + destruct n2.
   * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
   * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
   + intros. destruct n. reflexivity. reflexivity.
   + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (v : natural) (w : natural) (x : natural) (y : natural) (z : lst), eq (drop (Succ v) (drop w (drop x (Cons y z)))) (drop v (drop w (drop x z))).
Proof.
intros.
rewrite lem.
rewrite lem. reflexivity.
Qed.


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

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

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

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

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

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

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

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

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

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

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


Inductive truth : Set := Yes | No | Maybe.

Definition not (t : truth): truth :=
  match t with
  | Yes => No
  | No => Yes
  | Maybe => Maybe
  end.

Definition and (t1 : truth) (t2 : truth) : truth :=
  match t1 with
  | Yes => t2
  | No => No
  | Maybe =>
    match t2 with
    | Yes => Maybe
    | No => No
    | Maybe => Maybe
    end
  end.

Definition or (t1 : truth) (t2 : truth) : truth :=
  match t1 with
  | Yes => Yes
  | No => t2
  | Maybe =>
    match t2 with
    | Yes => Yes
    | No => Maybe
    | Maybe => Maybe
    end
  end.

Theorem and_commutative : forall t1 t2 : truth, and t1 t2 = and t2 t1.
  destruct t1; destruct t2; reflexivity.
Qed.

Theorem and_distributes_over_or : forall t1 t2 t3 : truth,
    and t1 (or t2 t3) = or (and t1 t2) (and t1 t3).
  destruct t1; destruct t2; destruct t3; reflexivity.
Qed.


Require Import QArith.
Require Import Setoid.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import profinite.
Require Import cusl.

Require Import rational_intervals.
Require Import realdom.

Require Import Qabs.
Require Import Qminmax.

Section cuts.
  Record cut  := Cut
    { cut_upper : eset Qpreord
    ; cut_lower : eset Qpreord
    ; cut_proper : forall u l, u ∈ cut_upper -> l ∈ cut_lower -> l <= u
    ; cut_is_lower : forall (q1 q2:Qpreord), q1 <= q2 -> q2 ∈ cut_lower -> q1 ∈ cut_lower
    ; cut_is_upper : forall (q1 q2:Qpreord), q1 <= q2 -> q1 ∈ cut_upper -> q2 ∈ cut_upper
     (** probably should reformulate the prereals as directed sets of
         intervals where the endpoints may be -∞ or ∞.
       *)
    ; cut_nonextended : (exists x, x ∈ cut_upper) <-> (exists x, x ∈ cut_lower)
    }.

  Definition cut_ord (x y:cut) :=
    cut_upper x ⊆ cut_upper y /\
    cut_lower x ⊆ cut_lower y.

  Program Definition cut_ord_mixin : Preord.mixin_of cut :=
    Preord.Mixin cut cut_ord _ _ .
  Next Obligation.
    intros. red; split; red; auto.
  Qed.
  Next Obligation.
    unfold cut_ord. intuition; repeat intro; eauto.
  Qed.

  Definition cut_preord := Preord.Pack cut cut_ord_mixin.

  Program Definition rints_to_cut
          (X:eset PreRealDom)
          (Hdir:directed true X)
          (Hdown:forall (r r':PreRealDom), r ≤ r' -> r' ∈ X -> r ∈ X )
          : cut :=
    Cut (eimage' _ _ rint_end   X)
        (eimage' _ _ rint_start X)
        _ _ _ _.
  Next Obligation.
    unfold eimage'.
    intros.
    destruct H as [n1 ?].
    destruct H0 as [n2 ?].
    revert H. case_eq (X n1); intros.
    revert H0. case_eq (X n2); intros.
    destruct H1 as [? _]. destruct H2 as [? _].
    red in H1. simpl in H1.
    red in H2. simpl in H2.
    rewrite H2. rewrite H1.
    destruct (Hdir (c::c0::nil)%list).
    exists c. apply cons_elem; auto.
    red; simpl; intros.
    apply cons_elem in H3. destruct H3. rewrite H3.
    exists n1. rewrite H. auto.
    apply cons_elem in H3. destruct H3. rewrite H3.
    exists n2. rewrite H0. auto.
    apply nil_elem in H3. elim H3.
    destruct H3.
    assert (c ≤ x).
    apply H3. apply cons_elem; auto.
    assert (c0 ≤ x).
    apply H3. apply cons_elem; right. apply cons_elem; auto.
    apply Qle_trans with (rint_start x).
    apply rint_ord_test in H6. intuition.
    apply Qle_trans with (rint_end x).
    apply rint_proper.
    apply rint_ord_test in H5. intuition.
    elim H2.
    elim H1.
  Qed.
  Next Obligation.
    repeat intro.
    unfold eimage' in H0.
    destruct H0 as [n ?].
    revert H0. case_eq (X n); intros.
    destruct H1 as [? _]. red in H1. simpl in H1.
    assert (q1 <= rint_end c).
    apply Qle_trans with q2; auto.
    rewrite H1. apply rint_proper.
    set (r := RatInt q1 (rint_end c) H2).
    assert (r ∈ X).
    apply Hdown with c.
    apply rint_ord_test.
    split; simpl; auto.
    apply Qle_trans with q2; auto.
    rewrite H1; auto.
    apply Qle_refl.
    apply Qle_refl.
    exists n. rewrite H0. auto.
    destruct H3 as [n' ?].
    exists n'.
    unfold eimage'.
    destruct (X n').
    assert (q1 == rint_start c0).
    destruct H3.
    assert (rint_start r == rint_start c0).
    apply rint_ord_test in H3.
    apply rint_ord_test in H4.
    apply Qle_antisym; intuition.
    simpl in H5. auto.
    split; red; simpl; auto.
    symmetry; auto.
    auto.
    elim H1.
  Qed.
  Next Obligation.
    repeat intro.
    unfold eimage' in H0.
    destruct H0 as [n ?].
    revert H0. case_eq (X n); intros.
    destruct H1 as [? _]. red in H1. simpl in H1.
    assert (rint_start c <= q2).
    apply Qle_trans with q1; auto.
    rewrite H1. apply rint_proper.
    set (r := RatInt (rint_start c) q2 H2).
    assert (r ∈ X).
    apply Hdown with c.
    apply rint_ord_test.
    split; simpl; auto.
    apply Qle_refl.
    apply Qle_trans with q1; auto.
    rewrite H1; auto.
    apply Qle_refl.
    exists n. rewrite H0. auto.
    destruct H3 as [n' ?].
    exists n'.
    unfold eimage'.
    destruct (X n').
    assert (q2 == rint_end c0).
    destruct H3.
    assert (rint_end r == rint_end c0).
    apply rint_ord_test in H3.
    apply rint_ord_test in H4.
    apply Qle_antisym; intuition.
    simpl in H5. auto.
    split; red; simpl; auto.
    symmetry; auto.
    auto.
    elim H1.
  Qed.
  Next Obligation.
    intros.
    unfold eimage'.
    split; intros [x ?].
    destruct H as [n ?].
    revert H. case_eq (X n); intros.
    exists (rint_start c).
    exists n. rewrite H. auto.
    elim H0.
    destruct H as [n ?].
    revert H. case_eq (X n); intros.
    exists (rint_end c).
    exists n. rewrite H. auto.
    elim H0.
  Qed.

  Lemma rints_to_cut_upper q X Hdir Hdown :
    q ∈ cut_upper (rints_to_cut X Hdir Hdown) <->
    exists r, r ∈ X /\ q == rint_end r.
  Proof.
    simpl; intros. unfold eimage'.
    split; intros.
    destruct H as [n ?].
    revert H. case_eq (X n); intros.
    exists c. split.
    exists n. rewrite H; auto.
    destruct H0; auto.
    elim H0.
    destruct H as [r [??]].
    destruct H as [n ?]. exists n.
    destruct (X n); auto.
    assert (rint_end r == rint_end c).
    destruct H.
    apply rint_ord_test in H.
    apply rint_ord_test in H1.
    apply Qle_antisym; intuition.
    rewrite H1 in H0.
    split; red; simpl; auto.
    symmetry; auto.
  Qed.

  Lemma rints_to_cut_lower q X Hdir Hdown :
    q ∈ cut_lower (rints_to_cut X Hdir Hdown) <->
    exists r, r ∈ X /\ q == rint_start r.
  Proof.
    simpl; intros. unfold eimage'.
    split; intros.
    destruct H as [n ?].
    revert H. case_eq (X n); intros.
    exists c. split.
    exists n. rewrite H; auto.
    destruct H0; auto.
    elim H0.
    destruct H as [r [??]].
    destruct H as [n ?]. exists n.
    destruct (X n); auto.
    assert (rint_start r == rint_start c).
    destruct H.
    apply rint_ord_test in H.
    apply rint_ord_test in H1.
    apply Qle_antisym; intuition.
    rewrite H1 in H0.
    split; red; simpl; auto.
    symmetry; auto.
  Qed.

  Opaque rints_to_cut.

  Parameter A:∂PLT.

  Program Definition hom_to_cut (f:A → PreRealDom) : PLT.ord A → cut_preord :=
    Preord.Hom (PLT.ord A) cut_preord
               (fun a => rints_to_cut (erel_image _ _ (PLT.dec A) (PLT.hom_rel f) a)
                                    (PLT.hom_directed _ _ _ f a)
                                     _)
               _.
  Next Obligation.
    intros.
    apply erel_image_elem in H0.
    apply erel_image_elem.
    revert H0. apply PLT.hom_order; auto.
  Qed.
  Next Obligation.
    simpl; intros.
    assert (erel_image _ _ (PLT.dec A) (PLT.hom_rel f) a ⊆
            erel_image _ _ (PLT.dec A) (PLT.hom_rel f) b).
    red; simpl; intros.
    apply erel_image_elem in H0.
    apply erel_image_elem.
    revert H0.
    apply PLT.hom_order; auto.

    split; red; intros.
    apply rints_to_cut_upper in H1.
    apply rints_to_cut_upper.
    destruct H1 as [r [??]]. exists r; split; auto.
    apply rints_to_cut_lower in H1.
    apply rints_to_cut_lower.
    destruct H1 as [r [??]]. exists r; split; auto.
  Qed.

  Program Definition cut_to_hom_rel (f:PLT.ord A → cut_preord) : erel A PreRealDom :=
    @esubset (prod_preord A PreRealDom)
            (fun ar => rint_end (snd ar) ∈ cut_upper (f (fst ar)) /\
                       rint_start (snd ar) ∈ cut_lower (f (fst ar)))
            _
            (eff_enum _ (effective_prod (PLT.effective A) (PLT.effective PreRealDom))).
  Next Obligation.
    intros.
    apply semidec_conj.
    apply semidec_in.
    constructor. apply Qeq_dec.
    apply semidec_in.
    constructor. apply Qeq_dec.
  Qed.

  Lemma cut_to_hom_rel_elem (f:PLT.ord A → cut_preord) a r :
    (a,r) ∈ cut_to_hom_rel f <->
       (rint_end r ∈ cut_upper (f a) /\ rint_start r ∈ cut_lower (f a)).
  Proof.
    unfold cut_to_hom_rel.
    rewrite esubset_elem. intuition.
    apply eprod_elem; split; apply eff_complete.
    simpl; intros.
    destruct H as [[??][??]].
    intuition.
    cut (rint_end (snd b) ∈ cut_upper (f (fst a0))).
    destruct (Preord.axiom _ _ f (fst a0) (fst b)); auto.
    revert H4. apply cut_is_upper.
    apply rint_ord_test in H3. intuition.
    cut (rint_start (snd b) ∈ cut_lower (f (fst a0))).
    destruct (Preord.axiom _ _ f (fst a0) (fst b)); auto.
    revert H5. apply cut_is_lower.
    apply rint_ord_test in H3. intuition.
  Qed.

  Program Definition cut_to_hom (f:PLT.ord A → cut_preord) : A → PreRealDom :=
    PLT.Hom true A PreRealDom (cut_to_hom_rel f) _ _.
  Next Obligation.
    simpl; intros.
    apply cut_to_hom_rel_elem in H1.
    apply cut_to_hom_rel_elem.
    apply rint_ord_test in H0.
    intuition.
    cut (rint_end y' ∈ cut_upper (f x)).
    destruct (Preord.axiom _ _ f x x'); auto.
    revert H0.
    apply cut_is_upper; auto.
    cut (rint_start y' ∈ cut_lower(f x)).
    destruct (Preord.axiom _ _ f x x'); auto.
    revert H4.
    apply cut_is_lower; auto.
  Qed.
  Next Obligation.
    intros f a. apply prove_directed; auto.
    intros.
    apply erel_image_elem in H.
    apply erel_image_elem in H0.
    apply cut_to_hom_rel_elem in H.
    apply cut_to_hom_rel_elem in H0.
    destruct H. destruct H0.
    assert (Qmax (rint_start x) (rint_start y) <= Qmin (rint_end x) (rint_end y)).
    apply Q.max_case.
    intros. rewrite <- H3; auto.
    apply Q.min_case.
    intros. rewrite <- H3; auto.
    eapply cut_proper; eauto.
    eapply cut_proper; eauto.
    apply Q.min_case.
    intros. rewrite <- H3; auto.
    eapply cut_proper; eauto.
    eapply cut_proper; eauto.
    exists (RatInt _ _ H3).
    split.
    apply rint_ord_test. simpl.
    split. apply Q.le_max_l. apply Q.le_min_l.
    split.
    apply rint_ord_test. simpl.
    split. apply Q.le_max_r. apply Q.le_min_r.
    apply erel_image_elem.
    apply cut_to_hom_rel_elem.
    simpl. split.
    apply Q.min_case; simpl; auto.
    intros p q ?. apply member_eq.
    split; red; simpl; auto. symmetry; auto.
    apply Q.max_case; simpl; auto.
    intros p q ?. apply member_eq.
    split; red; simpl; auto. symmetry; auto.
  Qed.

  Lemma cut_roundtrip1 f :
    cut_to_hom (hom_to_cut f) ≈ f.
  Proof.
    split; hnf; simpl; intros [a r] H.
    apply cut_to_hom_rel_elem in H. destruct H.
    simpl in *.
    rewrite rints_to_cut_upper in H.
    rewrite rints_to_cut_lower in H0.
    destruct H as [r1 [??]].
    destruct H0 as [r2 [??]].
    apply erel_image_elem in H.
    apply erel_image_elem in H0.
    destruct (plt_hom_directed2 _ _ _ f a r1 r2) as [r' [?[??]]]; auto.
    apply PLT.hom_order with a r'; auto.
    apply rint_ord_test.
    apply rint_ord_test in H4.
    apply rint_ord_test in H5.
    split.
    rewrite H2; intuition.
    rewrite H1; intuition.

    apply cut_to_hom_rel_elem.
    split; simpl.
    rewrite rints_to_cut_upper.
    exists r. split; auto.
    apply erel_image_elem. auto. reflexivity.
    rewrite rints_to_cut_lower.
    exists r. split; auto.
    apply erel_image_elem. auto. reflexivity.
  Qed.

  Lemma cut_roundtrip2 f :
    hom_to_cut (cut_to_hom f) ≈ f.
  Proof.
    intro a. split; split; simpl; hnf; intros.
    apply rints_to_cut_upper in H.
    destruct H as [r [??]].
    apply erel_image_elem in H.
    apply cut_to_hom_rel_elem in H. destruct H.
    revert H. apply member_eq.
    split; red; simpl; auto. symmetry; auto.
    apply rints_to_cut_lower in H.
    destruct H as [r [??]].
    apply erel_image_elem in H.
    apply cut_to_hom_rel_elem in H. destruct H.
    revert H1. apply member_eq.
    split; red; simpl; auto. symmetry; auto.

    apply rints_to_cut_upper.
    destruct (cut_nonextended (f a)) as [? _].
    destruct H0 as [z ?]; eauto.
    assert (z <= a0).
    eapply cut_proper; eauto.
    exists (RatInt z a0 H1).
    split; simpl; auto.
    apply erel_image_elem.
    apply cut_to_hom_rel_elem.
    simpl. split; auto. reflexivity.

    apply rints_to_cut_lower.
    destruct (cut_nonextended (f a)) as [_ ?].
    destruct H0 as [z ?]; eauto.
    assert (a0 <= z).
    eapply cut_proper; eauto.
    exists (RatInt a0 z H1).
    split; simpl; auto.
    apply erel_image_elem.
    apply cut_to_hom_rel_elem.
    simpl. split; auto. reflexivity.
  Qed.

  Definition cut_canonical (x:cut) :=
    (forall u, u ∈ cut_upper x -> exists u', u' ∈ cut_upper x /\ u' < u) /\
    (forall l, l ∈ cut_lower x -> exists l', l' ∈ cut_lower x /\ l < l').

  Definition located (x:cut) :=
    forall (ε:Q), ε > 0 ->
      exists u l,
        u ∈ cut_upper x /\
        l ∈ cut_lower x /\
        u - l <= ε.

  Lemma canonical_to_hom (f:PLT.ord A → cut_preord) :
    (forall a, cut_canonical (f a)) ->
    canonical A (cut_to_hom f).
  Proof.
    repeat intro.
    destruct (H a).
    simpl in H0.
    apply cut_to_hom_rel_elem in H0. destruct H0.
    destruct (H1 (rint_end x)) as [u' [??]]; auto.
    destruct (H2 (rint_start x)) as [l' [??]]; auto.
    assert (l' <= u').
    apply cut_proper with (f a); auto.
    exists (RatInt l' u' H8).
    split; simpl.
    apply cut_to_hom_rel_elem; split; simpl; auto.
    red; split; simpl; auto.
  Qed.

  Lemma canonical_to_cut (f:A → PreRealDom) :
    canonical A f ->
    forall a, cut_canonical (hom_to_cut f a).
  Proof.
    repeat intro.
    split; simpl; intros.
    apply rints_to_cut_upper in H0.
    destruct H0 as [r [??]].
    apply erel_image_elem in H0.
    destruct (H a r) as [r' [??]]; auto.
    exists (rint_end r').
    split.
    apply rints_to_cut_upper.
    exists r'. split.
    apply erel_image_elem. auto.
    reflexivity.
    rewrite H1.
    destruct H3; auto.
    apply rints_to_cut_lower in H0.
    destruct H0 as [r [??]].
    apply erel_image_elem in H0.
    destruct (H a r) as [r' [??]]; auto.
    exists (rint_start r').
    split.
    apply rints_to_cut_lower.
    exists r'. split.
    apply erel_image_elem. auto.
    reflexivity.
    rewrite H1.
    destruct H3; auto.
  Qed.

  Lemma located_converges (f:PLT.ord A → cut_preord) :
    (forall a, located (f a)) ->
   realdom_converges A (cut_to_hom f).
  Proof.
    repeat intro.
    destruct (H a ε) as [u [l [?[??]]]]; auto.
    assert (l <= u).
    apply cut_proper with (f a); auto.
    exists (RatInt l u H4). split; simpl; auto.
    apply cut_to_hom_rel_elem. split; simpl; auto.
  Qed.

  Lemma converges_located (f:A → PreRealDom) :
    realdom_converges A f ->
    forall a, located (hom_to_cut f a).
  Proof.
    repeat intro.
    destruct (H a ε) as [r [??]]; auto.
    exists (rint_end r), (rint_start r); split; simpl; auto.
    apply rints_to_cut_upper.
    exists r; split; auto.
    apply erel_image_elem. auto. reflexivity.
    split.
    apply rints_to_cut_lower.
    exists r; split; auto.
    apply erel_image_elem. auto. reflexivity.
    auto.
  Qed.

  Lemma hom_to_cut_mono (f g:A → PreRealDom) :
    f ≤ g -> hom_to_cut f ≤ hom_to_cut g.
  Proof.
    repeat intro.
    split; red; simpl; intros.
    apply rints_to_cut_upper in H0.
    apply rints_to_cut_upper.
    destruct H0 as [r [??]].
    exists r. split; auto.
    apply erel_image_elem in H0.
    apply erel_image_elem.
    apply H; auto.
    apply rints_to_cut_lower in H0.
    apply rints_to_cut_lower.
    destruct H0 as [r [??]].
    exists r. split; auto.
    apply erel_image_elem in H0.
    apply erel_image_elem.
    apply H; auto.
  Qed.

  Lemma cut_to_hom_mono (f g:PLT.ord A → cut_preord) :
    f ≤ g -> cut_to_hom f ≤ cut_to_hom g.
  Proof.
    repeat intro; simpl in *.
    destruct a as [a r].
    apply cut_to_hom_rel_elem in H0.
    apply cut_to_hom_rel_elem.
    destruct H0. split.
    apply (H a); auto.
    apply (H a); auto.
  Qed.

End cuts.

Canonical Structure cut_preord.

Definition cut_lt (x y:cut) :=
  exists u l,
    u ∈ cut_upper x /\
    l ∈ cut_lower y /\
    u < l.

Module interval_limit_cuts.

Section limit.
  Variable seq_upper : N -> cut.
  Variable seq_lower : N -> cut.

  Hypothesis seq_proper : forall n, cut_lt (seq_lower n) (seq_upper n).
  Hypothesis seq_upper_inside : forall n m, (n < m)%N -> cut_lt (seq_upper m) (seq_upper n).
  Hypothesis seq_lower_inside : forall n m, (n < m)%N -> cut_lt (seq_lower n) (seq_lower m).

  Definition limit_upper : eset Qpreord :=
    union ( (fun n => Some (cut_upper (seq_upper n))) : eset (eset Qpreord)).

  Definition limit_lower : eset Qpreord :=
    union ( (fun n => Some (cut_lower (seq_lower n)))  : eset (eset Qpreord)).

  Program Definition interval_limit : cut :=
    Cut limit_upper limit_lower _ _ _ _.
  Next Obligation.
    unfold limit_upper, limit_lower. intros.
    apply union_axiom in H.
    apply union_axiom in H0.
    destruct H as [XU [??]].
    destruct H0 as [XL [??]].
    destruct H as [n1 ?].
    destruct H0 as [n2 ?].
    set (o := (1 + N.max n1 n2)%N).
    destruct (seq_lower_inside n2 (1 + N.max n1 n2)) as [a [b [?[??]]]].
    zify. omega.
    apply Qle_trans with a.
    apply cut_proper with (seq_lower n2); auto.
    rewrite <- H0; auto.
    apply Qle_trans with b.
    intuition.
    destruct (seq_proper (1 + N.max n1 n2)) as [c [d [?[??]]]].
    apply Qle_trans with c.
    apply cut_proper with (seq_lower (1 + N.max n1 n2)); auto.
    apply Qle_trans with d.
    intuition.
    destruct (seq_upper_inside n1 (1 + N.max n1 n2)) as [e [f [?[??]]]].
    zify. omega.
    apply Qle_trans with e.
    apply cut_proper with (seq_upper (1 + N.max n1 n2)); auto.
    apply Qle_trans with f.
    intuition.
    apply cut_proper with (seq_upper n1); auto.
    rewrite <- H. auto.
  Qed.
  Next Obligation.
    unfold limit_lower; intros.
    apply union_axiom in H0.
    destruct H0 as [X [??]].
    destruct H0 as [n ?].
    apply union_axiom.
    exists X. split; auto.
    exists n. auto.
    rewrite H0. rewrite H0 in H1.
    revert H1. apply cut_is_lower. auto.
  Qed.
  Next Obligation.
    unfold limit_upper; intros.
    apply union_axiom in H0.
    destruct H0 as [X [??]].
    destruct H0 as [n ?].
    apply union_axiom.
    exists X. split; auto.
    exists n. auto.
    rewrite H0. rewrite H0 in H1.
    revert H1. apply cut_is_upper. auto.
  Qed.
  Next Obligation.
    unfold limit_upper, limit_lower.
    destruct (seq_proper 0) as [u [l [?[??]]]].
    split; intros.
    destruct (cut_nonextended (seq_lower 0)).
    destruct H3 as [l' ?].
    exists u. auto.
    exists l'.
    apply union_axiom.
    exists (cut_lower (seq_lower 0)).
    split; auto.
    exists 0%N. auto.

    destruct (cut_nonextended (seq_upper 0)).
    destruct H4 as [u' ?].
    exists l. auto.
    exists u'.
    apply union_axiom.
    exists (cut_upper (seq_upper 0)).
    split; auto.
    exists 0%N. auto.
  Qed.

  Lemma interval_limit_inside_upper : forall n,
    cut_lt interval_limit (seq_upper n).
  Proof.
    repeat intro. hnf.
    destruct (seq_upper_inside n (n+1)) as [u' [l' [?[??]]]].
    zify. omega.
    exists u'. exists l'. intuition.
    unfold interval_limit. simpl.
    unfold limit_upper.
    apply union_axiom.
    exists (cut_upper (seq_upper (n+1))).
    split. exists (n+1)%N. auto.
    auto.
  Qed.

  Lemma interval_limit_inside_lower : forall n,
    cut_lt (seq_lower n) interval_limit.
  Proof.
    repeat intro. hnf.
    destruct (seq_lower_inside n (n+1)) as [u' [l' [?[??]]]].
    zify. omega.
    exists u'. exists l'. intuition.
    unfold interval_limit. simpl.
    unfold limit_upper.
    apply union_axiom.
    exists (cut_lower (seq_lower (n+1))).
    split. exists (n+1)%N. auto.
    auto.
  Qed.

  Lemma interval_limit_least_defined lim :
    (forall n, cut_lt lim (seq_upper n)) ->
    (forall n, cut_lt (seq_lower n) lim) ->
    interval_limit ≤ lim.
  Proof.
    repeat intro. split; hnf; simpl; intros.

    unfold limit_upper in H1.
    apply union_axiom in H1.
    destruct H1 as [X [??]].
    destruct H1 as [n ?].
    destruct (H n) as [u [l [?[??]]]].
    rewrite H1 in H2.
    apply cut_is_upper with u; auto.
    apply Qle_trans with l; intuition.
    apply cut_proper with (seq_upper n); auto.

    unfold limit_lower in H1.
    apply union_axiom in H1.
    destruct H1 as [X [??]].
    destruct H1 as [n ?].
    destruct (H0 n) as [u [l [?[??]]]].
    rewrite H1 in H2.
    apply cut_is_lower with l; auto.
    apply Qle_trans with u; intuition.
    apply cut_proper with (seq_lower n); auto.
  Qed.

  Hypothesis seq_converges : forall ε, 0 < ε ->
     exists n a b,
       a ∈ cut_upper (seq_upper n) /\
       b ∈ cut_lower (seq_lower n) /\
       a - b <= ε.

  Lemma interval_limit_located : located interval_limit.
  Proof.
    red; intros.
    destruct (seq_converges ε H) as [n [a [b [?[??]]]]].
    exists a. exists b. intuition.
    simpl. unfold limit_upper.
    apply union_axiom. exists (cut_upper (seq_upper n)).
    split; auto. exists n. auto.
    apply union_axiom. exists (cut_lower (seq_lower n)).
    split; auto. exists n. auto.
  Qed.
End limit.
End interval_limit_cuts.

Definition pow2 (n:N) : positive :=
 match n with
 | N0     => 1%positive
 | Npos p => shift_pos p 1
 end.

Lemma pow2_commute n1 n2 :
  (pow2 n1 * pow2 n2 = pow2 (n1+n2))%positive.
Proof.
  unfold pow2.
  destruct n1; simpl; auto.
  destruct n2; simpl; auto.
  apply Pos.mul_1_r.
  unfold shift_pos.
  rewrite Pos.iter_add.
  induction p using Pos.peano_ind; simpl; auto.
  rewrite Pos.iter_succ. simpl.
  rewrite IHp.
  rewrite Pos.iter_succ. auto.
Qed.

Lemma pow2_div_eq (a b:N) :
  (a <= b)%N -> (pow2 (b - a) * pow2 a = pow2 b)%positive.
Proof.
  intros.
  rewrite pow2_commute.
  replace (b - a + a)%N with b; auto.
  assert (0 <= a)%N.
  hnf. simpl. destruct a; discriminate.
  symmetry. apply N.sub_add; auto.
Qed.

Definition oneOver2n (n:N) : Q := (1 # pow2 n)%Q.

Lemma oneOver2n_pos n : 0 < oneOver2n n.
Proof.
  unfold oneOver2n. intuition.
Qed.

Lemma oneOver2n_commute n1 n2 :
  (oneOver2n n1 * oneOver2n n2 == oneOver2n (n1+n2))%Q.
Proof.
  unfold oneOver2n.
  red. simpl. symmetry.
  f_equal. apply pow2_commute.
Qed.

Lemma oneOver2n_div_eq a b  :
  (a <= b)%N -> (oneOver2n (b - a) * oneOver2n a == oneOver2n b)%Q.
Proof.
  intro.
  unfold oneOver2n.
  red. simpl. symmetry.
  f_equal. apply pow2_div_eq. auto.
Qed.

Lemma pow2_ge1 (a:N) :
  (1 <= pow2 a)%positive.
Proof.
  induction a using N.peano_ind.
  simpl. reflexivity.
  replace (N.succ a) with (1+a)%N.
  2: zify; omega.
  rewrite <- pow2_commute.
  simpl pow2 at 1. unfold shift_pos. simpl Pos.iter.
  zify. omega.
Qed.

Lemma pow2_mono (a b:N) :
  (a <= b)%N -> (pow2 a <= pow2 b)%positive.
Proof.
  revert b. induction a using N.peano_ind.
  simpl; intros.
  apply pow2_ge1.
  intro b. induction b using N.peano_ind.
  intros.
  elimtype False. zify. omega.
  intros.
  replace (N.succ a) with (1+a)%N.
  replace (N.succ b) with (1+b)%N.
  2: zify; omega.
  2: zify; omega.
  rewrite <- pow2_commute.
  rewrite <- pow2_commute.
  cut (pow2 a <= pow2 b)%positive.
  simpl. zify. omega.
  apply IHa. zify. omega.
Qed.

Lemma oneOver2n_subsumes (a b c:N) :
    (a < b)%N -> (a < c)%N ->
       oneOver2n b + oneOver2n c <= oneOver2n a.
Proof.
  intros. unfold oneOver2n.
  red. simpl.
  cut ((pow2 c + pow2 b) * pow2 a <= (pow2 b * pow2 c))%positive. auto.
  rewrite pow2_commute.
  rewrite Pos.mul_add_distr_r.
  rewrite pow2_commute.
  rewrite pow2_commute.
  replace (b + c)%N with (1 + (b+c-1))%N by (zify; omega).
  rewrite <- (pow2_commute 1).
  simpl pow2 at 3. unfold shift_pos. simpl Pos.iter.
  replace 2%positive with (1 + 1)%positive.
  rewrite Pos.mul_add_distr_r.
  simpl.
  apply Pos.add_le_mono.
  apply pow2_mono.
  zify. omega.
  apply pow2_mono.
  zify. omega.
  zify. omega.
Qed.

Fixpoint pos_log2 (p:positive) : N :=
  match p with
    | xH => 1%N
    | xO p' => N.succ (pos_log2 p')
    | xI p' => N.succ (pos_log2 p')
  end.

Lemma pow2_succ (n:N) : (pow2 (N.succ n) = (pow2 n)~0)%positive.
Proof.
  destruct n.
  compute. auto.
  simpl.
  unfold shift_pos. simpl.
  rewrite Pos.iter_succ.
  auto.
Qed.

Lemma pow2_pos_log2 (p:positive) : (p < pow2 (pos_log2 p))%positive.
Proof.
  red. unfold Pos.compare.
  generalize Eq.
  induction p.
  simpl; intros.
  rewrite pow2_succ.
  simpl. apply IHp.
  simpl; intros.
  rewrite pow2_succ.
  simpl. apply IHp.
  simpl. auto.
Qed.

Lemma oneOver2n_small : forall ε:Q, 0 < ε -> exists n, oneOver2n n <= ε.
Proof.
  intros.
  exists (pos_log2 (Qden ε)).
  destruct ε.
  red in H. simpl in H.
  ring_simplify in H.
  simpl.
  red; simpl.
  apply Z.le_trans with (1 * 'Qden)%Z.
  simpl. reflexivity.
  apply Zmult_le_compat.
  omega.
  cut ( Qden <  pow2 (pos_log2 Qden))%positive.
  zify. omega.
  apply pow2_pos_log2.
  omega.
  compute. discriminate.
Qed.

Module cauchy_limit_cuts.

Program Definition widen_cut (n:N) (x:cut) : cut :=
  Cut (image (Preord.Hom _ _ (Qplus (oneOver2n n)) _) (cut_upper x))
      (image (Preord.Hom _ _ (Qplus (- oneOver2n n)) _) (cut_lower x))
      _ _ _ _.
Next Obligation.
  intros. red in H. simpl in H.
  red. simpl. rewrite H. reflexivity.
Qed.
Next Obligation.
  intros. red in H. simpl in H.
  red. simpl. rewrite H. reflexivity.
Qed.
Next Obligation.
  simpl; intros.
  apply image_axiom2 in H.
  apply image_axiom2 in H0.
  destruct H as [q1 [??]].
  destruct H0 as [q2 [??]].
  simpl in *.
  destruct H1. red in H1. simpl in H1.
  destruct H2. red in H2. simpl in H2.
  rewrite H2. rewrite H1.
  apply Qle_trans with (0 + q2)%Q.
  apply Qplus_le_compat.
  rewrite <- (Qplus_le_l _ _ (oneOver2n n)).
  ring_simplify.
  apply Qlt_le_weak.
  apply oneOver2n_pos.
  apply Qle_refl.
  apply Qle_trans with (0 + q1)%Q.
  apply Qplus_le_compat; auto.
  apply Qle_refl.
  apply cut_proper with x; auto.
  apply Qplus_le_compat.
  apply Qlt_le_weak.
  apply oneOver2n_pos.
  apply Qle_refl.
Qed.
Next Obligation.
  intros.
  apply image_axiom2 in H0.
  destruct H0 as [y [??]]. simpl in *.
  apply image_axiom1'.
  exists (q1 + oneOver2n n)%Q.
  split. simpl.
  split; red; simpl; ring.
  eapply cut_is_lower; eauto.
  destruct H1. red in H1. simpl in H1.
  rewrite <- (Qplus_le_l _ _ (-oneOver2n n)).
  ring_simplify.
  apply Qle_trans with q2; auto.
  rewrite H1.
  ring_simplify. apply Qle_refl.
Qed.
Next Obligation.
  intros.
  apply image_axiom2 in H0.
  destruct H0 as [y [??]]. simpl in *.
  apply image_axiom1'.
  exists (q2 - oneOver2n n)%Q.
  split. simpl.
  split; red; simpl; ring.
  eapply cut_is_upper; eauto.
  destruct H1. red in H1. simpl in H1.
  rewrite <- (Qplus_le_l _ _ (oneOver2n n)).
  ring_simplify.
  apply Qle_trans with q1; auto.
  rewrite H1.
  ring_simplify. apply Qle_refl.
Qed.
Next Obligation.
  intros. split; intros [q ?].
  apply image_axiom2 in H.
  destruct H as [y [??]]; simpl in *.
  destruct (cut_nonextended x).
  destruct H1 as [z ?]; eauto.
  exists (- oneOver2n n + z)%Q.
  apply image_axiom1'. exists z. split; auto.
  apply image_axiom2 in H.
  destruct H as [y [??]]; simpl in *.
  destruct (cut_nonextended x).
  destruct H2 as [z ?]; eauto.
  exists (oneOver2n n + z)%Q.
  apply image_axiom1'. exists z. split; auto.
Qed.

Definition near ε (x y:cut) :=
  (exists u l, u ∈ cut_upper x /\ l ∈ cut_lower y /\ u - l <= ε) /\
  (exists u l, u ∈ cut_upper y /\ l ∈ cut_lower x /\ u - l <= ε).

Definition is_limit (seq:N -> cut) (c:cut) :=
  forall ε:Q, ε > 0 ->
    exists m:N, forall (n:N), (m <= n)%N -> near ε (seq n) c.

Lemma is_limit_located seq lim : is_limit seq lim -> located lim.
Proof.
  red; intros.
  destruct (H (ε/(2#1))); auto.
  apply Qlt_shift_div_l.
  compute. auto.
  ring_simplify. auto.
  destruct (H1 x). reflexivity.
  destruct H2 as [u1 [l1 [?[??]]]].
  destruct H3 as [u2 [l2 [?[??]]]].
  exists u2. exists l1.
  split; auto. split; auto.
  rewrite <- (Qplus_le_l _ _ l1).
  rewrite <- (Qplus_le_l _ _ (-l2)).
  ring_simplify.
  apply Qle_trans with (ε/(2#1)).
  ring_simplify in H7; auto.
  rewrite <- (Qplus_le_l _ _ u1).
  rewrite <- (Qplus_le_l _ _ (-l1)).
  ring_simplify.
  apply Qle_trans with (ε/(2#1) + ε/(2#1) )%Q.
  rewrite <- Qplus_assoc.
  apply Qplus_le_compat. apply Qle_refl.
  ring_simplify in H5. auto.
  rewrite <- (Qplus_le_l _ _ l2).
  ring_simplify.
  field_simplify.
  cut (ε + l2 <= ε + u1).
  intros. field_simplify in H8. auto.
  apply Qplus_le_compat.
  apply Qle_refl.
  eapply cut_proper; eauto.
Qed.

Definition cauchy_sequence (seq:N -> cut) :=
  forall n m o,
     (o <= m)%N -> (o <= n)%N ->
        exists u, u ∈ cut_upper (seq m) /\
        exists l, l ∈ cut_lower (seq n) /\
        u - l < oneOver2n o.

Section cut_cauchy_limit.
  Variable seq : N -> cut.
  Hypothesis seq_cauchy : cauchy_sequence seq.

  Program Definition limit_uppers (n:N) : eset Qpreord :=
    image (Preord.Hom _ _ (Qplus (oneOver2n n)) _) (cut_upper (seq n)).
  Next Obligation.
    intros. red; simpl.
    red in H. simpl in H. rewrite H. reflexivity.
  Qed.

  Program Definition limit_lowers (n:N) : eset Qpreord :=
    image (Preord.Hom _ _ (Qplus (-oneOver2n n)) _) (cut_lower (seq n)).
  Next Obligation.
    intros. red; simpl.
    red in H. simpl in H. rewrite H. reflexivity.
  Qed.

  Definition limit_upper : eset Qpreord :=
    union ( (fun n => Some (limit_uppers n)) : eset (eset Qpreord)).

  Definition limit_lower : eset Qpreord :=
    union ( (fun n => Some (limit_lowers n)) : eset (eset Qpreord)).

  Program Definition limit : cut :=
    Cut limit_upper limit_lower _ _ _ _.
  Next Obligation.
    simpl; intros.
    apply union_axiom in H.
    apply union_axiom in H0.
    destruct H as [R [??]].
    destruct H0 as [S [??]].
    destruct H as [n ?].
    destruct H0 as [m ?].
    rewrite H in H1.
    rewrite H0 in H2. clear H H0.
    unfold limit_uppers in H1.
    apply image_axiom2 in H1.
    destruct H1 as [y [??]].
    simpl in *.
    destruct H0 as [? _]. red in H0; simpl in H0.
    rewrite H0.
    unfold limit_lowers in H2.
    apply image_axiom2 in H2.
    destruct H2 as [y' [??]].
    simpl in *.
    destruct H2 as [? _]. red in H2. simpl in H2. rewrite H2.
    destruct (seq_cauchy n m (N.min n m)) as [u' [? [l' [??]]]].
    apply N.le_min_r.
    apply N.le_min_l.
    assert (y' <= u'). eapply cut_proper; eauto.
    assert (l' <= y). eapply cut_proper; eauto.
    rewrite <- (Qplus_le_l _ _ (oneOver2n m)).
    ring_simplify.
    apply Qle_trans with u'; auto.
    rewrite <- (Qplus_le_l _ _ (-l')).
    apply Qle_trans with (oneOver2n (N.min n m)).
    ring_simplify in H5. ring_simplify. intuition.
    rewrite <- (Qplus_le_l _ _ (l')). ring_simplify.
    apply Qplus_le_compat; auto.
    apply N.min_case.
    rewrite <- (Qplus_le_l _ _ (-oneOver2n n)). ring_simplify.
    apply Qlt_le_weak. apply oneOver2n_pos.
    rewrite <- (Qplus_le_l _ _ (-oneOver2n m)). ring_simplify.
    apply Qlt_le_weak. apply oneOver2n_pos.
  Qed.
  Next Obligation.
    unfold limit_lower.
    simpl; intros.
    apply union_axiom in H0.
    apply union_axiom.
    destruct H0 as [X [??]].
    exists X. split; auto.
    destruct H0 as [n ?].
    rewrite H0. rewrite H0 in H1.
    unfold limit_lowers in H1.
    unfold limit_lowers.
    apply image_axiom2 in H1.
    destruct H1 as [q [??]]. simpl in *.
    apply image_axiom1'. simpl.
    exists (q1 + oneOver2n n)%Q.
    split.
    split; red; simpl; ring.
    apply cut_is_lower with q; auto.
    apply Qle_trans with (q2 + oneOver2n n)%Q.
    apply Qplus_le_compat; auto. apply Qle_refl.
    destruct H2. red in H2; simpl in H2. rewrite H2.
    ring_simplify. apply Qle_refl.
  Qed.
  Next Obligation.
    unfold limit_upper.
    simpl; intros.
    apply union_axiom in H0.
    apply union_axiom.
    destruct H0 as [X [??]].
    exists X. split; auto.
    destruct H0 as [n ?].
    rewrite H0. rewrite H0 in H1.
    unfold limit_uppers in H1.
    unfold limit_uppers.
    apply image_axiom2 in H1.
    destruct H1 as [q [??]]. simpl in *.
    apply image_axiom1'. simpl.
    exists (q2 - oneOver2n n)%Q.
    split.
    split; red; simpl; ring.
    apply cut_is_upper with q; auto.
    apply Qle_trans with (q1 - oneOver2n n)%Q.
    destruct H2. red in H2; simpl in H2. rewrite H2.
    ring_simplify. apply Qle_refl.
    apply Qplus_le_compat; auto. apply Qle_refl.
  Qed.
  Next Obligation.
    unfold limit_upper, limit_lower.
    destruct (seq_cauchy 0 0 0)%N as [u [? [l [??]]]].
    reflexivity.
    reflexivity.
    split; intros.
    exists (-oneOver2n 0 + l)%Q.
    apply union_axiom.
    exists (limit_lowers 0).
    split. exists 0%N. auto.
    unfold limit_lowers.
    apply image_axiom1'.
    simpl.
    exists l. split; auto.
    exists (oneOver2n 0 + u)%Q.
    apply union_axiom.
    exists (limit_uppers 0).
    split. exists 0%N. auto.
    unfold limit_lowers.
    apply image_axiom1'.
    simpl.
    exists u. split; auto.
  Qed.

  Lemma limit_correct : is_limit seq limit.
  Proof.
    red; intros.
    destruct (oneOver2n_small ε) as [m ?]; auto.
    exists (m+1)%N. intros.
    split.
    destruct (seq_cauchy (m+1) n (m+1))%N as [u [? [l [??]]]]; auto.
    reflexivity.
    exists u. exists (-oneOver2n (m+1) + l)%Q. split; auto. split.
    simpl.
    unfold limit_lower.
    apply union_axiom.
    exists (limit_lowers (m+1)).
    split. exists (m+1)%N. auto.
    unfold limit_lowers.
    apply image_axiom1'; simpl.
    exists l. split; auto.
    rewrite <- (Qplus_le_l _ _ (-oneOver2n (m+1))).
    ring_simplify.
    apply Qle_trans with (oneOver2n (m+1)).
    ring_simplify in H4. intuition.
    rewrite <- (Qplus_le_l _ _ (oneOver2n (m+1))).
    ring_simplify.
    rewrite <- oneOver2n_commute.
    unfold oneOver2n at 2. simpl.
    unfold shift_pos. simpl.
    field_simplify.
    field_simplify in H0. auto.

    destruct (seq_cauchy n (m+1) (m+1))%N as [u [? [l [??]]]]; auto.
    reflexivity.
    exists (oneOver2n (m+1) + u)%Q. exists l. split; auto.
    simpl.
    unfold limit_upper.
    apply union_axiom.
    exists (limit_uppers (m+1)).
    split. exists (m+1)%N. auto.
    unfold limit_uppers.
    apply image_axiom1'; simpl.
    exists u. split; auto.
    split; auto.
    rewrite <- (Qplus_le_l _ _ (-oneOver2n (m+1))).
    ring_simplify.
    apply Qle_trans with (oneOver2n (m+1)).
    ring_simplify in H4. intuition.
    rewrite <- (Qplus_le_l _ _ (oneOver2n (m+1))).
    ring_simplify.
    rewrite <- oneOver2n_commute.
    unfold oneOver2n at 2. simpl.
    unfold shift_pos. simpl.
    field_simplify.
    field_simplify in H0. auto.
  Qed.

  Lemma located_limit : located limit.
  Proof.
    eapply is_limit_located. apply limit_correct.
  Qed.
End cut_cauchy_limit.

End cauchy_limit_cuts.

Program Definition shift_cut (q:Q) (c:cut) :=
  Cut (image (Preord.Hom _ _ (Qplus q) _) (cut_upper c))
      (image (Preord.Hom _ _ (Qplus q) _) (cut_lower c))
      _ _ _ _.
Next Obligation.
  red; intros.
  simpl. red in H. simpl in H. rewrite H. reflexivity.
Qed.
Next Obligation.
  red; intros.
  simpl. red in H. simpl in H. rewrite H. reflexivity.
Qed.
Next Obligation.
  simpl; intros.
  apply image_axiom2 in H.
  destruct H as [u' [??]].
  apply image_axiom2 in H0.
  destruct H0 as [l' [??]].
  simpl in *.
  destruct H1. destruct H2.
  red in H1. simpl in H1.
  red in H2. simpl in H2.
  rewrite H2. rewrite H1.
  apply Qplus_le_compat.
  apply Qle_refl.
  eapply cut_proper; eauto.
Qed.
Next Obligation.
  intros.
  apply image_axiom2 in H0.
  destruct H0 as [y [??]]. simpl in *.
  apply image_axiom1'. simpl.
  exists (q1 - q)%Q.
  split.
  split; red; simpl; ring.
  apply cut_is_lower with y; auto.
  rewrite <- (Qplus_le_l _ _ q).
  ring_simplify.
  apply Qle_trans with q2; auto.
  destruct H1. red in H1. simpl in H1.
  rewrite H1.
  ring_simplify. apply Qle_refl.
Qed.
Next Obligation.
  intros.
  apply image_axiom2 in H0.
  destruct H0 as [y [??]]. simpl in *.
  apply image_axiom1'. simpl.
  exists (q2 - q)%Q.
  split.
  split; red; simpl; ring.
  apply cut_is_upper with y; auto.
  rewrite <- (Qplus_le_l _ _ (q)).
  ring_simplify.
  apply Qle_trans with q1; auto.
  destruct H1. red in H1. simpl in H1.
  rewrite H1.
  ring_simplify. apply Qle_refl.
Qed.
Next Obligation.
  intros.
  split; intros.
  destruct H as [x ?].
  apply image_axiom2 in H.
  destruct H as [y [??]]. simpl in*.
  destruct (cut_nonextended c).
  destruct H1 as [l ?]; eauto.
  exists (l + q)%Q.
  apply image_axiom1'. simpl.
  exists l. split.
  split; red; simpl; ring.
  auto.
  destruct H as [x ?].
  apply image_axiom2 in H.
  destruct H as [y [??]]. simpl in*.
  destruct (cut_nonextended c).
  destruct H2 as [u ?]; eauto.
  exists (u + q)%Q.
  apply image_axiom1'. simpl.
  exists u. split.
  split; red; simpl; ring.
  auto.
Qed.

Record cut_telescope := CutTelescope
  { seq_upper : N -> cut
  ; seq_lower : N -> cut
  ; seq_proper : forall n, cut_lt (seq_lower n) (seq_upper n)
  ; seq_upper_inside : forall n m, (n < m)%N -> cut_lt (seq_upper m) (seq_upper n)
  ; seq_lower_inside : forall n m, (n < m)%N -> cut_lt (seq_lower n) (seq_lower m)
  ; seq_converges : forall ε, 0 < ε ->
     exists n a b,
       a ∈ cut_upper (seq_upper n) /\
       b ∈ cut_lower (seq_lower n) /\
       a - b <= ε
  }.

Section cauchy_to_telescope.
  Variable seq : N -> cut.
  Hypothesis Hcauchy : cauchy_limit_cuts.cauchy_sequence seq.

  Program Definition cauchy_telescope :=
    CutTelescope
      (fun n => shift_cut (oneOver2n n) (seq (n+1)))
      (fun n => shift_cut (-oneOver2n n) (seq (n+1)))
      _ _ _ _.
  Next Obligation.
    repeat intro.
    red. simpl.
    destruct (Hcauchy (n+1) (n+1) n)%N as [u [? [l [??]]]]; auto.
    zify; omega.
    zify; omega.

    exists (u - oneOver2n n)%Q.
    exists (l + oneOver2n n)%Q.
    split.
    apply image_axiom1'. simpl.
    exists u. split.
    split; red; simpl; ring. auto.
    split.
    apply image_axiom1'. simpl.
    exists l. split.
    split; red; simpl; ring. auto.
    rewrite <- (Qplus_lt_l _ _ (oneOver2n n)).
    ring_simplify.
    rewrite <- (Qplus_lt_l _ _ (-l)). ring_simplify.
    apply Qle_lt_trans with (u-l).
    ring_simplify. apply Qle_refl.
    eapply Qlt_le_trans. apply H1.
    rewrite <- (Qplus_le_l _ _ (-oneOver2n n)).
    ring_simplify.
    apply Qlt_le_weak.
    apply oneOver2n_pos.
  Qed.
  Next Obligation.
    repeat intro. red.
    destruct (Hcauchy (n+1) (m+1) (n+1))%N as [u [? [l [??]]]]; intuition.
    zify. omega.

    exists (u + oneOver2n m)%Q.
    exists (l + oneOver2n n)%Q.
    split.
    simpl.
    apply image_axiom1'.
    simpl. exists u. split.
    split; red; simpl; ring.
    auto.
    split.
    apply image_axiom1'.
    simpl. exists l. split.
    split; red; simpl; ring.
    auto.
    rewrite <- (Qplus_lt_l _ _ (-oneOver2n m)).
    ring_simplify.
    rewrite <- (Qplus_lt_l _ _ (-l)).
    apply Qle_lt_trans with (u-l); auto.
    ring_simplify. apply Qle_refl.
    eapply Qlt_le_trans. apply H2.
    ring_simplify.
    rewrite <- (Qplus_le_l _ _ (oneOver2n m)).
    ring_simplify.
    apply oneOver2n_subsumes; auto.
    zify. omega.
  Qed.
  Next Obligation.
    repeat intro. red.
    destruct (Hcauchy (m+1) (n+1) (n+1))%N as [u [? [l [??]]]]; intuition.
    zify. omega.

    exists (u - oneOver2n n)%Q.
    exists (l - oneOver2n m)%Q.
    split.
    simpl.
    apply image_axiom1'.
    simpl. exists u. split.
    split; red; simpl; ring.
    auto.
    split.
    apply image_axiom1'.
    simpl. exists l. split.
    split; red; simpl; ring.
    auto.
    rewrite <- (Qplus_lt_l _ _ (oneOver2n n)).
    ring_simplify.
    rewrite <- (Qplus_lt_l _ _ (-l)).
    ring_simplify.
    apply Qle_lt_trans with (u-l); auto.
    ring_simplify. apply Qle_refl.
    eapply Qlt_le_trans. apply H2.
    rewrite <- (Qplus_le_l _ _ (oneOver2n m)).
    ring_simplify.
    apply oneOver2n_subsumes; auto.
    zify. omega.
  Qed.
  Next Obligation.
    intros.
    destruct (oneOver2n_small (ε/(3#1))).
    apply Qlt_shift_div_l. compute. auto.
    ring_simplify. auto.

    exists x.
    destruct (Hcauchy (x+1) (x+1) (x+1))%N as [u [? [l [??]]]]; intuition.
    exists (u + oneOver2n x)%Q.
    exists (l - oneOver2n x)%Q.
    split.
    simpl.
    apply image_axiom1'.
    simpl.
    exists u. split; auto.
    split; red; simpl; ring.
    split.
    simpl.
    apply image_axiom1'.
    simpl.
    exists l. split; auto.
    split; red; simpl; ring.
    ring_simplify.
    rewrite <- (Qplus_le_l _ _ (-(2#1) * oneOver2n x)).
    ring_simplify.
    apply Qlt_le_weak.
    eapply Qlt_le_trans. apply H3.
    rewrite <- (Qplus_le_l _ _ ((2#1) * oneOver2n x)).
    ring_simplify.
    rewrite <- oneOver2n_commute.
    unfold oneOver2n at 2. simpl.
    unfold shift_pos. simpl.
    ring_simplify.
    apply Qle_trans with ((5#2)*(ε/(3#1))).
    apply Qmult_le_compat; intuition.
    unfold Qdiv. unfold Qinv. simpl.
    ring_simplify.
    apply Qle_trans with (1*ε).
    apply Qmult_le_compat; intuition.
    ring_simplify. apply Qle_refl.
  Qed.

  Let interval_limit (t:cut_telescope) : cut :=
    interval_limit_cuts.interval_limit
      (seq_upper t) (seq_lower t)
      (seq_proper t) (seq_upper_inside t) (seq_lower_inside t).

  Lemma telescope_limit_is_limit :
    cauchy_limit_cuts.is_limit seq (interval_limit cauchy_telescope).
  Proof.
    red. intros.
    destruct (oneOver2n_small (ε/(2#1))).
    apply Qlt_shift_div_l. compute. auto.
    ring_simplify. auto.
    exists x. intros. split.
    destruct (Hcauchy (x+1) n x)%N as [u [? [l [??]]]]; auto.
    zify; omega.
    exists u. exists (l - oneOver2n x). split; auto.
    split; simpl.
    unfold interval_limit_cuts.limit_lower.
    apply union_axiom.
    exists (cut_lower (shift_cut (- oneOver2n x) (seq (x+1)))).
    split. exists x. auto.
    simpl. apply image_axiom1'.
    simpl. exists l. split; auto.
    split; red; simpl; ring.
    ring_simplify.
    rewrite <- (Qplus_le_l _ _ (- oneOver2n x)).
    ring_simplify.
    apply Qlt_le_weak. eapply Qlt_le_trans. apply H4.
    rewrite <- (Qplus_le_l _ _ (oneOver2n x)).
    ring_simplify.
    apply Qle_trans with ((2#1) * (ε / (2#1))).
    apply Qmult_le_compat; intuition.
    field_simplify.
    field_simplify.
    intuition.

    destruct (Hcauchy n (x+1) x)%N as [u [? [l [??]]]]; auto.
    zify; omega.
    exists (u + oneOver2n x)%Q. exists l.
    split.
    simpl.
    unfold interval_limit_cuts.limit_upper.
    apply union_axiom.
    exists (cut_upper (shift_cut (oneOver2n x) (seq (x+1)))).
    split. exists x. auto.
    simpl. apply image_axiom1'.
    simpl. exists u. split; auto.
    split; red; simpl; ring.
    split; auto.
    rewrite <- (Qplus_le_l _ _ (- oneOver2n x)).
    ring_simplify.
    apply Qlt_le_weak. eapply Qlt_le_trans. apply H4.
    rewrite <- (Qplus_le_l _ _ (oneOver2n x)).
    ring_simplify.
    apply Qle_trans with ((2#1) * (ε / (2#1))).
    apply Qmult_le_compat; intuition.
    field_simplify.
    field_simplify.
    intuition.
  Qed.

End cauchy_to_telescope.


Require Export XR_S_INR.
Require Export XR_Rplus_le_compat.
Require Export XR_Rlt_0_1.

Local Open Scope R_scope.

Lemma pos_INR : forall n:nat, R0 <= INR n.
Proof.
  induction n as [ | n hn ].
  {
    simpl.
    unfold "<=".
    right.
    reflexivity.
  }
  {
    rewrite S_INR.
    rewrite <- Rplus_0_r with R0.
    apply Rplus_le_compat.
    { exact hn. }
    {
      unfold "<=".
      left.
      exact Rlt_0_1.
    }
  }
Qed.


Require Export Arith.
Require Export ArithRing.
Require Export Omega.
Require Export Wf_nat.

Fixpoint div2 (n : nat) : nat :=
 match n with S (S p) => S (div2 p) | _ => 0 end.

Theorem div2_ind:
 forall (P : nat ->  Prop),
 P 0 -> P 1 -> (forall n, P n ->  P (S (S n))) -> forall n,  P n.
Proof.
intros P H0 H1 Hstep n.
assert (H : P n /\ P (S n)) by (elim n; intuition).
 now destruct H.
Qed.

Theorem div2_lt: forall n,  (div2 (S n) < S n).
Proof.
intros; elim n  using div2_ind; simpl; intros; omega.
Qed.

Definition log2_it_F (log2 : nat ->  nat) (n : nat) : nat :=
   match n with
     0 => 0
    | 1 => 0
    | S (S p) => S (log2 (div2 (S (S p))))
   end.

Fixpoint iter {A : Type} (f : A ->  A) (k : nat) (a : A) {struct k} : A :=
 match k with   0%nat => a
               | S p => f (iter  f p a) end.

Definition log2_terminates:
 forall (n : nat),
  ({v : nat | exists p : nat , forall k g, p < k ->  iter log2_it_F k g n = v }).
Proof.
 intros n; elim n  using (well_founded_induction lt_wf); clear n.
 intros n; case n.
 - intros; exists 0, 0;  intros k; case k.
   + intros; omega.
   + intros k' g _; simpl; auto.
 - intros n'; case n'.
   + intros; exists 0; exists 0; intros k; case k.
     * intros; omega.
     * intros k' g_; simpl; auto.
   + intros p f; assert (Hlt: div2 (S (S p)) < S (S p))
                 by apply div2_lt.
     destruct (f (div2 (S (S p))) Hlt) as [v Hex];exists (S v).
     destruct Hex as [p' Heq];exists (S p').
     intros k g; case k.
     * intros; omega.
     * intros k' Hltk;rewrite <- (Heq k' g); auto.
       omega.
Qed.

Definition log2 (n : nat) : nat :=
   match log2_terminates n with exist _ v _ => v end.

Theorem log2_fix_eqn:
 forall n,  log2 n = match n with
                       0 => 0
                      | 1 => 0
                      | S (S p) => S (log2 (div2 (S (S p))))
                     end.
Proof.
 intros n; unfold log2; case (log2_terminates n); case n.
 - intros v [p Heq]; rewrite <- (Heq (S p) log2); auto.
 - intros n'; case n'.
   + intros v [p Heq];rewrite <- (Heq (S p) log2); auto.
   + intros n'' v [p Heq];case (log2_terminates (div2 (S (S n'')))).
     intros v' [p' Heq'];
     rewrite <- (Heq (S (S (p + p'))) log2),
             <- (Heq' (S (p + p')) log2); auto.
     omega.
     omega.
Qed.

Theorem div2_eq: forall n,  2 * div2 n = n \/ 2 * div2 n + 1 = n.
Proof.
intros n; elim n  using div2_ind; simpl; (try omega).
intros n' [Heq|Heq]; omega.
Qed.

Fixpoint exp2 (n : nat) : nat :=
 match n with 0 => 1 | S p => 2 * exp2 p end.

Theorem log2_power:
 forall n, 0 < n ->  ( exp2 (log2 n) <= n < 2 * exp2 (log2 n) ).
Proof.
intros n; elim n  using (well_founded_ind lt_wf).
intros x; case x.
- simpl; intros; omega.
- intros x'; case x'.
  + rewrite (log2_fix_eqn 1); simpl; auto with arith.
  + intros p Hrec; elim (Hrec (div2 (S (S p)))).
    * intros Hle Hlt _; rewrite (log2_fix_eqn (S (S p))).
      cbv zeta iota beta delta [exp2]; fold exp2.
      split.
      apply le_trans with (2 * div2 (S (S p))).
      auto with arith.
      elim (div2_eq (S (S p))).
      omega.
      omega.
      apply le_lt_trans with (2 * div2 (S (S p)) + 1).
      elim (div2_eq (S (S p))).
      omega.
      omega.
      omega.
    * apply div2_lt; simpl; auto with arith.
    *  simpl; auto with arith.
Qed.