Require Import VST.floyd.proofauto.
Require Import cprogs.min_prog.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Require Import ZArith.
Require Import List.
Import ListNotations.
Open Scope Z.

Theorem fold_min_general:
  forall (al: list Z)(i: Z),
  In i (al) ->
  forall x, List.fold_right Z.min x al <= i.
Proof.
induction al; intros.
inversion H.
destruct H.
subst a.
simpl.
apply Z.le_min_l.
simpl. rewrite Z.le_min_r.
apply IHal.
apply H.
Qed.

Theorem fold_min:
  forall (al: list Z)(i: Z),
  In i (al) ->
  List.fold_right Z.min (hd 0 al) al <= i.
Proof.
intros.
apply fold_min_general.
apply H.
Qed.

Lemma Forall_fold_min:
  forall (f: Z -> Prop) (x: Z) (al: list Z),
    f x -> Forall f al -> f (fold_right Z.min x al).
Proof.
 intros.
 induction H0.
 simpl. auto.
 simpl.
 unfold Z.min at 1.
 destruct (Z.compare x0 (fold_right Z.min x l)) eqn:?; auto.
Qed.

Lemma fold_min_another:
  forall x al y,
    fold_right Z.min x (al ++ [y]) = Z.min (fold_right Z.min x al) y.
Proof.
 intros.
 revert x; induction al; simpl; intros.
 apply Z.min_comm.
 rewrite <- Z.min_assoc. f_equal.
 apply IHal.
Qed.

Lemma is_int_I32_Znth_map_Vint:
 forall i s al,
  0 <= i < Zlength al ->
  is_int I32 s (Znth i (map Vint al)).
Proof.
intros. rewrite Znth_map; auto.
Qed.
Hint Extern 3 (is_int I32 _ (Znth _ (map Vint _))) =>
  (apply  is_int_I32_Znth_map_Vint; rewrite ?Zlength_map; omega).


Add LoadPath ".".
Require Export groups.
Require Export Coq.Bool.Bool.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Logic.Eqdep_dec.

(* Реализация группы для Z_2 *)
Proposition bool_left_id : forall x: bool, xorb false x = x.
Proof.
  destruct x; simpl; reflexivity.
Qed.

Proposition bool_left_inv : forall x: bool, xorb (id x) x = false.
Proof.
  destruct x; simpl; reflexivity.
Qed.

Proposition xorb_assoc : forall x y z: bool, xorb x (xorb y z) = xorb (xorb x y) z.
Proof.
  intros. destruct x; destruct y; destruct z; simpl; reflexivity.
Qed.

Instance semigroupBool : Semigroup bool :=
{
    mult := xorb;
    assoc := xorb_assoc
}.

Instance monoidBool : Monoid bool :=
{
  e := false;
  left_id := bool_left_id;
}.

Instance groupBool : Group bool :=
{
  inv := (@id bool);
  left_inv := bool_left_inv;
}.

(* Реализация группы для Z_3 *)
Module GroupZ_3.
(* Тип Z_3 - подмножество nat с операцией сложения по модулю 3 *)
Record Z_3 : Type := Z3
{
  n :> nat;
  proof : (n <? 3) = true
}.

(* Nat.mod_upper_bound: forall a b : nat, b <> 0 -> a mod b < b *)

(* Определяем обитателей типа Z_3 *)
Proposition lt_0_3 : (0 <? 3) = true.
Proof.
  simpl. reflexivity.
Qed.

Definition z3_0 : Z_3 := (Z3 0 lt_0_3).

Proposition lt_1_3 : (1 <? 3) = true.
Proof.
  reflexivity.
Qed.

Definition z3_1 : Z_3 := (Z3 1 lt_1_3).

Proposition lt_2_3 : (2 <? 3) = true.
Proof.
  reflexivity.
Qed.

Definition z3_2 : Z_3 := (Z3 2 lt_2_3).
(* Конец определения обитателей *)

Proposition three_ne_0 : 3 <> 0.
Proof.
  discriminate.
Qed.

Lemma mod_upper_bound_bool : forall (a b : nat), b <> O -> (a mod b <? b) = true.
Proof.
  intros a b H. apply (Nat.mod_upper_bound a b) in H. case Nat.ltb_spec0.
  - reflexivity.
  - intros Hcontr. contradiction.
Qed.

Check (mod_upper_bound_bool 2 3) three_ne_0.

Definition nat_Z_3 (n: nat) : Z_3 :=
  let a := n mod 3 in
  (Z3 a ((mod_upper_bound_bool n 3) three_ne_0)).

Coercion nat_Z_3: nat >-> Z_3.

Definition Z3_op (x y: Z_3) : Z_3 :=
  let a := (x + y) mod 3 in
  Z3 a (mod_upper_bound_bool _ 3 three_ne_0).

Lemma Z_3_inv_lemma (k: nat) : ((3 + k) <? 3 = true) -> False.
Proof.
  intro. induction k as [| k' IH].
  - simpl in H. inversion H.
  - rewrite Nat.add_succ_r in H. auto.
Qed.

Lemma void {t : Set} : False -> t.
Proof.
  intro. contradiction H.
Qed.

Search (?n mod ?m < ?m ).
Definition Z_3_inv (x : Z_3) : Z_3 :=
  match x with
  | Z3 m pf => Z3 ((3 - m) mod 3) (mod_upper_bound_bool (3 - m) _ three_ne_0)
  end.

Set Printing All.
Lemma Z3_eq n m p q : n = m -> Z3 n p = Z3 m q.
Proof.
  intros H. revert p q. rewrite H. clear H. intros. apply f_equal. apply UIP_dec. apply bool_dec.
Qed.

Proposition n_apply : forall (x : nat), n (nat_Z_3 x) = x mod 3.
Proof.
  intro. simpl. reflexivity.
Qed.

Proposition n_apply' : forall (x : nat) (prf: (x <? 3) = true), n (Z3 x prf) = x.
Proof.
  intros. simpl. reflexivity.
Qed.

Proposition Z_op_sum : forall (x y: nat), Z3_op x y = x + y.
Proof.
  intros. unfold Z3_op. apply Z3_eq. repeat rewrite (n_apply _). rewrite (Nat.add_mod x y 3 three_ne_0). reflexivity.
Qed.

Proposition Z_op_sum' : forall (x y: Z_3), Z3_op x y = (n x) + (n y).
Proof.
  intros. unfold Z3_op. apply Z3_eq. repeat rewrite (n_apply _). rewrite (Nat.add_mod x y 3 three_ne_0). reflexivity.
Qed.

Example Z_3_inv_0 : Z_3_inv z3_0 = z3_0.
Proof.
  simpl. apply Z3_eq. reflexivity.
Qed.

Example Z_3_inv_1 : Z_3_inv z3_0 = z3_0.
Proof.
  simpl. apply Z3_eq. reflexivity.
Qed.

Example Z_3_inv_2 : Z_3_inv z3_2 = z3_1.
Proof.
  simpl. apply Z3_eq. reflexivity.
Qed.

(* Доказательство групповых теорем для Z_3 *)

Proposition Z3_left_id : forall x: Z_3, (Z3_op z3_0 x) = x.
Proof.
  intro. unfold Z3_op. destruct x as [vx proof]. apply Z3_eq. unfold n, z3_0. rewrite plus_O_n. apply Nat.mod_small. apply Nat.ltb_lt in proof. assumption.
Qed.

Proposition Z3_left_inv : forall x: Z_3, Z3_op (Z_3_inv x) x = z3_0.
Proof.
  intro. unfold Z3_op. unfold Z_3_inv. apply Z3_eq. destruct x as [vx proof]. repeat rewrite n_apply'. rewrite (Nat.add_mod_idemp_l _ _ _ three_ne_0). rewrite Nat.sub_add.
  - simpl. reflexivity.
  - apply Nat.ltb_lt in proof. apply Nat.lt_le_incl. assumption.
Qed.

Proposition Z3_assoc : forall x y z: Z_3, Z3_op x (Z3_op y z) = Z3_op (Z3_op x y) z.
Proof.
  intros. repeat rewrite (Z_op_sum' _ _). repeat rewrite n_apply.
  unfold nat_Z_3. apply Z3_eq. rewrite (Nat.add_mod_idemp_l _ _ _ three_ne_0). rewrite (Nat.add_mod_idemp_r _ _ _ three_ne_0). rewrite Nat.add_assoc. reflexivity.
Qed.

Instance semigroupZ3 : Semigroup Z_3 :=
{
  mult := Z3_op;
  assoc := Z3_assoc
}.

Instance monoidZ3 : Monoid Z_3 :=
{
  e := z3_0;
  left_id := Z3_left_id;
}.

Instance groupZ3 : Group Z_3 :=
{
  inv := Z_3_inv;
  left_inv := Z3_left_inv;
}.

End GroupZ_3.

Module GroupZ_n.
(* Реализация группы для Z_n *)
Variable pk : nat.
(* Нам нужно, чтобы k > 0 *)
Definition k := S pk.
(* Тип Z_n - подмножество nat с операцией сложения по модулю n *)
Record Z_k : Type := Zk
{
  n :> nat;
  proof : (n <? k) = true
}.

(* Определяем обитателей типа Z_k *)
Proposition lt_0_k : (0 <? k) = true.
Proof.
  simpl. reflexivity.
Qed.

Definition zk_0 : Z_k := (Zk 0 lt_0_k).

Proposition k_ne_0 : k <> 0.
Proof.
  discriminate.
Qed.

Lemma mod_upper_bound_bool : forall (a b : nat), b <> O -> (a mod b <? b) = true.
Proof.
  intros a b H. apply (Nat.mod_upper_bound a b) in H. case Nat.ltb_spec0.
  - reflexivity.
  - intros Hcontr. contradiction.
Qed.

Check (mod_upper_bound_bool 2 k) k_ne_0.

Definition nat_Z_k (n: nat) : Z_k :=
  let a := n mod k in
  (Zk a ((mod_upper_bound_bool n k) k_ne_0)).

Coercion nat_Z_k: nat >-> Z_k.

Definition Zk_op (x y: Z_k) : Z_k :=
  let a := (x + y) mod k in
  Zk a (mod_upper_bound_bool _ k k_ne_0).

Lemma Z_k_inv_lemma (m: nat) : ((k + m) <? k = true) -> False.
Proof.
  simpl. change k with (S pk). unfold Nat.ltb. simpl. destruct pk.
  - intros. discriminate H.
  -  rewrite Nat.leb_le. apply Nat.lt_nge. rewrite Nat.add_succ_comm. rewrite Nat.add_comm. apply Nat.lt_add_pos_l. apply Nat.lt_0_succ.
Qed.

Lemma void {t : Set} : False -> t.
Proof.
  intro. contradiction H.
Qed.

Definition Z_k_inv (x : Z_k) : Z_k :=
  match x with
  | Zk m pf => Zk ((k - m) mod k) (mod_upper_bound_bool (k - m) _ k_ne_0)
  end.

Lemma Zk_eq n m p q : n = m -> Zk n p = Zk m q.
Proof.
  intros H. revert p q. rewrite H. clear H. intros. apply f_equal. apply UIP_dec. apply bool_dec.
Qed.

Proposition n_apply : forall (x : nat), n (nat_Z_k x) = x mod k.
Proof.
  intro. simpl. reflexivity.
Qed.

Proposition n_apply' : forall (x : nat) (prf: (x <? k) = true), n (Zk x prf) = x.
Proof.
  intros. simpl. reflexivity.
Qed.

Proposition Z_op_sum : forall (x y: nat), Zk_op x y = x + y.
Proof.
  intros. unfold Zk_op. apply Zk_eq. repeat rewrite (n_apply _). rewrite (Nat.add_mod x y k k_ne_0). reflexivity.
Qed.

Proposition Z_op_sum' : forall (x y: Z_k), Zk_op x y = (n x) + (n y).
Proof.
  intros. unfold Zk_op. apply Zk_eq. repeat rewrite (n_apply _). rewrite (Nat.add_mod x y k k_ne_0). reflexivity.
Qed.

Lemma Z_k_inv_0 : Z_k_inv zk_0 = zk_0.
Proof.
  unfold Z_k_inv. unfold zk_0. rewrite Nat.sub_0_r. apply Zk_eq. apply (Nat.mod_same k k_ne_0).
Qed.

Proposition Zk_left_id : forall x: Z_k, (Zk_op zk_0 x) = x.
Proof.
  intro. unfold Zk_op. destruct x as [vx proof]. apply Zk_eq. unfold n, zk_0. rewrite plus_O_n. apply Nat.mod_small. apply Nat.ltb_lt in proof. assumption.
Qed.

Proposition Zk_left_inv : forall x: Z_k, Zk_op (Z_k_inv x) x = zk_0.
Proof.
  intro. unfold Zk_op. unfold Z_k_inv. apply Zk_eq. destruct x as [vx proof]. repeat rewrite n_apply'. rewrite (Nat.add_mod_idemp_l _ _ _ k_ne_0). rewrite Nat.sub_add.
  - apply (Nat.mod_same k k_ne_0).
  - apply Nat.ltb_lt in proof. apply Nat.lt_le_incl. apply proof.
Qed.

Proposition Zk_assoc : forall x y z: Z_k, Zk_op x (Zk_op y z) = Zk_op (Zk_op x y) z.
Proof.
  intros. repeat rewrite (Z_op_sum' _ _). repeat rewrite n_apply.
  unfold nat_Z_k. apply Zk_eq. rewrite (Nat.add_mod_idemp_l _ _ _ k_ne_0). rewrite (Nat.add_mod_idemp_r _ _ _ k_ne_0). rewrite Nat.add_assoc. reflexivity.
Qed.

Instance semigroupZk : Semigroup Z_k :=
{
  mult := Zk_op;
  assoc := Zk_assoc
}.

Instance monoidZk : Monoid Z_k :=
{
  e := zk_0;
  left_id := Zk_left_id;
}.

Instance groupZk : Group Z_k :=
{
  inv := Z_k_inv;
  left_inv := Zk_left_inv;
}.

Print Instances Semigroup.
End GroupZ_n.


Require Import Coq.Strings.String.
Require Import Coq.Init.Datatypes.
Require Import Coq.Lists.List.

Module TLC.

Inductive Ty: Type :=
  | T_Bool: Ty
  | T_Func: Ty -> Ty -> Ty.

Inductive Tm: Type :=
  | Tm_var: string -> Tm
  | Tm_abs: string -> Ty -> Tm -> Tm
  | Tm_app: Tm -> Tm -> Tm
  | Tm_true: Tm
  | Tm_false: Tm.

Declare Custom Entry tlc.
Notation "“ e ”" := e (e custom tlc at level 99).
Notation "( x )" := x (in custom tlc, x at level 99).
Notation "x" := x (in custom tlc at level 0, x constr at level 0).
Notation "S -> T" := (T_Func S T) (in custom tlc at level 50, right associativity).
Notation "x y" := (Tm_app x y) (in custom tlc at level 1, left associativity).
Notation "\ x : t => y" :=
  (Tm_abs x t y) (in custom tlc at level 90, x at level 99,
                     t custom tlc at level 99,
                     y custom tlc at level 99,
                     left associativity).
Coercion Tm_var : string >-> Tm.
Notation "'Bool'" := T_Bool (in custom tlc at level 0).
Notation "'true'" := true (at level 1).
Notation "'true'" := Tm_true (in custom tlc at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := Tm_false (in custom tlc at level 0).

Inductive value: Tm -> Prop :=
  | value_abs: forall x T t,
    value “ \x: T => t ”
  | value_true: value Tm_true
  | value_false: value Tm_false.

Inductive closed: Tm -> Prop :=
  | Cl_abs: forall x T t,
    closed “ \x: T => t ”
  | Cl_app: forall t1 t2,
    closed t1 /\ closed t2 ->
    closed “t1 t2”
  | Cl_true: closed Tm_true
  | Cl_false: closed Tm_false.

Reserved Notation "i '[' x ':=' s ']' =a u" (in custom tlc at level 20, x constr).

Inductive substitution (x: string) (s: Tm): Tm -> Tm -> Prop :=
  | Subst_var1: forall t,
      t = (Tm_var x) ->
      “t [x := s] =a t”

  | Subst_var2: forall t y,
      t = (Tm_var y) /\ ~(x = y) ->
      “t [x := s] =a t”

  | Subst_fun1: forall m T,
      “(\x:T => m) [x := s] =a (\x:T => m)”
  | Subst_fun2: forall y m m' T,
      “m [x := s] =a m'” ->
      “(\y:T => m) [x := s] =a (\x:T => m')”

  | Subst_app: forall m m' n n',
      “m [x := s] =a m'” /\
      “n [x := s] =a n'” ->
      “(m n) [x := s] =a (m' n')”
  | Subst_true:
      “true [x := s] =a true”
  | Subst_false:
      “false [x := s] =a false”
  where "i '[' x ':=' s ']' =a u" := (substitution x s i u) (in custom tlc).

Reserved Notation "t1 '-->' t1'" (at level 40).

Inductive step: Tm -> Tm -> Prop :=
  | E_App1: forall t1 t1' t2,
      t1 --> t1' ->
      “t1 t2” --> “t1' t2”
  | E_App2: forall t2 t2' v,
      value v ->
      t2 --> t2' ->
      “v t2” --> “v t2'”
  | E_AppAbs: forall x T t v t',
      value v ->
      “t [x:=v] =a t'” ->
      “(\x:T => t) v” --> t'
  where "t1 '-->' t1'" := (step t1 t1').

Definition Context := list (string * Ty).

Notation "t ';' L" := (cons t L) (at level 40).
Reserved Notation "G '|-' t \in T" (at level 30).

Inductive has_type: Context -> Tm -> Ty -> Prop :=
  | T_Var: forall G x T,
      In (x, T) G ->
      (G |- x \in T)
  | T_Abs: forall G x T1 t2 T2,
      ((x, T1); G) |- t2 \in T2 ->
      G |- “\x:T1 => t2” \in (T_Func T1 T2)
  | T_App: forall G t1 t2 T11 T12,
      G |- t1 \in (T_Func T11 T12) /\
      G |- t2 \in T11 ->
      G |- “t1 t2” \in T12
  where "G '|-' t \in T" := (has_type G t T).

Notation "'|-' t \in T" := (has_type nil t T) (at level 30).

(* Inversion of the typing relation *)
Lemma inversion1: forall G t R x,
  t = (Tm_var x) -> G |- x \in R -> In (x, R) G.
Proof.
  intros.
  inversion H0; subst.
  apply H3.
Qed.

Lemma inversion2: forall G x T1 t2 R,
  G |- “\x:T1 => t2” \in R ->
  exists R2, (((x, T1); G) |- t2 \in R2 /\ R = T_Func T1 R2).
Proof.
  intros.
  inversion H; subst.
  exists T2.
  split.
  apply H5.
  reflexivity.
Qed.

Lemma inversion3: forall G t1 t2 R,
  G |- “t1 t2” \in R ->
  exists T11, (G |- t1 \in “T11 -> R” /\ G |- t2 \in T11).
Proof.
  intros.
  inversion H; subst.
  exists T11.
  apply H4.
Qed.

Lemma inversion4: forall G R,
  G |- Tm_true \in R -> R = T_Bool.
Proof.
  intros.
  inversion H.
Qed.

Lemma inversion5: forall G R,
  G |- Tm_false \in R -> R = T_Bool.
Proof.
  intros.
  inversion H.
Qed.

(* canonical *)
Theorem bool_canonical: forall G v,
  value v ->
  G |- v \in T_Bool ->
  v = Tm_true \/ v = Tm_false.
Proof.
  intros.
  destruct H; subst; auto.
  inversion H0.
Qed.

Theorem fun_canonical: forall G v T1 T2,
  value v ->
  G |- v \in “T1 -> T2” ->
  exists x t2, v = “\x:T1 => t2”.
Proof.
  intros.
  destruct H; inversion H0; subst; auto.
  - exists x, t.
    inversion H0; subst.
    reflexivity.
Qed.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Definition.Include.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.Singleton.
Require Import BBST.Definition.BinaryUnion.
Require Import BBST.Definition.OneTwo.

Definition 后继 := λ a, a ∪ {a,}.
Notation "a ⁺" := (后继 a) (at level 6, format "a ⁺") : 集合域.

Lemma 左后继介入 : ∀ a, ∀x ∈ a, x ∈ a⁺.
Proof. intros. now apply 左并介入. Qed.

Lemma 右后继介入 : ∀ a, a ∈ a⁺.
Proof. intros. apply 右并介入. auto. Qed.

Global Hint Immediate 左后继介入 右后继介入 : core.

Lemma 后继除去 : ∀ a, ∀x ∈ a⁺, x ∈ a ∨ x = a.
Proof.
  intros a x Hx. apply 二元并除去 in Hx as []. auto.
  apply 单集除去 in H. auto.
Qed.

Lemma 含于后继 : ∀ a, a ⊆ a⁺.
Proof. firstorder. Qed.
Global Hint Immediate 含于后继 : core.

Lemma 后继非空 : ∀ a, a⁺ ≠ ∅.
Proof.
  intros a H. eapply 空集除去 in H. apply H. eauto.
Qed.
Global Hint Immediate 后继非空 : core.

Fact 零的后继为壹 : ∅⁺ = 壹.
Proof.
  外延.
  - apply 后继除去 in H as []. 空集归谬.
    subst. apply 壹介入.
  - apply 壹除去 in H. subst. auto.
Qed.

Fact 壹的后继为贰 : 壹⁺ = 贰.
Proof.
  外延.
  - apply 后继除去 in H as [].
    + apply 壹除去 in H. subst. apply 贰介入0.
    + subst. apply 贰介入1.
  - apply 贰除去 in H as []; subst.
    + apply 含于后继. apply 壹介入.
    + auto.
Qed.


Fixpoint pow a b :=
  match b with
  | O => 1
  | S n => a * pow a n
  end.

Notation "a ^ b" := (pow a b).

Theorem testing_pow : forall (x y : nat), x ^ 2 = x * x.
Proof.
  intros. simpl. induction x.
  + simpl. reflexivity.
  + simpl in *.


Require Import List.

Require Import Logic.List.In.
Require Import Logic.List.Equiv.

Lemma app_charac : forall (v:Type) (xs ys:list v) (z:v),
    z :: (xs ++ ys) <-> z :: xs \/ z :: ys.
Proof.
    intros v xs ys z. split.
    - apply in_app_or.
    - apply in_or_app.
Qed.

Lemma app_compat_l : forall (v:Type) (xs xs' ys:list v),
    xs == xs' -> xs ++ ys == xs' ++ ys.
Proof.
    intros v xs xs' ys [H1 H2]. split; intros z H3;
    apply app_charac in H3; destruct H3 as [H3|H3];
    apply app_charac.
    - left. apply H1. assumption.
    - right. assumption.
    - left. apply H2. assumption.
    - right. assumption.
Qed.

Lemma app_compat_r : forall (v:Type) (xs ys ys':list v),
    ys == ys' -> xs ++ ys == xs ++ ys'.
Proof.
    intros v xs ys ys' [H1 H2]. split; intros z H3;
    apply app_charac in H3; destruct H3 as [H3|H3];
    apply app_charac.
    - left. assumption.
    - right. apply H1. assumption.
    - left. assumption.
    - right. apply H2. assumption.
Qed.

Lemma app_compat_lr : forall (v:Type) (xs xs' ys ys':list v),
    xs == xs' -> ys == ys' -> xs ++ ys == xs' ++ ys'.
Proof.
    intros v xs xs' ys ys' H1 H2. apply equivTrans with (xs' ++ ys).
    - apply app_compat_l. assumption.
    - apply app_compat_r. assumption.
Qed.

(* not very useful                                                              *)
Lemma app_assoc' : forall (v:Type) (xs ys zs:list v),
    (xs ++ ys) ++ zs == xs ++ (ys ++ zs).
Proof.
    intros v xs ys zs. rewrite app_assoc. apply equivRefl.
Qed.

Lemma app_comm : forall (v:Type) (xs ys:list v),
    xs ++ ys == ys ++ xs.
Proof.
    intros v xs ys. split; intros z; intros H1;
    apply in_app_or in H1; destruct H1 as [H1|H1]; apply in_or_app.
    - right. assumption.
    - left. assumption.
    - right. assumption.
    - left. assumption.
Qed.

Lemma app_nil : forall (v:Type) (xs ys:list v),
    xs ++ ys = nil -> xs = nil /\ ys = nil.
Proof.
    intros v xs ys. destruct xs as [|x xs]; destruct ys as [|y ys];
    simpl; intros H.
    - split; reflexivity.
    - inversion H.
    - inversion H.
    - inversion H.
Qed.


Require Export Common.
Require Export Relations.Relation_Definitions.
Require Export Structures.Equalities.
Require Export Program.Basics.
Require Import Unicode.Utf8.

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

Section order_rel_defs.
  Variable X : Type.
  Variable R : relation X.

  Definition GreatestElem x := forall y, R y x.

  Definition LeastElem x := forall y, R x y.

  Definition BinBound x y z := R y x /\ R z x.

  Definition BinBestBound x y z :=
    BinBound x y z /\ forall w, BinBound w y z -> R x w.

  Definition OpIsBB op :=
    forall x y, BinBestBound (op x y) x y.

  Definition UniqueBestBound x y op :=
    unique (fun d => BinBestBound d x y) (op x y).
End order_rel_defs.

Module Type IsPOSet (Import X : UsualDecidableType).
  Parameter Leq   : relation t.
  Notation "x '⊑' y" := (Leq x y) (at level 60).

  Axiom LeqRefl    : reflexive _ Leq.
  Axiom LeqTrans   : transitive _ Leq.
  Axiom LeqAntisym : antisymmetric _ Leq.
  (*Definition isPO : order _ Leq.
  Proof. split; [refine LeqRefl | refine LeqTrans | refine LeqAntisym]. Defined.*)

  Parameter leq   : t -> t -> bool.
  Axiom leqProper : BinRelOp Leq leq.

  Hint Resolve LeqRefl.
End IsPOSet.

Module Type POSet := UsualDecidableType <+ IsPOSet.

Module Type IsJoinSemiLattice (Import X : POSet).
  Parameter join      : t -> t -> t.
  Notation "x '⊔' y"  := (join x y) (at level 50).
  Axiom JoinUnique    : forall x y, UniqueBestBound Leq x y join.

  Parameter bot     : t.
  Axiom BotIsLeast  : LeastElem Leq bot.
  Notation "⊥"      := bot.
  Hint Resolve BotIsLeast.
End IsJoinSemiLattice.

Module Type JoinSemiLattice := POSet <+ IsJoinSemiLattice.

Module Type IsMeetSemiLattice (Import X : POSet).
  Parameter meet     : t -> t -> t.
  Notation "x '⊓' y" := (meet x y) (at level 50).
  Axiom MeetUnique   : forall x y, UniqueBestBound (flip Leq) x y meet.

  Parameter top       : t.
  Axiom TopIsGreatest : GreatestElem Leq top.
  Notation "⊤"        := top.
  Hint Resolve TopIsGreatest.
End IsMeetSemiLattice.

Module Type MeetSemiLattice := POSet <+ IsMeetSemiLattice.
Module Type Lattice := POSet <+ IsJoinSemiLattice <+ IsMeetSemiLattice.

Module Type HasWidening (Import X : POSet).
  Parameter widen : t -> t -> t.
  Notation "x '∇' y" := (widen x y) (at level 50).

  Axiom WidenProper : forall x y, x ⊑ (x ∇ y) ∧ y ⊑ (x ∇ y).
End HasWidening.

Module Type HasNarrowing (Import X : POSet).
  Parameter narrow : t -> t -> t.
  Notation "x 'Δ' y" := (narrow x y) (at level 50).

  Axiom NarrowProper : forall x y, y ⊑ x -> y ⊑ (x Δ y) ∧ (x Δ y) ⊑ x.
End HasNarrowing.

Module Type WLattice  := Lattice <+ HasWidening.
Module Type NLattice  := Lattice <+ HasWidening <+ HasNarrowing.
Module Type WNLattice := Lattice <+ HasWidening <+ HasNarrowing.

Module Dual (Import D : Lattice) <: Lattice.
  Module DecImpl.
    Definition t := t.
    Definition eq_dec : forall x y, {eq x y} + {~ eq x y} := D.eq_dec.
  End DecImpl.

  Include Make_UDT (DecImpl).

  Definition Leq : relation t
    := fun x y => D.Leq y x.

  Definition leq : t -> t -> bool
    := fun x y => D.leq y x.

  Definition join : t -> t -> t
    := D.meet.

  Definition meet : t -> t -> t
    := D.join.

  Definition top : t := D.bot.
  Definition bot : t := D.top.

  Lemma LeqRefl : reflexive _ Leq.
  Proof. now apply D.LeqRefl. Qed.

  Lemma LeqTrans : transitive _ Leq.
  Proof. assert (H:=D.LeqTrans); now firstorder. Qed.

  Lemma LeqAntisym : antisymmetric _ Leq.
  Proof. assert (H:=D.LeqAntisym); now firstorder. Qed.

  Lemma leqProper : BinRelOp Leq leq.
  Proof. assert (H:=D.leqProper); now firstorder. Qed.

  Lemma JoinUnique : forall x y, UniqueBestBound Leq x y join.
  Proof. now refine D.MeetUnique. Qed.

  Lemma MeetUnique : forall x y, UniqueBestBound (flip Leq) x y meet.
  Proof. now refine D.JoinUnique. Qed.

  Lemma TopIsGreatest : GreatestElem Leq top.
  Proof. now refine D.BotIsLeast. Qed.

  Lemma BotIsLeast : LeastElem Leq bot.
  Proof. now refine D.TopIsGreatest. Qed.

  (*Definition isPO : order _ Leq.
  Proof. split; [ refine LeqRefl | refine LeqTrans | refine LeqAntisym ]. Defined.*)
End Dual.

Module test (L:Lattice).
  Module MSL : MeetSemiLattice := L.
  Module JSL : JoinSemiLattice := L.
End test.

Module UtilPOSet (Import D : POSet).

  Lemma leqRefl x : D.leq x x = true.
  Proof. now apply D.leqProper. Qed.

  (*Lemma if_leq_False x y:
    (if D.leq x y then False else True) -> ~ D.Leq x y.
  Proof.
    intros H e.
    now rewrite (proj1 (D.leqProper _ _) e) in H.
  Qed.*)
End UtilPOSet.

Module UtilJoin (Import D : JoinSemiLattice).

  Lemma FlipJoinIsJoin : OpIsBB D.Leq (flip D.join).
  Proof.
    intros y x.
    unfold flip.
    destruct (D.JoinUnique x y) as [H _].
    now firstorder.
  Qed.

  Lemma joinSym x y : D.join x y = D.join y x.
  Proof.
    apply D.JoinUnique.
    now apply FlipJoinIsJoin.
  Qed.

  Lemma joinSubsume1 x y : D.Leq x y <-> D.join x y = y.
  Proof.
    split.
    - intros H.
      apply D.JoinUnique.
      now firstorder.
    - intros H.
      rewrite <- H.
      now apply (D.JoinUnique x y).
  Qed.

  Lemma joinSubsume2 x y : D.Leq y x <-> D.join x y = x.
  Proof. rewrite joinSym; now apply joinSubsume1. Qed.

  Lemma LeqJoin1 x y : D.Leq x (D.join x y).
  Proof. now apply D.JoinUnique. Qed.
  Hint Resolve LeqJoin1.

  Lemma LeqJoin2 x y : D.Leq x (D.join y x).
  Proof. now apply D.JoinUnique. Qed.
  Hint Resolve LeqJoin2.

  Lemma LeqLeqJoin1 x y z : D.Leq x y -> D.Leq x (D.join y z).
  Proof.
    intros xLEy.
    destruct (D.JoinUnique y z) as [H _].
    now apply (D.LeqTrans (y:=y)).
  Qed.
  Hint Resolve LeqLeqJoin1.

  Lemma LeqLeqJoin2 x y z : D.Leq x y -> D.Leq x (D.join z y).
  Proof.
    intros xLEy.
    destruct (D.JoinUnique y z) as [H _].
    now apply (D.LeqTrans (y:=y)).
  Qed.
  Hint Resolve LeqLeqJoin2.

  Lemma LeqBotElim a : D.Leq a D.bot -> a = D.bot.
  Proof.
    intros H.
    now apply D.LeqAntisym.
  Qed.

End UtilJoin.

Module UtilMeet (Import D : MeetSemiLattice).

  Lemma meetSubsumed x y : D.Leq y x <-> D.meet x y = y.
  Proof.
    split.
    - intros H.
      apply D.MeetUnique.
      unfold flip.
      now firstorder.
    - intros H.
      rewrite <- H.
      now apply (D.MeetUnique x y).
  Qed.

  Lemma FlipMeetIsMeet : OpIsBB (flip D.Leq) (flip D.meet).
  Proof.
    intros y x.
    unfold flip.
    destruct (D.MeetUnique x y) as [H _].
    now firstorder.
  Qed.

  Lemma meetSym x y : D.meet x y = D.meet y x.
  Proof.
    apply D.MeetUnique.
    now apply FlipMeetIsMeet.
  Qed.

  Lemma meetSubsumedR x y : D.Leq x y <-> D.meet x y = x.
  Proof.
    rewrite meetSym.
    now apply meetSubsumed.
  Qed.

  Lemma leq_meetxy_z x y z : D.Leq x z -> D.Leq (D.meet x y) z.
  Proof.
    intros xLEz.
    destruct (D.MeetUnique x y) as [H _].
    apply D.LeqTrans with (y:=x); now firstorder.
  Qed.

End UtilMeet.

Module Util (Import D : Lattice).

  Include UtilPOSet (D).
  Include UtilJoin (D).
  Include UtilMeet (D).

  Lemma MeetBotL b : D.meet D.bot b = D.bot.
  Proof.
    rewrite meetSym.
    now apply meetSubsumed.
  Qed.
  Hint Rewrite MeetBotL.

  Lemma MeetBotR b : D.meet b D.bot = D.bot.
  Proof.
    apply meetSubsumed.
    apply D.BotIsLeast.
  Qed.
  Hint Rewrite MeetBotR.

End Util.

Module UtilWiden (Import D : WLattice).
  Module U := Util (D).

  Lemma BotWidenElimR a b : D.bot = widen a b -> b = D.bot.
  Proof.
    intros H.
    destruct (WidenProper a b) as [_ H1].
    rewrite <- H in H1.
    now apply U.LeqBotElim.
  Qed.

  Lemma BotWidenElimL a b : D.bot = widen a b -> a = D.bot.
  Proof.
    intros H.
    destruct (WidenProper a b) as [H1 _].
    rewrite <- H in H1.
    now apply U.LeqBotElim.
  Qed.

End UtilWiden.

Module UtilNarrow (Import D : NLattice).
  Module U := Util (D).

  Lemma BotNarrowElim : narrow D.bot D.bot = D.bot.
  Proof.
    destruct (NarrowProper (x:=D.bot) (y:=D.bot)) as [A B]; auto.
    now apply D.LeqAntisym.
  Qed.
End UtilNarrow.

Module OptionLattice (B : Lattice) <: Lattice.
  Module DecImpl.
    Definition t : Type := option B.t.

    Definition eq_dec : forall x y:t, {x=y} + {x<>y}.
    Proof.
      assert (E:=B.eq_dec).
      decide equality.
    Defined.
  End DecImpl.

  Include Make_UDT (DecImpl).

  Definition Leq : relation t :=
    fun x y =>
      match x, y with
        | Some x, Some y => B.Leq x y
        | None, _ => True
        | _, None => False
      end.

  Function leq x y : bool :=
    match x, y with
      | Some x, Some y => B.leq x y
      | None, _ => true
      | _, None => false
    end.

  Function join x y :=
    match x, y with
      | Some x, Some y => Some (B.join x y)
      | None, _ => y
      | _, None => x
    end.

  Function meet x y :=
    match x, y with
      | Some x, Some y => Some (B.meet x y)
      | _, _ => None
    end.

  Definition top : t := Some B.top.
  Definition bot : t := None.

  (*Lemma OrderInequal (X:Type) (leq:BinRel X) (asym:Antisym leq) :
      forall x y z, x<>y /\ leq x y /\ leq y z -> x<>z.
  Proof.
    intros x y z [XnY [XlY YlZ]] EQ.
    destruct EQ.
    now apply XnY, asym.
  Qed.*)

  Lemma LeqRefl : reflexive _ Leq.
  Proof. intros x. unfold Leq. now destruct x. Qed.

  Lemma LeqTrans : transitive _ Leq.
  Proof.
    assert (H:=B.LeqTrans).
    intros x y z.
    destruct x, y, z; now firstorder.
  Qed.

  Lemma LeqAntisym : antisymmetric _ Leq.
  Proof.
    assert (H:=B.LeqAntisym).
    intros x y A B.
    destruct x, y; try f_equal; now firstorder.
  Qed.

  (*Definition isPO : order _ Leq.
  Proof. split; [refine LeqRefl | refine LeqTrans | refine LeqAntisym]. Defined.*)

  Lemma leqProper : BinRelOp Leq leq.
  Proof.
    assert (H:=B.leqProper).
    intros x y; destruct x, y; unfold leq; now firstorder.
  Qed.

  Lemma JoinUnique : forall x y, UniqueBestBound Leq x y join.
  Proof.
    assert (H:=B.JoinUnique).
    intros x y. split.
    - destruct x,y; unfold Leq, join;
      firstorder; now destruct w; firstorder.
    - intros z A. destruct x,y,z; firstorder.
      + unfold join; f_equal. unfold Leq in H0, H2.
        destruct (H t0 t1) as [D E]. apply E. split; [firstorder|].
        intros w. apply (H1 (Some w)); firstorder.
      + unfold join. f_equal. apply B.LeqAntisym; auto.
        apply (H1 (Some t0)). now split; try apply LeqRefl.
      + unfold join. f_equal. apply B.LeqAntisym; auto.
        apply (H1 (Some t0)). now split; try apply LeqRefl.
      + exfalso. apply (H1 None). firstorder.
  Qed.

  Lemma MeetUnique : forall x y, UniqueBestBound (flip Leq) x y meet.
  Proof.
    assert (H:=B.MeetUnique).
    intros x y. split.
    - destruct x,y; cbv; firstorder.
      now destruct w; firstorder.
    - intros z A. destruct x,y,z; firstorder.
      + cbv. f_equal. apply (H t0 t1). firstorder.
        apply (H1 (Some w)). firstorder.
      + exfalso. apply (H1 (Some (B.bot))). unfold flip.
        assert (B:=B.BotIsLeast). firstorder.
  Qed.

  Lemma TopIsGreatest : GreatestElem Leq top.
  Proof.
    assert (H:=B.TopIsGreatest).
    intros x. destruct x; now firstorder.
  Qed.

  Lemma BotIsLeast : LeastElem Leq bot.
  Proof.
    assert (H:=B.BotIsLeast).
    intros x. destruct x; now firstorder.
  Qed.

End OptionLattice.


From Hammer Require Import Hammer.

Require Import NZAxioms NZMulOrder NZPow.

Module Type Log2 (Import A : Typ).
Parameter Inline log2 : t -> t.
End Log2.

Module Type NZLog2Spec (A : NZOrdAxiomsSig')(B : Pow' A)(C : Log2 A).
Import A B C.
Axiom log2_spec : forall a, 0<a -> 2^(log2 a) <= a < 2^(S (log2 a)).
Axiom log2_nonpos : forall a, a<=0 -> log2 a == 0.
End NZLog2Spec.

Module Type NZLog2 (A : NZOrdAxiomsSig)(B : Pow A) := Log2 A <+ NZLog2Spec A B.

Module Type NZLog2Prop
(Import A : NZOrdAxiomsSig')
(Import B : NZPow' A)
(Import C : NZLog2 A B)
(Import D : NZMulOrderProp A)
(Import E : NZPowProp A B D).

Lemma log2_nonneg : forall a, 0 <= log2 a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_nonneg".
intros a. destruct (le_gt_cases a 0) as [Ha|Ha].
now rewrite log2_nonpos.
destruct (log2_spec a Ha) as (_,LT).
apply lt_succ_r, (pow_gt_1 2). order'.
rewrite <- le_succ_l, <- one_succ in Ha. order.
Qed.

Ltac order_pos :=
((apply add_pos_pos || apply add_nonneg_nonneg ||
apply mul_pos_pos || apply mul_nonneg_nonneg ||
apply pow_nonneg || apply pow_pos_nonneg ||
apply log2_nonneg || apply (le_le_succ_r 0));
order_pos)
|| order'.

Lemma log2_unique : forall a b, 0<=b -> 2^b<=a<2^(S b) -> log2 a == b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_unique".
intros a b Hb (LEb,LTb).
assert (Ha : 0 < a).
apply lt_le_trans with (2^b); trivial.
apply pow_pos_nonneg; order'.
assert (Hc := log2_nonneg a).
destruct (log2_spec a Ha) as (LEc,LTc).
assert (log2 a <= b).
apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'.
now apply le_le_succ_r.
assert (b <= log2 a).
apply lt_succ_r, (pow_lt_mono_r_iff 2); try order'.
now apply le_le_succ_r.
order.
Qed.

Instance log2_wd : Proper (eq==>eq) log2.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_wd".
intros x x' Hx.
destruct (le_gt_cases x 0).
rewrite 2 log2_nonpos; trivial. reflexivity. now rewrite <- Hx.
apply log2_unique. apply log2_nonneg.
rewrite Hx in *. now apply log2_spec.
Qed.

Lemma log2_spec_alt : forall a, 0<a -> exists r,
a == 2^(log2 a) + r /\ 0 <= r < 2^(log2 a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_spec_alt".
intros a Ha.
destruct (log2_spec _ Ha) as (LE,LT).
destruct (le_exists_sub _ _ LE) as (r & Hr & Hr').
exists r.
split. now rewrite add_comm.
split. trivial.
apply (add_lt_mono_r _ _ (2^log2 a)).
rewrite <- Hr. generalize LT.
rewrite pow_succ_r by order_pos.
rewrite two_succ at 1. now nzsimpl.
Qed.

Lemma log2_unique' : forall a b c, 0<=b -> 0<=c<2^b ->
a == 2^b + c -> log2 a == b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_unique'".
intros a b c Hb (Hc,H) EQ.
apply log2_unique. trivial.
rewrite EQ.
split.
rewrite <- add_0_r at 1. now apply add_le_mono_l.
rewrite pow_succ_r by order.
rewrite two_succ at 2. nzsimpl. now apply add_lt_mono_l.
Qed.

Lemma log2_pow2 : forall a, 0<=a -> log2 (2^a) == a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_pow2".
intros a Ha.
apply log2_unique' with 0; trivial.
split; order_pos. now nzsimpl.
Qed.

Lemma log2_pred_pow2 : forall a, 0<a -> log2 (P (2^a)) == P a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_pred_pow2".
intros a Ha.
assert (Ha' : S (P a) == a) by (now rewrite lt_succ_pred with 0).
apply log2_unique.
apply lt_succ_r; order.
rewrite <-le_succ_l, <-lt_succ_r, Ha'.
rewrite lt_succ_pred with 0.
split; try easy. apply pow_lt_mono_r_iff; try order'.
rewrite succ_lt_mono, Ha'. apply lt_succ_diag_r.
apply pow_pos_nonneg; order'.
Qed.

Lemma log2_1 : log2 1 == 0.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_1".
rewrite <- (pow_0_r 2). now apply log2_pow2.
Qed.

Lemma log2_2 : log2 2 == 1.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_2".
rewrite <- (pow_1_r 2). apply log2_pow2; order'.
Qed.

Lemma log2_pos : forall a, 1<a -> 0 < log2 a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_pos".
intros a Ha.
assert (Ha' : 0 < a) by order'.
assert (H := log2_nonneg a). le_elim H; trivial.
generalize (log2_spec a Ha'). rewrite <- H in *. nzsimpl; try order.
intros (_,H'). rewrite two_succ in H'. apply lt_succ_r in H'; order.
Qed.

Lemma log2_null : forall a, log2 a == 0 <-> a <= 1.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_null".
intros a. split; intros H.
destruct (le_gt_cases a 1) as [Ha|Ha]; trivial.
generalize (log2_pos a Ha); order.
le_elim H.
apply log2_nonpos. apply lt_succ_r. now rewrite <- one_succ.
rewrite H. apply log2_1.
Qed.

Lemma log2_le_mono : forall a b, a<=b -> log2 a <= log2 b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_le_mono".
intros a b H.
destruct (le_gt_cases a 0) as [Ha|Ha].
rewrite log2_nonpos; order_pos.
assert (Hb : 0 < b) by order.
destruct (log2_spec a Ha) as (LEa,_).
destruct (log2_spec b Hb) as (_,LTb).
apply lt_succ_r, (pow_lt_mono_r_iff 2); order_pos.
Qed.

Lemma log2_lt_cancel : forall a b, log2 a < log2 b -> a < b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_lt_cancel".
intros a b H.
destruct (le_gt_cases b 0) as [Hb|Hb].
rewrite (log2_nonpos b) in H; trivial.
generalize (log2_nonneg a); order.
destruct (le_gt_cases a 0) as [Ha|Ha]. order.
destruct (log2_spec a Ha) as (_,LTa).
destruct (log2_spec b Hb) as (LEb,_).
apply le_succ_l in H.
apply (pow_le_mono_r_iff 2) in H; order_pos.
Qed.

Lemma log2_le_pow2 : forall a b, 0<a -> (2^b<=a <-> b <= log2 a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_le_pow2".
intros a b Ha.
split; intros H.
destruct (lt_ge_cases b 0) as [Hb|Hb].
generalize (log2_nonneg a); order.
rewrite <- (log2_pow2 b); trivial. now apply log2_le_mono.
transitivity (2^(log2 a)).
apply pow_le_mono_r; order'.
now destruct (log2_spec a Ha).
Qed.

Lemma log2_lt_pow2 : forall a b, 0<a -> (a<2^b <-> log2 a < b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_lt_pow2".
intros a b Ha.
split; intros H.
destruct (lt_ge_cases b 0) as [Hb|Hb].
rewrite pow_neg_r in H; order.
apply (pow_lt_mono_r_iff 2); try order_pos.
apply le_lt_trans with a; trivial.
now destruct (log2_spec a Ha).
destruct (lt_ge_cases b 0) as [Hb|Hb].
generalize (log2_nonneg a); order.
apply log2_lt_cancel; try order.
now rewrite log2_pow2.
Qed.

Lemma log2_lt_lin : forall a, 0<a -> log2 a < a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_lt_lin".
intros a Ha.
apply (pow_lt_mono_r_iff 2); try order_pos.
apply le_lt_trans with a.
now destruct (log2_spec a Ha).
apply pow_gt_lin_r; order'.
Qed.

Lemma log2_le_lin : forall a, 0<=a -> log2 a <= a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_le_lin".
intros a Ha.
le_elim Ha.
now apply lt_le_incl, log2_lt_lin.
rewrite <- Ha, log2_nonpos; order.
Qed.

Lemma log2_mul_below : forall a b, 0<a -> 0<b ->
log2 a + log2 b <= log2 (a*b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_mul_below".
intros a b Ha Hb.
apply log2_le_pow2; try order_pos.
rewrite pow_add_r by order_pos.
apply mul_le_mono_nonneg; try apply log2_spec; order_pos.
Qed.

Lemma log2_mul_above : forall a b, 0<=a -> 0<=b ->
log2 (a*b) <= log2 a + log2 b + 1.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_mul_above".
intros a b Ha Hb.
le_elim Ha.
le_elim Hb.
apply lt_succ_r.
rewrite add_1_r, <- add_succ_r, <- add_succ_l.
apply log2_lt_pow2; try order_pos.
rewrite pow_add_r by order_pos.
apply mul_lt_mono_nonneg; try order; now apply log2_spec.
rewrite <- Hb. nzsimpl. rewrite log2_nonpos; order_pos.
rewrite <- Ha. nzsimpl. rewrite log2_nonpos; order_pos.
Qed.

Lemma log2_mul_pow2 : forall a b, 0<a -> 0<=b -> log2 (a*2^b) == b + log2 a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_mul_pow2".
intros a b Ha Hb.
apply log2_unique; try order_pos. split.
rewrite pow_add_r, mul_comm; try order_pos.
apply mul_le_mono_nonneg_r. order_pos. now apply log2_spec.
rewrite <-add_succ_r, pow_add_r, mul_comm; try order_pos.
apply mul_lt_mono_pos_l. order_pos. now apply log2_spec.
Qed.

Lemma log2_double : forall a, 0<a -> log2 (2*a) == S (log2 a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_double".
intros a Ha. generalize (log2_mul_pow2 a 1 Ha le_0_1). now nzsimpl'.
Qed.

Lemma log2_same : forall a b, 0<a -> 0<b -> log2 a == log2 b -> a < 2*b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_same".
intros a b Ha Hb H.
apply log2_lt_cancel. rewrite log2_double, H by trivial.
apply lt_succ_diag_r.
Qed.

Lemma log2_succ_le : forall a, log2 (S a) <= S (log2 a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_succ_le".
intros a.
destruct (lt_trichotomy 0 a) as [LT|[EQ|LT]].
apply (pow_le_mono_r_iff 2); try order_pos.
transitivity (S a).
apply log2_spec.
apply lt_succ_r; order.
now apply le_succ_l, log2_spec.
rewrite <- EQ, <- one_succ, log2_1; order_pos.
rewrite 2 log2_nonpos. order_pos. order'. now rewrite le_succ_l.
Qed.

Lemma log2_succ_or : forall a,
log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_succ_or".
intros.
destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H].
right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order.
left. apply le_succ_l in H. generalize (log2_succ_le a); order.
Qed.

Lemma log2_eq_succ_is_pow2 : forall a,
log2 (S a) == S (log2 a) -> exists b, S a == 2^b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_eq_succ_is_pow2".
intros a H.
destruct (le_gt_cases a 0) as [Ha|Ha].
rewrite 2 (proj2 (log2_null _)) in H. generalize (lt_succ_diag_r 0); order.
order'. apply le_succ_l. order'.
assert (Ha' : 0 < S a) by (apply lt_succ_r; order).
exists (log2 (S a)).
generalize (proj1 (log2_spec (S a) Ha')) (proj2 (log2_spec a Ha)).
rewrite <- le_succ_l, <- H. order.
Qed.

Lemma log2_eq_succ_iff_pow2 : forall a, 0<a ->
(log2 (S a) == S (log2 a) <-> exists b, S a == 2^b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_eq_succ_iff_pow2".
intros a Ha.
split. apply log2_eq_succ_is_pow2.
intros (b,Hb).
assert (Hb' : 0 < b).
apply (pow_gt_1 2); try order'; now rewrite <- Hb, one_succ, <- succ_lt_mono.
rewrite Hb, log2_pow2; try order'.
setoid_replace a with (P (2^b)). rewrite log2_pred_pow2; trivial.
symmetry; now apply lt_succ_pred with 0.
apply succ_inj. rewrite Hb. symmetry. apply lt_succ_pred with 0.
rewrite <- Hb, lt_succ_r; order.
Qed.

Lemma log2_succ_double : forall a, 0<a -> log2 (2*a+1) == S (log2 a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_succ_double".
intros a Ha.
rewrite add_1_r.
destruct (log2_succ_or (2*a)) as [H|H]; [exfalso|now rewrite H, log2_double].
apply log2_eq_succ_is_pow2 in H. destruct H as (b,H).
destruct (lt_trichotomy b 0) as [LT|[EQ|LT]].
rewrite pow_neg_r in H; trivial.
apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'.
rewrite <- one_succ in Ha. order'.
rewrite EQ, pow_0_r in H.
apply (mul_pos_pos 2), succ_lt_mono in Ha; try order'.
rewrite <- one_succ in Ha. order'.
assert (EQ:=lt_succ_pred 0 b LT).
rewrite <- EQ, pow_succ_r in H; [|now rewrite <- lt_succ_r, EQ].
destruct (lt_ge_cases a (2^(P b))) as [LT'|LE'].
generalize (mul_2_mono_l _ _ LT'). rewrite add_1_l. order.
rewrite (mul_le_mono_pos_l _ _ 2) in LE'; try order'.
rewrite <- H in LE'. apply le_succ_l in LE'. order.
Qed.

Lemma log2_add_le : forall a b, a~=1 -> b~=1 -> log2 (a+b) <= log2 a + log2 b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.log2_add_le".
intros a b Ha Hb.
destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|].
rewrite one_succ, lt_succ_r in Ha'.
rewrite (log2_nonpos a); trivial. nzsimpl. apply log2_le_mono.
rewrite <- (add_0_l b) at 2. now apply add_le_mono.
destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|].
rewrite one_succ, lt_succ_r in Hb'.
rewrite (log2_nonpos b); trivial. nzsimpl. apply log2_le_mono.
rewrite <- (add_0_r a) at 2. now apply add_le_mono.
clear Ha Hb.
apply lt_succ_r.
apply log2_lt_pow2; try order_pos.
rewrite pow_succ_r by order_pos.
rewrite two_succ, one_succ at 1. nzsimpl.
apply add_lt_mono.
apply lt_le_trans with (2^(S (log2 a))). apply log2_spec; order'.
apply pow_le_mono_r. order'. rewrite <- add_1_r. apply add_le_mono_l.
rewrite one_succ; now apply le_succ_l, log2_pos.
apply lt_le_trans with (2^(S (log2 b))). apply log2_spec; order'.
apply pow_le_mono_r. order'. rewrite <- add_1_l. apply add_le_mono_r.
rewrite one_succ; now apply le_succ_l, log2_pos.
Qed.

Lemma add_log2_lt : forall a b, 0<a -> 0<b ->
log2 a + log2 b < 2 * log2 (a+b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2Prop.add_log2_lt".
intros a b Ha Hb. nzsimpl'.
assert (H : log2 a <= log2 (a+b)).
apply log2_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order.
assert (H' : log2 b <= log2 (a+b)).
apply log2_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order.
le_elim H.
apply lt_le_trans with (log2 (a+b) + log2 b).
now apply add_lt_mono_r. now apply add_le_mono_l.
rewrite <- H at 1. apply add_lt_mono_l.
le_elim H'; trivial.
symmetry in H. apply log2_same in H; try order_pos.
symmetry in H'. apply log2_same in H'; try order_pos.
revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order.
Qed.

End NZLog2Prop.

Module NZLog2UpProp
(Import A : NZDecOrdAxiomsSig')
(Import B : NZPow' A)
(Import C : NZLog2 A B)
(Import D : NZMulOrderProp A)
(Import E : NZPowProp A B D)
(Import F : NZLog2Prop A B C D E).

Definition log2_up a :=
match compare 1 a with
| Lt => S (log2 (P a))
| _ => 0
end.

Lemma log2_up_eqn0 : forall a, a<=1 -> log2_up a == 0.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_eqn0".
intros a Ha. unfold log2_up. case compare_spec; try order.
Qed.

Lemma log2_up_eqn : forall a, 1<a -> log2_up a == S (log2 (P a)).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_eqn".
intros a Ha. unfold log2_up. case compare_spec; try order.
Qed.

Lemma log2_up_spec : forall a, 1<a ->
2^(P (log2_up a)) < a <= 2^(log2_up a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_spec".
intros a Ha.
rewrite log2_up_eqn; trivial.
rewrite pred_succ.
rewrite <- (lt_succ_pred 1 a Ha) at 2 3.
rewrite lt_succ_r, le_succ_l.
apply log2_spec.
apply succ_lt_mono. now rewrite (lt_succ_pred 1 a Ha), <- one_succ.
Qed.

Lemma log2_up_nonpos : forall a, a<=0 -> log2_up a == 0.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_nonpos".
intros. apply log2_up_eqn0. order'.
Qed.

Instance log2_up_wd : Proper (eq==>eq) log2_up.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_wd".
assert (Proper (eq==>eq==>Logic.eq) compare).
repeat red; intros; do 2 case compare_spec; trivial; order.
intros a a' Ha. unfold log2_up. rewrite Ha at 1.
case compare; now rewrite ?Ha.
Qed.

Lemma log2_up_nonneg : forall a, 0 <= log2_up a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_nonneg".
intros a. unfold log2_up. case compare_spec; try order.
intros. apply le_le_succ_r, log2_nonneg.
Qed.

Lemma log2_up_unique : forall a b, 0<b -> 2^(P b)<a<=2^b -> log2_up a == b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_unique".
intros a b Hb (LEb,LTb).
assert (Ha : 1 < a).
apply le_lt_trans with (2^(P b)); trivial.
rewrite one_succ. apply le_succ_l.
apply pow_pos_nonneg. order'. apply lt_succ_r.
now rewrite (lt_succ_pred 0 b Hb).
assert (Hc := log2_up_nonneg a).
destruct (log2_up_spec a Ha) as (LTc,LEc).
assert (b <= log2_up a).
apply lt_succ_r. rewrite <- (lt_succ_pred 0 b Hb).
rewrite <- succ_lt_mono.
apply (pow_lt_mono_r_iff 2); try order'.
assert (Hc' : 0 < log2_up a) by order.
assert (log2_up a <= b).
apply lt_succ_r. rewrite <- (lt_succ_pred 0 _ Hc').
rewrite <- succ_lt_mono.
apply (pow_lt_mono_r_iff 2); try order'.
order.
Qed.

Lemma log2_up_pow2 : forall a, 0<=a -> log2_up (2^a) == a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_pow2".
intros a Ha.
le_elim Ha.
apply log2_up_unique; trivial.
split; try order.
apply pow_lt_mono_r; try order'.
rewrite <- (lt_succ_pred 0 a Ha) at 2.
now apply lt_succ_r.
now rewrite <- Ha, pow_0_r, log2_up_eqn0.
Qed.

Lemma log2_up_succ_pow2 : forall a, 0<=a -> log2_up (S (2^a)) == S a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_succ_pow2".
intros a Ha.
rewrite log2_up_eqn, pred_succ, log2_pow2; try easy.
rewrite one_succ, <- succ_lt_mono. apply pow_pos_nonneg; order'.
Qed.

Lemma log2_up_1 : log2_up 1 == 0.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_1".
now apply log2_up_eqn0.
Qed.

Lemma log2_up_2 : log2_up 2 == 1.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_2".
rewrite <- (pow_1_r 2). apply log2_up_pow2; order'.
Qed.

Lemma le_log2_log2_up : forall a, log2 a <= log2_up a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.le_log2_log2_up".
intros a. unfold log2_up. case compare_spec; intros H.
rewrite <- H, log2_1. order.
rewrite <- (lt_succ_pred 1 a H) at 1. apply log2_succ_le.
rewrite log2_nonpos. order. now rewrite <-lt_succ_r, <-one_succ.
Qed.

Lemma le_log2_up_succ_log2 : forall a, log2_up a <= S (log2 a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.le_log2_up_succ_log2".
intros a. unfold log2_up. case compare_spec; intros H; try order_pos.
rewrite <- succ_le_mono. apply log2_le_mono.
rewrite <- (lt_succ_pred 1 a H) at 2. apply le_succ_diag_r.
Qed.

Lemma log2_log2_up_spec : forall a, 0<a ->
2^log2 a <= a <= 2^log2_up a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_log2_up_spec".
intros a H. split.
now apply log2_spec.
rewrite <-le_succ_l, <-one_succ in H. le_elim H.
now apply log2_up_spec.
now rewrite <-H, log2_up_1, pow_0_r.
Qed.

Lemma log2_log2_up_exact :
forall a, 0<a -> (log2 a == log2_up a <-> exists b, a == 2^b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_log2_up_exact".
intros a Ha.
split. intros. exists (log2 a).
generalize (log2_log2_up_spec a Ha). rewrite <-H.
destruct 1; order.
intros (b,Hb). rewrite Hb.
destruct (le_gt_cases 0 b).
now rewrite log2_pow2, log2_up_pow2.
rewrite pow_neg_r; trivial. now rewrite log2_nonpos, log2_up_nonpos.
Qed.

Lemma log2_up_pos : forall a, 1<a -> 0 < log2_up a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_pos".
intros. rewrite log2_up_eqn; trivial. apply lt_succ_r; order_pos.
Qed.

Lemma log2_up_null : forall a, log2_up a == 0 <-> a <= 1.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_null".
intros a. split; intros H.
destruct (le_gt_cases a 1) as [Ha|Ha]; trivial.
generalize (log2_up_pos a Ha); order.
now apply log2_up_eqn0.
Qed.

Lemma log2_up_le_mono : forall a b, a<=b -> log2_up a <= log2_up b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_le_mono".
intros a b H.
destruct (le_gt_cases a 1) as [Ha|Ha].
rewrite log2_up_eqn0; trivial. apply log2_up_nonneg.
rewrite 2 log2_up_eqn; try order.
rewrite <- succ_le_mono. apply log2_le_mono, succ_le_mono.
rewrite 2 lt_succ_pred with 1; order.
Qed.

Lemma log2_up_lt_cancel : forall a b, log2_up a < log2_up b -> a < b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_lt_cancel".
intros a b H.
destruct (le_gt_cases b 1) as [Hb|Hb].
rewrite (log2_up_eqn0 b) in H; trivial.
generalize (log2_up_nonneg a); order.
destruct (le_gt_cases a 1) as [Ha|Ha]. order.
rewrite 2 log2_up_eqn in H; try order.
rewrite <- succ_lt_mono in H. apply log2_lt_cancel, succ_lt_mono in H.
rewrite 2 lt_succ_pred with 1 in H; order.
Qed.

Lemma log2_up_lt_pow2 : forall a b, 0<a -> (2^b<a <-> b < log2_up a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_lt_pow2".
intros a b Ha.
split; intros H.
destruct (lt_ge_cases b 0) as [Hb|Hb].
generalize (log2_up_nonneg a); order.
apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg.
apply lt_le_trans with a; trivial.
apply (log2_up_spec a).
apply le_lt_trans with (2^b); trivial.
rewrite one_succ, le_succ_l. apply pow_pos_nonneg; order'.
destruct (lt_ge_cases b 0) as [Hb|Hb].
now rewrite pow_neg_r.
rewrite <- (log2_up_pow2 b) in H; trivial. now apply log2_up_lt_cancel.
Qed.

Lemma log2_up_le_pow2 : forall a b, 0<a -> (a<=2^b <-> log2_up a <= b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_le_pow2".
intros a b Ha.
split; intros H.
destruct (lt_ge_cases b 0) as [Hb|Hb].
rewrite pow_neg_r in H; order.
rewrite <- (log2_up_pow2 b); trivial. now apply log2_up_le_mono.
transitivity (2^(log2_up a)).
now apply log2_log2_up_spec.
apply pow_le_mono_r; order'.
Qed.

Lemma log2_up_lt_lin : forall a, 0<a -> log2_up a < a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_lt_lin".
intros a Ha.
assert (H : S (P a) == a) by (now apply lt_succ_pred with 0).
rewrite <- H at 2. apply lt_succ_r. apply log2_up_le_pow2; trivial.
rewrite <- H at 1. apply le_succ_l.
apply pow_gt_lin_r. order'. apply lt_succ_r; order.
Qed.

Lemma log2_up_le_lin : forall a, 0<=a -> log2_up a <= a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_le_lin".
intros a Ha.
le_elim Ha.
now apply lt_le_incl, log2_up_lt_lin.
rewrite <- Ha, log2_up_nonpos; order.
Qed.

Lemma log2_up_mul_above : forall a b, 0<=a -> 0<=b ->
log2_up (a*b) <= log2_up a + log2_up b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_mul_above".
intros a b Ha Hb.
assert (Ha':=log2_up_nonneg a).
assert (Hb':=log2_up_nonneg b).
le_elim Ha.
le_elim Hb.
apply log2_up_le_pow2; try order_pos.
rewrite pow_add_r; trivial.
apply mul_le_mono_nonneg; try apply log2_log2_up_spec; order'.
rewrite <- Hb. nzsimpl. rewrite log2_up_nonpos; order_pos.
rewrite <- Ha. nzsimpl. rewrite log2_up_nonpos; order_pos.
Qed.

Lemma log2_up_mul_below : forall a b, 0<a -> 0<b ->
log2_up a + log2_up b <= S (log2_up (a*b)).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_mul_below".
intros a b Ha Hb.
rewrite <-le_succ_l, <-one_succ in Ha. le_elim Ha.
rewrite <-le_succ_l, <-one_succ in Hb. le_elim Hb.
assert (Ha' : 0 < log2_up a) by (apply log2_up_pos; trivial).
assert (Hb' : 0 < log2_up b) by (apply log2_up_pos; trivial).
rewrite <- (lt_succ_pred 0 (log2_up a)); trivial.
rewrite <- (lt_succ_pred 0 (log2_up b)); trivial.
nzsimpl. rewrite <- succ_le_mono, le_succ_l.
apply (pow_lt_mono_r_iff 2). order'. apply log2_up_nonneg.
rewrite pow_add_r; try (apply lt_succ_r; rewrite (lt_succ_pred 0); trivial).
apply lt_le_trans with (a*b).
apply mul_lt_mono_nonneg; try order_pos; try now apply log2_up_spec.
apply log2_up_spec.
setoid_replace 1 with (1*1) by now nzsimpl.
apply mul_lt_mono_nonneg; order'.
rewrite <- Hb, log2_up_1; nzsimpl. apply le_succ_diag_r.
rewrite <- Ha, log2_up_1; nzsimpl. apply le_succ_diag_r.
Qed.

Lemma log2_up_mul_pow2 : forall a b, 0<a -> 0<=b ->
log2_up (a*2^b) == b + log2_up a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_mul_pow2".
intros a b Ha Hb.
rewrite <- le_succ_l, <- one_succ in Ha; le_elim Ha.
apply log2_up_unique. apply add_nonneg_pos; trivial. now apply log2_up_pos.
split.
assert (EQ := lt_succ_pred 0 _ (log2_up_pos _ Ha)).
rewrite <- EQ. nzsimpl. rewrite pow_add_r, mul_comm; trivial.
apply mul_lt_mono_pos_r. order_pos. now apply log2_up_spec.
rewrite <- lt_succ_r, EQ. now apply log2_up_pos.
rewrite pow_add_r, mul_comm; trivial.
apply mul_le_mono_nonneg_l. order_pos. now apply log2_up_spec.
apply log2_up_nonneg.
now rewrite <- Ha, mul_1_l, log2_up_1, add_0_r, log2_up_pow2.
Qed.

Lemma log2_up_double : forall a, 0<a -> log2_up (2*a) == S (log2_up a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_double".
intros a Ha. generalize (log2_up_mul_pow2 a 1 Ha le_0_1). now nzsimpl'.
Qed.

Lemma log2_up_same : forall a b, 0<a -> 0<b -> log2_up a == log2_up b -> a < 2*b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_same".
intros a b Ha Hb H.
apply log2_up_lt_cancel. rewrite log2_up_double, H by trivial.
apply lt_succ_diag_r.
Qed.

Lemma log2_up_succ_le : forall a, log2_up (S a) <= S (log2_up a).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_succ_le".
intros a.
destruct (lt_trichotomy 1 a) as [LT|[EQ|LT]].
rewrite 2 log2_up_eqn; trivial.
rewrite pred_succ, <- succ_le_mono. rewrite <-(lt_succ_pred 1 a LT) at 1.
apply log2_succ_le.
apply lt_succ_r; order.
rewrite <- EQ, <- two_succ, log2_up_1, log2_up_2. now nzsimpl'.
rewrite 2 log2_up_eqn0. order_pos. order'. now rewrite le_succ_l.
Qed.

Lemma log2_up_succ_or : forall a,
log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_succ_or".
intros.
destruct (le_gt_cases (log2_up (S a)) (log2_up a)).
right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order.
left. apply le_succ_l in H. generalize (log2_up_succ_le a); order.
Qed.

Lemma log2_up_eq_succ_is_pow2 : forall a,
log2_up (S a) == S (log2_up a) -> exists b, a == 2^b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_eq_succ_is_pow2".
intros a H.
destruct (le_gt_cases a 0) as [Ha|Ha].
rewrite 2 (proj2 (log2_up_null _)) in H. generalize (lt_succ_diag_r 0); order.
order'. apply le_succ_l. order'.
assert (Ha' : 1 < S a) by (now rewrite one_succ, <- succ_lt_mono).
exists (log2_up a).
generalize (proj1 (log2_up_spec (S a) Ha')) (proj2 (log2_log2_up_spec a Ha)).
rewrite H, pred_succ, lt_succ_r. order.
Qed.

Lemma log2_up_eq_succ_iff_pow2 : forall a, 0<a ->
(log2_up (S a) == S (log2_up a) <-> exists b, a == 2^b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_eq_succ_iff_pow2".
intros a Ha.
split. apply log2_up_eq_succ_is_pow2.
intros (b,Hb).
destruct (lt_ge_cases b 0) as [Hb'|Hb'].
rewrite pow_neg_r in Hb; order.
rewrite Hb, log2_up_pow2; try order'.
now rewrite log2_up_succ_pow2.
Qed.

Lemma log2_up_succ_double : forall a, 0<a ->
log2_up (2*a+1) == 2 + log2 a.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_succ_double".
intros a Ha.
rewrite log2_up_eqn. rewrite add_1_r, pred_succ, log2_double; now nzsimpl'.
apply le_lt_trans with (0+1). now nzsimpl'.
apply add_lt_mono_r. order_pos.
Qed.

Lemma log2_up_add_le : forall a b, a~=1 -> b~=1 ->
log2_up (a+b) <= log2_up a + log2_up b.
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.log2_up_add_le".
intros a b Ha Hb.
destruct (lt_trichotomy a 1) as [Ha'|[Ha'|Ha']]; [|order|].
rewrite (log2_up_eqn0 a) by order. nzsimpl. apply log2_up_le_mono.
rewrite one_succ, lt_succ_r in Ha'.
rewrite <- (add_0_l b) at 2. now apply add_le_mono.
destruct (lt_trichotomy b 1) as [Hb'|[Hb'|Hb']]; [|order|].
rewrite (log2_up_eqn0 b) by order. nzsimpl. apply log2_up_le_mono.
rewrite one_succ, lt_succ_r in Hb'.
rewrite <- (add_0_r a) at 2. now apply add_le_mono.
clear Ha Hb.
transitivity (log2_up (a*b)).
now apply log2_up_le_mono, add_le_mul.
apply log2_up_mul_above; order'.
Qed.

Lemma add_log2_up_lt : forall a b, 0<a -> 0<b ->
log2_up a + log2_up b < 2 * log2_up (a+b).
Proof. hammer_hook "NZLog" "NZLog.NZLog2UpProp.add_log2_up_lt".
intros a b Ha Hb. nzsimpl'.
assert (H : log2_up a <= log2_up (a+b)).
apply log2_up_le_mono. rewrite <- (add_0_r a) at 1. apply add_le_mono; order.
assert (H' : log2_up b <= log2_up (a+b)).
apply log2_up_le_mono. rewrite <- (add_0_l b) at 1. apply add_le_mono; order.
le_elim H.
apply lt_le_trans with (log2_up (a+b) + log2_up b).
now apply add_lt_mono_r. now apply add_le_mono_l.
rewrite <- H at 1. apply add_lt_mono_l.
le_elim H'. trivial.
symmetry in H. apply log2_up_same in H; try order_pos.
symmetry in H'. apply log2_up_same in H'; try order_pos.
revert H H'. nzsimpl'. rewrite <- add_lt_mono_l, <- add_lt_mono_r; order.
Qed.

End NZLog2UpProp.


From Coq Require Import Arith Lia.
Unset Elimination Schemes.

Section Acc.
  Variables (X: Type) (R: X -> X -> Prop).
  Inductive Acc (x: X) : Prop := AccC (h: forall y, R y x -> Acc y).
  Fact Acc_iff x :
    Acc x <-> forall y, R y x -> Acc y.
  Proof.
    split.
    - intros [h]. exact h.
    - apply AccC.
  Qed.
  Variable p: X -> Type.
  Variable F: (forall x, (forall y, R y x -> p y) -> p x).
  Definition W'
    : forall x, Acc x -> p x
    := fix f x a :=
         match a with AccC _ h => F x (fun y r => f y (h y r)) end.
  Definition wf := forall x, Acc x.
End Acc.
Arguments Acc {X}.
Arguments W' {X R p}.
Arguments wf {X}.
Definition W {X R p} H F x := @W' X R p F x (H x).

Fact Acc_ext {X} {R R': X -> X -> Prop} :
  (forall x y, R' x y -> R x y) -> forall x, Acc R x -> Acc R' x.
Proof.
  intros H.
  apply W'. intros x IH.
  constructor. intros y H1%H.
  apply IH, H1.
Qed.

Fact lt_wf :
  wf lt.
Proof.
  hnf.
  enough (forall n x, x < n -> Acc lt x) by eauto.
  induction n as [|n IH].
  - easy.
  - intros x H. constructor. intros y H1. apply IH. lia.
Defined.

Section Lexical_product.
  Variables (X: Type) (R: X -> X -> Prop).
  Variables (Y: Type) (S: Y -> Y -> Prop).
  Definition lex (a b: X * Y) : Prop :=
    R (fst a) (fst b) \/ fst a = fst b /\ S (snd a) (snd b).
  Fact lex_wf :
    wf R -> wf S -> wf lex.
  Proof.
    intros H1 H2 [x y]. revert x y.
    refine (W H1 _). intros x IH1.
    refine (W H2 _). intros y IH2.
    constructor. intros [x' y']. unfold lex at 1. cbn. intros [H|[-> H]].
    - apply IH1, H.
    - apply IH2, H.
  Defined.
End Lexical_product.
Arguments lex {X} R {Y}.
Arguments lex_wf {X R Y S}.

Section Retract.
  Variables (X Y: Type) (R: Y -> Y -> Prop) (sigma: X -> Y).
  Definition retract (x x': X) := R (sigma x) (sigma x').
  Fact retract_wf :
    wf R -> wf retract.
  Proof.
    intros H.
    enough (forall y x,  sigma x = y -> Acc retract x) by (hnf;eauto).
    refine (W H _). intros y IH x H1.
    constructor. intros x' H2.
    apply (IH (sigma x')). 2:reflexivity.
    destruct H1. exact H2.
  Defined.
  Definition size_rec :
    wf(R) -> forall p: X -> Type,
      (forall x, (forall x', R (sigma x') (sigma x) -> p x') -> p x) ->
      forall x, p x.
  Proof.
    intros R_wf p. apply (W (retract_wf R_wf)).
  Defined.
End Retract.
Arguments retract_wf {X Y R}.

From Coq Require Import FunctionalExtensionality.

Fact Acc_pure X (R: X -> X -> Prop) :
  forall x (a a': Acc R x), a = a'.
Proof.
  enough (forall x (a: Acc R x) (a a': Acc R x), a = a') by eauto.
  refine (W' _). intros x IH [h] [h']. f_equal.
  extensionality y. extensionality r. apply IH, r.
Qed.

Print Assumptions Acc_pure.

Fact W_eq
     {X} {R: X -> X -> Prop} {R_wf: wf R}
     {p: X -> Type}
     {F: forall x, (forall y, R y x -> p y) -> p x}
     (x: X)
  : W R_wf F x = F x (fun y _ => W R_wf F y).
Proof.
  unfold W. destruct (R_wf x) as [h]. cbn.
  f_equal. extensionality y. extensionality r.
  f_equal. apply Acc_pure.
Qed.

Fact W_unique
     {X} {R: X -> X -> Prop} {R_wf: wf R}
     {p: X -> Type}
     {F: forall x, (forall y, R y x -> p y) -> p x}
     (f f': forall x, p x)
  : (forall x, f x = F x (fun y r => f y)) ->
    (forall x, f' x = F x (fun y r => f' y)) ->
    forall x, f x = f' x.
Proof.
  intros H1 H2.
  apply (W R_wf). intros x IH.
  rewrite H1, H2.
  f_equal. extensionality y. extensionality r.
  apply IH,r.
Qed.

(* A function useed for hiding lia-generated termination proofs *)
Definition tau {X x} : X := x.

(** Euclidean division with W *)

(* Guarded step function, y pulled out as parameter *)
Definition Div (y x : nat) (h: forall x', x' < x -> nat) : nat.
Proof.
  refine (if le_lt_dec x y then 0 else S (h (x - S y) tau)).
  lia.
Defined.

Definition div x y : nat := W lt_wf (Div y) x.
Compute div 16 3.
Fact div_eq x y :
  div x y = if le_lt_dec x y then 0 else S (div (x - S y) y).
Proof.
  exact (W_eq x).
Qed.

Print Assumptions div_eq.

(** GCDs with W *)
(* Note: Pairing introduces considerable bureaucratic pain *)

Module GCD.
Implicit Types (x y: nat) (a b: nat * nat).
Definition sigma a := fst a + snd a.

Definition GCD a : (forall b, sigma b < sigma a -> nat) -> nat.
Proof.
  (* must take h late because of dependency on a *)
  refine (match a with
          | (0, y) => fun _ => y
          | (S x, 0) => fun _ => S x
          | (S x, S y) => fun h => match (le_lt_dec x y) with
                               | left H => h (S x, y - x) tau
                               | right H => h (x - y, S y) tau
                               end
          end).
  all: cbn; lia.
Defined.

Definition gcd x y : nat := W (retract_wf sigma lt_wf) GCD (x,y).

Compute gcd 49 63.

Fact gcd_eq3 x y :
  gcd (S x) (S y) = if le_lt_dec x y
                    then gcd (S x) (y - x)
                    else gcd (x - y) (S y).
Proof.
  refine (W_eq _).
Qed.

Fact gcd_eq x y :
  gcd x y = match x, y with
            | 0, y => y
            | S x, 0 => S x
            | S x, S y => if le_lt_dec x y
                         then gcd (S x) (y - x)
                         else gcd (x - y) (S y)
            end.
Proof.
  unfold gcd. rewrite W_eq.
  destruct x. reflexivity.
  destruct y; reflexivity.
Qed.
End GCD.

(** Ackermann with W *)

Definition ACK a : (forall b, lex lt lt b a -> nat) -> nat.
Proof.
  (* must take h late because of dependency on a *)
  (* tuned so that computation works,
     "_" in place of tau, auto instead of lia.
     Fragile, I don't understand it *)
  refine (match a with
          | (0, y) => fun _ => S y
          | (S x, 0) => fun h => h (x, 1) tau
          | (S x, S y) => fun h => h (x, h (S x, y) tau) _
          end).
  Unshelve.
  all: unfold lex; cbn; auto.
Defined.

Definition ack x y : nat := W (lex_wf lt_wf lt_wf) ACK (x,y).

Compute ack 3 3.

Fact ack_eq x y :
  ack x y = match x, y with
            | 0, y => S y
            | S x, 0 => ack x 1
            | S x, S y => ack x (ack (S x) y)
            end.
Proof.
  unfold ack. rewrite W_eq.
  destruct x. reflexivity.
  destruct y; reflexivity.
Qed.

(** Unfolding equation without FE *)

Section Unfolding.
  Variables
    (X: Type) (R: X -> X -> Prop)
    (p: X -> Type)
    (F: forall x, (forall y, R y x -> p y) -> p x).

  Implicit Types (x y : X) (f: forall x, p x).

  Definition Ext :=
    forall x h h', (forall y r, h y r = h' y r) -> F x h = F x h'.

  Variable F_ext: Ext.

  Lemma W'_ext x a a' :
    W' F x a = W' F x a'.
  Proof.
    revert x a a'.
    enough (forall x (a: Acc R x), forall a a', W' F x a = W' F x a') by eauto.
    refine (W' (fun x IH => _)).
    intros [phi] [phi']. cbn.
    apply F_ext. intros y r.
    apply IH, r.
  Qed.

  Definition sat f :=
    forall x, f x = F x (fun y _ => f y).

  Variable R_wf: wf R.

  Fact W_eq' :
    sat (W R_wf F).
  Proof.
    intros x. unfold W. destruct (R_wf x) as [phi]. cbn.
    apply F_ext. intros y r. apply W'_ext.
  Qed.

  Fact unique f f' :
    sat f -> sat f' -> forall x, f x = f' x.
  Proof.
    intros H1 H2.
    apply (W R_wf). intros x IH.
    rewrite H1, H2. apply F_ext. exact IH.
  Qed.
End Unfolding.
Arguments Ext {X R p} F.
Arguments W_eq' {X R p F} F_ext R_wf.

Fact Div_ext y :
  Ext (Div y).
Proof.
  intros x h h' H. unfold Div.
  destruct le_lt_dec as [H1|H1].
  - reflexivity.
  - f_equal. apply H.
Qed.

Fact GCD_ext :
  Ext GCD.GCD.
Proof.
  intros [x y] h h' H.
  destruct x. reflexivity.
  destruct y. reflexivity.
  unfold GCD.GCD.
  destruct le_lt_dec as [H1|H1]; apply H.
Qed.

Fact ACK_ext :
  Ext ACK.
Proof.
  intros [x y] h h' H.
  destruct x. reflexivity.
  destruct y; cbn.
  - apply H.
  - rewrite H. unfold tau. rewrite H. reflexivity.
Qed.

(** Classical Characterization *)

From Coq Require Import Classical_Prop.

Section Classical.
  Variables (X: Type) (R: X -> X -> Prop).
  Implicit Types (x y: X) (p: X -> Prop).

  Fact char_wf_ind :
    wf R <-> forall p: X -> Prop, (forall x, (forall y, R y x -> p y) -> p x) -> forall x, p x.
  Proof.
    split; intros H.
    - intros p. apply W. exact H.
    - refine (H (Acc R) _). apply AccC.
  Qed.

  Definition pro_pred p := forall x, p x -> exists y, p y /\ R y x.
  Definition pro x := exists p, p x /\ pro_pred p.

  Fact pro_disjoint x :
    Acc R x -> pro x -> False.
  Proof.
    revert x. refine (W' _). intros x IH.
    intros (p&H1&H2). apply H2 in H1 as (y&H1&H3).
    eapply IH. exact H3. exists p. easy.
  Qed.

  Fact pro_exhaustive_xm x :
    Acc R x \/ pro x.
  Proof.
    classical_right.
    exists (fun x => ~Acc R x). split. exact H.
    clear. intros x H.
    apply NNPP. contradict H. constructor. intros y H1.
    apply NNPP. contradict H. exists y; easy.
  Qed.

  Fact char_wf_pro_xm :
    wf R <-> ~ex pro.
  Proof.
    split.
    - intros H (x&H1). specialize (H x).
      eapply pro_disjoint; eassumption.
    - intros H x.
      destruct (pro_exhaustive_xm x) as [H1|H1]. exact H1.
      contradict H. exists x. exact H1.
  Qed.

  Definition min p x := p x /\ forall y, p y -> ~R y x.

  Fact pro_min_xm p :
    pro_pred p <-> ~ ex (min p).
  Proof.
    split; intros H.
    - intros (x&H2&H3).
      apply H in H2 as (y&H2&H4). eapply H3; eassumption.
    - intros x H2. apply NNPP. contradict H.
      exists x. split. exact H2.
      intros y H4 H5. apply H. exists y; easy.
  Qed.

  Fact pro_min_pred_xm :
    ~ex pro <-> forall p, ex p -> ex (min p).
  Proof.
    split; intros H.
    - intros p [x H1].
      apply NNPP. intros H2%pro_min_xm.
      apply H. exists x,p; easy.
    - intros (y&p&H1&H2%pro_min_xm).
      apply H2, H. exists y. exact H1.
  Qed.

  Fact char_wf_min_xm :
    wf R <-> forall p, ex p -> ex (min p).
  Proof.
    rewrite char_wf_pro_xm. apply pro_min_pred_xm.
  Qed.
End Classical.
Print Assumptions char_wf_min_xm.

(** Transitive closure *)

Section Transitive_closure.
  Variables (X: Type) (R: X -> X -> Prop).
  Inductive TC (x y: X) : Prop :=
  | TC1 : R x y -> TC x y
  | TC2 y' : TC x y' -> R y' y -> TC x y.
  Fact TC_wf :
    wf R -> wf TC.
  Proof.
    intros H. hnf.
    refine (W H _). intros y IH.
    constructor. intros x H1.
    destruct H1 as [H1|y' H1 H2].
    - apply IH, H1.
    - apply IH in H2. destruct H2 as [H2].
      apply H2, H1.
  Qed.
  Fact TC_ind x (p: X -> Prop) :
    (forall y, R x y -> p y) ->
    (forall y' y, p y' -> R y' y -> p y) ->
    forall y, TC x y -> p y.
  Proof.
    intros e1 e2.
    refine (fix f y a := match a with
                         | TC1 _ _ r => e1 y r
                         | TC2 _ _ y' a r => e2 y' y _ r
                         end).
    refine (f y' a).
  Qed.
  Fact TC_trans x y z :
    TC x y -> TC y z -> TC x z.
  Proof.
    intros H. revert z. apply TC_ind.
    - intros z. apply TC2, H.
    - intros y' z. apply TC2.
  Qed.
End Transitive_closure.

Section Successor_relation.
  Definition R_S (x y: nat) := S x = y.
  Fact R_S_wf :
    wf R_S.
  Proof.
    hnf. induction x as [|x IH].
    - constructor. unfold R_S at 1. easy.
    - constructor. unfold R_S at 1. intros y [= ->]. exact IH.
  Qed.
End Successor_relation.

(** Existential Witness Operator *)

Module EWO.
Section EWO.
  Variable p: nat -> Prop.
  Variable p_dec: forall n, p n + ~p n.
  Implicit Types x y: nat.

  Let R x y := (x = S y) /\ ~p y.

  Fact R_Acc x y :
    p (x + y) -> Acc R y.
  Proof.
    induction x as [|x IH] in y |-*;
      intros H; constructor; intros ? [-> H1].
    - exfalso. easy.
    - apply IH. rewrite <-plus_n_Sm. easy.
  Qed.

  Fact R_Acc_Sigma :
    forall x, Acc R x -> sigT p.
    refine (W' _). intros x IH.
    destruct (p_dec x) as [H1|H1].
    - exists x. exact H1.
    - apply (IH (S x)). easy.
  Qed.

  Fact EWO :
    ex p -> sigT p.
  Proof.
    intros H.
    apply (R_Acc_Sigma 0).
    destruct H as [x H].
    apply (R_Acc x 0).
    rewrite plus_0_r. exact H.
  Qed.
End EWO.
End EWO.

(** Exercise: Prove that (TC R_S) is < on numbers *)

Fact exercise_loop (X: Type) (R: X -> X -> Prop) :
  forall x y, R x y -> R y x -> ~Acc R x.
Proof.
  intros x y H1 H2 H3. revert x H3 y H1 H2.
  refine (W' _). intros x IH y H1 H2.
  eapply IH; eassumption.
Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Import ListNotations.

Definition beq_string x y :=
  if string_dec x y then true else false.

Theorem beq_string_refl : forall s : string,
  true = beq_string s s.
Proof.
  intros. unfold beq_string.
  destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

Theorem beq_string_true_iff : forall x y : string,
  beq_string x y = true <-> x = y.
Proof.
  split.
  - intros. unfold beq_string in H. destruct (string_dec x y) as [|Hs].
    + apply e.
    + inversion H.
  - intros. rewrite H. rewrite beq_string_refl with y. reflexivity.
Qed.

Theorem beq_string_false_iff : forall x y : string,
  beq_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Theorem false_beq_string : forall x y : string,
  x <> y -> beq_string x y = false.
Proof.
  intros x y. rewrite beq_string_false_iff.
  intros H. apply H.
Qed.

Definition total_map (A:Type) := string -> A.

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A:Type} (m : total_map A)
                             (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
            "bar" true.

Notation "{ --> d }" := (t_empty d) (at level 0).

Notation "m '&' { a --> x }" :=
  (t_update m a x) (at level 20).
Notation "m '&' { a --> x ; b --> y }" :=
  (t_update (m & { a --> x }) b y) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z }" :=
  (t_update (m & { a --> x ; b --> y }) c z) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z }) d t) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 20).
Notation "m '&' { a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
    (t_update (m & { a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 20).

Definition examplemap' :=
  { --> false } & { "foo" --> true ; "bar" --> true }.

(* Exercise: 1 star, optional (t_apply_empty) *)
Lemma t_apply_empty: forall (A:Type) (x: string) (v: A),
  { --> v } x = v.
Proof.
  intros. unfold t_empty. reflexivity.
Qed.

(* Exercise: 2 stars, optional (t_update_eq) *)
Lemma t_update_eq: forall A (m: total_map A) x v,
  (m & {x --> v}) x = v.
Proof.
  intros.
  unfold t_update. rewrite <- beq_string_refl. reflexivity.
Qed.

(* Exercise: 2 stars, optional (t_update_neq) *)
Theorem t_update_neq : forall (X:Type) v x1 x2
                              (m : total_map X),
  x1 <> x2 ->
  (m & {x1 --> v}) x2 = m x2.
Proof.
  intros.
  unfold t_update. rewrite false_beq_string.
  - reflexivity.
  - apply H.
Qed.

(* Exercise: 2 stars, optional (t_update_shadow) *)
Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
  m & {x --> v1 ; x --> v2} = m & {x --> v2}.
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (beq_string x x0).
  - reflexivity.
  - reflexivity.
Qed.

(* Exercise: 2 stars, optional (beq_stringP) *)
Lemma beq_stringP : forall x y,
  reflect (x = y) (beq_string x y).
Proof.
  intros.
  destruct (beq_string x y) eqn:H.
  - apply ReflectT. unfold beq_string in H. destruct (string_dec x y).
    + apply e.
    + inversion H.
  - apply ReflectF. rewrite <- beq_string_false_iff. apply H.
Qed.

(* Exercise: 2 stars (t_update_same) *)
Theorem t_update_same : forall X x (m : total_map X),
  m & { x --> m x } = m.
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (beq_stringP x x0).
  - rewrite e. reflexivity.
  - reflexivity.
Qed.

(* Exercise: 3 stars, recommended (t_update_permute) *)
Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                                  (m : total_map X),
  x2 <> x1 ->
  m & { x2 --> v2 ; x1 --> v1 }
  = m & { x1 --> v1 ; x2 --> v2 }.
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (beq_stringP x2 x) as [H1 | H1].
  - destruct (beq_stringP x1 x) as [H2 | H2].
    + unfold not in H. destruct H. rewrite H1. rewrite H2. reflexivity.
    + reflexivity.
  - reflexivity.
Qed.

(* Partial Maps *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                    (x : string) (v : A) :=
  m & { x --> (Some v) }.

Notation "m '&' {{ a --> x }}" :=
  (update m a x) (at level 20).
Notation "m '&' {{ a --> x ; b --> y }}" :=
  (update (m & {{ a --> x }}) b y) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z }}" :=
  (update (m & {{ a --> x ; b --> y }}) c z) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z }}) d t) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t }}) e u) (at level 20).
Notation "m '&' {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }}" :=
    (update (m & {{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }}) f v) (at level 20).

Lemma apply_empty : forall (A: Type) (x: string), @empty A x = None.
Proof.
  intros.
  unfold empty. unfold t_empty. reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
  (m & {{ x --> v }}) x = Some v.
Proof.
  intros.
  unfold update.
  rewrite t_update_eq.
  reflexivity.
Qed.

Lemma update_neg : forall (X:Type) v x1 x2
                          ( m: partial_map X),
  x2 <> x1 ->
  (m & {{ x2 --> v }}) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update.
  apply t_update_neq. apply H.
Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  m & {{ x --> v1 ; x --> v2 }} = m & {{x --> v2}}.
Proof.
  intros.
  unfold update.
  apply t_update_shadow.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  m & {{x --> v}} = m.
Proof.
  intros.
  unfold update.
  rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                          (m : partial_map X),
  x2 <> x1 ->
  m & {{x2 --> v2 ; x1 --> v1}}
  = m & {{x1 --> v1 ; x2 --> v2}}.
Proof.
  intros.
  apply t_update_permute.
  apply H.
Qed.


(* This file is a modification of an eponymous file from the CoqApprox        *)
(* library. The header of the original file is reproduced below. Changes are  *)
(* part of the analysis library and enjoy the same licence as this library.   *)
(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (c) 2010-2013, ENS de Lyon and Inria.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

Require Import Rdefinitions Raxioms RIneq Rbasic_fun Zwf.
Require Import Epsilon FunctionalExtensionality Ranalysis1 Rsqrt_def.
Require Import Rtrigo1 Reals.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import choice bigop ssralg fintype poly.
From mathcomp Require Import mxpoly ssrnum finfun.
From Lindemann Require Import archi.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GRing.Theory Num.Def Num.Theory.

Local Open Scope R_scope.

Lemma Req_EM_T (r1 r2 : R) : {r1 = r2} + {r1 <> r2}.
Proof.
case: (total_order_T r1 r2) => [[r1Lr2 | <-] | r1Gr2].
- by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {2}r1Er2.
- by left.
by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {1}r1Er2.
Qed.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical R_eqMixin := EqMixin eqrP.
Canonical R_eqType := Eval hnf in EqType R R_eqMixin.

Fact inhR : inhabited R.
Proof. exact: (inhabits 0). Qed.

Definition pickR (P : pred R) (n : nat) :=
  let x := epsilon inhR P in if P x then Some x else None.

Fact pickR_some P n x : pickR P n = Some x -> P x.
Proof. by rewrite /pickR; case: (boolP (P _)) => // Px [<-]. Qed.

Fact pickR_ex (P : pred R) :
  (exists x : R, P x) -> exists n, pickR P n.
Proof. by rewrite /pickR; move=> /(epsilon_spec inhR)->; exists 0%N. Qed.

Fact pickR_ext (P Q : pred R) : P =1 Q -> pickR P =1 pickR Q.
Proof.
move=> PEQ n; rewrite /pickR; set u := epsilon _ _; set v := epsilon _ _.
suff->: u = v by rewrite PEQ.
by congr epsilon; apply: functional_extensionality=> x; rewrite PEQ.
Qed.

Definition R_choiceMixin : choiceMixin R :=
  Choice.Mixin pickR_some pickR_ex pickR_ext.

Canonical R_choiceType := Eval hnf in ChoiceType R R_choiceMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Definition R_zmodMixin := ZmodMixin RplusA Rplus_comm Rplus_0_l Rplus_opp_l.

Canonical R_zmodType := Eval hnf in ZmodType R R_zmodMixin.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Fact R1_neq_0 : R1 != R0.
Proof. by apply/eqP/R1_neq_R0. Qed.

Definition R_ringMixin := RingMixin RmultA Rmult_1_l Rmult_1_r
  Rmult_plus_distr_r Rmult_plus_distr_l R1_neq_0.

Canonical R_ringType := Eval hnf in RingType R R_ringMixin.
Canonical R_comRingType := Eval hnf in ComRingType R Rmult_comm.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.

Definition Rinvx r := if (r != 0) then / r else r.

Definition unit_R r := r != 0.

Lemma RmultRinvx : {in unit_R, left_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_l //; apply/eqP.
Qed.

Lemma RinvxRmult : {in unit_R, right_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_r //; apply/eqP.
Qed.

Lemma intro_unit_R x y : y * x = 1 /\ x * y = 1 -> unit_R x.
Proof.
move=> [yx_eq1 _]; apply: contra_eqN yx_eq1 => /eqP->.
by rewrite Rmult_0_r eq_sym R1_neq_0.
Qed.

Lemma Rinvx_out : {in predC unit_R, Rinvx =1 id}.
Proof. by move=> x; rewrite inE /= /Rinvx -if_neg => ->. Qed.

Definition R_unitRingMixin :=
  UnitRingMixin RmultRinvx RinvxRmult intro_unit_R Rinvx_out.

Canonical R_unitRing :=
  Eval hnf in UnitRingType R R_unitRingMixin.

Canonical R_comUnitRingType :=
  Eval hnf in [comUnitRingType of R].

Lemma R_idomainMixin x y : x * y = 0 -> (x == 0) || (y == 0).
Proof. by move=> /Rmult_integral []->; rewrite eqxx ?orbT. Qed.

Canonical R_idomainType := Eval hnf in IdomainType R R_idomainMixin.

Lemma R_fieldMixin : GRing.Field.mixin_of [unitRingType of R].
Proof. by done. Qed.

Definition R_fieldIdomainMixin := FieldIdomainMixin R_fieldMixin.

Canonical R_fieldType := FieldType R R_fieldMixin.

(** Reflect the order on the reals to bool *)

Definition Rleb r1 r2 := if Rle_dec r1 r2 is left _ then true else false.
Definition Rltb r1 r2 := Rleb r1 r2 && (r1 != r2).
Definition Rgeb r1 r2 := Rleb r2 r1.
Definition Rgtb r1 r2 := Rltb r2 r1.

Lemma RlebP r1 r2 : reflect (r1 <= r2) (Rleb r1 r2).
Proof. by rewrite /Rleb; apply: (iffP idP); case: Rle_dec. Qed.

Lemma RltbP r1 r2 : reflect (r1 < r2) (Rltb r1 r2).
Proof.
rewrite /Rltb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
- by case=> // r1Er2 /eqP[].
- by move=> _ r1Lr2; apply/eqP/Rlt_not_eq.
by move=> Nr1Lr2 r1Lr2; case: Nr1Lr2; left.
Qed.

(*
Ltac toR := rewrite /GRing.add /GRing.opp /GRing.zero /GRing.mul /GRing.inv
  /GRing.one //=.
*)

Section ssreal_struct.

Import GRing.Theory.
Import Num.Theory.
Import Num.Def.

Local Open Scope R_scope.

Lemma Rleb_norm_add x y : Rleb (Rabs (x + y)) (Rabs x + Rabs y).
Proof. by apply/RlebP/Rabs_triang. Qed.

Lemma addr_Rgtb0 x y : Rltb 0 x -> Rltb 0 y -> Rltb 0 (x + y).
Proof. by move/RltbP=> Hx /RltbP Hy; apply/RltbP/Rplus_lt_0_compat. Qed.

Lemma Rnorm0_eq0 x : Rabs x = 0 -> x = 0.
Proof. by move=> H; case: (x == 0) /eqP=> // /Rabs_no_R0. Qed.

Lemma Rleb_leVge x y : Rleb 0 x -> Rleb 0 y -> (Rleb x y) || (Rleb y x).
Proof.
move/RlebP=> Hx /RlebP Hy; case: (Rlt_le_dec x y).
by move/Rlt_le/RlebP=> ->.
by move/RlebP=> ->; rewrite orbT.
Qed.

Lemma RnormM : {morph Rabs : x y / x * y}.
exact: Rabs_mult. Qed.

Lemma Rleb_def x y : (Rleb x y) = (Rabs (y - x) == y - x).
apply/(sameP (RlebP x y))/(iffP idP)=> [/eqP H| /Rle_minus H].
  apply: Rminus_le; rewrite -Ropp_minus_distr.
  apply/Rge_le/Ropp_0_le_ge_contravar.
  by rewrite -H; apply: Rabs_pos.
apply/eqP/Rabs_pos_eq.
rewrite -Ropp_minus_distr.
by apply/Ropp_0_ge_le_contravar/Rle_ge.
Qed.

Lemma Rltb_def x y : (Rltb x y) = (y != x) && (Rleb x y).
apply/(sameP (RltbP x y))/(iffP idP).
  case/andP=> /eqP H /RlebP/Rle_not_gt H2.
  by case: (Rtotal_order x y)=> // [][] // /esym.
move=> H; apply/andP; split; [apply/eqP|apply/RlebP].
  exact: Rgt_not_eq.
exact: Rlt_le.
Qed.

Definition R_numMixin := NumMixin Rleb_norm_add addr_Rgtb0 Rnorm0_eq0
                                  Rleb_leVge RnormM Rleb_def Rltb_def.
Canonical R_numDomainType := NumDomainType R R_numMixin.

Lemma RleP : forall x y, reflect (Rle x y) (x <= y)%R.
Proof. exact: RlebP. Qed.
Lemma RltP : forall x y, reflect (Rlt x y) (x < y)%R.
Proof. exact: RltbP. Qed.
(* :TODO: *)
(* Lemma RgeP : forall x y, reflect (Rge x y) (x >= y)%R. *)
(* Proof. exact: RlebP. Qed. *)
(* Lemma RgtP : forall x y, reflect (Rgt x y) (x > y)%R. *)
(* Proof. exact: RltbP. Qed. *)

Canonical R_numFieldType := [numFieldType of R].

Lemma Rreal_axiom (x : R) : (0 <= x)%R || (x <= 0)%R.
Proof.
case: (Rle_dec 0 x)=> [/RleP ->|] //.
by move/Rnot_le_lt/Rlt_le/RleP=> ->; rewrite orbT.
Qed.

Canonical R_realDomainType := RealDomainType R Rreal_axiom.
Canonical R_realFieldType := [realFieldType of R].

Lemma Rarchimedean_axiom : Num.archimedean_axiom R_numDomainType.
Proof.
move=> x; exists (Z.abs_nat (up x) + 2)%N.
have [Hx1 Hx2]:= (archimed x).
have Hz (z : Z): z = (z - 1 + 1)%Z by rewrite Zplus_comm Zplus_minus.
have Zabs_nat_Zopp z : Z.abs_nat (- z)%Z = Z.abs_nat z by case: z.
apply/RltbP/Rabs_def1.
  apply: (Rlt_trans _ ((Z.abs_nat (up x))%:R)%R); last first.
    rewrite -[((Z.abs_nat _)%:R)%R]Rplus_0_r mulrnDr.
    by apply/Rplus_lt_compat_l/Rlt_0_2.
  apply: (Rlt_le_trans _ (IZR (up x)))=> //.
  elim/(well_founded_ind (Zwf_well_founded 0)): (up x) => z IHz.
  case: (Z_lt_le_dec 0 z) => [zp | zn].
    rewrite [z]Hz plus_IZR Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE mulrnDr.
    apply/Rplus_le_compat_r/IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_trans _ (IZR 0)); first exact: IZR_le.
  by apply/RlebP/(ler0n R_numDomainType (Z.abs_nat z)).
apply: (Rlt_le_trans _ (IZR (up x) - 1)).
  apply: Ropp_lt_cancel; rewrite Ropp_involutive.
  rewrite Ropp_minus_distr /Rminus -opp_IZR -{2}(Z.opp_involutive (up x)).
  elim/(well_founded_ind (Zwf_well_founded 0)): (- up x)%Z => z IHz .
  case: (Z_lt_le_dec 0 z) => [zp | zn].
  rewrite [z]Hz Zabs_nat_Zopp plus_IZR.
  rewrite Zabs_nat_Zplus //; last exact: Zlt_0_le_0_pred.
    rewrite plusE -Rplus_assoc -addnA [(_ + 2)%N]addnC addnA mulrnDr.
    apply: Rplus_lt_compat_r; rewrite -Zabs_nat_Zopp.
    apply: IHz; split; first exact: Zlt_le_weak.
    exact: Zlt_pred.
  apply: (Rle_lt_trans _ 1).
    rewrite -{2}[1]Rplus_0_r; apply: Rplus_le_compat_l.
    by rewrite -/(IZR 0); apply: IZR_le.
  rewrite mulrnDr; apply: (Rlt_le_trans _ 2).
    by rewrite -{1}[1]Rplus_0_r; apply/Rplus_lt_compat_l/Rlt_0_1.
  rewrite -[2]Rplus_0_l; apply: Rplus_le_compat_r.
  by apply/RlebP/(ler0n R_numDomainType (Z.abs_nat _)).
apply: Rminus_le.
rewrite /Rminus Rplus_assoc [- _ + _]Rplus_comm -Rplus_assoc -!/(Rminus _ _).
exact: Rle_minus.
Qed.

Canonical R_archiNumDomainType := ArchiNumDomainType R Rarchimedean_axiom.
Canonical R_archiNumFieldType := [archiNumFieldType of R].
Canonical R_archiRealDomainType := [archiRealDomainType of R].
Canonical R_archiRealFieldType := ArchiFieldType R Rarchimedean_axiom.

(** Here are the lemmas that we will use to prove that R has
the rcfType structure. *)

Lemma continuity_eq f g : f =1 g -> continuity f -> continuity g.
Proof.
move=> Hfg Hf x eps Heps.
have [y [Hy1 Hy2]]:= Hf x eps Heps.
by exists y; split=> // z; rewrite -!Hfg; exact: Hy2.
Qed.

Lemma continuity_sum (I : finType) F (P : pred I):
(forall i, P i -> continuity (F i)) ->
continuity (fun x => (\sum_(i | P i) ((F i) x)))%R.
Proof.
move=> H; elim: (index_enum I)=> [|a l IHl].
  set f:= fun _ => _.
  have Hf: (fun x=> 0) =1 f by move=> x; rewrite /f big_nil.
  by apply: (continuity_eq Hf); exact: continuity_const.
set f := fun _ => _.
case Hpa: (P a).
  have Hf: (fun x => F a x + \sum_(i <- l | P i) F i x)%R =1 f.
    by move=> x; rewrite /f big_cons Hpa.
  apply: (continuity_eq Hf); apply: continuity_plus=> //.
  exact: H.
have Hf: (fun x => \sum_(i <- l | P i) F i x)%R =1 f.
  by move=> x; rewrite /f big_cons Hpa.
exact: (continuity_eq Hf).
Qed.

Lemma continuity_exp f n: continuity f -> continuity (fun x => (f x)^+ n)%R.
Proof.
move=> Hf; elim: n=> [|n IHn]; first exact: continuity_const.
set g:= fun _ => _.
have Hg: (fun x=> f x * f x ^+ n)%R =1 g.
  by move=> x; rewrite /g exprS.
by apply: (continuity_eq Hg); exact: continuity_mult.
Qed.

Lemma Rreal_closed_axiom : Num.real_closed_axiom R_numDomainType.
Proof.
move=> p a b; rewrite !ler_eqVlt.
case Hpa: ((p.[a])%R == 0%R).
  by move=> ? _ ; exists a=> //; rewrite lerr ler_eqVlt.
case Hpb: ((p.[b])%R == 0%R).
  by move=> ? _; exists b=> //; rewrite lerr ler_eqVlt andbT.
case Hab: (a == b).
  by move=> _; rewrite (eqP Hab) eq_sym Hpb (ltrNge 0) /=; case/andP=> /ltrW ->.
rewrite eq_sym Hpb /=; clear=> /RltbP Hab /andP [] /RltbP Hpa /RltbP Hpb.
suff Hcp: continuity (fun x => (p.[x])%R).
  have [z [[Hza Hzb] /eqP Hz2]]:= IVT _ a b Hcp Hab Hpa Hpb.
  by exists z=> //; apply/andP; split; apply/RlebP.
rewrite -[p]coefK poly_def.
set f := fun _ => _.
have Hf: (fun (x : R) => \sum_(i < size p) (p`_i * x^+i))%R =1 f.
  move=> x; rewrite /f horner_sum.
  by apply: eq_bigr=> i _; rewrite hornerZ hornerXn.
apply: (continuity_eq Hf); apply: continuity_sum=> i _.
apply:continuity_scal; apply: continuity_exp=> x esp Hesp.
by exists esp; split=> // y [].
Qed.

Canonical R_rcfType := RcfType R Rreal_closed_axiom.
Canonical R_archiRcfType := [archiRcfType of R].

End ssreal_struct.

Open Scope ring_scope.
(*Require Import reals boolp.*)

Section ssreal_struct_contd.
(*
Lemma is_upper_boundE (E : pred R) x : is_upper_bound E x = (x \in ub E).
Proof.
rewrite /is_upper_bound inE forallbE asboolE /=; apply/eq_forall=> y.
by rewrite -(reflect_eq implyP) (reflect_eq (RleP _ _)).
Qed.

Lemma boundE (E : pred R) : bound E = has_ub E.
Proof. by apply/eq_exists=> x; rewrite is_upper_boundE. Qed.

Lemma completeness' (E : pred R) : has_sup E -> {m : R | is_lub E m}.
Proof. by move=> [eE bE]; rewrite -boundE in bE; apply: completeness. Qed.

Definition real_sup (E : pred R) : R :=
  if pselect (has_sup E) isn't left hsE then 0 else projT1 (completeness' hsE).

Lemma real_sup_is_lub (E : pred R) : has_sup E -> is_lub E (real_sup E).
Proof.
by move=> hsE; rewrite /real_sup; case: pselect=> // ?; case: completeness'.
Qed.

Lemma real_sup_ub (E : pred R) : has_sup E -> real_sup E \in ub E.
Proof. by move=> /real_sup_is_lub []; rewrite is_upper_boundE. Qed.

Lemma real_sup_out (E : pred R) : ~ has_sup E -> real_sup E = 0.
Proof. by move=> nosup; rewrite /real_sup; case: pselect. Qed.

(* :TODO: rewrite like this using (a fork of?) Coquelicot *)
(* Lemma real_sup_adherent (E : pred R) : real_sup E \in closure E. *)
Lemma real_sup_adherent (E : pred R) (eps : R) :
  has_sup E -> 0 < eps -> exists2 e : R, E e & (real_sup E - eps) < e.
Proof.
move=> supE eps_gt0; set m := _ - eps; apply: contrapT=> mNsmall.
have: m \in ub E.
  apply/ubP=> y Ey; have /negP := mNsmall (ex_intro2 _ _ y Ey _).
  by rewrite -lerNgt.
have [_ /(_ m)] := real_sup_is_lub supE.
rewrite is_upper_boundE => m_big /m_big /RleP.
by rewrite -subr_ge0 addrC addKr oppr_ge0 lerNgt eps_gt0.
Qed.

Definition real_realMixin : Real.mixin_of _ :=
  RealMixin real_sup_ub real_sup_adherent real_sup_out.
Canonical real_realType := RealType R real_realMixin.
*)
Implicit Types (x y : R) (m n : nat).

(* equational lemmas about exp, sin and cos for mathcomp compat *)

(* Require Import realsum. *)

(* :TODO: One day, do this *)
(* Notation "\Sum_ i E" := (psum (fun i => E)) *)
(*  (at level 100, i ident, format "\Sum_ i  E") : ring_scope. *)

(* Definition exp x := \Sum_n (n`!)%:R^-1 * x ^ n. *)

Lemma expR0 : exp (0 : R) = 1.
Proof. by rewrite exp_0. Qed.

Lemma expRD x y : exp x * exp y = exp (x + y).
Proof. by rewrite exp_plus. Qed.

Lemma expRX x n : exp x ^+ n = exp (x *+ n).
Proof.
elim: n => [|n Ihn]; first by rewrite expr0 mulr0n exp_0.
by rewrite exprS Ihn mulrS expRD.
Qed.

Lemma sinD x y : sin (x + y) = sin x * cos y + cos x * sin y.
Proof. by rewrite sin_plus. Qed.

Lemma cosD x y : cos (x + y) = (cos x * cos y - sin x * sin y).
Proof. by rewrite cos_plus. Qed.

Lemma RplusE x y : Rplus x y = x + y. Proof. by []. Qed.

Lemma RminusE x y : Rminus x y = x - y. Proof. by []. Qed.

Lemma RmultE x y : Rmult x y = x * y. Proof. by []. Qed.

Lemma RoppE x : Ropp x = - x. Proof. by []. Qed.

Lemma RinvE x : x != 0 -> Rinv x = x^-1.
Proof. by move=> x_neq0; rewrite -[RHS]/(if _ then _ else _) x_neq0. Qed.

Lemma RdivE x y : y != 0 -> Rdiv x y = x / y.
Proof. by move=> y_neq0; rewrite /Rdiv RinvE. Qed.

Lemma INRE n : INR n = n%:R.
Proof. elim: n => // n IH; by rewrite S_INR IH RplusE -addn1 natrD. Qed.

Lemma RsqrtE x : 0 <= x -> sqrt x = Num.sqrt x.
Proof.
move => x0; apply/eqP; have [t1 t2] := conj (sqrtr_ge0 x) (sqrt_pos x).
rewrite eq_sym -(eqr_expn2 (_: 0 < 2)%N t1) //; last by apply /RleP.
rewrite sqr_sqrtr // !exprS expr0 mulr1 -RmultE ?sqrt_sqrt //; by apply/RleP.
Qed.

Lemma RpowE x n : pow x n = x ^+ n.
Proof. by elim: n => [ | n In] //=; rewrite exprS In RmultE. Qed.

Lemma RmaxE x y : Rmax x y = Num.max x y.
Proof.
case: (lerP x y) => H; first by rewrite maxr_r // Rmax_right //; apply: RlebP.
by rewrite maxr_l ?ltrW // Rmax_left //;  apply/RlebP; move/ltrW : H.
Qed.

(* useful? *)
Lemma RminE x y : Rmin x y = Num.min x y.
Proof.
case: (lerP x y) => H; first by rewrite minr_l // Rmin_left //; apply: RlebP.
by rewrite minr_r ?ltrW // Rmin_right //;  apply/RlebP; move/ltrW : H.
Qed.

(* bigop pour le max pour des listes non vides ? *)
Definition bigmaxr (x0 : R) lr :=
  foldr Num.max (head x0 lr) (behead lr).

Lemma bigmaxr_nil x0 : bigmaxr x0 [::] = x0.
Proof. by rewrite /bigmaxr. Qed.

Lemma bigmaxr_un x0 x : bigmaxr x0 [:: x] = x.
Proof. by rewrite /bigmaxr. Qed.

Lemma bigmaxr_cons x0 x y lr :
  bigmaxr x0 (x :: y :: lr) = Num.max x (bigmaxr x0 (y :: lr)).
Proof.
rewrite /bigmaxr /=; elim: lr => [/= | a lr /=]; first by rewrite maxrC.
set b := foldr _ _ _; set c := foldr _ _ _ => H.
by rewrite [Num.max a b]maxrC maxrA H -maxrA (maxrC c a).
Qed.

Lemma bigmaxr_ler x0 lr i :
  (i < size lr)%N -> (nth x0 lr i) <= (bigmaxr x0 lr).
Proof.
case: lr i => [i | x lr]; first by rewrite nth_nil bigmaxr_nil lerr.
elim: lr x => [x i /= | x lr /= ihlr y i i_size].
  by rewrite ltnS leqn0 => /eqP ->; rewrite nth0 bigmaxr_un /=.
rewrite bigmaxr_cons /=; case: i i_size => [_ /= | i].
  by rewrite ler_maxr lerr.
rewrite ltnS /=; move/(ihlr x); move/(ler_trans)=> H; apply: H.
by rewrite ler_maxr lerr orbT.
Qed.

(* Compatibilité avec l'addition *)
Lemma bigmaxr_addr x0 lr x :
  bigmaxr (x0 + x) (map (fun y => y + x) lr) = (bigmaxr x0 lr) + x.
Proof.
case: lr => [/= | y lr]; first by rewrite bigmaxr_nil.
elim: lr y => [y | y lr ihlr z]; first by rewrite /= !bigmaxr_un.
by rewrite map_cons !bigmaxr_cons ihlr addr_maxl.
Qed.

Lemma bigmaxr_index x0 lr :
  (0 < size lr)%N -> (index (bigmaxr x0 lr) lr < size lr)%N.
Proof.
case: lr => [//= | x l _].
elim: l x => [x | x lr]; first by rewrite bigmaxr_un /= eq_refl.
move/(_ x); set z := bigmaxr _ _ => /= ihl y; rewrite bigmaxr_cons /Num.max -/z.
case: (z <= y); first by rewrite eq_refl.
by case: (y == z); rewrite //.
Qed.

Lemma bigmaxr_mem x0 lr :
  (0 < size lr)%N -> bigmaxr x0 lr \in lr.
Proof. by move/(bigmaxr_index x0); rewrite index_mem. Qed.

Lemma bigmaxr_lerP x0 lr x :
  (0 < size lr)%N ->
  reflect (forall i, (i < size lr)%N -> (nth x0 lr i) <= x) ((bigmaxr x0 lr) <= x).
Proof.
move=> lr_size; apply: (iffP idP) => [le_x i i_size | H].
  by apply: (ler_trans _ le_x); apply: bigmaxr_ler.
by move/(nthP x0): (bigmaxr_mem x0 lr_size) => [i i_size <-]; apply: H.
Qed.

Lemma bigmaxr_ltrP x0 lr x :
  (0 < size lr)%N ->
  reflect (forall i, (i < size lr)%N -> (nth x0 lr i) < x) ((bigmaxr x0 lr) < x).
Proof.
move=> lr_size; apply: (iffP idP) => [lt_x i i_size | H].
  by apply: ler_lt_trans lt_x; apply: bigmaxr_ler.
by move/(nthP x0): (bigmaxr_mem x0 lr_size) => [i i_size <-]; apply: H.
Qed.

Lemma bigmaxrP x0 lr x :
  (x \in lr /\ forall i, (i < size lr) %N -> (nth x0 lr i) <= x) -> (bigmaxr x0 lr = x).
Proof.
move=> [] /(nthP x0) [] j j_size j_nth x_ler; apply: ler_asym; apply/andP; split.
  by apply/bigmaxr_lerP => //; apply: (leq_trans _ j_size).
by rewrite -j_nth (bigmaxr_ler _ j_size).
Qed.

(* surement à supprimer à la fin
Lemma bigmaxc_lttc x0 lc :
  uniq lc -> forall i, (i < size lc)%N -> (i != index (bigmaxc x0 lc) lc)
    -> lttc (nth x0 lc i) (bigmaxc x0 lc).
Proof.
move=> lc_uniq Hi size_i /negP neq_i.
rewrite lttc_neqAle (bigmaxc_letc _ size_i) andbT.
apply/negP => /eqP H; apply: neq_i; rewrite -H eq_sym; apply/eqP.
by apply: index_uniq.
Qed. *)

Lemma bigmaxr_lerif x0 lr :
  uniq lr -> forall i, (i < size lr)%N ->
     (nth x0 lr i) <= (bigmaxr x0 lr) ?= iff (i == index (bigmaxr x0 lr) lr).
Proof.
move=> lr_uniq i i_size; rewrite /lerif (bigmaxr_ler _ i_size).
rewrite -(nth_uniq x0 i_size (bigmaxr_index _ (leq_trans _ i_size)) lr_uniq) //.
rewrite nth_index //.
by apply: bigmaxr_mem; apply: (leq_trans _ i_size).
Qed.

(* bigop pour le max pour des listes non vides ? *)
Definition bmaxrf n (f : {ffun 'I_n.+1 -> R}) :=
  bigmaxr (f ord0) (codom f).

Lemma bmaxrf_ler n (f : {ffun 'I_n.+1 -> R}) i :
  (f i) <= (bmaxrf f).
Proof.
move: (@bigmaxr_ler (f ord0) (codom f) (nat_of_ord i)).
rewrite /bmaxrf size_codom card_ord => H; move: (ltn_ord i); move/H.
suff -> : nth (f ord0) (codom f) i = f i; first by [].
by rewrite /codom (nth_map ord0) ?size_enum_ord // nth_ord_enum.
Qed.

Lemma bmaxrf_index n (f : {ffun 'I_n.+1 -> R}) :
  (index (bmaxrf f) (codom f) < n.+1)%N.
Proof.
rewrite /bmaxrf.
have {6}-> : n.+1 = size (codom f) by rewrite size_codom card_ord.
by apply: bigmaxr_index; rewrite size_codom card_ord.
Qed.

Definition index_bmaxrf n f := Ordinal (@bmaxrf_index n f).

Lemma ordnat i n (ord_i : (i < n)%N) : i = Ordinal ord_i :> nat.
Proof. by []. Qed.

Lemma eq_index_bmaxrf n (f : {ffun 'I_n.+1 -> R}) :
  f (index_bmaxrf f) = bmaxrf f.
Proof.
move: (bmaxrf_index f).
rewrite -{3}[n.+1]card_ord -(size_codom f) index_mem.
move/(nth_index (f ord0)) => <-; rewrite (nth_map ord0).
  by rewrite (ordnat (bmaxrf_index _)) /index_bmaxrf nth_ord_enum.
by rewrite size_enum_ord; apply: bmaxrf_index.
Qed.

Lemma bmaxrf_lerif n (f : {ffun 'I_n.+1 -> R}) :
  injective f -> forall i,
     (f i) <= (bmaxrf f) ?= iff (i == index_bmaxrf f).
Proof.
by move=> inj_f i; rewrite /lerif bmaxrf_ler -(inj_eq inj_f) eq_index_bmaxrf.
Qed.

End ssreal_struct_contd.