(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
Require Export Max.
Require Export Zpower.
Require Export Zlogarithm.
Require Export QArith.
Require Export Qpower.
Open Scope Z_scope.
Open Scope Q_scope.
Require Extraction.
Coercion inject_Z : Z >-> Q.
Local Coercion Z_of_nat : nat >-> Z.
Ltac QpowerSimpl :=
(repeat rewrite inj_S;
unfold Z.succ;
repeat rewrite Qpower_plus; try discriminate;
simpl).
Ltac get_hd := match goal with |- ?H -> _ => H end.
Ltac get_gl := match goal with |- ?H => H end.
Ltac lhs H :=
match H with
| ?a <= _ => a
| ?a < _ => a
| ?a == _ => a
end.
Ltac rhs H :=
match H with
| _ <= ?a => a
| _ < ?a => a
| _ == ?a => a
end.
Ltac step_left t :=  let H := get_gl in let a := lhs H in setoid_replace a with t by (QpowerSimpl;ring).
Ltac step_right t :=  let H := get_gl in let a := rhs H in setoid_replace a with t by (QpowerSimpl;ring).
Ltac step_left_hd t :=  let H := get_hd in let a := lhs H in setoid_replace a with t by (QpowerSimpl;ring).
Ltac step_right_hd t := let H := get_hd in let a := rhs H in setoid_replace a with t by (QpowerSimpl;ring).
Ltac step t := let a := lhs t in step_left a; let b := rhs t in step_right b.
Ltac step_hd t := let a := lhs t in step_left_hd a; let b := rhs t in step_right_hd b.
Local Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.
(**** A quick & dirty implementation of constructive reals. ****)
(****      Based on Pr. Schwichtenberg lecture notes.        ****)
(****      Main objective: sqrt(2) as root of X^2 -2  in [1;2]   ****)
(* First, the Cauchy property. *)
Definition Is_Cauchy (f : nat -> Q) (mo : nat -> nat) :=
forall k m n,  (mo k <= m)%nat -> (mo k <= n)%nat ->
-(1#2)^k <= f m - f n <= (1#2)^k.
(* A real is given by a cauchy sequence, a modulus sequence *)
(* and a proof of the Cauchy property of these sequences. *)
Record R : Set := {
cauchy : nat -> Q;
modulus : nat -> nat;
is_cauchy : Is_Cauchy cauchy modulus }.
(* Recursive Extraction R. *)
(* A rational is injected into R via a constant cauchy sequence. *)
Definition inject_Q : Q -> R.
(* Extraction test. *)
(* Addition on R. *)
(* Only the informative parts are provided. The logical statement is skipped. *)
(* Lemma two_power_S : forall k, !2^(S k) = (2 *(!2^k))%Z. intros. rewrite <- two_power_nat_S; auto with zarith. Qed. *)
Definition Rplus : R -> R -> R.
(* The strict order is conserved when injecting Q in R. *)

Lemma Qlt_Rlt : forall a b, a<b -> Rlt (inject_Q a) (inject_Q b).