From Hammer Require Import Hammer.

Require Export Raxioms.
Require Import Rpow_def.
Require Import Zpower.
Require Export ZArithRing.
Require Import Omega.
Require Export RealField.

Local Open Scope Z_scope.
Local Open Scope R_scope.

Implicit Type r : R.

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

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

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

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

Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2.
Proof. hammer_hook "RIneq" "RIneq.Rlt_not_eq".
red; intros r1 r2 H H0; apply (Rlt_irrefl r1).
pattern r1 at 2; rewrite H0; trivial.
Qed.

Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2.
Proof. hammer_hook "RIneq" "RIneq.Rgt_not_eq".
intros; apply not_eq_sym; apply Rlt_not_eq; auto with real.
Qed.

Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2.
Proof. hammer_hook "RIneq" "RIneq.Rlt_dichotomy_converse".
intuition.
- apply Rlt_not_eq in H1. eauto.
- apply Rgt_not_eq in H1. eauto.
Qed.
Hint Resolve Rlt_dichotomy_converse: real.

Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2.
Proof. hammer_hook "RIneq" "RIneq.Req_dec".
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. hammer_hook "RIneq" "RIneq.Rtotal_order".
intros; generalize (total_order_T r1 r2); tauto.
Qed.

Lemma Rdichotomy : forall r1 r2, r1 <> r2 -> r1 < r2 \/ r1 > r2.
Proof. hammer_hook "RIneq" "RIneq.Rdichotomy".
intros; generalize (total_order_T r1 r2); tauto.
Qed.

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

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

Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1.
Proof. hammer_hook "RIneq" "RIneq.Rle_ge".
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. hammer_hook "RIneq" "RIneq.Rge_le".
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. hammer_hook "RIneq" "RIneq.Rlt_gt".
trivial.
Qed.
Hint Resolve Rlt_gt: rorders.

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

Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1.
Proof. hammer_hook "RIneq" "RIneq.Rnot_le_lt".
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. hammer_hook "RIneq" "RIneq.Rnot_ge_gt".   intros; red; apply Rnot_le_lt. auto with real. Qed.

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

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

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

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

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

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

Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
Proof. hammer_hook "RIneq" "RIneq.Rlt_not_le".
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. hammer_hook "RIneq" "RIneq.Rgt_not_le".   exact Rlt_not_le. Qed.

Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2.
Proof. hammer_hook "RIneq" "RIneq.Rlt_not_ge".   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. hammer_hook "RIneq" "RIneq.Rgt_not_ge".   exact Rlt_not_ge. Qed.

Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2.
Proof. hammer_hook "RIneq" "RIneq.Rle_not_lt".
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. hammer_hook "RIneq" "RIneq.Rge_not_lt".   intros; apply Rle_not_lt; auto with real. Qed.

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

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

Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2.
Proof. hammer_hook "RIneq" "RIneq.Req_le".
unfold Rle; tauto.
Qed.
Hint Immediate Req_le: real.

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

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

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

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

Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rle_antisym".
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. hammer_hook "RIneq" "RIneq.Rge_antisym".   auto with real. Qed.

Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rle_le_eq".
intuition.
Qed.

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

Lemma Rlt_eq_compat :
forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3.
Proof. hammer_hook "RIneq" "RIneq.Rlt_eq_compat".
intros x x' y y'; intros; replace x with x'; replace y with y'; assumption.
Qed.

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

Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3.
Proof. hammer_hook "RIneq" "RIneq.Rle_trans".
generalize eq_trans Rlt_trans Rlt_eq_compat.
unfold Rle.
intuition eauto 2.
Qed.

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

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

Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
Proof. hammer_hook "RIneq" "RIneq.Rle_lt_trans".
generalize Rlt_trans Rlt_eq_compat.
unfold Rle.
intuition eauto 2.
Qed.

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

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

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

Lemma Rlt_dec : forall r1 r2, {r1 < r2} + {~ r1 < r2}.
Proof. hammer_hook "RIneq" "RIneq.Rlt_dec".
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. hammer_hook "RIneq" "RIneq.Rle_dec".
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. hammer_hook "RIneq" "RIneq.Rgt_dec".   do 2 intro; apply Rlt_dec. Qed.

Lemma Rge_dec : forall r1 r2, {r1 >= r2} + {~ r1 >= r2}.
Proof. hammer_hook "RIneq" "RIneq.Rge_dec".   intros; edestruct Rle_dec; [left|right]; eauto with rorders. Qed.

Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}.
Proof. hammer_hook "RIneq" "RIneq.Rlt_le_dec".
intros; generalize (total_order_T r1 r2); intuition.
Qed.

Lemma Rgt_ge_dec : forall r1 r2, {r1 > r2} + {r2 >= r1}.
Proof. hammer_hook "RIneq" "RIneq.Rgt_ge_dec".   intros; edestruct Rlt_le_dec; [left|right]; eauto with rorders. Qed.

Lemma Rle_lt_dec : forall r1 r2, {r1 <= r2} + {r2 < r1}.
Proof. hammer_hook "RIneq" "RIneq.Rle_lt_dec".
intros; generalize (total_order_T r1 r2); intuition.
Qed.

Lemma Rge_gt_dec : forall r1 r2, {r1 >= r2} + {r2 > r1}.
Proof. hammer_hook "RIneq" "RIneq.Rge_gt_dec".   intros; edestruct Rle_lt_dec; [left|right]; eauto with rorders. Qed.

Lemma Rlt_or_le : forall r1 r2, r1 < r2 \/ r2 <= r1.
Proof. hammer_hook "RIneq" "RIneq.Rlt_or_le".
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. hammer_hook "RIneq" "RIneq.Rgt_or_ge".   intros; edestruct Rlt_or_le; [left|right]; eauto with rorders. Qed.

Lemma Rle_or_lt : forall r1 r2, r1 <= r2 \/ r2 < r1.
Proof. hammer_hook "RIneq" "RIneq.Rle_or_lt".
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. hammer_hook "RIneq" "RIneq.Rge_or_gt".   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. hammer_hook "RIneq" "RIneq.Rle_lt_or_eq_dec".
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. hammer_hook "RIneq" "RIneq.inser_trans_R".
intros n m p q; intros; generalize (Rlt_le_dec m q); intuition.
Qed.

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

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

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

Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 = 0 -> r2 = - r1.
Proof. hammer_hook "RIneq" "RIneq.Rplus_opp_r_uniq".
intros x y H;
replace y with (- x + x + y) by ring.
rewrite Rplus_assoc; rewrite H; ring.
Qed.

Definition f_equal_R := (f_equal (A:=R)).

Hint Resolve f_equal_R : real.

Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2.
Proof. hammer_hook "RIneq" "RIneq.Rplus_eq_compat_l".
intros r r1 r2.
apply f_equal.
Qed.

Lemma Rplus_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r.
Proof. hammer_hook "RIneq" "RIneq.Rplus_eq_compat_r".
intros r r1 r2.
apply (f_equal (fun v => v + r)).
Qed.

Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 = r + r2 -> r1 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rplus_eq_reg_l".
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. hammer_hook "RIneq" "RIneq.Rplus_eq_reg_r".
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. hammer_hook "RIneq" "RIneq.Rplus_0_r_uniq".
intros r b; pattern r at 2; replace r with (r + 0); eauto with real.
Qed.

Lemma Rplus_eq_0_l :
forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0.
Proof. hammer_hook "RIneq" "RIneq.Rplus_eq_0_l".
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. hammer_hook "RIneq" "RIneq.Rplus_eq_R0".
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.

Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1.
Proof. hammer_hook "RIneq" "RIneq.Rinv_r".
intros; field; trivial.
Qed.
Hint Resolve Rinv_r: real.

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

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

Lemma Rmult_0_r : forall r, r * 0 = 0.
Proof. hammer_hook "RIneq" "RIneq.Rmult_0_r".
intro; ring.
Qed.
Hint Resolve Rmult_0_r: real.

Lemma Rmult_0_l : forall r, 0 * r = 0.
Proof. hammer_hook "RIneq" "RIneq.Rmult_0_l".
intro; ring.
Qed.
Hint Resolve Rmult_0_l: real.

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

Lemma Rmult_1_r : forall r, r * 1 = r.
Proof. hammer_hook "RIneq" "RIneq.Rmult_1_r".
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. hammer_hook "RIneq" "RIneq.Rmult_eq_compat_l".
auto with real.
Qed.

Lemma Rmult_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 * r = r2 * r.
Proof. hammer_hook "RIneq" "RIneq.Rmult_eq_compat_r".
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. hammer_hook "RIneq" "RIneq.Rmult_eq_reg_l".
intros; transitivity (/ r * r * r1).
field; trivial.
transitivity (/ r * r * r2).
repeat rewrite Rmult_assoc; rewrite H; trivial.
field; trivial.
Qed.

Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rmult_eq_reg_r".
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. hammer_hook "RIneq" "RIneq.Rmult_integral".
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. hammer_hook "RIneq" "RIneq.Rmult_eq_0_compat".
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. hammer_hook "RIneq" "RIneq.Rmult_eq_0_compat_r".
auto with real.
Qed.

Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 = 0 -> r1 * r2 = 0.
Proof. hammer_hook "RIneq" "RIneq.Rmult_eq_0_compat_l".
auto with real.
Qed.

Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0.
Proof. hammer_hook "RIneq" "RIneq.Rmult_neq_0_reg".
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. hammer_hook "RIneq" "RIneq.Rmult_integral_contrapositive".
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. hammer_hook "RIneq" "RIneq.Rmult_integral_contrapositive_currified".   auto using Rmult_integral_contrapositive. Qed.

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

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.

Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2.
Proof. hammer_hook "RIneq" "RIneq.Ropp_eq_compat".
auto with real.
Qed.
Hint Resolve Ropp_eq_compat: real.

Lemma Ropp_0 : -0 = 0.
Proof. hammer_hook "RIneq" "RIneq.Ropp_0".
ring.
Qed.
Hint Resolve Ropp_0: real.

Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0.
Proof. hammer_hook "RIneq" "RIneq.Ropp_eq_0_compat".
intros; rewrite H; auto with real.
Qed.
Hint Resolve Ropp_eq_0_compat: real.

Lemma Ropp_involutive : forall r, - - r = r.
Proof. hammer_hook "RIneq" "RIneq.Ropp_involutive".
intro; ring.
Qed.
Hint Resolve Ropp_involutive: real.

Lemma Ropp_neq_0_compat : forall r, r <> 0 -> - r <> 0.
Proof. hammer_hook "RIneq" "RIneq.Ropp_neq_0_compat".
red; 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. hammer_hook "RIneq" "RIneq.Ropp_plus_distr".
intros; ring.
Qed.
Hint Resolve Ropp_plus_distr: real.

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

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

Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2.
Proof. hammer_hook "RIneq" "RIneq.Rmult_opp_opp".
intros; ring.
Qed.
Hint Resolve Rmult_opp_opp: real.

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

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

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

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

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

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

Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0.
Proof. hammer_hook "RIneq" "RIneq.Rminus_diag_eq".
intros; rewrite H; ring.
Qed.
Hint Resolve Rminus_diag_eq: real.

Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rminus_diag_uniq".
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. hammer_hook "RIneq" "RIneq.Rminus_diag_uniq_sym".
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. hammer_hook "RIneq" "RIneq.Rplus_minus".
intros; ring.
Qed.
Hint Resolve Rplus_minus: real.

Lemma Rminus_eq_contra : forall r1 r2, r1 <> r2 -> r1 - r2 <> 0.
Proof. hammer_hook "RIneq" "RIneq.Rminus_eq_contra".
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. hammer_hook "RIneq" "RIneq.Rminus_not_eq".
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. hammer_hook "RIneq" "RIneq.Rminus_not_eq_right".
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. hammer_hook "RIneq" "RIneq.Rmult_minus_distr_l".
intros; ring.
Qed.

Lemma Rinv_1 : / 1 = 1.
Proof. hammer_hook "RIneq" "RIneq.Rinv_1".
field.
Qed.
Hint Resolve Rinv_1: real.

Lemma Rinv_neq_0_compat : forall r, r <> 0 -> / r <> 0.
Proof. hammer_hook "RIneq" "RIneq.Rinv_neq_0_compat".
red; intros; apply R1_neq_R0.
replace 1 with (/ r * r); auto with real.
Qed.
Hint Resolve Rinv_neq_0_compat: real.

Lemma Rinv_involutive : forall r, r <> 0 -> / / r = r.
Proof. hammer_hook "RIneq" "RIneq.Rinv_involutive".
intros; field; trivial.
Qed.
Hint Resolve Rinv_involutive: real.

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

Lemma Ropp_inv_permute : forall r, r <> 0 -> - / r = / - r.
Proof. hammer_hook "RIneq" "RIneq.Ropp_inv_permute".
intros; field; trivial.
Qed.

Lemma Rinv_r_simpl_r : forall r1 r2, r1 <> 0 -> r1 * / r1 * r2 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rinv_r_simpl_r".
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. hammer_hook "RIneq" "RIneq.Rinv_r_simpl_l".
intros; transitivity (r2 * 1); auto with real.
transitivity (r2 * (r1 * / r1)); auto with real.
Qed.

Lemma Rinv_r_simpl_m : forall r1 r2, r1 <> 0 -> r1 * r2 * / r1 = r2.
Proof. hammer_hook "RIneq" "RIneq.Rinv_r_simpl_m".
intros; transitivity (r2 * 1); auto with real.
transitivity (r2 * (r1 * / r1)); auto with real.
ring.
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. hammer_hook "RIneq" "RIneq.Rinv_mult_simpl".
intros a b c; intros.
transitivity (a * / a * (c * / b)); auto with real.
ring.
Qed.

Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2.
Proof. hammer_hook "RIneq" "RIneq.Rplus_gt_compat_l".   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. hammer_hook "RIneq" "RIneq.Rplus_lt_compat_r".
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. hammer_hook "RIneq" "RIneq.Rplus_gt_compat_r".   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. hammer_hook "RIneq" "RIneq.Rplus_le_compat_l".
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. hammer_hook "RIneq" "RIneq.Rplus_ge_compat_l".   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. hammer_hook "RIneq" "RIneq.Rplus_le_compat_r".
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. hammer_hook "RIneq" "RIneq.Rplus_ge_compat_r".   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. hammer_hook "RIneq" "RIneq.Rplus_lt_compat".
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. hammer_hook "RIneq" "RIneq.Rplus_le_compat".
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. hammer_hook "RIneq" "RIneq.Rplus_gt_compat".   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. hammer_hook "RIneq" "RIneq.Rplus_ge_compat".   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. hammer_hook "RIneq" "RIneq.Rplus_lt_le_compat".
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. hammer_hook "RIneq" "RIneq.Rplus_le_lt_compat".
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. hammer_hook "RIneq" "RIneq.Rplus_gt_ge_compat".   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. hammer_hook "RIneq" "RIneq.Rplus_ge_gt_compat".   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. hammer_hook "RIneq" "RIneq.Rplus_lt_0_compat".
intros x y; intros; apply Rlt_trans with x;
[ assumption
| pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
assumption ].
Qed.

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

Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2.
Proof. hammer_hook "RIneq" "RIneq.Rplus_lt_le_0_compat".
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. hammer_hook "RIneq" "RIneq.Rplus_le_le_0_compat".
intros x y; intros; apply Rle_trans with x;
[ assumption
| pattern x at 1; rewrite <- (Rplus_0_r x); 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. hammer_hook "RIneq" "RIneq.sum_inequa_Rle_lt".
intros; split.
apply Rlt_le_trans with (a + y); auto with real.
apply Rlt_le_trans with (b + y); auto with real.
Qed.

Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
Proof. hammer_hook "RIneq" "RIneq.Rplus_lt_reg_l".
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. hammer_hook "RIneq" "RIneq.Rplus_lt_reg_r".
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. hammer_hook "RIneq" "RIneq.Rplus_le_reg_l".
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. hammer_hook "RIneq" "RIneq.Rplus_le_reg_r".
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. hammer_hook "RIneq" "RIneq.Rplus_gt_reg_l".
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. hammer_hook "RIneq" "RIneq.Rplus_ge_reg_l".
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. hammer_hook "RIneq" "RIneq.Rplus_le_reg_pos_r".
intros x y z; intros; apply Rle_trans with (x + y);
[ pattern x at 1; rewrite <- (Rplus_0_r x); 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. hammer_hook "RIneq" "RIneq.Rplus_lt_reg_pos_r".
intros x y z; intros; apply Rle_lt_trans with (x + y);
[ pattern x at 1; rewrite <- (Rplus_0_r x); 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. hammer_hook "RIneq" "RIneq.Rplus_ge_reg_neg_r".
intros x y z; intros; apply Rge_trans with (x + y);
[ pattern x at 1; rewrite <- (Rplus_0_r x); 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. hammer_hook "RIneq" "RIneq.Rplus_gt_reg_neg_r".
intros x y z; intros; apply Rge_gt_trans with (x + y);
[ pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_ge_compat_l;
assumption
| assumption ].
Qed.

Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2.
Proof. hammer_hook "RIneq" "RIneq.Ropp_gt_lt_contravar".
unfold Rgt; intros.
apply (Rplus_lt_reg_l (r2 + r1)).
replace (r2 + r1 + - r1) with r2 by ring.
replace (r2 + r1 + - r2) with r1 by ring.
exact H.
Qed.
Hint Resolve Ropp_gt_lt_contravar.

Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2.
Proof. hammer_hook "RIneq" "RIneq.Ropp_lt_gt_contravar".
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. hammer_hook "RIneq" "RIneq.Ropp_lt_contravar".
auto with real.
Qed.
Hint Resolve Ropp_lt_contravar: real.

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

Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2.
Proof. hammer_hook "RIneq" "RIneq.Ropp_le_ge_contravar".
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. hammer_hook "RIneq" "RIneq.Ropp_ge_le_contravar".
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. hammer_hook "RIneq" "RIneq.Ropp_le_contravar".
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. hammer_hook "RIneq" "RIneq.Ropp_ge_contravar".   auto using Ropp_le_contravar with real. Qed.

Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r.
Proof. hammer_hook "RIneq" "RIneq.Ropp_0_lt_gt_contravar".
intros; replace 0 with (-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. hammer_hook "RIneq" "RIneq.Ropp_0_gt_lt_contravar".
intros; replace 0 with (-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. hammer_hook "RIneq" "RIneq.Ropp_lt_gt_0_contravar".
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. hammer_hook "RIneq" "RIneq.Ropp_gt_lt_0_contravar".
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. hammer_hook "RIneq" "RIneq.Ropp_0_le_ge_contravar".
intros; replace 0 with (-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. hammer_hook "RIneq" "RIneq.Ropp_0_ge_le_contravar".
intros; replace 0 with (-0); auto with real.
Qed.
Hint Resolve Ropp_0_ge_le_contravar: real.

Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2.
Proof. hammer_hook "RIneq" "RIneq.Ropp_lt_cancel".
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. hammer_hook "RIneq" "RIneq.Ropp_gt_cancel".   auto using Ropp_lt_cancel with rorders. Qed.

Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2.
Proof. hammer_hook "RIneq" "RIneq.Ropp_le_cancel".
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. hammer_hook "RIneq" "RIneq.Ropp_ge_cancel".   auto using Ropp_le_cancel with rorders. Qed.

Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r.
Proof. hammer_hook "RIneq" "RIneq.Rmult_lt_compat_r".
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. hammer_hook "RIneq" "RIneq.Rmult_gt_compat_r".   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. hammer_hook "RIneq" "RIneq.Rmult_gt_compat_l".   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. hammer_hook "RIneq" "RIneq.Rmult_le_compat_l".
intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle;
auto with real.
right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity.
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. hammer_hook "RIneq" "RIneq.Rmult_le_compat_r".
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. hammer_hook "RIneq" "RIneq.Rmult_ge_compat_l".   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. hammer_hook "RIneq" "RIneq.Rmult_ge_compat_r".   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. hammer_hook "RIneq" "RIneq.Rmult_le_compat".
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. hammer_hook "RIneq" "RIneq.Rmult_ge_compat".   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. hammer_hook "RIneq" "RIneq.Rmult_gt_0_lt_compat".
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. hammer_hook "RIneq" "RIneq.Rmult_le_0_lt_compat".
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. hammer_hook "RIneq" "RIneq.Rmult_lt_0_compat".   intros; replace 0 with (0 * r2); auto with real. Qed.

Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof. hammer_hook "RIneq" "RIneq.Rmult_gt_0_compat".  exact (Rmult_lt_0_compat). Qed.

Lemma Rmult_le_compat_neg_l :
forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1.
Proof. hammer_hook "RIneq" "RIneq.Rmult_le_compat_neg_l".
intros; replace r with (- - 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. hammer_hook "RIneq" "RIneq.Rmult_le_ge_compat_neg_l".
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. hammer_hook "RIneq" "RIneq.Rmult_lt_gt_compat_neg_l".
intros; replace r with (- - 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.

Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2.
Proof. hammer_hook "RIneq" "RIneq.Rmult_lt_reg_l".
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. hammer_hook "RIneq" "RIneq.Rmult_lt_reg_r".
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. hammer_hook "RIneq" "RIneq.Rmult_gt_reg_l".   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. hammer_hook "RIneq" "RIneq.Rmult_le_reg_l".
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; replace x with (/ z * (z * x)); auto with real.
replace y with (/ z * (z * y)).
rewrite H1; auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real.
Qed.

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

Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0.
Proof. hammer_hook "RIneq" "RIneq.Rlt_minus".
intros; apply (Rplus_lt_reg_l r2).
replace (r2 + (r1 - r2)) with r1 by ring.
now rewrite Rplus_0_r.
Qed.
Hint Resolve Rlt_minus: real.

Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0.
Proof. hammer_hook "RIneq" "RIneq.Rgt_minus".
intros; apply (Rplus_lt_reg_l r2).
replace (r2 + (r1 - r2)) with r1 by ring.
now rewrite Rplus_0_r.
Qed.

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

Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0.
Proof. hammer_hook "RIneq" "RIneq.Rle_minus".
destruct 1; unfold Rle; auto with real.
Qed.

Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0.
Proof. hammer_hook "RIneq" "RIneq.Rge_minus".
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. hammer_hook "RIneq" "RIneq.Rminus_lt".
intros; replace r1 with (r1 - r2 + r2).
pattern r2 at 3; replace r2 with (0 + r2); auto with real.
ring.
Qed.

Lemma Rminus_gt : forall r1 r2, r1 - r2 > 0 -> r1 > r2.
Proof. hammer_hook "RIneq" "RIneq.Rminus_gt".
intros; replace r2 with (0 + r2); auto with real.
replace r1 with (r1 - r2 + r2).
apply Rplus_gt_compat_r; assumption.
ring.
Qed.

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

Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2.
Proof. hammer_hook "RIneq" "RIneq.Rminus_le".
intros; replace r1 with (r1 - r2 + r2).
pattern r2 at 3; replace r2 with (0 + r2); auto with real.
ring.
Qed.

Lemma Rminus_ge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2.
Proof. hammer_hook "RIneq" "RIneq.Rminus_ge".
intros; replace r2 with (0 + r2); auto with real.
replace r1 with (r1 - r2 + r2).
apply Rplus_ge_compat_r; assumption.
ring.
Qed.

Lemma tech_Rplus : forall r (s:R), 0 <= r -> 0 < s -> r + s <> 0.
Proof. hammer_hook "RIneq" "RIneq.tech_Rplus".
intros; apply not_eq_sym; apply Rlt_not_eq.
rewrite Rplus_comm; replace 0 with (0 + 0); auto with real.
Qed.
Hint Immediate tech_Rplus: real.

Lemma Rle_0_sqr : forall r, 0 <= Rsqr r.
Proof. hammer_hook "RIneq" "RIneq.Rle_0_sqr".
intro; case (Rlt_le_dec r 0); unfold Rsqr; intro.
replace (r * r) with (- r * - r); auto with real.
replace 0 with (- r * 0); auto with real.
replace 0 with (0 * r); auto with real.
Qed.

Lemma Rlt_0_sqr : forall r, r <> 0 -> 0 < Rsqr r.
Proof. hammer_hook "RIneq" "RIneq.Rlt_0_sqr".
intros; case (Rdichotomy r 0); trivial; unfold Rsqr; intro.
replace (r * r) with (- r * - r); auto with real.
replace 0 with (- r * 0); auto with real.
replace 0 with (0 * r); 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. hammer_hook "RIneq" "RIneq.Rplus_sqr_eq_0_l".
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. hammer_hook "RIneq" "RIneq.Rplus_sqr_eq_0".
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.

Lemma Rlt_0_1 : 0 < 1.
Proof. hammer_hook "RIneq" "RIneq.Rlt_0_1".
replace 1 with (Rsqr 1); auto with real.
unfold Rsqr; auto with real.
Qed.
Hint Resolve Rlt_0_1: real.

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

Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r.
Proof. hammer_hook "RIneq" "RIneq.Rinv_0_lt_compat".
intros; apply Rnot_le_lt; red; intros.
absurd (1 <= 0); auto with real.
replace 1 with (r * / r); auto with real.
replace 0 with (r * 0); auto with real.
Qed.
Hint Resolve Rinv_0_lt_compat: real.

Lemma Rinv_lt_0_compat : forall r, r < 0 -> / r < 0.
Proof. hammer_hook "RIneq" "RIneq.Rinv_lt_0_compat".
intros; apply Rnot_le_lt; red; intros.
absurd (1 <= 0); auto with real.
replace 1 with (r * / r); auto with real.
replace 0 with (r * 0); 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. hammer_hook "RIneq" "RIneq.Rinv_lt_contravar".
intros; apply Rmult_lt_reg_l with (r1 * r2); auto with real.
case (Rmult_neq_0_reg r1 r2); intros; auto with real.
replace (r1 * r2 * / r2) with r1.
replace (r1 * r2 * / r1) with r2; trivial.
symmetry ; auto with real.
symmetry ; auto with real.
Qed.

Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1.
Proof. hammer_hook "RIneq" "RIneq.Rinv_1_lt_contravar".
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); 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.

Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1.
Proof. hammer_hook "RIneq" "RIneq.Rle_lt_0_plus_1".
intros.
apply Rlt_le_trans with 1; auto with real.
pattern 1 at 1; replace 1 with (0 + 1); auto with real.
Qed.
Hint Resolve Rle_lt_0_plus_1: real.

Lemma Rlt_plus_1 : forall r, r < r + 1.
Proof. hammer_hook "RIneq" "RIneq.Rlt_plus_1".
intros.
pattern r at 1; replace r with (r + 0); auto with real.
Qed.
Hint Resolve Rlt_plus_1: real.

Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2.
Proof. hammer_hook "RIneq" "RIneq.tech_Rgt_minus".
red; unfold Rminus; intros.
pattern r1 at 2; replace r1 with (r1 + 0); auto with real.
Qed.

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

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

Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m.
Proof. hammer_hook "RIneq" "RIneq.plus_INR".
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. hammer_hook "RIneq" "RIneq.minus_INR".
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. hammer_hook "RIneq" "RIneq.mult_INR".
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 lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n.
Proof. hammer_hook "RIneq" "RIneq.lt_0_INR".
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. hammer_hook "RIneq" "RIneq.lt_INR".
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. hammer_hook "RIneq" "RIneq.lt_1_INR".
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. hammer_hook "RIneq" "RIneq.pos_INR_nat_of_P".
intro; apply lt_0_INR.
simpl; auto with real.
apply Pos2Nat.is_pos.
Qed.
Hint Resolve pos_INR_nat_of_P: real.

Lemma pos_INR : forall n:nat, 0 <= INR n.
Proof. hammer_hook "RIneq" "RIneq.pos_INR".
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. hammer_hook "RIneq" "RIneq.INR_lt".
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. hammer_hook "RIneq" "RIneq.le_INR".
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. hammer_hook "RIneq" "RIneq.INR_not_0".
red; intros n H H1.
apply H.
rewrite H1; trivial.
Qed.
Hint Immediate INR_not_0: real.

Lemma not_0_INR : forall n:nat, n <> 0%nat -> INR n <> 0.
Proof. hammer_hook "RIneq" "RIneq.not_0_INR".
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. hammer_hook "RIneq" "RIneq.not_INR".
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_eq_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. hammer_hook "RIneq" "RIneq.INR_eq".
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. hammer_hook "RIneq" "RIneq.INR_le".
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. hammer_hook "RIneq" "RIneq.not_1_INR".
intros n.
apply not_INR.
Qed.
Hint Resolve not_1_INR: real.

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

Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p.
Proof. hammer_hook "RIneq" "RIneq.INR_IPR".
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.

Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n).
Proof. hammer_hook "RIneq" "RIneq.INR_IZR_INZ".
intros [|n].
easy.
simpl Z.of_nat. unfold IZR.
now rewrite <- INR_IPR, SuccNat2Pos.id_succ.
Qed.

Lemma plus_IZR_NEG_POS :
forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q).
Proof. hammer_hook "RIneq" "RIneq.plus_IZR_NEG_POS".
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.

Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m.
Proof. hammer_hook "RIneq" "RIneq.plus_IZR".
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.
apply plus_IZR_NEG_POS.
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. hammer_hook "RIneq" "RIneq.mult_IZR".
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. hammer_hook "RIneq" "RIneq.pow_IZR".
intros z [|n];simpl;trivial.
rewrite Zpower_pos_nat.
rewrite SuccNat2Pos.id_succ. unfold Zpower_nat;simpl.
rewrite mult_IZR.
induction n;simpl;trivial.
rewrite mult_IZR;ring[IHn].
Qed.

Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1.
Proof. hammer_hook "RIneq" "RIneq.succ_IZR".
intro; unfold Z.succ; apply plus_IZR.
Qed.

Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n.
Proof. hammer_hook "RIneq" "RIneq.opp_IZR".
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. hammer_hook "RIneq" "RIneq.minus_IZR".
intros; unfold Z.sub, Rminus.
rewrite <- opp_IZR.
apply plus_IZR.
Qed.

Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m).
Proof. hammer_hook "RIneq" "RIneq.Z_R_minus".
intros z1 z2; unfold Rminus; unfold Z.sub.
rewrite <- (Ropp_Ropp_IZR z2); symmetry ; apply plus_IZR.
Qed.

Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
Proof. hammer_hook "RIneq" "RIneq.lt_0_IZR".
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. hammer_hook "RIneq" "RIneq.lt_IZR".
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.

Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z.
Proof. hammer_hook "RIneq" "RIneq.eq_IZR_R0".
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. hammer_hook "RIneq" "RIneq.eq_IZR".
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.

Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0.
Proof. hammer_hook "RIneq" "RIneq.not_0_IZR".
intros z H; red; intros H0; case H.
apply eq_IZR; auto.
Qed.

Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z.
Proof. hammer_hook "RIneq" "RIneq.le_0_IZR".
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. hammer_hook "RIneq" "RIneq.le_IZR".
unfold Rle; intros z1 z2 [H| H].
apply (Z.lt_le_incl z1 z2); auto with real.
apply lt_IZR; trivial.
rewrite (eq_IZR z1 z2); auto with zarith real.
Qed.

Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z.
Proof. hammer_hook "RIneq" "RIneq.le_IZR_R1".
intros n.
apply le_IZR.
Qed.

Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m.
Proof. hammer_hook "RIneq" "RIneq.IZR_ge".
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. hammer_hook "RIneq" "RIneq.IZR_le".
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. hammer_hook "RIneq" "RIneq.IZR_lt".
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. hammer_hook "RIneq" "RIneq.IZR_neq".
intros; red; intro; elim H; apply eq_IZR; assumption.
Qed.

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. hammer_hook "RIneq" "RIneq.one_IZR_lt1".
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. hammer_hook "RIneq" "RIneq.one_IZR_r_R1".
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.
replace (-1) with (r - (r + 1)).
unfold Rminus; apply Rplus_lt_le_compat; auto with real.
ring.
replace 1 with (r + 1 - r).
unfold Rminus; apply Rplus_le_lt_compat; auto with real.
ring.
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. hammer_hook "RIneq" "RIneq.single_z_r_R1".
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. hammer_hook "RIneq" "RIneq.tech_single_z_r_R1".
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. hammer_hook "RIneq" "RIneq.Rmult_le_pos".
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. hammer_hook "RIneq" "RIneq.Rinv_le_contravar".
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. hammer_hook "RIneq" "RIneq.Rle_Rinv".
intros x y H _.
apply Rinv_le_contravar with (1 := H).
Qed.

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

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

Lemma double_var : forall r1, r1 = r1 / 2 + r1 / 2.
Proof. hammer_hook "RIneq" "RIneq.double_var".
intro; rewrite <- double; unfold Rdiv; rewrite <- Rmult_assoc;
symmetry ; apply Rinv_r_simpl_m.
now apply not_0_IZR.
Qed.

Lemma R_rm : ring_morph
0%R 1%R Rplus Rmult Rminus Ropp eq
0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool IZR.
Proof. hammer_hook "RIneq" "RIneq.R_rm".
constructor ; try easy.
exact plus_IZR.
exact minus_IZR.
exact mult_IZR.
exact opp_IZR.
intros x y H.
apply f_equal.
now apply Zeq_bool_eq.
Qed.

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

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

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. hammer_hook "RIneq" "RIneq.Rmult_ge_0_gt_0_lt_compat".
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. hammer_hook "RIneq" "RIneq.le_epsilon".
intros x y H.
destruct (Rle_or_lt x y) as [H1|H1].
exact H1.
apply Rplus_le_reg_r with x.
replace (y + x) with (2 * (y + (x - y) * / 2)) by field.
replace (x + x) with (2 * x) by ring.
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 completeness_weak :
forall E:R -> Prop,
bound E -> (exists x : R, E x) ->  exists m : R, is_lub E m.
Proof. hammer_hook "RIneq" "RIneq.completeness_weak".
intros; elim (completeness E H H0); intros; split with x; assumption.
Qed.

Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a/b.
Proof. hammer_hook "RIneq" "RIneq.Rdiv_lt_0_compat".
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.

Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
Proof. hammer_hook "RIneq" "RIneq.Req_EM_T".
intros; destruct (total_order_T r1 r2) as [[H|]|H].
- right; red; intros ->; elim (Rlt_irrefl r2 H).
- left; assumption.
- right; red; intros ->; elim (Rlt_irrefl r2 H).
Qed.

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}.

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).


Require Import CFGancestor.

Section cfg.
  Context `{C : redCFG}.
  Definition ancestor' a p q := deq_loop p a /\ deq_loop q a.

  Lemma ancestor_ancestor' a p q
    : ancestor a p q -> ancestor' a p q.
    intros. unfold ancestor',ancestor in *. destruct H.
    - destruct H. split;eauto using loop_contains_deq_loop.
    - subst. split;eapply deq_loop_root.
  Qed.

  Global Instance ancestor'_sym : forall a, Symmetric (ancestor' a).
  Proof.
    intros.
    econstructor;unfold ancestor' in *;destructH;eauto.
  Qed.

  Global Instance ancestor'_eq_loop a p
    : Proper (eq_loop ==> Basics.impl) (ancestor' a p).
  Proof.
    econstructor;unfold ancestor' in *;destructH;eauto.
    destruct H. transitivity x;auto.
  Qed.
End cfg.


Require Import refocusing_substitutions.
Require Import Setoid.

Module CallByName <: RED_LANG.

  Parameter var_name : Set.

  Inductive term' : Set :=
  | var : var_name -> term'
  | lam : var_name -> term' -> term'
  | appl : term' -> term' -> term'.
  Definition term := term'.

  Inductive value' : Set :=
  | v_var : var_name -> value'
  | v_lam : var_name -> term -> value'.
  Definition value := value'.

  Inductive redex' : Set :=
  | beta : value -> term -> redex'.
  Definition redex := redex'.

  Definition value_to_term (v : value) : term :=
  match v with
  | v_var v' => var v'
  | v_lam v' t => lam v' t
  end.
  Coercion value_to_term : value >-> term.

  Lemma value_to_term_injective : forall v v', value_to_term v = value_to_term v' -> v = v'.
  Proof.
    intros v v0; case v; case v0; simpl; intros; try discriminate; injection H;
    intros; subst v1; try subst t; auto.
  Qed.
  Hint Resolve value_to_term_injective.

  Definition redex_to_term (r : redex) : term :=
  match r with
  | beta v t => appl (v:term) t
  end.
  Coercion redex_to_term : redex >-> term.

  Lemma redex_to_term_injective : forall r r', redex_to_term r = redex_to_term r' -> r = r'.
  Proof.
    intros r r0; case r; case r0; intros; injection H; intros;
    rewrite (value_to_term_injective _ _ H1); rewrite H0; auto.
  Qed.

  Parameter subst : term -> var_name -> term -> term.

  Definition contract (r : redex) : option term :=
  match r with
    | beta v t => match v with
                    | v_var x => None
                    | v_lam x t0 => Some (subst t0 x t)
                  end
  end.

  Inductive elem_context' : Set :=
  | ap_r : term -> elem_context'.
  Definition elem_context := elem_context'.
  Definition context := list elem_context.
  Definition empty : context := nil.

  Definition compose (c0 c1 : context) : context := app c0 c1.
  Definition atom_plug (t : term) (ec : elem_context) : term :=
  match ec with
    | ap_r t0 => appl t t0
  end.
  Definition plug (t : term) (c : context) : term := fold_left atom_plug c t.

  Lemma plug_compose : forall (c c' : context) (t : term), plug t (compose c c') = plug (plug t c) c'.
  Proof (fold_left_app atom_plug).
  Hint Resolve plug_compose : prop.

  Lemma decompose : forall t : term, (exists v : value, t = v) \/
                      (exists r : redex, exists c : context, plug r c = t).
  Proof.
    induction t; simpl; [ left; split with (v_var v) | left; split with (v_lam v t) | right ]; auto.
    clear IHt2; destruct IHt1 as [[v H] | [r [c H]]]; [exists (beta v t2); exists empty
    | exists r; exists (compose c (ap_r t2 :: empty)); rewrite plug_compose]; subst; simpl; auto.
  Qed.

  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.
  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t -> c = empty \/ exists v, t' = value_to_term v.

  Lemma value_trivial : forall v : value, only_trivial (value_to_term v).
  Proof.
    intros v t c; generalize dependent t; induction c; intros; simpl in *; auto; right;
    destruct (IHc _ H) as [H0 | [v0 H0]]; subst; simpl in *;
    match goal with [Hdisc : atom_plug ?t ?a = _ ?v |- _ ] => destruct a; destruct v; discriminate Hdisc end.
  Qed.
  Lemma redex_trivial : forall r : redex, only_trivial (redex_to_term r).
  Proof.
    intros r t c; generalize dependent t; induction c; intros; simpl in *; auto; right;
    destruct (IHc _ H) as [H0 | [v0 H0]]; subst; simpl in *.
    destruct r; destruct a; inversion H; subst; exists v; auto.
    destruct a; destruct v0; discriminate H0.
  Qed.
  Lemma value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
  Proof.
    intros v r H; destruct v; destruct r; discriminate H.
  Qed.

  Lemma ot_subt : forall t t0 ec, only_trivial t -> atom_plug t0 ec = t -> exists v, t0 = value_to_term v.
  Proof with auto.
    intros; destruct (H t0 (ec :: nil)) as [H1 | [v H1]]...
    discriminate.
    exists v...
  Qed.

  Ltac ot_v t ec :=
  match goal with
  | [Hot : (only_trivial ?H1) |- _] => destruct (ot_subt _ t ec Hot) as [?v HV]; [auto | subst t]
  end.

  Ltac mlr rv :=
  match goal with
  | [ |- (exists v, ?H1 = value_to_term v) \/ (exists r, ?H1 = redex_to_term r)] =>
    match rv with
    | (?v : value) => left; exists v
    | (?r : redex) => right; exists r
    end; simpl; auto
  end.

  Lemma trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).
  Proof.
    destruct t; intros.
    mlr (v_var v).
    mlr (v_lam v t).
    ot_v t1 (ap_r t2); mlr (beta v t2).
  Qed.

End CallByName.

Module CallByName_Eval <: RED_SEM CallByName.

Definition term := CallByName.term.
Definition value := CallByName.value.
Definition redex := CallByName.redex.
Definition context := CallByName.context.
Definition var := CallByName.var.
Definition lam := CallByName.lam.
Definition appl := CallByName.appl.
Definition v_var := CallByName.v_var.
Definition v_lam := CallByName.v_lam.
Definition beta := CallByName.beta.
Definition empty := CallByName.empty.
Definition ap_r := CallByName.ap_r.
Definition value_to_term : value -> term := CallByName.value_to_term.
Definition redex_to_term : redex -> term := CallByName.redex_to_term.
Coercion value_to_term : value >-> term.
Coercion redex_to_term : redex >-> term.
Definition decomp_to_term := CallByName.decomp_to_term.

Definition contract := CallByName.contract.
Definition plug := CallByName.plug.
Definition compose := CallByName.compose.

Definition decomp := CallByName.decomp.
Definition d_val := CallByName.d_val.
Definition d_red := CallByName.d_red.

Inductive dec' : CallByName.term -> CallByName.context -> CallByName.decomp -> Prop :=
| val_ctx : forall (v : CallByName.value) (c : CallByName.context) (d : CallByName.decomp),
  decctx c v d -> dec' v c d
| app_ctx : forall (t s : CallByName.term) (c : CallByName.context) (d : CallByName.decomp),
  dec' t (ap_r s :: c) d -> dec' (appl t s) c d
with decctx : CallByName.context -> CallByName.value -> CallByName.decomp -> Prop :=
| mt_dec : forall (v : CallByName.value),
  decctx CallByName.empty v (CallByName.d_val v)
| ap_dec : forall (v : CallByName.value) (t : CallByName.term) (c : CallByName.context),
  decctx (ap_r t :: c) v (CallByName.d_red (CallByName.beta v t) c).

Definition dec := dec'.

Scheme dec_Ind := Induction for dec' Sort Prop
with decctx_Ind := Induction for decctx Sort Prop.

Lemma dec_redex_self : forall (r : redex) (c : context), dec (redex_to_term r) c (d_red r c).
Proof.
intros; destruct r; repeat (constructor; simpl; auto).
Qed.

Lemma dec_correct : forall t c d, dec t c d -> decomp_to_term d = plug t c.
Proof.
induction 1 using dec_Ind with
(P := fun t c d (H:dec t c d) => decomp_to_term d = plug t c)
(P0 := fun c v d (H:decctx c v d) => decomp_to_term d = plug v c); intros; simpl; auto.
Qed.

Lemma dec_plug :
  forall c c0 t d, dec (plug t c) c0 d -> dec t (compose c c0) d.
Proof.
  induction c; intros; auto; simpl; assert (hh:=IHc _ _ _ H); inversion hh; subst;
  destruct a; try (destruct v); inversion H0; subst; auto.
Qed.

Lemma dec_plug_rev :
  forall c c0 t d, dec t (compose c c0) d -> dec (plug t c) c0 d.
Proof.
induction c; intros; auto; simpl; apply IHc; destruct a;
constructor; inversion H; subst; constructor; trivial.
Qed.

  Inductive decempty : term -> decomp -> Prop :=
  | d_intro : forall (t : term) (d : decomp), dec t empty d -> decempty t d.

  Inductive iter : decomp -> value -> Prop :=
  | i_val : forall (v : value), iter (d_val v) v
  | i_red : forall (r : redex) (t : term) (c : context) (d : decomp) (v : value),
              contract r = Some t -> decempty (plug t c) d -> iter d v -> iter (d_red r c) v.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (d : decomp) (v : value), decempty t d -> iter d v -> eval t v.

  Definition decompose := CallByName.decompose.

End CallByName_Eval.

Module CallByName_Ref <: RED_REF_LANG.

  Module R := CallByName.

  Definition dec_term (t : R.term) : R.interm_dec :=
  match t with
  | CallByName.var v0 => R.in_val (CallByName.v_var v0)
  | CallByName.lam v t => R.in_val (CallByName.v_lam v t)
  | CallByName.appl t0 t1 => R.in_term t0 (CallByName.ap_r t1)
  end.
  Definition dec_context (ec : R.elem_context) (v : R.value) : R.interm_dec :=
  match ec with
  | CallByName.ap_r t => R.in_red (R.beta v t)
  end.

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Lemma wf_st1 : well_founded subterm_one_step.
  Proof.
    prove_st_wf.
  Qed.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

  Definition ec_order (ec0 : R.elem_context) (ec1 : R.elem_context) : Prop := False.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Lemma wf_eco : well_founded ec_order.
  Proof.
    prove_ec_wf.
  Qed.

  Lemma dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Proof.
    intros; destruct t; inversion H.
  Qed.
  Lemma dec_term_val_empty : forall t v, dec_term t = R.in_val v -> R.only_empty t.
  Proof.
    intros; destruct t; inversion H; subst; intros t0 c; generalize dependent t0; induction c; intros; simpl in *;
    auto; assert (hh := IHc _ H0); subst; destruct a; inversion H0.
  Qed.
  Lemma dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec -> forall ec', ~ec <: ec'.
  Proof.
    intros; destruct t; inversion H; subst; intro; contradiction H0.
  Qed.
  Lemma dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r -> forall ec', ~ec' <: ec.
  Proof.
    intros; destruct ec; inversion H; subst; intro; contradiction H0.
  Qed.
  Lemma dec_context_val_bot : forall ec v v0, dec_context ec v = R.in_val v0 -> forall ec', ~ec' <: ec.
  Proof.
    intros; destruct ec; inversion H.
  Qed.
  Lemma dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' -> ec' <: ec /\ forall ec'', ec'' <: ec -> ~ec' <: ec''.
  Proof.
    intros; destruct ec; inversion H.
  Qed.

  Lemma dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Proof.
    intros; destruct t; simpl; auto.
  Qed.
  Lemma dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v0 => R.value_to_term v0 = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.
  Proof.
    intros; destruct ec; simpl; auto.
  Qed.

  Lemma ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ec0 <: ec.
  Proof.
    intros; inversion H.
  Qed.
  Lemma dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Proof.
    intros; destruct ec0; destruct ec1; destruct t0; destruct t1; inversion H; subst; right; right; constructor; auto.
  Qed.
  Lemma elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.
  Proof.
    intros; inversion H.
  Qed.

End CallByName_Ref.

Module CallByName_RefEval_auto <: RED_REF_SEM CallByName := RedRefSem CallByName_Ref.

Lemma dec_sem_aref : forall t c d, CallByName_Eval.dec t c d <-> CallByName_RefEval_auto.dec t c d.
Proof with auto.
split; intro H.
induction H using CallByName_Eval.dec_Ind with
(P := fun t c d (H : CallByName_Eval.dec t c d) => CallByName_RefEval_auto.dec t c d)
(P0:= fun c v d (H : CallByName_Eval.decctx c v d) => CallByName_RefEval_auto.decctx v c d).
econstructor; eauto; destruct v; simpl; auto.
econstructor 3; simpl; eauto.
constructor.
econstructor; eauto.
induction H using CallByName_RefEval_auto.dec_Ind with
(P := fun t c d (H : CallByName_RefEval_auto.dec t c d) => CallByName_Eval.dec t c d)
(P0:= fun v c d (H : CallByName_RefEval_auto.decctx v c d) => CallByName_Eval.decctx c v d);
try (destruct t; inversion DT); try (destruct ec; inversion DC); subst; try econstructor; eauto.
cutrewrite (CallByName.var v0 = CallByName.value_to_term (CallByName.v_var v0)); try constructor; auto.
cutrewrite (CallByName.lam v0 t = CallByName.value_to_term (CallByName.v_lam v0 t)); try constructor; auto.
Qed.

Lemma iter_sem_aref : forall d v, CallByName_Eval.iter d v <-> CallByName_RefEval_auto.RS.iter d v.
Proof with auto.
split; intro H; induction H; try constructor;
[inversion_clear H0; rewrite dec_sem_aref in H2 | inversion_clear D_EM; rewrite <- dec_sem_aref in DEC];
econstructor 2; eauto; constructor...
Qed.

Lemma eval_sem_aref : forall t v, CallByName_Eval.eval t v <-> CallByName_RefEval_auto.RS.eval t v.
Proof with eauto.
split; intro H; inversion_clear H; econstructor; [ constructor; inversion H0; rewrite <- dec_sem_aref
| rewrite <- iter_sem_aref | constructor; inversion D_EM; rewrite dec_sem_aref | rewrite iter_sem_aref ]...
Qed.

Module CallByName_RefEval <: RED_REF_SEM CallByName.

Definition term := CallByName.term.
Definition value := CallByName.value.
Definition redex := CallByName.redex.
Definition context := CallByName.context.
Definition elem_context := CallByName.elem_context.
Definition var := CallByName.var.
Definition lam := CallByName.lam.
Definition appl := CallByName.appl.
Definition v_var := CallByName.v_var.
Definition v_lam := CallByName.v_lam.
Definition beta := CallByName.beta.
Definition empty := CallByName.empty.
Definition ap_r := CallByName.ap_r.
Definition value_to_term : value -> term := CallByName.value_to_term.
Definition redex_to_term : redex -> term := CallByName.redex_to_term.
Coercion value_to_term : value >-> term.
Coercion redex_to_term : redex >-> term.

Definition contract := CallByName.contract.
Definition plug := CallByName.plug.
Definition compose := CallByName.compose.
Definition atom_plug := CallByName.atom_plug.

Definition decomp := CallByName.decomp.
Definition d_val := CallByName.d_val.
Definition d_red := CallByName.d_red.

Definition interm_dec := CallByName.interm_dec.
Definition in_red := CallByName.in_red.
Definition in_val := CallByName.in_val.
Definition in_term := CallByName.in_term.
Definition decomp_to_term := CallByName.decomp_to_term.

(** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
Definition dec_term (t : term) : interm_dec :=
match t with
  | var vname => in_val (v_var vname)
  | lam vname s => in_val (v_lam vname s)
  | appl t s => in_term t (ap_r s)
end.

Definition dec_context (ec : elem_context) (v : value) : interm_dec :=
match ec with
  | ap_r t => in_red (beta v t)
end.

Lemma dec_term_value : forall (v:value), dec_term (v:term) = in_val v.
Proof.
intro v; case v; simpl; auto.
Qed.
Hint Resolve dec_term_value.

(** A decomposition function specified in terms of the atomic functions above *)
  Inductive dec : term -> context -> decomp -> Prop :=
  | d_dec  : forall (t : term) (c : context) (r : redex),
                 dec_term t = in_red r -> dec t c (d_red r c)
  | d_v    : forall (t : term) (c : context) (v : value) (d : decomp),
                 dec_term t = in_val v -> decctx v c d -> dec t c d
  | d_term : forall (t t0 : term) (c : context) (ec : elem_context) (d : decomp),
                 dec_term t = in_term t0 ec -> dec t0 (ec :: c) d -> dec t c d
  with decctx : value -> context -> decomp -> Prop :=
  | dc_end  : forall (v : value), decctx v empty (d_val v)
  | dc_dec  : forall (v : value) (ec : elem_context) (c : context) (r : redex),
                dec_context ec v = in_red r -> decctx v (ec :: c) (d_red r c)
  | dc_val  : forall (v v0 : value) (ec : elem_context) (c : context) (d : decomp),
                dec_context ec v = in_val v0 -> decctx v0 c d -> decctx v (ec :: c) d
  | dc_term : forall (v : value) (ec ec0 : elem_context) (c : context) (t : term) (d : decomp),
                dec_context ec v = in_term t ec0 -> dec t (ec0 :: c) d -> decctx v (ec :: c) d.

Scheme dec_Ind := Induction for dec Sort Prop
with decctx_Ind := Induction for decctx Sort Prop.

(** dec is left inverse of plug *)
Lemma dec_term_correct : forall t, match dec_term t with
  | in_red r => redex_to_term r = t
  | in_val v => value_to_term v = t
  | in_term t0 ec0 => CallByName.atom_plug t0 ec0 = t
end.
Proof.
induction t; simpl; auto.
Qed.
Lemma dec_context_correct : forall ec v, match dec_context ec v with
  | in_red r => redex_to_term r = atom_plug (value_to_term v) ec
  | in_val v0 => value_to_term v0 = atom_plug (value_to_term v) ec
  | in_term t ec0 => atom_plug t ec0 = atom_plug (value_to_term v) ec
end.
Proof.
destruct ec; simpl; auto.
Qed.

  Lemma dec_red_ref : forall t c d, CallByName_Eval.dec t c d <-> dec t c d.
  Proof with eauto.
    intros; split; intro.
    induction H using CallByName_Eval.dec_Ind with
    (P := fun t c d (H : CallByName_Eval.dec t c d) => dec t c d)
    (P0:= fun v c d (H : CallByName_Eval.decctx v c d) => decctx c v d);
    [ econstructor 2 | econstructor 3 | constructor | constructor ]; simpl...
    induction H using dec_Ind with
    (P := fun t c d (H : dec t c d) => CallByName_Eval.dec t c d)
    (P0:= fun v c d (H : decctx v c d) => CallByName_Eval.decctx c v d);
    try (destruct t; inversion e; subst;
      try (change (CallByName_Eval.dec (value_to_term (v_var v0)) c d));
      try (change (CallByName_Eval.dec (value_to_term (v_lam v0 t)) c d));
    constructor); auto; try constructor;
    destruct c; destruct ec; inversion e; subst; constructor...
  Qed.

Module RS <: RED_SEM CallByName with Definition dec := dec.

    Definition dec := dec.

    Inductive decempty : term -> decomp -> Prop :=
    | d_intro : forall (t : term) (d : decomp), dec t empty d -> decempty t d.

    Inductive iter : decomp -> value -> Prop :=
    | i_val : forall (v : value), iter (d_val v) v
    | i_red : forall (r : redex) (t : term) (c : context) (d : decomp) (v : value),
                contract r = Some t -> decempty (plug t c) d -> iter d v -> iter (d_red r c) v.

    Inductive eval : term -> value -> Prop :=
    | e_intro : forall (t : term) (d : decomp) (v : value), decempty t d -> iter d v -> eval t v.

    Lemma dec_redex_self : forall (r : redex) (c : context), dec (redex_to_term r) c (d_red r c).
    Proof.
      intros; rewrite <- dec_red_ref; apply CallByName_Eval.dec_redex_self.
    Qed.

    (** dec is left inverse of plug *)
    Lemma dec_correct : forall t c d, dec t c d -> decomp_to_term d = plug t c.
    Proof.
      intros; apply CallByName_Eval.dec_correct; rewrite dec_red_ref; auto.
    Qed.

    Lemma dec_plug : forall c c0 t d, dec (plug t c) c0 d -> dec t (compose c c0) d.
    Proof.
      intros; rewrite <- dec_red_ref; apply CallByName_Eval.dec_plug; rewrite dec_red_ref; auto.
    Qed.

    Lemma dec_plug_rev : forall c c0 t d, dec t (compose c c0) d -> dec (plug t c) c0 d.
    Proof.
      intros; rewrite <- dec_red_ref; apply CallByName_Eval.dec_plug_rev; rewrite dec_red_ref; auto.
    Qed.

    Definition decompose := CallByName.decompose.

End RS.

  Lemma iter_red_ref : forall d v, CallByName_Eval.iter d v <-> RS.iter d v.
  Proof.
    intros; split; intro; induction H; try constructor;
    constructor 2 with t d; auto; constructor; inversion_clear H0;
    [rewrite <- dec_red_ref | rewrite dec_red_ref]; auto.
  Qed.

  Lemma eval_red_ref : forall t v, CallByName_Eval.eval t v <-> RS.eval t v.
  Proof.
    intros; split; intro; inversion_clear H; constructor 1 with d.
    constructor; inversion_clear H0; rewrite <- dec_red_ref; auto.
    rewrite <- iter_red_ref; auto.
    constructor; inversion_clear H0; rewrite dec_red_ref; auto.
    rewrite iter_red_ref; auto.
  Qed.

  Lemma dec_val_self : forall v c d, dec (value_to_term v) c d <-> decctx v c d.
  Proof.
    split; intro.
    destruct v; inversion H; inversion H0; subst; auto.
    assert (hh := dec_term_value v); econstructor; eauto.
  Qed.

End CallByName_RefEval.

Module CallByName_PEEval <: PE_REF_SEM CallByName.

Module Red_Sem := CallByName_RefEval.

  Lemma dec_context_not_val : forall v v0 ec, ~(Red_Sem.dec_context ec v = Red_Sem.in_val v0).
  Proof.
    destruct ec; intros; discriminate.
  Qed.
  Hint Resolve dec_context_not_val.
  Definition dec_term_value := Red_Sem.dec_term_value.

End CallByName_PEEval.

Module CBN_PEM := ProperPEMachine CallByName CallByName_PEEval.

Module KrivineMachine : ABSTRACT_MACHINE.

Definition term := CallByName.term.
Definition value := CallByName.value.
Definition redex := CallByName.redex.
Definition context := CallByName.context.
Definition var := CallByName.var.
Definition lam := CallByName.lam.
Definition appl := CallByName.appl.
Definition v_var := CallByName.v_var.
Definition v_lam := CallByName.v_lam.
Definition beta := CallByName.beta.
Definition empty := CallByName.empty.
Definition ap_r := CallByName.ap_r.
Definition value_to_term : value -> term := CallByName.value_to_term.
Definition redex_to_term : redex -> term := CallByName.redex_to_term.
Coercion value_to_term : value >-> term.
Coercion redex_to_term : redex >-> term.

Definition contract := CallByName.contract.
Definition plug := CallByName.plug.
Definition compose := CallByName.compose.

Definition decomp := CallByName.decomp.
Definition d_val := CallByName.d_val.
Definition d_red := CallByName.d_red.

Definition configuration := CBN_PEM.configuration.
Definition c_init := CBN_PEM.c_init.
Definition c_eval := CBN_PEM.c_eval.
Definition c_final := CBN_PEM.c_final.

Inductive transition' : configuration -> configuration -> Prop :=
| t_init : forall t:term, transition' (c_init t) (c_eval t empty)
| t_mt   : forall v:value, transition' (c_eval (v:term) empty) (c_final v)
| t_app  : forall (t s:term) (c:context),
             transition' (c_eval (appl t s) c) (c_eval t (ap_r s :: c))
| t_val  : forall (v:value) (t0 t:term) (c:context),
             contract (beta v t0) = Some t -> transition' (c_eval (v:term) (ap_r t0 :: c)) (c_eval t c).

Definition transition := transition'.
Inductive trans_close : configuration -> configuration -> Prop :=
| one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
| multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

Inductive eval : term -> value -> Prop :=
| e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

Lemma trPE_K : forall w w' : configuration, CBN_PEM.transition w w' -> transition w w'.
Proof.
intros c c0 H; inversion H; subst; try (destruct t; discriminate).
constructor.
destruct t; inversion DT; subst.
change (transition (c_eval (value_to_term (v_var v0)) empty) (c_final (v_var v0))); constructor.
change (transition (c_eval (value_to_term (v_lam v0 t)) empty) (c_final (v_lam v0 t))); constructor.
destruct t; inversion DT; subst; destruct ec; inversion DC; subst; try discriminate.
change (transition (c_eval (value_to_term (v_lam v0 t)) (ap_r t1 :: c1)) (c_eval t0 c1)); constructor; auto.
destruct ec; discriminate.
induction t; simpl in DT; inversion DT; subst; simpl; constructor.
Qed.
Hint Resolve trPE_K.

Lemma tcPE_K : forall w w' : configuration, CBN_PEM.AM.trans_close w w' -> trans_close w w'.
Proof with eauto.
intros w w' H; induction H; subst; [ constructor 1 | econstructor 2]...
Qed.

Lemma evalPE_K : forall t v, CBN_PEM.AM.eval t v -> eval t v.
Proof.
intros t v H; inversion H; constructor; apply tcPE_K; auto.
Qed.
Hint Resolve evalPE_K.

Lemma trK_PE : forall w w' : configuration, transition w w' -> CBN_PEM.AM.transition w w'.
Proof with eauto.
intros c c0 H; inversion H; subst; try (constructor; simpl; auto; fail).
econstructor; eauto; simpl...
Qed.
Hint Resolve trK_PE.

Lemma tcK_PE : forall w w' : configuration, trans_close w w' -> CBN_PEM.AM.trans_close w w'.
Proof with eauto.
induction 1; [ constructor 1 | econstructor 2]...
Qed.

Lemma evalK_PE : forall t v, eval t v -> CBN_PEM.AM.eval t v.
Proof.
intros t v H; inversion H; constructor; apply tcK_PE; auto.
Qed.
Hint Resolve evalK_PE.

Theorem KrivineMachineCorrect : forall t v, CallByName_Eval.eval t v <-> eval t v.
Proof with auto.
intros; rewrite CallByName_RefEval.eval_red_ref; rewrite CBN_PEM.push_enter_correct; split...
Qed.

End KrivineMachine.


Require Import SetoidClass.
Require Import Views.BasicSetoids.
Require Import Views.Setof.
Require Import Views.Tactics.
Require Import Views.EquivalenceClasses.
Require Import Views.Inhabited.
Require Import Views.Structures.

Section Reification.
  Context {A} {B} `{A_Setoid : Setoid A} `{B_Setoid : Setoid B}.
  Variable reification : A -> Setof B.
  Context (reification_morphism : Proper (equiv ==> equiv) reification).
  Existing Instance reification_morphism.

  Section Option.
    Program Definition option_reification (c : option A) : Setof B :=
      match c with
      | None => emptyset
      | Some a => reification a
      end.
    Instance option_reification_morphism :
            Proper (equiv ==> equiv) option_reification.
     repeat intro;
     repeat optiondestruct; firstorder.
    Qed.
    Lemma option_reification_spec : forall a b,
       reification a b <-> option_reification (Some a) b.
     firstorder.
    Qed.
  End Option.

  Section AddUnit.
    Program Definition united_reification (c : @united A) : Setof B :=
      match c with
      | un_unit => emptyset
      | un_some a => reification a
      end.

    Existing Instance united_setoid.
    Instance united_reification_morphism :
            Proper (equiv ==> equiv) united_reification.
     repeat intro;
     repeat match goal with k : united |- _ => destruct k end;
     intuition; simpl;
     match goal with HH : _ == _ |- _ => inversion HH end;
     rewr auto.
    Qed.
    Lemma united_reification_spec : forall a b,
      reification a b <-> united_reification (un_some a) b.
     firstorder.
    Qed.
  End AddUnit.

  Section EC.

    Program Definition EC_reification (c : EC A) : Setof B :=
      {| elem := fun b => exists a, c a /\ reification a b |}.
    Obligation 1.
     repeat intro.
     firstorder;
      eexists; intuition eauto; rewr auto.
    Qed.
    Instance EC_reification_morphism :
            Proper (equiv ==> equiv) EC_reification.
     repeat intro; simpl;
     firstorder.
    Qed.
    Lemma EC_reification_spec : forall a b, reification a b <-> EC_reification (make_EC a) b.
     simpl; intuition.
     eexists; intuition eauto.
     eexists; intuition reflexivity.
     repeat splitup; rewr auto.
    Qed.

  End EC.

End Reification.