From QuickChick Require Import QuickChick. Import QcNotation.
From Coq Require Import List. Import ListNotations.
From Coq Require Import ZArith.
From ExtLib Require Import Monad.
Import MonadNotation.

From BST Require Import Impl.
From BST Require Import Spec.

#[local] Instance FuzzyNat : Fuzzy nat :=
  {| fuzz n := choose (n - 5, n + 5) |}.

Derive (Arbitrary, Show, Sized, Fuzzy) for Tree.

#[local] Instance FuzzyProd {A} `{Fuzzy A} {B} `{Fuzzy B}  : Fuzzy (A * B)  :=
{|
  fuzz ab :=
    (let '(a, b) := ab in
    ma <- fuzz a ;;
    mb <- fuzz b ;;
    ret (ma,mb))
|}.

(* ManualExtract Tree. *)

(* QuickChickDebug Debug On. *)
(*|toggle|*)Axiom num_tests : nat. Extract Constant num_tests => "max_int".

Definition test_prop_InsertValid (tkv: (Tree * nat * nat)) :=
  let '(t, k, v) := tkv in
  prop_InsertValid t k v.

Definition test_prop_InsertValid_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_InsertValid.

(*! FuzzChick test_prop_InsertValid (test_prop_InsertValid_fuzzer tt). *)

Definition test_prop_DeleteValid (tk: Tree * nat)  :=
  let '(t, k) := tk in
  prop_DeleteValid t k.

Definition test_prop_DeleteValid_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_DeleteValid.

(*! FuzzChick test_prop_DeleteValid (test_prop_DeleteValid_fuzzer tt). *)

Definition test_prop_UnionValid (t1t2: Tree * Tree)  :=
  let '(t1, t2) := t1t2 in
  prop_UnionValid t1 t2.

Definition test_prop_UnionValid_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_UnionValid.

(*! FuzzChick test_prop_UnionValid (test_prop_UnionValid_fuzzer tt). *)

Definition test_prop_InsertPost (tkkpv: Tree * nat * nat * nat) :=
  let '(t, k, k', v) := tkkpv in
  prop_InsertPost t k k' v.

Definition test_prop_InsertPost_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_InsertPost.

(*! FuzzChick test_prop_InsertPost (test_prop_InsertPost_fuzzer tt). *)

Definition test_prop_DeletePost (tkkp: Tree * nat * nat) :=
  let '(t, k, k') := tkkp in
  prop_DeletePost t k k.

Definition test_prop_DeletePost_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_DeletePost.

(*! FuzzChick test_prop_DeletePost (test_prop_DeletePost_fuzzer tt). *)

Definition test_prop_UnionPost (ttpk: Tree * Tree * nat)  :=
  let '(t, t', k) := ttpk in
  prop_UnionPost t t' k.

Definition test_prop_UnionPost_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_UnionPost.

(*! FuzzChick test_prop_UnionPost (test_prop_UnionPost_fuzzer tt). *)

Definition test_prop_InsertModel (tkv: Tree * nat * nat)  :=
  let '(t, k, v) := tkv in
  prop_InsertModel t k v.

Definition test_prop_InsertModel_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_InsertModel.

(*! FuzzChick test_prop_InsertModel (test_prop_InsertModel_fuzzer tt). *)

Definition test_prop_DeleteModel (tk: Tree * nat)  :=
  let '(t, k) := tk in
  prop_DeleteModel t k.

Definition test_prop_DeleteModel_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_DeleteModel.

(*! FuzzChick test_prop_DeleteModel (test_prop_DeleteModel_fuzzer tt). *)

Definition test_prop_UnionModel (ttp: Tree * Tree) :=
  let '(t, t') := ttp in
  prop_UnionModel t t'.

Definition test_prop_UnionModel_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_UnionModel.

(*! FuzzChick test_prop_UnionModel (test_prop_UnionModel_fuzzer tt). *)

Definition test_prop_InsertInsert (tkkpvvp: Tree * nat * nat * nat * nat)   :=
  let '(t, k, k', v, v') := tkkpvvp in
  prop_InsertInsert t k k' v v.

Definition test_prop_InsertInsert_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_InsertInsert.

(*! FuzzChick test_prop_InsertInsert (test_prop_InsertInsert_fuzzer tt). *)

Definition test_prop_InsertDelete (tkkpv: Tree * nat * nat * nat)  :=
  let '(t, k, k', v) := tkkpv in
  prop_InsertDelete t k k' v.

Definition test_prop_InsertDelete_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_InsertDelete.

(*! FuzzChick test_prop_InsertDelete (test_prop_InsertDelete_fuzzer tt). *)

Definition test_prop_InsertUnion (ttpkv: Tree * Tree * nat * nat) :=
  let '(t, t', k, v) := ttpkv in
  prop_InsertUnion t t' k v.

Definition test_prop_InsertUnion_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_InsertUnion.

(*! FuzzChick test_prop_InsertUnion (test_prop_InsertUnion_fuzzer tt). *)

Definition test_prop_DeleteInsert (tkkpvp: Tree * nat * nat * nat) :=
  let '(t, k, k', v') := tkkpvp in
  prop_DeleteInsert t k k' v'.

Definition test_prop_DeleteInsert_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_DeleteInsert.

(*! FuzzChick test_prop_DeleteInsert (test_prop_DeleteInsert_fuzzer tt). *)

Definition test_prop_DeleteDelete (tkkp: Tree * nat * nat) :=
  let '(t, k, k') := tkkp in
  prop_DeleteDelete t k k'.

Definition test_prop_DeleteDelete_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_DeleteDelete.

(*! FuzzChick test_prop_DeleteDelete (test_prop_DeleteDelete_fuzzer tt). *)

Definition test_prop_DeleteUnion (ttpk: Tree * Tree * nat) :=
  let '(t, t', k) := ttpk in
  prop_DeleteUnion t t' k.

Definition test_prop_DeleteUnion_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_DeleteUnion.

(*! FuzzChick test_prop_DeleteUnion (test_prop_DeleteUnion_fuzzer tt). *)

Definition test_prop_UnionDeleteInsert (ttpkv: Tree * Tree * nat * nat) :=
  let '(t, t', k, v) := ttpkv in
  prop_UnionDeleteInsert t t' k v.

Definition test_prop_UnionDeleteInsert_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_UnionDeleteInsert.

(*! FuzzChick test_prop_UnionDeleteInsert (test_prop_UnionDeleteInsert_fuzzer tt). *)

Definition test_prop_UnionUnionIdem (t: Tree) :=
  prop_UnionUnionIdem t.

Definition test_prop_UnionUnionIdem_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_UnionUnionIdem.

(*! FuzzChick test_prop_UnionUnionIdem (test_prop_UnionUnionIdem_fuzzer tt). *)

Definition test_prop_UnionUnionAssoc (t1t2t3 : Tree * Tree * Tree) :=
  let '(t1, t2, t3) := t1t2t3 in
  prop_UnionUnionAssoc t1 t2 t3.

Definition test_prop_UnionUnionAssoc_fuzzer :=
  fun (u : unit) => fuzzLoopWith (updMaxDiscard (updMaxSuccess (updAnalysis stdArgs true) num_tests) num_tests) arbitrary fuzz show test_prop_UnionUnionAssoc.

(*! FuzzChick test_prop_UnionUnionAssoc (test_prop_UnionUnionAssoc_fuzzer tt). *)


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import Logic.Classical.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Logic.PropExtensionality.
From Coq Require Import Logic.ProofIrrelevance.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Classes.Morphisms.
From Coq Require Import Field.
From Coq Require Import Omega.
From Coq Require Import Psatz.
From CReal Require Import Cauchy.RBase.
From CReal Require Import Cauchy.RArith.
From CReal Require Import Cauchy.RSign.
From CReal Require Import Cauchy.ROrder.
From CReal Require Import Cauchy.RAbs.
From CReal Require Import Cauchy.RFunc.
From CReal Require Import Cauchy.RComplete.
From CReal Require Import INQ_libs.
From CReal Require Import Uncomputable.Countable.
From CReal Require Import Uncomputable.ComRealBase.
From CReal Require Import Uncomputable.ComRealField.
From CReal Require Import Uncomputable.ComRealBaseLemma1.
From CReal Require Import Uncomputable.SingleLemmas.
From Coq Require Import PArith.BinPosDef.

Module CauchyR <: VIR_R.
  Definition R := Real.
  Delimit Scope R_scope with R.
  Bind Scope R_scope with R.
  Local Open Scope R_scope.
  Definition R0 := Rzero.
  Definition R1 := Rone.
  Definition Rplus := Rplus.
  Definition Rmult := Rmult.
  Definition Ropp := Ropp.
  Module Vex <: R_SINGLE_SIMPLE.
    Definition R := Real.
    Delimit Scope R_scope with R.
    Bind Scope R_scope with R.
    Local Open Scope R_scope.
    Definition Req := Real_equiv.
    Definition R_Setoid := Real_equiv_holds.
    Infix "==" := Req : R_scope.
    Definition P_singlefun (X : R -> Prop) := (forall x1 x2, X x1 -> X x2 -> x1 == x2)
         /\ (exists x, X x) /\ Proper (Req ==> iff) X.
    Definition Rsinglefun : {X: R -> Prop | P_singlefun X} -> R.
      intros.
      apply RSingleFun.
      destruct X. exists x.
      destruct p. destruct H0.
      auto.
    Defined.
    Theorem Rsinglefun_correct: forall X H, X (Rsinglefun (exist _ X H)).
    Proof.
      intros.
      unfold Rsinglefun.
      apply Rsinglefun_correct.
    Qed.
  End Vex.
  Module Vex_Lemmas := RSignleLemmas (Vex).
  Module Rinv_partial <: RINV_PARTIAL Vex.
    Module RS := Vex.
    Module RL := Vex_Lemmas.
    Import RS RL.
    Local Open Scope R_scope.
    Definition R0 := Rzero.
    Definition R1 := Rone.
    Definition Rmult := Rmult.
    Infix "*" := Rmult : R_scope.
    Definition Rmult_comp := Rmult_comp.
    Definition rinv' := Rinv.
    Definition Rinv' (a : R) (H : ~ (a == R0)) : R.
      apply rinv'.
      exists a. apply H.
    Defined.
    Theorem Rinv'_comp : forall (r1 r2 : R)(H1 : ~ r1 == R0) (H2 : ~r2 == R0), r1 == r2 -> Rinv' r1 H1 == Rinv' r2 H2.
    Proof.
      intros.
      pose proof Rinv_equiv (exist _ r1 H1) (exist _ r2 H2).
      specialize (H0 H).
      apply H0.
    Qed.
    Theorem Rinv'_l : forall (r : R)(H : ~ r == R0), Rinv' r H * r == R1.
    Proof.
      intros.
      rewrite Rmult_comm.
      apply Rmult_inv_r'.
    Qed.
  End Rinv_partial.

  Module RPTT := Rinv_Partial_To_Total Vex (Rinv_partial).

  Export RPTT Rinv_partial Vex_Lemmas Vex.
  Definition Rinv := Rinv.
  Definition Rlt := Rlt.
  Definition Req := Real_equiv.
  Infix "==" := Req : R_scope.
  Infix "+" := Rplus : R_scope.
  Infix "*" := Rmult : R_scope.
  Notation "- x" := (Ropp x) : R_scope.
  Notation "/ x" := (Rinv x) : R_scope.
  Infix "<" := Rlt : R_scope.

  Definition Rgt (r1 r2:R) : Prop := r2 < r1.

  Definition Rle (r1 r2:R) : Prop := Rlt r1 r2 \/ r1 ==r2.

  Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 == r2.

  Definition Rminus (r1 r2:R) : R := r1 + - r2.

  Definition Rdiv (r1 r2 :R) : R := r1 * Rinv r2.

  Infix "-" := Rminus : R_scope.
  Infix "/" := Rdiv : R_scope.
  Infix "<=" := Rle : R_scope.
  Infix ">=" := Rge : R_scope.
  Infix ">"  := Rgt : R_scope.
  Notation "0" := R0 : R_scope.
  Notation "1" := R1 : R_scope.
  Notation "2" := (1+1) : R_scope.

  Definition Req_refl := Real_def_refl.

  Definition Req_sym := Real_def_symm.

  Definition Req_trans := Real_def_trans.

  Definition R_Setoid := Real_equiv_holds.

  Definition Rplus_comp := Rplus_comp.

  Definition Ropp_comp := Ropp_comp.

  Definition Rmult_comp := Rmult_comp.

  Instance Rinv_comp : Proper (Req==>Req) Rinv.
  Proof.
    apply Rinv_comp.
  Qed.

  Instance Rle_comp : Proper (Req==>Req==>iff) Rle.
  Proof.
    split.
    - intros.
      destruct H1.
      + left. rewrite <- H , <- H0. auto.
      + right. rewrite <- H , <- H0. auto.
    - intros.
      destruct H1.
      + left. rewrite H, H0. auto.
      + right. rewrite H ,H0. auto.
  Qed.

  Definition Rlt_comp := Rlt_comp.

  Instance Rminus_comp : Proper (Req==>Req==>Req) Rminus.
  Proof. hnf ; red ; intros. unfold Rminus. rewrite H , H0. reflexivity. Qed.

  Instance Rdiv_comp : Proper (Req==>Req==>Req) Rdiv.
  Proof. hnf ; red ; intros. unfold Rdiv. rewrite H , H0. reflexivity. Qed.

  Instance Rgt_comp : Proper (Req==>Req==>iff) Rgt.
  Proof. hnf ; red ; intros. unfold Rgt. rewrite H , H0. reflexivity. Qed.

  Instance Rge_comp : Proper (Req==>Req==>iff) Rge.
  Proof. hnf ; red ; intros. unfold Rge. rewrite H , H0. reflexivity. Qed.

  (* Complementary definition of Real Equivalence. *)
  Fixpoint pow (r:R) (n:nat) : R :=
    match n with
      | O => 1
      | S n => Rmult r (pow r n)
    end.

  Notation "x ^ y" := (pow x y) : R_scope.

  Instance Rpow_comp : Proper (Req ==> eq ==> Req) pow.
  Proof.
    hnf ; red; intros. subst.
    induction y0.
    - reflexivity.
    - simpl. rewrite IHy0. rewrite H. reflexivity.
  Qed.

  (* Definition copied from Rpow_def.v *)

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

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

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

  (* Definitions copied from Rdefinitions.v *)

  Fixpoint INR (n:nat) : R :=
    match n with
    | O => 0
    | S O => 1
    | S n => INR n + 1
    end.
  Arguments INR n%nat.

  (* Definition copied from Raxioms.v *)

  Definition IQR(q : Q) : R :=
    match q with
    | p # q => IZR p / IPR q
    end.
  Arguments IQR q%Q.

  Definition Rplus_comm := Rplus_comm.

  Definition Rplus_assoc := Rplus_assoc.

  Definition Rplus_opp_r := Rplus_opp_r.

  Definition Rplus_0_l := Rplus_0_l.

  Definition Rmult_comm := Rmult_comm.

  Definition Rmult_assoc := Rmult_assoc.

  Theorem Rinv_l : forall r:R, ~ r == 0 -> Rinv r * r == 1.
  Proof.
    apply Rinv_l.
  Qed.

  Definition Rmult_1_l := Rmult_1_l.

  Theorem R1_gt_R0 : 0 < 1.
  Proof.
    rewrite <- Rpositive_gt_0.
      hnf.
      exists 1%Q.
      split ; try (lra).
      exists O.
      intros.
      simpl in H0.
      lra.
  Qed.

  Theorem Rmult_plus_distr_l :
    forall r1 r2 r3 : R, r1 * (r2 + r3) == (r1 * r2) + (r1 * r3).
  Proof.
    intros.
    rewrite Rmult_comm.
    rewrite Rmult_plus_distr_l.
    rewrite ! (Rmult_comm r1).
    reflexivity.
  Qed.

  Theorem total_order_T : forall r1 r2 : R, r1 < r2 \/ r1 == r2 \/ r2 < r1.
  Proof.
    intros.
    destruct (classic (r1 < r2)) ; auto.
    apply Rnot_lt in H.
    auto.
  Qed.

  Theorem Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1.
  Proof.
    intros. intro.
    apply (Rlt_irrefl r1).
    apply Rlt_trans with r2 ; auto.
  Qed.

  Definition Rlt_trans := Rlt_trans.

  Theorem Rplus_lt_compat_l :
    forall r r1 r2 : R, r1 < r2 -> (r + r1)%R < (r + r2)%R.
  Proof.
    intros.
    rewrite ! (Rplus_comm r).
    apply Rlt_plus_r. auto.
  Qed.

  Theorem Rmult_lt_compat_l :
     forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2.
  Proof.
    intros.
    rewrite !(Rmult_comm r).
    apply Rlt_mult_r with (C := r) ; auto.
    apply Rpositive_gt_0. auto.
  Qed.

End CauchyR.

Module CauchyR_complete : VIR_R_COMPLETE CauchyR.
  Module RF := VirR_Field(CauchyR).
  Module RLemma1 := VirRLemma1 CauchyR.
  Export CauchyR RF RLemma1.
  Local Open Scope R_scope.
  Module Vex_Lemmas := RSignleLemmas CauchyR.Vex.

  Export CauchyR.Vex Vex_Lemmas.

  Theorem IZR_Q:forall z:Z, IZR z == inject_Q (inject_Z z).
Proof. apply Zind.
  - reflexivity.
  - intros. unfold Z.succ. rewrite plus_IZR.  rewrite inject_Z_plus.
    rewrite inject_Q_plus. assert(IZR 1 == inject_Q (inject_Z 1)).
    { hnf. intros. exists O. intros. rewrite H2,H3. unfold Qminus.
    rewrite Qplus_opp_r. apply H0. } rewrite H,H0. reflexivity.
  - intros. unfold Z.pred. rewrite plus_IZR, inject_Z_plus, inject_Q_plus.
    assert(IZR (-1) == inject_Q (inject_Z (-1))). {
    hnf. unfold Cauchy_opp. intros. exists O. intros. assert(-1 = -(1))%Z. reflexivity.
    rewrite H4,(inject_Z_opp 1) in H3. clear H4. assert(-q2==1)%Q.
    { rewrite H3. rewrite Qopp_opp. reflexivity. }
    apply (H2 (-q2)%Q)in H4. rewrite Qopp_opp in H4. rewrite H4. unfold Qminus.
    rewrite Qplus_opp_r. apply H0. } rewrite H, H0. reflexivity.
Qed.
  Theorem R_Archimedian':forall A B:R,
    Rpositive A -> Rpositive B -> exists z:Z, inject_Q (inject_Z z) * A > B.
Proof. pose proof R_Archimedian. intros. pose proof classic (A<B).
  destruct H2.
  - (** lt*) apply (H A B) in H0.  destruct H0. exists (Z.of_nat x). apply H0. auto.
  - apply Rnot_lt in H2. destruct H2.
    + (** eq*) exists 2%Z. rewrite H2. unfold Rgt. rewrite<-Rmult_1_l at 1.
      rewrite Rmult_comm. rewrite (Rmult_comm _ B). apply Rlt_mult_l. apply H1.
      hnf. exists 1%Q. split. lra. unfold RArith.Rminus.  unfold RArith.Ropp.
      unfold RArith.Rplus.  unfold inject_Q. unfold Rone. unfold Cauchy_opp.
      exists O. unfold CauchySeqPlus. intros.  rewrite (H4 2 (-1))%Q;try lra.
      reflexivity. intros. lra.
    + (** gt*) exists 1%Z. assert(inject_Q (inject_Z 1) == 1). reflexivity.
      rewrite H3. rewrite Rmult_1_l. apply H2.
Qed.
  Theorem R_Archimedian'':forall A:R, Rpositive A ->
    exists z:Z, inject_Q (inject_Z z) > A.
Proof. pose proof (R_Archimedian' 1). intros. assert(Rpositive 1).
  { unfold Rpositive. unfold Rone. exists 1%Q. split. lra. exists O.
    intros. rewrite H2. lra. }
  apply (H A) in H1;auto. destruct H1. exists x. rewrite<-Rmult_1_l.
  rewrite Rmult_comm. apply H1.
Qed.
  Lemma czlemma1:forall a b:R,Rpositive a -> Rpositive b
    -> (forall n, inject_Q (inject_Z n)*a>b -> inject_Q (inject_Z (n-1))*a>b)
    -> exists x1,forall m, inject_Q (inject_Z(x1 + m))* a>b.
Proof. intros a b Ha Hb H. assert(Rpositive a) by auto.
  apply (R_Archimedian' a b) in H0;auto. destruct H0.
  exists x. apply Zind. - (** m=0*) rewrite Zplus_0_r. apply H0.
  - (** m+1*)intros. unfold Z.succ. rewrite Zplus_assoc. rewrite inject_Z_plus.
  rewrite inject_Q_plus. remember (inject_Q (inject_Z (x + x0))).
  assert(r*a + a>r*a). { unfold Rgt. rewrite<-Rplus_0_r at 1.
  apply Rplus_lt_compat_l. apply Rpositive_gt_0 in Ha. apply Ha. }
  rewrite Rmult_comm.  rewrite Rmult_plus_distr_l. rewrite Rmult_comm.
  rewrite Rmult_1_r. apply Rlt_trans with (r*a);auto.
  - (** m-1*)intros. apply H in H1. unfold Z.pred. rewrite Zplus_assoc. apply H1.
Qed.
  Lemma czlemma2:forall a b:R,Rpositive a -> Rpositive b
    -> (forall n, inject_Q (inject_Z n)*a>b -> inject_Q (inject_Z (n-1))*a>b)
    -> forall m, inject_Q (inject_Z m)* a>b.
Proof. intros.
  assert(exists x1, forall m, inject_Q (inject_Z (x1 + m)) * a > b).
  { apply czlemma1;auto. }
  destruct H2. assert(inject_Q (inject_Z (x + (-x +m))) * a > b).
  apply H2. rewrite Zplus_assoc in H3. rewrite Zplus_opp_r in H3.
  rewrite Zplus_0_l in H3. apply H3.
Qed.
  Lemma czlemma3:forall a b:R,Rpositive a -> Rpositive b
    -> ~(forall n, inject_Q (inject_Z n)*a>b -> inject_Q (inject_Z (n-1))*a>b).
Proof. intros. intros H1. assert(forall m, inject_Q (inject_Z m)* a>b).
  { apply czlemma2;auto. } assert(0*a>b). {
    replace Rzero with (inject_Q (inject_Z 0)) by reflexivity. apply H2. }
  rewrite Rmult_0_l in H3. apply Rpositive_gt_0 in H0. apply Rlt_asym in H0.
  destruct H0. auto.
Qed.
  (** czlemma_le just like czlemma except changing lt to le*)
  Lemma czlemma1_le:forall a b:R,Rpositive a -> Rpositive b
    -> (forall n, inject_Q (inject_Z n)*a>=b -> inject_Q (inject_Z (n-1))*a>=b)
    -> exists x1,forall m, inject_Q (inject_Z(x1 + m))* a>=b.
Proof. intros a b Ha Hb H. assert(Rpositive a) by auto.
  apply (R_Archimedian' a b) in H0;auto. destruct H0.
  exists x. apply Zind. - (** m=0*) rewrite Zplus_0_r.
  unfold Rge. left. apply H0.
  - (** m+1*)intros. unfold Z.succ. rewrite Zplus_assoc. rewrite inject_Z_plus.
  rewrite inject_Q_plus. remember (inject_Q (inject_Z (x + x0))).
  assert(r*a + a>r*a). { unfold Rgt. rewrite<-Rplus_0_r at 1.
  apply Rplus_lt_compat_l. apply Rpositive_gt_0 in Ha. apply Ha. }
  rewrite Rmult_comm.  rewrite Rmult_plus_distr_l. rewrite Rmult_comm.
  rewrite Rmult_1_r. destruct H1.
    + unfold Rge. left. apply Rlt_trans with (r*a);auto.
    + rewrite H1. unfold Rge. left. unfold Rgt. rewrite<-Rplus_0_r at 1.
      apply Rplus_lt_compat_l. apply Rpositive_gt_0 in Ha. apply Ha.
  - (** m-1*)intros. apply H in H1. unfold Z.pred. rewrite Zplus_assoc. apply H1.
Qed.
  Lemma czlemma2_le:forall a b:R,Rpositive a -> Rpositive b
    -> (forall n, inject_Q (inject_Z n)*a>=b -> inject_Q (inject_Z (n-1))*a>=b)
    -> forall m, inject_Q (inject_Z m)* a>=b.
Proof. intros.
  assert(exists x1, forall m, inject_Q (inject_Z (x1 + m)) * a >= b).
  { apply czlemma1_le;auto. }
  destruct H2. assert(inject_Q (inject_Z (x + (-x +m))) * a >= b).
  apply H2. rewrite Zplus_assoc in H3. rewrite Zplus_opp_r in H3.
  rewrite Zplus_0_l in H3. apply H3.
Qed.
  Lemma czlemma3_le:forall a b:R,Rpositive a -> Rpositive b
    -> ~(forall n, inject_Q (inject_Z n)*a>=b -> inject_Q (inject_Z (n-1))*a>=b).
Proof. intros. intros H1. assert(forall m, inject_Q (inject_Z m)* a>=b).
  { apply czlemma2_le;auto. } assert(0*a>=b). {
    replace Rzero with (inject_Q (inject_Z 0)) by reflexivity. apply H2. }
  rewrite Rmult_0_l in H3. apply Rpositive_gt_0 in H0.
  apply Rge_not_lt in H3. auto.
Qed.
  Lemma IZR_change:forall x r, IZR x - r > 1 -> IZR (x-1) > r.
Proof. intros. apply (Rplus_lt_compat_l (r-1)) in H. unfold Rminus in H.
   (** left H*)rewrite Rplus_assoc in H. rewrite (Rplus_comm _ 1) in H.
   rewrite Rplus_opp_r in H. rewrite Rplus_0_r in H.
  (** right H*) rewrite Rplus_assoc in H. rewrite<-(Rplus_assoc (-1%R)) in H.
   rewrite (Rplus_comm (-1%R)) in H. rewrite<-(opp_IZR 1) in H.
   rewrite<-plus_IZR in H. rewrite Rplus_comm in H. assert(-r + r==0).
   { rewrite Rplus_comm. rewrite Rplus_opp_r. reflexivity. }
    rewrite Rplus_assoc in H. rewrite H0 in H. rewrite Rplus_0_r in H.
    apply H.
Qed.
  Example pos1:Rpositive 1.
Proof. unfold Rpositive. unfold Rone. exists 1%Q. split. lra.
  exists O. intros. rewrite H0. lra.
Qed.
  Lemma Rnot_ge_lt:forall a b, ~(a>=b) -> a<b.
Proof. intros. pose proof classic (a<b). destruct H0;auto.
  destruct H. apply Rnot_lt_le in H0. hnf. destruct H0.
  - left;auto. -  right. symmetry; auto.
Qed.
  (** lemmas for proving archimed: end*)
  Theorem archimed : forall r:R, exists z : Z , IZR z > r /\ IZR z - r <= 1.
Proof. pose proof czlemma3. intros r. pose proof (Real_sgn_case r).
  destruct H0 as [H0|[H0|H0]].
  - (** positive*) apply not_all_not_ex. intros Hcontra.
    assert(forall x, (~(IZR x > r) \/ ~(IZR x - r <= 1))).
    { intros. specialize (Hcontra x). tauto. }
    assert(forall x, IZR x>r -> IZR (x-1) > r).
    { intros x. destruct (H1 x).
      + tauto.
      + intros _. apply IZR_change. apply Rnot_le_lt. apply H2. }
    apply (H 1 r);auto using pos1. intros n. repeat rewrite<-IZR_Q.
    repeat rewrite Rmult_1_r. apply H2.
  - (** zero*)exists (1)%Z. unfold IZR. unfold IPR. rewrite H0. split.
    + unfold Rgt. hnf. exists (1)%Q. split. lra. exists O. intros.
      hnf in H2. unfold Cauchy_opp in H2. rewrite (H2 1 0)%Q;try lra.
      intros. rewrite H3. lra.
    + assert(1%R-0==1)%R. { unfold RArith.Rminus.
      rewrite<-Rzero_opp_zero.  rewrite Rplus_0_r. reflexivity. } rewrite H1.
      hnf. right;reflexivity.
  - (** negative*) clear H. pose proof czlemma3_le. apply Rnegative_Ropp in H0.
    apply (H 1 (-r)) in H0;auto using pos1. clear H. apply not_all_ex_not in H0.
    destruct H0. exists (1+ -x)%Z. apply imply_to_and in H. destruct H. split.
    + apply Rnot_ge_lt in H0. rewrite<-IZR_Q in H0. rewrite Rmult_1_r in H0.
      assert(x-1 = x + -1)%Z by reflexivity. rewrite H1 in H0. clear H1.
      rewrite plus_IZR in H0. apply (Rplus_lt_compat_l (r + IZR 1 + -IZR x)) in H0.
      (** left*)rewrite<-Rplus_assoc in H0. rewrite (Rplus_assoc (r + IZR 1)) in H0.
      rewrite (Rplus_comm (-IZR x)) in H0. rewrite Rplus_opp_r in H0.
      rewrite Rplus_0_r in H0. assert(-1 = - 1%Z)%Z by reflexivity.
      rewrite H1 in H0. rewrite opp_IZR in H0. rewrite Rplus_assoc in H0.
      rewrite Rplus_opp_r in H0. rewrite Rplus_0_r in H0.
      (** right*) rewrite (Rplus_comm _ (-r)) in H0.
      repeat rewrite<-(Rplus_assoc (-r) _ _) in H0. rewrite (Rplus_comm (-r)) in H0.
      rewrite Rplus_opp_r in H0. rewrite Rplus_0_l in H0. rewrite<-opp_IZR in H0.
      rewrite plus_IZR. apply H0.
    + destruct H.
      * hnf. left. apply (Rplus_lt_compat_l (IZR (1 + - x))) in H.
        rewrite Rmult_1_r in H. rewrite<-IZR_Q in H. rewrite plus_IZR in H at 2.
        rewrite (Rplus_assoc _ _ (IZR x)) in H. rewrite (Rplus_comm _ (IZR x)) in H.
        rewrite opp_IZR in H. rewrite Rplus_opp_r in H. rewrite Rplus_0_r in H.
        apply H.
      * unfold Rminus. rewrite<-H. rewrite<-IZR_Q. rewrite Rmult_1_r.
        rewrite plus_IZR. rewrite Rplus_assoc. rewrite (Rplus_comm _ (IZR x)).
        rewrite opp_IZR. rewrite Rplus_opp_r. rewrite Rplus_0_r.
        hnf. right. reflexivity.
Qed.

  (** We have proved another version in Cauchy.RAbs named R_Archimedian *)
  Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m.

  Definition bound (E:R -> Prop) := exists m : R, is_upper_bound E m.

  Definition is_lub (E:R -> Prop) (m:R) :=
  is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).

  Fixpoint Nested_interval (E : R -> Prop) (x y : R) (n : nat) : R * R.
    destruct n eqn : En.
    - apply (x , y).
    - set (Nested_interval E x y n0).
      set (fst p).
      set (snd p).
      apply ((Rif (is_upper_bound E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound E ((r + r0)/2)) ((r + r0) / 2) r0 )).
  Defined.

  Definition Left_Nested_interval (E : R -> Prop) (x y : R) (n : nat) : R :=
     fst (Nested_interval E x y n).

  Definition Right_Nested_interval (E : R -> Prop) (x y : R)(n : nat) : R :=
     snd (Nested_interval E x y n).

  Lemma Rle_div2 : forall x y : R , x <= y -> x <= (x + y) / 2.
  Proof.
    intros.
    unfold Rdiv.
    apply Rle_mult_compat_r with 2.
    - rewrite Rpositive_gt_0. apply Rlt_0_2.
    - rewrite Rmult_assoc. rewrite Rinv_l.
      + rewrite Rmult_plus_distr_l.
        rewrite !Rmult_1_r.
        apply Rle_plus_l.
        auto.
      + intro.
        apply (Rlt_irrefl 0).
        rewrite <- H0 at 2.
        apply Rlt_0_2.
  Qed.

  Lemma Rge_div2 : forall x y : R , x <= y -> (x + y) / 2 <= y.
  Proof.
    intros.
    unfold Rdiv.
    apply Rle_mult_compat_r with 2.
    - rewrite Rpositive_gt_0. apply Rlt_0_2.
    - rewrite Rmult_assoc. rewrite Rinv_l.
      + rewrite Rmult_plus_distr_l.
        rewrite !Rmult_1_r.
        apply Rle_plus_r.
        auto.
      + intro.
        apply (Rlt_irrefl 0).
        rewrite <- H0 at 2.
        apply Rlt_0_2.
  Qed.

  Lemma Pow2_lemma1 : forall n : nat , 2 ^ n > 0.
  Proof.
    induction n.
    - simpl. apply R1_gt_R0.
    - rewrite <- Nat.add_1_r in *.
      rewrite Rdef_pow_add in *.
      apply Rmult_lt_0_compat.
      + apply IHn.
      + unfold pow. rewrite Rmult_1_r. apply Rlt_0_2.
  Qed.

  Lemma Pow2_lemma2 : forall n : nat , 2 ^ n >= 1.
  Proof.
    induction n.
    - simpl. apply Rle_refl.
    - rewrite <- Nat.add_1_r in *.
      rewrite Rdef_pow_add in *.
      assert (2 ^ 1 == 2).
      { unfold pow. rewrite Rmult_1_r. reflexivity. }
      rewrite H. clear H.
      rewrite Rmult_plus_distr_l.
      rewrite Rmult_1_r.
      apply Rle_ge. apply Rge_le in IHn.
      apply Rle_trans with (1+1).
      + rewrite <- Rplus_0_r.
        apply Rplus_le_compat.
        apply Rle_refl. left.
        apply R1_gt_R0.
      + apply Rplus_le_compat ; auto.
  Qed.

  Lemma Pow2_lemma3 : forall n : nat , 2 ^ n > INR n.
  Proof.
    intros.
    induction n.
    - simpl. apply R1_gt_R0.
    - rewrite <- Nat.add_1_r. rewrite plus_INR.
      rewrite Rdef_pow_add.
      assert (2 ^ 1 == 2).
      { unfold pow. rewrite Rmult_1_r. reflexivity. }
      rewrite H.
      rewrite Rmult_plus_distr_l. rewrite Rmult_1_r.
      rewrite (Rplus_comm (INR n)).
      apply Rplus_le_lt_compat ; auto.
      rewrite INR_R1. apply Rge_le. apply Pow2_lemma2.
  Qed.

  Lemma up_Nested_interval : forall E x y n , x <= y -> fst (Nested_interval E x y n) <= snd (Nested_interval E x y n).
  Proof.
    intros.
    induction n.
    - simpl. auto.
    - remember (Nested_interval E x y n) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 ) ) = Nested_interval E x y (S n)).
      { simpl. subst. reflexivity. }
      rewrite <- H0.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2)  == r).
        { apply Rif_left. auto. }
        assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0  == (r + r0) / 2).
        { apply Rif_left. auto. }
        simpl. rewrite H2.
        rewrite H3. apply Rle_div2. auto.
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == (r + r0) / 2).
        { apply Rif_right. auto. }
        assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0 == r0).
        { apply Rif_right. auto. }
        simpl. rewrite H2.
        rewrite H3. apply Rge_div2. auto.

  Qed.

  Lemma eq_Nested_interval : forall E x y n , x == y -> fst (Nested_interval E x y n) == snd (Nested_interval E x y n).
  Proof.
    intros.
    induction n.
    - simpl. auto.
    - remember (Nested_interval E x y n) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 )) = Nested_interval E x y (S n)).
      { simpl. subst. reflexivity. }
      rewrite <- H0.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2)  == r).
        { apply Rif_left. auto. }
        assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0  == (r + r0) / 2).
        { apply Rif_left. auto. }
        simpl. rewrite H2.
        rewrite H3. rewrite IHn. unfold Rdiv.
        rewrite Rmult_plus_distr_r.
        rewrite <- (double_var r0). reflexivity.
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == (r + r0) / 2).
        { apply Rif_right. auto. }
        assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0 == r0).
        { apply Rif_right. auto. }
        simpl. rewrite H2.
        rewrite H3. rewrite IHn. unfold Rdiv.
        rewrite Rmult_plus_distr_r.
        rewrite <- (double_var r0). reflexivity.
  Qed.

  Lemma sub_Nested_interval : forall E x y n , x <= y -> snd (Nested_interval E x y n) - fst(Nested_interval E x y n) <= (y - x) / (2 ^ n).
  Proof.
    intros.
    induction n.
    - simpl. right. unfold Rdiv. rewrite <- Rmult_1_r at 2.
      rewrite Rmult_assoc. rewrite (Rmult_comm 1). rewrite Rinv_l.
      + rewrite Rmult_1_r. reflexivity.
      + apply R1_neq_R0.
    - rewrite <- Nat.add_1_r.
      rewrite Rdef_pow_add.
      unfold Rdiv.
      assert (forall n : nat , ~ 2 ^ n == 0).
      { intros.
        intro.
        apply (Rlt_irrefl 0).
        rewrite <- H0 at 2.
        apply Pow2_lemma1.
      }
      rewrite Rinv_mult_distr ; auto.
      rewrite <- Rmult_assoc.
      apply Rle_trans with ((snd (Nested_interval E x y n) - fst (Nested_interval E x y n)) * (/ 2 ^ 1)%R).
      + rewrite Nat.add_1_r.  unfold pow. rewrite Rmult_1_r.
        simpl.
        remember (snd (Nested_interval E x y n)) as r0.
        remember (fst (Nested_interval E x y n)) as r.
        destruct (classic (is_upper_bound E ((r + r0) / 2))).
        * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2)  == r).
          { apply Rif_left. auto. }
          assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0  == (r + r0) / 2).
          { apply Rif_left. auto. }
          simpl. rewrite H2.
          rewrite H3. apply (Rmult_le_r _ _ 2).
          ++ apply Rlt_0_2.
          ++ unfold Rdiv , Rminus.
             rewrite Rmult_plus_distr_r. rewrite <- Ropp_mult_distr_l.
             rewrite !Rmult_assoc.
             assert (~ 2 == 0).
             { specialize (H0 1%nat). unfold pow in H0. rewrite Rmult_1_r in H0. auto. }
             rewrite !Rinv_l ; auto. rewrite Rmult_plus_distr_l.
             rewrite !Rmult_1_r.
             rewrite Ropp_plus_distr.
             right. rewrite Rplus_assoc. rewrite Rplus_comm.
             rewrite <- Rplus_assoc. rewrite Rplus_assoc.
             rewrite Rplus_opp_l. rewrite Rplus_0_r. reflexivity.
        * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == (r + r0) / 2).
          { apply Rif_right. auto. }
          assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0 == r0).
          { apply Rif_right. auto. }
          simpl. rewrite H2.
          rewrite H3. apply (Rmult_le_r _ _ 2).
          ++ apply Rlt_0_2.
          ++ unfold Rdiv , Rminus.
             rewrite Rmult_plus_distr_r. rewrite <- Ropp_mult_distr_l.
             rewrite !Rmult_assoc.
             assert (~ 2 == 0).
             { specialize (H0 1%nat). unfold pow in H0. rewrite Rmult_1_r in H0. auto. }
             rewrite !Rinv_l ; auto. rewrite Rmult_plus_distr_l.
             rewrite !Rmult_1_r.
             rewrite Ropp_plus_distr.
             right.
             rewrite Rplus_assoc. rewrite Rplus_comm.
             rewrite <- Rplus_assoc. rewrite Rplus_assoc.
             rewrite Rplus_opp_l. rewrite Rplus_0_r. reflexivity.

      + apply Rmult_le_compat_r ; auto.
        left. apply Rinv_0_lt_compat.
        unfold pow. rewrite Rmult_1_r. apply Rlt_0_2.
  Qed.

  Lemma Left_upper_Nested_interval : forall E x y n1 n2 , x <= y ->
      (n1 <= n2)%nat -> (Left_Nested_interval E x y n1) <= (Left_Nested_interval E x y n2).
  Proof.
    intros.
    induction H0.
    - right. reflexivity.
    - apply Rle_trans with (Left_Nested_interval E x y m) ; auto.
      clear IHle.
      unfold Left_Nested_interval.
      remember (Nested_interval E x y m) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 ) ) = Nested_interval E x y (S m)).
      { simpl. subst. reflexivity. }
      rewrite <- H1.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == r).
          { apply Rif_left. auto. }
          simpl.
          rewrite H3. apply Rle_refl.
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == (r + r0) / 2).
          { apply Rif_right. auto. }
          simpl.
          rewrite H3. apply Rle_div2. subst. apply up_Nested_interval. auto.
  Qed.

  Lemma Right_lower_Nested_interval : forall E x y n1 n2, x <= y ->
      (n1 <= n2)%nat -> Right_Nested_interval E x y n2 <= Right_Nested_interval E x y n1.
  Proof.
    intros.
    induction H0.
    - right. reflexivity.
    - apply Rle_trans with (Right_Nested_interval E x y m) ; auto.
      clear IHle.
      unfold Right_Nested_interval.
      remember (Nested_interval E x y m) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 ) ) = Nested_interval E x y (S m)).
      { simpl. subst. reflexivity. }
      rewrite <- H1.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
        * assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0  == ((r + r0) / 2)).
          { apply Rif_left. auto. }
          simpl.
          rewrite H3. apply Rge_div2. subst. apply up_Nested_interval. auto.
        * assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0  == r0).
          { apply Rif_right. auto. }
          simpl.
          rewrite H3. apply Rle_refl.
  Qed.

  Lemma Left_sub_Nested_interval : forall E x y n1 n2 , x <= y -> (n1 <= n2)%nat ->
      Rabs((Left_Nested_interval E x y n1) - (Left_Nested_interval E x y n2)) <= (y - x) / (2 ^ n1).
  Proof.
    intros.
    rewrite Rabs_Rminus.
    pose proof (Left_upper_Nested_interval E _ _ _ _ H H0).
    destruct H1.
    - apply Rpositive_gt_0 in H1.
      rewrite <- Rpositive_gt_0 in H1.
      rewrite Rabs_positive ; auto.
      apply Rle_trans with (Right_Nested_interval E x y n1 - Left_Nested_interval E x y n1).
      + apply Rle_Rle_minus.
        * apply Rle_refl.
        * apply Rle_trans with (Right_Nested_interval E x y n2).
          ++ apply up_Nested_interval ; auto.
          ++ apply Right_lower_Nested_interval ; auto.
      + apply sub_Nested_interval ; auto.
    - rewrite (Rminus_diag_eq (Left_Nested_interval E x y n2)).
      + rewrite Rabs_zero.
        apply Rmult_le_divr.
        * apply Rinv_0_lt_compat.
          apply Pow2_lemma1.
        * unfold Rdiv. rewrite Rmult_0_l.
          apply Rle_Rminus.
          rewrite Rplus_0_l.
          auto.
      + symmetry. auto.
  Qed.

  Lemma Right_sub_Nested_interval : forall E x y n1 n2, x <= y -> (n1 <= n2)%nat ->
    Rabs((Right_Nested_interval E x y n1) - (Right_Nested_interval E x y n2)) <= (y - x) / (2 ^ n1).
  Proof.
    intros.
    pose proof (Right_lower_Nested_interval E _ _ _ _ H H0).
    destruct H1.
    - apply Rpositive_gt_0 in H1.
      rewrite <- Rpositive_gt_0 in H1.
      rewrite Rabs_positive ; auto.
      apply Rle_trans with (Right_Nested_interval E x y n1 - Left_Nested_interval E x y n1).
      + apply Rle_Rle_minus.
        * apply Rle_trans with (Left_Nested_interval E x y n2).
          ++ apply Left_upper_Nested_interval ; auto.
          ++ apply up_Nested_interval ; auto.
        * apply Rle_refl.
      + apply sub_Nested_interval ; auto.
    - rewrite (Rminus_diag_eq (Right_Nested_interval E x y n1)).
      + rewrite Rabs_zero.
        apply Rmult_le_divr.
        * apply Rinv_0_lt_compat.
          apply Pow2_lemma1.
        * unfold Rdiv. rewrite Rmult_0_l.
          apply Rle_Rminus.
          rewrite Rplus_0_l.
          auto.
      + symmetry. auto.
  Qed.

  Lemma Right_pro : forall E x y n , is_upper_bound E y -> is_upper_bound E (Right_Nested_interval E x y n).
  Proof.
    intros.
    induction n.
    - apply H.
    - unfold Right_Nested_interval in *.
      remember (Nested_interval E x y n) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 )) = Nested_interval E x y (S n)).
      { simpl. subst. reflexivity. }
      rewrite <- H0.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0 == ((r + r0) / 2)).
        { apply Rif_left. auto. }
        simpl. hnf. intros.
        rewrite H2. apply H1. auto.
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0 == r0).
        { apply Rif_right. auto. }
        simpl. hnf. intros.
        rewrite H2. apply IHn. auto.
  Qed.

  Lemma Left_pro : forall (E : R -> Prop)( x y : R) , E x -> (forall n , exists x0 , (E x0 /\ (Left_Nested_interval E x y n) <= x0)).
  Proof.
    intros.
    induction n.
    - exists x. split ; auto. right. reflexivity.
    - destruct IHn , H0.
      unfold Left_Nested_interval in *.
      remember (Nested_interval E x y n) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 )) = Nested_interval E x y (S n)).
      { simpl. subst. reflexivity. }
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == r).
        { apply Rif_left. auto. }
        exists x0. split ; auto.
        rewrite <- H2. simpl. rewrite H4. auto.
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == (r + r0) / 2).
        { apply Rif_right. auto. }
        apply not_all_ex_not in H3. destruct H3.
        exists x1.
        apply not_imply_elim in H3 as goal.
        apply not_imply_elim2 in H3.
        split;  auto.
        rewrite <- H2. simpl. rewrite H4.
        left.
        apply Rnot_le_lt in H3. auto.
  Qed.

  Lemma Right_eq_Nested_interval : forall E x y n, x == y ->
        Right_Nested_interval E x y n == y.
  Proof.
    intros.
    induction n.
    - reflexivity.
    - unfold Right_Nested_interval in *.
      pose proof (eq_Nested_interval E _ _ n H).
      remember (Nested_interval E x y n) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 )) = Nested_interval E x y (S n)).
      { simpl. subst. reflexivity. }
      rewrite <- H1.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2) r0  == ((r + r0) / 2)).
          { apply Rif_left. auto. }
          simpl.
          rewrite H3. rewrite H0 , <- IHn.
          unfold Rdiv.
          rewrite Rmult_plus_distr_r.
          rewrite <- (double_var r0). reflexivity.
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) ((r + r0) / 2)  r0 == r0).
          { apply Rif_right. auto. }
          simpl.
          rewrite H3. auto.
  Qed.

  Lemma Left_eq_Nested_interval : forall E x y n, x == y ->
        Left_Nested_interval E x y n == x.
  Proof.
    intros.
    induction n.
    - reflexivity.
    - unfold Left_Nested_interval in *.
      pose proof (eq_Nested_interval E _ _ n H).
      remember (Nested_interval E x y n) as p.
      remember (fst p) as r.
      remember (snd p) as r0.
      assert (((Rif (is_upper_bound  E ((r + r0)/2)) r ((r + r0) / 2)),(Rif (is_upper_bound  E ((r + r0)/2)) ((r + r0) / 2) r0 )) = Nested_interval E x y (S n)).
      { simpl. subst. reflexivity. }
      rewrite <- H1.
      destruct (classic (is_upper_bound E ((r + r0) / 2))).
      * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == r ).
          { apply Rif_left. auto. }
          simpl.
          rewrite H3.  auto.
     * assert (Rif (is_upper_bound E ((r + r0) / 2)) r ((r + r0) / 2) == ((r + r0) / 2)).
          { apply Rif_right. auto. }
          simpl.
          rewrite H3. rewrite H0 , <- IHn.
          unfold Rdiv.
          rewrite Rmult_plus_distr_r.
          rewrite <- (double_var r0). symmetry. auto.
  Qed.

  Lemma INZ_IZN_LOW : forall z : Z , (z <= Z.of_nat (Z.to_nat z))%Z.
  Proof.
    intros.
    destruct (Z_lt_le_dec z 0).
    - apply Z.le_trans with 0%Z.
      + apply Z.lt_le_incl. auto.
      + apply Zle_0_nat.
    - rewrite Z2Nat.id ; auto.
      apply Z.le_refl.
  Qed.

  Theorem eps_gt_2n :forall eps : R , eps > R0 -> exists n : nat , 1 / 2 ^ n < eps.
  Proof.
     intros.
     assert (1 > R0).
     { apply R1_gt_R0.
     }
     apply Rpositive_gt_0 in H.
     apply Rpositive_gt_0 in H0.
     pose proof (R_Archimedian' eps 1 H H0).
     destruct H1.
     rewrite <- IZR_Q in H1.
     remember (Z.to_nat x) as x0.
     apply Rpositive_gt_0 in H.
     apply Rpositive_gt_0 in H0.
     assert (IZR x == INR x0).
     { rewrite INR_IZR_INZ. subst x0.
       rewrite Z2Nat.id. reflexivity.
       apply NNPP.
       intro.
       apply Znot_le_gt in H2.
       apply Z.gt_lt in H2.
       apply IZR_lt in H2.
       rewrite IZR_R0 in H2.
       apply Rmult_lt_r with (r3 := eps) in H2 ; auto.
       rewrite Rmult_0_l in H2.
       apply Rlt_irrefl with (INR 1).
       apply Rlt_trans with (R0) ; auto.
       apply Rlt_trans with (IZR x * eps) ; auto.
     }
     rewrite H2 in H1.
     exists x0.
     apply Rmult_lt_divr.
     - apply Rlt_le_trans with 1 ; auto.
       apply Rge_le. apply Pow2_lemma2.
     - apply Rlt_trans with (INR x0 * eps) ; auto.
       rewrite (Rmult_comm eps (2 ^ x0)).
       apply Rmult_lt_r ; auto.
       apply Pow2_lemma3.
  Qed.

  Theorem Rabs_pos : forall r1 : R , (r1 >= 0) -> Rabs r1 == r1.
  Proof.
    intros.
    destruct H.
    - apply Rabs_positive. apply Rpositive_gt_0. auto.
    - rewrite H. apply Rabs_zero.
  Qed.

  Theorem Rabs_neg : forall r1 : R , (r1 <= 0) -> Rabs r1 == (- r1).
  Proof.
    intros.
    destruct H.
    - apply Rabs_negative. apply Rnegative_lt_0. auto.
    - rewrite H. rewrite Ropp_0. apply Rabs_zero.
  Qed.

  Theorem Req_same : forall r1 r2 : R , r1 == r2 <-> forall eps : R , eps > R0 -> Rabs(r1 - r2) < eps.
  Proof.
    intros.
    split; intros ; subst ; try (reflexivity).
    - unfold Rminus. rewrite H.
      rewrite Rminus_diag_eq.
      + rewrite Rabs_zero. auto.
      + reflexivity.
    - apply NNPP.
      intro.
      apply Rdichotomy in H0.
      destruct H0.
      + apply Rlt_neg_eqb in H0.
        assert (r1 - r2 <= R0). { auto with real. }
        apply Rlt_neg_eqb in H0. apply Rlt_pos_eqb in H0.
        apply eps_gt_2n in H0.
        destruct H0.
        apply (Rlt_irrefl (1 / (2 ^ x))).
        apply Rlt_trans with (Rabs (r1 - r2)) ; auto.
        rewrite (Rabs_neg (r1 - r2)) ; auto.
        rewrite Ropp_minus_distr'. auto.
        apply H.
        apply Rmult_gt_divr.
        * apply Pow2_lemma1.
        * rewrite Rmult_0_l. apply R1_gt_R0.
     +  apply Rlt_pos_eqb in H0.
        assert (r1 - r2 >= R0). { apply Rle_ge. auto with real. }
        apply eps_gt_2n in H0.
        destruct H0.
        apply (Rlt_irrefl (1 / (2^ x))).
        apply Rlt_trans with (r1 - r2) ; auto.
        rewrite <- (Rabs_pos (r1 - r2)) ; auto.
        apply H.
        apply Rmult_gt_divr.
        * apply Pow2_lemma1.
        * rewrite Rmult_0_l. apply R1_gt_R0.
  Qed.

  Theorem trible_var : forall r : R , r * INR 3 == r + r + r.
  Proof.
    intros.
    assert (3 = 1 + 1 + 1)%nat. { omega. }
    rewrite H.
    rewrite ! plus_INR.
    rewrite INR_R1.
    rewrite !Rmult_plus_distr_l.
    rewrite Rmult_1_r. reflexivity.
  Qed.

  Theorem trible_var' : forall r : R , r == r / INR 3 + r / INR 3 + r / INR 3.
  Proof.
    intros.
    rewrite <- !Rdiv_plus_distr.
    rewrite <- trible_var.
    unfold Rdiv. rewrite Rmult_assoc.
    rewrite Rinv_r ; auto with real.
    rewrite Rmult_1_r. reflexivity.
  Qed.

  Theorem completeness :
    forall E:R -> Prop,
      bound E -> (exists x : R, E x) -> exists m:R , is_lub E m .
  Proof.
    pose proof CC_sufficiency.
    intros.
    destruct H0 , H1.
    set (Left_Nested_interval E x0 x).
    set (Right_Nested_interval E x0 x).
    assert (R_seq (fun n r1 => r n == r1)).
    { split.
      - intros. exists (r n). reflexivity.
      - intros. rewrite <- H2 , <- H3. reflexivity.
      - intros. hnf. intros.
        rewrite H2. reflexivity.
    }
    set (Rseq_intro _ H2).
    assert (R_seq (fun n r1 => r0 n == r1)).
    { split.
      - intros. exists (r0 n). reflexivity.
      - intros. rewrite <- H4 , <- H3. reflexivity.
      - intros. hnf. intros.
        rewrite H3. reflexivity.
    }
    set (Rseq_intro _ H3).
    assert (Cauchy_of_R r1).
    { hnf. intros.
      assert (x0 <= x).
      {  apply H0. auto. }
      destruct H5.
      - assert (~ x - x0 == 0).
        { intro.
          apply Rgt_minus in H5.
          apply (Rlt_irrefl 0).
          rewrite <- H6 at 2.
          auto.
        }
        apply Rgt_minus in H5.
        pose proof (Rdiv_lt_0_compat _ _ H4 H5).
        apply Rinv_0_lt_compat in  H7. unfold Rdiv in H7.
        apply Rinv_neq_0_compat in H6 as goal.
        assert (H' : ~ Eps == 0).
        { intro. apply (Rlt_irrefl 0). rewrite <- H8 at 2. auto. }
        rewrite Rinv_mult_distr in H7 ; auto.
        rewrite Rinv_involutive in H7 ; auto.
        rewrite Rmult_comm in H7.
        pose proof (R_Archimedian'' _ H7).
        destruct H8.
        exists (Z.to_nat x1).
        intros.
        rewrite Rminus_0_r in H8. rewrite <- IZR_Q in H8.
        simpl in H12 , H11.
        rewrite <- H11 , <- H12.
        subst r.
        assert (n >= m \/ n <= m)%nat. { omega. }
        destruct H13.
        + apply Rle_lt_trans with ((x - x0) / 2 ^ m).
          * rewrite Rabs_Rminus. apply Left_sub_Nested_interval ; auto.
          * apply Rmult_lt_divr.
            apply Pow2_lemma1.
            apply Rmult_lt_divr in H8 ; auto.
            apply Rlt_trans with ((IZR x1) * Eps) ; auto.
            rewrite Rmult_comm.
            apply Rmult_lt_compat_l ; auto.
            apply Rle_lt_trans with (INR m).
            rewrite INR_IZR_INZ.
            apply IZR_le.
            apply inj_ge in H10.
            apply Z.ge_le in H10.
            apply Z.le_trans with (Z.of_nat (Z.to_nat x1)) ; auto.
            apply INZ_IZN_LOW.
            apply Pow2_lemma3.
        + apply Rle_lt_trans with ((x - x0) / 2 ^ n).
          * apply Left_sub_Nested_interval ; auto.
          * apply Rmult_lt_divr.
            apply Pow2_lemma1.
            apply Rmult_lt_divr in H8 ; auto.
            apply Rlt_trans with ((IZR x1) * Eps) ; auto.
            rewrite Rmult_comm.
            apply Rmult_lt_compat_l ; auto.
            apply Rle_lt_trans with (INR n).
            rewrite INR_IZR_INZ.
            apply IZR_le.
            apply inj_ge in H9.
            apply Z.ge_le in H9.
            apply Z.le_trans with (Z.of_nat (Z.to_nat x1)) ; auto.
            apply INZ_IZN_LOW.
            apply Pow2_lemma3.
      - exists O.
        intros.
        simpl in H8 , H9.
        pose proof (Left_eq_Nested_interval E x0 x).
        subst r.
        rewrite (H10 n H5) in H8.
        rewrite (H10 m H5) in H9.
        rewrite <- H9 , <- H8.
        rewrite Rminus_diag_eq ; try (reflexivity).
        rewrite Rabs_zero. auto.
    }
    assert (Cauchy_of_R r2).
    { hnf. intros.
      assert (x0 <= x).
      {  apply H0. auto. }
      destruct H6.
      - assert (~ x - x0 == 0).
        { intro.
          apply Rgt_minus in H6.
          apply (Rlt_irrefl 0).
          rewrite <- H7 at 2.
          auto.
        }
        apply Rgt_minus in H6.
        pose proof (Rdiv_lt_0_compat _ _ H5 H6).
        apply Rinv_0_lt_compat in  H8. unfold Rdiv in H8.
        apply Rinv_neq_0_compat in H7 as goal.
        assert (H' : ~ Eps == 0).
        { intro. apply (Rlt_irrefl 0). rewrite <- H9 at 2. auto. }
        rewrite Rinv_mult_distr in H8 ; auto.
        rewrite Rinv_involutive in H8 ; auto.
        rewrite Rmult_comm in H8.
        pose proof (R_Archimedian'' _ H8).
        destruct H9.
        exists (Z.to_nat x1).
        intros.
        rewrite Rminus_0_r in H9. rewrite <- IZR_Q in H9.
        simpl in H13 , H12.
        rewrite <- H12 , <- H13.
        subst r0.
        assert (n >= m \/ n <= m)%nat. { omega. }
        destruct H14.
        + apply Rle_lt_trans with ((x - x0) / 2 ^ m).
          * rewrite Rabs_Rminus. apply Right_sub_Nested_interval ; auto.
          * apply Rmult_lt_divr.
            apply Pow2_lemma1.
            apply Rmult_lt_divr in H9 ; auto.
            apply Rlt_trans with ((IZR x1) * Eps) ; auto.
            rewrite Rmult_comm.
            apply Rmult_lt_compat_l ; auto.
            apply Rle_lt_trans with (INR m).
            rewrite INR_IZR_INZ.
            apply IZR_le.
            apply inj_ge in H11.
            apply Z.ge_le in H11.
            apply Z.le_trans with (Z.of_nat (Z.to_nat x1)) ; auto.
            apply INZ_IZN_LOW.
            apply Pow2_lemma3.
        + apply Rle_lt_trans with ((x - x0) / 2 ^ n).
          * apply Right_sub_Nested_interval ; auto.
          * apply Rmult_lt_divr.
            apply Pow2_lemma1.
            apply Rmult_lt_divr in H9 ; auto.
            apply Rlt_trans with ((IZR x1) * Eps) ; auto.
            rewrite Rmult_comm.
            apply Rmult_lt_compat_l ; auto.
            apply Rle_lt_trans with (INR n).
            rewrite INR_IZR_INZ.
            apply IZR_le.
            apply inj_ge in H10.
            apply Z.ge_le in H10.
            apply Z.le_trans with (Z.of_nat (Z.to_nat x1)) ; auto.
            apply INZ_IZN_LOW.
            apply Pow2_lemma3.
      - exists O.
        intros.
        simpl in H9 , H10.
        pose proof (Right_eq_Nested_interval E x0 x).
        subst r0.
        rewrite (H11 n H6) in H9.
        rewrite (H11 m H6) in H10.
        rewrite <- H9 , <- H10.
        rewrite Rminus_diag_eq ; try (reflexivity).
        rewrite Rabs_zero. auto.
    }
    apply H in H4.
    apply H in H5.
    destruct H4 , H5.
    assert (x1 == x2).
    { apply Req_same.
      intros.
      hnf in H4 , H5.
      pose proof Rabs_triangle.
      assert (x0 <= x). { apply H0. auto. }
      destruct H8.
      - rewrite (trible_var' eps).
        apply Rdiv_lt_0_compat with (b := INR 3) in H6 as goal ; auto with real.
        apply Rlt_Rminus in H8.
        apply Rdiv_lt_0_compat with (b := x - x0) in goal as goal1 ; auto.
        apply eps_gt_2n in goal1 as goal2.
        destruct goal2.
        apply Rmult_gt_divr with (r3 := (x - x0)) in H9 ; auto.
        rewrite Rmult_comm in H9.
        unfold Rdiv in H9. rewrite <- Rmult_assoc in H9. rewrite Rmult_1_r in H9.
        specialize (H4 _ goal). specialize (H5 _ goal).
        destruct H4,H5.
        remember (max x3 (max x4 x5)) as m.
        assert (m >= x5)%nat. {subst m. apply le_trans with (max x4 x5) ; apply Nat.le_max_r. }
        assert (m >= x4)%nat. {subst m. apply le_trans with (max x4 x5). apply Nat.le_max_l. apply Nat.le_max_r. }
        specialize (H4 _ H11). specialize (H5 _ H10). clear H10 H11.
        assert (r m == r m). { reflexivity. }
        assert (r0 m == r0 m). { reflexivity. }
        specialize (H4 _ H10). specialize (H5 _ H11). clear H10 H11.
        assert (x1 - x2 == (x1 - r m) + (r m - x2)).
        { unfold RArith.Rminus.
          rewrite Rplus_assoc. rewrite <- (Rplus_assoc (- r m)).
          rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity.
        }
        rewrite H10.
        apply Rle_lt_trans with (Rabs (x1 - r m) + Rabs (r m - x2)).
        apply H7. rewrite Rplus_assoc. rewrite Rabs_Rminus in H4.
        apply Rplus_lt_compat ; auto. clear H10.
        assert (r m - x2 == (r m - r0 m) + (r0 m - x2)).
        { unfold RArith.Rminus.
          rewrite Rplus_assoc. rewrite <- (Rplus_assoc (- r0 m)).
          rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity.
        }
        rewrite H10.
        apply Rle_lt_trans with (Rabs (r m - r0 m) + Rabs (r0 m - x2)).
        apply H7.
        apply Rplus_le_lt_compat ; auto. clear H10 H7.
        subst r r0. unfold Right_Nested_interval , Left_Nested_interval.
        apply Rle_trans with ((x - x0) * (/ 2 ^ x3)%R) ; auto.
        + apply Rle_trans with ((x - x0) * (/ 2 ^ m)%R).
          * rewrite Rabs_Rminus.  rewrite Rabs_pos.
            apply (sub_Nested_interval E x0 x m) ; auto with real.
            apply Rge_minus. apply Rle_ge.
            apply up_Nested_interval. auto.
          * apply Rmult_le_l ; auto.
            apply Rinv_le_contravar.
            apply Rgt_lt. apply Pow2_lemma1.
            assert (m >= x3)%nat. { subst m. apply Nat.le_max_l. }
            clear H4 H5 Heqm.
            induction H7.
            ++ apply Rle_refl.
            ++ rewrite <- Nat.add_1_r. rewrite Rdef_pow_add.
               rewrite <- Rmult_1_r.
               apply Rmult_le_compat ; auto.
               left. apply Pow2_lemma1.
               left. auto with real.
               apply Rge_le. apply Pow2_lemma2.
        + left. auto.
      - apply Rdiv_lt_0_compat with (b := 2) in H6 as goal ; auto with real.
        specialize (H4 _ goal). specialize (H5 _ goal).
        destruct H4 , H5.
        remember (max x3 x4) as m.
        assert (m >= x3)%nat. { subst m. apply Nat.le_max_l. }
        assert (m >= x4)%nat. { subst m. apply Nat.le_max_r. }
        specialize (H4 _ H9 x0). specialize (H5 _ H10 x).
        apply (Left_eq_Nested_interval E _ _ m) in H8 as goal0.
        specialize (H4 goal0). clear goal0.
        apply (Right_eq_Nested_interval E _ _ m) in H8 as goal0.
        specialize (H5 goal0). clear goal0.
        assert (x1 - x2 == (x1 - x0) + (x - x2)).
        { rewrite H8. unfold RArith.Rminus.
          rewrite Rplus_assoc. rewrite <- (Rplus_assoc (-x)).
          rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity. }
        rewrite H11. apply Rle_lt_trans with (Rabs (x1 - x0) + Rabs (x - x2)).
        apply H7. rewrite Rabs_Rminus in H4.
        rewrite (double_var eps).
        apply Rplus_lt_compat; auto.
    }
    exists x1.
    split.
    + intro. intros. rewrite H6.
      apply NNPP.
      intro. apply Rnot_le_lt in H8.
      apply Rgt_minus in H8.
      apply Rdiv_lt_0_compat with (b := 2) in H8 as goal; auto with real.
      specialize (H5 _ goal).
      destruct H5.
      assert (x4 >= x4)%nat. {omega. }
      specialize (H5 _ H9). clear H9.
      assert (r0 x4 == r0 x4). { reflexivity. }
      specialize (H5 _ H9). clear H9.
      pose proof (Right_pro _ x0 _ x4 H0).
      apply (Rlt_irrefl x3).
      apply Rle_lt_trans with (r0 x4).
      - apply H9. auto.
      - apply Rabs_lt_iff in H5 ; auto.
        destruct H5.
        apply Rlt_Rminus_Rplus in H10.
        apply Rlt_trans with (x2 + (x3 - x2) / 2) ; auto.
        apply Rplus_lt_reg_l with (-x2).
        rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
        rewrite (Rplus_comm _ x3).
        assert (RArith.Rplus x3 (Ropp x2) == x3 - x2). { reflexivity. }
        rewrite H11.
        assert (x3 - x2 == (x3 - x2) * 1).
        { rewrite Rmult_1_r. reflexivity. }
        rewrite H12. clear H11 H12. unfold Rdiv.
        apply Rmult_lt_compat_l ; auto.
        rewrite <- Rinv_1 at 3.
        apply Rinv_lt_contravar ; auto with real.
        rewrite Rmult_1_l. auto with real.
    + intros. apply NNPP. intro. apply Rnot_le_lt in H8.
      apply Rgt_minus in H8.
      apply Rdiv_lt_0_compat with (b := 2) in H8 as goal; auto with real.
      specialize (H4 _ goal).
      destruct H4.
      assert (x3 >= x3)%nat. {omega. }
      specialize (H4 _ H9). clear H9.
      assert (r x3 == r x3). { reflexivity. }
      specialize (H4 _ H9). clear H9.
      pose proof (Left_pro E x0 x H1 x3).
      destruct H9 , H9.
      apply (Rlt_irrefl b).
      assert (x4 <= b). { apply H7. auto. }
      apply Rlt_le_trans with x4 ; auto.
      clear H11. apply Rlt_le_trans with (r x3) ; auto.
      apply Rabs_lt_iff in H4 ; auto.
      destruct H4.
      apply Rplus_lt_reg_r with (- x1).
      apply Rlt_trans with (- ((x1 - b) / 2)) ; auto.
      apply Ropp_lt_cancel.
      rewrite Ropp_involutive.
      assert (b + (-x1) == b - x1). { reflexivity. }
      rewrite H12. clear H12.
      rewrite Ropp_minus_distr'.
      unfold Rdiv.
      rewrite (double_var (x1 - b)) at 2.
      rewrite <- Rplus_0_r.
      apply Rplus_lt_compat_l. auto.
  Qed.

End CauchyR_complete.

Module CauchyAll: VIR_R_ALL.

Include CauchyR.
Module CauchyRSingle : VIR_R_SINGLETON CauchyR := CauchyR.Vex.
Include CauchyRSingle.
Include CauchyR_complete.

End CauchyAll.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Lists.List.
Inductive ty : Set :=
| base : ty
| arr : list ty -> ty -> ty.

Fixpoint ty_Prop (t : ty) : Prop :=
  match t with
  | base => False
  | arr ts t' =>
    (fix tys_Prop (ts : list ty) :=
       match ts with
       | nil => True
       | t'' :: ts' => ty_Prop t'' /\ tys_Prop ts'
       end) ts /\ ty_Prop t'
  end.

Inductive ty_Prop' : ty -> Prop :=
| base_Prop : ty_Prop' base
| arr_Prop : forall ts t,
    Forall ty_Prop' ts -> ty_Prop' t ->
    ty_Prop' (arr ts t).

Require Import
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Numbers.BinNums
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts.

Inductive ASN1_Simple : Set :=
| ASN_Boolean : ASN1_Simple (* Universal 1 *)
| ASN_Null : ASN1_Simple (* Universal 5 *)
| ASN_Integer : ASN1_Simple (* Universal 2 *)
| ASN_Enum : (* Universal 10 *)
    list nat (* Codes *)
    -> ASN1_Simple
| ASN_BitString : ASN1_Simple (* Universal 3 *)
| ASN_OctetString : ASN1_Simple (* Universal 4 *)
| ASN_NumericString : ASN1_Simple (* Universal 18*)
| ASN_PrintableString : ASN1_Simple (* Universal 19 *)
| ASN_IA5String : ASN1_Simple. (* Universal 22 *)

Inductive ASN1_Simple_Modifier : Set :=
| ASN_Size_Fixed : nat -> ASN1_Simple_Modifier
| ASN_Size_Range : nat -> nat -> ASN1_Simple_Modifier
| ASN_None : ASN1_Simple_Modifier.

Definition ASN1_Simple_denote (desc : ASN1_Simple) : Set :=
  match desc with
  | ASN_Boolean => bool
  | ASN_Null => unit
  | ASN_Integer => Z
  | ASN_Enum n => Fin.t (List.length n)
  | ASN_BitString => list bool
  | ASN_OctetString => list (word 8)
  | ASN_NumericString => string
  | ASN_PrintableString => string
  | ASN_IA5String => string
  end.

Inductive ASN1_Structured : Set :=
| ASN_Sequence : list ASN1_Sequence_Element -> ASN1_Structured
| ASN_Choice : list ASN1_Type -> ASN1_Structured
| ASN_Sequence_Of : ASN1_Type -> ASN1_Structured

with ASN1_Sequence_Element : Set :=
     | Normal_Sequence_Element :
         ASN1_Type -> ASN1_Sequence_Element
     | Optional_Sequence_Element :
         ASN1_Type -> ASN1_Sequence_Element
     | Default_Sequence_Element :
         forall (desc : ASN1_Simple),
           ASN1_Simple_Modifier
           -> ASN1_Simple_denote desc
           -> ASN1_Sequence_Element

with ASN1_Type : Set :=
     | ASN_Simple : ASN1_Simple -> ASN1_Simple_Modifier -> ASN1_Type
     | ASN_Structured : ASN1_Structured -> ASN1_Type.

Coercion ASN_Structured : ASN1_Structured >-> ASN1_Type.

Definition ASN_Simple_UnModified (desc : ASN1_Simple) : ASN1_Type :=
  ASN_Simple desc ASN_None.
Coercion ASN_Simple_UnModified : ASN1_Simple >-> ASN1_Type.

Fixpoint ASN1_Structured_denote (desc : ASN1_Structured) : Set :=
  match desc with
  | ASN_Sequence l =>
    (fix ASN1_Sequence_denote (descs : list ASN1_Sequence_Element) {struct descs} : Set :=
       match descs with
       | Normal_Sequence_Element desc :: descs' =>
         (ASN1_Type_denote desc) * (ASN1_Sequence_denote descs')
       | Optional_Sequence_Element desc :: descs' =>
         option (ASN1_Type_denote desc) * (ASN1_Sequence_denote descs')
       | Default_Sequence_Element desc _ _ :: descs' =>
         (ASN1_Simple_denote desc) * (ASN1_Sequence_denote descs')
       | [ ] => unit
       end)%type l
  | ASN_Choice l =>
    (fix ASN1_Choice_denote (descs : list ASN1_Type) {struct descs} : Set :=
       match descs with
       | desc :: descs' => (ASN1_Type_denote desc) + (ASN1_Choice_denote descs')
       | [ ] => unit
       end)%type l
  | ASN_Sequence_Of desc' => list (ASN1_Type_denote desc')
  end

with ASN1_Type_denote (desc : ASN1_Type) : Set :=
       match desc with
       | ASN_Simple desc' mod => ASN1_Simple_denote desc'
       | ASN_Structured desc' => ASN1_Structured_denote desc'
       end.

Section ASN1_Format.

  Require Import
          Bedrock.Word.

  Require Import
          Fiat.Common.EnumType
          Fiat.Common.BoundedLookup
          Fiat.Narcissus.Formats.WordOpt
          Fiat.Narcissus.Formats.EnumOpt
          Fiat.Narcissus.Formats.Bool
          Fiat.Narcissus.Formats.NatOpt
          Fiat.Narcissus.Formats.FixStringOpt
          Fiat.Narcissus.Common.ComposeOpt.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Import Coq.Vectors.Vector.VectorNotations.

  Definition Tag_Classes :=
    ["Universal"; "Application"; "Context-Specific"; "Private"]%string.

  Definition Tag_Class_Codes :=
    [WO~0~0; WO~0~1; WO~1~0; WO~1~1].

  Definition Tag_Class := EnumType Tag_Classes.

  Definition ASN1_Format_Tag
           (tag : BoundedString Tag_Classes)
           (primitive : bool)
           (identifier : nat)
    : CacheFormat -> Comp (B * CacheFormat) :=
          format_enum Tag_Class_Codes (ibound (indexb tag))
    ThenC format_word (WS primitive WO)
    ThenC (If (NPeano.ltb identifier 31) Then
              format_nat 5 identifier
              Else (format_nat 31 identifier
              ThenC (* TODO: Put actual high-tag formating rule here. *)
              format_nat 5 identifier))
    DoneC.

  Definition ASN1_Format_Definite_Length
             (length : nat)
    : CacheFormat -> Comp (B * CacheFormat) :=
    If (NPeano.ltb length 127) Then
       format_nat 8 length
    Else
       (format_word WO~1 (* Set highest bit to 1 *)
       ThenC format_nat (S (NPeano.div (NPeano.log2 length) 8)) 7
       ThenC format_nat length (S (NPeano.div (NPeano.log2 length) 8) * 8))
       DoneC.

  Fixpoint ASN1_Format_Simple_DER
         (desc : ASN1_Simple)
  : ASN1_Simple_denote desc -> CacheFormat -> Comp (B * CacheFormat) :=
  match desc return
        ASN1_Simple_denote desc
        -> CacheFormat
        -> Comp (B * CacheFormat) with

  | ASN_Boolean =>
    fun data =>
          ASN1_Format_Tag ``"Universal" false 1
    ThenC ASN1_Format_Definite_Length 1
    ThenC format_word (if data then natToWord 8 255 else natToWord 8 0)
    DoneC

  | ASN_Null =>
    fun data =>
          ASN1_Format_Tag ``"Universal" false 5
    ThenC ASN1_Format_Definite_Length 0
    DoneC

  | ASN_Integer => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_Enum n => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_BitString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_OctetString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_NumericString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_PrintableString => fun data => format_word (natToWord 1 10) (* TODO *)
  | ASN_IA5String =>
    fun data =>
          ASN1_Format_Tag ``"Universal" false 22
    ThenC ASN1_Format_Definite_Length (String.length data)
    ThenC format_string data
    DoneC
  end.

End ASN1_Format.

Arguments ASN1_Format_Definite_Length _ _ / . (* Always simplify this format*)
Arguments ASN1_Format_Tag _ _ / . (* Always simplify this format*)

Section ASN1_Decoder_Example.

  Require Import
          Fiat.Narcissus.Stores.EmptyStore
          Fiat.Narcissus.Automation.Solver
          Fiat.Narcissus.BinLib.AlignedByteString
          Fiat.Narcissus.BinLib.AlignWord
          Fiat.Narcissus.BinLib.AlignedDecoders.

  Instance ByteStringQueueMonoid : Monoid ByteString :=
    ByteStringQueueMonoid.

  Example Simple_Format : ASN1_Simple :=
    ASN_IA5String.

  Ltac normalize_Compose Monoid :=
    eapply SetoidMorphisms.refine_refineEquiv_Proper;
    [ unfold flip;
      repeat first
             [ etransitivity; [ apply refineEquiv_compose_compose with (monoid := Monoid) | idtac ]
             | etransitivity; [ apply refineEquiv_compose_Done with (monoid := Monoid) | idtac ]
             | apply refineEquiv_under_compose with (monoid := Monoid) ];
      intros; first [reflexivity | higher_order_reflexivity]
    | reflexivity | ].

  Add Parametric Morphism
      (E B : Type) (monoid : Monoid B)
    : (@compose E B monoid)
      with signature
      (pointwise_relation _ (@refine (B * E)))
        ==> (pointwise_relation _ (@refine (B * E)))
        ==> (@eq E)
        ==> (@refine (B * E))
        as refine_compose.
  Proof.
    unfold pointwise_relation, compose, Bind2; intros.
    setoid_rewrite H; setoid_rewrite H0; reflexivity.
  Qed.

  Lemma refine_compose_compose
     : forall (E B : Type) (monoid : Monoid B) (format1 format2 format3 : E -> Comp (B * E)) (ctx : E),
      refine (((format1 ThenC format2) ThenC format3) ctx)
             ((format1 ThenC format2 ThenC format3) ctx).
  Proof.
    unfold pointwise_relation; intros.
    apply refineEquiv_compose_compose.
  Qed.

  Lemma refine_ThenC_beta_reduce
    : forall (E B : Type) (monoid : Monoid B) (format1 format2 : E -> Comp (B * E)) (ctx : E),
      refine ((format1 ThenC (fun ctx' => format2 ctx')) ctx)
             ((format1 ThenC format2) ctx).
  Proof.
    intros; reflexivity.
  Qed.

  Lemma refine_If_Then_Else_beta_reduce
    : forall (E B : Type) (monoid : Monoid B) (format1 format2 : E -> Comp (B * E)) (ctx : E) b,
      refine ((If b Then format1 Else format2) ctx)
             (If b Then format1 ctx Else format2 ctx).
  Proof.
    intros; destruct b; reflexivity.
  Qed.

  Corollary AlignedFormatNat
            {numBytes}
    : forall (n : nat) ce ce' (c : _ -> Comp _) (v : Vector.t _ numBytes),
      refine (c (addE ce 8)) (ret (build_aligned_ByteString v, ce'))
      -> refine (((format_nat 8 (monoidUnit := ByteString_QueueMonoidOpt) n)
                    ThenC c) ce)
                (ret (build_aligned_ByteString (Vector.cons _ (natToWord 8 n) _ v), ce')).
  Proof.
    unfold format_nat; cbv beta; intros.
    rewrite <- AlignedFormatChar; eauto.
    reflexivity.
  Qed.

  Definition Variational_Vector
             {numBytesT numBytesE}
             (b : bool)
             (vT : Vector.t Core.char numBytesT)
             (vE : Vector.t Core.char numBytesE)
    : Vector.t Core.char (If b Then numBytesT Else numBytesE) :=
    match b return
          Vector.t Core.char (If b Then numBytesT Else numBytesE)
    with
    | true => vT
    | false => vE
    end.

  Lemma AlignedFormat_If_Then_Else
            {numBytesT numBytesE}
    : forall (b : bool) ctx ctxT ctxE
             (vT : Vector.t Core.char numBytesT)
             (vE : Vector.t Core.char numBytesE)
             (format1 format2 : CacheFormat -> Comp (_ * CacheFormat)),
      (b = true
       -> refine (format1 ctx) (ret (build_aligned_ByteString vT, ctxT)))
      -> (b = false
          -> refine (format2 ctx) (ret (build_aligned_ByteString vE, ctxE)))
      -> refine (If b Then (format1 ctx) Else (format2 ctx))
                (ret (build_aligned_ByteString (Variational_Vector b vT vE)

                      , If b Then ctxT Else ctxE)).
  Proof.
    destruct b; simpl; intros; eauto.
  Qed.

  Lemma build_aligned_ByteString_id {B}
    : forall ctx : B,
      refine (ret (ByteString_id, ctx))
             (ret (build_aligned_ByteString (Vector.nil _), ctx)).
  Proof.
    intros; replace ByteString_id
             with (build_aligned_ByteString (Vector.nil _)).
    reflexivity.
    eapply ByteString_f_equal;
      instantiate (1 := eq_refl _); reflexivity.
  Qed.

  (* We'll restrict this example to strings with fewer than 127 bytes. *)
  Definition Simple_Format_OK
             (t : ASN1_Simple_denote Simple_Format)
    := NPeano.Nat.ltb (String.length t) 127 = true.

  Lemma If_Then_Else_format_correct
      {A B}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_invT P /\ P_invE P))
      (monoid : Monoid B)
      (predicate predicateT predicateE : A -> Prop)
      (predicate_rest : A -> B -> Prop)
      (proj : A -> bool)
      (ICompb : B -> bool)
      (formatT : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeT : B -> CacheDecode -> option (A * B * CacheDecode))
      (formatE : A -> CacheFormat -> Comp (B * CacheFormat))
      (decodeE : B -> CacheDecode -> option (A * B * CacheDecode))
      (decodeT_pf :
         cache_inv_Property P P_invT
         -> CorrectDecoder
              cache monoid predicateT predicate_rest
              formatT decodeT P)
      (decodeE_pf :
         cache_inv_Property P P_invE
         -> CorrectDecoder
              cache monoid predicateE predicate_rest
              formatE decodeE P)
      (ICompb_OKT : forall data bin env xenv ext,
          predicateT data
          -> formatT data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = true)
      (ICompb_OKT' : forall data bin env xenv ext,
          ICompb bin = true
          -> decodeT bin env = Some (data, ext, xenv)
          -> proj data = true)
      (ICompb_OKE : forall data bin env xenv ext,
          predicateE data
          -> formatE data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = false)
      (ICompb_OKE' : forall data bin env xenv ext,
          ICompb bin = false
          -> decodeE bin env = Some (data, ext, xenv)
          -> proj data = false)
      (predicateT_OK : forall a, proj a = true
                                 -> (predicate a
                                     <-> predicateT a))
      (predicateE_OK : forall a, proj a = false
                                 -> (predicate a
                                 <-> predicateE a))
  : CorrectDecoder
      cache monoid
      (fun a => predicate a)
      predicate_rest
      (fun (data : A) (ctx : CacheFormat) =>
         (If (proj data)
            Then (formatT data ctx)
            Else (formatE data ctx))
      )%comp
      (fun (b' : B) (env : CacheDecode) =>
         If ICompb b' Then
            decodeT b' env
            Else
            decodeE b' env
      ) P.
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm pred_pm_rest com_pf.
    specialize (predicateT_OK data).
    specialize (predicateE_OK data).
    destruct (proj data); simpl in com_pf.
    - erewrite ICompb_OKT; eauto.
      simpl; eapply decodeT_pf; intuition eauto.
      intuition eauto.
    - erewrite ICompb_OKE; eauto.
      simpl; eapply decodeE_pf; intuition eauto.
      intuition eauto.
  }
  { intros.
    destruct (ICompb bin) eqn : IComp_v ; simpl in *.
    - rewrite (ICompb_OKT' _ _ _ _ _ IComp_v H1).
      pose proof H1.
      eapply decodeT_pf in H1; simpl in *; intuition eauto.
      destruct_ex; eexists _, _; intuition eauto.
      eapply predicateT_OK; try eassumption.
      erewrite ICompb_OKT'; eauto.
    - rewrite (ICompb_OKE' _ _ _ _ _ IComp_v H1).
      pose proof H1.
      eapply decodeE_pf in H1; intuition eauto.
      destruct_ex; eexists _, _; intuition eauto.
      eapply predicateE_OK; try eassumption.
      erewrite ICompb_OKE'; eauto.

  }
Qed.

  Definition Correct_simple_formatr
    : { simple_formatr : _ &
                         forall (t : ASN1_Simple_denote Simple_Format),
                           Simple_Format_OK t
                           -> refine (ASN1_Format_Simple_DER Simple_Format t ())
                     (ret (simple_formatr t)) }.
  Proof.
    simpl; eexists; intros.
    unfold format_nat at 1, format_enum; simpl.
    eapply SetoidMorphisms.refine_refineEquiv_Proper;
      [ unfold flip;
        repeat first
               [ etransitivity; [ apply refineEquiv_compose_compose with (monoid := ByteStringQueueMonoid) | idtac ]
               | etransitivity; [ apply refineEquiv_compose_Done with (monoid := ByteStringQueueMonoid) | idtac ]
               | apply refineEquiv_under_compose with (monoid := ByteStringQueueMonoid) ];
        intros; higher_order_reflexivity
      | reflexivity | ];
      rewrite refine_ThenC_beta_reduce.
    rewrite (@CollapseFormatWord _ test_cache); simpl; eauto.
    rewrite !refine_ThenC_beta_reduce.
    rewrite (@CollapseFormatWord _ test_cache); simpl; eauto.
    rewrite !refine_ThenC_beta_reduce.
    eapply (@AlignedFormatChar test_cache); eauto.
    rewrite refine_If_Then_Else_ThenC.
    eapply AlignedFormat_If_Then_Else; intros.
    eapply (@AlignedFormatNat _).
    eapply (@format_string_aligned_ByteString test_cache); eauto.
    apply build_aligned_ByteString_id.
    congruence.
    Grab Existential Variables.
    exact ().
    apply Vector.nil.
  Defined.

  Arguments natToWord : simpl never.

  Definition byte_aligned_simple_formatr
             (t :  ASN1_Simple_denote Simple_Format)
    := Eval simpl in (projT1 Correct_simple_formatr t).

  Print byte_aligned_simple_formatr.

  Definition Simple_Format_decoder
    : CorrectDecoderFor Simple_Format_OK (ASN1_Format_Simple_DER Simple_Format).
  Proof.
    start_synthesizing_decoder.
    normalize_compose ByteStringQueueMonoid.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    simpl; omega.
    decode_step idtac.
    intros; eapply If_Then_Else_format_correct.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    intros; eapply String_decode_correct.
  Abort.
  (*intros.

    decode_step idtac.
    decode_step idtac.
    eauto.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    auto with arith.
    auto with arith.
    simpl.
    decode_step idtac.

    auto with arith.
    auto with arith.
    intros. setoid_rewrite refine_If_Then_Else_ThenC.
    intros.

    intros; eauto using FixedList_predicate_rest_True.
    synthesize_cache_invariant.
    cbv beta; optimize_decoder_impl.
  Defined.

Definition SimpleDecoderImpl
    := Eval simpl in (projT1 Simple_Format_decoder).

  Ltac rewrite_DecodeOpt2_fmap :=
    set_refine_evar;
    progress rewrite ?BindOpt_map, ?DecodeOpt2_fmap_if,
    ?DecodeOpt2_fmap_if_bool;
    subst_refine_evar.

Definition ByteAligned_SimpleDecoderImpl {A}
           (f : _ -> A)
           n
  : {impl : _ & forall (v : Vector.t _ (3 + n)),
         f (fst SimpleDecoderImpl (build_aligned_ByteString v) ()) =
         impl v () }.
Proof.
  eexists _; intros.
  etransitivity.
  set_refine_evar; simpl.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecodeNat NoCache.test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecode2Char NoCache.test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  erewrite optimize_align_decode_list.
  rewrite Ifopt_Ifopt; simpl.
  etransitivity.
  eapply optimize_under_if_opt; simpl; intros.
  higher_order_reflexivity.
  reflexivity.
  Focus 2.
  clear H; intros.
  etransitivity.
  match goal with
    |- ?b = _ =>
    let b' := (eval pattern (build_aligned_ByteString v0) in b) in
    let b' := match b' with ?f _ => f end in
      eapply (@optimize_Guarded_Decode n0 _ 1 b')
  end.
  destruct n0 as [ | [ | ?] ]; intros; try omega.
  apply (@decode_word_aligned_ByteString_overflow NoCache.test_cache) with (sz := 1); auto.
  destruct n0 as [ | ?]; intros; try omega.
  higher_order_reflexivity.
  instantiate (1 := fun n1 v1 (cd0 : CacheDecode) =>
                      If NPeano.leb 1 n1 Then (Some ((Vector.hd (Guarded_Vector_split 1 n1 v1), @existT _ (Vector.t _) _ (Vector.tl (Guarded_Vector_split 1 n1 v1))), cd0)) Else None).
  simpl; find_if_inside; simpl; try reflexivity.
  pattern n0, v0; apply Vector.caseS; simpl; intros.
  unfold decode_word, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; reflexivity.
  subst_refine_evar; higher_order_reflexivity.
  higher_order_reflexivity.
Defined.

Definition ByteAligned_SimpleDecoderImpl' n :=
  Eval simpl in (projT1 (ByteAligned_SimpleDecoderImpl id n)). *)

End ASN1_Decoder_Example.

Section ASN1_Example.
  (* Suppose a company owns several sales outlets linked to a central *)
  (* warehouse where stocks are maintained and deliveries start from. The *)
  (* company requires that its protocol have the following features: *)
  (* 1) the orders are collected locally at the sales outlets ; *)
  (* 2) they are transmitted to the warehouse, where the delivery *)
  (*    procedure should be managed ; *)
  (* 3) an account of the delivery must be sent back to the sales outlets *)
  (*    for following through the client's order. *)
  (* Example taken from: http://www.itu.int/en/ITU-T/asn1/Pages/introduction.aspx. *)

  (* Item-code ::= NumericString(SIZE (7)) *)
  Definition ItemCode : ASN1_Type :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 7).

  (* Label ::= PrintableString(SIZE (1..30)) *)
  Definition Label : ASN1_Type :=
    ASN_Simple ASN_PrintableString (ASN_Size_Range 1 30).

  (* Quantity ::= CHOICE {
   unites        INTEGER,
   millimetres   INTEGER,
   milligrammes  INTEGER
} *)

  Definition Quantity : ASN1_Type :=
    ASN_Choice [ASN_Simple_UnModified ASN_Integer;
                  ASN_Simple_UnModified ASN_Integer;
                  ASN_Simple_UnModified ASN_Integer].

  (* Cents ::= INTEGER *)
  Definition Cents : ASN1_Type := ASN_Integer.

  (* Order-number ::= NumericString(SIZE (12)) *)
  Definition Order_Number : ASN1_Type :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 12).

  (* Delivery-line ::= SEQUENCE {item      Item-code,
                            quantity  Quantity *)
  Definition Delivery_Line : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element ItemCode;
                    Normal_Sequence_Element Quantity].

  (*Delivery-report ::= SEQUENCE {
  order-code  Order-number,
  delivery    SEQUENCE OF Delivery-line
} *)

  Definition Delivery_Report : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Number;
                    Normal_Sequence_Element (ASN_Structured (ASN_Sequence_Of Delivery_Line))].

  (* Date ::= NumericString(SIZE (8)) -- MMDDYYYY *)
  Definition Date : ASN1_Type  :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 8).

  (* default-country PrintableString ::= "France" *)
  Definition Default_Country : ASN1_Type_denote ASN_PrintableString := "France"%string.

  (* Client ::= SEQUENCE {
  name      PrintableString(SIZE (1..20)),
  street    PrintableString(SIZE (1..50)) OPTIONAL,
  postcode  NumericString(SIZE (5)),
  town      PrintableString(SIZE (1..30)),
  country   PrintableString(SIZE (1..20)) DEFAULT default-country
  } *)
  Definition Client : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 20));
                    Optional_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 50));
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 5));
                    Normal_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 30));
                    Default_Sequence_Element ASN_PrintableString (ASN_Size_Range 1 20) Default_Country].

  (* Card-type ::= ENUMERATED {
  cb(0), visa(1), eurocard(2), diners(3), american-express(4)} *)
  Definition Card_Type : ASN1_Type :=
    ASN_Enum [ 0; 1; 2; 3; 4].

  (* Credit-card ::= SEQUENCE {
  type         Card-type,
  number       NumericString(SIZE (20)),
  expiry-date  NumericString(SIZE (6))-- MMYYYY --
  }*)
  Definition Credit_Card : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Card_Type;
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 20));
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 6))
                 ].

  (* Payment-method ::= CHOICE {
  check        NumericString(SIZE (15)),
  credit-card Credit-card,
  cash         NULL
} *)
  Definition Payment_Method : ASN1_Type :=
    ASN_Choice [ASN_Simple ASN_NumericString (ASN_Size_Fixed 8);
                  Credit_Card;
                  ASN_Simple ASN_Null ASN_None].

  (* Order-header ::= SEQUENCE {
  number   Order-number,
  date     Date,
  client   Client,
  payment  Payment-method
} *)
  Definition Order_Header : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Number;
                    Normal_Sequence_Element Date;
                    Normal_Sequence_Element Client;
                    Normal_Sequence_Element Payment_Method].

  (* Item-code ::= NumericString(SIZE (7)) *)
  Definition Item_Code : ASN1_Type  :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 7).

  (* Order-line ::= SEQUENCE {
  item-code  Item-code,
  label      Label,
  quantity   Quantity,
  price      Cents
} *)
  Definition Order_Line : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Item_Code;
                    Normal_Sequence_Element Label;
                    Normal_Sequence_Element Quantity;
                    Normal_Sequence_Element Cents].

  (* Order ::= SEQUENCE {header  Order-header,
                    items   SEQUENCE OF Order-line
} *)
  Definition Order : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Header;
                    Normal_Sequence_Element (ASN_Sequence_Of Order_Line)].

  (*
PDU ::= CHOICE {
  question
    CHOICE {question1  Order,
            question2  Item-code,
            question3  Order-number,
            ...},
  answer
    CHOICE {answer1  Delivery-report,
            answer2  Quantity,
            answer3  Delivery-report,
            ...}
} *)

  Definition PDU : ASN1_Type :=
    ASN_Choice [ASN_Structured (ASN_Choice [Order; Item_Code; Order_Number]);
                  ASN_Structured (ASN_Choice [Delivery_Report; Quantity; Delivery_Report])
               ].

End ASN1_Example.


Require Export Groupoid Functor SetCategory NaturalTransformation ComputableCat.
Require Import Common (*Adjoint*).

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope morphism_scope.

Section FunctorFromGroupoid.
  Context `{IsTrunc 1 X}.
  Variable D : PreCategory.
  Variable objOf : X -> D.

  Let FunctorFromGroupoid_MorphismOf s d (m : Morphism (Groupoid X) s d)
  : Morphism D (objOf s) (objOf d)
    := match m with
         | idpath => Identity _
       end.

  Local Ltac t :=
    intros; simpl in *; path_induction; simpl; apply symmetry; auto with morphism.

  Lemma FunctorFromGroupoid_FCompositionOf s d d'
        (m1 : Morphism (Groupoid X) s d)
        (m2 : Morphism (Groupoid X) d d')
  : FunctorFromGroupoid_MorphismOf (m2 ∘ m1) =
    FunctorFromGroupoid_MorphismOf m2 ∘ FunctorFromGroupoid_MorphismOf m1.
  Proof.
    t.
  Defined.

  Lemma FunctorFromGroupoid_FIdentityOf x
  : FunctorFromGroupoid_MorphismOf (Identity x) = Identity (objOf x).
  Proof.
    t.
  Defined.

  Global Arguments FunctorFromGroupoid_FCompositionOf / .
  Global Arguments FunctorFromGroupoid_FIdentityOf / .
  Global Opaque FunctorFromGroupoid_FIdentityOf FunctorFromGroupoid_FCompositionOf.

  Definition FunctorFromGroupoid : Functor (Groupoid X) D
    := @Build_Functor (Groupoid X)
                      D
                      objOf
                      FunctorFromGroupoid_MorphismOf
                      FunctorFromGroupoid_FCompositionOf
                      FunctorFromGroupoid_FIdentityOf.
End FunctorFromGroupoid.

Section Obj.
  Context `{fs : Funext}.
  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Notation build_obj_functor_evar C D typ build :=
    (@Build_Functor C D
                    (fun C' : I => build (Object (Index2Cat C')) (typ C'))
                    (fun _ _ F => ObjectOf F)
                    (fun _ _ _ _ _ => idpath)
                    (fun _ => idpath)).

  Local Ltac build_obj_functor build :=
    let C := match goal with |- Functor ?C ?D => constr:(C) end in
    let D := match goal with |- Functor ?C ?D => constr:(D) end in
    let T := fresh in
    let t := fresh in
    evar (T : Type);
      cut T; subst T;
      [ intro t;
        exact (build_obj_functor_evar C D t build)
      | ];
      instantiate;
      typeclasses eauto.

  Definition SetObjectFunctor `{H0 : forall i : I, IsTrunc 0 (Index2Cat i)}
  : Functor (ComputableCat Index2Cat) SetCat.
  Proof.
    build_obj_functor BuildhSet.
  Defined.

  (** We need to force the shape of the computable cat, or else
      [PropObjectFunctor] and [PropMorphismFunctor] pick up different
      instances.  Pick this typeclass instance arbitrarily. *)

  Definition PropObjectFunctor `{H0 : forall i : I, IsHProp (Index2Cat i)}
  : Functor (@ComputableCat _ _ Index2Cat (fun _ _ => Functor_IsTrunc _ _)) PropCat.
  Proof.
    build_obj_functor hp.
  Defined.
End Obj.

Arguments SetObjectFunctor {_ _ _ _}.
Arguments PropObjectFunctor {_ _ _ _}.

Section Mor.
  Context `{Funext}.
  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Ltac build_mor_functor build :=
    let C := match goal with |- Functor ?C ?D => constr:(C) end in
    let D := match goal with |- Functor ?C ?D => constr:(D) end in
    refine (Build_Functor
              C D
              (fun C' => build { sd : Index2Cat C' * Index2Cat C' & Morphism (Index2Cat C') (fst sd) (snd sd) } _)
              (fun _ _ F => (fun sdm =>
                               existT (fun sd => Morphism _ (fst sd) (snd sd))
                                      (F (fst (projT1 sdm)), F (snd (projT1 sdm)))
                                      (MorphismOf F (s := fst (projT1 sdm)) (d := snd (projT1 sdm)) (projT2 sdm))))
              (fun _ _ _ _ _ => idpath)
              _);
      simpl; intro; apply path_forall; intros [[? ?] ?]; exact idpath.

  Definition SetMorphismFunctor `{forall i : I, IsHSet (Index2Cat i)}
  : Functor (ComputableCat Index2Cat) SetCat.
  Proof.
    build_mor_functor BuildhSet.
  Defined.

  Definition PropMorphismFunctor `{forall i : I, IsHProp (Index2Cat i)}
             `{forall i s d, IsHProp (Morphism (Index2Cat i) s d)}
  : Functor (@ComputableCat _ _ Index2Cat (fun _ _ => Functor_IsTrunc _ _)) PropCat.
  Proof.
    build_mor_functor hp.
  Defined.
End Mor.

Arguments SetMorphismFunctor {_ _ _ _}.
Arguments PropMorphismFunctor {_ _ _ _ _}.

Section dom_cod.
  Context `{Funext}.
  Variable I : Type.
  Variable Index2Cat : I -> PreCategory.

  Local Notation build_dom_cod F G fst_snd :=
    (*let F := match goal with |- NaturalTransformation ?F ?G => constr:(F) end in
    let G := match goal with |- NaturalTransformation ?F ?G => constr:(G) end in*)
    (Build_NaturalTransformation
       F G
       (fun _ => (fun sdf => fst_snd _ _ (projT1 sdf)))
       (fun _ _ _ => idpath)).

  Definition SetDomainNaturalTransformation
             `{forall i, IsHSet (Index2Cat i)}
    := build_dom_cod (SetMorphismFunctor (Index2Cat := Index2Cat))
                     SetObjectFunctor
                     (@fst).

  Definition SetCodomainNaturalTransformation
             `{forall i, IsHSet (Index2Cat i)}
    := build_dom_cod (SetMorphismFunctor (Index2Cat := Index2Cat))
                     SetObjectFunctor
                     (@snd).

  Definition PropDomainNaturalTransformation
             `{forall i, IsHProp (Index2Cat i)}
             `{forall i s d, IsHProp (Morphism (Index2Cat i) s d)}
    := build_dom_cod (PropMorphismFunctor (Index2Cat := Index2Cat))
                     PropObjectFunctor
                     (@fst).

  Definition PropCodomainNaturalTransformation
             `{forall i, IsHProp (Index2Cat i)}
             `{forall i s d, IsHProp (Morphism (Index2Cat i) s d)}
    := build_dom_cod (PropMorphismFunctor (Index2Cat := Index2Cat))
                     PropObjectFunctor
                     (@snd).
End dom_cod.
(*
Section disc.
(*  Local Ltac t := simpl; intros; functor_eq;
    repeat (apply functional_extensionality_dep; intro);
      hnf in *; subst;
        auto.*)

  Definition DiscreteSetFunctor : Functor SetCat Cat.
    refine (Build_Functor TypeCat Cat
      (fun O => Groupoid O : PreCategory)
      (fun s d f => InducedGroupoidFunctor (Groupoid d) f)
      _
      _
    );
    abstract t.
  Defined.

  Definition GroupoidSetFunctor : Functor SetCat Cat.
    refine (Build_Functor SetCat Cat
      (fun O => Groupoid O : PreCategory)
      (fun s d f => InducedGroupoidFunctor (Groupoid d) f)
      _
      _
    );
    abstract t.
  Defined.
End disc.
*)(*
Section Adjoints.
  Lemma GroupoidObjectIdentity : ComposeFunctors ObjectFunctor GroupoidFunctor = IdentityFunctor _.
    functor_eq.
  Qed.

  Definition GroupoidObjectAdjunction : HomAdjunction GroupoidFunctor ObjectFunctor.
    match goal with
      | [ |- HomAdjunction ?F ?G ] =>
        refine (Build_HomAdjunction F G
          (fun _ _ F => (fun x => F x))
          _
          _
        )
    end;
    try abstract trivial;
      simpl; intros.
    exists (fun f => (InducedGroupoidFunctor _ f));
      abstract (repeat match goal with
                         | _ => progress trivial
                         | _ => progress repeat (apply functional_extensionality_dep; intro)
                         | _ => hnf in *;
                           match goal with
                             | [ H : _ = _ |- _ ] => destruct H; simpl in *
                           end
                         | _ => rewrite FIdentityOf
                         | _ => progress functor_eq
                       end).
  Defined.
End Adjoints.
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.

(****************************************************************************)
(* This is a small library to do epsilon - N reasonning.                    *)
(* In order to use it, one only has to know the following tactics:          *)
(*                                                                          *)
(*      pose_big_enough i == pose a big enough natural number i             *)
(*   pose_big_modulus m F == pose a function m : F -> nat which should      *)
(*                           provide a big enough return value              *)
(* exists_big_modulus m F := pose_big_modulus m F; exists m                 *)
(*             big_enough == replaces a big enough constraint x <= i        *)
(*                           by true and implicity remembers that i should  *)
(*                           be bigger than x.                              *)
(*                close   == all "pose" tactics create a dummy subgoal to   *)
(*                           force the user to explictely indicate that all *)
(*                           constraints have been found                    *)
(****************************************************************************)

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

Module BigEnough.

Record big_rel_class_of T (leq : rel T) :=
  BigRelClass {
      leq_big_internal_op : rel T;
      bigger_than_op : seq T -> T;
      _ : leq_big_internal_op = leq;
      _ : forall i s, leq_big_internal_op i (bigger_than_op (i :: s));
      _ : forall i j s, leq_big_internal_op i (bigger_than_op s) ->
                        leq_big_internal_op i (bigger_than_op (j :: s))
}.

Record big_rel_of T := BigRelOf {
  leq_big :> rel T;
  big_rel_class : big_rel_class_of leq_big
}.

Definition bigger_than_of T (b : big_rel_of T)
           (phb : phantom (rel T) b) :=
  bigger_than_op (big_rel_class b).
Notation bigger_than leq := (@bigger_than_of _ _ (Phantom (rel _) leq)).

Definition leq_big_internal_of T (b : big_rel_of T)
           (phb : phantom (rel T) b) :=
  leq_big_internal_op (big_rel_class b).
Notation leq_big_internal leq := (@leq_big_internal_of _ _ (Phantom (rel _) leq)).

Lemma next_bigger_than T (b : big_rel_of T) i j s :
  leq_big_internal b i (bigger_than b s) ->
  leq_big_internal b i (bigger_than b (j :: s)).
Proof. by case: b i j s => [? []]. Qed.

Lemma instantiate_bigger_than T (b : big_rel_of T) i s :
  leq_big_internal b i (bigger_than b (i :: s)).
Proof. by case: b i s => [? []]. Qed.

Lemma leq_big_internalE T (b : big_rel_of T) : leq_big_internal b = leq_big b.
Proof. by case: b => [? []]. Qed.

(* Lemma big_enough  T (b : big_rel_of T) i s : *)
(*   leq_big_internal b i (bigger_than b s) -> *)
(*   leq_big b i (bigger_than b s). *)
(* Proof. by rewrite leq_big_internalE. Qed. *)

Lemma context_big_enough P T (b : big_rel_of T) i s :
  leq_big_internal b i (bigger_than b s) ->
  P true ->
  P (leq_big b i (bigger_than b s)).
Proof. by rewrite leq_big_internalE => ->. Qed.

Definition big_rel_leq_class : big_rel_class_of leq.
Proof.
exists leq (foldr maxn 0%N) => [|i s|i j s /leq_trans->] //;
by rewrite (leq_maxl, leq_maxr).
Qed.
Canonical big_enough_nat := BigRelOf big_rel_leq_class.

Definition closed T (i : T) := {j : T | j = i}.
Ltac close :=  match goal with
                 | |- context [closed ?i] =>
                   instantiate (1 := [::]) in (Value of i); exists i
               end.

Ltac pose_big_enough i :=
  evar (i : nat); suff : closed i; first do
    [move=> _; instantiate (1 := bigger_than leq _) in (Value of i)].

Ltac pose_big_modulus m F :=
  evar (m : F -> nat); suff : closed m; first do
    [move=> _; instantiate (1 := (fun e => bigger_than leq _)) in (Value of m)].

Ltac exists_big_modulus m F := pose_big_modulus m F; first exists m.

Ltac olddone :=
   trivial; hnf; intros; solve
   [ do ![solve [trivial | apply: sym_equal; trivial]
         | discriminate | contradiction | split]
   | case not_locked_false_eq_true; assumption
   | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Ltac big_enough :=
  do ?[ apply context_big_enough;
        first do [do ?[ now apply instantiate_bigger_than
                      | apply next_bigger_than]]].

Ltac big_enough_trans :=
  match goal with
    | [leq_nm : is_true (?n <= ?m)%N |- is_true (?x <= ?m)] =>
        apply: leq_trans leq_nm; big_enough; olddone
    | _ => big_enough; olddone
  end.

Ltac done := do [olddone|big_enough_trans].

End BigEnough.