Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg

1 files changed, 514 insertions, 0 deletions

diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v
new file mode 100644
index 00000000..ae2cfd30
--- /dev/null
+++ b/theories/Numbers/Natural/BigN/Nbasic.v
@@ -0,0 +1,514 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
+(************************************************************************)
+
+(*i $Id: Nbasic.v 10964 2008-05-22 11:08:13Z letouzey $ i*)
+
+Require Import ZArith.
+Require Import BigNumPrelude.
+Require Import Max.
+Require Import DoubleType.
+Require Import DoubleBase.
+Require Import CyclicAxioms.
+Require Import DoubleCyclic.
+
+(* To compute the necessary height *)
+
+Fixpoint plength (p: positive) : positive :=
+  match p with 
+    xH => xH
+  | xO p1 => Psucc (plength p1)
+  | xI p1 => Psucc (plength p1)
+  end.
+
+Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
+assert (F: (forall p, 2 ^ (Zpos (Psucc p)) = 2 * 2 ^ Zpos p)%Z).
+intros p; replace (Zpos (Psucc p)) with (1 + Zpos p)%Z.
+rewrite Zpower_exp; auto with zarith.
+rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
+intros p; elim p; simpl plength; auto.
+intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
+assert (tmp: (forall p, 2 * p = p + p)%Z); 
+  try repeat rewrite tmp; auto with zarith.
+intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
+assert (tmp: (forall p, 2 * p = p + p)%Z); 
+  try repeat rewrite tmp; auto with zarith.
+rewrite Zpower_1_r; auto with zarith.
+Qed.
+
+Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Ppred p)))%Z.
+intros p; case (Psucc_pred p); intros H1.
+subst; simpl plength.
+rewrite Zpower_1_r; auto with zarith.
+pattern p at 1; rewrite <- H1.
+rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
+generalize (plength_correct (Ppred p)); auto with zarith.
+Qed.
+
+Definition Pdiv p q :=
+  match Zdiv (Zpos p) (Zpos q) with
+    Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with
+                 Z0 => q1
+               | _ => (Psucc q1)
+               end
+  |  _ => xH
+  end.
+
+Theorem Pdiv_le: forall p q,
+  Zpos p <= Zpos q * Zpos (Pdiv p q).
+intros p q.
+unfold Pdiv.
+assert (H1: Zpos q > 0); auto with zarith.
+assert (H1b: Zpos p >= 0); auto with zarith.
+generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b).
+generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Zdiv.
+  intros HH _; rewrite HH; rewrite Zmult_0_r; rewrite Zmult_1_r; simpl.
+case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith.
+intros q1 H2.
+replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q).
+  2: pattern (Zpos p) at 2; rewrite H2; auto with zarith.
+generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; 
+  case Zmod.
+  intros HH _; rewrite HH; auto with zarith.
+  intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism.
+  unfold Zsucc; rewrite Zmult_plus_distr_r; auto with zarith.
+  intros r1 _ (HH,_); case HH; auto.
+intros q1 HH; rewrite HH.
+unfold Zge; simpl Zcompare; intros HH1; case HH1; auto.
+Qed.
+
+Definition is_one p := match p with xH => true | _ => false end.
+
+Theorem is_one_one: forall p, is_one p = true -> p = xH.
+intros p; case p; auto; intros p1 H1; discriminate H1.
+Qed.
+
+Definition get_height digits p :=
+  let r := Pdiv p digits in
+   if is_one r then xH else Psucc (plength (Ppred r)).
+
+Theorem get_height_correct:
+  forall digits N,
+   Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)).
+intros digits N.
+unfold get_height.
+assert (H1 := Pdiv_le N digits).
+case_eq (is_one (Pdiv N digits)); intros H2.
+rewrite (is_one_one _ H2) in H1.
+rewrite Zmult_1_r in H1.
+change (2^(1-1))%Z with 1; rewrite Zmult_1_r; auto.
+clear H2.
+apply Zle_trans with (1 := H1).
+apply Zmult_le_compat_l; auto with zarith.
+rewrite Zpos_succ_morphism; unfold Zsucc.
+rewrite Zplus_comm; rewrite Zminus_plus.
+apply plength_pred_correct.
+Qed.
+
+Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n.
+ fix zn2z_word_comm 2.
+ intros w n; case n.
+  reflexivity.
+  intros n0;simpl.
+  case (zn2z_word_comm w n0).
+  reflexivity.
+Defined.
+
+Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) :=
+ match n return forall w:Type, zn2z w -> word w (S n) with 
+ | O => fun w x => x
+ | S m => 
+   let aux := extend m in
+   fun w x => WW W0 (aux w x)
+ end.
+
+Section ExtendMax.
+
+Open Scope nat_scope.
+
+Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat :=
+  match n return  (n + S m = S (n + m))%nat with
+  | 0 => refl_equal (S m)
+  | S n1 =>
+      let v := S (S n1 + m) in
+      eq_ind_r (fun n => S n = v) (refl_equal v) (plusnS n1 m)
+  end.
+
+Fixpoint plusn0 n : n + 0 = n :=
+  match n return (n + 0 = n) with
+  | 0 => refl_equal 0
+  | S n1 =>
+      let v := S n1 in
+      eq_ind_r (fun n : nat => S n = v) (refl_equal v) (plusn0 n1)
+  end.
+
+ Fixpoint diff (m n: nat) {struct m}: nat * nat :=
+   match m, n with
+     O, n => (O, n)
+   | m, O => (m, O)
+   | S m1, S n1 => diff m1 n1
+   end.
+
+Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n :=
+  match m return fst (diff m n) + n = max m n with
+  | 0 =>
+      match n return (n = max 0 n) with
+      | 0 => refl_equal _
+      | S n0 => refl_equal _
+      end
+  | S m1 =>
+      match n return (fst (diff (S m1) n) + n = max (S m1) n)
+      with
+      | 0 => plusn0 _
+      | S n1 =>
+          let v := fst (diff m1 n1) + n1 in
+          let v1 := fst (diff m1 n1) + S n1 in
+          eq_ind v (fun n => v1 = S n) 
+            (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _))
+            _ (diff_l _ _)
+      end
+  end.
+
+Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n :=
+  match m return (snd (diff m n) + m = max m n) with
+  | 0 =>
+      match n return (snd (diff 0 n) + 0 = max 0 n) with
+      | 0 => refl_equal _
+      | S _ => plusn0 _
+      end
+  | S m => 
+      match n return (snd (diff (S m) n) + S m = max (S m) n) with
+      | 0 => refl_equal (snd (diff (S m) 0) + S m)
+      | S n1 =>
+          let v := S (max m n1) in
+          eq_ind_r (fun n => n = v)
+            (eq_ind_r (fun n => S n = v)
+               (refl_equal v) (diff_r _ _)) (plusnS _ _)
+      end
+  end.
+
+ Variable w: Type.
+
+ Definition castm (m n: nat) (H: m = n) (x: word w (S m)):
+     (word w (S n)) :=
+ match H in (_ = y) return (word w (S y)) with
+ | refl_equal => x
+ end.
+
+Variable m: nat.
+Variable v: (word w (S m)).
+
+Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) :=
+  match n  return (word w (S (n + m))) with
+  | O => v
+  | S n1 => WW W0 (extend_tr n1)
+  end.
+
+End ExtendMax.
+
+Implicit Arguments extend_tr[w m].
+Implicit Arguments castm[w m n].
+
+
+
+Section Reduce.
+
+ Variable w : Type.
+ Variable nT : Type.
+ Variable N0 : nT.
+ Variable eq0 : w -> bool.
+ Variable reduce_n : w -> nT.
+ Variable zn2z_to_Nt : zn2z w -> nT.
+
+ Definition reduce_n1 (x:zn2z w) :=
+  match x with
+  | W0 => N0
+  | WW xh xl =>
+    if eq0 xh then reduce_n xl
+    else zn2z_to_Nt x
+  end.
+
+End Reduce.
+
+Section ReduceRec.
+
+ Variable w : Type.
+ Variable nT : Type.
+ Variable N0 : nT.
+ Variable reduce_1n : zn2z w -> nT.
+ Variable c : forall n, word w (S n) -> nT.
+
+ Fixpoint reduce_n (n:nat) : word w (S n) -> nT :=
+  match n return word w (S n) -> nT with
+  | O => reduce_1n
+  | S m => fun x =>
+    match x with
+    | W0 => N0
+    | WW xh xl =>
+      match xh with
+      | W0 => @reduce_n m xl
+      | _ => @c (S m) x 
+      end
+    end	
+  end.
+
+End ReduceRec.
+
+Definition opp_compare cmp :=
+  match cmp with
+  | Lt => Gt
+  | Eq => Eq
+  | Gt => Lt
+  end.
+
+Section CompareRec.
+
+ Variable wm w : Type.
+ Variable w_0 : w.
+ Variable compare : w -> w -> comparison.
+ Variable compare0_m : wm -> comparison.
+ Variable compare_m : wm -> w -> comparison.
+
+ Fixpoint compare0_mn (n:nat) : word wm n -> comparison :=
+  match n return word wm n -> comparison with 
+  | O => compare0_m 
+  | S m => fun x =>
+    match x with
+    | W0 => Eq
+    | WW xh xl => 
+      match compare0_mn m xh with
+      | Eq => compare0_mn m xl 
+      | r  => Lt
+      end
+    end
+  end.
+
+ Variable wm_base: positive.
+ Variable wm_to_Z: wm -> Z.
+ Variable w_to_Z: w -> Z.
+ Variable w_to_Z_0: w_to_Z w_0 = 0.
+ Variable spec_compare0_m: forall x,
+    match compare0_m x with
+      Eq => w_to_Z w_0 = wm_to_Z x
+    | Lt => w_to_Z w_0 < wm_to_Z x 
+    | Gt => w_to_Z w_0 > wm_to_Z x
+    end.
+ Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base.
+
+ Let double_to_Z := double_to_Z wm_base wm_to_Z.
+ Let double_wB := double_wB wm_base.
+
+ Lemma base_xO: forall n, base (xO n) = (base n)^2.
+ Proof.
+ intros n1; unfold base.
+ rewrite (Zpos_xO n1); rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith.
+ Qed.
+
+ Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n :=
+   (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos).
+
+
+ Lemma spec_compare0_mn: forall n x,
+    match compare0_mn n x with
+      Eq => 0 = double_to_Z n x
+    | Lt => 0 < double_to_Z n x
+    | Gt => 0 > double_to_Z n x
+    end.
+  Proof.
+  intros n; elim n; clear n; auto.
+  intros x; generalize (spec_compare0_m x); rewrite w_to_Z_0; auto.
+  intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto.
+  intros xh xl.
+  generalize (Hrec xh); case compare0_mn; auto.
+  generalize (Hrec xl); case compare0_mn; auto.
+  simpl double_to_Z; intros H1 H2; rewrite H1; rewrite <- H2; auto.
+  simpl double_to_Z; intros H1 H2; rewrite <- H2; auto.
+  case (double_to_Z_pos n xl); auto with zarith.
+  intros H1; simpl double_to_Z.
+  set (u := DoubleBase.double_wB wm_base n).
+  case (double_to_Z_pos n xl); intros H2 H3.
+  assert (0 < u); auto with zarith.
+  unfold u, DoubleBase.double_wB, base; auto with zarith.
+  change 0 with (0 + 0); apply Zplus_lt_le_compat; auto with zarith.
+  apply Zmult_lt_0_compat; auto with zarith.
+  case (double_to_Z_pos n xh); auto with zarith.
+  Qed.
+
+ Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
+  match n return word wm n -> w -> comparison with 
+  | O => compare_m 
+  | S m => fun x y => 
+    match x with
+    | W0 => compare w_0 y
+    | WW xh xl => 
+      match compare0_mn m xh with
+      | Eq => compare_mn_1 m xl y 
+      | r  => Gt
+      end
+    end
+  end.
+
+ Variable spec_compare: forall x y,
+   match compare x y with
+     Eq => w_to_Z x = w_to_Z y
+   | Lt => w_to_Z x < w_to_Z y
+   | Gt => w_to_Z x > w_to_Z y
+   end.
+ Variable spec_compare_m: forall x y,
+   match compare_m x y with
+     Eq => wm_to_Z x = w_to_Z y
+   | Lt => wm_to_Z x < w_to_Z y
+   | Gt => wm_to_Z x > w_to_Z y
+   end.
+ Variable wm_base_lt: forall x, 
+   0 <= w_to_Z x < base (wm_base).
+
+ Let double_wB_lt: forall n x,
+   0 <= w_to_Z x < (double_wB n).
+ Proof.
+ intros n x; elim n; simpl; auto; clear n.
+ intros n (H0, H); split; auto.
+ apply Zlt_le_trans with (1:= H).
+ unfold double_wB, DoubleBase.double_wB; simpl.
+ rewrite base_xO.
+ set (u := base (double_digits wm_base n)).
+ assert (0 < u).
+  unfold u, base; auto with zarith.
+ replace (u^2) with (u * u); simpl; auto with zarith.
+ apply Zle_trans with (1 * u); auto with zarith.
+ unfold Zpower_pos; simpl; ring.
+ Qed.
+
+ 
+ Lemma spec_compare_mn_1: forall n x y,
+   match compare_mn_1 n x y with
+     Eq => double_to_Z n x = w_to_Z y
+   | Lt => double_to_Z n x < w_to_Z y
+   | Gt => double_to_Z n x > w_to_Z y
+   end.
+ Proof.
+ intros n; elim n; simpl; auto; clear n.
+ intros n Hrec x; case x; clear x; auto.
+ intros y; generalize (spec_compare w_0 y); rewrite w_to_Z_0; case compare; auto.
+ intros xh xl y; simpl; generalize (spec_compare0_mn n xh); case compare0_mn; intros H1b.
+ rewrite <- H1b; rewrite Zmult_0_l; rewrite Zplus_0_l; auto.
+ apply Hrec.
+ apply Zlt_gt.
+ case (double_wB_lt n y); intros _ H0.
+ apply Zlt_le_trans with (1:= H0).
+ fold double_wB.
+ case (double_to_Z_pos n xl); intros H1 H2.
+ apply Zle_trans with (double_to_Z n xh * double_wB n); auto with zarith.
+ apply Zle_trans with (1 * double_wB n); auto with zarith.
+ case (double_to_Z_pos n xh); auto with zarith.
+ Qed.
+
+End CompareRec.
+
+
+Section AddS.
+
+ Variable w wm : Type.
+ Variable incr : wm -> carry wm.
+ Variable addr : w -> wm -> carry wm.
+ Variable injr : w -> zn2z wm.
+
+ Variable w_0 u: w.
+ Fixpoint injs  (n:nat): word w (S n) :=
+  match n return (word w (S n)) with
+    O => WW w_0 u
+  | S n1 => (WW W0 (injs n1))
+  end.
+
+ Definition adds x y :=
+   match y with
+    W0 => C0 (injr x)
+  | WW hy ly => match addr x ly with
+                  C0 z => C0 (WW hy z)
+                | C1 z => match incr hy with
+                            C0 z1 => C0 (WW z1 z)
+                          | C1 z1 => C1 (WW z1 z)
+                          end  
+                 end
+   end.
+
+End AddS.
+
+
+ Lemma spec_opp: forall u x y,
+  match u with
+  | Eq => y = x
+  | Lt => y < x
+  | Gt => y > x
+  end ->
+  match opp_compare u with
+  | Eq => x = y
+  | Lt => x < y
+  | Gt => x > y
+  end.
+ Proof.
+ intros u x y; case u; simpl; auto with zarith.
+ Qed.
+
+ Fixpoint length_pos x :=
+  match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end.
+ 
+ Theorem length_pos_lt: forall x y,
+   (length_pos x < length_pos y)%nat -> Zpos x < Zpos y.
+ Proof.
+ intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac];
+   intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; 
+   try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1));
+   try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1));
+   try (inversion H; fail);
+   try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith);
+   assert (0 < Zpos y1); auto with zarith; red; auto.
+ Qed.
+
+ Theorem cancel_app: forall A B (f g: A -> B) x, f = g -> f x = g x.
+ Proof.
+ intros A B f g x H; rewrite H; auto.
+ Qed.
+
+
+ Section SimplOp.
+
+ Variable w: Type.
+
+ Theorem digits_zop: forall w (x: znz_op w),
+  znz_digits (mk_zn2z_op x) = xO (znz_digits x).
+ intros ww x; auto.
+ Qed.
+
+ Theorem digits_kzop: forall w (x: znz_op w),
+  znz_digits (mk_zn2z_op_karatsuba x) = xO (znz_digits x).
+ intros ww x; auto.
+ Qed.
+
+ Theorem make_zop: forall w (x: znz_op w),
+  znz_to_Z (mk_zn2z_op x) = 
+    fun z => match z with 
+                W0 => 0
+             | WW xh xl => znz_to_Z x xh * base (znz_digits x) 
+                                + znz_to_Z x xl
+             end.
+ intros ww x; auto.
+ Qed.
+
+ Theorem make_kzop: forall w (x: znz_op w),
+  znz_to_Z (mk_zn2z_op_karatsuba x) = 
+    fun z => match z with 
+                W0 => 0
+             | WW xh xl => znz_to_Z x xh * base (znz_digits x) 
+                                + znz_to_Z x xl
+             end.
+ intros ww x; auto.
+ Qed.
+
+ End SimplOp.