(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype.
Require Import BinNat.
Require BinPos Ndec.
Require Export Ring.

(******************************************************************************)
(* A version of arithmetic on nat (natural numbers) that is better suited to  *)
(* small scale reflection than the Coq Arith library. It contains an          *)
(* extensive equational theory (including, e.g., the AGM inequality), as well *)
(* as support for the ring tactic, and congruence tactics.                    *)
(*   The following operations and notations are provided:                     *)
(*                                                                            *)
(*   successor and predecessor                                                *)
(*     n.+1, n.+2, n.+3, n.+4 and n.-1, n.-2                                  *)
(*     this frees the names "S" and "pred"                                    *)
(*                                                                            *)
(*   basic arithmetic                                                         *)
(*     m + n, m - n, m * n                                                    *)
(*   Important: m - n denotes TRUNCATED subtraction: m - n = 0 if m <= n.     *)
(*   The definitions use the nosimpl tag to prevent undesirable computation   *)
(*   computation during simplification, but remain compatible with the ones   *)
(*   provided in the Coq.Init.Peano prelude.                                  *)
(*     For computation, a module NatTrec rebinds all arithmetic notations     *)
(*   to less convenient but also less inefficient tail-recursive functions;   *)
(*   the auxiliary functions used by these versions are flagged with %Nrec.   *)
(*     Also, there is support for input and output of large nat values.       *)
(*       Num 3 082 241 inputs the number 3082241                              *)
(*         [Num of n]  outputs the value n                                    *)
(*   There are coercions num >-> BinNat.N >-> nat; ssrnat rebinds the scope   *)
(*   delimiter for BinNat.N to %num, as it uses the shorter %N for its own    *)
(*   notations (Peano notations are flagged with %coq_nat).                   *)
(*                                                                            *)
(*   doubling, halving, and parity                                            *)
(*      n.*2, n./2, odd n, uphalf n,  with uphalf n = n.+1./2                 *)
(*   bool coerces to nat so we can write, e.g., n = odd n + n./2.*2.          *)
(*                                                                            *)
(*   iteration                                                                *)
(*             iter n f x0  == f ( .. (f x0))                                 *)
(*             iteri n g x0 == g n.-1 (g ... (g 0 x0))                        *)
(*         iterop n op x x0 == op x (... op x x) (n x's) or x0 if n = 0       *)
(*                                                                            *)
(*   exponentiation, factorial                                                *)
(*        m ^ n, n`!                                                          *)
(*        m ^ 1 is convertible to m, and m ^ 2 to m * m                       *)
(*                                                                            *)
(*   comparison                                                               *)
(*      m <= n, m < n, m >= n, m > n, m == n, m <= n <= p, etc.,              *)
(*   comparisons are BOOLEAN operators, and m == n is the generic eqType      *)
(*   operation.                                                               *)
(*     Most compatibility lemmas are stated as boolean equalities; this keeps *)
(*   the size of the library down. All the inequalities refer to the same     *)
(*   constant "leq"; in particular m < n is identical to m.+1 <= n.           *)
(*                                                                            *)
(* -> patterns for contextual rewriting:                                      *)
(*      leqLHS := (X in (X <= _)%N)%pattern                                   *)
(*      leqRHS := (X in (_ <= X)%N)%pattern                                   *)
(*      ltnLHS := (X in (X < _)%N)%pattern                                    *)
(*      ltnRHS := (X in (_ < X)%N)%pattern                                    *)
(*                                                                            *)
(*   conditionally strict inequality `leqif'                                  *)
(*      m <= n ?= iff condition   ==   (m <= n) and ((m == n) = condition)    *)
(*   This is actually a pair of boolean equalities, so rewriting with an      *)
(*   `leqif' lemma can affect several kinds of comparison. The transitivity   *)
(*   lemma for leqif aggregates the conditions, allowing for arguments of     *)
(*   the form ``m <= n <= p <= m, so equality holds throughout''.             *)
(*                                                                            *)
(*   maximum and minimum                                                      *)
(*      maxn m n, minn m n                                                    *)
(*   Note that maxn m n = m + (n - m), due to the truncating subtraction.     *)
(*   Absolute difference (linear distance) between nats is defined in the int *)
(*   library (in the int.IntDist sublibrary), with the syntax `|m - n|. The   *)
(*   '-' in this notation is the signed integer difference.                   *)
(*                                                                            *)
(*   countable choice                                                         *)
(*     ex_minn : forall P : pred nat, (exists n, P n) -> nat                  *)
(*   This returns the smallest n such that P n holds.                         *)
(*     ex_maxn : forall (P : pred nat) m,                                     *)
(*        (exists n, P n) -> (forall n, P n -> n <= m) -> nat                 *)
(*   This returns the largest n such that P n holds (given an explicit upper  *)
(*   bound).                                                                  *)
(*                                                                            *)
(*  This file adds the following suffix conventions to those documented in    *)
(* ssrbool.v and eqtype.v:                                                    *)
(*   A (infix) -- conjunction, as in                                          *)
(*      ltn_neqAle : (m < n) = (m != n) && (m <= n).                          *)
(*   B -- subtraction, as in subBn : (m - n) - p = m - (n + p).               *)
(*   D -- addition, as in mulnDl : (m + n) * p = m * p + n * p.               *)
(*   M -- multiplication, as in expnMn : (m * n) ^ p = m ^ p * n ^ p.         *)
(*   p (prefix) -- positive, as in                                            *)
(*      eqn_pmul2l : m > 0 -> (m * n1 == m * n2) = (n1 == n2).                *)
(*   P  -- greater than 1, as in                                              *)
(*      ltn_Pmull : 1 < n -> 0 < m -> m < n * m.                              *)
(*   S -- successor, as in addSn : n.+1 + m = (n + m).+1.                     *)
(*   V (infix) -- disjunction, as in                                          *)
(*      leq_eqVlt : (m <= n) = (m == n) || (m < n).                           *)
(*   X - exponentiation, as in lognX : logn p (m ^ n) = logn p m * n in       *)
(*         file prime.v (the suffix is not used in this file).                 *)
(* Suffixes that abbreviate operations (D, B, M and X) are used to abbreviate *)
(* second-rank operations in equational lemma names that describe left-hand   *)
(* sides (e.g., mulnDl); they are not used to abbreviate the main operation   *)
(* of relational lemmas (e.g., leq_add2l).                                    *)
(*   For the asymmetrical exponentiation operator expn (m ^ n) a right suffix *)
(* indicates an operation on the exponent, e.g., expnM : m ^ (n1 * n2) = ...; *)
(* a trailing "n" is used to indicate the left operand, e.g.,                 *)
(* expnMn : (m1 * m2) ^ n = ... The operands of other operators are selected  *)
(* using the l/r suffixes.                                                    *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Declare Scope coq_nat_scope.
Declare Scope nat_rec_scope.

(* Disable Coq prelude hints to improve proof script robustness. *)

#[global] Remove Hints plus_n_O plus_n_Sm mult_n_O mult_n_Sm : core.

(* Declare legacy Arith operators in new scope. *)

Delimit Scope coq_nat_scope with coq_nat.

Notation "m + n" := (plus m n) : coq_nat_scope.
Notation "m - n" := (minus m n) : coq_nat_scope.
Notation "m * n" := (mult m n) : coq_nat_scope.
Notation "m <= n" := (le m n) : coq_nat_scope.
Notation "m < n" := (lt m n) : coq_nat_scope.
Notation "m >= n" := (ge m n) : coq_nat_scope.
Notation "m > n" := (gt m n) : coq_nat_scope.

(* Rebind scope delimiters, reserving a scope for the "recursive",     *)
(* i.e., unprotected version of operators.                             *)

Delimit Scope N_scope with num.
Delimit Scope nat_scope with N.
Delimit Scope nat_rec_scope with Nrec.

(* Postfix notation for the successor and predecessor functions.  *)
(* SSreflect uses "pred" for the generic predicate type, and S as *)
(* a local bound variable.                                        *)

Notation succn := Datatypes.S.
Notation predn := Peano.pred.

Notation "n .+1" := (succn n) (at level 2, left associativity,
  format "n .+1") : nat_scope.
Notation "n .+2" := n.+1.+1 (at level 2, left associativity,
  format "n .+2") : nat_scope.
Notation "n .+3" := n.+2.+1 (at level 2, left associativity,
  format "n .+3") : nat_scope.
Notation "n .+4" := n.+2.+2 (at level 2, left associativity,
  format "n .+4") : nat_scope.

Notation "n .-1" := (predn n) (at level 2, left associativity,
  format "n .-1") : nat_scope.
Notation "n .-2" := n.-1.-1 (at level 2, left associativity,
  format "n .-2") : nat_scope.

Lemma succnK : cancel succn predn. Proof. by []. Qed.
Lemma succn_inj : injective succn. Proof. by move=> n m []. Qed.

(* Predeclare postfix doubling/halving operators. *)

Reserved Notation "n .*2" (at level 2, left associativity, format "n .*2").
Reserved Notation "n ./2" (at level 2, left associativity, format "n ./2").

(* Canonical comparison and eqType for nat.                                *)

Fixpoint eqn m n {struct m} :=
  match m, n with
  | 0, 0 => true
  | m'.+1, n'.+1 => eqn m' n'
  | _, _ => false
  end.

Lemma eqnP : Equality.axiom eqn.
Proof.
move=> n m; apply: (iffP idP) => [|<-]; last by elim n.
by elim: n m => [|n IHn] [|m] //= /IHn->.
Qed.

Canonical nat_eqMixin := EqMixin eqnP.
Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin.

Arguments eqn !m !n.
Arguments eqnP {x y}.

Lemma eqnE : eqn = eq_op. Proof. by []. Qed.

Lemma eqSS m n : (m.+1 == n.+1) = (m == n). Proof. by []. Qed.

Lemma nat_irrelevance (x y : nat) (E E' : x = y) : E = E'.
Proof. exact: eq_irrelevance. Qed.

(* Protected addition, with a more systematic set of lemmas.                *)

Definition addn_rec := plus.
Notation "m + n" := (addn_rec m n) : nat_rec_scope.

Definition addn := nosimpl addn_rec.
Notation "m + n" := (addn m n) : nat_scope.

Lemma addnE : addn = addn_rec. Proof. by []. Qed.

Lemma plusE : plus = addn. Proof. by []. Qed.

Lemma add0n : left_id 0 addn.            Proof. by []. Qed.
Lemma addSn m n : m.+1 + n = (m + n).+1. Proof. by []. Qed.
Lemma add1n n : 1 + n = n.+1.            Proof. by []. Qed.

Lemma addn0 : right_id 0 addn. Proof. by move=> n; apply/eqP; elim: n. Qed.

Lemma addnS m n : m + n.+1 = (m + n).+1. Proof. by apply/eqP; elim: m. Qed.

Lemma addSnnS m n : m.+1 + n = m + n.+1. Proof. by rewrite addnS. Qed.

Lemma addnCA : left_commutative addn.
Proof. by move=> m n p; elim: m => //= m; rewrite addnS => <-. Qed.

Lemma addnC : commutative addn.
Proof. by move=> m n; rewrite -[n in LHS]addn0 addnCA addn0. Qed.

Lemma addn1 n : n + 1 = n.+1. Proof. by rewrite addnC. Qed.

Lemma addnA : associative addn.
Proof. by move=> m n p; rewrite (addnC n) addnCA addnC. Qed.

Lemma addnAC : right_commutative addn.
Proof. by move=> m n p; rewrite -!addnA (addnC n). Qed.

Lemma addnCAC m n p : m + n + p = p + n + m.
Proof. by rewrite addnC addnA addnAC. Qed.

Lemma addnACl m n p: m + n + p = n + (p + m).
Proof. by rewrite (addnC m) addnC addnCA. Qed.

Lemma addnACA : interchange addn addn.
Proof. by move=> m n p q; rewrite -!addnA (addnCA n). Qed.

Lemma addn_eq0 m n : (m + n == 0) = (m == 0) && (n == 0).
Proof. by case: m; case: n. Qed.

Lemma eqn_add2l p m n : (p + m == p + n) = (m == n).
Proof. by elim: p. Qed.

Lemma eqn_add2r p m n : (m + p == n + p) = (m == n).
Proof. by rewrite -!(addnC p) eqn_add2l. Qed.

Lemma addnI : right_injective addn.
Proof. by move=> p m n Heq; apply: eqP; rewrite -(eqn_add2l p) Heq eqxx. Qed.

Lemma addIn : left_injective addn.
Proof. move=> p m n; rewrite -!(addnC p); apply addnI. Qed.

Lemma addn2 m : m + 2 = m.+2. Proof. by rewrite addnC. Qed.
Lemma add2n m : 2 + m = m.+2. Proof. by []. Qed.
Lemma addn3 m : m + 3 = m.+3. Proof. by rewrite addnC. Qed.
Lemma add3n m : 3 + m = m.+3. Proof. by []. Qed.
Lemma addn4 m : m + 4 = m.+4. Proof. by rewrite addnC. Qed.
Lemma add4n m : 4 + m = m.+4. Proof. by []. Qed.

(* Protected, structurally decreasing subtraction, and basic lemmas.  *)
(* Further properties depend on ordering conditions.                  *)

Definition subn_rec := minus.
Arguments subn_rec : simpl nomatch.
Notation "m - n" := (subn_rec m n) : nat_rec_scope.

Definition subn := nosimpl subn_rec.
Notation "m - n" := (subn m n) : nat_scope.

Lemma subnE : subn = subn_rec. Proof. by []. Qed.
Lemma minusE : minus = subn.   Proof. by []. Qed.

Lemma sub0n : left_zero 0 subn.    Proof. by []. Qed.
Lemma subn0 : right_id 0 subn.   Proof. by case. Qed.
Lemma subnn : self_inverse 0 subn. Proof. by elim. Qed.

Lemma subSS n m : m.+1 - n.+1 = m - n. Proof. by []. Qed.
Lemma subn1 n : n - 1 = n.-1.          Proof. by case: n => [|[]]. Qed.
Lemma subn2 n : (n - 2)%N = n.-2.      Proof. by case: n => [|[|[]]]. Qed.

Lemma subnDl p m n : (p + m) - (p + n) = m - n.
Proof. by elim: p. Qed.

Lemma subnDr p m n : (m + p) - (n + p) = m - n.
Proof. by rewrite -!(addnC p) subnDl. Qed.

Lemma addnK n : cancel (addn^~ n) (subn^~ n).
Proof. by move=> m; rewrite (subnDr n m 0) subn0. Qed.

Lemma addKn n : cancel (addn n) (subn^~ n).
Proof. by move=> m; rewrite addnC addnK. Qed.

Lemma subSnn n : n.+1 - n = 1.
Proof. exact (addnK n 1). Qed.

Lemma subnDA m n p : n - (m + p) = (n - m) - p.
Proof. by elim: m n => [|m IHm] []. Qed.

Lemma subnAC : right_commutative subn.
Proof. by move=> m n p; rewrite -!subnDA addnC. Qed.

Lemma subnS m n : m - n.+1 = (m - n).-1.
Proof. by rewrite -addn1 subnDA subn1. Qed.

Lemma subSKn m n : (m.+1 - n).-1 = m - n.
Proof. by rewrite -subnS. Qed.

(* Integer ordering, and its interaction with the other operations.       *)

Definition leq m n := m - n == 0.

Notation "m <= n" := (leq m n) : nat_scope.
Notation "m < n"  := (m.+1 <= n) : nat_scope.
Notation "m >= n" := (n <= m) (only parsing) : nat_scope.
Notation "m > n"  := (n < m) (only parsing)  : nat_scope.

(* For sorting, etc. *)
Definition geq := [rel m n | m >= n].
Definition ltn := [rel m n | m < n].
Definition gtn := [rel m n | m > n].

Notation "m <= n <= p" := ((m <= n) && (n <= p)) : nat_scope.
Notation "m < n <= p" := ((m < n) && (n <= p)) : nat_scope.
Notation "m <= n < p" := ((m <= n) && (n < p)) : nat_scope.
Notation "m < n < p" := ((m < n) && (n < p)) : nat_scope.

Lemma ltnS m n : (m < n.+1) = (m <= n). Proof. by []. Qed.
Lemma leq0n n : 0 <= n.                 Proof. by []. Qed.
Lemma ltn0Sn n : 0 < n.+1.              Proof. by []. Qed.
Lemma ltn0 n : n < 0 = false.           Proof. by []. Qed.
Lemma leqnn n : n <= n.                 Proof. by elim: n. Qed.
#[global] Hint Resolve leqnn : core.
Lemma ltnSn n : n < n.+1.               Proof. by []. Qed.
Lemma eq_leq m n : m = n -> m <= n.     Proof. by move->. Qed.
Lemma leqnSn n : n <= n.+1.             Proof. by elim: n. Qed.
#[global] Hint Resolve leqnSn : core.
Lemma leq_pred n : n.-1 <= n.           Proof. by case: n => /=. Qed.
Lemma leqSpred n : n <= n.-1.+1.        Proof. by case: n => /=. Qed.

Lemma ltn_predL n : (n.-1 < n) = (0 < n).
Proof. by case: n => [//|n]; rewrite ltnSn. Qed.

Lemma ltn_predRL m n : (m < n.-1) = (m.+1 < n).
Proof. by case: n => [//|n]; rewrite succnK. Qed.

Lemma ltn_predK m n : m < n -> n.-1.+1 = n.
Proof. by case: n. Qed.

Lemma prednK n : 0 < n -> n.-1.+1 = n.
Proof. exact: ltn_predK. Qed.

Lemma leqNgt m n : (m <= n) = ~~ (n < m).
Proof. by elim: m n => [|m IHm] []. Qed.

Lemma leqVgt m n : (m <= n) || (n < m). Proof. by rewrite leqNgt orNb. Qed.

Lemma ltnNge m n : (m < n) = ~~ (n <= m).
Proof. by rewrite leqNgt. Qed.

Lemma ltnn n : n < n = false.
Proof. by rewrite ltnNge leqnn. Qed.

Lemma leqn0 n : (n <= 0) = (n == 0).           Proof. by case: n. Qed.
Lemma lt0n n : (0 < n) = (n != 0).             Proof. by case: n. Qed.
Lemma lt0n_neq0 n : 0 < n -> n != 0.           Proof. by case: n. Qed.
Lemma eqn0Ngt n : (n == 0) = ~~ (n > 0).       Proof. by case: n. Qed.
Lemma neq0_lt0n n : (n == 0) = false -> 0 < n. Proof. by case: n. Qed.
#[global] Hint Resolve lt0n_neq0 neq0_lt0n : core.

Lemma eqn_leq m n : (m == n) = (m <= n <= m).
Proof. by elim: m n => [|m IHm] []. Qed.

Lemma anti_leq : antisymmetric leq.
Proof. by move=> m n; rewrite -eqn_leq => /eqP. Qed.

Lemma neq_ltn m n : (m != n) = (m < n) || (n < m).
Proof. by rewrite eqn_leq negb_and orbC -!ltnNge. Qed.

Lemma gtn_eqF m n : m < n -> n == m = false.
Proof. by rewrite eqn_leq (leqNgt n) => ->. Qed.

Lemma ltn_eqF m n : m < n -> m == n = false.
Proof. by move/gtn_eqF; rewrite eq_sym. Qed.

Lemma ltn_geF m n : m < n -> m >= n = false.
Proof. by rewrite (leqNgt n) => ->. Qed.

Lemma leq_gtF m n : m <= n -> m > n = false.
Proof. by rewrite (ltnNge n) => ->. Qed.

Lemma leq_eqVlt m n : (m <= n) = (m == n) || (m < n).
Proof. by elim: m n => [|m IHm] []. Qed.

Lemma ltn_neqAle m n : (m < n) = (m != n) && (m <= n).
Proof. by rewrite ltnNge leq_eqVlt negb_or -leqNgt eq_sym. Qed.

Lemma leq_trans n m p : m <= n -> n <= p -> m <= p.
Proof. by elim: n m p => [|i IHn] [|m] [|p] //; apply: IHn m p. Qed.

Lemma leq_ltn_trans n m p : m <= n -> n < p -> m < p.
Proof. by move=> Hmn; apply: leq_trans. Qed.

Lemma ltnW m n : m < n -> m <= n.
Proof. exact: leq_trans. Qed.
#[global] Hint Resolve ltnW : core.

Lemma leqW m n : m <= n -> m <= n.+1.
Proof. by move=> le_mn; apply: ltnW. Qed.

Lemma ltn_trans n m p : m < n -> n < p -> m < p.
Proof. by move=> lt_mn /ltnW; apply: leq_trans. Qed.

Lemma leq_total m n : (m <= n) || (m >= n).
Proof. by rewrite -implyNb -ltnNge; apply/implyP; apply: ltnW. Qed.

(* Helper lemmas to support generalized induction over a nat measure.         *)
(* The idiom for a proof by induction over a measure Mxy : nat involving      *)
(* variables x, y, ... (e.g., size x + size y) is                             *)
(*   have [n leMn] := ubnP Mxy; elim: n => // n IHn in x y ... leMn ... *.    *)
(* after which the current goal (possibly modified by generalizations in the  *)
(* in ... part) can be proven with the extra context assumptions              *)
(*  n : nat                                                                   *)
(*  IHn : forall x y ..., Mxy < n -> ... -> the_initial_goal                  *)
(*  leMn : Mxy < n.+1                                                         *)
(* This is preferable to the legacy idiom relying on numerical occurrence     *)
(* selection, which is fragile if there can be multiple occurrences of x, y,  *)
(* ... in the measure expression Mxy (e.g., in #|y| with x : finType and      *)
(* y : {set x}).                                                              *)
(*  The leMn statement is convertible to Mxy <= n; if it is necessary to      *)
(* have _exactly_ leMn : Mxy <= n, the ltnSE helper lemma may be used as      *)
(* follows                                                                    *)
(*   have [n] := ubnP Mxy; elim: n => // n IHn in x y ... * => /ltnSE-leMn.   *)
(*  We also provide alternative helper lemmas for proofs where the upper      *)
(* bound appears in the goal, and we assume nonstrict (in)equality.           *)
(* In either case the proof will have to dispatch an Mxy = 0 case.            *)
(*  have [n defM] := ubnPleq Mxy; elim: n => [|n IHn] in x y ... defM ... *.  *)
(* yields two subgoals, in which Mxy has been replaced by 0 and n.+1,         *)
(* with the extra assumption defM : Mxy <= 0 / Mxy <= n.+1, respectively.     *)
(* The second goal also has the inductive assumption                          *)
(*   IHn : forall x y ..., Mxy <= n -> ... -> the_initial_goal[n / Mxy].      *)
(* Using ubnPgeq or ubnPeq instead of ubnPleq yields assumptions with         *)
(* Mxy >= 0/n.+1 or Mxy == 0/n.+1 instead of Mxy <= 0/n.+1, respectively.     *)
(* These introduce a different kind of induction; for example ubnPgeq M lets  *)
(* us remember that n < M throughout the induction.                           *)
(*   Finally, the ltn_ind lemma provides a generalized induction view for a   *)
(* property of a single integer (i.e., the case Mxy := x).                    *)
Lemma ubnP m : {n | m < n}.             Proof. by exists m.+1. Qed.
Lemma ltnSE m n : m < n.+1 -> m <= n.   Proof. by []. Qed.
Variant ubn_leq_spec m : nat -> Type := UbnLeq n of m <= n : ubn_leq_spec m n.
Variant ubn_geq_spec m : nat -> Type := UbnGeq n of m >= n : ubn_geq_spec m n.
Variant ubn_eq_spec m : nat -> Type := UbnEq n of m == n : ubn_eq_spec m n.
Lemma ubnPleq m : ubn_leq_spec m m.    Proof. by []. Qed.
Lemma ubnPgeq m : ubn_geq_spec m m.    Proof. by []. Qed.
Lemma ubnPeq m : ubn_eq_spec m m.      Proof. by []. Qed.
Lemma ltn_ind P : (forall n, (forall m, m < n -> P m) -> P n) -> forall n, P n.
Proof.
move=> accP M; have [n leMn] := ubnP M; elim: n => // n IHn in M leMn *.
by apply/accP=> p /leq_trans/(_ leMn)/IHn.
Qed.

(* Link to the legacy comparison predicates. *)

Lemma leP m n : reflect (m <= n)%coq_nat (m <= n).
Proof.
apply: (iffP idP); last by elim: n / => // n _ /leq_trans->.
elim: n => [|n IHn]; first by case: m.
by rewrite leq_eqVlt ltnS => /predU1P[<- // | /IHn]; right.
Qed.
Arguments leP {m n}.

Lemma le_irrelevance m n le_mn1 le_mn2 : le_mn1 = le_mn2 :> (m <= n)%coq_nat.
Proof.
elim/ltn_ind: n => n IHn in le_mn1 le_mn2 *; set n1 := n in le_mn1 *.
pose def_n : n = n1 := erefl n; transitivity (eq_ind _ _ le_mn2 _ def_n) => //.
case: n1 / le_mn1 le_mn2 => [|n1 le_mn1] {n}[|n le_mn2] in (def_n) IHn *.
- by rewrite [def_n]eq_axiomK.
- by case/leP/idPn: (le_mn2); rewrite -def_n ltnn.
- by case/leP/idPn: (le_mn1); rewrite def_n ltnn.
case: def_n (def_n) => <-{n1} def_n in le_mn1 *.
by rewrite [def_n]eq_axiomK /=; congr le_S; apply: IHn.
Qed.

Lemma ltP m n : reflect (m < n)%coq_nat (m < n).
Proof. exact leP. Qed.
Arguments ltP {m n}.

Lemma lt_irrelevance m n lt_mn1 lt_mn2 : lt_mn1 = lt_mn2 :> (m < n)%coq_nat.
Proof. exact: (@le_irrelevance m.+1). Qed.

(* Monotonicity lemmas *)

Lemma leq_add2l p m n : (p + m <= p + n) = (m <= n).
Proof. by elim: p. Qed.

Lemma ltn_add2l p m n : (p + m < p + n) = (m < n).
Proof. by rewrite -addnS; apply: leq_add2l. Qed.

Lemma leq_add2r p m n : (m + p <= n + p) = (m <= n).
Proof. by rewrite -!(addnC p); apply: leq_add2l. Qed.

Lemma ltn_add2r p m n : (m + p < n + p) = (m < n).
Proof. exact: leq_add2r p m.+1 n. Qed.

Lemma leq_add m1 m2 n1 n2 : m1 <= n1 -> m2 <= n2 -> m1 + m2 <= n1 + n2.
Proof.
by move=> le_mn1 le_mn2; rewrite (@leq_trans (m1 + n2)) ?leq_add2l ?leq_add2r.
Qed.

Lemma leq_addl m n : n <= m + n. Proof. exact: (leq_add2r n 0). Qed.

Lemma leq_addr m n : n <= n + m. Proof. by rewrite addnC leq_addl. Qed.

Lemma ltn_addl m n p : m < n -> m < p + n.
Proof. by move/leq_trans=> -> //; apply: leq_addl. Qed.

Lemma ltn_addr m n p : m < n -> m < n + p.
Proof. by move/leq_trans=> -> //; apply: leq_addr. Qed.

Lemma addn_gt0 m n : (0 < m + n) = (0 < m) || (0 < n).
Proof. by rewrite !lt0n -negb_and addn_eq0. Qed.

Lemma subn_gt0 m n : (0 < n - m) = (m < n).
Proof. by elim: m n => [|m IHm] [|n] //; apply: IHm n. Qed.

Lemma subn_eq0 m n : (m - n == 0) = (m <= n).
Proof. by []. Qed.

Lemma leq_subLR m n p : (m - n <= p) = (m <= n + p).
Proof. by rewrite -subn_eq0 -subnDA. Qed.

Lemma leq_subr m n : n - m <= n.
Proof. by rewrite leq_subLR leq_addl. Qed.

Lemma ltn_subrR m n : (n < n - m) = false.
Proof. by rewrite ltnNge leq_subr. Qed.

Lemma leq_subrR m n : (n <= n - m) = (m == 0) || (n == 0).
Proof. by case: m n => [|m] [|n]; rewrite ?subn0 ?leqnn ?ltn_subrR. Qed.

Lemma ltn_subrL m n : (n - m < n) = (0 < m) && (0 < n).
Proof. by rewrite ltnNge leq_subrR negb_or !lt0n. Qed.

Lemma subnKC m n : m <= n -> m + (n - m) = n.
Proof. by elim: m n => [|m IHm] [|n] // /(IHm n) {2}<-. Qed.

Lemma addnBn m n : m + (n - m) = m - n + n.
Proof. by elim: m n => [|m IHm] [|n] //; rewrite addSn addnS IHm. Qed.

Lemma subnK m n : m <= n -> (n - m) + m = n.
Proof. by rewrite addnC; apply: subnKC. Qed.

Lemma addnBA m n p : p <= n -> m + (n - p) = m + n - p.
Proof. by move=> le_pn; rewrite -[in RHS](subnK le_pn) addnA addnK. Qed.

Lemma addnBAC m n p : n <= m -> m - n + p = m + p - n.
Proof. by move=> le_nm; rewrite addnC addnBA // addnC. Qed.

Lemma addnBCA m n p : p <= m -> p <= n -> m + (n - p) = n + (m - p).
Proof. by move=> le_pm le_pn; rewrite !addnBA // addnC. Qed.

Lemma addnABC m n p : p <= m -> p <= n -> m + (n - p) = m - p + n.
Proof. by move=> le_pm le_pn; rewrite addnBA // addnBAC. Qed.

Lemma subnBA m n p : p <= n -> m - (n - p) = m + p - n.
Proof. by move=> le_pn; rewrite -[in RHS](subnK le_pn) subnDr. Qed.

Lemma subnA m n p : p <= n -> n <= m -> m - (n - p) = m - n + p.
Proof. by move=> le_pn lr_nm; rewrite addnBAC // subnBA. Qed.

Lemma subKn m n : m <= n -> n - (n - m) = m.
Proof. by move/subnBA->; rewrite addKn. Qed.

Lemma subSn m n : m <= n -> n.+1 - m = (n - m).+1.
Proof. by rewrite -add1n => /addnBA <-. Qed.

Lemma subnSK m n : m < n -> (n - m.+1).+1 = n - m. Proof. by move/subSn. Qed.

Lemma predn_sub m n : (m - n).-1 = (m.-1 - n).
Proof. by case: m => // m; rewrite subSKn. Qed.

Lemma leq_sub2r p m n : m <= n -> m - p <= n - p.
Proof. by move=> le_mn; rewrite leq_subLR (leq_trans le_mn) // -leq_subLR. Qed.

Lemma leq_sub2l p m n : m <= n -> p - n <= p - m.
Proof.
rewrite -(leq_add2r (p - m)) leq_subLR.
by apply: leq_trans; rewrite -leq_subLR.
Qed.

Lemma leq_sub m1 m2 n1 n2 : m1 <= m2 -> n2 <= n1 -> m1 - n1 <= m2 - n2.
Proof. by move/(leq_sub2r n1)=> le_m12 /(leq_sub2l m2); apply: leq_trans. Qed.

Lemma ltn_sub2r p m n : p < n -> m < n -> m - p < n - p.
Proof. by move/subnSK <-; apply: (@leq_sub2r p.+1). Qed.

Lemma ltn_sub2l p m n : m < p -> m < n -> p - n < p - m.
Proof. by move/subnSK <-; apply: leq_sub2l. Qed.

Lemma ltn_subRL m n p : (n < p - m) = (m + n < p).
Proof. by rewrite !ltnNge leq_subLR. Qed.

Lemma leq_psubRL m n p : 0 < n -> (n <= p - m) = (m + n <= p).
Proof. by move=> /prednK<-; rewrite ltn_subRL addnS. Qed.

Lemma ltn_psubLR m n p : 0 < p -> (m - n < p) = (m < n + p).
Proof. by move=> /prednK<-; rewrite ltnS leq_subLR addnS. Qed.

Lemma leq_subRL m n p : m <= p -> (n <= p - m) = (m + n <= p).
Proof. by move=> /subnKC{2}<-; rewrite leq_add2l. Qed.

Lemma ltn_subLR m n p : n <= m -> (m - n < p) = (m < n + p).
Proof. by move=> /subnKC{2}<-; rewrite ltn_add2l. Qed.

Lemma leq_subCl m n p : (m - n <= p) = (m - p <= n).
Proof. by rewrite !leq_subLR // addnC. Qed.

Lemma ltn_subCr m n p : (p < m - n) = (n < m - p).
Proof. by rewrite !ltn_subRL // addnC. Qed.

Lemma leq_psubCr m n p : 0 < p -> 0 < n -> (p <= m - n) = (n <= m - p).
Proof. by move=> p_gt0 n_gt0; rewrite !leq_psubRL // addnC. Qed.

Lemma ltn_psubCl m n p : 0 < p -> 0 < n -> (m - n < p) = (m - p < n).
Proof. by move=> p_gt0 n_gt0; rewrite !ltn_psubLR // addnC. Qed.

Lemma leq_subCr m n p : n <= m -> p <= m -> (p <= m - n) = (n <= m - p).
Proof. by move=> np pm; rewrite !leq_subRL // addnC. Qed.

Lemma ltn_subCl m n p : n <= m -> p <= m -> (m - n < p) = (m - p < n).
Proof. by move=> nm pm; rewrite !ltn_subLR // addnC. Qed.

Lemma leq_sub2rE p m n : p <= n -> (m - p <= n - p) = (m <= n).
Proof. by move=> pn; rewrite leq_subLR subnKC. Qed.

Lemma leq_sub2lE m n p : n <= m -> (m - p <= m - n) = (n <= p).
Proof. by move=> nm; rewrite leq_subCl subKn. Qed.

Lemma ltn_sub2rE p m n : p <= m -> (m - p < n - p) = (m < n).
Proof. by move=> pn; rewrite ltn_subRL addnC subnK. Qed.

Lemma ltn_sub2lE m n p : p <= m -> (m - p < m - n) = (n < p).
Proof. by move=> pm; rewrite ltn_subCr subKn. Qed.

(* Max and min. *)

Definition maxn m n := if m < n then n else m.

Definition minn m n := if m < n then m else n.

Lemma max0n : left_id 0 maxn.  Proof. by case. Qed.
Lemma maxn0 : right_id 0 maxn. Proof. by []. Qed.

Lemma maxnC : commutative maxn.
Proof. by rewrite /maxn; elim=> [|m ih] [] // n; rewrite !ltnS -!fun_if ih. Qed.

Lemma maxnE m n : maxn m n = m + (n - m).
Proof.
rewrite /maxn; elim: m n => [|m ih] [|n]; rewrite ?addn0 //.
by rewrite ltnS subSS addSn -ih; case: leq.
Qed.

Lemma maxnAC : right_commutative maxn.
Proof. by move=> m n p; rewrite !maxnE -!addnA !subnDA -!maxnE maxnC. Qed.

Lemma maxnA : associative maxn.
Proof. by move=> m n p; rewrite !(maxnC m) maxnAC. Qed.

Lemma maxnCA : left_commutative maxn.
Proof. by move=> m n p; rewrite !maxnA (maxnC m). Qed.

Lemma maxnACA : interchange maxn maxn.
Proof. by move=> m n p q; rewrite -!maxnA (maxnCA n). Qed.

Lemma maxn_idPl {m n} : reflect (maxn m n = m) (m >= n).
Proof. by rewrite -subn_eq0 -(eqn_add2l m) addn0 -maxnE; apply: eqP. Qed.

Lemma maxn_idPr {m n} : reflect (maxn m n = n) (m <= n).
Proof. by rewrite maxnC; apply: maxn_idPl. Qed.

Lemma maxnn : idempotent maxn.
Proof. by move=> n; apply/maxn_idPl. Qed.

Lemma leq_max m n1 n2 : (m <= maxn n1 n2) = (m <= n1) || (m <= n2).
Proof.
without loss le_n21: n1 n2 / n2 <= n1.
  by case/orP: (leq_total n2 n1) => le_n12; last rewrite maxnC orbC; apply.
by rewrite (maxn_idPl le_n21) orb_idr // => /leq_trans->.
Qed.
Lemma leq_maxl m n : m <= maxn m n. Proof. by rewrite leq_max leqnn. Qed.
Lemma leq_maxr m n : n <= maxn m n. Proof. by rewrite maxnC leq_maxl. Qed.

Lemma gtn_max m n1 n2 : (m > maxn n1 n2) = (m > n1) && (m > n2).
Proof. by rewrite !ltnNge leq_max negb_or. Qed.

Lemma geq_max m n1 n2 : (m >= maxn n1 n2) = (m >= n1) && (m >= n2).
Proof. by rewrite -ltnS gtn_max. Qed.

Lemma maxnSS m n : maxn m.+1 n.+1 = (maxn m n).+1.
Proof. by rewrite !maxnE. Qed.

Lemma addn_maxl : left_distributive addn maxn.
Proof. by move=> m1 m2 n; rewrite !maxnE subnDr addnAC. Qed.

Lemma addn_maxr : right_distributive addn maxn.
Proof. by move=> m n1 n2; rewrite !(addnC m) addn_maxl. Qed.

Lemma subn_maxl : left_distributive subn maxn.
Proof.
move=> m n p; apply/eqP.
rewrite eqn_leq !geq_max !leq_sub2r leq_max ?leqnn ?andbT ?orbT // /maxn.
by case: (_ < _); rewrite leqnn // orbT.
Qed.

Lemma min0n : left_zero 0 minn. Proof. by case. Qed.
Lemma minn0 : right_zero 0 minn. Proof. by []. Qed.

Lemma minnC : commutative minn.
Proof. by rewrite /minn; elim=> [|m ih] [] // n; rewrite !ltnS -!fun_if ih. Qed.

Lemma addn_min_max m n : minn m n + maxn m n = m + n.
Proof. by rewrite /minn /maxn; case: (m < n) => //; exact: addnC. Qed.

Lemma minnE m n : minn m n = m - (m - n).
Proof. by rewrite -(subnDl n) -maxnE -addn_min_max addnK minnC. Qed.

Lemma minnAC : right_commutative minn.
Proof.
by move=> m n p; rewrite !minnE -subnDA subnAC -maxnE maxnC maxnE subnAC subnDA.
Qed.

Lemma minnA : associative minn.
Proof. by move=> m n p; rewrite minnC minnAC (minnC n). Qed.

Lemma minnCA : left_commutative minn.
Proof. by move=> m n p; rewrite !minnA (minnC n). Qed.

Lemma minnACA : interchange minn minn.
Proof. by move=> m n p q; rewrite -!minnA (minnCA n). Qed.

Lemma minn_idPl {m n} : reflect (minn m n = m) (m <= n).
Proof.
rewrite (sameP maxn_idPr eqP) -(eqn_add2l m) eq_sym -addn_min_max eqn_add2r.
exact: eqP.
Qed.

Lemma minn_idPr {m n} : reflect (minn m n = n) (m >= n).
Proof. by rewrite minnC; apply: minn_idPl. Qed.

Lemma minnn : idempotent minn.
Proof. by move=> n; apply/minn_idPl. Qed.

Lemma leq_min m n1 n2 : (m <= minn n1 n2) = (m <= n1) && (m <= n2).
Proof.
wlog le_n21: n1 n2 / n2 <= n1.
  by case/orP: (leq_total n2 n1) => ?; last rewrite minnC andbC; apply.
rewrite /minn ltnNge le_n21 /=; case le_m_n1: (m <= n1) => //=.
apply/contraFF: le_m_n1 => /leq_trans; exact.
Qed.

Lemma gtn_min m n1 n2 : (m > minn n1 n2) = (m > n1) || (m > n2).
Proof. by rewrite !ltnNge leq_min negb_and. Qed.

Lemma geq_min m n1 n2 : (m >= minn n1 n2) = (m >= n1) || (m >= n2).
Proof. by rewrite -ltnS gtn_min. Qed.

Lemma geq_minl m n : minn m n <= m. Proof. by rewrite geq_min leqnn. Qed.
Lemma geq_minr m n : minn m n <= n. Proof. by rewrite minnC geq_minl. Qed.

Lemma addn_minr : right_distributive addn minn.
Proof. by move=> m1 m2 n; rewrite !minnE subnDl addnBA ?leq_subr. Qed.

Lemma addn_minl : left_distributive addn minn.
Proof. by move=> m1 m2 n; rewrite -!(addnC n) addn_minr. Qed.

Lemma subn_minl : left_distributive subn minn.
Proof.
move=> m n p; apply/eqP.
rewrite eqn_leq !leq_min !leq_sub2r geq_min ?leqnn ?orbT //= /minn.
by case: (_ < _); rewrite leqnn // orbT.
Qed.

Lemma minnSS m n : minn m.+1 n.+1 = (minn m n).+1.
Proof. by rewrite -(addn_minr 1). Qed.

(* Quasi-cancellation (really, absorption) lemmas *)
Lemma maxnK m n : minn (maxn m n) m = m.
Proof. exact/minn_idPr/leq_maxl. Qed.

Lemma maxKn m n : minn n (maxn m n) = n.
Proof. exact/minn_idPl/leq_maxr. Qed.

Lemma minnK m n : maxn (minn m n) m = m.
Proof. exact/maxn_idPr/geq_minl. Qed.

Lemma minKn m n : maxn n (minn m n) = n.
Proof. exact/maxn_idPl/geq_minr. Qed.

(* Distributivity. *)
Lemma maxn_minl : left_distributive maxn minn.
Proof.
move=> m1 m2 n; wlog le_m21: m1 m2 / m2 <= m1.
  move=> IH; case/orP: (leq_total m2 m1) => /IH //.
  by rewrite minnC [in R in _ = R]minnC.
rewrite (minn_idPr le_m21); apply/esym/minn_idPr.
by rewrite geq_max leq_maxr leq_max le_m21.
Qed.

Lemma maxn_minr : right_distributive maxn minn.
Proof. by move=> m n1 n2; rewrite !(maxnC m) maxn_minl. Qed.

Lemma minn_maxl : left_distributive minn maxn.
Proof.
by move=> m1 m2 n; rewrite maxn_minr !maxn_minl -minnA maxnn (maxnC _ n) !maxnK.
Qed.

Lemma minn_maxr : right_distributive minn maxn.
Proof. by move=> m n1 n2; rewrite !(minnC m) minn_maxl. Qed.

(* Comparison predicates. *)

Variant leq_xor_gtn m n : nat -> nat -> nat -> nat -> bool -> bool -> Set :=
  | LeqNotGtn of m <= n : leq_xor_gtn m n m m n n true false
  | GtnNotLeq of n < m  : leq_xor_gtn m n n n m m false true.

Lemma leqP m n : leq_xor_gtn m n (minn n m) (minn m n) (maxn n m) (maxn m n)
                                 (m <= n) (n < m).
Proof.
rewrite (minnC m) /minn (maxnC m) /maxn ltnNge.
by case le_mn: (m <= n); constructor; rewrite //= ltnNge le_mn.
Qed.

Variant ltn_xor_geq m n : nat -> nat -> nat -> nat -> bool -> bool -> Set :=
  | LtnNotGeq of m < n  : ltn_xor_geq m n m m n n false true
  | GeqNotLtn of n <= m : ltn_xor_geq m n n n m m true false.

Lemma ltnP m n : ltn_xor_geq m n (minn n m) (minn m n) (maxn n m) (maxn m n)
                                 (n <= m) (m < n).
Proof. by case: leqP; constructor. Qed.

Variant eqn0_xor_gt0 n : bool -> bool -> Set :=
  | Eq0NotPos of n = 0 : eqn0_xor_gt0 n true false
  | PosNotEq0 of n > 0 : eqn0_xor_gt0 n false true.

Lemma posnP n : eqn0_xor_gt0 n (n == 0) (0 < n).
Proof. by case: n; constructor. Qed.

Variant compare_nat m n : nat -> nat -> nat -> nat ->
                          bool -> bool -> bool -> bool -> bool -> bool -> Set :=
  | CompareNatLt of m < n :
      compare_nat m n m m n n false false false true false true
  | CompareNatGt of m > n :
      compare_nat m n n n m m false false true false true false
  | CompareNatEq of m = n :
      compare_nat m n m m m m true true true true false false.

Lemma ltngtP m n :
  compare_nat m n (minn n m) (minn m n) (maxn n m) (maxn m n)
                  (n == m) (m == n) (n <= m) (m <= n) (n < m) (m < n).
Proof.
rewrite !ltn_neqAle [_ == n]eq_sym; have [mn|] := ltnP m n.
  by rewrite ltnW // gtn_eqF //; constructor.
rewrite leq_eqVlt; case: ltnP; rewrite ?(orbT, orbF) => //= lt_nm eq_nm.
  by rewrite ltn_eqF //; constructor.
by rewrite eq_nm (eqP eq_nm); constructor.
Qed.

(* Eliminating the idiom for structurally decreasing compare and subtract. *)
Lemma subn_if_gt T m n F (E : T) :
  (if m.+1 - n is m'.+1 then F m' else E) = (if n <= m then F (m - n) else E).
Proof.
by have [le_nm|/eqnP-> //] := leqP; rewrite -{1}(subnK le_nm) -addSn addnK.
Qed.

Notation leqLHS := (X in (X <= _)%N)%pattern.
Notation leqRHS := (X in (_ <= X)%N)%pattern.
Notation ltnLHS := (X in (X < _)%N)%pattern.
Notation ltnRHS := (X in (_ < X)%N)%pattern.

(* Getting a concrete value from an abstract existence proof. *)

Section ExMinn.

Variable P : pred nat.
Hypothesis exP : exists n, P n.

Inductive acc_nat i : Prop := AccNat0 of P i | AccNatS of acc_nat i.+1.

Lemma find_ex_minn : {m | P m & forall n, P n -> n >= m}.
Proof.
have: forall n, P n -> n >= 0 by [].
have: acc_nat 0.
  case exP => n; rewrite -(addn0 n); elim: n 0 => [|n IHn] j; first by left.
  by rewrite addSnnS; right; apply: IHn.
move: 0; fix find_ex_minn 2 => m IHm m_lb; case Pm: (P m); first by exists m.
apply: find_ex_minn m.+1 _ _ => [|n Pn]; first by case: IHm; rewrite ?Pm.
by rewrite ltn_neqAle m_lb //; case: eqP Pm => // -> /idP[].
Qed.

Definition ex_minn := s2val find_ex_minn.

Inductive ex_minn_spec : nat -> Type :=
  ExMinnSpec m of P m & (forall n, P n -> n >= m) : ex_minn_spec m.

Lemma ex_minnP : ex_minn_spec ex_minn.
Proof. by rewrite /ex_minn; case: find_ex_minn. Qed.

End ExMinn.

Section ExMaxn.

Variables (P : pred nat) (m : nat).
Hypotheses (exP : exists i, P i) (ubP : forall i, P i -> i <= m).

Lemma ex_maxn_subproof : exists i, P (m - i).
Proof. by case: exP => i Pi; exists (m - i); rewrite subKn ?ubP. Qed.

Definition ex_maxn := m - ex_minn ex_maxn_subproof.

Variant ex_maxn_spec : nat -> Type :=
  ExMaxnSpec i of P i & (forall j, P j -> j <= i) : ex_maxn_spec i.

Lemma ex_maxnP : ex_maxn_spec ex_maxn.
Proof.
rewrite /ex_maxn; case: ex_minnP => i Pmi min_i; split=> // j Pj.
have le_i_mj: i <= m - j by rewrite min_i // subKn // ubP.
rewrite -subn_eq0 subnBA ?(leq_trans le_i_mj) ?leq_subr //.
by rewrite addnC -subnBA ?ubP.
Qed.

End ExMaxn.

Lemma eq_ex_minn P Q exP exQ : P =1 Q -> @ex_minn P exP = @ex_minn Q exQ.
Proof.
move=> eqPQ; case: ex_minnP => m1 Pm1 m1_lb; case: ex_minnP => m2 Pm2 m2_lb.
by apply/eqP; rewrite eqn_leq m1_lb (m2_lb, eqPQ) // -eqPQ.
Qed.

Lemma eq_ex_maxn (P Q : pred nat) m n exP ubP exQ ubQ :
  P =1 Q -> @ex_maxn P m exP ubP = @ex_maxn Q n exQ ubQ.
Proof.
move=> eqPQ; case: ex_maxnP => i Pi max_i; case: ex_maxnP => j Pj max_j.
by apply/eqP; rewrite eqn_leq max_i ?eqPQ // max_j -?eqPQ.
Qed.

Section Iteration.

Variable T : Type.
Implicit Types m n : nat.
Implicit Types x y : T.
Implicit Types S : {pred T}.

Definition iter n f x :=
  let fix loop m := if m is i.+1 then f (loop i) else x in loop n.

Definition iteri n f x :=
  let fix loop m := if m is i.+1 then f i (loop i) else x in loop n.

Definition iterop n op x :=
  let f i y := if i is 0 then x else op x y in iteri n f.

Lemma iterSr n f x : iter n.+1 f x = iter n f (f x).
Proof. by elim: n => //= n <-. Qed.

Lemma iterS n f x : iter n.+1 f x = f (iter n f x). Proof. by []. Qed.

Lemma iterD n m f x : iter (n + m) f x = iter n f (iter m f x).
Proof. by elim: n => //= n ->. Qed.

Lemma iteriS n f x : iteri n.+1 f x = f n (iteri n f x).
Proof. by []. Qed.

Lemma iteropS idx n op x : iterop n.+1 op x idx = iter n (op x) x.
Proof. by elim: n => //= n ->. Qed.

Lemma eq_iter f f' : f =1 f' -> forall n, iter n f =1 iter n f'.
Proof. by move=> eq_f n x; elim: n => //= n ->; rewrite eq_f. Qed.

Lemma iter_fix n f x : f x = x -> iter n f x = x.
Proof. by move=> fixf; elim: n => //= n ->. Qed.

Lemma eq_iteri f f' : f =2 f' -> forall n, iteri n f =1 iteri n f'.
Proof. by move=> eq_f n x; elim: n => //= n ->; rewrite eq_f. Qed.

Lemma eq_iterop n op op' : op =2 op' -> iterop n op =2 iterop n op'.
Proof. by move=> eq_op x; apply: eq_iteri; case. Qed.

Lemma iter_in f S i : {homo f : x / x \in S} -> {homo iter i f : x / x \in S}.
Proof. by move=> f_in x xS; elim: i => [|i /f_in]. Qed.

End Iteration.

Lemma iter_succn m n : iter n succn m = m + n.
Proof. by rewrite addnC; elim: n => //= n ->. Qed.

Lemma iter_succn_0 n : iter n succn 0 = n.
Proof. exact: iter_succn. Qed.

Lemma iter_predn m n : iter n predn m = m - n.
Proof. by elim: n m => /= [|n IHn] m; rewrite ?subn0 // IHn subnS. Qed.

(* Multiplication. *)

Definition muln_rec := mult.
Notation "m * n" := (muln_rec m n) : nat_rec_scope.

Definition muln := nosimpl muln_rec.
Notation "m * n" := (muln m n) : nat_scope.

Lemma multE : mult = muln.     Proof. by []. Qed.
Lemma mulnE : muln = muln_rec. Proof. by []. Qed.

Lemma mul0n : left_zero 0 muln.          Proof. by []. Qed.
Lemma muln0 : right_zero 0 muln.         Proof. by elim. Qed.
Lemma mul1n : left_id 1 muln.            Proof. exact: addn0. Qed.
Lemma mulSn m n : m.+1 * n = n + m * n.  Proof. by []. Qed.
Lemma mulSnr m n : m.+1 * n = m * n + n. Proof. exact: addnC. Qed.

Lemma mulnS m n : m * n.+1 = m + m * n.
Proof. by elim: m => // m; rewrite !mulSn !addSn addnCA => ->. Qed.
Lemma mulnSr m n : m * n.+1 = m * n + m.
Proof. by rewrite addnC mulnS. Qed.

Lemma iter_addn m n p : iter n (addn m) p = m * n + p.
Proof. by elim: n => /= [|n ->]; rewrite ?muln0 // mulnS addnA. Qed.

Lemma iter_addn_0 m n : iter n (addn m) 0 = m * n.
Proof. by rewrite iter_addn addn0. Qed.

Lemma muln1 : right_id 1 muln.
Proof. by move=> n; rewrite mulnSr muln0. Qed.

Lemma mulnC : commutative muln.
Proof.
by move=> m n; elim: m => [|m]; rewrite (muln0, mulnS) // mulSn => ->.
Qed.

Lemma mulnDl : left_distributive muln addn.
Proof. by move=> m1 m2 n; elim: m1 => //= m1 IHm; rewrite -addnA -IHm. Qed.

Lemma mulnDr : right_distributive muln addn.
Proof. by move=> m n1 n2; rewrite !(mulnC m) mulnDl. Qed.

Lemma mulnBl : left_distributive muln subn.
Proof.
move=> m n [|p]; first by rewrite !muln0.
by elim: m n => // [m IHm] [|n] //; rewrite mulSn subnDl -IHm.
Qed.

Lemma mulnBr : right_distributive muln subn.
Proof. by move=> m n p; rewrite !(mulnC m) mulnBl. Qed.

Lemma mulnA : associative muln.
Proof. by move=> m n p; elim: m => //= m; rewrite mulSn mulnDl => ->. Qed.

Lemma mulnCA : left_commutative muln.
Proof. by move=> m n1 n2; rewrite !mulnA (mulnC m). Qed.

Lemma mulnAC : right_commutative muln.
Proof. by move=> m n p; rewrite -!mulnA (mulnC n). Qed.

Lemma mulnACA : interchange muln muln.
Proof. by move=> m n p q; rewrite -!mulnA (mulnCA n). Qed.

Lemma muln_eq0 m n : (m * n == 0) = (m == 0) || (n == 0).
Proof. by case: m n => // m [|n] //=; rewrite muln0. Qed.

Lemma muln_eq1 m n : (m * n == 1) = (m == 1) && (n == 1).
Proof. by case: m n => [|[|m]] [|[|n]] //; rewrite muln0. Qed.

Lemma muln_gt0 m n : (0 < m * n) = (0 < m) && (0 < n).
Proof. by case: m n => // m [|n] //=; rewrite muln0. Qed.

Lemma leq_pmull m n : n > 0 -> m <= n * m.
Proof. by move/prednK <-; apply: leq_addr. Qed.

Lemma leq_pmulr m n : n > 0 -> m <= m * n.
Proof. by move/leq_pmull; rewrite mulnC. Qed.

Lemma leq_mul2l m n1 n2 : (m * n1 <= m * n2) = (m == 0) || (n1 <= n2).
Proof. by rewrite [LHS]/leq -mulnBr muln_eq0. Qed.

Lemma leq_mul2r m n1 n2 : (n1 * m <= n2 * m) = (m == 0) || (n1 <= n2).
Proof. by rewrite -!(mulnC m) leq_mul2l. Qed.

Lemma leq_mul m1 m2 n1 n2 : m1 <= n1 -> m2 <= n2 -> m1 * m2 <= n1 * n2.
Proof.
move=> le_mn1 le_mn2; apply (@leq_trans (m1 * n2)).
  by rewrite leq_mul2l le_mn2 orbT.
by rewrite leq_mul2r le_mn1 orbT.
Qed.

Lemma eqn_mul2l m n1 n2 : (m * n1 == m * n2) = (m == 0) || (n1 == n2).
Proof. by rewrite eqn_leq !leq_mul2l -orb_andr -eqn_leq. Qed.

Lemma eqn_mul2r m n1 n2 : (n1 * m == n2 * m) = (m == 0) || (n1 == n2).
Proof. by rewrite eqn_leq !leq_mul2r -orb_andr -eqn_leq. Qed.

Lemma leq_pmul2l m n1 n2 : 0 < m -> (m * n1 <= m * n2) = (n1 <= n2).
Proof. by move/prednK=> <-; rewrite leq_mul2l. Qed.
Arguments leq_pmul2l [m n1 n2].

Lemma leq_pmul2r m n1 n2 : 0 < m -> (n1 * m <= n2 * m) = (n1 <= n2).
Proof. by move/prednK <-; rewrite leq_mul2r. Qed.
Arguments leq_pmul2r [m n1 n2].

Lemma eqn_pmul2l m n1 n2 : 0 < m -> (m * n1 == m * n2) = (n1 == n2).
Proof. by move/prednK <-; rewrite eqn_mul2l. Qed.
Arguments eqn_pmul2l [m n1 n2].

Lemma eqn_pmul2r m n1 n2 : 0 < m -> (n1 * m == n2 * m) = (n1 == n2).
Proof. by move/prednK <-; rewrite eqn_mul2r. Qed.
Arguments eqn_pmul2r [m n1 n2].

Lemma ltn_mul2l m n1 n2 : (m * n1 < m * n2) = (0 < m) && (n1 < n2).
Proof. by rewrite lt0n !ltnNge leq_mul2l negb_or. Qed.

Lemma ltn_mul2r m n1 n2 : (n1 * m < n2 * m) = (0 < m) && (n1 < n2).
Proof. by rewrite lt0n !ltnNge leq_mul2r negb_or. Qed.

Lemma ltn_pmul2l m n1 n2 : 0 < m -> (m * n1 < m * n2) = (n1 < n2).
Proof. by move/prednK <-; rewrite ltn_mul2l. Qed.
Arguments ltn_pmul2l [m n1 n2].

Lemma ltn_pmul2r m n1 n2 : 0 < m -> (n1 * m < n2 * m) = (n1 < n2).
Proof. by move/prednK <-; rewrite ltn_mul2r. Qed.
Arguments ltn_pmul2r [m n1 n2].

Lemma ltn_Pmull m n : 1 < n -> 0 < m -> m < n * m.
Proof. by move=> lt1n m_gt0; rewrite -[ltnLHS]mul1n ltn_pmul2r. Qed.

Lemma ltn_Pmulr m n : 1 < n -> 0 < m -> m < m * n.
Proof. by move=> lt1n m_gt0; rewrite mulnC ltn_Pmull. Qed.

Lemma ltn_mul m1 m2 n1 n2 : m1 < n1 -> m2 < n2 -> m1 * m2 < n1 * n2.
Proof.
move=> lt_mn1 lt_mn2; apply (@leq_ltn_trans (m1 * n2)).
  by rewrite leq_mul2l orbC ltnW.
by rewrite ltn_pmul2r // (leq_trans _ lt_mn2).
Qed.

Lemma maxnMr : right_distributive muln maxn.
Proof. by case=> // m n1 n2; rewrite /maxn (fun_if (muln _)) ltn_pmul2l. Qed.

Lemma maxnMl : left_distributive muln maxn.
Proof. by move=> m1 m2 n; rewrite -!(mulnC n) maxnMr. Qed.

Lemma minnMr : right_distributive muln minn.
Proof. by case=> // m n1 n2; rewrite /minn (fun_if (muln _)) ltn_pmul2l. Qed.

Lemma minnMl : left_distributive muln minn.
Proof. by move=> m1 m2 n; rewrite -!(mulnC n) minnMr. Qed.

Lemma iterM (T : Type) (n m : nat) (f : T -> T) :
  iter (n * m) f =1 iter n (iter m f).
Proof. by move=> x; elim: n => //= n <-; rewrite mulSn iterD. Qed.

(* Exponentiation. *)

Definition expn_rec m n := iterop n muln m 1.
Notation "m ^ n" := (expn_rec m n) : nat_rec_scope.
Definition expn := nosimpl expn_rec.
Notation "m ^ n" := (expn m n) : nat_scope.

Lemma expnE : expn = expn_rec. Proof. by []. Qed.

Lemma expn0 m : m ^ 0 = 1. Proof. by []. Qed.
Lemma expn1 m : m ^ 1 = m. Proof. by []. Qed.
Lemma expnS m n : m ^ n.+1 = m * m ^ n. Proof. by case: n; rewrite ?muln1. Qed.
Lemma expnSr m n : m ^ n.+1 = m ^ n * m. Proof. by rewrite mulnC expnS. Qed.

Lemma iter_muln m n p : iter n (muln m) p = m ^ n * p.
Proof. by elim: n => /= [|n ->]; rewrite ?mul1n // expnS mulnA. Qed.

Lemma iter_muln_1 m n : iter n (muln m) 1 = m ^ n.
Proof. by rewrite iter_muln muln1. Qed.

Lemma exp0n n : 0 < n -> 0 ^ n = 0. Proof. by case: n => [|[]]. Qed.

Lemma exp1n n : 1 ^ n = 1.
Proof. by elim: n => // n; rewrite expnS mul1n. Qed.

Lemma expnD m n1 n2 : m ^ (n1 + n2) = m ^ n1 * m ^ n2.
Proof. by elim: n1 => [|n1 IHn]; rewrite !(mul1n, expnS) // IHn mulnA. Qed.

Lemma expnMn m1 m2 n : (m1 * m2) ^ n = m1 ^ n * m2 ^ n.
Proof. by elim: n => // n IHn; rewrite !expnS IHn -!mulnA (mulnCA m2). Qed.

Lemma expnM m n1 n2 : m ^ (n1 * n2) = (m ^ n1) ^ n2.
Proof.
elim: n1 => [|n1 IHn]; first by rewrite exp1n.
by rewrite expnD expnS expnMn IHn.
Qed.

Lemma expnAC m n1 n2 : (m ^ n1) ^ n2 = (m ^ n2) ^ n1.
Proof. by rewrite -!expnM mulnC. Qed.

Lemma expn_gt0 m n : (0 < m ^ n) = (0 < m) || (n == 0).
Proof.
by case: m => [|m]; elim: n => //= n IHn; rewrite expnS // addn_gt0 IHn.
Qed.

Lemma expn_eq0 m e : (m ^ e == 0) = (m == 0) && (e > 0).
Proof. by rewrite !eqn0Ngt expn_gt0 negb_or -lt0n. Qed.

Lemma ltn_expl m n : 1 < m -> n < m ^ n.
Proof.
move=> m_gt1; elim: n => //= n; rewrite -(leq_pmul2l (ltnW m_gt1)) expnS.
by apply: leq_trans; apply: ltn_Pmull.
Qed.

Lemma leq_exp2l m n1 n2 : 1 < m -> (m ^ n1 <= m ^ n2) = (n1 <= n2).
Proof.
move=> m_gt1; elim: n1 n2 => [|n1 IHn] [|n2] //; last 1 first.
- by rewrite !expnS leq_pmul2l ?IHn // ltnW.
- by rewrite expn_gt0 ltnW.
by rewrite leqNgt (leq_trans m_gt1) // expnS leq_pmulr // expn_gt0 ltnW.
Qed.

Lemma ltn_exp2l m n1 n2 : 1 < m -> (m ^ n1 < m ^ n2) = (n1 < n2).
Proof. by move=> m_gt1; rewrite !ltnNge leq_exp2l. Qed.

Lemma eqn_exp2l m n1 n2 : 1 < m -> (m ^ n1 == m ^ n2) = (n1 == n2).
Proof. by move=> m_gt1; rewrite !eqn_leq !leq_exp2l. Qed.

Lemma expnI m : 1 < m -> injective (expn m).
Proof. by move=> m_gt1 e1 e2 /eqP; rewrite eqn_exp2l // => /eqP. Qed.

Lemma leq_pexp2l m n1 n2 : 0 < m -> n1 <= n2 -> m ^ n1 <= m ^ n2.
Proof. by case: m => [|[|m]] // _; [rewrite !exp1n | rewrite leq_exp2l]. Qed.

Lemma ltn_pexp2l m n1 n2 : 0 < m -> m ^ n1 < m ^ n2 -> n1 < n2.
Proof. by case: m => [|[|m]] // _; [rewrite !exp1n | rewrite ltn_exp2l]. Qed.

Lemma ltn_exp2r m n e : e > 0 -> (m ^ e < n ^ e) = (m < n).
Proof.
move=> e_gt0; apply/idP/idP=> [|ltmn].
  rewrite !ltnNge; apply: contra => lemn.
  by elim: e {e_gt0} => // e IHe; rewrite !expnS leq_mul.
by elim: e e_gt0 => // [[|e] IHe] _; rewrite ?expn1 // ltn_mul // IHe.
Qed.

Lemma leq_exp2r m n e : e > 0 -> (m ^ e <= n ^ e) = (m <= n).
Proof. by move=> e_gt0; rewrite leqNgt ltn_exp2r // -leqNgt. Qed.

Lemma eqn_exp2r m n e : e > 0 -> (m ^ e == n ^ e) = (m == n).
Proof. by move=> e_gt0; rewrite !eqn_leq !leq_exp2r. Qed.

Lemma expIn e : e > 0 -> injective (expn^~ e).
Proof. by move=> e_gt1 m n /eqP; rewrite eqn_exp2r // => /eqP. Qed.

Lemma iterX (T : Type) (n m : nat) (f : T -> T) :
  iter (n ^ m) f =1 iter m (iter n) f.
Proof. elim: m => //= m ihm x; rewrite expnS iterM; exact/eq_iter. Qed.

(* Factorial. *)

Fixpoint fact_rec n := if n is n'.+1 then n * fact_rec n' else 1.

Definition factorial := nosimpl fact_rec.

Notation "n `!" := (factorial n) (at level 2, format "n `!") : nat_scope.

Lemma factE : factorial = fact_rec. Proof. by []. Qed.

Lemma fact0 : 0`! = 1. Proof. by []. Qed.

Lemma factS n : (n.+1)`!  = n.+1 * n`!. Proof. by []. Qed.

Lemma fact_gt0 n : n`! > 0.
Proof. by elim: n => //= n IHn; rewrite muln_gt0. Qed.

Lemma fact_geq n : n <= n`!.
Proof. by case: n => // n; rewrite factS -(addn1 n) leq_pmulr ?fact_gt0. Qed.

Lemma ltn_fact m n : 0 < m -> m < n -> m`! < n`!.
Proof.
case: m n => // m n _; elim: n m => // n ih [|m] ?; last by rewrite ltn_mul ?ih.
by rewrite -[_.+1]muln1 leq_mul ?fact_gt0.
Qed.

(* Parity and bits. *)

Coercion nat_of_bool (b : bool) := if b then 1 else 0.

Lemma leq_b1 (b : bool) : b <= 1. Proof. by case: b. Qed.

Lemma addn_negb (b : bool) : ~~ b + b = 1. Proof. by case: b. Qed.

Lemma eqb0 (b : bool) : (b == 0 :> nat) = ~~ b. Proof. by case: b. Qed.

Lemma eqb1 (b : bool) : (b == 1 :> nat) = b. Proof. by case: b. Qed.

Lemma lt0b (b : bool) : (b > 0) = b. Proof. by case: b. Qed.

Lemma sub1b (b : bool) : 1 - b = ~~ b. Proof. by case: b. Qed.

Lemma mulnb (b1 b2 : bool) : b1 * b2 = b1 && b2.
Proof. by case: b1; case: b2. Qed.

Lemma mulnbl (b : bool) n : b * n = (if b then n else 0).
Proof. by case: b; rewrite ?mul1n. Qed.

Lemma mulnbr (b : bool) n : n * b = (if b then n else 0).
Proof. by rewrite mulnC mulnbl. Qed.

Fixpoint odd n := if n is n'.+1 then ~~ odd n' else false.

Lemma oddS n : odd n.+1 = ~~ odd n. Proof. by []. Qed.

Lemma oddb (b : bool) : odd b = b. Proof. by case: b. Qed.

Lemma oddD m n : odd (m + n) = odd m (+) odd n.
Proof. by elim: m => [|m IHn] //=; rewrite -addTb IHn addbA addTb. Qed.

Lemma oddB m n : n <= m -> odd (m - n) = odd m (+) odd n.
Proof.
by move=> le_nm; apply: (@canRL bool) (addbK _) _; rewrite -oddD subnK.
Qed.

Lemma oddN i m : odd m = false -> i <= m -> odd (m - i) = odd i.
Proof. by move=> oddm /oddB ->; rewrite oddm. Qed.

Lemma oddM m n : odd (m * n) = odd m && odd n.
Proof. by elim: m => //= m IHm; rewrite oddD -addTb andb_addl -IHm. Qed.

Lemma oddX m n : odd (m ^ n) = (n == 0) || odd m.
Proof. by elim: n => // n IHn; rewrite expnS oddM {}IHn orbC; case odd. Qed.

(* Doubling. *)

Fixpoint double_rec n := if n is n'.+1 then n'.*2%Nrec.+2 else 0
where "n .*2" := (double_rec n) : nat_rec_scope.

Definition double := nosimpl double_rec.
Notation "n .*2" := (double n) : nat_scope.

Lemma doubleE : double = double_rec. Proof. by []. Qed.

Lemma double0 : 0.*2 = 0. Proof. by []. Qed.

Lemma doubleS n : n.+1.*2 = n.*2.+2. Proof. by []. Qed.

Lemma double_pred n : n.-1.*2 = n.*2.-2. Proof. by case: n. Qed.

Lemma addnn n : n + n = n.*2.
Proof. by apply: eqP; elim: n => // n IHn; rewrite addnS. Qed.

Lemma mul2n m : 2 * m = m.*2.
Proof. by rewrite mulSn mul1n addnn. Qed.

Lemma muln2 m : m * 2 = m.*2.
Proof. by rewrite mulnC mul2n. Qed.

Lemma doubleD m n : (m + n).*2 = m.*2 + n.*2.
Proof. by rewrite -!mul2n mulnDr. Qed.

Lemma doubleB m n : (m - n).*2 = m.*2 - n.*2.
Proof. by elim: m n => [|m IHm] []. Qed.

Lemma leq_double m n : (m.*2 <= n.*2) = (m <= n).
Proof. by rewrite /leq -doubleB; case (m - n). Qed.

Lemma ltn_double m n : (m.*2 < n.*2) = (m < n).
Proof. by rewrite 2!ltnNge leq_double. Qed.

Lemma ltn_Sdouble m n : (m.*2.+1 < n.*2) = (m < n).
Proof. by rewrite -doubleS leq_double. Qed.

Lemma leq_Sdouble m n : (m.*2 <= n.*2.+1) = (m <= n).
Proof. by rewrite leqNgt ltn_Sdouble -leqNgt. Qed.

Lemma odd_double n : odd n.*2 = false.
Proof. by rewrite -addnn oddD addbb. Qed.

Lemma double_gt0 n : (0 < n.*2) = (0 < n).
Proof. by case: n. Qed.

Lemma double_eq0 n : (n.*2 == 0) = (n == 0).
Proof. by case: n. Qed.

Lemma doubleMl m n : (m * n).*2 = m.*2 * n.
Proof. by rewrite -!mul2n mulnA. Qed.

Lemma doubleMr m n : (m * n).*2 = m * n.*2.
Proof. by rewrite -!muln2 mulnA. Qed.

(* Halving. *)

Fixpoint half (n : nat) : nat := if n is n'.+1 then uphalf n' else n
with   uphalf (n : nat) : nat := if n is n'.+1 then n'./2.+1 else n
where "n ./2" := (half n) : nat_scope.

Lemma uphalfE n : uphalf n = n.+1./2.
Proof. by []. Qed.

Lemma doubleK : cancel double half.
Proof. by elim=> //= n ->. Qed.

Definition half_double := doubleK.
Definition double_inj := can_inj doubleK.

Lemma uphalf_double n : uphalf n.*2 = n.
Proof. by elim: n => //= n ->. Qed.

Lemma uphalf_half n : uphalf n = odd n + n./2.
Proof. by elim: n => //= n ->; rewrite addnA addn_negb. Qed.

Lemma odd_double_half n : odd n + n./2.*2 = n.
Proof.
by elim: n => //= n {3}<-; rewrite uphalf_half doubleD; case (odd n).
Qed.

Lemma halfK n : n./2.*2 = n - odd n.
Proof. by rewrite -[n in n - _]odd_double_half addnC addnK. Qed.

Lemma uphalfK n : (uphalf n).*2 = odd n + n.
Proof. by rewrite uphalfE halfK/=; case: odd; rewrite ?subn1. Qed.

Lemma odd_halfK n : odd n -> n./2.*2 = n.-1.
Proof. by rewrite halfK => ->; rewrite subn1. Qed.

Lemma even_halfK n : ~~ odd n -> n./2.*2 = n.
Proof. by rewrite halfK => /negbTE->; rewrite subn0. Qed.

Lemma odd_uphalfK n : odd n -> (uphalf n).*2 = n.+1.
Proof. by rewrite uphalfK => ->. Qed.

Lemma even_uphalfK n : ~~ odd n -> (uphalf n).*2 = n.
Proof. by rewrite uphalfK => /negbTE->. Qed.

Lemma half_bit_double n (b : bool) : (b + n.*2)./2 = n.
Proof. by case: b; rewrite /= (half_double, uphalf_double). Qed.

Lemma halfD m n : (m + n)./2 = (odd m && odd n) + (m./2 + n./2).
Proof.
rewrite -[n in LHS]odd_double_half addnCA.
rewrite -[m in LHS]odd_double_half -addnA -doubleD.
by do 2!case: odd; rewrite /= ?add0n ?half_double ?uphalf_double.
Qed.

Lemma half_leq m n : m <= n -> m./2 <= n./2.
Proof. by move/subnK <-; rewrite halfD addnA leq_addl. Qed.

Lemma geq_half_double m n : (m <= n./2) = (m.*2 <= n).
Proof.
rewrite -[X in _.*2 <= X]odd_double_half.
case: odd; last by rewrite leq_double.
by case: m => // m; rewrite doubleS ltnS ltn_double.
Qed.

Lemma ltn_half_double m n : (m./2 < n) = (m < n.*2).
Proof. by rewrite ltnNge geq_half_double -ltnNge. Qed.

Lemma leq_half_double m n : (m./2 <= n) = (m <= n.*2.+1).
Proof. by case: m => [|[|m]] //; rewrite ltnS ltn_half_double. Qed.

Lemma gtn_half_double m n : (n < m./2) = (n.*2.+1 < m).
Proof. by rewrite ltnNge leq_half_double -ltnNge. Qed.

Lemma half_gt0 n : (0 < n./2) = (1 < n).
Proof. by case: n => [|[]]. Qed.

Lemma uphalf_leq m n : m <= n -> uphalf m <= uphalf n.
Proof.
move/subnK <-; rewrite !uphalf_half oddD halfD !addnA.
by do 2 case: odd; apply: leq_addl.
Qed.

Lemma leq_uphalf_double m n : (uphalf m <= n) = (m <= n.*2).
Proof. by rewrite uphalfE leq_half_double. Qed.

Lemma geq_uphalf_double m n : (m <= uphalf n) = (m.*2 <= n.+1).
Proof. by rewrite uphalfE geq_half_double. Qed.

Lemma gtn_uphalf_double m n : (n < uphalf m) = (n.*2 < m).
Proof. by rewrite uphalfE gtn_half_double. Qed.

Lemma ltn_uphalf_double m n : (uphalf m < n) = (m.+1 < n.*2).
Proof. by rewrite uphalfE ltn_half_double. Qed.

Lemma uphalf_gt0 n : (0 < uphalf n) = (0 < n).
Proof. by case: n. Qed.

Lemma odd_geq m n : odd n -> (m <= n) = (m./2.*2 <= n).
Proof.
move=> odd_n; rewrite -[m in LHS]odd_double_half -[n]odd_double_half odd_n.
by case: (odd m); rewrite // leq_Sdouble ltnS leq_double.
Qed.

Lemma odd_ltn m n : odd n -> (n < m) = (n < m./2.*2).
Proof. by move=> odd_n; rewrite !ltnNge odd_geq. Qed.

Lemma odd_gt0 n : odd n -> n > 0. Proof. by case: n. Qed.

Lemma odd_gt2 n : odd n -> n > 1 -> n > 2.
Proof. by move=> odd_n n_gt1; rewrite odd_geq. Qed.

(* Squares and square identities. *)

Lemma mulnn m : m * m = m ^ 2.
Proof. by rewrite !expnS muln1. Qed.

Lemma sqrnD m n : (m + n) ^ 2 = m ^ 2 + n ^ 2 + 2 * (m * n).
Proof.
rewrite -!mulnn mul2n mulnDr !mulnDl (mulnC n) -!addnA.
by congr (_ + _); rewrite addnA addnn addnC.
Qed.

Lemma sqrnB m n : n <= m -> (m - n) ^ 2 = m ^ 2 + n ^ 2 - 2 * (m * n).
Proof.
move/subnK <-; rewrite addnK sqrnD -addnA -addnACA -addnA.
by rewrite addnn -mul2n -mulnDr -mulnDl addnK.
Qed.

Lemma sqrnD_sub m n : n <= m -> (m + n) ^ 2 - 4 * (m * n) = (m - n) ^ 2.
Proof.
move=> le_nm; rewrite -[4]/(2 * 2) -mulnA mul2n -addnn subnDA.
by rewrite sqrnD addnK sqrnB.
Qed.

Lemma subn_sqr m n : m ^ 2 - n ^ 2 = (m - n) * (m + n).
Proof. by rewrite mulnBl !mulnDr addnC (mulnC m) subnDl. Qed.

Lemma ltn_sqr m n : (m ^ 2 < n ^ 2) = (m < n).
Proof. by rewrite ltn_exp2r. Qed.

Lemma leq_sqr m n : (m ^ 2 <= n ^ 2) = (m <= n).
Proof. by rewrite leq_exp2r. Qed.

Lemma sqrn_gt0 n : (0 < n ^ 2) = (0 < n).
Proof. exact: (ltn_sqr 0). Qed.

Lemma eqn_sqr m n : (m ^ 2 == n ^ 2) = (m == n).
Proof. by rewrite eqn_exp2r. Qed.

Lemma sqrn_inj : injective (expn ^~ 2).
Proof. exact: expIn. Qed.

(* Almost strict inequality: an inequality that is strict unless some    *)
(* specific condition holds, such as the Cauchy-Schwartz or the AGM      *)
(* inequality (we only prove the order-2 AGM here; the general one       *)
(* requires sequences).                                                  *)
(*   We formalize the concept as a rewrite multirule, that can be used   *)
(* both to rewrite the non-strict inequality to true, and the equality   *)
(* to the specific condition (for strict inequalities use the ltn_neqAle *)
(* lemma); in addition, the conditional equality also coerces to a       *)
(* non-strict one.                                                       *)

Definition leqif m n C := ((m <= n) * ((m == n) = C))%type.

Notation "m <= n ?= 'iff' C" := (leqif m n C) : nat_scope.

Coercion leq_of_leqif m n C (H : m <= n ?= iff C) := H.1 : m <= n.

Lemma leqifP m n C : reflect (m <= n ?= iff C) (if C then m == n else m < n).
Proof.
rewrite ltn_neqAle; apply: (iffP idP) => [|lte]; last by rewrite !lte; case C.
by case C => [/eqP-> | /andP[/negPf]]; split=> //; apply: eqxx.
Qed.

Lemma leqif_refl m C : reflect (m <= m ?= iff C) C.
Proof. by apply: (iffP idP) => [-> | <-] //; split; rewrite ?eqxx. Qed.

Lemma leqif_trans m1 m2 m3 C12 C23 :
  m1 <= m2 ?= iff C12 -> m2 <= m3 ?= iff C23 -> m1 <= m3 ?= iff C12 && C23.
Proof.
move=> ltm12 ltm23; apply/leqifP; rewrite -ltm12.
have [->|eqm12] := eqVneq; first by rewrite ltn_neqAle !ltm23 andbT; case C23.
by rewrite (@leq_trans m2) ?ltm23 // ltn_neqAle eqm12 ltm12.
Qed.

Lemma mono_leqif f : {mono f : m n / m <= n} ->
  forall m n C, (f m <= f n ?= iff C) = (m <= n ?= iff C).
Proof. by move=> f_mono m n C; rewrite /leqif !eqn_leq !f_mono. Qed.

Lemma leqif_geq m n : m <= n -> m <= n ?= iff (m >= n).
Proof. by move=> lemn; split=> //; rewrite eqn_leq lemn. Qed.

Lemma leqif_eq m n : m <= n -> m <= n ?= iff (m == n).
Proof. by []. Qed.

Lemma geq_leqif a b C : a <= b ?= iff C -> (b <= a) = C.
Proof. by case=> le_ab; rewrite eqn_leq le_ab. Qed.

Lemma ltn_leqif a b C : a <= b ?= iff C -> (a < b) = ~~ C.
Proof. by move=> le_ab; rewrite ltnNge (geq_leqif le_ab). Qed.

Lemma ltnNleqif x y C : x <= y ?= iff ~~ C -> (x < y) = C.
Proof. by move=> /ltn_leqif; rewrite negbK. Qed.

Lemma eq_leqif x y C : x <= y ?= iff C -> (x == y) = C.
Proof. by move=> /leqifP; case: C ltngtP => [] []. Qed.

Lemma eqTleqif x y C : x <= y ?= iff C -> C -> x = y.
Proof. by move=> /eq_leqif<-/eqP. Qed.

Lemma leqif_add m1 n1 C1 m2 n2 C2 :
    m1 <= n1 ?= iff C1 -> m2 <= n2 ?= iff C2 ->
  m1 + m2 <= n1 + n2 ?= iff C1 && C2.
Proof.
rewrite -(mono_leqif (leq_add2r m2)) -(mono_leqif (leq_add2l n1) m2).
exact: leqif_trans.
Qed.

Lemma leqif_mul m1 n1 C1 m2 n2 C2 :
    m1 <= n1 ?= iff C1 -> m2 <= n2 ?= iff C2 ->
  m1 * m2 <= n1 * n2 ?= iff (n1 * n2 == 0) || (C1 && C2).
Proof.
case: n1 => [|n1] le1; first by case: m1 le1 => [|m1] [_ <-] //.
case: n2 m2 => [|n2] [|m2] /=; try by case=> // _ <-; rewrite !muln0 ?andbF.
have /leq_pmul2l-/mono_leqif<-: 0 < n1.+1 by [].
by apply: leqif_trans; have /leq_pmul2r-/mono_leqif->: 0 < m2.+1.
Qed.

Lemma nat_Cauchy m n : 2 * (m * n) <= m ^ 2 + n ^ 2 ?= iff (m == n).
Proof.
without loss le_nm: m n / n <= m.
  by have [?|/ltnW ?] := leqP n m; last rewrite eq_sym addnC (mulnC m); apply.
apply/leqifP; have [-> | ne_mn] := eqVneq; first by rewrite addnn mul2n.
by rewrite -subn_gt0 -sqrnB // sqrn_gt0 subn_gt0 ltn_neqAle eq_sym ne_mn.
Qed.

Lemma nat_AGM2 m n : 4 * (m * n) <= (m + n) ^ 2 ?= iff (m == n).
Proof.
rewrite -[4]/(2 * 2) -mulnA mul2n -addnn sqrnD; apply/leqifP.
by rewrite ltn_add2r eqn_add2r ltn_neqAle !nat_Cauchy; case: eqVneq.
Qed.

Section ContraLeq.
Implicit Types (b : bool) (m n : nat) (P : Prop).

Lemma contraTleq b m n : (n < m -> ~~ b) -> (b -> m <= n).
Proof. by rewrite ltnNge; apply: contraTT. Qed.

Lemma contraTltn b m n : (n <= m -> ~~ b) -> (b -> m < n).
Proof. by rewrite ltnNge; apply: contraTN. Qed.

Lemma contraPleq P m n : (n < m -> ~ P) -> (P -> m <= n).
Proof. by rewrite ltnNge; apply: contraPT. Qed.

Lemma contraPltn P m n : (n <= m -> ~ P) -> (P -> m < n).
Proof. by rewrite ltnNge; apply: contraPN. Qed.

Lemma contraNleq b m n : (n < m -> b) -> (~~ b -> m <= n).
Proof. by rewrite ltnNge; apply: contraNT. Qed.

Lemma contraNltn b m n : (n <= m -> b) -> (~~ b -> m < n).
Proof. by rewrite ltnNge; apply: contraNN. Qed.

Lemma contra_not_leq P m n : (n < m -> P) -> (~ P -> m <= n).
Proof. by rewrite ltnNge; apply: contra_notT. Qed.

Lemma contra_not_ltn P m n : (n <= m -> P) -> (~ P -> m < n).
Proof. by rewrite ltnNge; apply: contra_notN. Qed.

Lemma contraFleq b m n : (n < m -> b) -> (b = false -> m <= n).
Proof. by rewrite ltnNge; apply: contraFT. Qed.

Lemma contraFltn b m n : (n <= m -> b) -> (b = false -> m < n).
Proof. by rewrite ltnNge; apply: contraFN. Qed.

Lemma contra_leqT b m n : (~~ b -> m < n) -> (n <= m -> b).
Proof. by rewrite ltnNge; apply: contraTT. Qed.

Lemma contra_ltnT b m n : (~~ b -> m <= n) -> (n < m -> b).
Proof. by rewrite ltnNge; apply: contraNT. Qed.

Lemma contra_leqN b m n : (b -> m < n) -> (n <= m -> ~~ b).
Proof. by rewrite ltnNge; apply: contraTN. Qed.

Lemma contra_ltnN b m n : (b -> m <= n) -> (n < m -> ~~ b).
Proof. by rewrite ltnNge; apply: contraNN. Qed.

Lemma contra_leq_not P m n : (P -> m < n) -> (n <= m -> ~ P).
Proof. by rewrite ltnNge; apply: contraTnot. Qed.

Lemma contra_ltn_not P m n : (P -> m <= n) -> (n < m -> ~ P).
Proof. by rewrite ltnNge; apply: contraNnot. Qed.

Lemma contra_leqF b m n : (b -> m < n) -> (n <= m -> b = false).
Proof. by rewrite ltnNge; apply: contraTF. Qed.

Lemma contra_ltnF b m n : (b -> m <= n) -> (n < m -> b = false).
Proof. by rewrite ltnNge; apply: contraNF. Qed.

Lemma contra_leq m n p q : (q < p -> n < m) -> (m <= n -> p <= q).
Proof. by rewrite !ltnNge; apply: contraTT. Qed.

Lemma contra_leq_ltn m n p q : (q <= p -> n < m) -> (m <= n -> p < q).
Proof. by rewrite !ltnNge; apply: contraTN. Qed.

Lemma contra_ltn_leq m n p q : (q < p -> n <= m) -> (m < n -> p <= q).
Proof. by rewrite !ltnNge; apply: contraNT. Qed.

Lemma contra_ltn m n p q : (q <= p -> n <= m) -> (m < n -> p < q).
Proof. by rewrite !ltnNge; apply: contraNN. Qed.

End ContraLeq.

Section Monotonicity.
Variable T : Type.

Lemma homo_ltn_in (D : {pred nat}) (f : nat -> T) (r : T -> T -> Prop) :
  (forall y x z, r x y -> r y z -> r x z) ->
  {in D &, forall i j k, i < k < j -> k \in D} ->
  {in D, forall i, i.+1 \in D -> r (f i) (f i.+1)} ->
  {in D &, {homo f : i j / i < j >-> r i j}}.
Proof.
move=> r_trans Dcx r_incr i j iD jD lt_ij; move: (lt_ij) (jD) => /subnKC<-.
elim: (_ - _) => [|k ihk]; first by rewrite addn0 => Dsi; apply: r_incr.
move=> DSiSk [: DSik]; apply: (r_trans _ _ _ (ihk _)); rewrite ?addnS.
  by abstract: DSik; apply: (Dcx _ _ iD DSiSk); rewrite ltn_addr ?addnS /=.
by apply: r_incr; rewrite -?addnS.
Qed.

Lemma homo_ltn (f : nat -> T) (r : T -> T -> Prop) :
  (forall y x z, r x y -> r y z -> r x z) ->
  (forall i, r (f i) (f i.+1)) -> {homo f : i j / i < j >-> r i j}.
Proof. by move=> /(@homo_ltn_in predT f) fr fS i j; apply: fr. Qed.

Lemma homo_leq_in (D : {pred nat}) (f : nat -> T) (r : T -> T -> Prop) :
  (forall x, r x x) -> (forall y x z, r x y -> r y z -> r x z) ->
  {in D &, forall i j k, i < k < j -> k \in D} ->
  {in D, forall i, i.+1 \in D -> r (f i) (f i.+1)} ->
  {in D &, {homo f : i j / i <= j >-> r i j}}.
Proof.
move=> r_refl r_trans Dcx /(homo_ltn_in r_trans Dcx) lt_r i j iD jD.
case: ltngtP => [? _||->] //; exact: lt_r.
Qed.

Lemma homo_leq (f : nat -> T) (r : T -> T -> Prop) :
   (forall x, r x x) -> (forall y x z, r x y -> r y z -> r x z) ->
  (forall i, r (f i) (f i.+1)) -> {homo f : i j / i <= j >-> r i j}.
Proof. by move=> rrefl /(@homo_leq_in predT f r) fr fS i j; apply: fr. Qed.

Section NatToNat.
Variable (f : nat -> nat).

(****************************************************************************)
(* This listing of "Let"s factor out the required premises for the          *)
(* subsequent lemmas, putting them in the context so that "done" solves the *)
(* goals quickly                                                            *)
(****************************************************************************)

Let ltn_neqAle := ltn_neqAle.
Let gtn_neqAge x y : (y < x) = (x != y) && (y <= x).
Proof. by rewrite ltn_neqAle eq_sym. Qed.
Let anti_leq := anti_leq.
Let anti_geq : antisymmetric geq.
Proof. by move=> m n /=; rewrite andbC => /anti_leq. Qed.
Let leq_total := leq_total.

Lemma ltnW_homo : {homo f : m n / m < n} -> {homo f : m n / m <= n}.
Proof. exact: homoW. Qed.

Lemma inj_homo_ltn : injective f -> {homo f : m n / m <= n} ->
  {homo f : m n / m < n}.
Proof. exact: inj_homo. Qed.

Lemma ltnW_nhomo : {homo f : m n /~ m < n} -> {homo f : m n /~ m <= n}.
Proof. exact: homoW. Qed.

Lemma inj_nhomo_ltn : injective f -> {homo f : m n /~ m <= n} ->
  {homo f : m n /~ m < n}.
Proof. exact: inj_homo. Qed.

Lemma incn_inj : {mono f : m n / m <= n} -> injective f.
Proof. exact: mono_inj. Qed.

Lemma decn_inj : {mono f : m n /~ m <= n} -> injective f.
Proof. exact: mono_inj. Qed.

Lemma leqW_mono : {mono f : m n / m <= n} -> {mono f : m n / m < n}.
Proof. exact: anti_mono. Qed.

Lemma leqW_nmono : {mono f : m n /~ m <= n} -> {mono f : m n /~ m < n}.
Proof. exact: anti_mono. Qed.

Lemma leq_mono : {homo f : m n / m < n} -> {mono f : m n / m <= n}.
Proof. exact: total_homo_mono. Qed.

Lemma leq_nmono : {homo f : m n /~ m < n} -> {mono f : m n /~ m <= n}.
Proof. exact: total_homo_mono. Qed.

Variables (D D' : {pred nat}).

Lemma ltnW_homo_in : {in D & D', {homo f : m n / m < n}} ->
  {in D & D', {homo f : m n / m <= n}}.
Proof. exact: homoW_in. Qed.

Lemma ltnW_nhomo_in : {in D & D', {homo f : m n /~ m < n}} ->
                 {in D & D', {homo f : m n /~ m <= n}}.
Proof. exact: homoW_in. Qed.

Lemma inj_homo_ltn_in : {in D & D', injective f} ->
                        {in D & D', {homo f : m n / m <= n}} ->
  {in D & D', {homo f : m n / m < n}}.
Proof. exact: inj_homo_in. Qed.

Lemma inj_nhomo_ltn_in : {in D & D', injective f} ->
                        {in D & D', {homo f : m n /~ m <= n}} ->
  {in D & D', {homo f : m n /~ m < n}}.
Proof. exact: inj_homo_in. Qed.

Lemma incn_inj_in : {in D &, {mono f : m n / m <= n}} ->
  {in D &, injective f}.
Proof. exact: mono_inj_in. Qed.

Lemma decn_inj_in : {in D &, {mono f : m n /~ m <= n}} ->
  {in D &, injective f}.
Proof. exact: mono_inj_in. Qed.

Lemma leqW_mono_in : {in D &, {mono f : m n / m <= n}} ->
  {in D &, {mono f : m n / m < n}}.
Proof. exact: anti_mono_in. Qed.

Lemma leqW_nmono_in : {in D &, {mono f : m n /~ m <= n}} ->
  {in D &, {mono f : m n /~ m < n}}.
Proof. exact: anti_mono_in. Qed.

Lemma leq_mono_in : {in D &, {homo f : m n / m < n}} ->
  {in D &, {mono f : m n / m <= n}}.
Proof. exact: total_homo_mono_in. Qed.

Lemma leq_nmono_in : {in D &, {homo f : m n /~ m < n}} ->
  {in D &, {mono f : m n /~ m <= n}}.
Proof. exact: total_homo_mono_in. Qed.

End NatToNat.
End Monotonicity.

Lemma leq_pfact : {in [pred n | 0 < n] &, {mono factorial : m n / m <= n}}.
Proof. by apply: leq_mono_in => n m n0 m0; apply: ltn_fact. Qed.

Lemma leq_fact : {homo factorial : m n / m <= n}.
Proof.
by move=> [m|m n mn]; rewrite ?fact_gt0// leq_pfact// inE (leq_trans _ mn).
Qed.

Lemma ltn_pfact : {in [pred n | 0 < n] &, {mono factorial : m n / m < n}}.
Proof. exact/leqW_mono_in/leq_pfact. Qed.

(* Support for larger integers. The normal definitions of +, - and even  *)
(* IO are unsuitable for Peano integers larger than 2000 or so because   *)
(* they are not tail-recursive. We provide a workaround module, along    *)
(* with a rewrite multirule to change the tailrec operators to the       *)
(* normal ones. We handle IO via the NatBin module, but provide our      *)
(* own (more efficient) conversion functions.                            *)

Module NatTrec.

(*   Usage:                                             *)
(*     Import NatTrec.                                  *)
(*        in section defining functions, rebinds all    *)
(*        non-tail recursive operators.                 *)
(*     rewrite !trecE.                                  *)
(*        in the correctness proof, restores operators  *)

Fixpoint add m n := if m is m'.+1 then m' + n.+1 else n
where "n + m" := (add n m) : nat_scope.

Fixpoint add_mul m n s := if m is m'.+1 then add_mul m' n (n + s) else s.

Definition mul m n := if m is m'.+1 then add_mul m' n n else 0.

Notation "n * m" := (mul n m) : nat_scope.

Fixpoint mul_exp m n p := if n is n'.+1 then mul_exp m n' (m * p) else p.

Definition exp m n := if n is n'.+1 then mul_exp m n' m else 1.

Notation "n ^ m" := (exp n m) : nat_scope.

Local Notation oddn := odd.
Fixpoint odd n := if n is n'.+2 then odd n' else eqn n 1.

Local Notation doublen := double.
Definition double n := if n is n'.+1 then n' + n.+1 else 0.
Notation "n .*2" := (double n) : nat_scope.

Lemma addE : add =2 addn.
Proof. by elim=> //= n IHn m; rewrite IHn addSnnS. Qed.

Lemma doubleE : double =1 doublen.
Proof. by case=> // n; rewrite -addnn -addE. Qed.

Lemma add_mulE n m s : add_mul n m s = addn (muln n m) s.
Proof. by elim: n => //= n IHn in m s *; rewrite IHn addE addnCA addnA. Qed.

Lemma mulE : mul =2 muln.
Proof. by case=> //= n m; rewrite add_mulE addnC. Qed.

Lemma mul_expE m n p : mul_exp m n p = muln (expn m n) p.
Proof.
by elim: n => [|n IHn] in p *; rewrite ?mul1n //= expnS IHn mulE mulnCA mulnA.
Qed.

Lemma expE : exp =2 expn.
Proof. by move=> m [|n] //=; rewrite mul_expE expnS mulnC. Qed.

Lemma oddE : odd =1 oddn.
Proof.
move=> n; rewrite -[n in LHS]odd_double_half addnC.
by elim: n./2 => //=; case (oddn n).
Qed.

Definition trecE := (addE, (doubleE, oddE), (mulE, add_mulE, (expE, mul_expE))).

End NatTrec.

Notation natTrecE := NatTrec.trecE.

Lemma eq_binP : Equality.axiom N.eqb.
Proof.
move=> p q; apply: (iffP idP) => [|<-]; last by case: p => //; elim.
by case: q; case: p => //; elim=> [p IHp|p IHp|] [q|q|] //= /IHp [->].
Qed.

Canonical bin_nat_eqMixin := EqMixin eq_binP.
Canonical bin_nat_eqType := Eval hnf in EqType N bin_nat_eqMixin.

Arguments N.eqb !n !m.

Section NumberInterpretation.

Import BinPos.

Section Trec.

Import NatTrec.

Fixpoint nat_of_pos p0 :=
  match p0 with
  | xO p => (nat_of_pos p).*2
  | xI p => (nat_of_pos p).*2.+1
  | xH   => 1
  end.

End Trec.

Local Coercion nat_of_pos : positive >-> nat.

Coercion nat_of_bin b := if b is Npos p then p : nat else 0.

Fixpoint pos_of_nat n0 m0 :=
  match n0, m0 with
  | n.+1, m.+2 => pos_of_nat n m
  | n.+1,    1 => xO (pos_of_nat n n)
  | n.+1,    0 => xI (pos_of_nat n n)
  |    0,    _ => xH
  end.

Definition bin_of_nat n0 := if n0 is n.+1 then Npos (pos_of_nat n n) else 0%num.

Lemma bin_of_natK : cancel bin_of_nat nat_of_bin.
Proof.
have sub2nn n : n.*2 - n = n by rewrite -addnn addKn.
case=> //= n; rewrite -[n in RHS]sub2nn.
by elim: n {2 4}n => // m IHm [|[|n]] //=; rewrite IHm // natTrecE sub2nn.
Qed.

Lemma nat_of_binK : cancel nat_of_bin bin_of_nat.
Proof.
case=> //=; elim=> //= p; case: (nat_of_pos p) => //= n [<-].
  by rewrite natTrecE !addnS {2}addnn; elim: {1 3}n.
by rewrite natTrecE addnS /= addnS {2}addnn; elim: {1 3}n.
Qed.

Lemma nat_of_succ_pos p : Pos.succ p = p.+1 :> nat.
Proof. by elim: p => //= p ->; rewrite !natTrecE. Qed.

Lemma nat_of_add_pos p q : (p + q)%positive = p + q :> nat.
Proof.
apply: @fst _ (Pplus_carry p q = (p + q).+1 :> nat) _.
elim: p q => [p IHp|p IHp|] [q|q|] //=; rewrite !natTrecE //;
  by rewrite ?IHp ?nat_of_succ_pos ?(doubleS, doubleD, addn1, addnS).
Qed.

Lemma nat_of_mul_pos p q : (p * q)%positive = p * q :> nat.
Proof.
elim: p => [p IHp|p IHp|] /=; rewrite ?mul1n //;
  by rewrite ?nat_of_add_pos /= !natTrecE IHp doubleMl.
Qed.

Lemma nat_of_add_bin b1 b2 : (b1 + b2)%num = b1 + b2 :> nat.
Proof. by case: b1 b2 => [|p] [|q]; rewrite ?addn0 //= nat_of_add_pos. Qed.

Lemma nat_of_mul_bin b1 b2 : (b1 * b2)%num = b1 * b2 :> nat.
Proof. by case: b1 b2 => [|p] [|q]; rewrite ?muln0 //= nat_of_mul_pos. Qed.

Lemma nat_of_exp_bin n (b : N) : n ^ b = pow_N 1 muln n b.
Proof.
by case: b; last (elim=> //= p <-; rewrite natTrecE mulnn -expnM muln2 ?expnS).
Qed.

End NumberInterpretation.

(* Big(ger) nat IO; usage:                              *)
(*     Num 1 072 399                                    *)
(*        to create large numbers for test cases        *)
(* Eval compute in [Num of some expression]             *)
(*        to display the result of an expression that   *)
(*        returns a larger integer.                     *)

Record number : Type := Num {bin_of_number :> N}.

Definition extend_number (nn : number) m := Num (nn * 1000 + bin_of_nat m).

Coercion extend_number : number >-> Funclass.

Canonical number_subType := [newType for bin_of_number].
Definition number_eqMixin := Eval hnf in [eqMixin of number by <:].
Canonical number_eqType := Eval hnf in EqType number number_eqMixin.

Notation "[ 'Num' 'of' e ]" := (Num (bin_of_nat e))
  (at level 0, format "[ 'Num'  'of'  e ]") : nat_scope.

(* Interface to ring/ring_simplify tactics *)

Lemma nat_semi_ring : semi_ring_theory 0 1 addn muln (@eq _).
Proof. exact: mk_srt add0n addnC addnA mul1n mul0n mulnC mulnA mulnDl. Qed.

Lemma nat_semi_morph :
  semi_morph 0 1 addn muln (@eq _) 0%num 1%num Nplus Nmult pred1 nat_of_bin.
Proof. by move: nat_of_add_bin nat_of_mul_bin; split=> //= m n /eqP ->. Qed.

Lemma nat_power_theory : power_theory 1 muln (@eq _) nat_of_bin expn.
Proof. by split; apply: nat_of_exp_bin. Qed.

(* Interface to the ring tactic machinery. *)

Fixpoint pop_succn e := if e is e'.+1 then fun n => pop_succn e' n.+1 else id.

Ltac pop_succn e := eval lazy beta iota delta [pop_succn] in (pop_succn e 1).

Ltac nat_litteral e :=
  match pop_succn e with
  | ?n.+1 => constr: (bin_of_nat n)
  |     _ => NotConstant
  end.

Ltac succn_to_add :=
  match goal with
  | |- context G [?e.+1] =>
    let x := fresh "NatLit0" in
    match pop_succn e with
    | ?n.+1 => pose x := n.+1; let G' := context G [x] in change G'
    | _ ?e' ?n => pose x := n; let G' := context G [x + e'] in change G'
    end; succn_to_add; rewrite {}/x
  | _ => idtac
  end.

Add Ring nat_ring_ssr : nat_semi_ring (morphism nat_semi_morph,
   constants [nat_litteral], preprocess [succn_to_add],
   power_tac nat_power_theory [nat_litteral]).

(* A congruence tactic, similar to the boolean one, along with an .+1/+  *)
(* normalization tactic.                                                 *)

Ltac nat_norm :=
  succn_to_add; rewrite ?add0n ?addn0 -?addnA ?(addSn, addnS, add0n, addn0).

Ltac nat_congr := first
 [ apply: (congr1 succn _)
 | apply: (congr1 predn _)
 | apply: (congr1 (addn _) _)
 | apply: (congr1 (subn _) _)
 | apply: (congr1 (addn^~ _) _)
 | match goal with |- (?X1 + ?X2 = ?X3) =>
     symmetry;
     rewrite -1?(addnC X1) -?(addnCA X1);
     apply: (congr1 (addn X1) _);
     symmetry
   end ].


   Theorem z2_1_a: forall A : Prop,
                   (A \/ A) <-> (A /\ A).
   Proof.
      intros. split.
      intros. elim H. intros. split. assumption. assumption.
      intros. split. assumption. assumption.
      intros. left. apply H.
   Qed.
   Theorem z2_1_a': forall A : Prop,
                   (A /\ A) <-> (A).
   Proof.
      intros. split.
      intros. elim H. intros. assumption.
      intros. split. assumption. assumption.
   Qed.

   Theorem z2_1_a'': forall A : Prop,
                   (A \/ A) <-> (A).
   Proof.
      intros. split.
      intros. elim H. intros. assumption. apply id.
      intros. left. assumption.
   Qed.

   Theorem z2_2_a: forall A : Prop,
                   (~~A) <-> (A).
   Proof.
      Require Import Classical.
      intros. split.
      intros. apply NNPP. intro. contradiction.
      intros. intro. contradiction.
   Qed.

   Theorem z2_3_a: forall (A B C : Type -> Prop),
           (forall x : Type, (A x \/ B x) -> C x) <->
               (forall x : Type,  A x -> C x)
                   /\ forall x : Type,  B x -> C x.
   Proof.
      intros. split. intros. split. intros. apply H. left. assumption.
                     intros. apply H. right. assumption.
      intros. elim H0. elim H. clear H. intros. revert H2. apply H.
              intros. revert H1. elim H. intros. revert H3. apply H2.
  Qed.


(* Exercise coq_nat_07 *)

(* So far we were dealing with addition on natural numbers. How
   about multiplication? Not surprisingly it is defined in the
   standard library of Coq, but before seeing the definition
   try to think of how would you define that (using addition). *)
Print mult.
Check mult.

(* Here is this definition for reference (and in the way you would
   type it in, which slightly differs from the way Coq presents it)

Fixpoint mult (n m:nat) {struct n} : nat :=
  match n with
  | O => 0
  | S p => m + mult p m
  end
*)

(* Let us prove the 0 properties of multiplication *)

Lemma mult_0_l : forall n, 0 * n = 0.

Proof.
intros.
unfold mult.
reflexivity.

Qed.

Lemma mult_0_r : forall n, n * 0 = 0.

Proof.
intros.
induction n.
simpl; reflexivity.
simpl.
assumption.
Qed.


Require Export TopologicalSpaces.
Require Export OrderTopology.
Require Export Reals.

Local Unset Standard Proposition Elimination Names.

Definition RTop := OrderTopology Rle.

Require Export MetricSpaces.

Definition R_metric (x y:R) : R := Rabs (y-x).

Lemma R_metric_is_metric: metric R_metric.
Proof.
constructor.
intros.
unfold R_metric.
pose proof (Rabs_pos (y-x)).
auto with *.

intros.
unfold R_metric.
replace (y-x) with (-(x-y)); try ring.
apply Rabs_Ropp.

intros.
unfold R_metric.
replace (z-x) with ((y-x) + (z-y)); try ring.
apply Rabs_triang.

intros.
unfold R_metric.
replace (x-x) with 0; try ring.
exact Rabs_R0.

intros.
assert (y-x=0).
apply NNPP.
contradict H.
apply Rabs_no_R0; assumption.
auto with *.
Qed.

Lemma Rmetric_bound: forall x y z:R, R_metric x z < y - x ->
  z < y.
Proof.
intros.
replace z with (x + (z-x)); try ring.
apply Rle_lt_trans with (x + R_metric x z).
assert (z - x <= R_metric x z).
apply Rle_abs.
auto with real.
replace y with (x + (y-x)); try ring.
auto with real.
Qed.

Lemma Rmetric_bound2: forall x y z:R, R_metric y z < y - x ->
  x < z.
Proof.
intros.
replace z with (y + (z-y)); try ring.
apply Rlt_le_trans with (y - R_metric y z).
apply Rlt_minus in H.
apply Rminus_lt.
replace (x - (y - R_metric y z)) with
  (R_metric y z - (y - x)); try ring.
trivial.
assert (y - z <= R_metric y z).
rewrite (metric_sym _ _ R_metric_is_metric y z).
apply Rle_abs.
apply Rle_minus in H0.
apply Rminus_le.
replace (y - R_metric y z - (y + (z - y))) with
  (y - z - R_metric y z); trivial; ring.
Qed.

Lemma RTop_metrization: metrizes RTop R_metric.
Proof.
refine (let Hsubbasis := Build_TopologicalSpace_from_subbasis_subbasis
  _ (order_topology_subbasis _ Rle) in _).
clearbody Hsubbasis.
red; intros.
constructor.
intros.
destruct H.
assert (open_ball (point_set RTop) R_metric x r = Intersection
  [ y:R | x-r <= y /\ y <> x-r ]
  [ y:R | y <= x+r /\ y <> x+r ]).
apply Extensionality_Ensembles; split; red; intros.
destruct H0.
assert (x - r < x0).
apply Rmetric_bound2 with x.
ring_simplify; trivial.
assert (x + r > x0).
apply Rmetric_bound with x.
ring_simplify; trivial.
repeat split; auto with real.
constructor.
destruct H0.
destruct H0.
destruct H0.
destruct H1.
destruct H1.
apply Rabs_def1.
assert (x0-x <= r).
apply Rminus_le.
apply Rle_minus in H1.
replace (x0 - x - r) with (x0 - (x + r)); trivial; ring.
assert (x0 - x <> r).
intro.
contradiction H3.
rewrite <- H5.
ring.
destruct (total_order_T (x0 - x) r) as [[|]|]; try tauto.
assert (r < r).
apply Rlt_le_trans with (x0 - x); trivial.
contradict H6.
apply Rlt_irrefl.
assert (-r <= x0 - x).
apply Rle_minus in H0.
apply Rminus_le.
replace (-r - (x0 - x)) with (x - r - x0); try ring; trivial.
assert (-r <> x0 - x).
intro.
contradiction H2.
replace r with (- -r); try ring.
rewrite H5; ring.
destruct (total_order_T (-r) (x0 - x)) as [[|]|]; try tauto.
assert (-r < -r).
apply Rle_lt_trans with (x0 - x); trivial.
contradict H6.
apply Rlt_irrefl.

rewrite H0.
constructor.
apply (@open_intersection2 RTop).
apply Hsubbasis; constructor.
apply Hsubbasis; constructor.
assert (x-r < x).
apply Rminus_lt.
ring_simplify.
auto with real.
assert (x+r > x).
apply Rminus_gt.
ring_simplify; trivial.
repeat split; auto with real.

intros.
destruct H.
destruct H.
destruct H0.
pose proof (H _ H0).
assert (exists eps:R, eps > 0 /\ Included (open_ball _ R_metric x eps) S).
clear H0.
induction H2.
exists 1.
split.
red.
auto with real.
intro; constructor.
destruct H0.
destruct H1.
destruct H0.
exists (x0-x).
split.
destruct (total_order_T x0 x) as [[]|].
assert (x < x).
apply Rle_lt_trans with x0; trivial.
contradict H2.
apply Rlt_irrefl.
congruence.
apply Rgt_minus; trivial.
red; intros y ?.
destruct H2.
constructor.
assert (y < x0).
apply Rmetric_bound with x; trivial.
split; auto with real.

destruct H1.
destruct H0.
exists (x - x0).
split.
destruct (total_order_T x0 x) as [[]|].
apply Rgt_minus; trivial.
congruence.
assert (x < x).
apply Rlt_le_trans with x0; trivial.
contradict H2.
apply Rlt_irrefl.
intros y ?.
destruct H2.
constructor.
assert (x0 < y).
apply Rmetric_bound2 with x; trivial.
split; auto with real.
destruct H1.
apply IHfinite_intersections in H1.
apply IHfinite_intersections0 in H3.
destruct H1 as [eps1 []].
destruct H3 as [eps2 []].
exists (Rmin eps1 eps2).
split.
unfold Rmin.
destruct Rle_dec; trivial.
red; intros y ?.
destruct H6.
constructor.
apply H4.
constructor.
apply Rlt_le_trans with (Rmin eps1 eps2); trivial.
unfold Rmin; destruct Rle_dec; auto with real.
apply H5.
constructor.
apply Rlt_le_trans with (Rmin eps1 eps2); trivial.
unfold Rmin; destruct Rle_dec; auto with real.

destruct H3 as [eps []].
exists (open_ball R R_metric x eps).
split.
constructor.
trivial.
assert (Included S (FamilyUnion F)).
intros y ?.
exists S; trivial.
auto with sets.
Qed.

Corollary RTop_metrizable: metrizable RTop.
Proof.
exists R_metric.
exact R_metric_is_metric.
exact RTop_metrization.
Qed.

Lemma RTop_separable: separable RTop.
Proof.
Require Import RationalsInReals.
exists (Im Full_set Q2R).
apply countable_img.
apply countable_type_ensemble.
exact Q_countable.

apply meets_every_nonempty_open_impl_dense.
intros.
destruct H0 as [x].
destruct (RTop_metrization x).
destruct (open_neighborhood_basis_cond U) as [V []].
split; trivial.
destruct H1.
destruct (rationals_dense_in_reals (x-r) (x+r)) as [q].
apply Rminus_gt.
replace (x+r-(x-r)) with (r+r); try ring.
apply Rgt_trans with r; auto with real.
pattern r at 3.
replace r with (r+0); try ring.
auto with real.

exists (Q2R q).
constructor.
exists q; trivial.
constructor.
apply H2.
constructor.
destruct H3.
apply Rabs_def1.
apply Rminus_lt.
apply Rlt_minus in H4.
replace (Q2R q - x - r) with (Q2R q - (x + r)); trivial; ring.
apply Rminus_lt.
apply Rlt_minus in H3.
replace (-r - (Q2R q - x)) with (x - r - Q2R q); trivial; ring.
Qed.

Require Export Compactness.

Lemma bounded_real_net_has_cluster_point: forall (I:DirectedSet)
  (x:Net I RTop) (a b:R), (forall i:DS_set I, a <= x i <= b) ->
  exists x0:point_set RTop, net_cluster_point x x0.
Proof.
(* idea: the liminf is a cluster point *)
intros.
destruct (classic (inhabited (DS_set I))) as [Hinh|Hempty].
assert (forall i:DS_set I, { y:R | is_glb
                             (Im [ j:DS_set I | DS_ord i j ] x) y }).
intro.
apply inf.
exists a.
red; intros.
destruct H0.
destruct (H x0).
rewrite H1.
auto with real.
exists (x i).
exists i; trivial.
constructor.
apply preord_refl.
apply DS_ord_cond.

assert ({ x0:R | is_lub (Im Full_set (fun i:DS_set I => proj1_sig (X i)))
                        x0 }).
apply sup.
exists b.
red; intros.
destruct H0 as [i].
destruct (X i).
simpl in H1.
rewrite H1.
destruct i0.
cut (b >= x0).
auto with real.
apply Rge_trans with (x i).
destruct (H i).
auto with real.
apply H2.
exists i; trivial.
constructor.
apply preord_refl.
apply DS_ord_cond.

destruct Hinh as [i0].
exists (proj1_sig (X i0)).
exists i0; trivial.
constructor.

destruct H0 as [x0].
exists x0.
assert (forall i j:DS_set I, DS_ord i j ->
  proj1_sig (X i) <= proj1_sig (X j)).
intros.
destruct (X i0).
destruct (X j).
simpl.
destruct i1.
destruct i2.
apply H4.
red; intros.
destruct H5.
destruct H5.
apply H1.
exists x3; trivial.
constructor.
apply preord_trans with j; trivial.
apply DS_ord_cond.

red; intros.
destruct (RTop_metrization x0).
destruct (open_neighborhood_basis_cond U).
split; trivial.
destruct H3.
destruct H3.
destruct (lub_approx _ _ r i).
trivial.
destruct H5.
destruct H5.
destruct H6.
red; intros.
destruct (DS_join_cond x1 i0).
destruct H9.
remember (X x2) as y2.
destruct y2.
destruct (glb_approx _ _ r i1).
trivial.
destruct H11.
destruct H11.
destruct H11.
destruct H12.
exists x4.
split.
apply preord_trans with x2; trivial.
apply DS_ord_cond.
apply H4.
constructor.
assert (y <= proj1_sig (X x2)).
rewrite H7.
apply H0; trivial.
rewrite <- Heqy2 in H15.
simpl in H15.
assert (proj1_sig (X x2) <= x0).
apply i.
exists x2; trivial.
constructor.
rewrite <- Heqy2 in H16.
simpl in H16.
rewrite <- H13.
apply Rabs_def1.

cut (y0 < x0 + r).
intro.
apply Rlt_minus in H17.
apply Rminus_lt.
replace (y0 - x0 - r) with (y0-(x0+r)); trivial; ring.
apply Rlt_le_trans with (x3 + r).
trivial.
auto with real.

cut (y0 > x0 - r).
intro.
apply Rlt_minus in H17.
apply Rminus_lt.
replace (-r - (y0-x0)) with (x0-r-y0); trivial; ring.
apply Rge_gt_trans with y.
apply Rge_trans with x3; auto with real.
trivial.

exists a.
red; intros.
red; intros.
contradiction Hempty.
exists; exact i.
Qed.

Lemma R_closed_interval_compact: forall a b:R, a <= b ->
  compact (SubspaceTopology ([x:point_set RTop | a <= x <= b])).
Proof.
intros a b Hbound.
apply net_cluster_point_impl_compact.
intros.
pose (y := fun i:DS_set I => proj1_sig (x i)).
destruct (bounded_real_net_has_cluster_point _ y a b).
intros.
unfold y.
destruct (x i).
destruct i0.
simpl.
trivial.

assert (closed [x:point_set RTop | a <= x <= b]).
assert ([x:point_set RTop | a <= x <= b] = Intersection
                [ x:point_set RTop | a <= x ]
                [ x:point_set RTop | x <= b ]).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct H1.
constructor; constructor; trivial.
destruct H1.
destruct H1.
destruct H2.
constructor.
auto.
rewrite H1.
apply closed_intersection2.
apply upper_closed_interval_closed.
constructor; red; intros; auto with real.
apply Rle_trans with y0; trivial.
intros.
destruct (total_order_T x1 y0) as [[|]|]; auto with real.
apply lower_closed_interval_closed.
constructor; red; intros; auto with real.
apply Rle_trans with y0; trivial.
intros.
destruct (total_order_T x1 y0) as [[|]|]; auto with real.

assert (Ensembles.In [x:point_set RTop | a <= x <= b] x0).
rewrite <- (closure_fixes_closed _ H1).
apply net_cluster_point_in_closure with _ y.
destruct H as [i0].
exists i0.
intros.
constructor.
unfold y.
destruct (x j).
simpl.
destruct i.
trivial.
trivial.

exists (exist _ x0 H2).
red; intros.
destruct (subspace_topology_topology _ _ _ H3) as [V].
destruct H5.
red; intros.
assert (Ensembles.In V x0).
rewrite H6 in H4.
destruct H4.
simpl in H4.
trivial.

destruct (H0 V H5 H7 i) as [j []].
exists j.
split; trivial.
rewrite H6.
constructor.
simpl.
exact H9.
Qed.

Lemma R_compact_subset_bounded: forall A:Ensemble (point_set RTop),
  compact (SubspaceTopology A) -> bound A.
Proof.
intros.
destruct (H (Im Full_set (fun y:R => inverse_image (subspace_inc _)
                   [ x:point_set RTop | y - 1 < x < y + 1 ]))).
intros.
destruct H0.
rewrite H1.
apply subspace_inc_continuous.
replace [x0:point_set RTop | x-1 < x0 < x+1] with
  (Intersection [x0:point_set RTop | x-1 <= x0 /\ x0 <> x-1]
                [x0:point_set RTop | x0 <= x+1 /\ x0 <> x+1]).
pose proof (Build_TopologicalSpace_from_subbasis_subbasis
  _ (order_topology_subbasis _ Rle)).
apply open_intersection2.
apply H2.
constructor.
apply H2.
constructor.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
destruct H2.
destruct H2.
destruct H3.
destruct H3.
constructor.
split.
destruct (total_order_T (x-1) x0) as [[|]|]; auto with real.
contradiction H4; symmetry; trivial.
assert (x0 < x0).
apply Rlt_le_trans with (x-1); auto with real.
contradict H6; apply Rlt_irrefl.
destruct (total_order_T x0 (x+1)) as [[|]|]; auto with real.
contradiction H5.
assert (x0 < x0).
apply Rle_lt_trans with (x+1); auto with real.
contradict H6; apply Rlt_irrefl.
destruct H2.
destruct H2.
constructor; constructor; split; auto with real.

apply Extensionality_Ensembles; split; red; intros.
constructor.
eexists.
exists (proj1_sig x).
constructor.
reflexivity.
constructor.
constructor.
destruct x.
simpl.
split; apply Rminus_lt; auto with real.
replace (x-1-x) with (-1); try ring.
apply Ropp_lt_gt_0_contravar.
exact Rlt_0_1.

destruct H0.
destruct H1.
assert (exists a:R, forall S:Ensemble (point_set (SubspaceTopology A)),
  forall b:point_set (SubspaceTopology A),
  Ensembles.In x S -> Ensembles.In S b -> proj1_sig b < a).
clear H2.
induction H0.
exists 0.
intros.
destruct H0.
destruct IHFinite.
cut (Included A0 (Add A0 x)); auto with sets.
assert (Ensembles.In (Add A0 x) x).
right.
constructor.
apply H1 in H4.
destruct H4.
exists (Rmax x0 (x+1)).
intros.
destruct H6.
apply Rlt_le_trans with x0.
apply H3 with x1; trivial.
unfold Rmax.
destruct Rle_dec; auto with real.
destruct H6.
rewrite H5 in H7.
destruct H7.
destruct H6.
apply Rlt_le_trans with (x+1).
apply H6.
unfold Rmax; destruct Rle_dec; auto with real.

destruct H3 as [a].
exists a.
red; intros.
assert (Ensembles.In (FamilyUnion x)
  (exist (fun x:R => Ensembles.In A x) x0 H4)).
rewrite H2; constructor.
inversion H5.
pose proof (H3 _ _ H6 H7).
simpl in H9.
auto with real.
Qed.

Lemma Ropp_continuous: continuous Ropp (X:=RTop) (Y:=RTop).
Proof.
apply pointwise_continuity.
intro.
apply metric_space_fun_continuity with R_metric R_metric;
  try apply RTop_metrization.
intros.
exists eps.
split; trivial.
intros.
unfold R_metric.
replace (-x' - -x) with (x-x'); try ring.
rewrite Rabs_minus_sym; trivial.
Qed.

Require Export Connectedness.

Lemma R_connected: connected RTop.
Proof.
cut (forall S:Ensemble (point_set RTop),
  clopen S -> Ensembles.In S 0 -> S = Full_set).
intro.
red; intros.
destruct (classic (Ensembles.In S 0)).
right.
apply H; trivial.
left.
assert (Complement S = Full_set).
apply H; trivial.
destruct H0; split; trivial.
red; rewrite Complement_Complement; trivial.
apply Extensionality_Ensembles; split; red; intros.
assert (Ensembles.In (Complement S) x).
rewrite H2; constructor.
contradiction H4.
destruct H3.

cut (forall S:Ensemble (point_set RTop),
  clopen S -> Ensembles.In S 0 -> forall x:R, x > 0 ->
                                  Ensembles.In S x).
intro.
assert (forall S:Ensemble (point_set RTop),
  clopen S -> Ensembles.In S 0 -> forall x:R, x < 0 ->
                                  Ensembles.In S x).
intros.
pose (T := inverse_image Ropp S).

assert (Ensembles.In T (-x)).
apply H.
destruct H0; split.
apply Ropp_continuous; trivial.
red.
subst T.
rewrite <- inverse_image_complement.
apply Ropp_continuous; trivial.
constructor.
replace (-0) with 0; trivial; ring.
cut (0 < -x); auto with real.
destruct H3.
rewrite Ropp_involutive in H3; trivial.

intros.
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct (total_order_T x 0) as [[|]|].
apply H0; trivial.
congruence.
apply H; trivial.

intros.
apply NNPP; intro.
pose (T := [ y:R | forall z:R, 0 <= z <= y -> Ensembles.In S z ]).
assert (Ensembles.In T 0).
constructor.
intros.
assert (z = 0).
destruct H3; auto with real.
rewrite H4; trivial.

destruct (sup T).
exists x.
red; intros.
cut (~ x0>x).
apply Rnot_lt_le; auto with real.
intro.
destruct H4.
apply H2.
apply H4.
split; auto with real.
exists 0.
exact H3.

assert (0 <= x0).
apply i.
exact H3.

destruct (RTop_metrization x0).
assert (Ensembles.In S x0).
rewrite <- (closure_fixes_closed S); try apply H.
apply meets_every_open_neighborhood_impl_closure.
intros.
destruct (open_neighborhood_basis_cond U).
split; trivial.
destruct H7.
destruct H7.
destruct (lub_approx _ _ r i).
trivial.
destruct H9.
exists (Rmax x1 0).
constructor.
unfold Rmax.
destruct Rle_dec.
trivial.
apply H9.
auto with real.

apply H8.
constructor.
unfold Rmax.
destruct Rle_dec.
unfold R_metric.
rewrite Rabs_minus_sym.
replace (x0-0) with x0; try ring.
apply Rabs_def1.
apply Rminus_lt.
destruct H10.
apply Rlt_le_trans with x1; trivial.
apply Rlt_le_trans with 0; auto with real.

apply Rabs_def1.
apply Rle_lt_trans with 0; auto with real.
destruct H10.
apply Rle_minus; trivial.
destruct H10.
apply Rminus_lt.
apply Rlt_minus in H10.
replace (-r - (x1-x0)) with (x0-r-x1); trivial; ring.

destruct (open_neighborhood_basis_cond S).
split; trivial.
apply H.
destruct H6.
destruct H6.

destruct (lub_approx _ _ r i).
trivial.
destruct H8.

assert (Ensembles.In T (x0+r/2)).
constructor.
intros.
destruct H10.
destruct (total_order_T z x1) as [[|]|].
apply H8.
split; auto with real.
apply H8.
split; auto with real.
apply H7.
constructor.
apply Rabs_def1.
apply Rle_lt_trans with (r/2).
apply Rminus_le.
apply Rle_minus in H11.
replace (z-x0-r/2) with (z-(x0+r/2)); trivial; ring.
apply Rminus_gt.
replace (r-r/2) with (r/2); try field.
apply Rmult_gt_0_compat; auto with real.
auto with *.
apply Rlt_trans with (x1 - x0).
destruct H9.
apply Rlt_minus in H9.
apply Rminus_lt.
replace (-r - (x1-x0)) with (x0-r-x1); trivial; ring.
cut (x1<z); trivial.
intro.
unfold Rminus.
auto with real.

assert (x0 + r/2 <= x0).
apply i.
exact H10.

absurd (x0 + r/2 > x0).
apply Rge_not_gt; auto with real.
apply Rminus_gt.
ring_simplify.
apply Rmult_gt_0_compat; auto with real.
apply Rinv_0_lt_compat.
auto with real.
Qed.

Require Export Completeness.

Lemma R_cauchy_sequence_bounded: forall x:nat->R,
  cauchy R_metric x -> bound (Im Full_set x).
Proof.
intros.
destruct (H 1) as [N].
red; auto with real.
assert (exists y:R, forall n:nat, (n<N)%nat -> x n <= y).
clear H0; induction N.
exists 0.
intros.
contradict H0.
auto with arith.
destruct IHN as [y].
exists (Rmax y (x N)).
intros.
apply lt_n_Sm_le in H1.
destruct (le_lt_or_eq _ _ H1).
apply Rle_trans with y.
apply H0; trivial.
apply Rmax_l.
rewrite H2.
apply Rmax_r.

destruct H1 as [y].
exists (Rmax y (x N + 1)).
red; intros.
destruct H2 as [n].
rewrite H3; clear y0 H3.
destruct (le_or_lt N n).
apply Rle_trans with (x N + 1).
assert (R_metric (x n) (x N) < 1).
apply H0; auto with arith.
apply Rabs_def2 in H4.
destruct H4.
Require Import Fourier.
fourier.
apply Rmax_r.
apply Rle_trans with y; auto.
apply Rmax_l.
Qed.

Lemma R_cauchy_sequence_lower_bound: forall x:nat->R,
  cauchy R_metric x -> lower_bound (Im Full_set x).
Proof.
intros.
assert (cauchy R_metric (fun n:nat => - x n)).
red; intros.
destruct (H eps H0) as [N].
exists N.
intros.
replace (R_metric (- x m) (- x n)) with (R_metric (x m) (x n)).
apply H1; trivial.
unfold R_metric.
replace (x n - x m) with (- (- x n - - x m)) by ring.
apply Rabs_Ropp.
destruct (R_cauchy_sequence_bounded _ H0) as [m].
exists (-m).
red; intros.
cut (-x0 <= m).
intros; fourier.
apply H1.
destruct H2 as [n].
exists n; trivial.
f_equal; trivial.
Qed.

Lemma R_metric_complete: complete R_metric R_metric_is_metric.
Proof.
red; intros.
destruct (R_cauchy_sequence_bounded _ H) as [b].
destruct (R_cauchy_sequence_lower_bound _ H) as [a].
destruct (bounded_real_net_has_cluster_point nat_DS x a b) as [x0].
intros; split; [ cut (x i >= a); auto with real; apply H1 | apply H0 ];
  exists i; trivial; constructor.
exists x0.
apply cauchy_sequence_with_cluster_point_converges; trivial.
apply metric_space_net_cluster_point with R_metric;
  try apply MetricTopology_metrizable.
intros.
apply metric_space_net_cluster_point_converse with RTop; trivial.
apply RTop_metrization.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus y (plus lf1 x).