Require Import Zpower.
Require Export ZArithRing.
Require Import Omega.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Psatz.
From CReal Require Import INQ_libs.
From CReal Require Import ComRealBase.
From CReal Require Import ComRealField.
From Coq Require Import Logic.Classical.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Logic.PropExtensionality.

(* Lemmas copied from RIneq.v *)
(* Change dec into or *)
(* Supplementary Theorem about IQR *)

Module VirRLemma1 (R : VIR_R).

  Module RF := VirR_Field (R).
  Import R.
  Export RF.
  Local Open Scope R_scope.

(*********************************************************)
(** ** Relation between orders and equality              *)
(*********************************************************)

(** Reflexivity of the large order *)

Lemma not_Req_sym : forall r1 r2 , ~ r1 == r2 <-> ~ r2 == r1.
Proof.
  intros. split ; intros ; intro ; apply H ; rewrite H0 ; reflexivity.
Qed.

Lemma Rle_refl : forall r, r <= r.
Proof.
  intro; right; reflexivity.
Qed.
Hint Immediate Rle_refl: rorders.

Lemma Rge_refl : forall r, r <= r.
Proof. exact Rle_refl. Qed.
Hint Immediate Rge_refl: rorders.

(** Irreflexivity of the strict order *)

Lemma Rlt_irrefl : forall r, ~ r < r.
Proof.
  intros r H; eapply Rlt_asym; eauto.
Qed.
Hint Resolve Rlt_irrefl: real.

Lemma Rgt_irrefl : forall r, ~ r > r.
Proof. exact Rlt_irrefl. Qed.

Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> ~ r1 == r2.
Proof.
  red; intros r1 r2 H H0; apply (Rlt_irrefl r1).
  rewrite H0 at 2. auto.
Qed.

Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> ~ r1 == r2.
Proof.
  intros. intro.
  apply (Rlt_irrefl r1).
  rewrite H0 at 1.
  auto.
Qed.

(**********)
Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> ~ r1 == r2.
Proof.
  intuition.
  - apply Rlt_not_eq in H1. eauto.
  - apply Rgt_not_eq in H1. eauto.
Qed.
Hint Resolve Rlt_dichotomy_converse: real.

(** Reasoning by case on equality and order *)

(**********)
Lemma Req_dec : forall r1 r2 :R , r1 == r2 \/ ~ r1 == r2.
Proof.
  intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
    unfold not; intuition eauto 3.
Qed.
Hint Resolve Req_dec: real.

(**********)
Lemma Rtotal_order : forall r1 r2, r1 < r2 \/ r1 == r2 \/ r1 > r2.
Proof.
  intros; generalize (total_order_T r1 r2); tauto.
Qed.

(**********)
Lemma Rdichotomy : forall r1 r2, ~ r1 == r2 -> r1 < r2 \/ r1 > r2.
Proof.
  intros; generalize (total_order_T r1 r2); tauto.
Qed.

(*********************************************************)
(** ** Relating [<], [>], [<=] and [>=]  	         *)
(*********************************************************)

(*********************************************************)
(** ** Order                                             *)
(*********************************************************)

(** *** Relating strict and large orders *)

Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2.
Proof.
  intros; red; tauto.
Qed.
Hint Resolve Rlt_le: real.

Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2.
Proof.
  intros; red; tauto.
Qed.

(**********)
Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1.
Proof.
  destruct 1; red; auto with real.
Qed.
Hint Immediate Rle_ge: real.
Hint Resolve Rle_ge: rorders.

Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1.
Proof.
  destruct 1; red; auto with real.
Qed.
Hint Resolve Rge_le: real.
Hint Immediate Rge_le: rorders.

(**********)
Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1.
Proof.
  trivial.
Qed.
Hint Resolve Rlt_gt: rorders.

Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1.
Proof.
  trivial.
Qed.
Hint Immediate Rgt_lt: rorders.

(**********)

Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1.
Proof.
  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle; tauto.
Qed.
Hint Immediate Rnot_le_lt: real.

Lemma Rnot_ge_gt : forall r1 r2, ~ r1 >= r2 -> r2 > r1.
Proof. intros; red; apply Rnot_le_lt. auto with real. Qed.

Lemma Rnot_le_gt : forall r1 r2, ~ r1 <= r2 -> r1 > r2.
Proof. intros; red; apply Rnot_le_lt. auto with real. Qed.

Lemma Rnot_ge_lt : forall r1 r2, ~ r1 >= r2 -> r1 < r2.
Proof. intros; apply Rnot_le_lt. auto with real. Qed.

Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1.
Proof.
  intros r1 r2 H; destruct (Rtotal_order r1 r2) as [ | [ H0 | H0 ] ].
    contradiction. rewrite H0; auto with rorders. auto with real.
Qed.

Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2.
Proof. auto using Rnot_lt_le with real. Qed.

Lemma Rnot_gt_ge : forall r1 r2, ~ r1 > r2 -> r2 >= r1.
Proof. intros; eauto using Rnot_lt_le with rorders. Qed.

Lemma Rnot_lt_ge : forall r1 r2, ~ r1 < r2 -> r1 >= r2.
Proof. eauto using Rnot_gt_ge with rorders. Qed.

(**********)
Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
Proof.
  generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle.
  unfold not; intuition eauto 3.
Qed.
Hint Immediate Rlt_not_le: real.

Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2.
Proof. exact Rlt_not_le. Qed.

Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2.
Proof. red; intros; eapply Rlt_not_le; eauto with real. Qed.
Hint Immediate Rlt_not_ge: real.

Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2.
Proof. exact Rlt_not_ge. Qed.

Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2.
Proof.
  intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2).
  unfold Rle; intuition.
Qed.

Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> ~ r1 < r2.
Proof. intros; apply Rle_not_lt; auto with real. Qed.

Lemma Rle_not_gt : forall r1 r2, r1 <= r2 -> ~ r1 > r2.
Proof. do 2 intro; apply Rle_not_lt. Qed.

Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> ~ r1 > r2.
Proof. do 2 intro; apply Rge_not_lt. Qed.

(**********)
Lemma Req_le : forall r1 r2, r1 == r2 -> r1 <= r2.
Proof.
  unfold Rle; tauto.
Qed.
Hint Immediate Req_le: real.

Lemma Req_ge : forall r1 r2, r1 == r2 -> r1 >= r2.
Proof.
  unfold Rge; tauto.
Qed.
Hint Immediate Req_ge: real.

Lemma Req_le_sym : forall r1 r2, r2 == r1 -> r1 <= r2.
Proof.
  unfold Rle; auto with real.
Qed.
Hint Immediate Req_le_sym: real.

Lemma Req_ge_sym : forall r1 r2, r2 == r1 -> r1 >= r2.
Proof.
  unfold Rge; auto with real.
Qed.
Hint Immediate Req_ge_sym: real.

(** *** Asymmetry *)

(** Remark: [Rlt_asym] is an axiom *)

Lemma Rgt_asym : forall r1 r2:R, r1 > r2 -> ~ r2 > r1.
Proof. do 2 intro; apply Rlt_asym. Qed.

(** *** Antisymmetry *)

Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 == r2.
Proof.
  intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle; intuition.
Qed.
Hint Resolve Rle_antisym: real.

Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 == r2.
Proof. auto with real. Qed.

(**********)
Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 == r2.
Proof.
  intuition.
Qed.

Lemma Rge_ge_eq : forall r1 r2, r1 >= r2 /\ r2 >= r1 <-> r1 == r2.
Proof.
  intuition.
Qed.

(** *** Compatibility with equality *)

Lemma Rlt_eq_compat :
  forall r1 r2 r3 r4, r1 == r2 -> r2 < r4 -> r4 == r3 -> r1 < r3.
Proof.
  intros x x' y y'; intros ; rewrite H ; rewrite <- H1 ;  assumption.
Qed.

Lemma Rgt_eq_compat :
  forall r1 r2 r3 r4, r1 == r2 -> r2 > r4 -> r4 == r3 -> r1 > r3.
Proof. intros; red; apply Rlt_eq_compat with (r2:=r4) (r4:=r2); auto with real. Qed.

(** *** Transitivity *)

(** Remark: [Rlt_trans] is an axiom *)

Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3.
Proof.
  generalize Req_trans Rlt_trans Rlt_eq_compat.
  unfold Rle. intros.
  destruct H2 , H3.
  - left. eauto.
  - left. rewrite H3 in H2. auto.
  - left. rewrite H2. auto.
  - right. eauto.
Qed.

Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3.
Proof. eauto using Rle_trans with rorders. Qed.

Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3.
Proof. eauto using Rlt_trans with rorders. Qed.

(**********)
Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
Proof.
  generalize Rlt_trans Rlt_eq_compat.
  unfold Rle. intros.
  destruct H1 ; eauto.
  rewrite H1 ; auto.
Qed.

Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3.
Proof.
  generalize Rlt_trans Rlt_eq_compat; unfold Rle; intuition eauto 2.
  rewrite <- H3. auto.
Qed.

Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3.
Proof. eauto using Rlt_le_trans with rorders. Qed.

Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3.
Proof. eauto using Rle_lt_trans with rorders. Qed.

(** *** (Classical) decidability *)

Lemma Rlt_dec : forall r1 r2, r1 < r2 \/ ~ r1 < r2.
Proof.
  intros; generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2);
    intuition.
Qed.

Lemma Rle_dec : forall r1 r2, r1 <= r2 \/ ~ r1 <= r2.
Proof.
  intros r1 r2.
  generalize (total_order_T r1 r2) (Rlt_dichotomy_converse r1 r2).
  intuition eauto 4 with real.
Qed.

Lemma Rgt_dec : forall r1 r2, r1 > r2 \/ ~ r1 > r2.
Proof. do 2 intro; apply Rlt_dec. Qed.

Lemma Rge_dec : forall r1 r2, r1 >= r2 \/ ~ r1 >= r2.
Proof. intros; edestruct Rle_dec; [left|right]; eauto with rorders. Qed.

Lemma Rlt_le_dec : forall r1 r2, r1 < r2 \/ r2 <= r1.
Proof.
  intros; generalize (total_order_T r1 r2); intuition.
Qed.

Lemma Rgt_ge_dec : forall r1 r2, r1 > r2 \/ r2 >= r1.
Proof. intros; edestruct Rlt_le_dec; [left|right]; eauto with rorders. Qed.

Lemma Rle_lt_dec : forall r1 r2, r1 <= r2 \/ r2 < r1.
Proof.
  intros; generalize (total_order_T r1 r2); intuition.
Qed.

Lemma Rge_gt_dec : forall r1 r2, r1 >= r2 \/ r2 > r1.
Proof. intros; edestruct Rle_lt_dec; [left|right]; eauto with rorders. Qed.

Lemma Rlt_or_le : forall r1 r2, r1 < r2 \/ r2 <= r1.
Proof.
  intros n m; elim (Rle_lt_dec m n); auto with real.
Qed.

Lemma Rgt_or_ge : forall r1 r2, r1 > r2 \/ r2 >= r1.
Proof. intros; edestruct Rlt_or_le; [left|right]; eauto with rorders. Qed.

Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1.
Proof.
  intros n m; elim (Rlt_le_dec m n); auto with real.
Qed.

Lemma Rge_or_gt : forall r1 r2, r1 >= r2 \/ r2 > r1.
Proof. intros; edestruct Rle_or_lt; [left|right]; eauto with rorders. Qed.

Lemma Rle_lt_or_eq_dec : forall r1 r2, r1 <= r2 -> r1 < r2 \/ r1 == r2.
Proof.
  intros r1 r2 H; generalize (total_order_T r1 r2); intuition.
Qed.

(**********)
Lemma inser_trans_R :
  forall r1 r2 r3 r4, r1 <= r2 < r3 -> r1 <= r2 < r4 \/ r4 <= r2 < r3.
Proof.
  intros n m p q; intros; generalize (Rlt_le_dec m q); intuition.
Qed.

(*********************************************************)
(** ** Addition                                          *)
(*********************************************************)

(** Remark: [Rplus_0_l] is an axiom *)

Lemma Rplus_0_r : forall r, r + 0 == r.
Proof.
  intro; ring.
Qed.
Hint Resolve Rplus_0_r: real.

Lemma Rplus_ne : forall r, r + 0 == r /\ 0 + r == r.
Proof.
  split; ring.
Qed.
Hint Resolve Rplus_ne: real.

(**********)

(** Remark: [Rplus_opp_r] is an axiom *)

Lemma Rplus_opp_l : forall r, - r + r == 0.
Proof.
  intro; ring.
Qed.
Hint Resolve Rplus_opp_l: real.

(**********)
Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 == 0 -> r2 == - r1.
Proof.
  intros x y H.
  assert (y == - x + x + y). { ring. }
  rewrite H0.
  rewrite Rplus_assoc; rewrite H; ring.
Qed.

Lemma Rplus_eq_compat_l : forall r r1 r2, r1 == r2 -> r + r1 == r + r2.
Proof.
  intros. rewrite H. reflexivity.
Qed.

Lemma Rplus_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 + r == r2 + r.
Proof.
  intros.
  rewrite H. reflexivity.
Qed.

(**********)
Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 == r + r2 -> r1 == r2.
Proof.
  intros; transitivity (- r + r + r1).
  ring.
  transitivity (- r + r + r2).
  repeat rewrite Rplus_assoc; rewrite <- H; reflexivity.
  ring.
Qed.
Hint Resolve Rplus_eq_reg_l: real.

Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r == r2 + r -> r1 == r2.
Proof.
  intros r r1 r2 H.
  apply Rplus_eq_reg_l with r.
  now rewrite 2!(Rplus_comm r).
Qed.

(**********)
Lemma Rplus_0_r_uniq : forall r r1, r + r1 == r -> r1 == 0.
Proof.
  intros r b; pattern r at 2. simpl.
  intros. assert (r == r + 0). { ring. }
  eauto with real.
Qed.

(***********)
Lemma Rplus_eq_0_l :
  forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 == 0 -> r1 == 0.
Proof.
  intros a b H [H0| H0] H1; auto with real.
    absurd (0 < a + b).
      rewrite H1; auto with real.
      apply Rle_lt_trans with (a + 0).
        rewrite Rplus_0_r; assumption.
        auto using Rplus_lt_compat_l with real.
    rewrite <- H0, Rplus_0_r in H1; assumption.
Qed.

Lemma Rplus_eq_R0 :
  forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 == 0 -> r1 == 0 /\ r2 == 0.
Proof.
  intros a b; split.
  apply Rplus_eq_0_l with b; auto with real.
  apply Rplus_eq_0_l with a; auto with real.
  rewrite Rplus_comm; auto with real.
Qed.

(*********************************************************)
(** ** Multiplication                                    *)
(*********************************************************)

(**********)
Lemma Rinv_r : forall r, ~ r == 0 -> r * / r == 1.
Proof.
  intros; field; trivial.
Qed.
Hint Resolve Rinv_r: real.

Lemma Rinv_l_sym : forall r, ~ r == 0 -> 1 == / r * r.
Proof.
  intros; field; trivial.
Qed.
Hint Resolve Rinv_l_sym: real.

Lemma Rinv_r_sym : forall r, ~ r == 0 -> 1 == r * / r.
Proof.
  intros; field; trivial.
Qed.
Hint Resolve Rinv_r_sym: real.

(**********)
Lemma Rmult_0_r : forall r, r * 0 == 0.
Proof.
  intro; ring.
Qed.
Hint Resolve Rmult_0_r: real.

(**********)
Lemma Rmult_0_l : forall r, 0 * r == 0.
Proof.
  intro; ring.
Qed.
Hint Resolve Rmult_0_l: real.

(**********)
Lemma Rmult_ne : forall r, r * 1 == r /\ 1 * r == r.
Proof.
  intro; split; ring.
Qed.
Hint Resolve Rmult_ne: real.

(**********)
Lemma Rmult_1_r : forall r, r * 1 == r.
Proof.
  intro; ring.
Qed.
Hint Resolve Rmult_1_r: real.

(**********)
Lemma Rmult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2.
Proof.
  intros. rewrite H.
  auto with real.
Qed.

Lemma Rmult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r.
Proof.
  intros.
  rewrite <- 2!(Rmult_comm r).
  now apply Rmult_eq_compat_l.
Qed.

(**********)
Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 == r * r2 -> ~ r == 0 -> r1 == r2.
Proof.
  intros; transitivity (/ r * r * r1).
  field; trivial.
  transitivity (/ r * r * r2).
  repeat rewrite Rmult_assoc; rewrite H; trivial.
  field; trivial.
  rewrite Rinv_l ; auto with real.
Qed.

Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> ~ r == 0 -> r1 == r2.
Proof.
  intros.
  apply Rmult_eq_reg_l with (2 := H0).
  now rewrite 2!(Rmult_comm r).
Qed.

(**********)
Lemma Rmult_integral : forall r1 r2, r1 * r2 == 0 -> r1 == 0 \/ r2 == 0.
Proof.
  intros; case (Req_dec r1 0); [ intro Hz | intro Hnotz ].
  auto.
  right; apply Rmult_eq_reg_l with r1; trivial.
  rewrite H; auto with real.
Qed.

(**********)
Lemma Rmult_eq_0_compat : forall r1 r2, r1 == 0 \/ r2 == 0 -> r1 * r2 == 0.
Proof.
  intros r1 r2 [H| H]; rewrite H; auto with real.
Qed.

Hint Resolve Rmult_eq_0_compat: real.

(**********)
Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 == 0 -> r1 * r2 == 0.
Proof.
  auto with real.
Qed.

(**********)
Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 == 0 -> r1 * r2 == 0.
Proof.
  auto with real.
Qed.

(**********)
Lemma Rmult_neq_0_reg : forall r1 r2, ~ r1 * r2 == 0 -> ~ r1 == 0 /\ ~ r2 == 0.
Proof.
  intros r1 r2 H; split; red; intro; apply H; auto with real.
Qed.

(**********)
Lemma Rmult_integral_contrapositive :
  forall r1 r2, ~ r1 == 0 /\ ~ r2 == 0 -> ~ r1 * r2 == 0.
Proof.
  red; intros r1 r2 [H1 H2] H.
  case (Rmult_integral r1 r2); auto with real.
Qed.
Hint Resolve Rmult_integral_contrapositive: real.

Lemma Rmult_integral_contrapositive_currified :
  forall r1 r2, ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
Proof. auto using Rmult_integral_contrapositive. Qed.

(**********)
Lemma Rmult_plus_distr_r :
  forall r1 r2 r3, (r1 + r2) * r3 == r1 * r3 + r2 * r3.
Proof.
  intros; ring.
Qed.

(*********************************************************)
(** ** Square function                                   *)
(*********************************************************)

(***********)
Definition Rsqr r : R := r * r.

Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope.

(***********)
Lemma Rsqr_0 : Rsqr 0 == 0.
  unfold Rsqr; auto with real.
Qed.

(***********)
Lemma Rsqr_0_uniq : forall r, Rsqr r == 0 -> r == 0.
  unfold Rsqr; intros; elim (Rmult_integral r r H); trivial.
Qed.

(*********************************************************)
(** ** Opposite                                          *)
(*********************************************************)

(**********)
Lemma Ropp_eq_compat : forall r1 r2, r1 == r2 -> - r1 == - r2.
Proof.
  intros. rewrite H. reflexivity.
Qed.
Hint Resolve Ropp_eq_compat: real.

(**********)
Lemma Ropp_0 : -0 == 0.
Proof.
  ring.
Qed.
Hint Resolve Ropp_0: real.

(**********)
Lemma Ropp_eq_0_compat : forall r, r == 0 -> - r == 0.
Proof.
  intros; rewrite H; auto with real.
Qed.
Hint Resolve Ropp_eq_0_compat: real.

(**********)
Lemma Ropp_involutive : forall r, - - r == r.
Proof.
  intro; ring.
Qed.
Hint Resolve Ropp_involutive: real.

(*********)
Lemma Ropp_neq_0_compat : forall r, ~ r == 0 -> ~ - r == 0.
Proof.
  intros r H H0.
  apply H.
  transitivity (- - r); auto with real.
Qed.
Hint Resolve Ropp_neq_0_compat: real.

(**********)
Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2.
Proof.
  intros; ring.
Qed.
Hint Resolve Ropp_plus_distr: real.

(*********************************************************)
(** ** Opposite and multiplication                       *)
(*********************************************************)

Lemma Ropp_mult_distr_l : forall r1 r2, - (r1 * r2) == - r1 * r2.
Proof.
  intros; ring.
Qed.

Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 == - (r1 * r2).
Proof.
  intros; ring.
Qed.
Hint Resolve Ropp_mult_distr_l_reverse: real.

(**********)
Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 == r1 * r2.
Proof.
  intros; ring.
Qed.
Hint Resolve Rmult_opp_opp: real.

Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) == r1 * - r2.
Proof.
  intros; ring.
Qed.

Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 == - (r1 * r2).
Proof.
  intros; ring.
Qed.

(*********************************************************)
(** ** Subtraction                                      *)
(*********************************************************)

Lemma Rminus_0_r : forall r, r - 0 == r.
Proof.
  intro; ring.
Qed.
Hint Resolve Rminus_0_r: real.

Lemma Rminus_0_l : forall r, 0 - r == - r.
Proof.
  intro; ring.
Qed.
Hint Resolve Rminus_0_l: real.

(**********)
Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) == r2 - r1.
Proof.
  intros; ring.
Qed.
Hint Resolve Ropp_minus_distr: real.

Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) == r1 - r2.
Proof.
  intros; ring.
Qed.

(**********)
Lemma Rminus_diag_eq : forall r1 r2, r1 == r2 -> r1 - r2 == 0.
Proof.
  intros; rewrite H; ring.
Qed.
Hint Resolve Rminus_diag_eq: real.

(**********)
Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 == 0 -> r1 == r2.
Proof.
  intros r1 r2; unfold Rminus; rewrite Rplus_comm; intro.
  rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H).
Qed.
Hint Immediate Rminus_diag_uniq: real.

Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 == 0 -> r1 == r2.
Proof.
  intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; intro H; rewrite H;
    ring.
Qed.
Hint Immediate Rminus_diag_uniq_sym: real.

Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) == r2.
Proof.
  intros; ring.
Qed.
Hint Resolve Rplus_minus: real.

(**********)
Lemma Rminus_eq_contra : forall r1 r2, ~ r1 == r2 -> ~ r1 - r2 == 0.
Proof.
  red; intros r1 r2 H H0.
  apply H; auto with real.
Qed.
Hint Resolve Rminus_eq_contra: real.

Lemma Rminus_not_eq : forall r1 r2, ~ r1 - r2 == 0 -> ~ r1 == r2.
Proof.
  red; intros; elim H; apply Rminus_diag_eq; auto.
Qed.
Hint Resolve Rminus_not_eq: real.

Lemma Rminus_not_eq_right : forall r1 r2, ~ r2 - r1 == 0 -> ~ r1 == r2.
Proof.
  red; intros; elim H; rewrite H0; ring.
Qed.
Hint Resolve Rminus_not_eq_right: real.

(**********)
Lemma Rmult_minus_distr_l :
  forall r1 r2 r3, r1 * (r2 - r3) == r1 * r2 - r1 * r3.
Proof.
  intros; ring.
Qed.

(*********************************************************)
(** ** Inverse                                           *)
(*********************************************************)

Lemma Rinv_1 : / 1 == 1.
Proof.
  field. auto with real.
Qed.
Hint Resolve Rinv_1: real.

(*********)
Lemma Rinv_neq_0_compat : forall r, ~ r == 0 -> ~ / r == 0.
Proof.
  red; intros; apply R1_neq_R0.
  rewrite <- (Rinv_l r) ; auto with real.
Qed.
Hint Resolve Rinv_neq_0_compat: real.

(*********)
Lemma Rinv_involutive : forall r, ~ r == 0 -> / / r == r.
Proof.
  intros; field; auto with real.
Qed.
Hint Resolve Rinv_involutive: real.

(*********)
Lemma Rinv_mult_distr :
  forall r1 r2, ~ r1 == 0 -> ~ r2 == 0 -> / (r1 * r2) == / r1 * / r2.
Proof.
  intros; field; auto.
Qed.

(*********)
Lemma Ropp_inv_permute : forall r, ~ r == 0 -> - / r == / - r.
Proof.
  intros; field; auto with real.
Qed.

Lemma Rinv_r_simpl_r : forall r1 r2, ~ r1 == 0 -> r1 * / r1 * r2 == r2.
Proof.
  intros; transitivity (1 * r2); auto with real.
  rewrite Rinv_r; auto with real.
Qed.

Lemma Rinv_r_simpl_l : forall r1 r2, ~ r1 == 0 -> r2 * r1 * / r1 == r2.
Proof.
  intros; transitivity (r2 * 1); auto with real.
  transitivity (r2 * (r1 * / r1)); auto with real.
  rewrite Rinv_r ; auto with real.
Qed.

Lemma Rinv_r_simpl_m : forall r1 r2, ~ r1 == 0 -> r1 * r2 * / r1 == r2.
Proof.
  intros; transitivity (r2 * 1); auto with real.
  transitivity (r2 * (r1 * / r1)); auto with real.
  ring. rewrite Rinv_r ; auto with real.
Qed.
Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: real.

(*********)
Lemma Rinv_mult_simpl :
  forall r1 r2 r3, ~ r1 == 0 -> r1 * / r2 * (r3 * / r1) == r3 * / r2.
Proof.
  intros a b c; intros.
  transitivity (a * / a * (c * / b)); auto with real.
  ring.
Qed.

(*********************************************************)
(** ** Order and addition                                *)
(*********************************************************)

(** *** Compatibility *)

(** Remark: [Rplus_lt_compat_l] is an axiom *)

Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2.
Proof. eauto using Rplus_lt_compat_l with rorders. Qed.
Hint Resolve Rplus_gt_compat_l: real.

(**********)
Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r.
Proof.
  intros.
  rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real.
Qed.
Hint Resolve Rplus_lt_compat_r: real.

Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r.
Proof. do 3 intro; apply Rplus_lt_compat_r. Qed.

(**********)
Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2.
Proof.
  unfold Rle; intros; elim H; intro.
  left; apply (Rplus_lt_compat_l r r1 r2 H0).
  right; rewrite <- H0; auto with zarith real.
Qed.

Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2.
Proof. auto using Rplus_le_compat_l with rorders. Qed.
Hint Resolve Rplus_ge_compat_l: real.

(**********)
Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r.
Proof.
  unfold Rle; intros; elim H; intro.
  left; apply (Rplus_lt_compat_r r r1 r2 H0).
  right; rewrite <- H0; auto with real.
Qed.

Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real.

Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r.
Proof. auto using Rplus_le_compat_r with rorders. Qed.

(*********)
Lemma Rplus_lt_compat :
  forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
Proof.
  intros; apply Rlt_trans with (r2 + r3); auto with real.
Qed.
Hint Immediate Rplus_lt_compat: real.

Lemma Rplus_le_compat :
  forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4.
Proof.
  intros; apply Rle_trans with (r2 + r3); auto with real.
Qed.
Hint Immediate Rplus_le_compat: real.

Lemma Rplus_gt_compat :
  forall r1 r2 r3 r4, r1 > r2 -> r3 > r4 -> r1 + r3 > r2 + r4.
Proof. auto using Rplus_lt_compat with rorders. Qed.

Lemma Rplus_ge_compat :
  forall r1 r2 r3 r4, r1 >= r2 -> r3 >= r4 -> r1 + r3 >= r2 + r4.
Proof. auto using Rplus_le_compat with rorders. Qed.

(*********)
Lemma Rplus_lt_le_compat :
  forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4.
Proof.
  intros; apply Rlt_le_trans with (r2 + r3); auto with real.
Qed.

Lemma Rplus_le_lt_compat :
  forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4.
Proof.
  intros; apply Rle_lt_trans with (r2 + r3); auto with real.
Qed.

Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: real.

Lemma Rplus_gt_ge_compat :
  forall r1 r2 r3 r4, r1 > r2 -> r3 >= r4 -> r1 + r3 > r2 + r4.
Proof. auto using Rplus_lt_le_compat with rorders. Qed.

Lemma Rplus_ge_gt_compat :
  forall r1 r2 r3 r4, r1 >= r2 -> r3 > r4 -> r1 + r3 > r2 + r4.
Proof. auto using Rplus_le_lt_compat with rorders. Qed.

(**********)
Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2.
Proof.
  intros x y; intros; apply Rlt_trans with x ; auto.
  rewrite <- Rplus_0_r at 1.
  apply Rplus_lt_compat_l. auto.
Qed.

Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2.
Proof.
  intros x y; intros; apply Rle_lt_trans with x;
    [ assumption
      | rewrite <- (Rplus_0_r x) at 1; apply Rplus_lt_compat_l;
        assumption ].
Qed.

Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2.
Proof.
  intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat;
    assumption.
Qed.

Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2.
Proof.
  intros x y; intros; apply Rle_trans with x;
    [ assumption
      | rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l;
        assumption ].
Qed.

(**********)
Lemma sum_inequa_Rle_lt :
  forall a x b c y d:R,
    a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d.
Proof.
  intros; split.
  apply Rlt_le_trans with (a + y); auto with real.
  apply Rlt_le_trans with (b + y); auto with real.
Qed.

(** *** Cancellation *)

Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
Proof.
  intros; cut (- r + r + r1 < - r + r + r2).
  rewrite Rplus_opp_l.
  elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1;
    auto with zarith real.
  rewrite Rplus_assoc; rewrite Rplus_assoc;
    apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H).
Qed.

Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2.
Proof.
  intros.
  apply (Rplus_lt_reg_l r).
  now rewrite 2!(Rplus_comm r).
Qed.

Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2.
Proof.
  unfold Rle; intros; elim H; intro.
  left; apply (Rplus_lt_reg_l r r1 r2 H0).
  right; apply (Rplus_eq_reg_l r r1 r2 H0).
Qed.

Lemma Rplus_le_reg_r : forall r r1 r2, r1 + r <= r2 + r -> r1 <= r2.
Proof.
  intros.
  apply (Rplus_le_reg_l r).
  now rewrite 2!(Rplus_comm r).
Qed.

Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2.
Proof.
  unfold Rgt; intros; apply (Rplus_lt_reg_l r r2 r1 H).
Qed.

Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2.
Proof.
  intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with real.
Qed.

(**********)
Lemma Rplus_le_reg_pos_r :
  forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3.
Proof.
  intros x y z; intros; apply Rle_trans with (x + y);
    [ rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l;
      assumption
      | assumption ].
Qed.

Lemma Rplus_lt_reg_pos_r : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3.
Proof.
  intros x y z; intros; apply Rle_lt_trans with (x + y);
    [ rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l;
      assumption
      | assumption ].
Qed.

Lemma Rplus_ge_reg_neg_r :
  forall r1 r2 r3, 0 >= r2 -> r1 + r2 >= r3 -> r1 >= r3.
Proof.
  intros x y z; intros; apply Rge_trans with (x + y);
    [ rewrite <- (Rplus_0_r x) at 1; apply Rplus_ge_compat_l;
      assumption
      | assumption ].
Qed.

Lemma Rplus_gt_reg_neg_r : forall r1 r2 r3, 0 >= r2 -> r1 + r2 > r3 -> r1 > r3.
Proof.
  intros x y z; intros; apply Rge_gt_trans with (x + y);
    [ rewrite <- (Rplus_0_r x) at 1; apply Rplus_ge_compat_l;
      assumption
      | assumption ].
Qed.

(*********************************************************)
(** ** Order and opposite                                *)
(*********************************************************)

(** *** Contravariant compatibility *)

Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2.
Proof.
  unfold Rgt; intros.
  apply (Rplus_lt_reg_l (r2 + r1)).
  assert (r2 + r1 + - r1 == r2). { ring. }
  assert (r2 + r1 + - r2 == r1). { ring. }
  rewrite H0, H1.
  exact H.
Qed.
Hint Resolve Ropp_gt_lt_contravar.

Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2.
Proof.
  unfold Rgt; auto with real.
Qed.
Hint Resolve Ropp_lt_gt_contravar: real.

(**********)
Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2.
Proof.
  auto with real.
Qed.
Hint Resolve Ropp_lt_contravar: real.

Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2.
Proof. auto with real. Qed.

(**********)
Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2.
Proof.
  unfold Rge; intros r1 r2 [H| H]; auto with real.
Qed.
Hint Resolve Ropp_le_ge_contravar: real.

Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2.
Proof.
  unfold Rle; intros r1 r2 [H| H]; auto with real.
Qed.
Hint Resolve Ropp_ge_le_contravar: real.

(**********)
Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2.
Proof.
  intros r1 r2 H; elim H; auto with real.
Qed.
Hint Resolve Ropp_le_contravar: real.

Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2.
Proof. auto using Ropp_le_contravar with real. Qed.

(**********)
Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r.
Proof.
  intros; rewrite <- Ropp_0 ; auto with real.
Qed.
Hint Resolve Ropp_0_lt_gt_contravar: real.

Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r.
Proof.
  intros; rewrite <- Ropp_0 ; auto with real.
Qed.
Hint Resolve Ropp_0_gt_lt_contravar: real.

(**********)
Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0.
Proof.
  intros; rewrite <- Ropp_0; auto with real.
Qed.
Hint Resolve Ropp_lt_gt_0_contravar: real.

Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0.
Proof.
  intros; rewrite <- Ropp_0; auto with real.
Qed.
Hint Resolve Ropp_gt_lt_0_contravar: real.

(**********)
Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r.
Proof.
  intros; rewrite <- Ropp_0; auto with real.
Qed.
Hint Resolve Ropp_0_le_ge_contravar: real.

Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r.
Proof.
  intros; rewrite <- Ropp_0; auto with real.
Qed.
Hint Resolve Ropp_0_ge_le_contravar: real.

(** *** Cancellation *)

Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2.
Proof.
  intros x y H'.
  rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
    auto with real.
Qed.
Hint Immediate Ropp_lt_cancel: real.

Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2.
Proof. auto using Ropp_lt_cancel with rorders. Qed.

Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2.
Proof.
  intros x y H.
  elim H; auto with real.
  intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y);
    rewrite H1; auto with real.
Qed.
Hint Immediate Ropp_le_cancel: real.

Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2.
Proof. auto using Ropp_le_cancel with rorders. Qed.

(*********************************************************)
(** ** Order and multiplication                          *)
(*********************************************************)

(** Remark: [Rmult_lt_compat_l] is an axiom *)

(** *** Covariant compatibility *)

Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r.
Proof.
  intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real.
Qed.
Hint Resolve Rmult_lt_compat_r.

Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r.
Proof. eauto using Rmult_lt_compat_r with rorders. Qed.

Lemma Rmult_gt_compat_l : forall r r1 r2, r > 0 -> r1 > r2 -> r * r1 > r * r2.
Proof. eauto using Rmult_lt_compat_l with rorders. Qed.

(**********)
Lemma Rmult_le_compat_l :
  forall r r1 r2, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2.
Proof.
  intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle;
    auto with real.
  right ; rewrite H0 ; reflexivity.
  right ; rewrite <- H ; ring.
  right ; rewrite <- H ; ring.
Qed.
Hint Resolve Rmult_le_compat_l: real.

Lemma Rmult_le_compat_r :
  forall r r1 r2, 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r.
Proof.
  intros r r1 r2 H; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r);
    auto with real.
Qed.
Hint Resolve Rmult_le_compat_r: real.

Lemma Rmult_ge_compat_l :
  forall r r1 r2, r >= 0 -> r1 >= r2 -> r * r1 >= r * r2.
Proof. eauto using Rmult_le_compat_l with rorders. Qed.

Lemma Rmult_ge_compat_r :
  forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r.
Proof. eauto using Rmult_le_compat_r with rorders. Qed.

(**********)
Lemma Rmult_le_compat :
  forall r1 r2 r3 r4,
    0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4.
Proof.
  intros x y z t H' H'0 H'1 H'2.
  apply Rle_trans with (r2 := x * t); auto with real.
  repeat rewrite (fun x => Rmult_comm x t).
  apply Rmult_le_compat_l; auto.
  apply Rle_trans with z; auto.
Qed.
Hint Resolve Rmult_le_compat: real.

Lemma Rmult_ge_compat :
  forall r1 r2 r3 r4,
    r2 >= 0 -> r4 >= 0 -> r1 >= r2 -> r3 >= r4 -> r1 * r3 >= r2 * r4.
Proof. auto with real rorders. Qed.

Lemma Rmult_gt_0_lt_compat :
  forall r1 r2 r3 r4,
    r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
Proof.
  intros; apply Rlt_trans with (r2 * r3); auto with real.
Qed.

(*********)
Lemma Rmult_le_0_lt_compat :
  forall r1 r2 r3 r4,
    0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
Proof.
  intros; apply Rle_lt_trans with (r2 * r3);
    [ apply Rmult_le_compat_r; [ assumption | left; assumption ]
      | apply Rmult_lt_compat_l;
        [ apply Rle_lt_trans with r1; assumption | assumption ] ].
Qed.

(*********)
Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2.
Proof. intros; rewrite <- (Rmult_0_l r2); auto with real. Qed.

Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof Rmult_lt_0_compat.

(** *** Contravariant compatibility *)

Lemma Rmult_le_compat_neg_l :
  forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1.
Proof.
  intros; rewrite <- (Ropp_involutive r); auto with real.
  do 2 rewrite (Ropp_mult_distr_l_reverse (- r)).
  apply Ropp_le_contravar; auto with real.
Qed.
Hint Resolve Rmult_le_compat_neg_l: real.

Lemma Rmult_le_ge_compat_neg_l :
  forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2.
Proof.
  intros; apply Rle_ge; auto with real.
Qed.
Hint Resolve Rmult_le_ge_compat_neg_l: real.

Lemma Rmult_lt_gt_compat_neg_l :
  forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2.
Proof.
  intros; rewrite <- (Ropp_involutive r); auto with real.
  rewrite (Ropp_mult_distr_l_reverse (- r));
    rewrite (Ropp_mult_distr_l_reverse (- r)).
  apply Ropp_lt_gt_contravar; auto with real.
Qed.

(** *** Cancellation *)

Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
Proof.
  intros z x y H H0.
  case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0.
  rewrite Eq0 in H0; exfalso; apply (Rlt_irrefl (z * y)); auto.
  generalize (Rmult_lt_compat_l z y x H Eq0); intro; exfalso;
    generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1);
      intro; apply (Rlt_irrefl (z * x)); auto.
Qed.

Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 0 < r -> r1 * r < r2 * r -> r1 < r2.
Proof.
  intros.
  apply Rmult_lt_reg_l with r.
  exact H.
  now rewrite 2!(Rmult_comm r).
Qed.

Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
Proof. eauto using Rmult_lt_reg_l with rorders. Qed.

Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2.
Proof.
  intros z x y H H0; case H0; auto with real.
  intros H1; apply Rlt_le.
  apply Rmult_lt_reg_l with (r := z); auto.
  intros H1.
  assert (/ z * (z * x) == x). { field. auto with real. }
  assert (/ z * (z * y) == y). { field. auto with real. }
  rewrite <- H2. rewrite <- H3.
  rewrite H1. auto with real.
Qed.

Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2.
Proof.
  intros.
  apply Rmult_le_reg_l with r.
  exact H.
  now rewrite 2!(Rmult_comm r).
Qed.

(*********************************************************)
(** ** Order and substraction                            *)
(*********************************************************)

Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0.
Proof.
  intros; apply (Rplus_lt_reg_l r2).
  assert (r2 + (r1 - r2) == r1). { ring. }
  rewrite H0.
  now rewrite Rplus_0_r.
Qed.
Hint Resolve Rlt_minus: real.

Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0.
Proof.
  intros; apply (Rplus_lt_reg_l r2).
  assert (r2 + (r1 - r2) == r1). { ring. }
  rewrite H0.
  now rewrite Rplus_0_r.
Qed.

Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a.
Proof.
  intros a b; apply Rgt_minus.
Qed.

(**********)
Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0.
Proof.
  destruct 1; unfold Rle; auto with real.
Qed.

Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0.
Proof.
  destruct 1.
    auto using Rgt_minus, Rgt_ge.
    right; auto using Rminus_diag_eq with rorders.
Qed.

(**********)
Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2.
Proof.
  intros.
  assert (r1 == r1 - r2 + r2). { ring. }
  rewrite H0. rewrite <- (Rplus_0_l r2) at 3. auto with real.
Qed.

Lemma Rminus_gt : forall r1 r2, r1 - r2 > 0 -> r1 > r2.
Proof.
  intros; rewrite <- (Rplus_0_l r2); auto with real.
  assert ( r1 == r1 - r2 + r2). { ring. }
  rewrite H0.
  apply Rplus_gt_compat_r; assumption.
Qed.

Lemma Rminus_gt_0_lt : forall a b, 0 < b - a -> a < b.
Proof. intro; intro; apply Rminus_gt. Qed.

(**********)
Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2.
Proof.
  intros.
  assert (r1 == r1 - r2 + r2). { ring. }
  rewrite H0.
  rewrite <- (Rplus_0_l r2) at 3.
  auto with real.
Qed.

Lemma Rminus_ge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2.
Proof.
  intros; rewrite <- (Rplus_0_l r2); auto with real.
  assert ( r1 == r1 - r2 + r2). { ring. }
  rewrite H0.
  apply Rplus_ge_compat_r; assumption.
Qed.

(**********)
Lemma tech_Rplus : forall r (s:R), 0 <= r -> 0 < s -> ~ r + s == 0.
Proof.
  intros. intro.
  apply (Rlt_irrefl 0).
  rewrite <- H1 at 2.
  apply Rle_lt_trans with r ; auto.
  rewrite <- Rplus_0_r at 1. auto with real.
Qed.
Hint Immediate tech_Rplus: real.

(*********************************************************)
(** ** Order and square function                         *)
(*********************************************************)

Lemma Rle_0_sqr : forall r, 0 <= Rsqr r.
Proof.
  intro; case (Rlt_le_dec r 0); unfold Rsqr; intro.
  - assert (r * r == -r * -r). { ring. }
    assert (0 == -r * 0). { ring. }
    rewrite H1. rewrite H0. auto with real.
  - assert (0 == 0 * r). { ring. }
    rewrite H0. auto with real.
Qed.

(***********)
Lemma Rlt_0_sqr : forall r, ~ r == 0 -> 0 < Rsqr r.
Proof.
  intros; case (Rdichotomy r 0); trivial; unfold Rsqr; intro.
  - assert (r * r == -r * -r). { ring. }
    assert (0 == -r * 0). { ring. }
    rewrite H1. rewrite H2. auto with real.
  - assert (0 == 0 * r). { ring. }
    rewrite H1. auto with real.
Qed.
Hint Resolve Rle_0_sqr Rlt_0_sqr: real.

(***********)
Lemma Rplus_sqr_eq_0_l : forall r1 r2, Rsqr r1 + Rsqr r2 == 0 -> r1 == 0.
Proof.
  intros a b; intros; apply Rsqr_0_uniq; apply Rplus_eq_0_l with (Rsqr b);
    auto with real.
Qed.

Lemma Rplus_sqr_eq_0 :
  forall r1 r2, Rsqr r1 + Rsqr r2 == 0 -> r1 == 0 /\ r2 == 0.
Proof.
  intros a b; split.
  apply Rplus_sqr_eq_0_l with b; auto with real.
  apply Rplus_sqr_eq_0_l with a; auto with real.
  rewrite Rplus_comm; auto with real.
Qed.

(*********************************************************)
(** ** Zero is less than one                             *)
(*********************************************************)

Lemma Rlt_0_1 : 0 < 1.
Proof.
  assert (1 == Rsqr 1). { unfold Rsqr. auto with real. }
  rewrite H. auto with real.
Qed.
Hint Resolve Rlt_0_1: real.

Lemma Rle_0_1 : 0 <= 1.
Proof.
  left.
  exact Rlt_0_1.
Qed.

(*********************************************************)
(** ** Order and inverse                                 *)
(*********************************************************)

Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r.
Proof.
  intros; apply Rnot_le_lt; red; intros.
  absurd (1 <= 0); auto with real.
  rewrite <- (Rinv_l r) ; auto with real.
  rewrite <- (Rmult_0_l r). auto with real.
Qed.
Hint Resolve Rinv_0_lt_compat: real.

(*********)
Lemma Rinv_lt_0_compat : forall r, r < 0 -> / r < 0.
Proof.
  intros; apply Rnot_le_lt; red; intros.
  absurd (1 <= 0); auto with real.
  rewrite <- (Rinv_l r) ; auto with real.
  rewrite <- (Rmult_0_r (/ r)). auto with real.
Qed.
Hint Resolve Rinv_lt_0_compat: real.

(*********)
Lemma Rinv_lt_contravar : forall r1 r2, 0 < r1 * r2 -> r1 < r2 -> / r2 < / r1.
Proof.
  intros; apply Rmult_lt_reg_l with (r1 * r2); auto with real.
  case (Rmult_neq_0_reg r1 r2); intros; auto with real.
  assert (r1 * r2 * / r2 == r1). { field. trivial. }
  assert (r1 * r2 * / r1 == r2). { field. trivial. }
  rewrite H3 , H4. trivial.
Qed.

Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1.
Proof.
  intros x y H' H'0.
  cut (0 < x); [ intros Lt0 | apply Rlt_le_trans with (r2 := 1) ];
    auto with real.
  apply Rmult_lt_reg_l with (r := x); auto with real.
  rewrite (Rmult_comm x (/ x)); rewrite Rinv_l; auto with real.
  apply Rmult_lt_reg_l with (r := y); auto with real.
  apply Rlt_trans with (r2 := x); auto.
  cut (y * (x * / y) == x).
  intro H1; rewrite H1; rewrite (Rmult_1_r y); auto.
  rewrite (Rmult_comm x (/y)); rewrite <- Rmult_assoc; rewrite (Rmult_comm y (/ y));
    rewrite Rinv_l; auto with real.
  apply Rlt_dichotomy_converse; right.
  red; apply Rlt_trans with (r2 := x); auto with real.
Qed.
Hint Resolve Rinv_1_lt_contravar: real.

(*********************************************************)
(** ** Miscellaneous                                     *)
(*********************************************************)

(**********)
Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1.
Proof.
  intros.
  apply Rlt_le_trans with 1; auto with real.
  rewrite <- (Rplus_0_l 1)at 1; auto with real.
Qed.
Hint Resolve Rle_lt_0_plus_1: real.

(**********)
Lemma Rlt_plus_1 : forall r, r < r + 1.
Proof.
  intros. rewrite <- (Rplus_0_r r) at 1 ; auto with real.
Qed.
Hint Resolve Rlt_plus_1: real.

(**********)
Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2.
Proof.
  red; unfold Rminus; intros.
  rewrite <- (Rplus_0_r r1) at 2; auto with real.
Qed.

(*********************************************************)
(** ** Injection from [N] to [R]                         *)
(*********************************************************)

(**********)
Lemma S_INR : forall n:nat, INR (S n) == INR n + 1.
Proof.
  intro; case n; auto with real.
Qed.

(**********)
Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n.
Proof.
  intro; simpl; case n; intros; auto with real.
Qed.

(**********)
Lemma plus_INR : forall n m:nat, INR (n + m) == INR n + INR m.
Proof.
  intros n m; induction  n as [| n Hrecn].
  simpl; auto with real.
  replace (S n + m)%nat with (S (n + m)); auto with arith.
  repeat rewrite S_INR.
  rewrite Hrecn; ring.
Qed.
Hint Resolve plus_INR: real.

(**********)
Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) == INR n - INR m.
Proof.
  intros n m le; pattern m, n; apply le_elim_rel; auto with real.
  intros; rewrite <- minus_n_O; auto with real.
  intros; repeat rewrite S_INR; simpl.
  rewrite H0; ring.
Qed.
Hint Resolve minus_INR: real.

(*********)
Lemma mult_INR : forall n m:nat, INR (n * m) == INR n * INR m.
Proof.
  intros n m; induction  n as [| n Hrecn].
  simpl; auto with real.
  intros; repeat rewrite S_INR; simpl.
  rewrite plus_INR; rewrite Hrecn; ring.
Qed.
Hint Resolve mult_INR: real.

Lemma pow_INR (m n: nat) :  INR (m ^ n) == pow (INR m) n.
Proof. now induction n as [|n IHn];[ | simpl; rewrite mult_INR, IHn]. Qed.

(*********)
Lemma lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n.
Proof.
  simple induction 1; intros; auto with real.
  rewrite S_INR; auto with real.
Qed.
Hint Resolve lt_0_INR: real.

Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m.
Proof.
  simple induction 1; intros; auto with real.
  rewrite S_INR; auto with real.
  rewrite S_INR; apply Rlt_trans with (INR m0); auto with real.
Qed.
Hint Resolve lt_INR: real.

Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n.
Proof.
  apply lt_INR.
Qed.
Hint Resolve lt_1_INR: real.

(**********)
Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (Pos.to_nat p).
Proof.
  intro; apply lt_0_INR.
  simpl; auto with real.
Qed.
Hint Resolve pos_INR_nat_of_P: real.

(**********)
Lemma pos_INR : forall n:nat, 0 <= INR n.
Proof.
  intro n; case n.
  simpl; auto with real.
  auto with arith real.
Qed.
Hint Resolve pos_INR: real.

Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat.
Proof.
  intros n m. revert n.
  induction m ; intros n H.
  - elim (Rlt_irrefl 0).
    apply Rle_lt_trans with (2 := H).
    apply pos_INR.
  - destruct n as [|n].
    apply Nat.lt_0_succ.
    apply lt_n_S, IHm.
    rewrite 2!S_INR in H.
    apply Rplus_lt_reg_r with (1 := H).
Qed.
Hint Resolve INR_lt: real.

(*********)
Lemma le_INR : forall n m:nat, (n <= m)%nat -> INR n <= INR m.
Proof.
  simple induction 1; intros; auto with real.
  rewrite S_INR.
  apply Rle_trans with (INR m0); auto with real.
Qed.
Hint Resolve le_INR: real.

(**********)
Lemma INR_not_0 : forall n:nat, ~ INR n == 0 -> n <> 0%nat.
Proof.
  red; intros n H H1.
  apply H.
  rewrite H1; trivial. reflexivity.
Qed.
Hint Immediate INR_not_0: real.

(**********)
Lemma not_0_INR : forall n:nat, n <> 0%nat -> ~ INR n == 0.
Proof.
  intro n; case n.
  intro; absurd (0%nat = 0%nat); trivial.
  intros; rewrite S_INR.
  apply Rgt_not_eq; red; auto with real.
Qed.
Hint Resolve not_0_INR: real.

Lemma not_INR : forall n m:nat, n <> m -> ~ INR n == INR m.
Proof.
  intros n m H; case (le_or_lt n m); intros H1.
  case (le_lt_or_eq _ _ H1); intros H2.
  apply Rlt_dichotomy_converse; auto with real.
  exfalso; auto.
  apply not_Req_sym ; apply Rlt_dichotomy_converse; auto with real.
Qed.
Hint Resolve not_INR: real.

Lemma INR_eq : forall n m:nat, INR n == INR m -> n = m.
Proof.
  intros n m HR.
  destruct (dec_eq_nat n m) as [H|H].
  exact H.
  now apply not_INR in H.
Qed.
Hint Resolve INR_eq: real.

Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat.
Proof.
  intros; elim H; intro.
  generalize (INR_lt n m H0); intro; auto with arith.
  generalize (INR_eq n m H0); intro; rewrite H1; auto.
Qed.
Hint Resolve INR_le: real.

Lemma not_1_INR : forall n:nat, n <> 1%nat -> ~ INR n == 1.
Proof.
  intros n.
  apply not_INR.
Qed.
Hint Resolve not_1_INR: real.

(*********************************************************)
(** ** Injection from [Z] to [R]                         *)
(*********************************************************)

(**********)
Lemma IZN : forall n:Z, (0 <= n)%Z ->  exists m : nat, n = Z.of_nat m.
Proof.
  intros z; idtac; apply Z_of_nat_complete; assumption.
Qed.

Hint Resolve IZN: real.

Lemma INR_IPR : forall p, INR (Pos.to_nat p) == IPR p.
Proof.
  assert (H: forall p, 2 * INR (Pos.to_nat p) == IPR_2 p).
    induction p as [p|p|] ; simpl IPR_2.
    rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp.
    now rewrite (Rplus_comm (2 * _)).
    now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp.
    apply Rmult_1_r.
  intros [p|p|] ; unfold IPR.
  rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H.
  apply Rplus_comm.
  now rewrite Pos2Nat.inj_xO, mult_INR, <- H.
  easy.
Qed.
Hint Resolve INR_IPR: real.
(**********)
Lemma INR_IZR_INZ : forall n:nat, INR n == IZR (Z.of_nat n).
Proof.
  intros [|n].
  easy.
  simpl Z.of_nat. unfold IZR.
  now rewrite <- INR_IPR, SuccNat2Pos.id_succ.
Qed.
Hint Resolve INR_IZR_INZ: real.

Lemma plus_IZR_NEG_POS :
  forall p q:positive, IZR (Zpos p + Zneg q) == IZR (Zpos p) + IZR (Zneg q).
Proof.
  intros p q; simpl. rewrite Z.pos_sub_spec.
  case Pos.compare_spec; intros H; unfold IZR.
  subst. ring.
  rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial.
  rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt).
  ring.
  rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial.
  rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt).
  ring.
Qed.

Hint Resolve plus_IZR_NEG_POS: real.
(**********)
Lemma plus_IZR : forall n m:Z, IZR (n + m) == IZR n + IZR m.
Proof.
  intro z; destruct z; intro t; destruct t; intros; auto with real.
  simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR.
  rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
  simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR.
  apply Ropp_plus_distr.
Qed.

(**********)
Lemma mult_IZR : forall n m:Z, IZR (n * m) == IZR n * IZR m.
Proof.
  intros z t; case z; case t; simpl; auto with real;
    unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring.
Qed.

Lemma pow_IZR : forall z n, pow (IZR z) n == IZR (Z.pow z (Z.of_nat n)).
Proof.
 intros z [|n];simpl; auto with real.
 rewrite Zpower_pos_nat.
 rewrite SuccNat2Pos.id_succ. unfold Zpower_nat;simpl.
 rewrite mult_IZR.
 induction n;simpl; auto with real.
 rewrite mult_IZR;ring[IHn].
Qed.
Hint Resolve plus_IZR mult_IZR pow_IZR: real.
(**********)
Lemma succ_IZR : forall n:Z, IZR (Z.succ n) == IZR n + 1.
Proof.
  intro; unfold Z.succ; apply plus_IZR.
Qed.

(**********)
Lemma opp_IZR : forall n:Z, IZR (- n) == - IZR n.
Proof.
  intros [|z|z]; unfold IZR; simpl; auto with real.
Qed.

Definition Ropp_Ropp_IZR := opp_IZR.

Lemma minus_IZR : forall n m:Z, IZR (n - m) == IZR n - IZR m.
Proof.
  intros; unfold Z.sub, Rminus.
  rewrite <- opp_IZR.
  apply plus_IZR.
Qed.

Hint Resolve succ_IZR opp_IZR minus_IZR: real.
(**********)
Lemma Z_R_minus : forall n m:Z, IZR n - IZR m == IZR (n - m).
Proof.
  intros z1 z2; unfold Rminus; unfold Z.sub.
  rewrite <- (Ropp_Ropp_IZR z2); symmetry ; apply plus_IZR.
Qed.

Hint Resolve Z_R_minus : real.
(**********)
Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
Proof.
  intro z; case z; simpl; intros.
  elim (Rlt_irrefl _ H).
  easy.
  elim (Rlt_not_le _ _ H).
  unfold IZR.
  rewrite <- INR_IPR.
  auto with real.
Qed.

(**********)
Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z.
Proof.
  intros z1 z2 H; apply Z.lt_0_sub.
  apply lt_0_IZR.
  rewrite <- Z_R_minus.
  exact (Rgt_minus (IZR z2) (IZR z1) H).
Qed.

Hint Resolve lt_0_IZR lt_IZR: real.
(**********)
Lemma eq_IZR_R0 : forall n:Z, IZR n == 0 -> n = 0%Z.
Proof.
  intro z; destruct z; simpl; intros; auto with zarith.
  elim Rgt_not_eq with (2 := H).
  unfold IZR. rewrite <- INR_IPR.
  apply lt_0_INR, Pos2Nat.is_pos.
  elim Rlt_not_eq with (2 := H).
  unfold IZR. rewrite <- INR_IPR.
  apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos.
Qed.

(**********)
Lemma eq_IZR : forall n m:Z, IZR n == IZR m -> n = m.
Proof.
  intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H);
    rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0);
      intro; omega.
Qed.
Hint Resolve eq_IZR_R0 eq_IZR: real.
(**********)
Lemma not_0_IZR : forall n:Z, n <> 0%Z -> ~ IZR n == 0.
Proof.
  intros z H; red; intros H0; case H.
  apply eq_IZR; auto.
Qed.

Hint Resolve not_0_IZR : real.
(*********)
Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z.
Proof.
  unfold Rle; intros z [H| H].
  red; intro; apply (Z.lt_le_incl 0 z (lt_0_IZR z H)); assumption.
  rewrite (eq_IZR_R0 z); auto with zarith real.
Qed.

(**********)
Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z.
Proof.
  unfold Rle; intros z1 z2 [H| H].
  apply (Z.lt_le_incl z1 z2); auto with real.
  rewrite (eq_IZR z1 z2); auto with zarith real.
Qed.

Hint Resolve le_0_IZR le_IZR: real.
(**********)
Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z.
Proof.
  intros n.
  assert (IZR 1 = 1). { auto. }
  rewrite <- H.
  apply le_IZR.
Qed.
Hint Resolve le_IZR_R1 : real.
(**********)
Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m.
Proof.
  intros m n H; apply Rnot_lt_ge; red; intro.
  generalize (lt_IZR m n H0); intro; omega.
Qed.

Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m.
Proof.
  intros m n H; apply Rnot_gt_le; red; intro.
  unfold Rgt in H0; generalize (lt_IZR n m H0); intro; omega.
Qed.

Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m.
Proof.
  intros m n H; cut (m <= n)%Z.
  intro H0; elim (IZR_le m n H0); intro; auto.
  generalize (eq_IZR m n H1); intro; exfalso; omega.
  omega.
Qed.

Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> ~ IZR z1 == IZR z2.
Proof.
intros; red; intro; elim H; apply eq_IZR; assumption.
Qed.
Hint Resolve IZR_ge IZR_le IZR_lt IZR_neq: real.
Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : real.
Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : real.
Hint Extern 0 (IZR _ <  IZR _) => apply IZR_lt, eq_refl : real.
Hint Extern 0 (IZR _ >  IZR _) => apply IZR_lt, eq_refl : real.
Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : real.

Lemma one_IZR_lt1 : forall n:Z, - (1) < IZR n < 1 -> n = 0%Z.
Proof.
  intros z [H1 H2].
  apply Z.le_antisymm.
  apply Z.lt_succ_r; apply lt_IZR; trivial.
  change 0%Z with (Z.succ (-1)).
  apply Z.le_succ_l; apply lt_IZR; trivial.
Qed.

Lemma one_IZR_r_R1 :
  forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m.
Proof.
  intros r z x [H1 H2] [H3 H4].
  cut ((z - x)%Z = 0%Z); auto with zarith.
  apply one_IZR_lt1.
  rewrite <- Z_R_minus; split.
  assert (- (1) == r - (r + 1)). { ring. }
  rewrite H.
  unfold Rminus; apply Rplus_lt_le_compat; auto with real.
  assert (1 == r + 1 - r). { ring. }
  rewrite H.
  unfold Rminus; apply Rplus_le_lt_compat; auto with real.
Qed.

(**********)
Lemma single_z_r_R1 :
  forall r (n m:Z),
    r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m.
Proof.
  intros; apply one_IZR_r_R1 with r; auto.
Qed.

(**********)
Lemma tech_single_z_r_R1 :
  forall r (n:Z),
    r < IZR n ->
    IZR n <= r + 1 ->
    (exists s : Z, s <> n /\ r < IZR s /\ IZR s <= r + 1) -> False.
Proof.
  intros r z H1 H2 [s [H3 [H4 H5]]].
  apply H3; apply single_z_r_R1 with r; trivial.
Qed.

(*********)
Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2.
Proof.
  intros x y H H0; rewrite <- (Rmult_0_l x); rewrite <- (Rmult_comm x);
    apply (Rmult_le_compat_l x 0 y H H0).
Qed.

Lemma Rinv_le_contravar :
  forall x y, 0 < x -> x <= y -> / y <= / x.
Proof.
  intros x y H1 [H2|H2].
  apply Rlt_le.
  apply Rinv_lt_contravar with (2 := H2).
  apply Rmult_lt_0_compat with (1 := H1).
  now apply Rlt_trans with x.
  rewrite H2.
  apply Rle_refl.
Qed.

Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
Proof.
  intros x y H _.
  apply Rinv_le_contravar with (1 := H).
Qed.

Lemma Ropp_div : forall x y, -x/y == - (x / y).
Proof.
  intros x y; unfold Rdiv; ring.
Qed.

Lemma double : forall r1, 2 * r1 == r1 + r1.
Proof.
  intro; ring.
Qed.

Lemma double_var : forall r1, r1 == r1 / 2 + r1 / 2.
Proof.
  intro; rewrite <- double; unfold Rdiv; rewrite <- Rmult_assoc;
    symmetry ; apply Rinv_r_simpl_m.
  assert (IZR 2 == 2). { auto with real. }
  rewrite <- H.
  now apply not_0_IZR.
Qed.

Lemma R_rm : ring_morph
  0%R 1%R Rplus Rmult Rminus Ropp Req
  0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool IZR.
Proof.
constructor ; try easy.
exact plus_IZR.
exact minus_IZR.
exact mult_IZR.
exact opp_IZR.
intros x y H.
apply Zeq_bool_eq in H.
subst. reflexivity.
Qed.

Lemma Zeq_bool_IZR x y :
  IZR x == IZR y -> Zeq_bool x y = true.
Proof.
intros H.
apply Zeq_is_eq_bool.
now apply eq_IZR.
Qed.

Add Field ABS' : Rfield
  (completeness Zeq_bool_IZR, morphism R_rm, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]).

(*********************************************************)
(** ** Other rules about < and <=                        *)
(*********************************************************)

Lemma Rmult_ge_0_gt_0_lt_compat :
  forall r1 r2 r3 r4,
    r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4.
Proof.
  intros; apply Rle_lt_trans with (r2 * r3); auto with real.
Qed.

Lemma le_epsilon :
  forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2.
Proof.
  intros x y H.
  destruct (Rle_or_lt x y) as [H1|H1].
  exact H1.
  apply Rplus_le_reg_r with x.
  assert (y + x == (2 * (y + (x - y) * / 2))). { field. }
  assert (x + x == 2 * x). { ring. }
  rewrite H0 , H2.
  apply Rmult_le_compat_l.
  now apply (IZR_le 0 2).
  apply H.
  apply Rmult_lt_0_compat.
  now apply Rgt_minus.
  apply Rinv_0_lt_compat, Rlt_0_2.
Qed.

Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a/b.
Proof.
intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption.
Qed.

Lemma Rdiv_plus_distr : forall a b c, (a + b)/c == a/c + b/c.
intros a b c; apply Rmult_plus_distr_r.
Qed.

Lemma Rdiv_minus_distr : forall a b c, (a - b)/c == a/c - b/c.
intros a b c; unfold Rminus, Rdiv; rewrite Rmult_plus_distr_r; ring.
Qed.

(* A test for equality function. *)
Lemma Req_EM_T : forall r1 r2:R, r1 == r2 \/ ~ r1 == r2.
Proof.
  intros; destruct (total_order_T r1 r2) as [| [|]].
  - right ; intro. apply (Rlt_irrefl r2). rewrite <- H0 at 1. auto.
  - left; assumption.
  - right ; intro. apply (Rlt_irrefl r2). rewrite <- H0 at 2. auto.
Qed.

(*********************************************************)
(** * Definitions of new types                           *)
(*********************************************************)

Record nonnegreal : Type := mknonnegreal
  {nonneg :> R; cond_nonneg : 0 <= nonneg}.

Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}.

Record nonposreal : Type := mknonposreal
  {nonpos :> R; cond_nonpos : nonpos <= 0}.

Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}.

Record nonzeroreal : Type := mknonzeroreal
  {nonzero :> R; cond_nonzero : nonzero <> 0}.

(** Compatibility *)

Notation prod_neq_R0 := Rmult_integral_contrapositive_currified (only parsing).
Notation minus_Rgt := Rminus_gt (only parsing).
Notation minus_Rge := Rminus_ge (only parsing).
Notation plus_le_is_le := Rplus_le_reg_pos_r (only parsing).
Notation plus_lt_is_lt := Rplus_lt_reg_pos_r (only parsing).
Notation INR_lt_1 := lt_1_INR (only parsing).
Notation lt_INR_0 := lt_0_INR (only parsing).
Notation not_nm_INR := not_INR (only parsing).
Notation INR_pos := pos_INR_nat_of_P (only parsing).
Notation not_INR_O := INR_not_0 (only parsing).
Notation not_O_INR := not_0_INR (only parsing).
Notation not_O_IZR := not_0_IZR (only parsing).
Notation le_O_IZR := le_0_IZR (only parsing).
Notation lt_O_IZR := lt_0_IZR (only parsing).

Lemma INR_R0 : INR 0 == 0.
Proof. auto with real. Qed.

Lemma INR_R1 : INR 1 == 1.
Proof. auto with real. Qed.

Hint Resolve INR_R0 INR_R1: real.

Lemma IZR_R0 : IZR 0 == 0.
Proof. auto with real. Qed.

Lemma IZR_R1 : IZR 1 == 1.
Proof. auto with real. Qed.

Hint Resolve IZR_R0 IZR_R1: real.

Lemma IQR_R0 : IQR (0%Q) == 0.
Proof. unfold IQR. field. auto with real. Qed.

Lemma IQR_R1 : IQR (1%Q) == 1.
Proof. unfold IQR. unfold IZR. field. auto with real. Qed.

Hint Resolve IQR_R0 IQR_R1: real.

Lemma plus_IQR : forall n m:Q, IQR (n + m) == IQR n + IQR m.
Proof.
  intros.
  destruct n , m.
  unfold IQR. simpl. unfold Rdiv.
  rewrite !plus_IZR. rewrite !mult_IZR. rewrite Rmult_plus_distr_r.
  rewrite <- INR_IPR. rewrite Pos2Nat.inj_mul.
  rewrite !mult_INR. rewrite !INR_IPR.
  assert (forall Qden0 : positive , IZR (Z.pos Qden0) = IPR Qden0). { auto. }
  rewrite !H. field. clear H.
  rewrite <- !INR_IPR.
  split ; auto with real.
Qed.

(**********)
Lemma mult_IQR : forall n m:Q, IQR (n * m) == IQR n * IQR m.
Proof.
  intros.
  destruct n , m.
  unfold IQR. simpl. unfold Rdiv.
  rewrite !mult_IZR.
  rewrite <- INR_IPR. rewrite Pos2Nat.inj_mul.
  rewrite !mult_INR. rewrite !INR_IPR. field.
  rewrite <- !INR_IPR.
  split ; auto with real.
Qed.

Hint Resolve plus_IQR mult_IQR : real.
(**********)
Lemma succ_IQR : forall n:Q, IQR (n + 1) == IQR n + 1.
Proof.
  intro; rewrite plus_IQR ; auto with real.
Qed.

(**********)
Lemma opp_IQR : forall n:Q, IQR (- n) == - IQR n.
Proof.
  intros []; unfold IQR; simpl.
  rewrite opp_IZR. field.
  rewrite <- !INR_IPR.
  auto with real.
Qed.

Definition Ropp_Ropp_IQR := opp_IQR.

Lemma minus_IQR : forall n m:Q, IQR (n - m) == IQR n - IQR m.
Proof.
  intros; unfold Qminus, Rminus.
  rewrite <- opp_IQR.
  apply plus_IQR.
Qed.

Hint Resolve opp_IQR succ_IQR minus_IQR : real.
(**********)
Lemma Q_R_minus : forall n m:Q, IQR n - IQR m == IQR (n - m).
Proof.
  intros ; unfold Rminus , Qminus.
  rewrite <- (Ropp_Ropp_IQR m); symmetry ; apply plus_IQR.
Qed.

Hint Resolve Q_R_minus : real.
(**********)
Lemma lt_0_IQR : forall n:Q, 0 < IQR n -> (0 < n)%Q.
Proof.
  intro z; case z; simpl; intros.
  unfold Qlt. simpl. rewrite Zmult_1_r.
  apply lt_0_IZR.
  assert (0 == 0 / IPR Qden). { field. rewrite <- INR_IPR. auto with real. }
  rewrite H0 in H. unfold Rdiv in *.
  apply Rmult_lt_reg_r with ( / IPR Qden)  ; auto.
  rewrite <- INR_IPR. auto with real.
Qed.

(**********)
Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q.
Proof.
  intros z1 z2 H.
  assert (z2 - z1 > 0)%Q.
  { apply lt_0_IQR. rewrite minus_IQR. apply Rlt_Rminus. auto. }
  lra.
Qed.

Hint Resolve lt_0_IQR lt_IQR: real.
(**********)
Lemma eq_IQR_R0 : forall n:Q, IQR n == 0 -> (n == 0)%Q.
Proof.
  intros. destruct n. simpl in *.
  unfold Qeq. simpl. rewrite Zmult_1_r.
  apply eq_IZR_R0. unfold Rdiv in H. apply Rmult_integral in H.
  destruct H ; auto.
  exfalso.
  apply (Rlt_irrefl 0). rewrite <- H at 2. rewrite <- INR_IPR. auto with real.
Qed.

Lemma IQR_eq_R0 : forall n:Q, (n == 0)%Q -> IQR n == 0.
Proof.
  intros. induction n.
  hnf in *. simpl in *.
  rewrite Z.mul_1_r in H.
  rewrite H. unfold Rdiv. rewrite IZR_R0. rewrite Rmult_0_l. reflexivity.
Qed.

(**********)
Lemma IQR_eq : forall n m : Q , (n == m)%Q -> IQR n == IQR m.
Proof.
  intros. subst.
  assert (n - m == 0)%Q. { lra. }
  apply IQR_eq_R0 in H0.
  rewrite minus_IQR in H0.
  apply Rminus_diag_uniq. auto.
Qed.

Lemma eq_IQR : forall n m:Q, IQR n == IQR m -> (n == m)%Q.
Proof.
  intros.
  assert (n - m == 0)%Q.
  { apply eq_IQR_R0. rewrite minus_IQR. auto with real. }
  lra.
Qed.

Instance IQR_comp : Proper (Qeq ==> Req) IQR.
Proof.
  hnf. intros.
  apply IQR_eq. auto.
Qed.

Hint Resolve eq_IQR_R0 eq_IQR: real.
Hint Resolve IQR_eq_R0 IQR_eq: real.
(**********)
Lemma not_0_IQR : forall n:Q, ~ (n == 0)%Q -> ~ IQR n == 0.
Proof.
  intros z H; red; intros H0; case H.
  apply eq_IQR. rewrite H0. auto with real.
Qed.

Hint Resolve not_0_IQR : real.
(*********)
Lemma le_0_IQR : forall n:Q, 0 <= IQR n -> (0 <= n)%Q.
Proof.
  unfold Rle; intros z [H| H].
  - apply lt_0_IQR in H. lra.
  - symmetry in H. apply eq_IQR_R0 in H. lra.
Qed.

(**********)
Lemma le_IQR : forall n m:Q, IQR n <= IQR m -> (n <= m)%Q.
Proof.
  unfold Rle; intros z1 z2 [H| H].
  - apply lt_IQR in H. lra.
  - apply eq_IQR in H. lra.
Qed.

Hint Resolve le_0_IQR le_IQR: real.
(**********)
Lemma le_IQR_R1 : forall n:Q, IQR n <= 1 -> (n <= 1)%Q.
Proof.
  intros n.
  assert (IQR 1 == 1). { auto with real. }
  rewrite <- H.
  apply le_IQR.
Qed.
Hint Resolve le_IQR_R1 : real.
(**********)
Lemma IQR_ge : forall n m:Q, (n >= m)%Q -> IQR n >= IQR m.
Proof.
  intros m n H; apply Rnot_lt_ge; red; intro.
  generalize (lt_IQR m n H0); intro ; lra.
Qed.

Lemma IQR_le : forall n m:Q, (n <= m)%Q -> IQR n <= IQR m.
Proof.
  intros m n H; apply Rnot_gt_le; red; intro.
  unfold Rgt in H0; generalize (lt_IQR n m H0); intro; lra.
Qed.

Lemma IQR_lt : forall n m:Q, (n < m)%Q -> IQR n < IQR m.
Proof.
  intros m n H; cut (m <= n)%Q.
  intro H0; elim (IQR_le m n H0); intro; auto.
  generalize (eq_IQR m n H1); intro; exfalso; lra.
  lra.
Qed.

Lemma IQR_neq : forall z1 z2:Q, ~ (z1 == z2)%Q -> ~ IQR z1 == IQR z2.
Proof.
intros; red; intro; elim H; apply eq_IQR; assumption.
Qed.
Hint Resolve IQR_ge IQR_le IQR_lt IQR_neq: real.
Hint Extern 0 (IQR _ <= IQR _) => apply IQR_le, Qle_bool_imp_le, eq_refl : real.
Hint Extern 0 (IQR _ >= IQR _) => apply Rle_ge, IQR_le, Qle_bool_imp_le, eq_refl : real.
Hint Extern 0 (IQR _ <  IQR _) => apply IQR_lt, eq_refl : real.
Hint Extern 0 (IQR _ >  IQR _) => apply IQR_lt, eq_refl : real.
Hint Extern 0 (~ IQR _ == IQR _) => apply IQR_neq, Qeq_bool_neq, eq_refl : real.

Lemma INQ_IQR_INR : forall n : nat , IQR (INQ n) == INR n.
Proof.
  intros. induction n.
  - rewrite INR_R0. rewrite <- IQR_R0.
    simpl. reflexivity.
  - rewrite <- Nat.add_1_r.
    rewrite plus_INR. rewrite <- IHn. rewrite INR_R1.
    rewrite <- IQR_R1. rewrite <- plus_IQR.
    simpl. rewrite Z.mul_1_r.
    rewrite Nat2Z.inj_add. reflexivity.
Qed.

  Theorem IQR_inv : forall r : Q, (~ r == 0)%Q -> / IQR r == IQR (/ r).
  Proof.
    intros.
    destruct r.
    simpl. unfold Rdiv , Qinv. simpl.
    assert (forall p , ~ IPR p == 0). { intros. rewrite <- INR_IPR. auto with real. }
    destruct Qnum ; simpl.
    - assert (0 # Qden == 0)%Q. { unfold Qeq. auto. }
      exfalso. auto.
    - unfold IZR. field. split ; auto.
    - unfold IZR. field. split ; auto.
  Qed.
  Hint Resolve IQR_inv : real.

  Theorem Rlt_opp : forall r : R , r > R0 -> - r < R0.
  Proof. auto with real. Qed.
  Theorem Rle_opp : forall r : R , r >= R0 -> - r <= R0.
  Proof. auto with real. Qed.
  Hint Resolve Rlt_opp Rle_opp : real.

  Theorem Rlt_pos_eqb : forall r1 r2 : R  , r1 < r2 <-> r2 - r1 > R0.
  Proof.
    split ; intros.
    - apply Rlt_Rminus. auto.
    - apply Rminus_gt. auto.
  Qed.

  Theorem Rlt_neg_eqb : forall r1 r2 : R  , r1 > r2 <-> r2 - r1 < R0.
  Proof.
    split ; intros ; auto with real.
    hnf. apply Rminus_lt. auto.
  Qed.

  Hint Resolve Rlt_pos_eqb Rlt_neg_eqb : real.

  Theorem Rle_pos_eqb : forall r1 r2 : R  , r1 <= r2 <-> r2 - r1 >= R0.
  Proof.
    split ; intros ; destruct H.
    - left. rewrite <- Rlt_pos_eqb. auto.
    - right. rewrite H. ring.
    - left. apply Rlt_pos_eqb. auto.
    - right. subst. auto with real.
  Qed.

  Theorem Rle_neg_eqb : forall r1 r2 : R  , r1 >= r2 <-> r2 - r1 <= R0.
  Proof.
    split ; intros ; destruct H.
    - left. rewrite <- Rlt_neg_eqb. auto.
    - right. rewrite H. ring.
    - left. apply Rlt_neg_eqb. auto.
    - right. subst. auto with real.
  Qed.

  Hint Resolve Rle_pos_eqb Rle_neg_eqb : real.

  Theorem Rmult_le_l : forall r1 r2 r3 : R , r3 > R0 -> r3 * r1  <= r3 * r2 <-> r1 <= r2.
  Proof.  split ; intros ; auto with real. apply Rmult_le_reg_l with r3 ; auto. Qed.

  Theorem Rmult_lt_l : forall r1 r2 r3 : R , r3 > R0 -> r3 * r1 < r3 * r2 <-> r1 < r2.
  Proof.  split ; intros ; auto with real. apply Rmult_gt_reg_l with r3 ; auto. Qed.

  Theorem Rmult_le_r : forall r1 r2 r3 : R , r3 > R0 -> r1 * r3 <= r2 * r3 <-> r1 <= r2.
  Proof.  split ; intros ; auto with real. apply Rmult_le_reg_r with r3 ; auto. Qed.

  Theorem Rmult_lt_r : forall r1 r2 r3 : R , r3 > R0 -> r1 * r3 < r2 * r3 <-> r1 < r2.
  Proof. split ; intros ; auto with real. apply Rmult_lt_reg_r with r3 ; auto. Qed.

  Hint Resolve Rmult_le_l Rmult_le_r  Rmult_lt_l Rmult_le_l : real.

  Theorem Rmult_lt_divr : forall r1 r2 r3 : R , r3 > R0 -> r1 < r2 * r3 <-> r1  / r3  < r2.
  Proof.
    split ; intros ; auto with real.
    - apply Rmult_lt_r with r3 ; auto.
      unfold Rdiv. rewrite Rmult_assoc. rewrite Rinv_l. rewrite Rmult_1_r. auto.
      auto with real.
    - apply Rmult_lt_r with (/ r3 ) ; auto.
      apply Rinv_0_lt_compat ; auto.
      rewrite Rmult_assoc. rewrite Rinv_r. rewrite Rmult_1_r. auto.
      auto with real.
  Qed.

  Theorem Rmult_le_divr : forall r1 r2 r3 : R , r3 > R0 -> r1 <= r2 * r3 <-> r1 / r3 <= r2.
  Proof.
    split ; intros ; auto with real.
    - apply Rmult_le_r with r3 ; auto.
      unfold Rdiv. rewrite Rmult_assoc. rewrite Rinv_l. rewrite Rmult_1_r. auto.
      auto with real.
    - apply Rmult_le_r with (/ r3) ; auto.
      apply Rinv_0_lt_compat ; auto.
      rewrite Rmult_assoc. rewrite Rinv_r. rewrite Rmult_1_r. auto.
      auto with real.
  Qed.

  Hint Resolve Rmult_lt_divr Rmult_le_divr : real.

  Theorem Rmult_gt_divr : forall r1 r2 r3 : R , r3 > R0 -> r1 > r2 * r3 <-> r1 / r3  > r2.
  Proof.
    split ; intros ; auto with real.
    - apply Rmult_lt_r with r3 ; auto.
      unfold Rdiv. rewrite Rmult_assoc. rewrite Rinv_l. rewrite Rmult_1_r. auto.
      auto with real.
    - apply Rmult_lt_r with (/ r3) ; auto.
      apply Rinv_0_lt_compat ; auto.
      rewrite Rmult_assoc. rewrite Rinv_r. rewrite Rmult_1_r. auto.
      auto with real.
  Qed.

  Theorem Rmult_ge_divr : forall r1 r2 r3 : R , r3 > R0 -> r1 >= r2 * r3 <-> r1 / r3 >= r2.
  Proof.
    split ; intros ; apply Rle_ge ; auto with real.
    - apply Rmult_le_r with r3 ; auto.
      unfold Rdiv. rewrite Rmult_assoc. rewrite Rinv_l ; auto with real. rewrite Rmult_1_r.
      auto with real.
    - apply Rmult_le_r with (/ r3) ; auto.
      apply Rinv_0_lt_compat ; auto.
      rewrite Rmult_assoc. rewrite Rinv_r ; auto with real. rewrite Rmult_1_r.
      auto with real.
  Qed.

  Hint Resolve Rmult_gt_divr Rmult_ge_divr : real.

  Theorem Rlt_Rlt_minus : forall r1 r2 r3 r4 : R , r1 < r2 -> r3 < r4 -> r3 - r2 < r4 - r1.
  Proof. intros. apply Rplus_lt_reg_r with (r2 + r1).
    assert (r3 - r2 + (r2 + r1) == r3 + r1). { ring. }
    assert (r4 - r1 + (r2 + r1) == r4 + r2). { ring. }
    rewrite H1 , H2.
    auto with real.
  Qed.

  Theorem Rle_Rle_minus : forall r1 r2 r3 r4 : R , r1 <= r2 -> r3 <= r4 -> r3 - r2 <= r4 - r1.
  Proof. intros. apply Rplus_le_reg_r with (r2 + r1).
    assert (r3 - r2 + (r2 + r1) == r3 + r1). { ring. }
    assert (r4 - r1 + (r2 + r1) == r4 + r2). { ring. }
    rewrite H1 , H2.
    auto with real.
  Qed.

  Theorem Rlt_Rle_minus : forall r1 r2 r3 r4 : R , r1 < r2 -> r3 <= r4 -> r3 - r2 < r4 - r1.
  Proof. intros. apply Rplus_lt_reg_r with (r2 + r1).
    assert (r3 - r2 + (r2 + r1) == r3 + r1). { ring. }
    assert (r4 - r1 + (r2 + r1) == r4 + r2). { ring. }
    rewrite H1 , H2.
    auto with real.
  Qed.

  Theorem Rle_Rlt_minus : forall r1 r2 r3 r4 : R , r1 <= r2 -> r3 < r4 -> r3 - r2 < r4 - r1.
  Proof. intros. apply Rplus_lt_reg_r with (r2 + r1).
    assert (r3 - r2 + (r2 + r1) == r3 + r1). { ring. }
    assert (r4 - r1 + (r2 + r1) == r4 + r2). { ring. }
    rewrite H1 , H2.
    auto with real.
  Qed.
  Hint Resolve Rlt_Rlt_minus Rle_Rlt_minus Rlt_Rle_minus Rle_Rle_minus : real.

  Theorem Rlt_Rminus_r : forall r1 r2 r3: R , r1 - r2 < r3 -> r1 - r3 < r2.
  Proof. intros. apply Rplus_lt_reg_r with (r3 - r2).
    assert (r1 - r3 + (r3 - r2) == r1 - r2). { ring. }
    assert (r2 + (r3 - r2) == r3). { ring. }
    rewrite H0 , H1.
    auto with real.
  Qed.

  Theorem Rlt_Rminus_Rplus : forall r1 r2 r3: R , r1 < r2 + r3 <-> r1 - r2 < r3.
  Proof. split ; intros .
    - apply Rplus_lt_reg_r with r2.
      assert (r1 - r2 + r2 == r1). { ring. }  rewrite H0. rewrite Rplus_comm. auto.
    - apply Rplus_lt_reg_r with (-r2).
      assert (r2 + r3 + - r2 == r3). { ring. } rewrite H0. auto.
  Qed.

  Theorem Rle_Rminus_r : forall r1 r2 r3: R , r1 - r2 <= r3 -> r1 - r3 <= r2.
  Proof. intros. apply Rplus_le_reg_r with (r3 - r2).
    assert (r1 - r3 + (r3 - r2) == r1 - r2). { ring. }
    assert (r2 + (r3 - r2) == r3). { ring. }
    rewrite H0 , H1. auto.
  Qed.

  Theorem Rle_Rminus_Rplus : forall r1 r2 r3: R , r1 <= r2 + r3 <-> r1 - r2 <= r3.
  Proof. split ; intros .
    - apply Rplus_le_reg_r with r2.
      assert (r1 - r2 + r2 == r1). { ring. }  rewrite H0. rewrite Rplus_comm. auto.
    - apply Rplus_le_reg_r with (-r2).
      assert (r2 + r3 + - r2 == r3). { ring. } rewrite H0. auto.
  Qed.

  Hint Resolve Rlt_Rminus_r  Rlt_Rminus_Rplus  Rle_Rminus_r Rle_Rminus_Rplus : real.

  Theorem Rle_Rminus :forall r1 r2 r3 : R , r1 + r3 <= r2 <-> r1 <= r2 - r3.
  Proof. split ; intros.
    - apply Rplus_le_reg_r with r3.
      assert (r2 - r3 + r3 == r2). { ring. }  rewrite H0. auto.
    - apply Rplus_le_reg_r with (-r3).
      assert (r1 + r3 + - r3 == r1). { ring. } rewrite H0. auto.
  Qed.
  Hint Resolve Rle_Rminus : real.

  Theorem Rlt_opp_eqb :forall r1 r2 :R , r1 < -r2 <->  r2 < - r1.
  Proof. split ; intros ; rewrite <- Ropp_involutive at 1;  apply Ropp_lt_contravar; auto. Qed.

  Theorem Rle_opp_eqb :forall r1 r2 :R , r1 <= -r2 <-> r2 <= - r1.
  Proof. split ; intros ; rewrite <- Ropp_involutive at 1; apply Ropp_le_contravar ; auto. Qed.

  Hint Resolve Rlt_opp_eqb Rle_opp_eqb : real.

  Theorem Rgt_Rinv : forall r1 : R , r1 > R1 -> r1 > / r1.
  Proof. intros. assert (r1 > 0). { apply Rlt_trans with 1 ; auto with real. }
    apply Rmult_lt_r with r1 ; auto.
    rewrite Rinv_l ; auto with real.
    apply Rlt_trans with r1 ; auto.
    rewrite <- Rmult_1_r at 1. apply Rmult_lt_l ; auto.
  Qed.

  Theorem Rge_Rinv : forall r1 : R , r1 >= R1 -> r1 >= / r1.
  Proof. intros. assert (r1 > 0). { apply Rlt_le_trans with 1 ; auto with real. }
    apply Rle_ge.
    apply Rmult_le_r with r1 ; auto.
    rewrite Rinv_l ; auto with real.
    apply Rle_trans with r1 ; auto with real.
    rewrite <- Rmult_1_r at 1. apply Rmult_le_compat_l ; auto with real.
  Qed.

  Theorem Rlt_Rinv : forall r1 : R , r1 < R1 /\ r1 > R0 -> r1 < / r1.
  Proof.  intros. destruct H.
    apply Rmult_lt_r with r1 ; auto.
    rewrite Rinv_l ; auto with real.
    apply Rlt_trans with r1 ; auto with real.
    rewrite <- (Rmult_1_r r1 )at 3. apply Rmult_lt_l ; auto with real.
  Qed.

  Theorem Rle_Rinv_self : forall r1 : R , r1 <= R1 /\ r1 > R0 -> r1 <= / r1.
  Proof. intros. destruct H.
    apply Rmult_le_r with r1 ; auto.
    rewrite Rinv_l ; auto with real.
    apply Rle_trans with r1 ; auto with real.
    rewrite <- (Rmult_1_r r1) at 3. apply Rmult_le_l ; auto with real.
  Qed.

  Hint Resolve Rgt_Rinv Rge_Rinv Rlt_Rinv Rle_Rinv_self : real.
End VirRLemma1.


Inductive Either (a b : Type) : Type :=
| Left  : a -> Either a b
| Right : b -> Either a b
.

Print or.

Arguments Left  {a} {b} _.
Arguments Right {a} {b} _.

(*
Inductive or (A B : Prop) : Prop :=
| or_introl : A -> A \/ B
| or_intror : B -> A \/ B
*)

(* this conversion is possible *)
Definition toOr (A B:Prop) (p:Either A B) : or A B :=
    match p with
    | Left  x   => or_introl x
    | Right y   => or_intror y
    end.

(* but this one is not:
Incorrect elimination of "p" in the inductive type "or":
the return type has sort "Set" while it should be "Prop".
Elimination of an inductive object of sort Prop
is not allowed on a predicate in sort Set
because proofs can be eliminated only to build proofs.

Definition toEither (A B:Prop) (p:or A B) : Either A B :=
        match p with
        | or_introl x   => Left  x
        | or_intror y   => Right y
        end.
*)


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer LibMonoid.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import LibNatExtra LibIter InverseNatNat
     Ackermann InverseAckermann MiscArith TLCBuffer UnionFind01Data
     UnionFind03Link UnionFind04Compress UnionFind11Rank UnionFind21Parent
     UnionFind22ParentEvolution UnionFind41Potential.

Section BasicEvolution.

Variable r : nat.
Hypothesis r_geq_1: 1 <= r.

Notation prek := (prek r).
Notation k := (k r).
Notation i := (i r).
Notation rankr := (rankr r).

Variable V : Type.
Variable D : set V.
Variable F : binary V.
Variable K : V -> nat.
Hypothesis is_rdsf_F : is_rdsf D F K.

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

(* During a compression, the function [k] is unchanged at ancestors of [y]. *)

Lemma compress_preserves_k_above_y:
  forall x y z,
  F x y ->
  path F y z ->
  forall v,
  path F y v ->
  ~ is_root F v ->
  k (compress F x z) K v = k F K v.
Proof using is_rdsf_F.
  unfold k, prek. intros.
  assert (x <> v).
  { eapply paths_have_distinct_endpoints; eauto with is_dsf tclosure. }
  erewrite compress_does_not_change_parent_of_v; eauto with is_dsf.
Qed.

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

Section KxKy.

Notation is_root := (is_root F).
Notation path := (path F).
Notation p := (p F).
Notation prek := (prek F K).
Notation k := (k F K).
Notation i := (i F K).
Notation rankr := (rankr K).

(* Assume [x] and [y] are non-roots. (This is required for their level and index
   to be defined.) Assume that there is a non-trivial path from [x] to [y].
   Finally, assume that [x] and [y] have the same level, i.e., [k x = k y].
   Then, [iter (1 + i x) (A (prek x)) (rankr x)] is at most [rankr (p y)]. This
   is part of the proof of Lemma 4.10 in Alstrup et al.'s paper. *)

Lemma kx_ky:
  forall x y,
  ~ is_root x ->
  ~ is_root y ->
  path (p x) y ->
  k x = k y ->
  iter (1 + i x) (A (prek x)) (rankr x) <= rankr (p y).
Proof using is_rdsf_F r_geq_1.
  intros.
  assert (pp: prek x = prek y).
  { unfold k in *. lia. }
  (* Because there is a path from the parent of [x] to [y], the rank of [y]
     is at least the rank of the parent of [x]. *)
  assert (hxy: rankr (p x) <= rankr y).
  { eauto using rankr_increases_along_a_path. }
  (* By definition of [i], iterating [i x] times [A (prek x)], starting
     from [rankr x], takes us at most to [rankr (p x)]. *)
  assert (hx: iter (i x) (A (prek x)) (rankr x) <= rankr (p x)).
  { i f_betaf. }
  (* By definition of [prek], applying [A (prek x)] to [rankr y] takes us
     at least to [rankr (p y)]. *)
  assert (hy: A (prek x) (rankr y) <= rankr (p y)).
  { rewrite pp. k betaf_spec_direct. }
  (* Together, the above inequalities imply that iterating [1 + i x] times
     [A (prek x)], starting from [rankr x], takes us at most to [rankr (p y)].
     Which is our goal. *)
  simpl. rewrite hx. rewrite hxy. rewrite hy. eauto.
Qed.

End KxKy.

(* Under the same hypotheses as the previous lemma, if one performs path
   compression by installing an edge from [x] to its representative [z],
   then either [rankr x] changes (which means it increases, really, but we
   have not yet proved that), or [i x] increases. *)

Lemma kx_ky_compress:
  forall x y,
  ~ is_root F x ->
  ~ is_root F y ->
  path F (p F x) y ->
  k F K x = k F K y ->
  forall z,
  is_repr F x z ->
  k F K x = k (compress F x z) K x ->
  1 + i F K x <= i (compress F x z) K x.
Proof using is_rdsf_F r_geq_1.
  (* This proof is part of Lemma 4.10 in Alstrup et al.s paper, where
     it is really quite cryptic. Fortunately, it follows the same pattern
     as in Tarjan's proof. *)
  introv ? ? ? hkxy ? hkk.
  (* Because there is a path from [x] to the parent of [y], the
     representative of the parent of [y] must be [z]. This implies
     an inequality between the ranks of these vertices. *)
  assert (pyz: is_repr F (p F y) z).
  { eauto 11 using is_equiv_trans, is_equiv_parent, path_is_equiv with is_repr is_dsf. }
  destruct pyz.
  assert (rpyz: rankr K (p F y) <= rankr K z).
  { eauto using rankr_increases_along_a_path. }
  (* Now, recall the inequality which we proved previously. *)
  Opaque plus.
  forwards f: kx_ky x y; eauto.
  (* Combine the two inequalities. *)
  rewrite rpyz in f. clear rpyz.
  (* Note that [z] is the new parent of [x]. *)
  forwards w: compress_changes_parent_of_x_to_z x z; eauto.
  rewrite <- w in f by eauto. clear w.
  (* Massage. *)
  assert (prehkk: prek F K x = prek (compress F x z) K x).
  { unfold k in hkk. lia. }
  rewrite prehkk in f. clear prehkk.
  (* The assertion [f] guarantees that [i x] in the new state is
     at least [1 + i x] in the old state. *)
  i betaf_spec_reciprocal. (* tchac! *)
Qed.

End BasicEvolution.


(** * Bit vector semantics.

This module exposes a semantics that is based on interpreting the
words as bitvectors.

*)

Require Import Verse.TypeSystem.
Require Import Verse.Language.Types.
Require Import Verse.Language.Pretty.
Require Import Verse.BitVector.

Definition wordOfSize : nat -> Type := Types.BWord.
Definition const : forall sz : nat, constOf verse_type_system (word sz) -> wordOfSize sz
  := fun sz x => x.

Definition oper (sz arity : nat) (o : op arity)
  := match o in op arity0 return nary (wordOfSize sz) arity0 with
     | plus      => @BVplus    _
     | minus     => @BVminus   _
     | mul       => @BVmul     _
     | quot      => @BVquot    _
     | rem       => @BVrem     _
     | bitOr     => @BVor      _
     | bitAnd    => @BVand     _
     | bitXor    => @BVxor     _
     | bitComp   => @BVcomp    _
     | shiftL  n => @BVshiftL  _ n
     | shiftR  n => @BVshiftR  _ n
     | rotL    n => @BVrotL    _ n
     | rotR    n => @BVrotR    _ n
     end.

Definition bvDenote : typeDenote verse_type_system := fromWordDenote wordOfSize const oper.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable axiom_betweennesssymmetry_1 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_3_5b_2 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A C D)).

Theorem lemma_3_6b_3 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
induction l1.
- intros. simpl. rewrite <- IHl1. reflexivity.
- intros. reflexivity.
Qed.

Lemma lem: forall l1 l2, len (append l1 l2) = len (append l2 l1).
Proof. induction l1.
  - intros.  simpl.  rewrite IHl1. lfind.  reflexivity.
Admitted.

Theorem theorem0 : forall (x : lst) (y : lst), eq (half (len (append x y))) (half (len (append y x))).
Proof.
intros. f_equal. apply lem.
Qed.


(*TODO: Read STYLE.md and put this into HoTT library.*)
Require Import HoTT.
Load pType_basics.
(*The main result in this file is the fact that S^n->*A <~> loops n A.
I also use this to construct a map between homotopy groups from a map between spheres.
Lastly I (assuming the Hopf map) construct a map pi_(n+1) A ->* pi_n A. *)

(*Setting some notation for the pointed type of pointed maps. Level is chosen arbitrarily. . .*)
Notation "A '*->*' B" := (Build_pType (A ->* B) _) (at level 50).
Notation sph := pSphere.

(*Show that precomposing with a pointed equivalence induces an equivalence. *)
(*TODO: do also with postcompose. . .*)
Section Compose_pointed_equivalence.
  Definition pointed_precompose {A B C:pType} (f:A->*B) : (B->*C) -> (A->*C)
    := fun g => g o* f.

  Definition pt_precompose_inv {A B C:pType} (f : A->*B) {feq : IsEquiv f} :
    (A->*C) -> (B->*C)
    := pointed_precompose (pequiv_inv f).

  (*Precomposing with inverse is pointed homotopic to the idmap*)
  Lemma pcompose_inverse {A B:pType} (f : A->*B) {feq : IsEquiv f} :
    pequiv_inv f o* f ==* pmap_idmap A.
  Proof.
    apply issig_phomotopy.
    exists (fun x => eissect _ x).
    hott_simpl.
    unfold pequiv_inverse; simpl.
    unfold moveR_equiv_V.
    rewrite <- ap_pp_p.
    hott_simpl.
  Qed.

  (*The inverse of the inverse is pointed homotopic to the map itself.*)
  Lemma pequiv_inverse_twice {A B:pType} (f: A->*B) {feq : IsEquiv f} :
    f ==* pequiv_inverse (pequiv_inv f).
  Proof.
    apply issig_phomotopy.
    exists (ap10 idpath).
    hott_simpl; simpl.
    unfold moveR_equiv_V; simpl.
    rewrite <- (point_eq f).
    rewrite eisadj.
    rewrite <- ap_pp.
    hott_simpl.
  Qed.

  (*Precomposing with pointed equivalence results in an equivalence.*)
  (*Should this just follow from isequiv_precompose?*)
  Lemma isequiv_pt_precompose `{Funext} {A B C:pType} (f : A->*B) {feq : IsEquiv f} :
    IsEquiv (@pointed_precompose A B C f).
  Proof.
    refine (isequiv_adjointify (pointed_precompose f) (pt_precompose_inv f) _ _).
    -intro g.
     apply equiv_path_pmap.
     pHomotopy_via (g o* ( (pequiv_inv f) o* f)).
     +apply pmap_compose_assoc.
     +pHomotopy_via (g o* (pmap_idmap A)).
      *apply pmap_postwhisker.
       apply pcompose_inverse.
      *exact (pmap_precompose_idmap g).
    -intro g.
     apply equiv_path_pmap.
     pHomotopy_via (g o* (f o* (pequiv_inv f))).
     +apply pmap_compose_assoc.
     +pHomotopy_via (g o* (pmap_idmap B)).
      *apply pmap_postwhisker.
       pHomotopy_via
         ((pequiv_inverse (pequiv_inv f)) o* pequiv_inv f ).
       apply pmap_prewhisker.
       apply pequiv_inverse_twice.
       apply pcompose_inverse.
      *apply pmap_precompose_idmap.
  Qed.

  Definition pointed_postcompose {A B C : pType} (g:B->*C) : (A->*B) -> (A->*C)
    := fun f => g o* f.

  Lemma isequiv_pt_postcompose `{Funext} {A B C:pType} (g : B->*C) {geq : IsEquiv g} :
    IsEquiv (@pointed_postcompose A B C g).
  Admitted. (*TODO*)

End Compose_pointed_equivalence.

(*Prove that addpoint and the forgetful functor pType->Type are adjoint. This is lemma 6.5.3 in book.*)
(*Move section to pointed.v*)
Section Addpoint_forgetful_adjointness.
  Definition pMap_to_Map {A:Type } {B:pType} :
    ( (add_pt A) ->* B  ) -> ( A -> (pointed_type B) ) :=
    fun f => (f o inl).

  Definition Map_to_pMap {A:Type } {B:pType} : ( A->(pointed_type B) ) -> ( (add_pt A) ->* B  ).
    intro f.
    rapply Build_pMap.
    -intros [a | [] ].
     *exact (f a). (*What inl a maps to*)
     *exact (point B). (*What the basepoint maps to*)
    -exact idpath.
  Defined.

  Lemma isequiv_Map_to_pMap {A:Type } {B:pType} `{Funext} : IsEquiv (@Map_to_pMap A B).
  Proof.
    apply (@isequiv_adjointify (A->B) ( (add_pt A) ->* B  ) Map_to_pMap pMap_to_Map).
    -intros [pf pe].
     apply path_pmap.
     apply issig_phomotopy.
     unfold pMap_to_Map; unfold Map_to_pMap; simpl.
     refine (ex_intro _ _ _).
     +intros [a | [] ].
      *exact idpath.
      *exact pe^ .
     +simpl. hott_simpl.
    -exact (fun _ => idpath).
  Qed.

  (*Lemma 6_5_3 in book:*)
  Lemma adjoint_addpt_forget `{Funext} (A:Type) (B:pType) :
    ( A -> (pointed_type B) ) <~> ( (add_pt A) ->* B  ).
  Proof.
    exact (BuildEquiv _ _ Map_to_pMap isequiv_Map_to_pMap).
  Qed.
End Addpoint_forgetful_adjointness.

(*Show that my two-pointed types are equivalent*)
(*Move to HOT/Sphere*)
Section Two_points.
  Definition two_pts := add_pt Unit.

  Definition sph0_to_two_pts : (pSphere 0) ->* two_pts.
    rapply Build_pMap.
    (*Construct map*)
    -apply (Susp_rec (inr tt) (inl tt)).
     +intros [].
    -exact idpath.
  Defined.

  Definition two_pts_to_sph0 : two_pts -> (pSphere 0).
    intros [].
      - exact (Unit_rec (pSphere 0) South).
      - exact (Unit_rec (pSphere 0) North).
  Defined.

  Lemma isequiv_sph0_to_two_pts : IsEquiv sph0_to_two_pts.
    rapply (isequiv_adjointify sph0_to_two_pts two_pts_to_sph0).
    - intros [ [] | [] ] ; exact idpath.
    - exact (Susp_ind _ idpath idpath (Empty_ind _)).
  Defined.

  (*TODO: Is pEquiv*)
End Two_points.

Section Loops.
  (*Move to HIT/Sphere*)
  (*TODO: Give new name? Regexp: "Omega \\((.+)\\|.\\) \\((.+)\\|.\\)"*)
  (*Define Omega n A as pointed maps from the n-sphere*)

(*  Definition Omega (n:nat) (A:pType) : pType :=
    Build_pType (pMap (pSphere n) A) _. *)

  Definition A_to_So2A {A:pType} : A -> (sph 0 ->* A) :=
    (pointed_precompose sph0_to_two_pts) o Map_to_pMap o (Unit_rec A).

  (*A_to_Omega0 is pointed:*)
  Definition pointed_A_to_So2A `{Funext} {A:pType}  : A_to_So2A (point A) = point (sph 0 ->* A).
    apply path_pmap.
    refine (Build_pHomotopy _ _).
    - refine (Susp_ind _ idpath idpath _).
      + intros [].
    - exact idpath.
  Defined.

  Definition pA_to_So2A `{Funext} {A:pType}  :=
    Build_pMap A (sph 0 *->* A)  A_to_So2A pointed_A_to_So2A.

  Lemma isequiv_A_to_So2A `{Funext} {A:pType} : IsEquiv (@A_to_So2A A).
    Proof.
      refine isequiv_compose.
      refine isequiv_compose.
      - exact isequiv_Map_to_pMap.
      - exact (isequiv_pt_precompose sph0_to_two_pts (feq := isequiv_sph0_to_two_pts)).
  Defined.

  Definition pEquiv_A_So2A `{Funext} {A:pType} : A <~>* (sph 0 *->* A) :=
    Build_pEquiv _ _ pA_to_So2A isequiv_A_to_So2A.

  Fixpoint it_loop_susp_adj `{Funext} (n:nat) (A : pType) :
    (sph n ->* A) -> (sph 0 ->* (iterated_loops n A)) :=
    match n with
      | O => idmap
      | S n => (it_loop_susp_adj n (loops A)) o (loop_susp_adjoint _ _)
    end
  .
 (*
  Definition it_loop_susp_adj `{Funext} (n:nat) :
    forall A:pType, Omega n A -> Omega 0 (iterated_loops n A).
    induction n.
    -intro A. exact idmap.
    -intro A.
     exact ( (IHn (loops A)) o (loop_susp_adjoint _ _) ) .
  Defined.
*)
  Lemma pointed_loop_susp_adjoint `{Funext} (A B:pType)  :
    loop_susp_adjoint A B (point (psusp A ->* B)) = point (A ->* (loops B)).
    Proof.
      refine (concat _ (pmap_postcompose_const A _ (loops B) (loop_susp_unit A))).
      apply path_pmap.
      apply pmap_prewhisker.
      refine (Build_pHomotopy _ _).
      - intro loop.
        refine (concat (concat_1p _) _).
        refine (concat (concat_p1 _) _).
        apply ap_const.
      - hott_simpl.
    Qed.

  Lemma pointed_it_loop_susp_adj `{Funext} (n:nat) : forall A:pType,
    it_loop_susp_adj n A (point (sph n ->* A)) = point (sph 0 ->* (iterated_loops n A)).
    Proof.
      induction n.
      - reflexivity.
      - intro A.
        change (it_loop_susp_adj n.+1 A (point (sph n.+1 ->* A))) with
        ( (it_loop_susp_adj n (loops A)) ((loop_susp_adjoint _ _) (point (sph n.+1 ->* A))) ).
        rewrite (pointed_loop_susp_adjoint (pSphere n) A).
        exact (IHn (loops A)).
    Qed.

  Lemma isequiv_it_loop_susp_adj `{Funext} (n:nat) :
    forall A:pType, IsEquiv (it_loop_susp_adj n A).
  Proof.
    induction n.
    -intro A.
     apply isequiv_idmap.
    -intro A.
     refine isequiv_compose.
  Defined.

  Definition pEquiv_S2A_So2lA `{Funext} (n:nat) (A:pType) :
    (sph n *->* A) <~>* (sph 0 *->* iterated_loops n A).
    refine (Build_pEquiv _ _ _ _).
    - refine (Build_pMap _ _ _ _).
      + apply it_loop_susp_adj.
      + apply pointed_it_loop_susp_adj.
    - apply isequiv_it_loop_susp_adj.
  Defined.

  (*Now we can prove the main theorem of this section:
    Omega is pointed equivalent to iterated_loops.*)
  Theorem pEquiv_S2A_loops `{Funext} (n:nat) (A:pType) :
    (sph n *->* A) <~>* iterated_loops n A.
  Proof.
    exact (Build_pEquiv _ _
                        ((pequiv_inverse pEquiv_A_So2A)  o* (pEquiv_S2A_So2lA n A))
                        isequiv_compose).
  Defined.
End Loops.

Section homotopy_groups.

  Definition homotopy_group (n:nat) (A:pType) : pType :=
    pTr 0 (sph n *->* A).

  Notation "'HtGr'" := homotopy_group.

  Definition SphereToS2A_functor {m n:nat} (f:pSphere m ->* pSphere n) (A:pType) :
    (sph n *->* A) ->* (sph m *->* A).
  Proof.
    rapply Build_pMap.
    (*Define the map*)
    * intro h. exact (h o* f).
    (*Prove that it is pointed map.*)
    * apply pmap_postcompose_const.
  Defined.

  Definition S2A_to_HtGr_functor {m n : nat} {A:pType} (f : (sph n *->* A) ->* (sph m *->* A)) :
    HtGr n A ->* HtGr m A.
    rapply Build_pMap.
    (*Construct map*)
    *apply Trunc_rec.
     intro loop.
     apply tr.
     exact (f loop).
    (*Show that it is pointed.*)
    *apply (ap tr).
     rewrite (point_eq f).
     reflexivity.
  Qed.

  Definition SphereToHtGr_functor {m n : nat} (f:pSphere m ->* pSphere n) (A:pType) :
    HtGr n A ->* HtGr m A :=
    S2A_to_HtGr_functor (SphereToS2A_functor f A).

End homotopy_groups.

Section Hopf.
  Definition Hopf : pSphere 3 ->* pSphere 2.
  Admitted. (*TODO*)

  Definition Hopf_induced (n:nat){A:pType}:
    homotopy_group (n+2) A ->* homotopy_group (n+3) A
    :=
      SphereToHtGr_functor (natural_sphere n Hopf) A.

End Hopf.

(*  Lemma equiv_sph0toA_A `{Funext} {A:pType} : A <~> (pSphere 0 ->* A).
        equiv_via (two_pts ->* A).
            -exact equiv_twotoA_A.
            -
            refine (BuildEquiv _ _ _ _).
                +exact (fun g => g o* sph0_to_two_pts).
                +refine (BuildIsEquiv _ _ _ _ _ _ _).
                admit. admit. admit. admit.
                (*
                apply isequiv_precompose. *)
        Abort.
 *)


Set Implicit Arguments.
Section List.
Variables X Y : Type.
Variable f : X -> Y -> Y.
Inductive list0 := nil0 : list0 | cons0 : X -> list0 -> list0.
Fixpoint fold (y : Y) (xs : list0) : Y := match xs with
| nil0 => y
| cons0 x xr => fold (f x y) xr
 end.
End List.
Inductive tree := T : list0 tree -> tree.
Fixpoint size (t : tree) : nat := match t with
| T ts => S (fold (fun t a => size t + a) 0 ts)
end.
Check nil0.
Fixpoint size2 (t : tree) : nat := match t with (*1*)
 | T ts =>
   S (let fix fold y xs {struct xs} :=
      match xs with
      | nil0 _ => y
      | cons0 x xr => fold (size x + y) xr
      end
    in fold 0 ts)
end.

Fixpoint size (t : tree) : nat := match t with (*1*)
 | T ts =>
   S (let fix fold y xs {struct xs} :=
      match xs with
      | nil => y
      | cons x xr => fold (size x + y) xr
      end
    in fold 0 ts)
end.


Require Import Iso.Isomorphism.
Require Import Cat.Category.
Require Import FunctionalExtensionality.

Inductive RNA := rA | rC | rG | rU.
Inductive DNA := dA | dC | dG | dT.

Theorem iso_rna_dna : Isomorphic CoqIsCat RNA DNA.
    exists (fun x => match x with rA => dT | rC => dG | rG => dC | rU => dA end).
    exists (fun x => match x with dA => rU | dC => rG | dG => rC | dT => rA end).
    split;
        apply functional_extensionality;
        intros x;
        destruct x;
        reflexivity.
Qed.


Inductive Qpositive : Set :=
  | nR : Qpositive -> Qpositive
  | dL : Qpositive -> Qpositive
  | One : Qpositive.

Fixpoint Qpositive_le_bool (w w' : Qpositive) {struct w'} : bool :=
  match w with
  | One => match w' with
           | dL y => false
           | _ => true
           end
  | dL y => match w' with
            | dL y' => Qpositive_le_bool y y'
            | _ => true
            end
  | nR y => match w' with
            | nR y' => Qpositive_le_bool y y'
            | _ => false
            end
  end.

Definition Qpositive_le (w w' : Qpositive) := Qpositive_le_bool w w' = true.

Fixpoint Qpositive_i (w : Qpositive) : nat * nat :=
  match w with
  | One => (1, 1)
  | nR w' => match Qpositive_i w' with
             | (p, q) => (p + q, q)
             end
  | dL w' => match Qpositive_i w' with
             | (p, q) => (p, p + q)
             end
  end.

Fixpoint Qpositive_c (p q n : nat) {struct n} : Qpositive :=
  match n with
  | O => One
  | S n' =>
      match p - q with
      | O => match q - p with
             | O => One
             | v => dL (Qpositive_c p v n')
             end
      | v => nR (Qpositive_c v q n')
      end
  end.

Definition Qpositive_sub (w w' : Qpositive) :=
  let (p, q) := Qpositive_i w in
  let (p', q') := Qpositive_i w' in
  Qpositive_c (p * q' - p' * q) (q * q') (p * q' + p' * q + q * q').

Theorem interp_non_zero :
 forall w : Qpositive,
 exists p : nat, (exists q : nat, Qpositive_i w = (S p, S q)).
simple induction w; simpl in |- *;
 (repeat exists 0; auto; fail) ||
   (intros w' Hrec; elim Hrec; intros p' Hex; elim Hex; intros q' Heq;
     rewrite Heq).
exists (p' + S q'); exists q'; auto.
exists p'; exists (p' + S q'); auto.
Qed.

Ltac make_fraction w p q Heq := elim (interp_non_zero w); intros p (q, Heq).

Theorem Qpositive_le_sub_l :
 forall w w' w'' : Qpositive,
 w <> w'' ->
 w' <> w'' ->
 Qpositive_le w w'' ->
 Qpositive_le w' w'' ->
 Qpositive_le w w' ->
 Qpositive_le (Qpositive_sub w'' w') (Qpositive_sub w'' w).
Proof.
intros w w' w''; make_fraction w ipattern:(p) ipattern:(q) ipattern:(Heq);
 make_fraction w' ipattern:(p') ipattern:(q') ipattern:(Heq');
 make_fraction w'' ipattern:(p'') ipattern:(q'') ipattern:(Heq'');
 intros Hneq1 Hneq2.
Admitted.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Lemma lem: forall n1 n2 l, drop (Succ n1) (drop n2 l) = drop n1 (drop (Succ n2) l).
Proof.
intros. generalize dependent n1. generalize dependent n2. induction l.
- intros. assert (forall n x l, drop (Succ n) (Cons x l) = drop n l).
   + intros. reflexivity.
   + destruct n2.
   * rewrite H. rewrite H. rewrite <- IHl. reflexivity.
   * simpl. destruct l. reflexivity. reflexivity.
- intros. assert (forall n, drop n Nil = Nil).
   + intros. destruct n. reflexivity. reflexivity.
   + rewrite H. rewrite H. rewrite H. reflexivity.
Qed.

Theorem theorem0 : forall (v : natural) (w : natural) (x : natural) (y : natural) (z : lst), eq (drop (Succ v) (drop w (drop x (Cons y z)))) (drop v (drop w (drop x z))).
Proof.
intros.
lfind.
Admitted.