(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Group_util.
Require Export Abelian_group_facts.
Section Free_abelian_group_def.
Variable V : SET.

Inductive FaG : Type :=
  | Var : V -> FaG
  | Law : FaG -> FaG -> FaG
  | Unit : FaG
  | Inv : FaG -> FaG.

Inductive eqFaG : FaG -> FaG -> Prop :=
  | eqFaG_Var : forall x y : V, Equal x y -> (eqFaG (Var x) (Var y):Prop)
  | eqFaG_law :
      forall x x' y y' : FaG,
      eqFaG x x' -> eqFaG y y' -> (eqFaG (Law x y) (Law x' y'):Prop)
  | eqFaG_law_assoc :
      forall x y z : FaG, eqFaG (Law (Law x y) z) (Law x (Law y z)):Prop
  | eqFaG_law0r : forall x : FaG, eqFaG (Law x Unit) x:Prop
  | eqFaG_inv : forall x y : FaG, eqFaG x y -> eqFaG (Inv x) (Inv y)
  | eqFaG_invr : forall x : FaG, eqFaG (Law x (Inv x)) Unit
  | eqFaG_refl : forall x : FaG, eqFaG x x:Prop
  | eqFaG_sym : forall x y : FaG, eqFaG x y -> (eqFaG y x:Prop)
  | eqFaG_trans :
      forall x y z : FaG, eqFaG x y -> eqFaG y z -> (eqFaG x z:Prop)
  | eqFaG_com : forall x y : FaG, eqFaG (Law x y) (Law y x).
Hint Resolve eqFaG_Var eqFaG_law eqFaG_law_assoc eqFaG_law0r eqFaG_invr
  eqFaG_refl eqFaG_com: algebra.
Hint Immediate eqFaG_sym: algebra.

Lemma eqFaG_Equiv : equivalence eqFaG.
red in |- *.
split; [ try assumption | idtac ].
exact eqFaG_refl.
red in |- *.
split; [ try assumption | idtac ].
exact eqFaG_trans.
exact eqFaG_sym.
Qed.

Definition FaG_set := Build_Setoid eqFaG_Equiv.

Definition FreeAbelianGroup : ABELIAN_GROUP.
apply
 (BUILD_ABELIAN_GROUP (E:=FaG_set) (genlaw:=Law) (e:=Unit) (geninv:=Inv)).
exact eqFaG_law.
exact eqFaG_law_assoc.
exact eqFaG_law0r.
exact eqFaG_inv.
exact eqFaG_invr.
exact eqFaG_com.
Defined.
Section Universal_prop.
Variable G : ABELIAN_GROUP.
Variable f : Hom V G.

Fixpoint FaG_lift_fun (p : FreeAbelianGroup) : G :=
  match p with
  | Var v => f v
  | Law p1 p2 => sgroup_law _ (FaG_lift_fun p1) (FaG_lift_fun p2)
  | Unit => monoid_unit G
  | Inv p1 => group_inverse G (FaG_lift_fun p1)
  end.

Definition FaG_lift : Hom FreeAbelianGroup G.
apply (BUILD_HOM_GROUP (G:=FreeAbelianGroup) (G':=G) (ff:=FaG_lift_fun)).
intros x y H'; try assumption.
elim H'; simpl in |- *; auto with algebra.
intros x0 y0 z H'0 H'1 H'2 H'3; try assumption.
apply Trans with (FaG_lift_fun y0); auto with algebra.
simpl in |- *; auto with algebra.
simpl in |- *; auto with algebra.
Defined.

Definition FaG_var : Hom V FreeAbelianGroup.
apply (Build_Map (A:=V) (B:=FreeAbelianGroup) (Ap:=Var)).
red in |- *.
simpl in |- *; auto with algebra.
Defined.

Lemma FaG_comp_prop :
 Equal f (comp_hom (FaG_lift:Hom (FreeAbelianGroup:SET) G) FaG_var).
simpl in |- *.
red in |- *.
simpl in |- *.
auto with algebra.
Qed.
End Universal_prop.
End Free_abelian_group_def.
Hint Resolve FaG_comp_prop: algebra.


Require Export P06.

(** **** Exercise: 3 stars, optional (CSeq_congruence)  *)
Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  unfold cequiv. intros.
  split; intros.
  - inversion H1. subst. apply H in H4. apply H0 in H7. econstructor; eassumption.
  - inversion H1. subst. apply H in H4. apply H0 in H7. econstructor; eassumption.
Qed.


Require Export StlcFix.SpecSyntax.

(** * Typing *)

Reserved Notation "⟪  i : T ∈ Γ  ⟫"
  (at level 0, i at level 98, Γ at level 98).
Inductive GetEvar : Env → Ix → Ty → Prop :=
  | GetEvarHere {Γ T} :
      ⟪   O : T ∈ Γ ▻ T  ⟫
  | GetEvarThere {Γ T T' i} :
      ⟪   i : T ∈ Γ      ⟫ →
      ⟪ S i : T ∈ Γ ▻ T' ⟫
where "⟪  i : T ∈ Γ  ⟫" := (GetEvar Γ i T).

Reserved Notation "⟪  Γ ⊢ t : T  ⟫"
  (at level 0, Γ at level 98, t at level 98, T at level 98 ).
Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | WtVar {i T} :
      ⟪ i : T ∈ Γ ⟫ →
      ⟪ Γ ⊢ var i : T ⟫
  | WtAbs {t τ₁ τ₂} :
      ⟪ Γ ▻ τ₁ ⊢ t : τ₂ ⟫ →
      ⟪ Γ ⊢ abs τ₁ t : tarr τ₁ τ₂ ⟫
  | WtApp {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₁ ⟫ →
      ⟪ Γ ⊢ app t₁ t₂ : τ₂ ⟫
  | WtUnit :
      ⟪ Γ ⊢ unit : tunit ⟫
  | WtTrue :
      ⟪ Γ ⊢ true : tbool ⟫
  | WtFalse :
      ⟪ Γ ⊢ false : tbool ⟫
  | WtIte {t₁ t₂ t₃ T} :
      ⟪ Γ ⊢ t₁ : tbool ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ Γ ⊢ t₃ : T ⟫ →
      ⟪ Γ ⊢ ite t₁ t₂ t₃ : T ⟫
  | WtPair {t₁ t₂ τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : τ₁ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₂ ⟫ →
      ⟪ Γ ⊢ pair t₁ t₂ : tprod τ₁ τ₂ ⟫
  | WtProj1 {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ proj₁ t : τ₁ ⟫
  | WtProj2 {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : tprod τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ proj₂ t : τ₂ ⟫
  | WtInl {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : τ₁ ⟫ →
      ⟪ Γ ⊢ inl t : tsum τ₁ τ₂ ⟫
  | WtInr {t τ₁ τ₂} :
      ⟪ Γ ⊢ t : τ₂ ⟫ →
      ⟪ Γ ⊢ inr t : tsum τ₁ τ₂ ⟫
  | WtCaseof {t₁ t₂ t₃ τ₁ τ₂ T} :
      ⟪ Γ ⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ ▻ τ₁ ⊢ t₂ : T ⟫ →
      ⟪ Γ ▻ τ₂ ⊢ t₃ : T ⟫ →
      ⟪ Γ ⊢ caseof t₁ t₂ t₃ : T ⟫
  | WtSeq {t₁ t₂ T} :
      ⟪ Γ ⊢ t₁ : tunit ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ Γ ⊢ seq t₁ t₂ : T ⟫
  | WtFixt {τ₁ τ₂ t} :
      ⟪ Γ ⊢ t : tarr (tarr τ₁ τ₂) (tarr τ₁ τ₂) ⟫ →
      ⟪ Γ ⊢ fixt τ₁ τ₂ t : tarr τ₁ τ₂ ⟫
where "⟪  Γ ⊢ t : T  ⟫" := (Typing Γ t T).

Reserved Notation "⟪ ⊢ C : Γ₀ , τ₀ → Γ , τ ⟫"
  (at level 0, C at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ⊢  C  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").
Inductive PCtxTyping (Γ₀: Env) (τ₀: Ty) : Env → PCtx → Ty → Prop :=
  | WtPHole :
      ⟪ ⊢ phole : Γ₀, τ₀ → Γ₀, τ₀ ⟫
  | WtPAbs {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ ▻ τ₁, τ₂ ⟫ →
      ⟪ ⊢ pabs τ₁ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫
  | WtPAppl {Γ C t₂ τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₁ ⟫ →
      ⟪ ⊢ papp₁ C t₂ : Γ₀, τ₀ → Γ, τ₂ ⟫
  | WtPAppr {Γ t₁ C τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : tarr τ₁ τ₂ ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ ⊢ papp₂ t₁ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | WtPIteI {Γ C t₂ t₃ T} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ , tbool ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ Γ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pite₁ C t₂ t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | WtPIteT {Γ t₁ C t₃ T} :
      ⟪ Γ ⊢ t₁ : tbool ⟫ →
      ⟪ ⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ Γ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pite₂ t₁ C t₃ : Γ₀ , τ₀ → Γ , T ⟫
  | WtPIteE {Γ t₁ t₂ C T} :
      ⟪ Γ ⊢ t₁ : tbool ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ ⊢ C : Γ₀ , τ₀ → Γ , T ⟫ →
      ⟪ ⊢ pite₃ t₁ t₂ C : Γ₀ , τ₀ → Γ , T ⟫
  | WtPPair₁ {Γ C t₂ τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ Γ ⊢ t₂ : τ₂ ⟫ →
      ⟪ ⊢ ppair₁ C t₂ : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | WtPPair₂ {Γ t₁ C τ₁ τ₂} :
      ⟪ Γ ⊢ t₁ : τ₁ ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ⟪ ⊢ ppair₂ t₁ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫
  | WtPProj₁ {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ⟪ ⊢ pproj₁ C : Γ₀, τ₀ → Γ, τ₁ ⟫
  | WtPProj₂ {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tprod τ₁ τ₂ ⟫ →
      ⟪ ⊢ pproj₂ C : Γ₀, τ₀ → Γ, τ₂ ⟫
  | WtPInl {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₁ ⟫ →
      ⟪ ⊢ pinl C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | WtPInr {Γ C τ₁ τ₂} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, τ₂ ⟫ →
      ⟪ ⊢ pinr C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫
  | WtPCaseof₁ {Γ C t₂ t₃ τ₁ τ₂ T} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tsum τ₁ τ₂ ⟫ →
      ⟪ Γ ▻ τ₁ ⊢ t₂ : T ⟫ →
      ⟪ Γ ▻ τ₂ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pcaseof₁ C t₂ t₃ : Γ₀, τ₀ → Γ, T ⟫
  | WtPCaseof₂ {Γ t₁ C t₃ τ₁ τ₂ T} :
      ⟪ Γ ⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ ▻ τ₁, T ⟫ →
      ⟪ Γ ▻ τ₂ ⊢ t₃ : T ⟫ →
      ⟪ ⊢ pcaseof₂ t₁ C t₃ : Γ₀, τ₀ → Γ, T ⟫
  | WtPCaseof₃ {Γ t₁ t₂ C τ₁ τ₂ T} :
      ⟪ Γ ⊢ t₁ : tsum τ₁ τ₂ ⟫ →
      ⟪ Γ ▻ τ₁ ⊢ t₂ : T ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ ▻ τ₂, T ⟫ →
      ⟪ ⊢ pcaseof₃ t₁ t₂ C : Γ₀, τ₀ → Γ, T ⟫
  | WtPSeq₁ {Γ C t₂ T} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tunit ⟫ →
      ⟪ Γ ⊢ t₂ : T ⟫ →
      ⟪ ⊢ pseq₁ C t₂ : Γ₀, τ₀ → Γ, T ⟫
  | WtPSeq₂ {Γ C t₁ T} :
      ⟪ Γ ⊢ t₁ : tunit ⟫ →
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, T ⟫ →
      ⟪ ⊢ pseq₂ t₁ C : Γ₀, τ₀ → Γ, T ⟫
  | WtPFixt {Γ τ₁ τ₂ C} :
      ⟪ ⊢ C : Γ₀, τ₀ → Γ, tarr (tarr τ₁ τ₂) (tarr τ₁ τ₂) ⟫ →
      ⟪ ⊢ pfixt τ₁ τ₂ C : Γ₀, τ₀ → Γ, tarr τ₁ τ₂ ⟫
where "⟪ ⊢ C : Γ₀ , τ₀ → Γ , τ ⟫" := (PCtxTyping Γ₀ τ₀ Γ C τ).

Lemma pctxtyping_app {Γ₀ t₀ τ₀ Γ C τ} :
  ⟪ Γ₀ ⊢ t₀ : τ₀ ⟫ → ⟪ ⊢ C : Γ₀, τ₀ → Γ , τ ⟫ → ⟪ Γ ⊢ pctx_app t₀ C : τ ⟫.
Proof.
  intros wt₀ wC;
  induction wC; cbn; subst; eauto using Typing.
Qed.

Lemma pctxtyping_cat {Γ₀ τ₀ C₁ Γ₁ τ₁ C₂ Γ₂ τ₂} :
  ⟪ ⊢ C₁ : Γ₀, τ₀ → Γ₁ , τ₁ ⟫ →
  ⟪ ⊢ C₂ : Γ₁, τ₁ → Γ₂ , τ₂ ⟫ →
  ⟪ ⊢ pctx_cat C₁ C₂ : Γ₀, τ₀ → Γ₂ , τ₂ ⟫.
Proof.
  intros wC₁ wC₂.
  induction wC₂; cbn; eauto using PCtxTyping.
Qed.

Definition WtRen (Γ₁ Γ₂: Env) (ξ: Sub Ix) : Prop :=
  ∀ i T, ⟪ i : T ∈ Γ₁ ⟫ → ⟪ (ξ i) : T ∈ Γ₂ ⟫.
Definition WtSub (Γ₁ Γ₂: Env) (ζ: Sub Tm) : Prop :=
  ∀ i T, ⟪ i : T ∈ Γ₁ ⟫ → ⟪ Γ₂ ⊢ (ζ i) : T ⟫.


From mathcomp Require Import all_ssreflect all_algebra finmap.
From Coq Require Import Uint63 PArray.
From Polyhedra Require Import extra_misc inner_product extra_matrix vector_order affine row_submx barycenter.
From Polyhedra Require Import lrel polyhedron poly_base simplex.
Require Import enum_algo enum_proof enum_equiv graph high_graph img_graph extra_array extra_int rat_bigQ diameter refinement.

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

Import Order.Theory Num.Theory.

Local Notation "a .[ i ]" := (PArray.get a i).

Section LexCorrectness.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).
Local Notation b_pert := (Simplex.b_pert b).

Context (G : graph (enum_type m' n')).

Hypothesis enum_h_r : high_enum_algo A b G.
Hypothesis P_compact : forall c, Simplex.bounded A b c.
Hypothesis G_prop0 : G != (graph0 (enum_type m' n')).

Lemma enum_h :
  [forall e : vertices G,
    [&& card_verification (fsval e),
        feas_verification A b (fsval e),
        bas_verification A b (fsval e),
        reg_verification G (fsval e) &
        [forall e' : successors G (fsval e), inter_verification (fsval e) (fsval e')]
    ]
  ].
Proof. by move: enum_h_r; rewrite high_enum_algoE. Qed.

Section ConstructFeasbas.

Context (e : enum_type m' n').
Hypothesis IxG : e \in (vertices G).

Local Notation I := e.1.
Local Notation x := e.2.

Lemma I_prebasis : #|I|==n.
Proof.
move/forallP:enum_h=> /= /(_ [` IxG]).
by case/and5P.
Qed.

Definition prebasis_I := Simplex.Prebasis I_prebasis.
Definition x_inv := -1 *: (row_submx (col' ord0 x)^T I)^T.

Lemma I_basis : Simplex.is_basis A prebasis_I.
Proof.
move/forallP:enum_h=> /= /(_ [` IxG]).
case/and5P=> _ _ + _ _; rewrite /bas_verification /= => /eqP A_Ix.
rewrite /Simplex.is_basis /=; apply/row_freeP.
exists x_inv; rewrite /x_inv -scalemxAr -[X in X *m _]trmxK -trmx_mul tr_col'.
apply/matrixP=> p q; rewrite !mxE.
under eq_bigr => [k _] do rewrite !mxE.
move: A_Ix=> /matrixP /(_ p (lift ord0 (enum_val q))); rewrite mxE.
under eq_bigr=> [k _] do rewrite mxE GRing.mulrC; move=> ->.
rewrite !mxE; case: splitP.
- move=> j /=; rewrite (ord1_eq0 j) /= => /esym /eqP.
  by rewrite (negPf (neq_bump _ _)).
- move=> k; rewrite lift0 [RHS]add1n => /succn_inj /val_inj <-.
  rewrite !mxE -GRing.mulNrn GRing.Theory.mulrnAr GRing.mulrN1 GRing.opprK.
  congr GRing.natmul; congr nat_of_bool.
  by apply/idP/idP=> [/eqP /enum_val_inj ->|/eqP ->].
Qed.

Definition basis_I := Simplex.Basis I_basis.

Lemma x_point_of_I : x = Simplex.point_of_basis b_pert basis_I.
Proof.
rewrite -(@Simplex.basis_subset_active_ineq_eq _ _ _ _ _ _ _ x) //=.
apply/subsetP=> i iI; rewrite inE row_mul.
move/forallP:enum_h=> /= /(_ [` IxG]).
case/and5P=> _ _ /eqP I_bas _ _.
by rewrite -[i](enum_rankK_in iI) // -!row_submx_row -I_bas row_mul.
Qed.

Lemma I_feasible : Simplex.is_feasible b_pert basis_I.
Proof.
move/forallP:enum_h=> /= /(_ [` IxG]).
case/and5P=> _ + _ _ _; rewrite /feas_verification /=.
by rewrite x_point_of_I /Simplex.is_feasible.
Qed.

Definition lexbasis_I := Simplex.FeasibleBasis I_feasible.

End ConstructFeasbas.

Lemma I0_def : exists x, x \in vertices G.
Proof. by move/graph0Pn: G_prop0. Qed.

Definition I0 := lexbasis_I (xchooseP I0_def).

Definition to_feas_bas (e : enum_type m' n'):=
  if @idP (e \in vertices G) is ReflectT h then
  lexbasis_I h else I0.

Definition lex_graph := lex_graph A b.

Lemma to_feas_bas_inj : {in vertices G &, injective to_feas_bas}.
Proof.
move=> e e' eG e'G; rewrite /to_feas_bas.
case: {-}_/idP=> // p; case: {-}_/idP=> // p'.
move=> bas_I_eq; rewrite [e]surjective_pairing [e']surjective_pairing.
apply/pair_equal_spec; split.
+ by move: bas_I_eq; do 3! move/(congr1 val).
+ by rewrite !x_point_of_I; move/(congr1 val):bas_I_eq=> /= ->.
Qed.

Lemma to_feas_bas_edges : {in vertices G &,
  forall x y, edges G x y ->
  edges lex_graph (to_feas_bas x) (to_feas_bas y)}.
Proof.
move=> x y xG yG; rewrite edge_mk_graph ?inE // -in_succE => yx.
rewrite /set_adjacence /=.
move/forallP: enum_h=> /(_ [`xG]) /and5P [_ _ _ _].
move/forallP=> /(_ [`yx]) /=; rewrite /inter_verification.
by rewrite /to_feas_bas; case: {-}_/idP=> // p; case: {-}_/idP.
Qed.

Lemma repr_lex_graph: gisof G lex_graph to_feas_bas.
Proof.
apply/sub_gisof=> //.
- exact: to_feas_bas_inj.
- by apply/fsubsetP=> x; rewrite vtx_mk_graph inE /=.
- exact:to_feas_bas_edges.
- exact:lex_graph_connected.
- move=> x xG; apply/eqP; rewrite eqEfcard; apply/andP; split.
  + apply/fsubsetP=> y' /imfsetP [/= y].
    rewrite in_succE=> /[dup] /edge_vtxr yG /(to_feas_bas_edges xG yG).
    by rewrite -in_succE => /[swap] ->.
  + rewrite lex_graph_regular ?vtx_mk_graph ?inE // card_in_imfset /=.
    * move/forallP: enum_h=> /(_ [`xG]) /and5P [_ _ _ + _].
      by rewrite /reg_verification=> /eqP ->.
    * move=> p q /(fsubsetP (sub_succ _ _)) + /(fsubsetP (sub_succ _ _)).
      exact:to_feas_bas_inj.
Qed.

End LexCorrectness.

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

Section ImgGraph.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (G_lex : graph (enum_type m' n')) (G_vert : graph [choiceType of 'cV[rat]_n]).

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).

Hypothesis boundA : forall c, Simplex.bounded A b c.
Hypothesis G_lex_verif : high_enum_algo A b G_lex.
Hypothesis G_lex_prop0 : G_lex != graph0 _.

(* Hypothesis G_vert_img : G_vert = ((@phi m' n') @/ G_lex). *)

Definition base_of_syst (C : 'M[rat]_(m,n) * 'cV[rat]_m) :=
  [fset [<(row i C.1)^T, C.2 i 0>] | i : 'I_m].
Definition poly_of_syst C:= 'P(base_of_syst C).

Local Notation P := (poly_of_syst (A,b)).

Lemma feasA : Simplex.feasible A b.
Proof. exact/feas_bas0/(I0 G_lex_verif G_lex_prop0). Qed.

Lemma relA : rel_mat_Po (base_of_syst (A, b)) (A,b).
Proof. by []. Qed.

Lemma high_img : poly_graph P =
  ((fun I => Simplex.point_of_basis b I) @/ (lex_graph A b)).
Proof. by exact/(im_lex_graph_vert_graph boundA feasA relA). Qed.

Lemma G_lex_repr : gisof G_lex (lex_graph A b) (to_feas_bas G_lex_verif G_lex_prop0).
Proof. exact/repr_lex_graph. Qed.

Lemma repr_poly_graph :  poly_graph P = ((@phi m' n') @/ G_lex).
Proof.
apply/esym/(gisof_diagram _ G_lex_repr _ high_img); [|exact:erefl].
move=> x xG_lex /=; rewrite Simplex.rel_points_of_basis.
rewrite /to_feas_bas; case: {-}_/idP=> // ?.
by rewrite -x_point_of_I.
Qed.

End ImgGraph.

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

Section BoundPoly.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).
Context (Y_pos Y_neg : 'M[rat]_(n,m)).

Hypothesis feasA : Simplex.feasible A b.
Hypothesis bound_h : high_poly_bounded A Y_pos Y_neg.

Definition max_bound_i (i : 'I_n):=
  (Order.max '[-(row i Y_pos)^T, b] '[-(row i Y_neg)^T,b]).
Definition max_bound := \big[Order.max/0%R]_(i < n) max_bound_i i.

Lemma max_boundP (i : 'I_n):
  max_bound_i i <= max_bound.
Proof.
rewrite /max_bound.
have: i \in index_enum (ordinal_finType n) by rewrite mem_index_enum.
elim: (index_enum _)=> // h t IH.
rewrite in_cons big_cons le_maxr; case/orP.
- by move/eqP=> ->; rewrite lexx.
- by move/IH=> ->; rewrite orbT.
Qed.

Lemma high_poly_boundedP: forall c, Simplex.bounded A b c.
Proof.
move=> c; rewrite -(boundedE (relA A b)); move: c; apply/compactP.
- case/Simplex.feasibleP: feasA=> x x_in; apply/proper0P; exists x.
  by rewrite (feasE (relA A b)).
- apply/compactP_Linfty; exists max_bound=> x.
  rewrite (feasE (relA A b)) inE => x_Ab i.
  case/andP: bound_h=> /forallP /(_ i) + /forallP /(_ i).
  case/andP=> /eqP Y_pos_A Y_pos_pos.
  case/andP=> /eqP Y_neg_A Y_neg_pos.
  move: (vdot_lev Y_pos_pos x_Ab) (vdot_lev Y_neg_pos x_Ab).
  rewrite !vdot_mulmx -!trmx_mul Y_pos_A Y_neg_A.
  rewrite [X in _ <= X]row_vdot mul_scalar_mx GRing.scale1r.
  move=> x_i_ge; rewrite [X in _ <= X]row_vdot mul_scalar_mx GRing.scaleN1r mxE.
  move=> x_i_le; apply/(le_trans _ (max_boundP i)).
  rewrite ler_norml; apply/andP; split.
  + rewrite ler_oppl le_maxr; apply/orP; left.
    by rewrite vdotNl ler_oppl GRing.opprK.
  + rewrite le_maxr; apply/orP; right.
    by rewrite vdotNl ler_oppr.
Qed.

End BoundPoly.

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

Section FullDim.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).
Context (x0 : 'cV[rat]_n) (s : seq 'cV[rat]_n).

Local Definition base_AB := base_of_syst (A, b).

Hypothesis full_h :
  [/\ x0 \in (vertex_set 'P(base_AB)),
    {subset s <= (vertex_set 'P(base_AB))} &
    \dim (span [seq x - x0 | x <- s]) = n].

Lemma high_dim_fullP: \pdim 'P(base_AB) = n.+1.
Proof.
apply/anti_leq/andP; split; first exact:adim_leSn.
case: full_h=> x0_vtx s_vtx {1}<-.
apply/leq_trans; [|apply/(dim_sub_affine (x0:=x0) (X:=s))].
- by rewrite adimN0_eq ?mk_affine_proper0 // dir_mk_affine.
- exact/vertex_set_subset.
- by move=> x /s_vtx; exact/vertex_set_subset.
Qed.

End FullDim.

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

Section HighHirsch.

Context (m' n' : nat).
Local Notation m := m'.+1.
Local Notation n := n'.+1.

Context (A : 'M[rat]_(m,n)) (b : 'cV[rat]_m).

Context (G_lex : graph (enum_type m' n')) (G_vert : graph [choiceType of 'cV[rat]_n]).

Hypothesis enum_h : high_enum_algo A b G_lex.
Hypothesis img_h : G_vert = ((@phi m' n') @/ G_lex).
Hypothesis boundA : forall c : 'cV_n, Simplex.bounded A b c.
Hypothesis G_lex_prop0 : G_lex != graph0 _.
Hypothesis poly_dim : \pdim (poly_of_syst (A, b)) = n.+1.

Hypothesis G_vert_BFS : (diameter G_vert > m - n)%nat.

Lemma poly_facets: (#|` facets (poly_of_syst (A, b))| <= m)%nat.
Proof.
apply/(leq_trans (@facets_le _ _ (base_of_syst (A, b))))/(leq_trans (leq_imfset_card _ _ _)).
by rewrite size_enum_ord leqnn.
Qed.

Theorem high_algo_Hirsch :
  (diameter (poly_graph (poly_of_syst (A,b))) >
    #|`facets (poly_of_syst (A,b))| -
      (\pdim (poly_of_syst (A,b))).-1)%nat.
Proof.
have G_vert_poly: poly_graph (poly_of_syst (A,b)) = G_vert.
- rewrite img_h; apply: repr_poly_graph.
  + exact: boundA.
  + exact: enum_h.
  + exact: G_lex_prop0.
rewrite poly_dim /=; apply/(leq_ltn_trans (n:=m - n))=> //;first
  apply/leq_sub2r/poly_facets.
by rewrite G_vert_poly.
Qed.

End HighHirsch.

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

Section HirschVerification.

Context (Po : Com.polyType).
Hypothesis Po_format : poly_format Po.
Local Notation m' := (Com.m Po).-1.
Local Notation n' := (Com.n Po).-1.

Context (g_lex : graph.graph) (l_lex : Com.lex_mapping).
Hypothesis gl_lex_format : lex_graph_format Po g_lex l_lex.

Context (g_vert : graph.graph) (l_vert : array (array BigQ.bigQ)).
Hypothesis gl_vert_format : vert_graph_format Po g_vert l_vert.

Context (morph morph' : array Uint63.int).
Context (edge_inv : array (array (Uint63.int * Uint63.int))).

Context (y_pos y_neg : array (array BigQ.bigQ)).
Hypothesis y_pos_format : bound_format Po y_pos.
Hypothesis y_neg_format : bound_format Po y_neg.

Hypothesis enum_h : enum_algo Po g_lex l_lex.
Hypothesis img_h : img_lex_graph morph morph' edge_inv g_lex l_lex g_vert l_vert.
Hypothesis bound_h : @bounded_Po_test Po y_pos y_neg.
Hypothesis graph_h : lex_graph_n0 g_lex.

Local Notation high_poly := (spec_poly m' n' Po).
Local Notation A := high_poly.1.
Local Notation b := high_poly.2.
Local Notation G_lex := (spec_lex_graph m' n' (g_lex,l_lex)).
Local Notation G_vert := (spec_vert_graph n' (g_vert,l_vert)).

Lemma high_enum_h : high_enum_algo A b G_lex.
Proof.
move: (format_poly_precond Po_format) (lex_graph_format_precond Po_format gl_lex_format).
move/spec_func_poly=> + /spec_func_lex_graph.
by move/lex_certif_equiv=> /[apply] /= <-.
Qed.

Lemma high_graph_h : G_lex != graph0 _.
Proof.
move: (lex_graph_format_precond Po_format gl_lex_format).
by move/spec_func_lex_graph/graph_n0_equiv=> <-.
Qed.

Lemma high_img_h:
  G_vert = ((@phi m' n') @/ G_lex).
Proof.
apply/img_lex_graph_equiv; [| |exact:img_h].
- exact/spec_func_lex_graph/lex_graph_format_precond.
- exact/spec_func_vert_graph/vert_graph_format_precond.
Qed.

Lemma high_bound_h:
  forall c, Simplex.bounded A b c.
Proof.
move: (format_poly_precond Po_format)
  (bound_format_precond Po_format y_pos_format)
  (bound_format_precond Po_format y_neg_format).
move/spec_func_poly=> + /spec_func_bound + /spec_func_bound.
move/poly_bounded_equiv=> /[apply] /[apply] /eq_imply bound_eq.
apply/high_poly_boundedP;
  [apply/feasA; [exact/high_enum_h|exact/high_graph_h]|exact/bound_eq].
Qed.

Lemma Validation: poly_graph (poly_of_syst high_poly) = G_vert.
Proof.
rewrite high_img_h.
apply/repr_poly_graph;
  [ exact:high_bound_h|exact:high_enum_h|exact:high_graph_h].
Qed.

Context (origin : Uint63.int) (map_ : array int) (inv : array (array BigQ.bigQ)).
Hypothesis inv_format: inv_format Po inv.

Context (start : Uint63.int).

Hypothesis dim_h : dim_full_test l_vert map_ origin inv Po.
Hypothesis diameter_h : diameter_check g_vert Po start.

Lemma high_dim_h:
  \pdim (poly_of_syst high_poly) = n'.+2.
Proof.
move: (format_poly_precond Po_format)
  (inv_format_precond Po_format inv_format)
  (vert_graph_format_precond Po_format gl_vert_format).
move/spec_func_poly=> + /spec_func_inv + /spec_func_vert_graph.
move/dim_full_vtx_graph=> /[apply] /[apply].
case/(_ _ _ dim_h)=> /= x0 [s].
rewrite high_img_h.
rewrite -(repr_poly_graph high_bound_h high_enum_h high_graph_h).
by rewrite vtx_mk_graph=> /high_dim_fullP.
Qed.

Lemma high_diameter_h:
  (diameter G_vert > m'.+1 - n'.+1)%nat.
Proof.
move: (format_poly_precond Po_format)
  (vert_graph_format_precond Po_format gl_vert_format).
move/spec_func_poly=> + /spec_func_vert_graph.
by move/high_diameter_check_equiv=> /[apply] /(_ _ diameter_h).
Qed.

Local Notation P := (poly_of_syst high_poly).

Lemma disprove_Hirsch:
  ((diameter (poly_graph P)) >
  #|`facets P| - (\pdim P).-1)%nat.
Proof.
apply/high_algo_Hirsch;
  [ exact:high_enum_h|exact:high_img_h|
    exact:high_bound_h|exact:high_graph_h|
    exact:high_dim_h|exact:high_diameter_h].
Qed.

End HirschVerification.

Section ExactDimension.
Context (Po : Com.polyType).
Hypothesis Po_format : poly_format Po.
Local Notation m' := (Com.m Po).-1.
Local Notation n' := (Com.n Po).-1.
Context (g_lex : graph.graph) (l_lex : Com.lex_mapping).
Hypothesis gl_lex_format : lex_graph_format Po g_lex l_lex.

Context (g_vert : graph.graph) (l_vert : array (array BigQ.bigQ)).
Hypothesis gl_vert_format : vert_graph_format Po g_vert l_vert.

Context (morph morph' : array Uint63.int).
Context (edge_inv : array (array (Uint63.int * Uint63.int))).

Context (y_pos y_neg : array (array BigQ.bigQ)).
Hypothesis y_pos_format : bound_format Po y_pos.
Hypothesis y_neg_format : bound_format Po y_neg.

Hypothesis enum_h : enum_algo Po g_lex l_lex.
Hypothesis img_h : img_lex_graph morph morph' edge_inv g_lex l_lex g_vert l_vert.
Hypothesis bound_h : @bounded_Po_test Po y_pos y_neg.
Hypothesis graph_h : lex_graph_n0 g_lex.

Local Notation high_poly := (spec_poly m' n' Po).
Local Notation A := high_poly.1.
Local Notation b := high_poly.2.
Local Notation G_lex := (spec_lex_graph m' n' (g_lex,l_lex)).
Local Notation G_vert := (spec_vert_graph n' (g_vert,l_vert)).

Lemma diameter_of_polyXXdimXX k:
  diameter_exact g_vert Po k ->
  diameter (poly_graph (poly_of_syst high_poly)) = int_to_nat k.
Proof.
move=> diameter_h.
have:= (Validation Po_format gl_lex_format gl_vert_format y_pos_format y_neg_format).
move=> /(_ _ _ _ enum_h img_h bound_h graph_h) ->.
move: (vert_graph_format_precond Po_format gl_vert_format).
move/spec_func_vert_graph=> rel_g_vert.
rewrite -(rel_graph_diameter rel_g_vert) /=.
move: diameter_h=> /eqP diam_h.
apply/nat_to_int_inj; [|exact:int_thresholdP|rewrite int_to_natK //].
rewrite inE.
apply/(@leq_ltn_trans (length g_vert)); last exact/int_thresholdP.
case: rel_g_vert=> -[g' ?] [_ [/= gg' _] _].
rewrite (rel_struct_diameter gg') -(rel_struct_card gg').
apply/bigmax_leqP=> p _; exact: size_path_le.
Qed.

Lemma diameter_of_poly20dim21:
  diameter_exact g_vert Po 21%uint63->
  diameter (poly_graph (poly_of_syst high_poly)) = 21%nat.
Proof. by move/diameter_of_polyXXdimXX=> ->. Qed.

Lemma diameter_of_poly23dim24:
  diameter_exact g_vert Po 24%uint63->
  diameter (poly_graph (poly_of_syst high_poly)) = 24%nat.
Proof. by move/diameter_of_polyXXdimXX=> ->. Qed.

End ExactDimension.


From Coq Require Import Utf8 Setoid ssreflect.
Set Default Proof Using "Type".

Local Set Universe Polymorphism.

(** Telescopes *)
Inductive tele : Type :=
  | TeleO : tele
  | TeleS {X} (binder : X → tele) : tele.

Arguments TeleS {_} _.

(** The telescope version of Coq's function type *)
Fixpoint tele_fun (TT : tele) (T : Type) : Type :=
  match TT with
  | TeleO => T
  | TeleS b => ∀ x, tele_fun (b x) T
  end.

Notation "TT -t> A" :=
  (tele_fun TT A) (at level 99, A at level 200, right associativity).

(** A sigma-like type for an "element" of a telescope, i.e. the data it
  takes to get a [T] from a [TT -t> T]. *)
Inductive tele_arg : tele → Type :=
| TargO : tele_arg TeleO
(* the [x] is the only relevant data here *)
| TargS {X} {binder} (x : X) : tele_arg (binder x) → tele_arg (TeleS binder).

Definition tele_app {TT : tele} {T} (f : TT -t> T) : tele_arg TT → T :=
  λ a, (fix rec {TT} (a : tele_arg TT) : (TT -t> T) → T :=
     match a in tele_arg TT return (TT -t> T) → T with
     | TargO => λ t : T, t
     | TargS x a => λ f, rec a (f x)
     end) TT a f.
Arguments tele_app {!_ _} _ !_ /.

Coercion tele_arg : tele >-> Sortclass.
Coercion tele_app : tele_fun >-> Funclass.

(** Inversion lemma for [tele_arg] *)
Lemma tele_arg_inv {TT : tele} (a : TT) :
  match TT as TT return TT → Prop with
  | TeleO => λ a, a = TargO
  | TeleS f => λ a, ∃ x a', a = TargS x a'
  end a.
Proof. induction a; eauto. Qed.
Lemma tele_arg_O_inv (a : TeleO) : a = TargO.
Proof. exact (tele_arg_inv a). Qed.
Lemma tele_arg_S_inv {X} {f : X → tele} (a : TeleS f) :
  ∃ x a', a = TargS x a'.
Proof. exact (tele_arg_inv a). Qed.

(** Operate below [tele_fun]s with argument telescope [TT]. *)
Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U :=
  match TT as TT return (TT → U) → TT -t> U with
  | TeleO => λ F, F TargO
  | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *)
                  tele_bind (λ a, F (TargS x a))
  end.
Arguments tele_bind {_ !_} _ /.

(* Show that tele_app ∘ tele_bind is the identity. *)
Lemma tele_app_bind {U} {TT : tele} (f : TT → U) x :
  (tele_app (tele_bind f)) x = f x.
Proof.
  induction TT as [|X b IH]; simpl in *.
  - rewrite (tele_arg_O_inv x). auto.
  - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl.
    rewrite IH. auto.
Qed.

(** Notation-compatible telescope mapping *)
(* This adds (tele_app ∘ tele_bind), which is an identity function, around every
   binder so that, after simplifying, this matches the way we typically write
   notations involving telescopes. *)
Notation "'λ..' x .. y , e" :=
  (tele_app (tele_bind (λ x, .. (tele_app (tele_bind (λ y, e))) .. )))
  (at level 200, x binder, y binder, right associativity,
   format "'[  ' 'λ..'  x  ..  y ']' ,  e").

(* The testcase *)
Lemma test {TA TB : tele} {X} (α' β' γ' : X → Prop) (Φ : TA → TB → Prop) x' :
  (forall P Q, ((P /\ Q) = Q) * ((P -> Q) = Q)) ->
  ∀ a b, Φ a b = (λ.. x y, β' x' ∧ (γ' x' → Φ x y)) a b.
Proof.
intros cheat a b.
rewrite !tele_app_bind.
by rewrite !cheat.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E : Universe, ((wd_ A B /\ (wd_ B D /\ (wd_ D E /\ (wd_ B E /\ (wd_ B C /\ (wd_ A C /\ (col_ A B D /\ col_ A B E))))))) -> col_ B D E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export LogRelIE.PseudoType.
Require Export LogRelIE.InstPTy.
Require Export RecTypes.Contraction.
Require Export LogRelIE.Contraction.

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Max.
Require Import Coq.micromega.Lia.

Fixpoint pNumbFree (τ : PTy) : nat :=
  match τ with
  | ptunit => 0
  | ptbool => 0
  | ptprod τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptsum τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptarr τ1 τ2 => max (pNumbFree τ1) (pNumbFree τ2)
  | ptrec τ => pred (pNumbFree τ)
  | ptvar i => S i
  | pEmulDV n p τ => 0
  end.
Arguments pNumbFree !τ.

Lemma pNumbFree_sound τ : innerPClosed τ → ws (pNumbFree τ) τ.
Proof.
  induction τ; cbn; try constructor; dependent destruction H.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ1 H)); lia.
  - refine (WsPTy_mono _ (IHτ2 H)); lia.
  - refine (WsPTy_mono _ (IHτ H)); lia.
  - induction i; constructor; assumption.
  - assumption.
Qed.

Definition pDecideClosed τ := match pNumbFree τ with
                             | 0 => B.true
                             | _ => B.false
                             end.

Arguments pDecideClosed /.
Lemma decidePClosed_sound {τ} : innerPClosed τ → Is_true (pDecideClosed τ) -> ⟨ 0 ⊢ τ ⟩.
Proof.
  unfold pDecideClosed, WsTy.
  remember (pNumbFree τ).
  destruct n; intuition.
  rewrite Heqn.
  now eapply pNumbFree_sound.
Qed.

Lemma pNumbFree_complete {τ n} : ⟨ n ⊢ τ ⟩ -> pNumbFree τ <= n.
Proof.
  induction 1; cbn; try lia.
  induction H; lia.
Qed.

Lemma pNumbFree_complete' {τ} : ⟨ 0 ⊢ τ ⟩ -> pNumbFree τ = 0.
Proof.
  intros cl.
  cut (pNumbFree τ <= 0).
  - lia.
  - now eapply pNumbFree_complete.
Qed.

Lemma pDecideClosed_complete {τ} : ⟨ 0 ⊢ τ ⟩ -> Is_true (pDecideClosed τ).
Proof.
  intros cτ.
  assert (nc := pNumbFree_complete cτ).
  assert (eq : pNumbFree τ = 0) by lia.
  unfold pDecideClosed.
  now rewrite eq.
Qed.

Inductive ClosedPEnv : PEnv → Prop :=
  | PEmptyClosed : ClosedPEnv pempty
  | VarPClosed {Γ τ} :
      ⟨ 0 ⊢ τ ⟩ →
      ClosedPEnv Γ →
      ClosedPEnv (Γ p▻ τ).

#[export]
Hint Constructors wsPTy : cty.
#[export]
Hint Constructors ClosedPEnv : cenv.

Definition ValidPTy : PTy -> Prop := fun τ => ⟨ 0 ⊢ τ ⟩ /\ SimplePContr τ.
Definition ValidPEnv : PEnv -> Prop := fun Γ => ClosedPEnv Γ /\ ContrPEnv Γ.

Lemma ValidPTy_SimplePContr {τ} : ValidPTy τ -> SimplePContr τ.
Proof.
  now destruct 1.
Qed.
#[export]
Hint Resolve ValidPTy_SimplePContr : simple_p_contr_rec.

Lemma ValidPEnv_nil : ValidPEnv pempty.
Proof.
  split; constructor; eauto.
Qed.
#[export]
Hint Resolve ValidPEnv_nil : ptyvalid.

Lemma ValidPEnv_cons {Γ τ} : ValidPEnv Γ -> ValidPTy τ -> ValidPEnv (Γ p▻ τ).
Proof.
  intros [env_cl env_contr] [ty_cl ty_contr].
  split; constructor; eauto.
Qed.
#[export]
Hint Resolve ValidPEnv_cons : ptyvalid.

Lemma ValidPEnv_invert_cons {Γ τ} : ValidPEnv (Γ p▻ τ) → ValidPEnv Γ ∧ ValidPTy τ.
Proof.
  intro vΓ.
  destruct vΓ as (closedΓ & contrΓ).
  inversion closedΓ; inversion contrΓ; subst.
  split; split; assumption.
Qed.

Lemma ValidPEnv_getevar {Γ i τ} : ValidPEnv Γ → ⟪ i : τ p∈ Γ ⟫ → ValidPTy τ.
Proof.
  revert Γ.
  induction i; intros Γ vΓ ev.
  - inversion ev; subst.
    destruct (ValidPEnv_invert_cons vΓ) as (_ & vτ).
    assumption.
  - inversion ev; subst.
    destruct (ValidPEnv_invert_cons vΓ) as (vΓ0 & _).
    apply (IHi Γ0 vΓ0 H1).
Qed.

Lemma ValidPTy_unfold_trec {τ} : ValidPTy (ptrec τ) -> ValidPTy (τ[beta1 (ptrec τ)]).
Proof.
  intros (clτ & crτ).
  inversion clτ; subst.
  split.
  - now eauto using (wsAp (X := PTy)), (wsSub_sub_beta1 (X := PTy)).
  - now eapply (SimplePContr_pUnfoldOnce (ptrec τ)).
Qed.


(*! Definition of a small imperative language !*)

From PresburgerAI Require Export TotalMap EqDec RelationalAbstractDomain Utils.
From Coq Require Export Strings.String ZArith List.

Open Scope list_scope.

(** Variables id **)
Notation Vid n := (Fin n).

(** Location ids **)
Definition Location := list nat.

(** Binary operation codes **)
Inductive BinOpCode := Add | Mul | Le.

(** A Program **)
Inductive Program {n: nat} :=
| PBinop (res: Vid n) (opc: BinOpCode) (op1 op2: Vid n)
| PSeq (p1 p2: Program)
| PIf (cond_var: Vid n) (p_true p_false: Program)
| PWhile (cond: Vid n) (p1: Program).

Arguments Program : clear implicits.

(** A state in the program **)
Notation State n := (Array Z n).

(** Execute a binary operation given both operands values **)
Definition execute_binop (opc: BinOpCode) (v1 v2: Z) :=
  match opc with
  | Add => (v1 + v2)%Z
  | Mul => (v1 * v2)%Z
  | Le => if (v1 <=? v2)%Z then 1%Z else 0%Z
  end.

(** Execute a binary operation on a state **)
Definition execute_binop_state {n: nat} (opc: BinOpCode) (op1 op2: Vid n) (s: State n) :=
  execute_binop opc (array_get s op1) (array_get s op2).

(** Notation for relational semantics **)
Reserved Notation
         "st '=[' c ']=>' st'"
         (at level 40, st constr, st' constr at next level).

(** Relational semantics of a program **)
Inductive semantics {n: nat} : Program n -> State n -> State n -> Prop :=
| EBinop res opc op1 op2 s :
  s =[ PBinop res opc op1 op2 ]=> (array_set s res (execute_binop_state opc op1 op2 s))
| ESeq p1 p2 s s' s'' :
    s =[ p1 ]=> s' ->
    s' =[ p2 ]=> s'' ->
    s =[ PSeq p1 p2 ]=> s''
| EIfTrue var p_true p_false (s s': State n) :
    (array_get s var) <> 0%Z ->
    s =[ p_true ]=> s' ->
    s =[ PIf var p_true p_false ]=> s'
| EIfFalse var p_true p_false (s s': State n) :
    (array_get s var) = 0%Z ->
    s =[ p_false ]=> s' ->
    s =[ PIf var p_true p_false ]=> s'
| EWhileTrue var p (s s' s'': State n) :
    (array_get s var) <> 0%Z ->
    s =[ p ]=> s' ->
    s' =[ PWhile var p ]=> s'' ->
    s =[ PWhile var p ]=> s''
| EWhileFalse var p (s: State n) :
    (array_get s var) = 0%Z ->
    s =[ PWhile var p ]=> s
where "st =[ p ]=> st'" := (semantics p st st').

Section ImpLemmas.

  (** When we are out of the while loop, the condition is false **)
  Lemma while_out_cond n cond p s s' :
    s =[ @PWhile n cond p ]=> s' ->
    array_get s' cond = 0%Z.
  Proof.
    intros.
    remember (PWhile _ _).
    induction H; try discriminate; inversion Heqp0; subst; auto.
  Qed.

  (** equivalence with the denotational semantics**)
  Lemma while_trans_closure n cond p s s' :
    s =[ @PWhile n cond p ]=> s' <->
    transitive_closure (fun (s: State n * State n) => (array_get (fst s) cond <> 0%Z) /\ (fst s) =[ p ]=> (snd s)) (s, s') /\ array_get s' cond = 0%Z.
  Proof.
    split; intros.
    - split; [ | eauto using while_out_cond ].
      remember (PWhile _ _).
      induction H; try discriminate; inversion Heqp0; subst; [ | constructor ].
      specialize (IHsemantics2 eq_refl).
      eapply tc_app; [ | eauto].
      auto.
    - destruct H.
      remember (s, s').
      generalize dependent s'.
      generalize dependent s.
      induction H; intros; inversion Heqp0; subst; [ constructor; auto | ].
      destruct H.
      simpl in *.
      eapply EWhileTrue; eauto.
  Qed.

End ImpLemmas.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: nat;
      task_period: nat;
      task_deadline: nat;
      task_jitter: nat
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_jitter t1 == task_jitter t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL] /eqP JITTER].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [/orP [EQ | /eqP DL] | /eqP JITTER]; last by apply JITTER; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        by apply ID; inversion BUG.
        by apply DL; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition himmilbeau_bmap_list := [Build_varinfo Tdouble 1%positive (-5) (5);Build_varinfo Tdouble 2%positive (-5) (5)].

Definition himmilbeau_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list himmilbeau_bmap_list) in exact z).

Definition himmilbeau (x1 : ftype Tdouble) (x2 : ftype Tdouble) :=
  cast Tdouble (let a := (((x1 * x1)%F64 + x2)%F64 - (11)%F64)%F64 in
  let b := ((x1 + (x2 * x2)%F64)%F64 - (7)%F64)%F64 in
  ((a * a)%F64 + (b * b)%F64)%F64).

Definition himmilbeau_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive]) himmilbeau in exact e').

Derive himmilbeau_b
SuchThat (forall vmap, prove_roundoff_bound himmilbeau_bmap vmap himmilbeau_expr himmilbeau_b)
As jetengine_bound.
Proof.
idtac "Starting himmilbeau".
time "himmilbeau" (
try (subst himmilbeau_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)).
Qed.

Lemma check_himmilbeau_bound: ltac:(CheckBound himmilbeau_b 2.31e-12%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import HoTT.
Require Import Categories.Functor Category.Morphisms.
Require Import Category.Core.
From GCTT Require Import quotients categories.
From GCTT Require Export cquot cquot_principles.

(** The definition of the 1type-completion is in the folder cquot. We change the notation here so that it matches the thesis. *)
Notation "'N1'" := cquot.
Notation "'N1_rec'" := cquot_rec.
Notation "'N1_ind'" := cquot_ind.
Notation "'N1_ind_set'" := cquot_ind_set.

(** A simplified version of N1_rec where we don't need to specify that identities are preserved  *)
Definition N1_rec' {C : PreCategory} (Y : Type)
             (cclY : C -> Y)
             (ccleqY : forall {a₁ a₂ : C},
                 C a₁ a₂ -> cclY a₁ = cclY a₂)
             (* (ceY : forall (a : C), ccleqY (identity a) = idpath) *)
             (cconcatY : forall (a₁ a₂ a₃: C) (c₁: C a₁ a₂) (c₂: C a₂ a₃),
                 ccleqY (c₂ o c₁)%morphism = ccleqY c₁ @ ccleqY c₂)
             {truncY : IsTrunc 1 Y}
  : N1 C -> Y.
  Proof.
    refine (N1_rec Y cclY ccleqY _ cconcatY).
    intro c.
    apply (cancelL (ccleqY c c 1%morphism)).
    refine ((cconcatY c c c _ _)^ @ _).
    refine (ap (ccleqY c c) (left_identity C c c _) @ _).
    apply inverse. apply concat_p1.
  Defined.

(** The functor given by the constructors of N1 *)
Definition include_in_N1 (C : PreCategory)
  : Functor C (Core.groupoid_category (N1 C)).
Proof.
  srapply @Build_Functor.
  - apply ccl.
  - apply ccleq.
  - apply cconcat.
  - apply ce.
Defined.

(** N1 is functorial *)
Definition functor_groupoid_category
           (X Y : Type) {istrunc_X : IsTrunc 1 X} {istrunc_Y : IsTrunc 1 Y}
  : (X -> Y) -> Functor (Core.groupoid_category X) (Core.groupoid_category Y).
Proof.
  intro f.
  srapply @Build_Functor.
  + exact f.
  + intros x1 x2. simpl. exact (ap f).
  + intros x1 x2 x3 p1 p2. simpl in *.
    apply ap_pp.
  + reflexivity.
Defined.

(** The universal principle of the 1-type completion *)
Definition univ_N1 (C : PreCategory) (Y : Type) {istrunc_Y : IsTrunc 1 Y}
  : (N1 C -> Y) <~> Functor C (Core.groupoid_category Y).
Proof.
  srapply @equiv_adjointify.
  - intro f.
    refine (_ o (include_in_N1 C))%functor.
    apply functor_groupoid_category. exact f.
  - intro F.
    srapply @cquot_rec.
    + exact (object_of F).
    + apply (morphism_of F).
    + apply (identity_of F).
    + apply (composition_of F).
  - intro F.
    srapply @path_functor'.
    + reflexivity.
    + cbn.
      intros a b f. rewrite concat_p1. rewrite concat_1p.
      apply cquot_rec_beta_ccleq.
  - intro F. apply path_arrow. intro x. revert x.
    srapply @cquot_ind_set.
    + intro c. simpl. reflexivity.
    + intros c1 c2 f. simpl.
      apply path_to_path_over.
      refine (transport_paths_FlFr _ _ @ _).
      simpl. rewrite concat_p1.
      apply moveR_Vp. rewrite concat_p1.
      apply inverse.
      refine (cquot_rec_beta_ccleq _ _ _ _ _ _ _ _ _ _).
Defined.

Definition functor_N1 {C D : PreCategory}
  : Functor C D -> (N1 C -> N1 D).
Proof.
  intro F.
  apply (univ_N1 _ _)^-1.
  refine (include_in_N1 _ o F)%functor.
Defined.

(** Computational rules  *)
Definition univ_N1_beta_ccleq {C : PreCategory}
           (Y : Type) {istrunc_Y : IsTrunc 1 Y}
           (F : Functor C (Core.groupoid_category Y))
           {c1 c2 : C} (f : morphism C c1 c2)
  : ap ((univ_N1 C Y)^-1 F) (ccleq C f) = (morphism_of F f).
Proof.
  unfold univ_N1. simpl.
  apply cquot_rec_beta_ccleq.
Defined.

Definition functor_N1_beta_ccleq {C D : PreCategory}
           (F : Functor C D)
           {c1 c2 : C} (f : morphism C c1 c2)
  : ap (functor_N1 F) (ccleq C f) =
    ccleq D (morphism_of F f).
Proof.
  unfold functor_N1.
  apply univ_N1_beta_ccleq.
Defined.

(** The 1-type completion preserves set truncation.  *)
Definition pi0_cat_N1 (C : PreCategory) :
  pi0_cat C <~> Trunc 0 (N1 C).
Proof.
  srapply @equiv_adjointify.
  - srapply @set_quotient_rec.
    + intro c. apply tr. apply (ccl C c).
    + simpl. intros x y f.
      apply (ap tr).
      apply ccleq. exact f.
  - srapply @Trunc_rec.
    srapply @cquot_rec.
    + apply class_of.
    + intros c d f.
      apply related_classes_eq. exact f.
    + simpl. intro c.
      apply set_quotient_set.
    + simpl. intros.
      apply set_quotient_set.
  - intro x. revert x.
    srefine (Trunc_ind _ _).
    srefine (cquot_ind_prop _ _ _).
    simpl. reflexivity.
  - intro x. revert x.
    srefine (set_quotient_ind_prop _ _ _).
    simpl. reflexivity.
Defined.


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.