(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                          Constructive Geometry                           *)
(*                             according to                                 *)
(*                            Jan von Plato                                 *)
(*                                                                          *)
(*                               Coq V5.10                                  *)
(*									    *)
(*			        Gilles Kahn 				    *)
(*				   INRIA                                    *)
(*		              Sophia-Antipolis		 	            *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work started in Turin in May 95 with Yves Bertot.  *)
(* Thanks to the Newton Institute for providing an exceptional work         *)
(* environment in Summer 1995 so that I could complete this.                *)
(****************************************************************************)

(****************************************************************************)
(*                               part1.v                                    *)
(*                                                                          *)
(* Congruence lemmas near the end slightly more explicit than in von Plato  *)
(****************************************************************************)
Require Import basis.

Theorem Uniqueness_of_constructed_lines :
 forall (x : Segment) (l : Line),
 Incident (origin x) l -> Incident (extremity x) l -> EqLn l (ln x).
Proof.
intros x l.
generalize (inc_ln2 x); generalize (inc_ln1 x).
unfold Incident, EqLn, Negation in |- *.
intros H' H'0 H'1 H'2; red in |- *; intro H'3.
lapply (el_ax x l (ln x)); trivial.
tauto.
Qed.

Theorem Convergent_imp_distinct : forall l m : Line, ConLn l m -> DiLn l m.
Proof.
intros l m H'.
lapply (cmp_con_diln l m l); trivial.
intro H'0; elim H'0; auto.
intro H'1; elim apart_con.
intro H'2; elim (H'2 l); trivial.
Qed.
Hint Resolve Convergent_imp_distinct.

Theorem Uniqueness_of_constructed_points :
 forall (x : Twolines) (a : Point),
 Incident a (line1 x) -> Incident a (line2 x) -> EqPt a (pt x).
Proof.
intro x.
generalize (inc_pt2 x); generalize (inc_pt1 x).
unfold Incident, EqPt, Negation in |- *.
intros H' H'0 a H'1 H'2; red in |- *; intro H'3.
lapply (el_ax (Seg a (pt x) H'3) (line1 x) (line2 x)); simpl in |- *.
tauto.
elim x; auto.
Qed.

Theorem cong_eqpt_apt :
 forall (a b : Point) (l : Line), Apart a l -> EqPt a b -> Apart b l.
Proof.
intros a b l H' H'0.
elim (cmp_apt_dipt a b l); auto.
intro H'1; elim H'0; trivial.
Qed.

Theorem cong_eqln_apt :
 forall (a : Point) (l m : Line), Apart a l -> EqLn l m -> Apart a m.
Proof.
intros a l m H' H'0.
elim (cmp_apt_diln a l m); auto.
intro H'1; elim H'0; trivial.
Qed.

Theorem cong_eqpt_inc :
 forall (a b : Point) (l : Line), Incident a l -> EqPt a b -> Incident b l.
Proof.
unfold Incident in |- *.
intros a b l H' H'0; red in |- *; intro H'1; apply H'.
apply cong_eqpt_apt with (a := b); auto.
Qed.

Theorem cong_eqln_inc :
 forall (a : Point) (l m : Line), Incident a l -> EqLn l m -> Incident a m.
Proof.
unfold Incident in |- *.
intros a l m H' H'0; red in |- *; intro H'1; apply H'.
apply cong_eqln_apt with (l := m); auto.
Qed.

Theorem cong_eqln_con :
 forall l m n : Line, ConLn l m -> EqLn m n -> ConLn l n.
Proof.
intros l m n H' H'0.
elim (cmp_con_diln l m n); auto.
intro H'1; elim H'0; trivial.
Qed.

Theorem cong_eqln_par : forall l m n : Line, Par l m -> EqLn m n -> Par l n.
Proof.
unfold Par, Negation in |- *.
intros l m n H' H'0; red in |- *; intro H'1; apply H'.
apply cong_eqln_con with (m := n); auto.
Qed.

Theorem cong_eqpt_dipt :
 forall a b c : Point, DiPt a b -> EqPt b c -> DiPt a c.
Proof.
intros a b c H' H'0; elim apart_dipt.
unfold Separating at 1 in |- *.
intros H'1 H'2; elim (H'2 a b c); trivial.
intro H'3; elim H'0; trivial.
Qed.

Theorem cong_eqln_diln :
 forall l m n : Line, DiLn l m -> EqLn m n -> DiLn l n.
Proof.
intros l m n H' H'0; elim apart_diln.
unfold Separating at 1 in |- *.
intros H'1 H'2; elim (H'2 l m n); trivial.
intro H'3; elim H'0; trivial.
Qed.

Theorem eqln_imp_par : forall l m : Line, EqLn l m -> Par l m.
Proof.
unfold Par, EqLn, Negation in |- *; red in |- *; auto.
Qed.

Theorem cong_par_con : forall l m n : Line, ConLn l m -> Par m n -> ConLn l n.
Proof.
intros l m n H' H'0.
elim apart_con.
unfold Separating at 1 in |- *.
intros H'1 H'2; elim (H'2 l m n); trivial.
intro H'3; elim H'0; trivial.
Qed.

Theorem sym_SPar : forall x y : Line, SPar x y -> SPar y x.
Proof.
unfold SPar in |- *.
intuition.
Qed.
Hint Resolve sym_SPar.

Theorem cong_eqln_spar :
 forall l m n : Line, SPar l m -> EqLn m n -> SPar l n.
Proof.
unfold SPar in |- *.
intros l m n H'; elim H'; intros H'0 H'1; try exact H'0; clear H'.
intro H'; split.
apply cong_eqln_par with (m := m); trivial.
apply cong_eqln_diln with (m := m); trivial.
Qed.

Definition reverse : Segment -> Segment.
Proof.
intro H'; elim H'.
intros a b H'0.
apply (Seg b a); auto.
Defined.

Theorem orig_rev : forall x : Segment, origin x = extremity (reverse x).
Proof.
intro x; elim x; simpl in |- *; auto.
Qed.

Theorem ext_rev : forall x : Segment, extremity x = origin (reverse x).
Proof.
intro x; elim x; simpl in |- *; auto.
Qed.

Theorem rev_defines_sameln : forall x : Segment, EqLn (ln x) (ln (reverse x)).
Proof.
intro x; apply Uniqueness_of_constructed_lines.
rewrite <- (ext_rev x); auto.
rewrite <- (orig_rev x); auto.
Qed.
Hint Resolve rev_defines_sameln.

Definition flip : Twolines -> Twolines.
Proof.
intro H'; elim H'.
intros l m H'0.
apply (Twol m l); auto.
Defined.

Theorem line1_flip : forall x : Twolines, line1 x = line2 (flip x).
Proof.
intro x; elim x; simpl in |- *; auto.
Qed.

Theorem line2_flip : forall x : Twolines, line2 x = line1 (flip x).
Proof.
intro x; elim x; simpl in |- *; auto.
Qed.

Theorem flip_defines_samept : forall x : Twolines, EqPt (pt x) (pt (flip x)).
Proof.
intro x; apply Uniqueness_of_constructed_points.
rewrite <- (line2_flip x); auto.
rewrite <- (line1_flip x); auto.
Qed.
Hint Resolve rev_defines_sameln flip_defines_samept.

Definition colinear (x y : Segment) : Prop := EqLn (ln x) (ln y).

Theorem Colinearity_is_equivalence : Equivalence Segment colinear.
Proof.
cut (Equivalence Line EqLn); auto.
intro H'; elim H'.
intros H'0 H'1 H'2; apply Definition_of_equivalence; unfold colinear in |- *;
 auto.
red in |- *.
intros x y z H'3 H'4.
red in H'2.
apply H'2 with (y := ln y); auto.
Qed.


Require Import Max.
Require Import Reals.
Require Import Lra.
Require Import RiemannInt.
Require Import Rfunction_classes_def.
Require Import Rextensionality.

Open Scope R_scope.

(*Replacing x by a word in RiemannInt_Px for x from 1 to 33*)

Section Copy_stdlib.

Lemma Riemann_integrable_opp_bound :
  forall (f:R -> R) (a b:R),
    Riemann_integrable f a b -> Riemann_integrable f b a.
Proof.
 apply RiemannInt_P1.
Qed.

Definition RinvN (N:nat) : posreal := mkposreal _ (RinvN_pos N).

Lemma Riemann_integrable_PI :
  forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b),
    RiemannInt pr1 = RiemannInt pr2.
Proof.
 apply RiemannInt_P5.
Qed.

Lemma Riemann_integrable_continuity :
  forall (f:R -> R) (a b:R),
    a < b ->
    (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
Proof.
 apply RiemannInt_P6.
Qed.

Lemma Riemann_integrable_singleton : forall (f:R -> R) (a:R), Riemann_integrable f a a.
Proof.
 apply RiemannInt_P7.
Qed.

Lemma Riemann_integrable_continuity_gen :
  forall (f:R -> R) (a b:R),
    a <= b ->
    (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
Proof.
 apply continuity_implies_RiemannInt.
Qed.

Lemma RiemannInt_bound_exchange :
  forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2.
Proof.
 apply RiemannInt_P8.
Qed.

Lemma RiemannInt_bound_exchange_1 :
  forall (f : R -> R) (a b : R) (pr1 : Riemann_integrable f a b),
    RiemannInt pr1 = - RiemannInt (Riemann_integrable_opp_bound f a b pr1).
Proof.
 intros. rewrite (RiemannInt_bound_exchange f a b pr1 (Riemann_integrable_opp_bound f a b pr1)).
 reflexivity.
Qed.

Lemma RiemannInt_singleton :
  forall (f:R -> R) (a:R) (pr:Riemann_integrable f a a), RiemannInt pr = 0.
Proof.
 apply RiemannInt_P9.
Qed.

Lemma Riemann_integrable_linear :
  forall (f g:R -> R) (a b l:R),
    Riemann_integrable f a b ->
    Riemann_integrable g a b ->
    Riemann_integrable (fun x:R => f x + l * g x) a b.
Proof.
 apply RiemannInt_P10.
Qed.

(*
TODO
Lemma RiemannInt_P11 :
  forall (f:R -> R) (a b l:R) (un:nat -> posreal)
    (phi1 phi2 psi1 psi2:nat -> StepFun a b),
    Un_cv un 0 ->
    (forall n:nat,
      (forall t:R,
        Rmin a b <= t <= Rmax a b -> Rabs (f t - phi1 n t) <= psi1 n t) /\
      Rabs (RiemannInt_SF (psi1 n)) < un n) ->
    (forall n:nat,
      (forall t:R,
        Rmin a b <= t <= Rmax a b -> Rabs (f t - phi2 n t) <= psi2 n t) /\
      Rabs (RiemannInt_SF (psi2 n)) < un n) ->
    Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) l ->
    Un_cv (fun N:nat => RiemannInt_SF (phi2 N)) l.
*)

Lemma RiemannInt_linear :
  forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable g a b)
    (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
    RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
Proof.
 apply RiemannInt_P13.
Qed.

Lemma Riemann_integrable_constant : forall a b c:R, Riemann_integrable (fct_cte c) a b.
Proof.
 apply RiemannInt_P14.
Qed.

Lemma RiemannInt_constant :
  forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b),
    RiemannInt pr = c * (b - a).
Proof.
 apply RiemannInt_P15.
Qed.

Lemma Riemann_integrable_Rabs :
  forall (f:R -> R) (a b:R),
    Riemann_integrable f a b -> Riemann_integrable (fun x:R => Rabs (f x)) a b.
Proof.
 apply RiemannInt_P16.
Qed.

Lemma RiemannInt_le_Rabs :
  forall (f:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable (fun x:R => Rabs (f x)) a b),
    a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2.
Proof.
 apply RiemannInt_P17.
Qed.

Lemma RiemannInt_ext :
  forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable g a b),
    a <= b ->
    (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2.
Proof.
 apply RiemannInt_P18.
Qed.

Lemma RiemannInt_le_ext :
  forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable g a b),
    a <= b ->
    (forall x:R, a < x < b -> f x <= g x) -> RiemannInt pr1 <= RiemannInt pr2.
Proof.
 apply RiemannInt_P19.
Qed.

Lemma RiemannInt_primitive :
  forall (f:R -> R) (a b:R) (h:a <= b)
    (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x)
    (pr0:Riemann_integrable f a b),
    RiemannInt pr0 = primitive h pr b - primitive h pr a.
Proof.
 apply RiemannInt_P20.
Qed.

Lemma Riemann_integrable_included_left :
  forall (f:R -> R) (a b c:R),
    Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c.
Proof.
 apply RiemannInt_P22.
Qed.

Lemma Riemann_integrable_included_right :
  forall (f:R -> R) (a b c:R),
    Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b.
Proof.
 apply RiemannInt_P23.
Qed.

Lemma Riemann_integrable_Chasles :
  forall (f:R -> R) (a b c:R),
    Riemann_integrable f a b ->
    Riemann_integrable f b c -> Riemann_integrable f a c.
Proof.
 apply RiemannInt_P24.
Qed.

Lemma RiemannInt_Chasles :
  forall (f:R -> R) (a b c:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
    RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
Proof.
 apply RiemannInt_P26.
Qed.

Lemma derivable_primitive :
  forall (f:R -> R) (a b x:R) (h:a <= b)
    (C0:forall x:R, a <= x <= b -> continuity_pt f x),
    a <= x <= b -> derivable_pt_lim (primitive h (FTC_P1 h C0)) x (f x).
Proof.
 apply RiemannInt_P28.
Qed.

(*
TODO to be done
Lemma RiemannInt_P29 :
  forall (f:R -> R) a b (h:a <= b)
    (C0:forall x:R, a <= x <= b -> continuity_pt f x),
    antiderivative f (primitive h (FTC_P1 h C0)) a b.

Lemma RiemannInt_P30 :
  forall (f:R -> R) (a b:R),
    a <= b ->
    (forall x:R, a <= x <= b -> continuity_pt f x) ->
    { g:R -> R | antiderivative f g a b }.

Record C1_fun : Type := mkC1
  {c1 :> R -> R; diff0 : derivable c1; cont1 : continuity (derive c1 diff0)}.

Lemma RiemannInt_P31 :
  forall (f:C1_fun) (a b:R),
    a <= b -> antiderivative (derive f (diff0 f)) f a b.

Lemma RiemannInt_P32 :
  forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b.

Lemma RiemannInt_P33 :
  forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
    a <= b -> RiemannInt pr = f b - f a.
TODO refaire FTC_Riemann avec C.
Lemma FTC_Riemann :
  forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
    RiemannInt pr = f b - f a.
*)

End Copy_stdlib.

Lemma RiemannInt_integrable_eq_compat : forall f g a b, (forall x, f x = g x) ->
  Riemann_integrable f a b -> Riemann_integrable g a b.
intros f g a b H X eps.
elim X with eps;intros x p; exists x.
elim p; intros x0 [p01 p02]; exists x0.
split; intros; [ rewrite <- (H t); apply p01 | ]; assumption.
Qed.

Lemma RiemannInt_integrable_minus : forall (f g:R -> R) (a b:R)
   (prf:Riemann_integrable f a b)
   (prg:Riemann_integrable g a b), (Riemann_integrable (fun x => f x - g x) a b).
Proof.
intros.
apply RiemannInt_integrable_eq_compat with (fun x => f x + (-1) * g x); [intros; ring|].
apply RiemannInt_P10; assumption.
Qed.

Lemma RiemannInt_minus :
  forall (f g:R -> R) (a b:R)
   (prf:Riemann_integrable f a b)
   (prg:Riemann_integrable g a b)
   (prfg:Riemann_integrable (fun x:R => f x - g x) a b),
     a<=b -> RiemannInt prfg = RiemannInt prf - RiemannInt prg.
Proof.
intros.
assert (REW: forall x y, x - y = x + (-1)*y) by (intros; ring); rewrite REW; clear REW.
pose proof (RiemannInt_P10 (-1) prf prg) as prfg'.
replace (RiemannInt prfg) with (RiemannInt prfg').
apply RiemannInt_P13.
apply RiemannInt_P18 ; intuition.
ring.
Qed.

Lemma RiemannInt_minus_1 :
  forall (f g:R -> R) (a b:R)
   (prf:Riemann_integrable f a b)
   (prg:Riemann_integrable g a b),
     a<=b -> RiemannInt prf - RiemannInt prg = RiemannInt (RiemannInt_integrable_minus f g a b prf prg).
Proof.
 intros. rewrite (RiemannInt_minus _ _ _ _ prf prg) ; intuition.
Qed.

Lemma RiemannInt_linear_1 :
  forall (f g:R -> R) (a b l:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable g a b),
    RiemannInt pr1 + l * RiemannInt pr2 = RiemannInt (Riemann_integrable_linear f g a b l pr1 pr2).
Proof.
 intros. symmetry. apply RiemannInt_linear.
Qed.

Lemma Riemann_integrable_add :
   forall (f g:R -> R) (a b:R) (pr1:Riemann_integrable f a b)
    (pr2:Riemann_integrable g a b),
      Riemann_integrable (f + g)%F a b.
Proof.
 intros. apply RiemannInt_integrable_eq_compat with (fun x => f x + 1 * g x).
  intros. unfold plus_fct. ring.  apply Riemann_integrable_linear ; assumption.
Qed.

Lemma RiemannInt_add :
  forall (f g:R -> R) (a b:R) (prf:Riemann_integrable f a b)
    (prg:Riemann_integrable g a b) (prfg:Riemann_integrable (f + g)%F a b), a <= b ->
    RiemannInt prf + RiemannInt prg = RiemannInt prfg.
Proof.
 intros.
 pose proof (RiemannInt_P10 1 prf prg) as prfg'.
 replace (RiemannInt prfg) with (RiemannInt prfg').
  replace (RiemannInt prg) with (1 * RiemannInt prg) by ring.
  symmetry. apply RiemannInt_P13.

  apply RiemannInt_P18 ; intuition. unfold plus_fct. ring.
Qed.

Lemma RiemannInt_add_1 :
 forall (f g:R -> R) (a b:R) (prf:Riemann_integrable f a b)
    (prg:Riemann_integrable g a b), a <= b ->
    RiemannInt prf + RiemannInt prg = RiemannInt (Riemann_integrable_add f g a b prf prg).
Proof.
 intros.
 apply RiemannInt_add. apply H.
Qed.

Hint Rewrite RiemannInt_minus_1 : Rintegrals.
Hint Rewrite RiemannInt_linear_1 : Rintegrals.
Hint Rewrite RiemannInt_add_1 : Rintegrals.

Lemma continuity_RiemannInt_1 :
  forall (f:R -> R) (a b:R),
    (forall x:R, a <= x <= b \/ b <= x <= a -> continuity_pt f x) -> Riemann_integrable f a b.
Proof.
  intros; case (total_order_T a b); intro.
   elim s ; intro.
    apply RiemannInt_P6. assumption. intros. apply H. intuition.

    subst; apply RiemannInt_P7.

    apply Riemann_integrable_opp_bound. apply RiemannInt_P6. intuition.
     intros. apply H. intuition.
Qed.

(* TODO EN COURS copie de std lib Raffinage en cours *)
Lemma RiemannInt_derivable_pt_lim :
  forall (f:R -> R) (a x:R)
    (pr:forall x y:R,  Riemann_integrable f x y)
      (Hcont:continuity_pt f x),
      derivable_pt_lim (fun t1 => @RiemannInt f a t1 (pr a t1)) x (f x).
Proof.
 intros.
 unfold derivable_pt_lim. intros.
 (* epsilon is eps / 2 *)
 assert (H4:0 < eps / 2) by lra.
 destruct (Hcont _ H4) as [x1 [Hcont1 Hcont2]].
 exists (mkposreal _ Hcont1). (* TODO c'est pas le bon epsilon *)
 (* epsilon is eps / 2 end *)
 intros.
(* rewriting *)
 rewrite <- (RiemannInt_Chasles f a x (x+h) (pr a x) (pr x (x + h)) (pr a (x + h))).
 ring_simplify ((RiemannInt (pr a x) + RiemannInt (pr x (x + h)) - RiemannInt (pr a x))).
 replace (f x) with (RiemannInt (Riemann_integrable_constant x (x + h) (f x)) / h)
  by (rewrite RiemannInt_constant; field; assumption).
  replace
  (RiemannInt (pr x (x + h)) / h - RiemannInt (Riemann_integrable_constant x (x + h) (f x)) / h)
    with ((RiemannInt (pr x (x + h)) + (-1) *  RiemannInt (Riemann_integrable_constant x (x + h) (f x))) / h)
      by (unfold Rdiv ; ring).
  rewrite RiemannInt_linear_1.
(* end rewritiing *)
  unfold Rdiv in |- *; rewrite Rabs_mult; case (Rle_dec x (x + h)); intro.
(* case x <= x + h *)
(* passage de Rabs à l'interieur *)
  apply Rle_lt_trans with
     (RiemannInt
       (Riemann_integrable_Rabs _ _ _
         (Riemann_integrable_linear _ _ _ _ (-1) (pr x (x + h)) (Riemann_integrable_constant x (x + h) (f x)))) *
       Rabs (/ h)).
(* Preuve de Rabs int <= int Rabs *)
    do 2 rewrite <- (Rmult_comm (Rabs (/ h))); apply Rmult_le_compat_l.
    apply Rabs_pos. apply RiemannInt_le_Rabs. assumption.

(* Suite de la preuve avec int Rabs *)
    apply Rle_lt_trans with
      (RiemannInt (Riemann_integrable_constant x (x + h) (eps / 2)) * Rabs (/ h)).
  do 2 rewrite <- (Rmult_comm (Rabs (/ h))); apply Rmult_le_compat_l.
  apply Rabs_pos.
  apply RiemannInt_P19; try assumption.
(* rewriting *)
  intros; replace (f x0 + -1 * fct_cte (f x) x0) with (f x0 - f x) by (intros ; unfold fct_cte ; simpl ; ring).
  unfold fct_cte.
(* end rewriting *)
(* x <> x0 *)
  assert (x <> x0) by (intro ; subst ; destruct H2 ; lra).
(* end x <> x0 *)
(* TODO pas besoin de x <= x+h là dedans*)
  left. simpl in *. unfold R_dist in *. apply Hcont2.
  unfold D_x, no_cond. repeat split. assumption.
  eapply Rlt_trans ; [|apply H1].
  assert (0 < x0 - x < h) by (intuition ; lra).
  rewrite Rabs_pos_eq. rewrite Rabs_pos_eq. intuition.
  apply Rle_trans with (x0 - x) ; intuition. intuition.
(* end TODO *)

(*  rewrite Rabs_right.
  apply Rplus_lt_reg_r with x; replace (x + (x1 - x)) with x1; [ idtac | ring ].
  apply Rlt_le_trans with (x + h). ring_simplify. apply H2.
   apply Rplus_le_compat_l. apply Rle_trans with x1. left.
   apply Rle_lt_trans with (Rabs h). apply RRle_abs. apply H1.
   (*unfold del.*) (*apply Rmin_l.*) right. reflexivity.
   destruct H2. lra.*)
(* TODO here need eps / 2 et x <= x + h*)
  rewrite RiemannInt_constant.
  rewrite Rmult_assoc; replace ((x + h - x) * Rabs (/ h)) with 1.
  ring_simplify. lra.
  rewrite Rabs_right.
  replace (x + h - x) with h; [ idtac | ring ].
  apply Rinv_r_sym.
  assumption.
  apply Rle_ge; left; apply Rinv_0_lt_compat.
  elim r; intro.
  apply Rplus_lt_reg_r with x; rewrite Rplus_comm, Rplus_0_r, Rplus_comm. assumption.
  elim H0; symmetry  in |- *; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
    assumption.

(* case ~ x <= x + h *)
(* on insere la valeur absolu en echangeant les bornes *)
  apply Rle_lt_trans with
    (RiemannInt
      (Riemann_integrable_Rabs _ _ _
         (Riemann_integrable_opp_bound _ _ _
          (Riemann_integrable_linear f (fct_cte (f x)) x
           (x + h) (-1) (pr x (x + h))
           (Riemann_integrable_constant x (x + h) (f x))))) *
      Rabs (/ h)).
  do 2 rewrite <- (Rmult_comm (Rabs (/ h))); apply Rmult_le_compat_l.
  apply Rabs_pos.
  rewrite RiemannInt_bound_exchange_1.
  rewrite Rabs_Ropp.
  apply RiemannInt_le_Rabs. left. intuition.
   apply Rle_lt_trans with
    (RiemannInt (Riemann_integrable_constant (x + h) x (eps / 2)) * Rabs (/ h)).
  do 2 rewrite <- (Rmult_comm (Rabs (/ h))); apply Rmult_le_compat_l.
  apply Rabs_pos.
  apply RiemannInt_le_ext.
  auto with real.
  intros. unfold fct_cte in *. ring_simplify (-1 * f x).
  intros; replace (f x0 + -1 * fct_cte (f x) x0) with (f x0 - f x).
  unfold fct_cte in |- *; case (Req_dec x x0); intro.
  rewrite H3. ring_simplify (f x0 + - f x0). rewrite Rabs_R0; left;
    assumption.
  left; simpl in Hcont2 ; ring_simplify (f x0 + -1 * f x) ; apply Hcont2.
  repeat split.
  assumption.
  unfold R_dist. rewrite Rabs_left.
  apply Rplus_lt_reg_r with (x0 - x1); replace (x0 - x1 + x1) with x0 by ring.
  replace (- (x0 - x) + (x0 - x1)) with (x - x1) by ring.
  apply Rle_lt_trans with (x + h).
  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
  rewrite Ropp_involutive; apply Rle_trans with (Rabs h).

  rewrite <- Rabs_Ropp; apply RRle_abs.
  apply Rle_trans with x1;
    [ left; assumption | idtac ]. right. reflexivity.
  ring_simplify. now intuition.
  apply Rplus_lt_reg_r with x. ring_simplify. now intuition.
  unfold fct_cte in |- *; ring.
  rewrite RiemannInt_P15.
  rewrite Rmult_assoc; replace ((x - (x + h)) * Rabs (/ h)) with 1.
  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
    [ prove_sup0
      | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
        rewrite <- Rinv_r_sym;
          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
            rewrite double; apply Rplus_lt_compat_l; assumption
            | discrR ] ].
  rewrite Rabs_left.
  replace (x - (x + h)) with (- h); [ idtac | ring ].
  rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_mult_distr_r_reverse;
    rewrite Ropp_involutive; apply Rinv_r_sym.
  assumption.
  apply Rinv_lt_0_compat.
  assert (H8 : x + h < x).
  auto with real.
  apply Rplus_lt_reg_r with x. ring_simplify. rewrite Rplus_comm; assumption.
Qed.

Lemma RiemannInt_derivable_pt :
  forall (f:R -> R) (a x:R)
    (pr:forall x y:R,  Riemann_integrable f x y)
      (Hcont:continuity_pt f x),
      derivable_pt (fun t1 => @RiemannInt f a t1 (pr a t1)) x.
Proof.
 intros.
 unfold derivable_pt, derivable_pt_abs.
 exists (f x). apply RiemannInt_derivable_pt_lim.
assumption.
Qed.

Lemma derive_pt_RiemannInt :
  forall (f:R -> R) (a x:R)
    (pr:forall x y:R,  Riemann_integrable f x y)
      (Hcont:continuity_pt f x),
        derive_pt (fun t => RiemannInt (pr a t)) x (RiemannInt_derivable_pt f a x pr Hcont) = f x.
Proof.
intros.
rewrite derive_pt_eq. apply RiemannInt_derivable_pt_lim.
apply Hcont.
Qed.

Lemma derive_pt_RiemannInt_1 :
  forall (f:R -> R) (a x:R)
    (pr:forall x y:R,  Riemann_integrable f x y)
      (Hcont:continuity_pt f x) H1,
        derive_pt (fun t => RiemannInt (pr a t)) x H1 = f x.
Proof.
intros.
rewrite derive_pt_eq. apply RiemannInt_derivable_pt_lim.
apply Hcont.
Qed.

(* This lemma uses extentionality of continuity*)
Lemma derivable_pt_continuity_Riemann_implies_C1 :
  forall f t0 (pr:forall t t0, Riemann_integrable f t t0), continuity f ->
    C 1 (fun t => RiemannInt (pr t0 t)).
Proof.
intros.
assert (derivable (fun t => RiemannInt (pr t0 t))).
intro. apply RiemannInt_derivable_pt. apply H.
apply (C_S _ _ H0).
apply C_0. apply continuity_ext with f.
intro. unfold derive. rewrite derive_pt_RiemannInt_1.
reflexivity.
apply H. apply H.
Qed.

(* TODO EN COURS preuve à changer pour ne pas utiliser la preuve sur derivable. *)
Lemma RiemannInt_continuity : forall a t0 (Hconta : continuity a) (Ha : forall t0 t,
   Riemann_integrable a t0 t), continuity (fun t => RiemannInt (Ha t0 t)).
Proof.
 intros.
 apply derivable_continuous. unfold derivable. intros. apply RiemannInt_derivable_pt.
 apply Hconta.
Qed.


From QuickChick Require Import QuickChick.
Require Import ZArith.
Require Import List.

From QuickChick.ifcbasic Require Import Machine.

Fixpoint forallb2 {A : Type} (f : A -> A -> bool) (l1 l2 :list A) : bool :=
  match l1, l2 with
    | nil, nil => true
    | cons h1 t1, cons h2 t2 => f h1 h2 && forallb2 f t1 t2
    | _, _ => false
  end.

(* Indistinguishability type class *)
Class Indist (A : Type) : Type :=
{
  indist : A -> A -> bool
}.

Instance indist_atom : Indist Atom :=
{|
  indist a1 a2 :=
    let '(x1@l1) := a1 in
    let '(x2@l2) := a2 in
    match l1, l2 with
      | L, L => Z.eqb x1 x2
      | H, H => true
      | _, _ => false
    end
|}.

Instance indist_mem : Indist Mem :=
{|
  indist m1 m2 := forallb2 indist m1 m2
|}.

Fixpoint cropTop (s:Stack) : Stack :=
  match s with
    | Mty        => Mty
    | x::s'      => cropTop s'
    | (x@H:::s') => cropTop s'
    | (_@L:::_)  => s
  end.

(* Assumes stacks have been cropTopped! *)
Instance indist_stack : Indist Stack :=
{|
  indist s1 s2 :=
    let fix aux s1 s2 :=
        match s1, s2 with
          | a1::s1', a2::s2' => indist a1 a2 && aux s1' s2'
          | a1:::s1', a2:::s2' => indist a1 a2 && aux s1' s2'
          | Mty, Mty => true
          | _, _ => false
        end
    in aux s1 s2
|}.

Instance indist_state : Indist State :=
{|
  indist st1 st2 :=
    let '(St imem1 mem1 stk1 pc1) := st1 in
    let '(St imem2 mem2 stk2 pc2) := st2 in
    if negb (indist mem1 mem2) then (* trace "Memory" *) false
    else if negb (indist pc1 pc2) then (* trace "PC" *) false
    else let (stk1',stk2') :=
           match pc1 with
             | _ @ H => (cropTop stk1, cropTop stk2)
             | _ => (stk1, stk2)
           end in
    if negb (indist stk1' stk2') then (* trace "Stack" *) false
    else true
|}.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import SeqProp.
Require Import Max.
Local Open Scope R_scope.

Theorem R_complete :
forall Un:nat -> R, Cauchy_crit Un -> { l:R | Un_cv Un l } .
Proof. hammer_hook "Rcomplete" "Rcomplete.R_complete".
intros.
set (Vn := sequence_minorant Un (cauchy_min Un H)).
set (Wn := sequence_majorant Un (cauchy_maj Un H)).
pose proof (maj_cv Un H) as (x,p).
fold Wn in p.
pose proof (min_cv Un H) as (x0,p0).
fold Vn in p0.
cut (x = x0).
intros H2.
exists x.
rewrite <- H2 in p0.
unfold Un_cv.
intros.
unfold Un_cv in p; unfold Un_cv in p0.
cut (0 < eps / 3).
intro H4.
elim (p (eps / 3) H4); intros.
elim (p0 (eps / 3) H4); intros.
exists (max x1 x2).
intros.
unfold R_dist.
apply Rle_lt_trans with (Rabs (Un n - Vn n) + Rabs (Vn n - x)).
replace (Un n - x) with (Un n - Vn n + (Vn n - x));
[ apply Rabs_triang | ring ].
apply Rle_lt_trans with (Rabs (Wn n - Vn n) + Rabs (Vn n - x)).
do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
apply Rplus_le_compat_l.
repeat rewrite Rabs_right.
unfold Rminus; do 2 rewrite <- (Rplus_comm (- Vn n));
apply Rplus_le_compat_l.
assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
fold Vn Wn in H8.
elim (H8 n); intros.
assumption.
apply Rle_ge.
unfold Rminus; apply Rplus_le_reg_l with (Vn n).
rewrite Rplus_0_r.
replace (Vn n + (Wn n + - Vn n)) with (Wn n); [ idtac | ring ].
assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
fold Vn Wn in H8.
elim (H8 n); intros.
apply Rle_trans with (Un n); assumption.
apply Rle_ge.
unfold Rminus; apply Rplus_le_reg_l with (Vn n).
rewrite Rplus_0_r.
replace (Vn n + (Un n + - Vn n)) with (Un n); [ idtac | ring ].
assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
fold Vn Wn in H8.
elim (H8 n); intros.
assumption.
apply Rle_lt_trans with (Rabs (Wn n - x) + Rabs (x - Vn n) + Rabs (Vn n - x)).
do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
apply Rplus_le_compat_l.
replace (Wn n - Vn n) with (Wn n - x + (x - Vn n));
[ apply Rabs_triang | ring ].
apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3).
repeat apply Rplus_lt_compat.
unfold R_dist in H1.
apply H1.
unfold ge; apply le_trans with (max x1 x2).
apply le_max_l.
assumption.
rewrite <- Rabs_Ropp.
replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ].
unfold R_dist in H3.
apply H3.
unfold ge; apply le_trans with (max x1 x2).
apply le_max_r.
assumption.
unfold R_dist in H3.
apply H3.
unfold ge; apply le_trans with (max x1 x2).
apply le_max_r.
assumption.
right.
pattern eps at 4; replace eps with (3 * (eps / 3)).
ring.
unfold Rdiv; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR.
unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
apply cond_eq.
intros.
cut (0 < eps / 5).
intro.
unfold Un_cv in p; unfold Un_cv in p0.
unfold R_dist in p; unfold R_dist in p0.
elim (p (eps / 5) H1); intros N1 H4.
elim (p0 (eps / 5) H1); intros N2 H5.
unfold Cauchy_crit in H.
unfold R_dist in H.
elim (H (eps / 5) H1); intros N3 H6.
set (N := max (max N1 N2) N3).
apply Rle_lt_trans with (Rabs (x - Wn N) + Rabs (Wn N - x0)).
replace (x - x0) with (x - Wn N + (Wn N - x0)); [ apply Rabs_triang | ring ].
apply Rle_lt_trans with
(Rabs (x - Wn N) + Rabs (Wn N - Vn N) + Rabs (Vn N - x0)).
rewrite Rplus_assoc.
apply Rplus_le_compat_l.
replace (Wn N - x0) with (Wn N - Vn N + (Vn N - x0));
[ apply Rabs_triang | ring ].
replace eps with (eps / 5 + 3 * (eps / 5) + eps / 5).
repeat apply Rplus_lt_compat.
rewrite <- Rabs_Ropp.
replace (- (x - Wn N)) with (Wn N - x); [ apply H4 | ring ].
unfold ge, N.
apply le_trans with (max N1 N2); apply le_max_l.
unfold Wn, Vn.
unfold sequence_majorant, sequence_minorant.
assert
(H7 :=
approx_maj (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
assert
(H8 :=
approx_min (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
cut
(Wn N =
majorant (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
cut
(Vn N =
minorant (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
intros H9 H10.
rewrite <- H9 in H8 |- *.
rewrite <- H10 in H7 |- *.
elim (H7 (eps / 5) H1); intros k2 H11.
elim (H8 (eps / 5) H1); intros k1 H12.
apply Rle_lt_trans with
(Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Vn N)).
replace (Wn N - Vn N) with
(Wn N - Un (N + k2)%nat + (Un (N + k2)%nat - Vn N));
[ apply Rabs_triang | ring ].
apply Rle_lt_trans with
(Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Un (N + k1)%nat) +
Rabs (Un (N + k1)%nat - Vn N)).
rewrite Rplus_assoc.
apply Rplus_le_compat_l.
replace (Un (N + k2)%nat - Vn N) with
(Un (N + k2)%nat - Un (N + k1)%nat + (Un (N + k1)%nat - Vn N));
[ apply Rabs_triang | ring ].
replace (3 * (eps / 5)) with (eps / 5 + eps / 5 + eps / 5);
[ repeat apply Rplus_lt_compat | ring ].
assumption.
apply H6.
unfold ge.
apply le_trans with N.
unfold N; apply le_max_r.
apply le_plus_l.
unfold ge.
apply le_trans with N.
unfold N; apply le_max_r.
apply le_plus_l.
rewrite <- Rabs_Ropp.
replace (- (Un (N + k1)%nat - Vn N)) with (Vn N - Un (N + k1)%nat);
[ assumption | ring ].
reflexivity.
reflexivity.
apply H5.
unfold ge; apply le_trans with (max N1 N2).
apply le_max_r.
unfold N; apply le_max_l.
pattern eps at 4; replace eps with (5 * (eps / 5)).
ring.
unfold Rdiv; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
discrR.
unfold Rdiv; apply Rmult_lt_0_compat.
assumption.
apply Rinv_0_lt_compat.
prove_sup0; try apply lt_O_Sn.
Qed.


(** Basic definitions added to the standard library. *)

Ltac inv H := inversion H; subst; clear H.

Definition first {A B C} (f : A -> C) (p : A * B) : C * B :=
  (f (fst p), snd p).

Definition second {A B C} (f : B -> C) (p : A * B) : A * C :=
  (fst p, f (snd p)).

Require Import
  Coq.Sets.Ensembles
  ByteString.Lib.Same_set.

Definition Map_set {A B} (f : A -> B) (r : Ensemble A) : Ensemble B :=
  fun b => exists a : A, In _ r a /\ b = f a.

Lemma Map_set_left_identity {A} (r : Ensemble A) : Same_set A r (Map_set id r).
Proof.
  unfold Map_set; split; intros.
    eexists; intuition.
    assumption.
  intros ??.
  do 2 destruct H.
  unfold id in H0.
  congruence.
Qed.

Lemma Map_set_right_identity {A} (r : Ensemble A) : Same_set A (Map_set id r) r.
Proof.
  unfold Map_set; split; intros.
    intros ??.
    do 2 destruct H.
    unfold id in H0.
    congruence.
  eexists; intuition.
  assumption.
Qed.

Lemma Map_set_composition {A B C} (r : Ensemble A) :
  forall (f : B -> C) (g : A -> B),
   Same_set C (Map_set (fun x => f (g x)) r) (Map_set f (Map_set g r)).
Proof.
  unfold Map_set; split; intros; intros ??.
    do 2 destruct H; subst.
    exists (g x0); simpl in *.
    split; trivial.
    exists x0; simpl.
    intuition.
  do 2 destruct H; subst.
  do 2 destruct H; simpl in *; subst.
  exists x; simpl in *.
  intuition.
Qed.

Definition Product {T U} (X : Ensemble T) (Y : Ensemble U) : Ensemble (T * U) :=
  fun p => In T X (fst p) /\ In U Y (snd p).

Lemma Product_Add_left : forall T U (X : Ensemble T) (Y : Ensemble U) x,
  Same_set _ (Product (Add T X x) Y)
             (Union _ (Product (Singleton _ x) Y) (Product X Y)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *;
  destruct H;
  destruct x0; simpl in *;
  destruct H.
  - right; constructor; simpl; auto.
  - left; constructor; simpl; auto.
  - simpl in *; intuition; right; intuition.
  - simpl in *; intuition; left; intuition.
Qed.

Lemma Product_Add_right : forall T (X : Ensemble T) U (Y : Ensemble U) y,
  Same_set _ (Product X (Add U Y y))
             (Union _ (Product X Y) (Product X (Singleton _ y))).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *;
  destruct H;
  destruct x; simpl in *.
  - destruct H0.
    + left; constructor; simpl; auto.
    + right; constructor; simpl; auto.
  - destruct H. intuition; left; intuition.
  - destruct H. intuition; right; intuition.
Qed.

Lemma Product_Empty_set_left : forall T U (X : Ensemble U),
  Same_set _ (Product (Empty_set T) X) (Empty_set (T * U)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *.
  destruct H;
  destruct x; simpl in *;
  destruct H.
  destruct H.
Qed.

Lemma Product_Empty_set_right : forall T (X : Ensemble T) U,
  Same_set _ (Product X (Empty_set U)) (Empty_set (T * U)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *.
  destruct H;
  destruct x; simpl in *.
  destruct H0.
  destruct H.
Qed.

Lemma Product_Singleton_Singleton : forall T U x y,
  Same_set _ (Product (Singleton T x) (Singleton U y))
             (Singleton (T * U) (x, y)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *;
  destruct H.
    inversion H; subst; clear H.
    inversion H0; subst; clear H0.
    rewrite <- surjective_pairing.
    constructor.
  simpl.
  intuition.
Qed.

Lemma nth_plus_one : forall A (x : A) xs e off,
  (0 < off)%nat -> List.nth off (x :: xs) e = List.nth (off - 1) xs e.
Proof.
  intros.
  destruct off.
    firstorder.
  simpl.
  rewrite NPeano.Nat.sub_0_r.
  reflexivity.
Qed.

Lemma fst_match_list :
  forall A (xs : list A) B z C z'
         (f : A -> list A -> B) (f' : A -> list A -> C),
    fst match xs with
        | List.nil => (z, z')
        | List.cons x xs => (f x xs, f' x xs)
        end = match xs with
              | List.nil => z
              | List.cons x xs => f x xs
              end.
Proof. induction xs; auto. Qed.

Lemma snd_match_list :
  forall A (xs : list A) B z C z'
         (f : A -> list A -> B) (f' : A -> list A -> C),
    snd match xs with
        | List.nil => (z, z')
        | List.cons x xs => (f x xs, f' x xs)
        end = match xs with
              | List.nil => z'
              | List.cons x xs => f' x xs
              end.
Proof. induction xs; auto. Qed.


Set Implicit Arguments.

Ltac inv H := inversion H; subst; clear H.

Definition dec (X: Prop) : Type := {X} + {~ X}.

Existing Class dec.

Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> (if Dec X then true else false) = true.
Proof.
  destruct d as [A|A]; cbn; intuition congruence.
Qed.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

(* Propagation rules for decisions *)

#[export] Instance True_dec : dec True.
Proof. unfold dec; tauto. Qed.

#[export] Instance False_dec : dec False.
Proof. unfold dec; tauto. Qed.

#[export] Instance impl_dec (X Y : Prop) : dec X -> dec Y -> dec (X -> Y).
Proof. unfold dec; tauto. Qed.

#[export] Instance and_dec (X Y : Prop) : dec X -> dec Y -> dec (X /\ Y).
Proof. unfold dec; tauto. Qed.

#[export] Instance or_dec (X Y : Prop) : dec X -> dec Y -> dec (X \/ Y).
Proof. unfold dec; tauto. Qed.

(* Coq standard modules make "not" and "iff" opaque for type class inference,
   can be seen with Print HintDb typeclass_instances. *)

#[export] Instance not_dec (X : Prop) : dec X -> dec (~ X).
Proof. unfold not. exact _. Qed.

#[export] Instance iff_dec (X Y : Prop) : dec X -> dec Y -> dec (X <-> Y).
Proof. unfold iff. exact _. Qed.

(* Discrete types *)

Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

#[export] Instance unit_eq_dec : eq_dec unit.
Proof. unfold dec. decide equality. Qed.

#[export] Instance bool_eq_dec : eq_dec bool.
Proof. unfold dec. decide equality. Defined.

#[export] Instance nat_eq_dec : eq_dec nat.
Proof. unfold dec. decide equality. Defined.

#[export] Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof. unfold dec. decide equality. Defined.

#[export] Instance list_eq_dec X : eq_dec X -> eq_dec (list X).
Proof. unfold dec. decide equality. Defined.

#[export] Instance sum_eq_dec X Y : eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof. unfold dec. decide equality. Defined.

#[export] Instance option_eq_dec X : eq_dec X -> eq_dec (option X).
Proof. unfold dec. decide equality. Defined.

#[export] Instance Empty_set_eq_dec : eq_dec Empty_set.
Proof. unfold dec. decide equality. Qed.

#[export] Instance True_eq_dec : eq_dec True.
Proof. intros x y. destruct x,y. now left. Qed.

#[export] Instance False_eq_dec : eq_dec False.
Proof. intros []. Qed.


Require Export prosa.model.priority.classes.
Require Export prosa.model.schedule.preemption_time.

(** * Priority-Driven Schedules *)

(** We now define what it means for a schedule to respect a priority in the
    presence of jobs with non-preemptive segments.  We only specify a
    definition for JLDP policies since JLFP and FP policies can be used with
    this definition through the canonical conversions (see
    model.priority.classes).

    NB: For legacy reasons, the below definition is currently specific to ideal
        uniprocessor schedules. Removal of this limitation is future work. *)

(** Throughout this file, we assume ideal uniprocessor schedules. *)
Require prosa.model.processor.ideal.

Section Priority.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.

  (** Suppose jobs have an arrival time, a cost, ... *)
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** ... and consider any preemption model and notion of readiness. *)
  Context `{JobPreemptable Job}.
  Context `{JobReady Job (ideal.processor_state Job)}.

  (** Given any job arrival sequence... *)
  Variable arr_seq : arrival_sequence Job.

  (** ...and an ideal uniprocessor schedule of these jobs, *)
  Variable sched : schedule (ideal.processor_state Job).

  (** we say that a JLDP policy ...*)
  Context `{JLDP_policy Job}.

  (** ...is respected by the schedule iff, at every preemption point, the
     priority of the scheduled job is higher than or equal to the priority of
     any backlogged job. *)
  Definition respects_policy_at_preemption_point :=
    forall j j_hp t,
      arrives_in arr_seq j ->
      preemption_time sched t ->
      backlogged sched j t ->
      scheduled_at sched j_hp t ->
      hep_job_at t j_hp j.

End Priority.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import MyRIneq.
Require Import Rinterval Ranalysis_def Ranalysis_def_simpl Ranalysis_continuity.
Require Import Ranalysis_derivability Ranalysis_usual Ranalysis_facts Ranalysis_MVT.
Require Import Canalysis_diff.
Require Import Cprop_base.
Require Import Cnorm.
Require Import Ctacfield.
Require Import Cmet.
Require Import Canalysis_def.
Require Import Cderiv.

Open Scope C_scope.

(**********)
Lemma uniqueness_step1 : forall f x l1 l2,
    limit1_in (fun h => (f (x + h) - f x) / h) (fun h => h <> 0) l1 0 ->
    limit1_in (fun h => (f (x + h) - f x) / h) (fun h => h <> 0) l2 0 ->
    l1 = l2.
Proof.
intros f x l1 l2 Hl1 Hl2 ;
 apply (single_limit (fun h => (f (x + h) - f x) / h) (fun h => h <> 0) l1 l2 0);
 try assumption.
 intros alpha alpha_pos ; exists (IRC (alpha / 2)) ; split.
 apply (proj2 (C0_neq_R0_neq _)) ; left ; simpl ; apply Rgt_not_eq ; lra.
 unfold C_dist ; rewrite Cminus_0_r ; rewrite Cnorm_IRC_Rabs ;
 rewrite Rabs_right ; lra.
Qed.

Lemma uniqueness_step2 : forall f x l,
    derivable_pt_lim f x l ->
    limit1_in (fun h => (f (x + h) - f x) / h) (fun h : C => h <> C0) l C0.
Proof.
unfold derivable_pt_lim, limit1_in, limit_in.
intros f x l Hf_deriv eps eps_pos ; destruct (Hf_deriv eps eps_pos)
 as ([alpha alpha_pos], Halpha) ; clear Hf_deriv ; exists alpha ; split ;
 [assumption |] ; intros h [h_neq Hh] ; simpl in * ; unfold C_dist in Hh ;
 rewrite Cminus_0_r in Hh. unfold C_dist. apply Halpha ; intuition.
Qed.

Lemma uniqueness_step3 : forall f x l,
    limit1_in (fun h => (f (x + h) - f x) / h) (fun h => h <> 0) l 0 ->
    derivable_pt_lim f x l.
Proof.
unfold limit1_in, derivable_pt_lim, limit_in, C_dist ; simpl ; unfold C_dist ;
intros f x l Hf_lim eps eps_pos ; destruct (Hf_lim eps eps_pos) as
 (alpha, [alpha_pos Halpha]) ; clear Hf_lim ;
 exists (mkposreal alpha alpha_pos) ; intros h h_neq Hyp ;
 apply Halpha ; rewrite Cminus_0_r ; split ; assumption.
Qed.

Lemma uniqueness_limite : forall f x l1 l2,
    derivable_pt_lim f x l1 -> derivable_pt_lim f x l2 -> l1 = l2.
Proof.
intros f x l1 l2 Hf_deriv1 Hf_deriv2 ;
 assert (H1 := uniqueness_step2 _ _ _ Hf_deriv1) ;
 assert (H2 := uniqueness_step2 _ _ _ Hf_deriv2) ;
 apply uniqueness_step1 with f x ; assumption.
Qed.

Lemma derive_pt_eq : forall f x l (pr:derivable_pt f x),
    derive_pt f x pr = l <-> derivable_pt_lim f x l.
Proof.
intros f x l pr ; split ; intro Hf_deriv.
 assert (H := proj2_sig pr) ; unfold derive_pt in Hf_deriv ;
 rewrite Hf_deriv in H ; assumption.
 assert (H := proj2_sig pr) ; unfold derivable_pt_abs in H ;
 assert (H' := uniqueness_limite _ _ _ _ Hf_deriv H) ;
 symmetry ; assumption.
Qed.

(**********)
Lemma derive_pt_eq_0 : forall f x l (pr:derivable_pt f x),
    derivable_pt_lim f x l -> derive_pt f x pr = l.
Proof.
intros f x l pr ; destruct (derive_pt_eq f x l pr) ; assumption.
Qed.

(**********)
Lemma derive_pt_eq_1 : forall f x l (pr:derivable_pt f x),
    derive_pt f x pr = l -> derivable_pt_lim f x l.
Proof.
intros f x l pr ; destruct (derive_pt_eq f x l pr) ; assumption.
Qed.

(**********************************************************************)
(** * Equivalence of this definition with the one using limit concept *)
(**********************************************************************)
Lemma derive_pt_D_in : forall (f df:C -> C) (x:C) (pr:derivable_pt f x),
    D_in f df no_cond x <-> derive_pt f x pr = df x.
Proof.
intros f df x pr ; split.
 unfold D_in, limit1_in, limit_in ; simpl ; unfold C_dist ; intros.
 apply derive_pt_eq_0.
 intros eps eps_pos ; destruct (H eps eps_pos) as [alpha [alpha_pos Halpha]] ;
 exists (mkposreal alpha alpha_pos) ; intros h h_neq h_bd.
 fold C in h ; assert (Hrew : h = (x + h) - x) by ring ; rewrite Hrew at 2.
 apply Halpha ; split.
 unfold D_x, no_cond ; split ; [trivial |].
 intro Hf ; apply h_neq ; clear -Hf.
 apply Cadd_eq_reg_l with x ; rewrite Cadd_0_r ; symmetry ; assumption.
 rewrite <- Hrew ; assumption.
intro H.
 assert (H0 := derive_pt_eq_1 f x (df x) pr H).
 intros eps eps_pos.
 destruct (H0 eps eps_pos) as [alpha Halpha] ; exists alpha ; split.
 exact (cond_pos alpha).
  intros a [Ha a_bd] ; unfold D_x in Ha ; destruct Ha as [_ Ha] ;
  assert (Temp : a - x <> 0) by (auto with complex).
  generalize (Halpha (a - x) Temp a_bd); replace (x + (a - x)) with a.
  intro; assumption.
  auto with complex.
Qed.

Lemma derivable_pt_lim_D_in : forall f (df:C -> C) (x:C),
    D_in f df no_cond x <-> derivable_pt_lim f x (df x).
Proof.
intros f df x ; split.
 unfold D_in, limit1_in, limit_in ; simpl ; unfold C_dist ; intros H eps eps_pos.
 destruct (H eps eps_pos) as [alpha [alpha_pos Halpha]].
 exists (mkposreal alpha alpha_pos) ; intros h h_neq h_bd ; fold C in h ;
 assert (Hrew : h = (x + h) - x) by ring ; rewrite Hrew at 2 ;
 apply Halpha ; unfold D_x, no_cond ; repeat split.
  intro Hf ; apply h_neq ; clear -Hf.
 apply Cadd_eq_reg_l with x ; rewrite Cadd_0_r ; symmetry ; assumption.
 rewrite <- Hrew ; assumption.
 intro.
  unfold derivable_pt_lim in H.
  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
      intros.
  elim (H eps H0); intros alpha H2; exists (pos alpha); split.
  apply (cond_pos alpha).
  intros.
  elim H1; intros; unfold D_x in H3; elim H3; intros; cut (x0 - x <> 0).
  intro; generalize (H2 (x0 - x) H7 H4); replace (x + (x0 - x)) with x0.
  intro; assumption.
  ring.
  auto with complex.
Qed.

(***********************************)
(** * derivability -> continuity   *)
(***********************************)
(**********)
Lemma derivable_derive : forall f x (pr:derivable_pt f x),
 exists l, derive_pt f x pr = l.
Proof.
intros f x pr ; exists (proj1_sig pr) ; reflexivity.
Qed.

Theorem derivable_continuous_pt : forall f x,
 derivable_pt f x -> continuity_pt f x.
Proof.
intros f x Hf_deriv eps eps_pos ; destruct Hf_deriv as (l, Hl).
 case (Ceq_or_neq_C0 l) ; intro Hl_0.
  assert (eps_2_pos : eps / 2 > 0) by lra ;
  destruct (Hl (eps / 2)%R eps_2_pos) as ([alpha alpha_pos], Halpha) ;
  exists (Rmin (1/2) alpha) ; split ; [apply Rmin_pos ; lra|] ;
  intros x' [_ x'_bd] ; simpl ; simpl in Halpha ; unfold C_dist in *.
  pose (h := x' - x) ; replace x' with (x + h) by (unfold h ; intuition).
   case (Ceq_or_neq_C0 h) ; intro Hh_0.
   rewrite Hh_0, Cadd_0_r, Cminus_diag_eq ; [| reflexivity] ;
   rewrite Cnorm_C0 ; assumption.
   apply Rlt_trans with (Cnorm h*eps)%R.
   apply Rle_lt_trans with (Cnorm (f (x + h)%C - f x) * (/ Cnorm h * Cnorm h))%R.
   right ; field ; apply Rgt_not_eq ; apply Cnorm_pos_lt ; assumption.
   unfold Rdiv ; rewrite  <- Rmult_assoc ; rewrite <- Cnorm_inv, <- Cnorm_Cmult.
   rewrite Rmult_comm ; apply Rmult_lt_compat_l.
   apply Cnorm_pos_lt ; assumption.
   replace ((f (x + h) - f x) * / h) with ((f (x + h) - f x) / h - l).
   apply Rlt_trans with (eps / 2)%R ; [apply Halpha ; intuition | lra].
   subst ; apply Rlt_le_trans with (Rmin (1/2) alpha) ; [apply x'_bd | apply Rmin_r].
   rewrite Hl_0. rewrite Cminus_0_r. auto. assumption.
   apply Rlt_trans with ((Rmin (1/2) alpha) * eps)%R.
   apply Rmult_lt_compat_r ; assumption.
   apply Rle_lt_trans with (eps / 2)%R.
   unfold Rdiv ; rewrite Rmult_comm ; apply Rmult_le_compat_l ; intuition ;
   apply Rle_trans with (1 * /2)%R ; [apply Rmin_l | right ; field].
   lra.
   assert (eps_2_pos : eps / 2 > 0) by lra ;
   destruct (Hl (eps / 2)%R eps_2_pos) as ([alpha alpha_pos], Halpha).
   exists (Rmin (eps / (2 * Cnorm l)) (Rmin (1/2) alpha)) ; split ; [apply Rmin_pos |].
  unfold Rdiv ; rewrite Rinv_mult_distr ; repeat apply Rmult_lt_0_compat.
  assumption.
  lra.
  apply Rinv_0_lt_compat ; apply Cnorm_pos_lt ; assumption.
  apply Rgt_not_eq ; lra.
  apply Rgt_not_eq ; apply Cnorm_pos_lt ; assumption.
  apply Rmin_pos ; lra.
 intros x' [_ x'_bd] ; simpl ; unfold C_dist.
  pose (h := x' - x) ; replace x' with (x+h) by (unfold h ; intuition) ;
  case (Ceq_or_neq_C0 h) ; intro Hh_0.
  rewrite Hh_0, Cadd_0_r, Cminus_diag_eq ; [| reflexivity] ;
  rewrite Cnorm_C0 ; assumption.
  apply Rlt_trans with (Cnorm h * eps + Cnorm h * Cnorm l )%R.
  apply Rle_lt_trans with (Cnorm (f (x + h)%C - f x) * (/ Cnorm h * Cnorm h))%R.
   right ; field ; apply Rgt_not_eq ; apply Cnorm_pos_lt ; assumption.
   unfold Rdiv ; rewrite  <- Rmult_assoc ; rewrite <- Cnorm_inv, <- Cnorm_Cmult.
   apply Rle_lt_trans with ((Cnorm ((f (x + h)%C - f x) * / h) + (- Cnorm l + Cnorm l)) * Cnorm h)%R.
   right ; field.
   repeat rewrite Rmult_plus_distr_r.
   replace (Cnorm l * Cnorm h)%R with (Cnorm h * Cnorm l)%R by (apply Rmult_comm).
   rewrite <- Rplus_assoc ; apply Rplus_lt_compat_r.
   apply Rle_lt_trans with (Cnorm ((f (x +h)%C - f x) / h - l)* Cnorm h)%R.
   rewrite <- Rmult_plus_distr_r ; apply Rmult_le_compat_r ;
   [apply Cnorm_pos | apply Cnorm_triang_rev_l].
   rewrite Rmult_comm ; apply Rmult_lt_compat_l.
   apply Cnorm_pos_lt ; assumption.
   apply Rlt_trans with (eps /2)%R ; [apply Halpha | lra].
   assumption.
   unfold h ; apply Rlt_le_trans with (Rmin (eps / (2 * Cnorm l)) (Rmin (1/2) alpha)) ;
   [apply x'_bd |].
   apply Rle_trans with (Rmin (1/2) alpha) ; apply Rmin_r.
   assumption.
   apply Rlt_trans with (eps / 2 + Cnorm h * Cnorm l)%R.
   apply Rplus_lt_compat_r ; unfold h.
   unfold Rdiv ; rewrite Rmult_comm ; apply Rmult_lt_compat_l ;
   [assumption |].
   apply Rlt_le_trans with (Rmin (eps / (2 * Cnorm l)) (Rmin (1 / 2) alpha)).
   assumption.
   apply Rle_trans with (Rmin (1/2) alpha) ; [apply Rmin_r | apply Rle_trans with (1/2)%R ;
   [apply Rmin_l | right ; field]].
   apply Rlt_le_trans with (eps / 2 + eps / 2)%R ; [apply Rplus_lt_compat_l | right ; field].
   replace (eps / 2)%R with ((eps / (2 * Cnorm l)) * Cnorm l)%R
       by (field ; apply Cnorm_no_R0 ; assumption).
   apply Rmult_lt_compat_r.
   apply Cnorm_pos_lt ; assumption.
   unfold h ; apply Rlt_le_trans with (Rmin (eps / (2 * Cnorm l)) (Rmin (1 / 2) alpha)).
   apply x'_bd.
   apply Rmin_l.
Qed.

Theorem derivable_continuous : forall f, derivable f -> continuity f.
Proof.
  unfold derivable, continuity in |- *; intros f X x.
  apply (derivable_continuous_pt f x (X x)).
Qed.

(***********************************)
(** * derivability -> differentiability  *)
(***********************************)

Lemma derivable_differentiable_pt_abs : forall f x l,
   derivable_pt_abs f x l -> forall v, differentiable_pt_abs f x v l.
Proof.
intros f x l Hl v v_neq eps eps_pos ;
 destruct (Hl eps eps_pos) as [delta Hdelta] ;
 assert (delta'_pos : (0 < delta / Cnorm v)%R).
  apply Rlt_mult_inv_pos ; [apply delta |
  apply Cnorm_pos_lt ; assumption].
  pose (delta' := mkposreal (delta / Cnorm v)%R delta'_pos) ;
 exists delta' ; intros h h_neq h_ub ; apply Hdelta.
 apply Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_0_compat |] ; assumption.
 rewrite Cnorm_Cmult.
 apply Rlt_le_trans with (delta' * Cnorm v)%R.
 apply Rmult_lt_compat_r.
 apply Cnorm_pos_lt ; assumption.
 rewrite Cnorm_IRC_Rabs ; assumption.
 unfold delta', Rdiv ; simpl ; rewrite Rmult_assoc, Rinv_l.
 right ; field.
 apply Cnorm_no_R0 ; assumption.
Qed.

Theorem derivable_differentiable_pt : forall f x,
 derivable_pt f x -> forall v, differentiable_pt f x v.
Proof.
intros f x [l Hl] v ; exists l ; apply derivable_differentiable_pt_abs ;
 assumption.
Qed.

(****************************************************************)
(** *                    Main rules                             *)
(****************************************************************)

Lemma derivable_pt_lim_add : forall f1 f2 x l1 l2,
    derivable_pt_lim f1 x l1 -> derivable_pt_lim f2 x l2 ->
    derivable_pt_lim (f1 + f2) x (l1 + l2).
Proof.
intros f1 f2 x l1 l2 H H0.
 apply uniqueness_step3.
 assert (H1 := uniqueness_step2 _ _ _ H).
 assert (H2 := uniqueness_step2 _ _ _ H0).
 unfold plus_fct in |- *.
  cut
    (forall h,
      (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
      (f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h).
  intro H3 ; generalize
    (limit_plus (fun h' => (f1 (x + h') - f1 x) / h')
      (fun h' => (f2 (x + h') - f2 x) / h') (fun h => h <> 0) l1 l2 0 H1 H2).
 intros H4 eps eps_pos.
  elim (H4 eps eps_pos); intros x0 Hx0.
  exists x0.
  destruct Hx0 as [x0_pos Hx0'].
  split.
  assumption.
  intros; rewrite H3; apply Hx0'; assumption.
  intro; unfold Cdiv ; ring.
Qed.

Lemma derivable_pt_lim_opp : forall f x l, derivable_pt_lim f x l ->
     derivable_pt_lim (- f) x (- l).
Proof.
intros f x l H.
 apply uniqueness_step3.
 assert (H1 := uniqueness_step2 _ _ _ H).
  unfold opp_fct in |- * ;
  cut (forall h, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
  intro.
  generalize
    (limit_opp (fun h => (f (x + h) - f x) / h) (fun h => h <> 0) l 0 H1).
  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
    simpl in |- *; unfold R_dist in |- *; intros.
  elim (H2 eps H3); intros.
  exists x0.
  elim H4; intros.
  split.
  assumption.
  intros; rewrite H0; apply H6; assumption.
  intro; unfold Cdiv in |- *; ring.
Qed.

Lemma derivable_pt_lim_minus : forall f1 f2 x l1 l2,
    derivable_pt_lim f1 x l1 -> derivable_pt_lim f2 x l2 ->
    derivable_pt_lim (f1 - f2) x (l1 - l2).
Proof.
  intros.
  apply uniqueness_step3.
  assert (H1 := uniqueness_step2 _ _ _ H).
  assert (H2 := uniqueness_step2 _ _ _ H0).
  unfold minus_fct in |- *.
  cut
    (forall h,
      (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
      (f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h).
  intro.
  generalize
    (limit_minus (fun h' => (f1 (x + h') - f1 x) / h')
      (fun h' => (f2 (x + h') - f2 x) / h') (fun h => h <> 0) l1 l2 0 H1 H2).
  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
    simpl in |- *; unfold R_dist in |- *; intros.
  elim (H4 eps H5); intros.
  exists x0.
  elim H6; intros.
  split.
  assumption.
  intros; rewrite <- H3; apply H8; assumption.
  intro; unfold Cdiv in |- *; ring.
Qed.

Lemma derivable_pt_lim_const : forall a x, derivable_pt_lim (fct_cte a) x 0.
Proof.
  intros; unfold fct_cte, derivable_pt_lim in |- *.
  intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Cminus in |- *;
  rewrite Cadd_opp_r; unfold Cdiv in |- * ; rewrite Cmult_0_l;
  rewrite Cadd_opp_r; rewrite Cnorm_C0; assumption.
Qed.

Lemma derivable_pt_lim_mult : forall f1 f2 x l1 l2,
    derivable_pt_lim f1 x l1 ->
    derivable_pt_lim f2 x l2 ->
    derivable_pt_lim (f1 * f2) x (l1 * f2 x + f1 x * l2).
Proof.
  intros.
  assert (H1 := derivable_pt_lim_D_in f1 (fun y => l1) x).
  elim H1; intros.
  assert (H4 := H3 H).
  assert (H5 := derivable_pt_lim_D_in f2 (fun y => l2) x).
  elim H5; intros.
  assert (H8 := H7 H0).
  clear H1 H2 H3 H5 H6 H7.
  assert
    (H1 :=
      derivable_pt_lim_D_in (f1 * f2)%F (fun y => l1 * f2 x + f1 x * l2) x).
  elim H1; intros.
  clear H1 H3.
  apply H2.
  unfold mult_fct in |- *.
  apply (Dmult no_cond (fun y => l1) (fun y => l2) f1 f2 x); assumption.
Qed.

Lemma derivable_pt_lim_scal : forall f a x l,
    derivable_pt_lim f x l -> derivable_pt_lim (fun x => a * f x) x (a * l).
Proof.
  intros.
  assert (H0 := derivable_pt_lim_const a x).
  replace (mult_real_fct a f) with (fct_cte a * f)%F.
  replace (a * l) with (C0 * f x + a * l); [ idtac | ring ].
  apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption.
  unfold mult_real_fct, mult_fct, fct_cte in |- *; reflexivity.
Qed.

Lemma derivable_pt_lim_id : forall x:C, derivable_pt_lim id x C1.
Proof.
  intro; unfold derivable_pt_lim in |- *.
  intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
    unfold id in |- *; replace ((x + h - x) / h - C1) with C0.
  rewrite Cnorm_C0 ; assumption.
  fold C in h.
  replace (x + h - x) with h by ring.
  replace (h / h) with C1.
  unfold Cminus ; rewrite Cadd_opp_r ; reflexivity.
  unfold Cdiv ; rewrite Cinv_r ; trivial.
Qed.

(*
Lemma derivable_pt_lim_Csqr : forall x:R, derivable_pt_lim Csqr x (2 * x).
Proof.
  intro; unfold derivable_pt_lim in |- *.
  unfold Rsqr in |- *; intros eps Heps; exists (mkposreal eps Heps);
    intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h.
  assumption.
  replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h);
  [ idtac | ring ].
  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r.
  repeat rewrite Rmult_assoc.
  repeat rewrite <- Rinv_r_sym; [ idtac | assumption ].
  ring.
Qed.
*)

Lemma derivable_pt_lim_comp : forall f1 f2 (x l1 l2:C),
    derivable_pt_lim f1 x l1 ->
    derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (comp f2 f1) x (l2 * l1).
Proof.
  intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:C => l1) x).
  elim H1; intros.
  assert (H4 := H3 H).
  assert (H5 := derivable_pt_lim_D_in f2 (fun y:C => l2) (f1 x)).
  elim H5; intros.
  assert (H8 := H7 H0).
  clear H1 H2 H3 H5 H6 H7.
  assert (H1 := derivable_pt_lim_D_in (comp f2 f1)%F (fun y:C => l2 * l1) x).
  elim H1; intros.
  clear H1 H3; apply H2.
  unfold comp in |- *;
    cut
      (D_in (fun x0:C => f2 (f1 x0)) (fun y:C => l2 * l1)
        (Dgf no_cond no_cond f1) x ->
        D_in (fun x0:C => f2 (f1 x0)) (fun y:C => l2 * l1) no_cond x).
  intro; apply H1.
  rewrite Cmult_comm;
    apply (Dcomp no_cond no_cond (fun y:C => l1) (fun y:C => l2) f1 f2 x);
      assumption.
  unfold Dgf, D_in, no_cond in |- *; unfold limit1_in in |- *;
    unfold limit_in in |- *; unfold dist in |- *; simpl in |- *;
      unfold R_dist in |- *; intros.
  elim (H1 eps H3); intros.
  exists x0; intros; split.
  elim H5; intros; assumption.
  intros; elim H5; intros; apply H9; split.
  unfold D_x in |- *; split.
  split; trivial.
  elim H6; intros; unfold D_x in H10; elim H10; intros; assumption.
  elim H6; intros; assumption.
Qed.

(***********************************)
(** * derivable_pt compatibility lemmas *)
(***********************************)

Lemma derivable_pt_add : forall f1 f2 (x:C),
    derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x.
Proof.
  unfold derivable_pt in |- *; intros f1 f2 x X X0.
  elim X; intros.
  elim X0; intros.
  exists (x0 + x1).
  apply derivable_pt_lim_add; assumption.
Qed.

Lemma derivable_pt_opp : forall f (x:C), derivable_pt f x -> derivable_pt (- f) x.
Proof.
  unfold derivable_pt in |- *; intros f x X.
  elim X; intros.
  exists (- x0).
  apply derivable_pt_lim_opp; assumption.
Qed.

Lemma derivable_pt_minus : forall f1 f2 (x:C),
    derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x.
Proof.
  unfold derivable_pt in |- *; intros f1 f2 x X X0.
  elim X; intros.
  elim X0; intros.
  exists (x0 - x1).
  apply derivable_pt_lim_minus; assumption.
Qed.

Lemma derivable_pt_mult : forall f1 f2 (x:C),
    derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x.
Proof.
  unfold derivable_pt in |- *; intros f1 f2 x X X0.
  elim X; intros.
  elim X0; intros.
  exists (x0 * f2 x + f1 x * x1).
  apply derivable_pt_lim_mult; assumption.
Qed.

Lemma derivable_pt_const : forall a x:C, derivable_pt (fct_cte a) x.
Proof.
  intros; unfold derivable_pt in |- *.
  exists 0.
  apply derivable_pt_lim_const.
Qed.

Lemma derivable_pt_scal : forall f (a x:C), derivable_pt f x ->
 derivable_pt (mult_real_fct a f) x.
Proof.
  unfold derivable_pt in |- *; intros f1 a x X.
  elim X; intros.
  exists (a * x0).
  apply derivable_pt_lim_scal; assumption.
Qed.

Lemma derivable_pt_id : forall x:C, derivable_pt id x.
Proof.
  unfold derivable_pt in |- *; intro.
  exists 1.
  apply derivable_pt_lim_id.
Qed.

(***********************************)
(** * derivable compatibility lemmas *)
(***********************************)

Lemma derivable_add : forall f1 f2,
    derivable f1 -> derivable f2 -> derivable (f1 + f2).
Proof.
intros f1 f2 Hf1 Hf2 z ; apply derivable_pt_add ; intuition.
Qed.

Lemma derivable_opp : forall f, derivable f -> derivable (- f).
Proof.
intros f1 Hf1 z ; apply derivable_pt_opp ; intuition.
Qed.

Lemma derivable_minus : forall f1 f2,
    derivable f1 -> derivable f2 -> derivable (f1 - f2).
Proof.
intros f1 f2 Hf1 Hf2 z ; apply derivable_pt_minus ; intuition.
Qed.

Lemma derivable_mult : forall f1 f2,
    derivable f1 -> derivable f2 -> derivable (f1 * f2).
Proof.
intros f1 f2 Hf1 Hf2 z ; apply derivable_pt_mult ; intuition.
Qed.

Lemma derivable_const : forall a, derivable (fct_cte a).
Proof.
 intros a z ; apply derivable_pt_const.
Qed.

Lemma derivable_scal : forall f a, derivable f ->
 derivable (mult_real_fct a f).
Proof.
 intros f a Hf z ; apply derivable_pt_scal ; intuition.
Qed.

Lemma derivable_id : derivable id.
Proof.
intro z ; apply derivable_pt_id.
Qed.

(***********************************)
(** * fully differentiability -/-> derivability *)
(***********************************)

Theorem fully_differentiable_pt_not_derivable_pt :
     (forall f x, fully_differentiable_pt f x -> derivable_pt f x) -> False.
Proof.
intro H.
 assert (Main : forall (x y : R), differentiable_pt_abs (fun z1 => (Cre z1 * Cre z1 +
            Cim z1 * Cim z1)%R) 1 (x +i y) (2 * x / (x +i y))).
  intros x y v_neq eps eps_pos.
  pose (delta := (eps / Cnorm (x +i y))%R) ; assert (delta_pos : 0 < delta).
   unfold Rdiv ; apply Rlt_mult_inv_pos ; [| apply Cnorm_pos_lt] ; assumption.
  exists (mkposreal delta delta_pos) ; intros h h_neq h_bd ; simpl.
  repeat rewrite Rmult_0_l ; repeat rewrite Rminus_0_r ; repeat rewrite Rplus_0_r ;
  repeat rewrite Rplus_0_l.
  apply Rle_lt_trans with (Cnorm (h * (h * (x ^ 2) + h * (y ^ 2) + 2 * x)%R / (h * (x, y)) - 2 * x / (x, y))).
  right ; apply Cnorm_eq_compat.
  unfold Cminus ; apply Cadd_eq_compat_r ; apply Cmult_eq_compat_r.
  rewrite Rmult_plus_distr_l ; repeat rewrite Rmult_plus_distr_r.
  repeat rewrite Rmult_1_r ; repeat rewrite Rmult_1_l.
  apply (proj1 (Ceq _ _)) ; split ; simpl ; ring.
  apply Rle_lt_trans with (Cnorm ((h * x ^ 2 + h * y ^ 2 + 2 * x)%R / (x, y) - 2 * x / (x, y))).
  right ; apply Cnorm_eq_compat.
  apply Cadd_eq_compat_r.
  rewrite Cmult_comm ; unfold Cdiv ; repeat rewrite Cmult_assoc ;
  apply Cmult_eq_compat_l ; field ; split ; [| apply IRC_neq_compat] ; assumption.
  apply Rle_lt_trans with (Cnorm ((h * x ^ 2 + h * y ^ 2)%R / (x, y))).
  right ; apply Cnorm_eq_compat ; apply (proj1 (Ceq _ _)) ; split ; simpl ; ring.
  rewrite <- Rmult_plus_distr_l ; unfold Cdiv ; rewrite Cmult_IRC_Rmult ;
  repeat rewrite Cnorm_Cmult.
  apply Rlt_le_trans with (eps * Cnorm_sqr (x, y) * (/ Cnorm (x, y)) ^ 2)%R.
  simpl ; repeat rewrite Rmult_1_r ; rewrite <- Rmult_assoc, Cnorm_inv.
  apply Rmult_lt_compat_r.
  apply Rinv_0_lt_compat ; apply Cnorm_pos_lt ; assumption.
  replace (Cnorm_sqr (x, y))%R with (Cnorm (x * x + y * y)%R).
  apply Rlt_le_trans with (eps * / Cnorm (x, y)* Cnorm (x * x + y * y)%R)%R.
  apply Rmult_lt_compat_r.
  apply Cnorm_pos_lt ; intro Hf ; apply v_neq.
  apply HC0_norm_R0.
  unfold Cnorm_sqr ; simpl.
  destruct (proj2 (Ceq _ _) Hf) as [Hf' _] ; apply Hf'.
  rewrite Cnorm_IRC_Rabs ; apply h_bd.
  right ; field.
  apply Cnorm_no_R0 ; assumption.
  unfold Cnorm_sqr ; rewrite Cnorm_IRC_Rabs, Rabs_right ; [reflexivity |].
  apply Rle_ge ; apply Cnorm_sqr_pos.
  assumption.
  right ; rewrite <- Rmult_1_r, Rmult_assoc ; apply Rmult_eq_compat_l.
  unfold Cnorm, Cnorm_sqr.
  simpl.
  rewrite Rmult_1_r, <- Rinv_mult_distr, sqrt_sqrt, Rinv_r.
  reflexivity.
  apply Rgt_not_eq.
  apply Cnorm_sqr_pos_lt ; assumption.
  apply Cnorm_sqr_pos.
  apply Rgt_not_eq ; apply sqrt_lt_R0 ; apply Cnorm_sqr_pos_lt ; assumption.
  apply Rgt_not_eq ; apply sqrt_lt_R0 ; apply Cnorm_sqr_pos_lt ; assumption.
 assert (Main2 : fully_differentiable_pt Cnorm_sqr 1).
  intros v ; unfold Cnorm_sqr ; destruct v as [x y] ; exists (2 * x / (x, y)) ;
  apply Main.
 assert (Main3 : derivable_pt Cnorm_sqr C1 -> False).
   intros [l Hl].
   assert (H1 := derivable_differentiable_pt_abs Cnorm_sqr 1 l Hl (0,1)%R).
   assert (H1' := Main R0 R1).
   assert (H2 := derivable_differentiable_pt_abs Cnorm_sqr 1 l Hl (1,0)%R).
   assert (H2' := Main R1 R0).
   unfold differentiable_pt_abs in *.
   assert (H1_neq : (R0, R1) <> C0).
    apply HintC0_neq_R0_neq ; right ; simpl ; apply Rgt_not_eq ; apply Rlt_0_1.
   assert (H2_neq : (R1, R0) <> C0).
    apply HintC0_neq_R0_neq ; left ; simpl ; apply Rgt_not_eq ; apply Rlt_0_1.
   assert (Hf1 := Canalysis_diff.uniqueness_limite _ _ _ _ _ H1_neq H1 H1').
   assert (Hf2 := Canalysis_diff.uniqueness_limite _ _ _ _ _ H2_neq H2 H2').
   subst.
   unfold Cdiv in Hf2 ; repeat rewrite Cmult_assoc in Hf2.
   assert (Hneq : IRC 2 <> IRC 0) by (apply IRC_neq_compat ; apply Rgt_not_eq ; lra) ;
   assert (T := Cmult_eq_reg_l _ _ _ Hneq Hf2).
   clear -T H1_neq H2_neq.
   do 2 rewrite Cinv_rew in T.
   destruct (proj2 (Ceq _ _) T) as [H _] ; clear T.
   simpl in H ; ring_simplify in H.
   repeat rewrite Rmult_0_l in H ; repeat rewrite Rmult_1_l in H ;
   rewrite Rplus_0_r, Rinv_1 in H.
   lra.
   assumption.
   assumption.
   assumption.
   apply Main3 ; apply H ; apply Main2.
Qed.

(** * MVT (weak version : the strong one is false when f has complex values *)
(* see http://planetmath.org/encyclopedia/ProofOfComplexMeanValueTheorem.html for the proof *)

Theorem MVT_Cre : forall (f : C -> C) (z h : C)
    (f_deriv : forall (t : R), interval 0 1 t -> derivable_pt f (z + t*h)), h <> 0 ->
    exists u : R, exists u_in_I : interval 0 1 u,
    Cre ((f (z + h) - f z) / h) = Cre (derive_pt f (z + u * h) (f_deriv u u_in_I)).
Proof.
intros f z h f_deriv h_neq.
 pose (H := fun (t : R) => Cre ((f (z + t*h) - f z) / h)).
 assert (H0_0 : (H 0 = 0)%R).
  unfold H ; unfold Cminus, Cdiv ; rewrite Cmult_0_l, Cadd_0_r, Cadd_opp_r, Cmult_0_l ; reflexivity.
 assert (H1_d : H R1  = Cre ((f (z + h) - f z) / h)).
  unfold H ; rewrite Cmult_1_l ; reflexivity.
 assert (H_deriv : forall (t:R) (t_in : interval 0 1 t),
                    Ranalysis_def.derivable_pt_lim_in (interval 0 1) H t (Cre (derive_pt f (z + t * h) (f_deriv t t_in)))).
{  intros t t_in ; destruct (f_deriv t t_in) as [f' Hf'] ;
  intros eps eps_pos ; destruct (Hf' _ eps_pos) as [delta Hdelta].
  pose (delta' := (delta / Cnorm h)%R) ; assert (delta'_pos : 0 < delta').
   unfold delta', Rdiv ; apply Rlt_mult_inv_pos ; [destruct delta | apply Cnorm_pos_lt] ;
   assumption.
  exists delta' ; split ; [assumption |].
  simpl ; intros u [[u_in ut_neq] u_bd] ;
   replace (Ranalysis_def.growth_rate H t u)
   with (Cre (growth_rate f (z + t * h) (z + u * h))).
  + unfold R_dist ; rewrite Cre_minus_compat ; eapply Rle_lt_trans.
    - eapply Cre_le_Cnorm.
    - unfold growth_rate.
      replace (z + IRC u * h - (z + IRC t * h)) with (IRC (u - t) * h).
      replace (IRC u * h) with (IRC t * h + IRC (u - t) * h).
      rewrite <- Cadd_assoc ; apply Hdelta.
       * apply Cmult_integral_contrapositive_currified.
          apply IRC_neq_compat, Rminus_eq_contra ; symmetry ; assumption.
          assumption.
       * rewrite Cnorm_Cmult, Cnorm_IRC_Rabs ; apply Rlt_le_trans with (delta' * Cnorm h)%R.
         apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt |] ; assumption.
         unfold delta', Rdiv ; rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
          reflexivity.
          apply Rgt_not_eq, Cnorm_pos_lt ; assumption.
       * rewrite <- IRC_minus_compat ; ring.
       * rewrite <- IRC_minus_compat ; ring.
  + unfold growth_rate, Ranalysis_def.growth_rate, H.
    rewrite Cre_minus_compat, <- Cre_div_compat.
    rewrite <- IRC_minus_compat ; apply Cre_eq_compat ; field ; repeat split.
     assumption.
     rewrite IRC_minus_compat ; apply IRC_neq_compat, Rminus_eq_contra ; symmetry ; assumption.
     ring_simplify (z + IRC u * h - (z + IRC t * h)) ; rewrite Cmult_comm, <- Cmult_minus_distr_l.
     apply Cmult_integral_contrapositive_currified.
      assumption.
      rewrite IRC_minus_compat ; apply IRC_neq_compat, Rminus_eq_contra ; symmetry ; assumption.
      apply Rminus_eq_contra ; symmetry ; assumption.
}

 assert (H_deriv2 : derivable_open_interval 0 1 H).
  intros a a_in ;
  exists (Cre (derive_pt f (z + a * h) (f_deriv a (open_interval_interval _ _ _ a_in)))).
  eapply derivable_pt_lim_in_contravariant, H_deriv.
  unfold included ; apply open_interval_interval ; assumption.

 assert (id_deriv : derivable_open_interval 0 1 Ranalysis1.id).
  apply derivable_in_id.

 assert (H_cont : Ranalysis_def.continuity_interval 0 1 H).
  apply derivable_in_continuity_in ; intros x x_in ;
   eexists ; apply (H_deriv _ x_in).

 assert (id_cont : Ranalysis_def.continuity_interval 0 1 Ranalysis1.id).
  apply derivable_in_continuity_in, derivable_in_id.

  destruct (Ranalysis_MVT.MVT H (Ranalysis1.id) 0 1 H_deriv2 id_deriv Rlt_0_1 H_cont id_cont) as [c [c_in Hc]] ;
  exists c ; exists (open_interval_interval _ _ _ c_in).
  assert (Hrew := Rminus_0_r (H R1)) ; rewrite <- H0_0 in Hrew.
  rewrite <- H1_d, <- Hrew ; clear Hrew.

  unfold Ranalysis1.id in Hc ; rewrite Rminus_0_r, Rmult_1_l in Hc.
  rewrite derive_open_interval_unfold with (f := fun x => x) (c_in := c_in) in Hc.
  rewrite derive_pt_open_interval_id, Rmult_1_r in Hc ; [| assumption].
  rewrite derive_open_interval_unfold with (f := H) (c_in := c_in) in Hc.

  erewrite derivable_pt_lim_derive_pt_open_interval in Hc.

  change R0 with (IZR 0).
  change R1 with (IZR 1).
  rewrite <- Hc.
  reflexivity.
  assumption.
  apply derivable_pt_lim_in_contravariant with (interval 0 1), H_deriv.
   apply included_open_interval_interval.
Qed.

Theorem MVT_Cim : forall (f : C -> C) (z h : C)
    (f_deriv : forall (t : R), interval 0 1 t -> derivable_pt f (z + t*h)), h <> 0 ->
    exists u : R, exists u_in_I : interval 0 1 u, Cim ((f (z + h) - f z) / h) = Cim (derive_pt f (z + u * h) (f_deriv u u_in_I)).
Proof.
intros f z h f_deriv h_neq.
 pose (H := fun (t : R) => Cim ((f (z + t*h) - f z) / h)).
 assert (H0_0 : (H 0 = 0)%R).
  unfold H ; unfold Cminus, Cdiv ; rewrite Cmult_0_l, Cadd_0_r, Cadd_opp_r, Cmult_0_l ; reflexivity.
 assert (H1_d : H R1  = Cim ((f (z + h) - f z) / h)).
  unfold H ; rewrite Cmult_1_l ; reflexivity.
 assert (H_deriv : forall (t:R) (t_in : interval 0 1 t),
                    Ranalysis_def.derivable_pt_lim_in (interval 0 1) H t (Cim (derive_pt f (z + t * h) (f_deriv t t_in)))).
{  intros t t_in ; destruct (f_deriv t t_in) as [f' Hf'] ;
  intros eps eps_pos ; destruct (Hf' _ eps_pos) as [delta Hdelta].
  pose (delta' := (delta / Cnorm h)%R) ; assert (delta'_pos : 0 < delta').
   unfold delta', Rdiv ; apply Rlt_mult_inv_pos ; [destruct delta | apply Cnorm_pos_lt] ;
   assumption.
  exists delta' ; split ; [assumption |].
  simpl ; intros u [[u_in ut_neq] u_bd] ;
   replace (Ranalysis_def.growth_rate H t u)
   with (Cim (growth_rate f (z + t * h) (z + u * h))).
  + unfold R_dist ; rewrite Cim_minus_compat ; eapply Rle_lt_trans.
    - eapply Cim_le_Cnorm.
    - unfold growth_rate.
      replace (z + IRC u * h - (z + IRC t * h)) with (IRC (u - t) * h).
      replace (IRC u * h) with (IRC t * h + IRC (u - t) * h).
      rewrite <- Cadd_assoc ; apply Hdelta.
       * apply Cmult_integral_contrapositive_currified.
          apply IRC_neq_compat, Rminus_eq_contra ; symmetry ; assumption.
          assumption.
       * rewrite Cnorm_Cmult, Cnorm_IRC_Rabs ; apply Rlt_le_trans with (delta' * Cnorm h)%R.
         apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt |] ; assumption.
         unfold delta', Rdiv ; rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
          reflexivity.
          apply Rgt_not_eq, Cnorm_pos_lt ; assumption.
       * rewrite <- IRC_minus_compat ; ring.
       * rewrite <- IRC_minus_compat ; ring.
  + unfold growth_rate, Ranalysis_def.growth_rate, H.
    rewrite Cim_minus_compat, <- Cim_div_compat.
    rewrite <- IRC_minus_compat ; apply Cim_eq_compat ; field ; repeat split.
     assumption.
     rewrite IRC_minus_compat ; apply IRC_neq_compat, Rminus_eq_contra ; symmetry ; assumption.
     ring_simplify (z + IRC u * h - (z + IRC t * h)) ; rewrite Cmult_comm, <- Cmult_minus_distr_l.
     apply Cmult_integral_contrapositive_currified.
      assumption.
      rewrite IRC_minus_compat ; apply IRC_neq_compat, Rminus_eq_contra ; symmetry ; assumption.
      apply Rminus_eq_contra ; symmetry ; assumption.
}

 assert (H_deriv2 : derivable_open_interval 0 1 H).
  intros a a_in ;
  exists (Cim (derive_pt f (z + a * h) (f_deriv a (open_interval_interval _ _ _ a_in)))).
  eapply derivable_pt_lim_in_contravariant, H_deriv.
  unfold included ; apply open_interval_interval ; assumption.

 assert (id_deriv : derivable_open_interval 0 1 Ranalysis1.id).
  apply derivable_in_id.

 assert (H_cont : Ranalysis_def.continuity_interval 0 1 H).
  apply derivable_in_continuity_in ; intros x x_in ;
   eexists ; apply (H_deriv _ x_in).

 assert (id_cont : Ranalysis_def.continuity_interval 0 1 Ranalysis1.id).
  apply derivable_in_continuity_in, derivable_in_id.

  destruct (Ranalysis_MVT.MVT H (Ranalysis1.id) 0 1 H_deriv2 id_deriv Rlt_0_1 H_cont id_cont) as [c [c_in Hc]] ;
  exists c ; exists (open_interval_interval _ _ _ c_in).
  assert (Hrew := Rminus_0_r (H R1)) ; rewrite <- H0_0 in Hrew.
  rewrite <- H1_d, <- Hrew ; clear Hrew.

  unfold Ranalysis1.id in Hc ; rewrite Rminus_0_r, Rmult_1_l in Hc.
  rewrite derive_open_interval_unfold with (f := fun x => x) (c_in := c_in) in Hc.
  rewrite derive_pt_open_interval_id, Rmult_1_r in Hc ; [| assumption].
  rewrite derive_open_interval_unfold with (f := H) (c_in := c_in) in Hc.

  erewrite derivable_pt_lim_derive_pt_open_interval in Hc.

  change R0 with (IZR 0).
  change R1 with (IZR 1).
  rewrite <- Hc.
  reflexivity.
  assumption.
  apply derivable_pt_lim_in_contravariant with (interval 0 1), H_deriv.
   apply included_open_interval_interval.
Qed.


Require Import RBT.Verif.RBtree_Type .

Inductive color := Red | Black.

Section Section_RBtree_Def.

Context {rbt:RBtree_setting}.
Existing Instance rbt.

Record Node  := {
   k : Key ;
   v : Value ;
   c : color ;
   t : Tag;
}.

Inductive RBtree : Type :=
| Empty :  RBtree
| T :  color ->   RBtree -> Key -> Value  -> Tag -> RBtree  -> RBtree.

(*Simple Operations and Properties*)
  Definition makeBlack t :=
    match t with
    | Empty => Empty
    | T _ a x vx tx b => T Black a x vx tx b
    end.
  Definition makeRed t : RBtree :=
    match t with
    |Empty => Empty
    |T co a k v t b => T Red a k v t b
    end.
  Definition tag_tree_t t s :RBtree :=
    match s with
    |Empty => Empty
    |T co a y vy ty b =>  T co a y vy (Optt t ty) b
    end.
  Definition Red_tree s :=
    match s with
    |Empty => False
    |T co a k v t b => co = Red
    end.
  Definition Black_tree s :=
    match s with
    |Empty => False
    |T co a k v t b => co = Black
    end.
  Definition default_tag_tree s : Prop :=
    match s with
    |Empty => False
    |T co a k v t b => t= default
    end.
  Definition le_rotate_notag co a k v t y :=
    match y with
    |Empty => Empty
    |T co' b k1 v1 t1 c =>  T co' (T co a k v t b) k1 v1 t1 c
    end.
  Definition ri_rotate_notag co y k v t a :=
    match y with
    |Empty => Empty
    |T co' b k1 v1 t1 c => T co' b k1 v1 t1 (T co c k v t a)
    end.
  (** 含tag操作的左旋和右旋 *)
  Definition left_rotate color a k v t y :=
    match y with
    |Empty => Empty
    |T color' b k1 v1 t1 c =>
       T color'  (T color a k v default (tag_tree_t t1 b)) k1 (f v1 t1) t (tag_tree_t t1 c)
    end.
  Definition right_rotate color y k v t a :=
    match y with
    |Empty => Empty
    |T color' b k1 v1 t1 c =>
        T color' (tag_tree_t t1 b) k1 (f v1 t1) t (T color (tag_tree_t t1 c) k v default a)
    end.

(*SearchTree AND Redblack*)
Inductive SearchTree' : Key -> RBtree -> Key -> Prop :=
| ST_E : forall lo hi, lo < hi -> SearchTree' lo Empty hi
| ST_T: forall lo c l k v t r hi,
    SearchTree' lo l k ->
    SearchTree'  k r hi ->
    SearchTree' lo (T c l k v t r) hi.
Inductive SearchTree: RBtree -> Prop :=
| ST_intro: forall t lo hi, SearchTree' lo t hi -> SearchTree t.

Inductive is_redblack_color : RBtree -> color -> Prop :=
|IsRB_co_leaf: forall c, is_redblack_color Empty c
|IsRB_co_r: forall tl k kv kt tr ,
          is_redblack_color tl Red ->
          is_redblack_color tr Red ->
           is_redblack_color (T Red tl k kv kt tr) Black
|IsRB_co_b: forall c tl k kv kt tr ,
         is_redblack_color tl Black ->
         is_redblack_color tr Black ->
         is_redblack_color (T Black tl k kv kt tr) c.
Inductive is_redblack_dep : RBtree -> nat -> Prop :=
|IsRB_dep_em: is_redblack_dep Empty 0
|IsRB_dep_r: forall tl k kv kt tr n,
     is_redblack_dep tl n ->
     is_redblack_dep tr n ->
     is_redblack_dep (T Red tl k kv kt tr) n
|IsRB_dep_b: forall tl k kv kt tr n,
     is_redblack_dep tl n ->
     is_redblack_dep tr n ->
     is_redblack_dep (T Black tl k kv kt tr)(S n).
Definition is_redblack t : Prop := ( is_redblack_color t Red ) /\ (exists n, is_redblack_dep t n).

(*SearchTree Lemmas*)
  Lemma st_color : forall l k v t r lo hi c1 c2,
    SearchTree' lo (T c1 l k v t r) hi -> SearchTree' lo (T c2 l k v t r) hi.
  Proof.
    intros.
    inversion H;subst.
    eapply ST_T;try eassumption.
  Qed.
  Lemma makeBlack_st : forall s lo hi , SearchTree' lo s hi ->
    SearchTree' lo (makeBlack s) hi.
  Proof.
    intros.
    inversion H.
    - simpl. subst. auto.
    - simpl. subst. apply ST_T. auto. auto.
  Qed.
  Lemma makeRed_st : forall s lo hi , SearchTree' lo s hi ->
    SearchTree' lo (makeRed s) hi.
  Proof.
    intros.
    inversion H.
    - simpl. subst. auto.
    - simpl. subst. apply ST_T. auto. auto.
  Qed.
  Lemma search_tag_tree_t :
    forall lo t hi v,
     SearchTree' lo t hi -> SearchTree' lo (tag_tree_t v t) hi.
  Proof.
    intros.
    induction t0.
    - simpl. auto.
    - simpl. inversion H. apply ST_T. auto. auto.
  Qed.
  Lemma search_popro :
   forall lo t hi,
     SearchTree' lo t hi -> lo < hi.
  Proof.
    intros.
    induction H.
    - auto.
    -  eapply Total_Transitive . apply IHSearchTree'1. auto.
  Qed.
  Lemma search_popro2 :
   forall lo t hi k ,
     SearchTree' lo t k -> k < hi -> SearchTree' lo t hi .
  Proof.
    intros.
    induction H.
    -  constructor. eapply Total_Transitive. apply H. auto.
    - constructor. auto.   apply IHSearchTree'2 . auto.
  Qed.
  Lemma search_popro2_lte :
   forall lo t hi k ,
     SearchTree' lo t k -> k <= hi -> SearchTree' lo t hi .
  Proof.
    intros.
    destruct H0. eapply search_popro2; try eassumption.
    subst. auto.
  Qed.
  Lemma search_popro3 :
   forall lo t hi k ,
     SearchTree' k t hi -> lo < k -> SearchTree' lo t hi .
  Proof.
    intros.
    induction H.
    -  constructor. eapply Total_Transitive. apply H0. auto.
    - constructor. auto.   auto.
  Qed.
  Lemma search_popro3_lte :
   forall lo t hi k ,
     SearchTree' k t hi -> lo <= k -> SearchTree' lo t hi .
  Proof.
    intros.
    destruct H0. eapply search_popro3; try eassumption.
    subst. auto.
  Qed.
   Lemma search_left_max: forall t lo low hi,
 SearchTree' lo t hi -> SearchTree' low t hi -> SearchTree' (max_k lo low ) t hi.
 Proof.
   intros.
   pose proof lte_complete lo low.
   destruct H1.
   + pose proof max_lte _ _ H1. rewrite H2. auto.
   + pose proof max_lte _ _ H1. rewrite max_comm. rewrite H2. auto.
Qed.
 Lemma search_right_min: forall t lo hi high,
 SearchTree' lo t hi -> SearchTree' lo t high -> SearchTree' lo t (min_k hi high).
 Proof.
   intros.
   pose proof lte_complete hi high.
   destruct H1.
   + pose proof min_lte _ _ H1. rewrite H2. auto.
   + pose proof min_lte _ _ H1. rewrite min_comm. rewrite H2. auto.
 Qed.

End Section_RBtree_Def.

Ltac stt n :=
    first [assumption | apply ST_E |
      match n with
      | S ?m =>
          match goal with
          | |- _ <=  _ => TR 5;stt m
          | |- _ < _ => TR 5;stt m
          | H: SearchTree' ?lo (T Red ?l ?k ?v ?t ?r) ?hi
             |- SearchTree' ?lo (T Black ?l ?k ?v ?t ?r) ?hi
              => eapply (st_color l k v t r lo hi Red Black);stt m
          | H: SearchTree' ?lo (T Black ?l ?k ?v ?t ?r) ?hi
             |- SearchTree' ?lo (T Red ?l ?k ?v ?t ?r) ?hi
              => eapply (st_color l k v t r lo hi Black Red);stt m
          | H: SearchTree' ?k ?a ?hi |-  SearchTree' ?lo ?a ?hi
                         => eapply (search_popro3_lte lo a hi k);stt m
          | H: SearchTree' ?lo ?a ?k |-  SearchTree' ?lo ?a ?hi
                         => eapply (search_popro2_lte lo a hi k);stt m
          | H: SearchTree' ?lo ?a ?hi |- SearchTree' ?k0 ?a ?k1
                         =>  eapply (search_popro3_lte k0 a k1 lo);stt m
          | |- SearchTree' _ (T _ _ _ _ _ _ ) _ => eapply ST_T;stt m
          end
      end].

Section Section_RBtree_Def_2.

Context {rbt:RBtree_setting}.
Existing Instance rbt.

(*Redblack Lemmas*)
  Lemma isrb_dep_makeBlack : forall t n, is_redblack_dep t n ->
   (exists n', is_redblack_dep (makeBlack t) n').
  Proof.
    intros.
    inversion H.
    subst. exists O. auto.
    subst. exists (S n). apply IsRB_dep_b; try eassumption.
    subst. exists (S n0). apply IsRB_dep_b; try eassumption.
  Qed.
  Lemma isr_isb:
   forall t, is_redblack_color t Red -> is_redblack_color t Black .
  Proof.
    intros.
    induction H.
    - apply IsRB_co_leaf.
    - eapply IsRB_co_r; try eassumption.
    - eapply IsRB_co_b; try eassumption.
  Qed.
  Lemma isb_isr : forall l , is_redblack_color l Black -> is_redblack_color (makeBlack l) Red.
  Proof.
    intros.
    inversion H.
    - simpl. apply IsRB_co_leaf.
    - simpl. apply IsRB_co_b. eapply isr_isb; try eassumption. eapply isr_isb; try eassumption.
    - simpl. apply IsRB_co_b; try eassumption.
  Qed.
  Lemma isb_isr_black : forall l , Black_tree l -> is_redblack_color l Black -> is_redblack_color l Red.
  Proof.
    intros.
    inversion H0.
    - simpl. apply IsRB_co_leaf.
    - subst.  inversion H.
    - simpl. apply IsRB_co_b; try eassumption.
  Qed.
  Lemma isrb_left: forall c l k v t r, is_redblack_color (T c l k v t r) Black ->
    is_redblack_color l Black.
  Proof.
    intros.
    inversion H.
    subst. eapply isr_isb; try eassumption.
    subst. auto.
  Qed.
  Lemma isrb_right: forall c l k v t r, is_redblack_color (T c l k v t r) Black ->
    is_redblack_color r Black.
  Proof.
    intros.
    inversion H.
    subst. eapply isr_isb; try eassumption.
    subst. auto.
  Qed.
  Lemma isrb_changekvt: forall c l k1 v1 k2 v2 t1 t2 r co, is_redblack_color (T c l k1 v1 t1 r) co ->
   is_redblack_color (T c l k2 v2 t2 r) co.
  Proof.
    intros.
    destruct co.
    - inversion H. subst. eapply IsRB_co_b; try eassumption.
    - inversion H. subst. eapply IsRB_co_r; try eassumption.
      subst. eapply IsRB_co_b; try eassumption.
  Qed.
  Lemma isrb_changekvt_dep: forall c l k1 v1 k2 v2 t1 t2 r n, is_redblack_dep (T c l k1 v1 t1 r) n ->
   is_redblack_dep (T c l k2 v2 t2 r) n.
  Proof.
    intros.
    inversion H.
    - subst. eapply IsRB_dep_r; try eassumption.
    - subst. eapply IsRB_dep_b; try eassumption.
  Qed.
  Lemma isrb_tagupdate: forall tree t co, is_redblack_color tree co -> is_redblack_color (tag_tree_t t tree ) co.
  Proof.
    intros.
    inversion H.
    subst. simpl. auto.
    subst. simpl. apply (isrb_changekvt _ _ _ _ _ _ _ _ _ _ H).
    subst. simpl. eapply isrb_changekvt; try eassumption.
  Qed.
  Lemma isrb_tagupdate_dep: forall tree t n, is_redblack_dep tree n -> is_redblack_dep (tag_tree_t t tree ) n.
  Proof.
    intros.
    inversion H.
    subst. simpl. auto.
    subst. simpl. apply (isrb_changekvt_dep _ _ _ _ _ _ _ _ _ _ H).
    subst. simpl. eapply isrb_changekvt_dep; try eassumption.
  Qed.
  Lemma isrb_dep_RtoB : forall l k v t r n,
   is_redblack_dep (T Red l k v t r) n ->
    is_redblack_dep (T Black l k v t r) (S n).
  Proof.
    intros.
    inversion H;subst.
    eapply IsRB_dep_b;try eassumption.
  Qed.

End Section_RBtree_Def_2.

Ltac rbco n :=
    first [assumption | apply (IsRB_co_leaf Red) | apply (IsRB_co_leaf Black)|
      match n with
      | S ?m =>
          match goal with
          | H: is_redblack_color ?a Red |- is_redblack_color ?a Black => eapply isr_isb;rbco m
          | H: is_redblack_color ?a Black,
            H0: Black_tree ?a |- is_redblack_color ?a Red => eapply (isb_isr_black _ H0);rbco m
          | |- is_redblack_color (tag_tree_t _ ?a) _ => eapply isrb_tagupdate;rbco m
          | H: is_redblack_color (T _ ?a _ _ _ _ ) _ |- is_redblack_color ?a _ => inversion H;subst;rbco m
          | H: is_redblack_color (T _ _ _ _ _ ?a ) _ |- is_redblack_color ?a _ => inversion H;subst;rbco m
          | |- is_redblack_color (T Red _ _ _ _ _ ) Black => apply IsRB_co_r;rbco m
          | |- is_redblack_color (T Black _ _ _ _ _ ) _ => apply IsRB_co_b;rbco m
          end
      end].
Ltac rbdep n :=
    first [assumption | apply IsRB_dep_em |
      match n with
      | S ?m =>
          match goal with
          | H: is_redblack_dep (T ?c ?l _ _ _ ?r) ?n
                |- is_redblack_dep (T ?c ?l _ _ _ ?r) ?n
                     => eapply isrb_changekvt_dep;try eassumption
          | |- is_redblack_dep (tag_tree_t _ ?a) ?n
                    => eapply isrb_tagupdate_dep;rbdep m
          | H: is_redblack_dep (T Red ?l _ _ _ ?r) ?n
                |- is_redblack_dep (T Black ?l _ _ _ ?r) (S ?n)
                     => eapply isrb_dep_RtoB;rbdep m
          | |- is_redblack_dep (T Red _ _ _ _ _ ) _ => eapply IsRB_dep_r;rbdep m
          | |- is_redblack_dep (T Black _ _ _ _ _ ) _ => eapply IsRB_dep_b;rbdep m
          end
      end].


Require Import PPS.SOS.SOS.
Require Export PPS.Exercises.S2.Exp_Let.
Require Import PPS.Env.

Set Implicit Arguments.

Reserved Notation "Sigma '|-a' e ⇓ v" (at level 40).
Reserved Notation "Sigma '|-b' e ⇓ v" (at level 40).

Section ArithRelation.

  Inductive aevalR : AExp -> SOS_Context nat -> nat -> Prop :=
  | EvNum  : forall Sigma n, Sigma |-a ANum n ⇓ n
  | EvVar  : forall Sigma x v,
      SOS_lookup Sigma x = Some v ->
      Sigma |-a AVar x ⇓ v
  | EvPlus : forall Sigma e1 e2 v1 v2 v,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      v = v1 + v2 ->
      Sigma |-a APlus e1 e2 ⇓ v
  | EvSub : forall Sigma e1 e2 v1 v2 v,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      v = v1 - v2 ->
      Sigma |-a AMinus e1 e2 ⇓ v
  | EvMult : forall Sigma e1 e2 v1 v2 v,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      v = v1 * v2 ->
      Sigma |-a AMult e1 e2 ⇓ v
  (* >>>>>>>>>>>>>>>>>>>>> *)
  | EvLet : forall Sigma x e1 e2 v1 v2,
      Sigma |-a e1 ⇓ v1 ->
      let Delta := add Sigma x v1
      in Delta |-a e2 ⇓ v2 ->
      Sigma |-a ALet x e1 e2 ⇓ v2
  (* <<<<<<<<<<<<<<<<<<<<< *)
  where "Sigma '|-a' e ⇓ v" := (aevalR e Sigma v).

End ArithRelation.

Section ArithFunction.

  Fixpoint aevalF (e : AExp) (c0 : SOS_Context nat) : option nat :=
    match e with
    | ANum n => Some n
    | AVar x => SOS_lookup c0 x
    | APlus e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 =>
        Some (v1 + v2)
      | _,_ => None
      end
    | AMult e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 =>
        Some (v1 * v2)
      | _,_ => None
      end
    | AMinus e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 =>
        Some (v1 - v2)
      | _,_ => None
      end
    (* >>>>>>>>>>>>>>>>>>>>> *)
    | ALet x e1 e2 =>
      match aevalF e1 c0 with
      | Some v1 =>
        aevalF e2 (add c0 x v1)
      | _ => None
      end
    (* <<<<<<<<<<<<<<<<<<<<< *)
    end.

End ArithFunction.

Notation "Sigma '|-a' e ⇓ v" := (aevalR e Sigma v).

Section BoolRelation.

  Inductive bevalR : BExp -> SOS_Context nat -> bool -> Prop :=
  | EvT : forall Sigma, Sigma |-b BTrue ⇓ true
  | EvF : forall Sigma, Sigma |-b BFalse ⇓ false
  | EvLess : forall Sigma e1 e2 v1 v2 b,
      Sigma |-a e1 ⇓ v1 ->
      Sigma |-a e2 ⇓ v2 ->
      b = Nat.leb v1 v2 ->
      Sigma |-b BLess e1 e2 ⇓ b
  where "Sigma '|-b' e ⇓ v" := (bevalR e Sigma v).

End BoolRelation.

Section BoolFunction.

  Fixpoint bevalF (be : BExp) (c0 : SOS_Context nat) : option bool :=
    match be with
    | BTrue => Some true
    | BFalse => Some false
    | BLess e1 e2 =>
      match aevalF e1 c0, aevalF e2 c0 with
      | Some v1, Some v2 => Some (Nat.leb v1 v2)
      | _,_ => None
      end
    end.

End BoolFunction.

Notation "Sigma '|-b' e ⇓ v" := (bevalR e Sigma v).


(* generated by Ott 0.10.17 ***locally nameless*** from: STLC.ott *)

Require Import Metatheory.

(** syntax *)
Definition termvar := var.

Inductive typ : Set :=
 | typ_base : typ
 | typ_arrow : typ -> typ -> typ.

Inductive term : Set :=
 | term_var_b : nat -> term
 | term_var_f : termvar -> term
 | term_abs : typ -> term -> term
 | term_app : term -> term -> term.

Definition typing_env : Set := list (atom*typ).

(* EXPERIMENTAL *)

(** opening up abstractions *)
Fixpoint open_term_wrt_term_rec (k:nat) (e_5:term) (e__6:term) {struct e__6}: term :=
  match e__6 with
  | (term_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => term_var_b nat
        | inleft (right _) => e_5
        | inright _ => term_var_b (nat - 1)
      end
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs t (open_term_wrt_term_rec (S k) e_5 e)
  | (term_app e1 e2) => term_app (open_term_wrt_term_rec k e_5 e1) (open_term_wrt_term_rec k e_5 e2)
end.

Definition open_term_wrt_term e_5 e__6 := open_term_wrt_term_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_term *)
Inductive lc_term : term -> Prop :=    (* defn lc_term *)
 | lc_term_var_f : forall (x:termvar),
     (lc_term (term_var_f x))
 | lc_term_abs : forall (t:typ) (e:term),
      ( forall x , lc_term  ( open_term_wrt_term e (term_var_f x) )  )  ->
     (lc_term (term_abs t e))
 | lc_term_app : forall (e1 e2:term),
     (lc_term e1) ->
     (lc_term e2) ->
     (lc_term (term_app e1 e2)).

(** free variables *)
Fixpoint fv_term (e_5:term) : vars :=
  match e_5 with
  | (term_var_b nat) => {}
  | (term_var_f x) => {{x}}
  | (term_abs t e) => (fv_term e)
  | (term_app e1 e2) => (fv_term e1) \u (fv_term e2)
end.

(** substitutions *)
Fixpoint subst_term (e_5:term) (x5:termvar) (e__6:term) {struct e__6} : term :=
  match e__6 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => (if eq_var x x5 then e_5 else (term_var_f x))
  | (term_abs t e) => term_abs t (subst_term e_5 x5 e)
  | (term_app e1 e2) => term_app (subst_term e_5 x5 e1) (subst_term e_5 x5 e2)
end.

(** definitions *)

(* defns Jval *)
Inductive pval : term -> Prop :=    (* defn pval *)
 | pval_var : forall (x:termvar),
     pval (term_var_f x)
 | pval_app : forall (e1 e2:term),
     pval e1 ->
     val e2 ->
     pval  ( (term_app e1 e2) )
with val : term -> Prop :=    (* defn val *)
 | val_pval : forall (e:term),
     pval e ->
     val e
 | val_abs : forall (L:vars) (t:typ) (e:term),
      ( forall x , x \notin  L  -> val  ( open_term_wrt_term e (term_var_f x) )  )  ->
     val  ( (term_abs t e) ) .

(* defns Jwfterm *)
Inductive wfterm : typing_env -> term -> typ -> Prop :=    (* defn wfterm *)
 | wfterm_val : forall (G:typing_env) (x:termvar) (t:typ),
      uniq ( G )  ->
      binds ( x ) ( t ) ( G )  ->
     wfterm G (term_var_f x) t
 | wfterm_app : forall (G:typing_env) (e1 e2:term) (t1 t2:typ),
     wfterm G e1 (typ_arrow t2 t1) ->
     wfterm G e2 t2 ->
     wfterm G (term_app e1 e2) t1
 | wfterm_abs : forall (L:vars) (G:typing_env) (t1:typ) (e:term) (t2:typ),
      ( forall x , x \notin  L  -> wfterm  ( x ~ t1  ++  G )   ( open_term_wrt_term e (term_var_f x) )  t2 )  ->
     wfterm G (term_abs t1 e) (typ_arrow t1 t2).

(* defns Jred0 *)
Inductive red0 : term -> term -> Prop :=    (* defn red0 *)
 | red0_beta : forall (t:typ) (e1 e2:term),
     lc_term (term_abs t e1) ->
     lc_term e2 ->
     red0 (term_app  ( (term_abs t e1) )  e2)  (open_term_wrt_term  e1   e2 ) .

(* defns Jred1 *)
Inductive red1 : term -> term -> Prop :=    (* defn red1 *)
 | red1_empty : forall (e e':term),
     red0 e e' ->
     red1 e e'
 | red1_appL : forall (e1 e2 e1':term),
     lc_term e2 ->
     red1 e1 e1' ->
     red1 (term_app e1 e2) (term_app e1' e2)
 | red1_appR : forall (e1 e2 e2':term),
     lc_term e1 ->
     red1 e2 e2' ->
     red1 (term_app e1 e2) (term_app e1 e2')
 | red1_abs : forall (L:vars) (t:typ) (e e':term),
      ( forall x , x \notin  L  -> red1  ( open_term_wrt_term e (term_var_f x) )   ( open_term_wrt_term e' (term_var_f x) )  )  ->
     red1 (term_abs t e) (term_abs t e').

(** infrastructure *)

(* additional definitions *)

(* instanciation of tactics *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let D1 := gather_atoms_with (fun x => fv_term x) in
  constr:(A \u B \u D1).

Hint Constructors pval val wfterm red0 red1 lc_term.


Inductive Le : nat -> nat -> Set :=
  | LeO : forall n : nat, Le 0 n
  | LeS : forall n m : nat, Le n m -> Le (S n) (S m).

Parameter discr_l : forall n : nat, S n <> 0.

Type
  (fun n : nat =>
   match n return (n = 0 \/ n <> 0) with
   | O => or_introl (0 <> 0) (refl_equal 0)
   | S O => or_intror (1 = 0) (discr_l 0)
   | S (S x) => or_intror (S (S x) = 0) (discr_l (S x))
   end).

Parameter iguales : forall (n m : nat) (h : Le n m), Prop.

Type
  match LeO 0 as h in (Le n m) return Prop with
  | LeO O => True
  | LeS (S x) (S y) H => iguales (S x) (S y) H
  | _ => False
  end.

Type
  match LeO 0 as h in (Le n m) return Prop with
  | LeO O => True
  | LeS (S x) O H => iguales (S x) 0 H
  | _ => False
  end.


Require Export Rbase.
Require Import Reals.
Require Export ROrderedType.
Require Import Sail2_values.

(* "Decidable" in a classical sense... *)
Instance Decidable_eq_real : forall (x y : R), Decidable (x = y) :=
  Decidable_eq_from_dec Req_dec.

Definition realFromFrac (num denom : Z) : R := Rdiv (IZR num) (IZR denom).

Definition neg_real := Ropp.
Definition mult_real := Rmult.
Definition sub_real := Rminus.
Definition add_real := Rplus.
Definition div_real := Rdiv.
Definition sqrt_real := sqrt.
Definition abs_real := Rabs.

(* Use flocq definitions, but without making the whole library a dependency. *)
Definition round_down (x : R) := (up x - 1)%Z.
Definition round_up (x : R) := (- round_down (- x))%Z.

Definition to_real := IZR.

Definition eq_real := Reqb.
Definition gteq_real (x y : R) : bool := if Rge_dec x y then true else false.
Definition lteq_real (x y : R) : bool := if Rle_dec x y then true else false.
Definition gt_real (x y : R) : bool := if Rgt_dec x y then true else false.
Definition lt_real (x y : R) : bool := if Rlt_dec x y then true else false.

(* Export select definitions from outside of Rbase *)
Definition pow_real := powerRZ.

Definition print_real (_ : string) (_ : R) : unit := tt.
Definition prerr_real (_ : string) (_ : R) : unit := tt.