diff options
Diffstat (limited to 'theories/Ints')
27 files changed, 0 insertions, 24855 deletions
diff --git a/theories/Ints/Basic_type.v b/theories/Ints/Basic_type.v deleted file mode 100644 index 2116aaddd3..0000000000 --- a/theories/Ints/Basic_type.v +++ /dev/null @@ -1,68 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Open Local Scope Z_scope. - -Section Carry. - - Variable A : Set. - - Inductive carry : Set := - | C0 : A -> carry - | C1 : A -> carry. - -End Carry. - -Section Zn2Z. - - Variable znz : Set. - - Inductive zn2z : Set := - | W0 : zn2z - | WW : znz -> znz -> zn2z. - - Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := - match x with - | W0 => 0 - | WW xh xl => w_to_Z xh * wB + w_to_Z xl - end. - - Definition base digits := Zpower 2 (Zpos digits). - - Definition interp_carry sign B (interp:znz -> Z) c := - match c with - | C0 x => interp x - | C1 x => sign*B + interp x - end. - -End Zn2Z. - -Implicit Arguments W0 [znz]. - -Fixpoint word_tr (w:Set) (n:nat) {struct n} : Set := - match n with - | O => w - | S n => word_tr (zn2z w) n - end. - -Fixpoint word (w:Set) (n:nat) {struct n} : Set := - match n with - | O => w - | S n => zn2z (word w n) - end. - diff --git a/theories/Ints/BigN.v b/theories/Ints/BigN.v deleted file mode 100644 index b64a853fd6..0000000000 --- a/theories/Ints/BigN.v +++ /dev/null @@ -1,139 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(** * Natural numbers in base 2^31 *) - -(** -Author: Arnaud Spiwack -*) - -Require Export Int31. -Require Import NMake. -Require Import ZnZ. - -Open Scope int31_scope. - -Definition int31_op : znz_op int31. - split. - - (* Conversion functions with Z *) - exact (31%positive). (* number of digits *) - exact (31). (* number of digits *) - exact (phi). (* conversion to Z *) - exact (positive_to_int31). (* positive -> N*int31 : p => N,i where p = N*2^31+phi i *) - exact head031. (* number of head 0 *) - exact tail031. (* number of tail 0 *) - - (* Basic constructors *) - exact 0. (* 0 *) - exact 1. (* 1 *) - exact Tn. (* 2^31 - 1 *) - (* A function which given two int31 i and j, returns a double word - which is worth i*2^31+j *) - exact (fun i j => match (match i ?= 0 with | Eq => j ?= 0 | not0 => not0 end) with | Eq => W0 | _ => WW i j end). - (* two special cases where i and j are respectively taken equal to 0 *) - exact (fun i => match i ?= 0 with | Eq => W0 | _ => WW i 0 end). - exact (fun j => match j ?= 0 with | Eq => W0 | _ => WW 0 j end). - - (* Comparison *) - exact compare31. - exact (fun i => match i ?= 0 with | Eq => true | _ => false end). - - (* Basic arithmetic operations *) - (* opposite functions *) - exact (fun i => 0 -c i). - exact (fun i => 0 - i). - exact (fun i => 0-i-1). (* the carry is always -1*) - (* successor and addition functions *) - exact (fun i => i +c 1). - exact add31c. - exact add31carryc. - exact (fun i => i + 1). - exact add31. - exact (fun i j => i + j + 1). - (* predecessor and subtraction functions *) - exact (fun i => i -c 1). - exact sub31c. - exact sub31carryc. - exact (fun i => i - 1). - exact sub31. - exact (fun i j => i - j - 1). - (* multiplication functions *) - exact mul31c. - exact mul31. - exact (fun x => x *c x). - - (* special (euclidian) division operations *) - exact div3121. - exact div31. (* this is supposed to be the special case of division a/b where a > b *) - exact div31. - (* euclidian division remainder *) - (* again special case for a > b *) - exact (fun i j => let (_,r) := i/j in r). - exact (fun i j => let (_,r) := i/j in r). - (* gcd functions *) - exact gcd31. (*gcd_gt*) - exact gcd31. (*gcd*) - - (* shift operations *) - exact addmuldiv31. (*add_mul_div *) -(*modulo 2^p *) - exact (fun p i => - match compare31 p 32 with - | Lt => addmuldiv31 p 0 (addmuldiv31 (31-p) i 0) - | _ => i - end). - - (* is i even ? *) - exact (fun i => let (_,r) := i/2 in - match r ?= 0 with - | Eq => true - | _ => false - end). - - (* square root operations *) - exact sqrt312. (* sqrt2 *) - exact sqrt31. (* sqr *) -Defined. - -Definition int31_spec : znz_spec int31_op. -Admitted. - - - -Module Int31_words <: W0Type. - Definition w := int31. - Definition w_op := int31_op. - Definition w_spec := int31_spec. -End Int31_words. - -Module BigN := NMake.Make Int31_words. - -Definition bigN := BigN.t. - -Delimit Scope bigN_scope with bigN. -Bind Scope bigN_scope with bigN. -Bind Scope bigN_scope with BigN.t. -Bind Scope bigN_scope with BigN.t_. - -Notation " i + j " := (BigN.add i j) : bigN_scope. -Notation " i - j " := (BigN.sub i j) : bigN_scope. -Notation " i * j " := (BigN.mul i j) : bigN_scope. -Notation " i / j " := (BigN.div i j) : bigN_scope. -Notation " i ?= j " := (BigN.compare i j) : bigN_scope. - - Theorem succ_pred: forall q, - (0 < BigN.to_Z q -> - BigN.to_Z (BigN.succ (BigN.pred q)) = BigN.to_Z q)%Z. - intros q Hq. - rewrite BigN.spec_succ. - rewrite BigN.spec_pred; auto. - generalize Hq; set (a := BigN.to_Z q). - ring_simplify (a - 1 + 1)%Z; auto. - Qed. - diff --git a/theories/Ints/BigZ.v b/theories/Ints/BigZ.v deleted file mode 100644 index 8c7c1f809c..0000000000 --- a/theories/Ints/BigZ.v +++ /dev/null @@ -1,48 +0,0 @@ -Require Export BigN. -Require Import ZMake. - - -Module BigZ := Make BigN. - - -Definition bigZ := BigZ.t. - -Delimit Scope bigZ_scope with bigZ. -Bind Scope bigZ_scope with bigZ. -Bind Scope bigZ_scope with BigZ.t. -Bind Scope bigZ_scope with BigZ.t_. - -Notation " i + j " := (BigZ.add i j) : bigZ_scope. -Notation " i - j " := (BigZ.sub i j) : bigZ_scope. -Notation " i * j " := (BigZ.mul i j) : bigZ_scope. -Notation " i / j " := (BigZ.div i j) : bigZ_scope. -Notation " i ?= j " := (BigZ.compare i j) : bigZ_scope. - - - Theorem spec_to_Z: - forall n, BigN.to_Z (BigZ.to_N n) = - (Zsgn (BigZ.to_Z n) * BigZ.to_Z n)%Z. - intros n; case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. - intros p1 H1; case H1; auto. - intros p1 H1; case H1; auto. - Qed. - - Theorem spec_to_N n: - (BigZ.to_Z n = - Zsgn (BigZ.to_Z n) * (BigN.to_Z (BigZ.to_N n)))%Z. - intros n; case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. - intros p1 H1; case H1; auto. - intros p1 H1; case H1; auto. - Qed. - - Theorem spec_to_Z_pos: - forall n, (0 <= BigZ.to_Z n -> - BigN.to_Z (BigZ.to_N n) = BigZ.to_Z n)%Z. - intros n; case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. - intros p1 _ H1; case H1; auto. - intros p1 H1; case H1; auto. - Qed. - diff --git a/theories/Ints/Int31.v b/theories/Ints/Int31.v deleted file mode 100644 index d7e80d4a28..0000000000 --- a/theories/Ints/Int31.v +++ /dev/null @@ -1,408 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*i $ $ i*) - -(* Require Import Notations.*) -Require Export ZArith. -Require Export Basic_type. - -Unset Boxed Definitions. - -Inductive digits : Type := |D0 |D1. - -Inductive int31 : Type := -| I31 : digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits -> int31 -. - -(* spiwack: Registration of the type of integers, so that the matchs in - the functions below perform dynamic decompilation (otherwise some segfault - occur when they are applied to one non-closed term and one closed term *) -Register digits as int31 bits in "coq_int31" by True. -Register int31 as int31 type in "coq_int31" by True. - -Delimit Scope int31_scope with int31. -Bind Scope int31_scope with int31. -Open Scope int31_scope. - - -Definition size := 31%nat. -Definition sizeN := 31%N. - -Definition On := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0. -Definition In := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D1. -Definition Tn := I31 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1. -Definition Twon := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D1 D0. -Definition T31 := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D1 D1 D1 D1 D1. - -Definition sneakr b i := - match i with - | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => - I31 b b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 - end -. - -Definition sneakl b i := - match i with - | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => - I31 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 b - end -. - -Definition firstl i := - match i with - | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => b1 - end -. - -Definition firstr i := - match i with - | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => b31 - end -. - -Definition iszero i := - match i with - | I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 => true - | _ => false - end -. - - -(* abstract definition : smallest b > 0 s.t. phi_inv b = 0 (see below) *) -Definition base := Eval compute in (fix base_aux (counter:nat) := - match counter with - | 0%nat => 1%Z - | S n => Zdouble (base_aux n) - end) size -. - -Definition shiftl := sneakl D0. -Definition shiftr := sneakr D0. - -Definition twice := sneakl D0. -Definition twice_plus_one := sneakl D1. - - - -(*recursors*) - -Fixpoint recl_aux (iter:nat) (A:Type) (case0:A) (caserec:digits->int31->A->A) - (i:int31) {struct iter} : A := - match iter with - | 0%nat => case0 - | S next => - if iszero i then - case0 - else - let si := shiftl i in - caserec (firstl i) si (recl_aux next A case0 caserec si) - end -. -Fixpoint recr_aux (iter:nat) (A:Type) (case0:A) (caserec:digits->int31->A->A) - (i:int31) {struct iter} : A := - match iter with - | 0%nat => case0 - | S next => - if iszero i then - case0 - else - let si := shiftr i in - caserec (firstr i) si (recr_aux next A case0 caserec si) - end -. - -Definition recl := recl_aux size. -Definition recr := recr_aux size. - - -Definition phi := - recr Z (0%Z) (fun b _ rec => (match b with | D0 => Zdouble | D1 => Zdouble_plus_one end) rec) -. - - -(* abstract definition : phi_inv (2n) = 2*phi_inv n /\ - phi_inv 2n+1 = 2*(phi_inv n) + 1 *) -Definition phi_inv := -(* simple incrementation *) -let incr := - recr int31 In (fun b si rec => match b with | D0 => sneakl D1 si | D1 => sneakl D0 rec end) -in -fun n => - match n with - | Z0 => On - | Zpos p =>(fix phi_inv_positive (p:positive) := - match p with - | xI q => twice_plus_one (phi_inv_positive q) - | xO q => twice (phi_inv_positive q) - | xH => In - end) p - | Zneg p =>incr ((fix complement_negative (p:positive) := - match p with - | xI q => twice (complement_negative q) - | xO q => twice_plus_one (complement_negative q) - | xH => twice Tn - end) p) - end -. - -(* like phi_inv but returns a double word (zn2z int31) *) -Definition phi_inv2 n := - match n with - | Z0 => W0 - | _ => WW (phi_inv (n/base)%Z) (phi_inv n) - end -. - -(* like phi but takes a double word (two args) *) -Definition phi2 nh nl := - ((phi nh)*base+(phi nl))%Z. - -(* addition modulo 2^31 *) -Definition add31 (n m : int31) := phi_inv ((phi n)+(phi m)). -Notation "n + m" := (add31 n m) : int31_scope. - -(* addition with carry (the result is thus exact) *) -Definition add31c (n m : int31) := - let npm := n+m in - match (phi npm ?= (phi n)+(phi m))%Z with (* spiwack : when executed in non-compiled*) - | Eq => C0 npm (* mode, (phi n)+(phi m) is computed twice*) - | _ => C1 npm (* it may be considered to optimize it *) - end -. -Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope. - -(* addition plus one with carry (the result is thus exact) *) -Definition add31carryc (n m : int31) := - let npmpone_exact := ((phi n)+(phi m)+1)%Z in - let npmpone := phi_inv npmpone_exact in - match (phi npmpone ?= npmpone_exact)%Z with - | Eq => C0 npmpone - | _ => C1 npmpone - end -. - - -(* subtraction modulo 2^31 *) -Definition sub31 (n m : int31) := phi_inv ((phi n)-(phi m)). -Notation "n - m" := (sub31 n m) : int31_scope. - -(* subtraction with carry (thus exact) *) -Definition sub31c (n m : int31) := - let nmm := n-m in - match (phi nmm ?= (phi n)-(phi m))%Z with - | Eq => C0 nmm - | _ => C1 nmm - end -. -Notation "n '-c' m" := (sub31c n m) (at level 50, no associativity) : int31_scope. - -(* subtraction minus one with carry (thus exact) *) -Definition sub31carryc (n m : int31) := - let nmmmone_exact := ((phi n)-(phi m)-1)%Z in - let nmmmone := phi_inv nmmmone_exact in - match (phi nmmmone ?= nmmmone_exact)%Z with - | Eq => C0 nmmmone - | _ => C1 nmmmone - end -. - - -(* multiplication modulo 2^31 *) -Definition mul31 (n m : int31) := phi_inv ((phi n)*(phi m)). -Notation "n * m" := (mul31 n m) : int31_scope. - - - -(* multiplication with double word result (thus exact) *) -Definition mul31c (n m : int31) := phi_inv2 ((phi n)*(phi m)). -Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scope. - -(* division of a double size word modulo 2^31 *) -Definition div3121 (nh nl m : int31) := - let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in - (phi_inv q, phi_inv r) -. - -(* division modulo 2^31 *) -Definition div31 (n m : int31) := - let (q,r) := Zdiv_eucl (phi n) (phi m) in - (phi_inv q, phi_inv r) -. -Notation "n / m" := (div31 n m) : int31_scope. - -(* unsigned comparison *) -Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z. -Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope. - -(* [iter_int31 i A f x] = f^i x *) -Definition iter_int31 i A f x := - recr (A->A) (fun x => x) (fun b si rec => match b with - | D0 => fun x => rec (rec x) - | D1 => fun x => f (rec (rec x)) - end) - i x -. - -(* [addmuldiv31 p i j] = i*2^p+y/2^(31-p) (modulo 2^31) *) -Definition addmuldiv31 p i j := - let (res, _ ) := - iter_int31 p (int31*int31) (fun ij => let (i,j) := ij in - (sneakl (firstl j) i, shiftl j)) - (i,j) - in - res -. - - -Register add31 as int31 plus in "coq_int31" by True. -Register add31c as int31 plusc in "coq_int31" by True. -Register add31carryc as int31 pluscarryc in "coq_int31" by True. -Register sub31 as int31 minus in "coq_int31" by True. -Register sub31c as int31 minusc in "coq_int31" by True. -Register sub31carryc as int31 minuscarryc in "coq_int31" by True. -Register mul31 as int31 times in "coq_int31" by True. -Register mul31c as int31 timesc in "coq_int31" by True. -Register div3121 as int31 div21 in "coq_int31" by True. -Register div31 as int31 div in "coq_int31" by True. -Register compare31 as int31 compare in "coq_int31" by True. -Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True. - -Definition gcd31 (i j:int31) := - (fix euler (guard:nat) (i j:int31) {struct guard} := - match guard with - | 0%nat => In - | S p => match j ?= On with - | Eq => i - | _ => euler p j (let (_, r ) := i/j in r) - end - end) - size i j -. - -Definition sqrt31 (i:int31) := - match i ?= On with - | Eq => On - | _ => - (fix babylon (guard:nat) (r:int31) {struct guard} := - match guard with - | 0%nat => r - | S p => - let (quo, _) := i/r in - match quo ?= r with - | Eq => r - | _ => let (avrg, _) := (quo+r)/(Twon) in babylon p avrg - end - end) - size (let (approx, _) := (i/Twon) in approx+In) (* approx + 1 > 0 *) - end -. - -Definition sqrt312 (ih il:int31) := - match (match ih ?= On with | Eq => il ?= On | not0 => not0 end) with - | Eq => (On, C0 On) - | _ => let root := - (* invariant lower <= r <= upper *) - let closer_to_upper (r upper lower:int31) := - let (quo,_) := (upper-r)/Twon in - match quo ?= On with - | Eq => upper - | _ => r+quo - end - in - let closer_to_lower (r upper lower:int31) := - let (quo,_) := (r-lower)/Twon in r-quo - in - (fix dichotomy (guard:nat) (r upper lower:int31) {struct guard} := - match guard with - | 0%nat => r - | S p => - match r*c r with - | W0 => dichotomy p - (closer_to_upper r upper lower) - upper r (* because 0 < WW ih il *) - | WW jh jl => match (match jh ?= ih with - | Eq => jl ?= il - | noteq => noteq - end) - with - | Eq => r - | Lt => - match (r + In)*c (r + In) with - | W0 => r (* r = 2^31 - 1 *) - | WW jh1 jl1 => - match (match jh1 ?= ih with - | Eq => jl1 ?= il - | noteq => noteq - end) - with - | Eq => r + In - | Gt => r - | Lt => dichotomy p - (closer_to_upper r upper lower) - upper r - end - end - | Gt => dichotomy p - (closer_to_lower r upper lower) - r lower - end - end - end) - size (let (quo,_) := Tn/Twon in quo) Tn On - in - let square := root *c root in - let rem := match square with - | W0 => C0 il (* this case should not occure *) - | WW sh sl => match il -c sl with - | C0 reml => match ih - sh ?= On with - | Eq => C0 reml - | _ => C1 reml - end - | C1 reml => match ih - sh - In ?= On with - | Eq => C0 reml - | _ => C1 reml - end - end - end - in - (root, rem) - end -. - -Definition positive_to_int31 (p:positive) := - (fix aux (max_digit:nat) (p:positive) {struct p} : (N*int31)%type := - match max_digit with - | 0%nat => (Npos p, On) - | S md => match p with - | xO p' => let (r,i) := aux md p' in (r, Twon*i) - | xI p' => let (r,i) := aux md p' in (r, Twon*i+In) - | xH => (N0, In) - end - end) - size p -. - -Definition head031 (i:int31) := - recl _ (fun _ => T31) (fun b si rec n => match b with - | D0 => rec (add31 n In) - | D1 => n - end) - i On -. - -Definition tail031 (i:int31) := - recr _ (fun _ => T31) (fun b si rec n => match b with - | D0 => rec (add31 n In) - | D1 => n - end) - i On -. - -Register head031 as int31 head0 in "coq_int31" by True. -Register tail031 as int31 tail0 in "coq_int31" by True. diff --git a/theories/Ints/Zaux.v b/theories/Ints/Zaux.v deleted file mode 100644 index 8e4b1d64f0..0000000000 --- a/theories/Ints/Zaux.v +++ /dev/null @@ -1,324 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -(********************************************************************** - Aux.v - - Auxillary functions & Theorems - **********************************************************************) - -Require Import ArithRing. -Require Export ZArith. -Require Export Znumtheory. -Require Export Zpow_facts. - -(* *** Nota Bene *** - All results that were general enough has been moved in ZArith. - Only remain here specialized lemmas and compatibility elements. - (P.L. 5/11/2007). -*) - - -Open Local Scope Z_scope. - -Hint Extern 2 (Zle _ _) => - (match goal with - |- Zpos _ <= Zpos _ => exact (refl_equal _) -| H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) -| H: _ < ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) - end). - -Hint Extern 2 (Zlt _ _) => - (match goal with - |- Zpos _ < Zpos _ => exact (refl_equal _) -| H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) -| H: _ < ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H) - end). - - -Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. - -(************************************** - Properties of order and product - **************************************) - - Theorem beta_lex: forall a b c d beta, - a * beta + b <= c * beta + d -> - 0 <= b < beta -> 0 <= d < beta -> - a <= c. - Proof. - intros a b c d beta H1 (H3, H4) (H5, H6). - assert (a - c < 1); auto with zarith. - apply Zmult_lt_reg_r with beta; auto with zarith. - apply Zle_lt_trans with (d - b); auto with zarith. - rewrite Zmult_minus_distr_r; auto with zarith. - Qed. - - Theorem beta_lex_inv: forall a b c d beta, - a < c -> 0 <= b < beta -> - 0 <= d < beta -> - a * beta + b < c * beta + d. - Proof. - intros a b c d beta H1 (H3, H4) (H5, H6). - case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith. - intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto. - Qed. - - Lemma beta_mult : forall h l beta, - 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. - Proof. - intros h l beta H1 H2;split. auto with zarith. - rewrite <- (Zplus_0_r (beta^2)); rewrite Zpower_2; - apply beta_lex_inv;auto with zarith. - Qed. - - Lemma Zmult_lt_b : - forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. - Proof. - intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. - apply Zle_trans with ((b-1)*(b-1)). - apply Zmult_le_compat;auto with zarith. - apply Zeq_le;ring. - Qed. - - Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, - 1 < beta -> - 0 <= wc < beta -> - 0 <= xh < beta -> - 0 <= xl < beta -> - 0 <= yh < beta -> - 0 <= yl < beta -> - 0 <= cc < beta^2 -> - wc*beta^2 + cc = xh*yl + xl*yh -> - 0 <= wc <= 1. - Proof. - intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. - assert (H8 := Zmult_lt_b beta xh yl H2 H5). - assert (H9 := Zmult_lt_b beta xl yh H3 H4). - split;auto with zarith. - apply beta_lex with (cc) (beta^2 - 2) (beta^2); auto with zarith. - Qed. - - Theorem mult_add_ineq: forall x y cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= cross < beta -> - 0 <= x * y + cross < beta^2. - Proof. - intros x y cross beta HH HH1 HH2. - split; auto with zarith. - apply Zle_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. - apply Zplus_le_compat; auto with zarith. - apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); - rewrite Zpower_2; auto with zarith. - Qed. - - Theorem mult_add_ineq2: forall x y c cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= c*beta + cross <= 2*beta - 2 -> - 0 <= x * y + (c*beta + cross) < beta^2. - Proof. - intros x y c cross beta HH HH1 HH2. - split; auto with zarith. - apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. - apply Zplus_le_compat; auto with zarith. - apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); - rewrite Zpower_2; auto with zarith. - Qed. - -Theorem mult_add_ineq3: forall x y c cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= cross <= beta - 2 -> - 0 <= c <= 1 -> - 0 <= x * y + (c*beta + cross) < beta^2. - Proof. - intros x y c cross beta HH HH1 HH2 HH3. - apply mult_add_ineq2;auto with zarith. - split;auto with zarith. - apply Zle_trans with (1*beta+cross);auto with zarith. - Qed. - -Hint Rewrite Zmult_1_r Zmult_0_r Zmult_1_l Zmult_0_l Zplus_0_l Zplus_0_r Zminus_0_r: rm10. - - -(************************************** - Properties of Zdiv and Zmod -**************************************) - -Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. - Proof. - intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. - case (Zle_or_lt b a); intros H4; auto with zarith. - rewrite Zmod_small; auto with zarith. - Qed. - - - Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (t < 2 ^ b). - apply Zlt_le_trans with (1:= H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_small with (a := t); auto with zarith. - apply Zmod_small; auto with zarith. - split; auto with zarith. - assert (0 <= 2 ^a * r); auto with zarith. - apply Zplus_le_0_compat; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); - try ring. - apply Zplus_le_lt_compat; auto with zarith. - replace b with ((b - a) + a); try ring. - rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); - try rewrite <- Zmult_minus_distr_r. - rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; - auto with zarith. - rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - Theorem Zmod_shift_r: - forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (r * 2 ^a + t) mod (2 ^ b) = (r * 2 ^a) mod (2 ^ b) + t. - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (t < 2 ^ b). - apply Zlt_le_trans with (1:= H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_small with (a := t); auto with zarith. - apply Zmod_small; auto with zarith. - split; auto with zarith. - assert (0 <= 2 ^a * r); auto with zarith. - apply Zplus_le_0_compat; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. - apply Zplus_le_lt_compat; auto with zarith. - replace b with ((b - a) + a); try ring. - rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); - try rewrite <- Zmult_minus_distr_r. - repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; - auto with zarith. - apply Zmult_le_compat_l; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - Theorem Zdiv_shift_r: - forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (Eq: t < 2 ^ b); auto with zarith. - apply Zlt_le_trans with (1 := H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b); - auto with zarith. - rewrite <- Zplus_assoc. - rewrite <- Zmod_shift_r; auto with zarith. - rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith. - rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - - Lemma shift_unshift_mod : forall n p a, - 0 <= a < 2^n -> - 0 <= p <= n -> - a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. - Proof. - intros n p a H1 H2. - pattern (a*2^p) at 1;replace (a*2^p) with - (a*2^p/2^n * 2^n + a*2^p mod 2^n). - 2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq. - replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. - replace (2^n) with (2^(n-p)*2^p). - symmetry;apply Zdiv_mult_cancel_r. - destruct H1;trivial. - cut (0 < 2^p); auto with zarith. - rewrite <- Zpower_exp. - replace (n-p+p) with n;trivial. ring. - omega. omega. - apply Zlt_gt. apply Zpower_gt_0;auto with zarith. - Qed. - - Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. - Proof. - intros p x Hle;destruct (Z_le_gt_dec 0 p). - apply Zdiv_le_lower_bound;auto with zarith. - replace (2^p) with 0. - destruct x;compute;intro;discriminate. - destruct p;trivial;discriminate z. - Qed. - - Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. - Proof. - intros p x y H;destruct (Z_le_gt_dec 0 p). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Zlt_le_trans with y;auto with zarith. - rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. - assert (0 < 2^p);auto with zarith. - replace (2^p) with 0. - destruct x;change (0<y);auto with zarith. - destruct p;trivial;discriminate z. - Qed. - - Theorem Zgcd_div_pos a b: - (0 < b)%Z -> (0 < Zgcd a b)%Z -> (0 < b / Zgcd a b)%Z. - Proof. - intros a b Ha Hg. - case (Zle_lt_or_eq 0 (b/Zgcd a b)); auto. - apply Z_div_pos; auto with zarith. - intros H; generalize Ha. - pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite <- H; auto with zarith. - assert (F := (Zgcd_is_gcd a b)); inversion F; auto. - Qed. - -(* For compatibility of scripts, weaker version of some lemmas of Zdiv *) - -Lemma Zlt0_not_eq : forall n, 0<n -> n<>0. -Proof. - auto with zarith. -Qed. - -Definition Zdiv_mult_cancel_r a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). -Definition Zdiv_mult_cancel_l a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). -Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H). - -Theorem Zbounded_induction : - (forall Q : Z -> Prop, forall b : Z, - Q 0 -> - (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> - forall n, 0 <= n -> n < b -> Q n)%Z. -Proof. -intros Q b Q0 QS. -set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). -assert (H : forall n, 0 <= n -> Q' n). -apply natlike_rec2; unfold Q'. -destruct (Zle_or_lt b 0) as [H | H]. now right. left; now split. -intros n H IH. destruct IH as [[IH1 IH2] | IH]. -destruct (Zle_or_lt (b - 1) n) as [H1 | H1]. -right; auto with zarith. -left. split; [auto with zarith | now apply (QS n)]. -right; auto with zarith. -unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. -assumption. apply Zle_not_lt in H3. false_hyp H2 H3. -Qed. diff --git a/theories/Ints/num/BigQ.v b/theories/Ints/num/BigQ.v deleted file mode 100644 index 33e5f669cd..0000000000 --- a/theories/Ints/num/BigQ.v +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(* *) - -Require Export QMake_base. -Require Import QpMake. -Require Import QvMake. -Require Import Q0Make. -Require Import QifMake. -Require Import QbiMake. - -(* We choose for Q the implemention with - multiple representation of 0: 0, 1/0, 2/0 etc *) -Module BigQ := Q0. - -Definition bigQ := BigQ.t. - -Delimit Scope bigQ_scope with bigQ. -Bind Scope bigQ_scope with bigQ. -Bind Scope bigQ_scope with BigQ.t. - -Notation " i + j " := (BigQ.add i j) : bigQ_scope. -Notation " i - j " := (BigQ.sub i j) : bigQ_scope. -Notation " i * j " := (BigQ.mul i j) : bigQ_scope. -Notation " i / j " := (BigQ.div i j) : bigQ_scope. -Notation " i ?= j " := (BigQ.compare i j) : bigQ_scope. diff --git a/theories/Ints/num/GenAdd.v b/theories/Ints/num/GenAdd.v deleted file mode 100644 index fae16aad69..0000000000 --- a/theories/Ints/num/GenAdd.v +++ /dev/null @@ -1,321 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section GenAdd. - Variable w : Set. - Variable w_0 : w. - Variable w_1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable ww_1 : zn2z w. - Variable w_succ_c : w -> carry w. - Variable w_add_c : w -> w -> carry w. - Variable w_add_carry_c : w -> w -> carry w. - Variable w_succ : w -> w. - Variable w_add : w -> w -> w. - Variable w_add_carry : w -> w -> w. - - Definition ww_succ_c x := - match x with - | W0 => C0 ww_1 - | WW xh xl => - match w_succ_c xl with - | C0 l => C0 (WW xh l) - | C1 l => - match w_succ_c xh with - | C0 h => C0 (WW h w_0) - | C1 h => C1 W0 - end - end - end. - - Definition ww_succ x := - match x with - | W0 => ww_1 - | WW xh xl => - match w_succ_c xl with - | C0 l => WW xh l - | C1 l => w_W0 (w_succ xh) - end - end. - - Definition ww_add_c x y := - match x, y with - | W0, _ => C0 y - | _, W0 => C0 x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Variable R : Set. - Variable f0 f1 : zn2z w -> R. - - Definition ww_add_c_cont x y := - match x, y with - | W0, _ => f0 y - | _, W0 => f0 x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => f0 (WW h l) - | C1 h => f1 (w_WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => f0 (WW h l) - | C1 h => f1 (w_WW h l) - end - end - end. - - (* ww_add et ww_add_carry conserve la forme normale s'il n'y a pas - de debordement *) - Definition ww_add x y := - match x, y with - | W0, _ => y - | _, W0 => x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => WW (w_add xh yh) l - | C1 l => WW (w_add_carry xh yh) l - end - end. - - Definition ww_add_carry_c x y := - match x, y with - | W0, W0 => C0 ww_1 - | W0, WW yh yl => ww_succ_c (WW yh yl) - | WW xh xl, W0 => ww_succ_c (WW xh xl) - | WW xh xl, WW yh yl => - match w_add_carry_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Definition ww_add_carry x y := - match x, y with - | W0, W0 => ww_1 - | W0, WW yh yl => ww_succ (WW yh yl) - | WW xh xl, W0 => ww_succ (WW xh xl) - | WW xh xl, WW yh yl => - match w_add_carry_c xl yl with - | C0 l => WW (w_add xh yh) l - | C1 l => WW (w_add_carry xh yh) l - end - end. - - (*Section GenProof.*) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : - forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. - Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - - Lemma spec_ww_succ_c : forall x, [+[ww_succ_c x]] = [[x]] + 1. - Proof. - destruct x as [ |xh xl];simpl. apply spec_ww_1. - generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l]; - intro H;unfold interp_carry in H. simpl;rewrite H;ring. - rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l. - assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. - rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; - intro H1;unfold interp_carry in H1. - simpl;rewrite H1;rewrite spec_w_0;ring. - unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. - assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. - rewrite H2;ring. - Qed. - - Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Proof. - destruct x as [ |xh xl];simpl;trivial. - destruct y as [ |yh yl];simpl. rewrite Zplus_0_r;trivial. - replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1. trivial. - repeat rewrite Zmult_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1. - simpl;ring. - repeat rewrite Zmult_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring. - Qed. - - Section Cont. - Variable P : zn2z w -> zn2z w -> R -> Prop. - Variable x y : zn2z w. - Variable spec_f0 : forall r, [[r]] = [[x]] + [[y]] -> P x y (f0 r). - Variable spec_f1 : forall r, wwB + [[r]] = [[x]] + [[y]] -> P x y (f1 r). - - Lemma spec_ww_add_c_cont : P x y (ww_add_c_cont x y). - Proof. - destruct x as [ |xh xl];simpl;trivial. - apply spec_f0;trivial. - destruct y as [ |yh yl];simpl. - apply spec_f0;simpl;rewrite Zplus_0_r;trivial. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - intros H;unfold interp_carry in H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *. - apply spec_f0. simpl;rewrite H;rewrite H1;ring. - apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. - rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. - rewrite Zmult_1_l in H1;rewrite H1;ring. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h]; intros H1;unfold interp_carry in *. - apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l. - rewrite <- Zplus_assoc;rewrite H;ring. - apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. - rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. - rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l. - rewrite <- Zplus_assoc;rewrite H;ring. - Qed. - - End Cont. - - Lemma spec_ww_add_carry_c : - forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1. - Proof. - destruct x as [ |xh xl];intro y;simpl. - exact (spec_ww_succ_c y). - destruct y as [ |yh yl];simpl. - rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)). - replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. - unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. - unfold interp_carry;rewrite spec_w_WW; - repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. - rewrite spec_ww_1;rewrite Zmod_small;trivial. - split;[intro;discriminate|apply wwB_pos]. - rewrite <- Zplus_assoc;generalize (spec_w_succ_c xl); - destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H. - rewrite Zmod_small;trivial. - rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z. - assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0. - assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega. - rewrite H0;rewrite Zplus_0_r;rewrite <- Zmult_plus_distr_l;rewrite wwB_wBwB. - rewrite Zpower_2; rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite spec_w_W0;rewrite spec_w_succ;trivial. - Qed. - - Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Proof. - destruct x as [ |xh xl];intros y;simpl. - rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. - destruct y as [ |yh yl]. - change [[W0]] with 0;rewrite Zplus_0_r. - rewrite Zmod_small;trivial. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - unfold interp_carry;intros H;simpl;rewrite <- H. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. - - Lemma spec_ww_add_carry : - forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. - Proof. - destruct x as [ |xh xl];intros y;simpl. - exact (spec_ww_succ y). - destruct y as [ |yh yl]. - change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)). - simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) - as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. - -(* End GenProof. *) -End GenAdd. diff --git a/theories/Ints/num/GenBase.v b/theories/Ints/num/GenBase.v deleted file mode 100644 index e93e3a4893..0000000000 --- a/theories/Ints/num/GenBase.v +++ /dev/null @@ -1,454 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(* $Id:$ *) - -(** * *) - -(** -- Authors: Benjamin Grégoire, Laurent Théry -- Institution: INRIA -- Date: 2007 -- Remark: File automatically generated -*) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import JMeq. - -Open Local Scope Z_scope. - -Section GenBase. - Variable w : Set. - Variable w_0 : w. - Variable w_1 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_digits : positive. - Variable w_zdigits: w. - Variable w_add: w -> w -> zn2z w. - Variable w_to_Z : w -> Z. - Variable w_compare : w -> w -> comparison. - - Definition ww_digits := xO w_digits. - - Definition ww_zdigits := w_add w_zdigits w_zdigits. - - Definition ww_to_Z := zn2z_to_Z (base w_digits) w_to_Z. - - Definition ww_1 := WW w_0 w_1. - - Definition ww_Bm1 := WW w_Bm1 w_Bm1. - - Definition ww_WW xh xl : zn2z (zn2z w) := - match xh, xl with - | W0, W0 => W0 - | _, _ => WW xh xl - end. - - Definition ww_W0 h : zn2z (zn2z w) := - match h with - | W0 => W0 - | _ => WW h W0 - end. - - Definition ww_0W l : zn2z (zn2z w) := - match l with - | W0 => W0 - | _ => WW W0 l - end. - - Definition gen_WW (n:nat) := - match n return word w n -> word w n -> word w (S n) with - | O => w_WW - | S n => - fun (h l : zn2z (word w n)) => - match h, l with - | W0, W0 => W0 - | _, _ => WW h l - end - end. - - Fixpoint gen_digits (n:nat) : positive := - match n with - | O => w_digits - | S n => xO (gen_digits n) - end. - - Definition gen_wB n := base (gen_digits n). - - Fixpoint gen_to_Z (n:nat) : word w n -> Z := - match n return word w n -> Z with - | O => w_to_Z - | S n => zn2z_to_Z (gen_wB n) (gen_to_Z n) - end. - - Fixpoint extend_aux (n:nat) (x:zn2z w) {struct n}: word w (S n) := - match n return word w (S n) with - | O => x - | S n1 => WW W0 (extend_aux n1 x) - end. - - Definition extend (n:nat) (x:w) : word w (S n) := - let r := w_0W x in - match r with - | W0 => W0 - | _ => extend_aux n r - end. - - Definition gen_0 n : word w n := - match n return word w n with - | O => w_0 - | S _ => W0 - end. - - Definition gen_split (n:nat) (x:zn2z (word w n)) := - match x with - | W0 => - match n return word w n * word w n with - | O => (w_0,w_0) - | S _ => (W0, W0) - end - | WW h l => (h,l) - end. - - Definition ww_compare x y := - match x, y with - | W0, W0 => Eq - | W0, WW yh yl => - match w_compare w_0 yh with - | Eq => w_compare w_0 yl - | _ => Lt - end - | WW xh xl, W0 => - match w_compare xh w_0 with - | Eq => w_compare xl w_0 - | _ => Gt - end - | WW xh xl, WW yh yl => - match w_compare xh yh with - | Eq => w_compare xl yl - | Lt => Lt - | Gt => Gt - end - end. - - - (* Return the low part of the composed word*) - Fixpoint get_low (n : nat) {struct n}: - word w n -> w := - match n return (word w n -> w) with - | 0%nat => fun x => x - | S n1 => - fun x => - match x with - | W0 => w_0 - | WW _ x1 => get_low n1 x1 - end - end. - - - Section GenProof. - Notation wB := (base w_digits). - Notation wwB := (base ww_digits). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99). - Notation "[! n | x !]" := (gen_to_Z n x) (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_compare : forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - - Lemma wwB_wBwB : wwB = wB^2. - Proof. - unfold base, ww_digits;rewrite Zpower_2; rewrite (Zpos_xO w_digits). - replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits). - apply Zpower_exp; unfold Zge;simpl;intros;discriminate. - ring. - Qed. - - Lemma spec_ww_1 : [[ww_1]] = 1. - Proof. simpl;rewrite spec_w_0;rewrite spec_w_1;ring. Qed. - - Lemma spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. - Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. - - Lemma lt_0_wB : 0 < wB. - Proof. - unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity. - unfold Zle;intros H;discriminate H. - Qed. - - Lemma lt_0_wwB : 0 < wwB. - Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed. - - Lemma wB_pos: 1 < wB. - Proof. - unfold base;apply Zlt_le_trans with (2^1). unfold Zlt;reflexivity. - apply Zpower_le_monotone. unfold Zlt;reflexivity. - split;unfold Zle;intros H. discriminate H. - clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. - destruct w_digits; discriminate H. - Qed. - - Lemma wwB_pos: 1 < wwB. - Proof. - assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1). - rewrite Zpower_2. - apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]). - apply Zlt_le_weak;trivial. - Qed. - - Theorem wB_div_2: 2 * (wB / 2) = wB. - Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W - spec_to_Z;unfold base. - assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). - pattern 2 at 2; rewrite <- Zpower_1_r. - rewrite <- Zpower_exp; auto with zarith. - f_equal; auto with zarith. - case w_digits; compute; intros; discriminate. - rewrite H; f_equal; auto with zarith. - rewrite Zmult_comm; apply Z_div_mult; auto with zarith. - Qed. - - Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. - Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W - spec_to_Z. - rewrite wwB_wBwB; rewrite Zpower_2. - pattern wB at 1; rewrite <- wB_div_2; auto. - rewrite <- Zmult_assoc. - repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith. - Qed. - - Lemma mod_wwB : forall z x, - (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. - Proof. - intros z x. - rewrite Zplus_mod. - pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2. - rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite (Zmod_small [|x|]). - apply Zmod_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z. - apply Z_mod_lt;apply Zlt_gt;apply lt_0_wB. - destruct (spec_to_Z x);split;trivial. - change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB. - rewrite Zpower_2;rewrite <- (Zplus_0_r (wB*wB));apply beta_lex_inv. - apply lt_0_wB. apply spec_to_Z. split;[apply Zle_refl | apply lt_0_wB]. - Qed. - - Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|]. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros x y;unfold base;rewrite Zdiv_shift_r;auto with zarith. - rewrite Z_div_mult;auto with zarith. - destruct (spec_to_Z x);trivial. - Qed. - - Lemma wB_div_plus : forall x y p, - 0 <= p -> - ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros x y p Hp;rewrite Zpower_exp;auto with zarith. - rewrite <- Zdiv_Zdiv;auto with zarith. - rewrite wB_div;trivial. - Qed. - - Lemma lt_wB_wwB : wB < wwB. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - unfold base;apply Zpower_lt_monotone;auto with zarith. - assert (0 < Zpos w_digits). compute;reflexivity. - unfold ww_digits;rewrite Zpos_xO;auto with zarith. - Qed. - - Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. - Proof. - intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB. - Qed. - - Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - destruct x as [ |h l];simpl. - split;[apply Zle_refl|apply lt_0_wwB]. - assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split. - apply Zplus_le_0_compat;auto with zarith. - rewrite <- (Zplus_0_r wwB);rewrite wwB_wBwB; rewrite Zpower_2; - apply beta_lex_inv;auto with zarith. - Qed. - - Lemma gen_wB_wwB : forall n, gen_wB n * gen_wB n = gen_wB (S n). - Proof. - intros n;unfold gen_wB;simpl. - unfold base;rewrite (Zpos_xO (gen_digits n)). - replace (2 * Zpos (gen_digits n)) with - (Zpos (gen_digits n) + Zpos (gen_digits n)). - symmetry; apply Zpower_exp;intro;discriminate. - ring. - Qed. - - Lemma gen_wB_pos: - forall n, 0 <= gen_wB n. - Proof. - intros n; unfold gen_wB, base; auto with zarith. - Qed. - - Lemma gen_wB_more_digits: - forall n, wB <= gen_wB n. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros n; elim n; clear n; auto. - unfold gen_wB, gen_digits; auto with zarith. - intros n H1; rewrite <- gen_wB_wwB. - apply Zle_trans with (wB * 1). - rewrite Zmult_1_r; apply Zle_refl. - apply Zmult_le_compat; auto with zarith. - apply Zle_trans with wB; auto with zarith. - unfold base. - rewrite <- (Zpower_0_r 2). - apply Zpower_le_monotone2; auto with zarith. - unfold base; auto with zarith. - Qed. - - Lemma spec_gen_to_Z : - forall n (x:word w n), 0 <= [!n | x!] < gen_wB n. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - induction n;intros. exact (spec_to_Z x). - unfold gen_to_Z;fold gen_to_Z. - destruct x;unfold zn2z_to_Z. - unfold gen_wB,base;split;auto with zarith. - assert (U0:= IHn w0);assert (U1:= IHn w1). - split;auto with zarith. - apply Zlt_le_trans with ((gen_wB n - 1) * gen_wB n + gen_wB n). - assert (gen_to_Z n w0*gen_wB n <= (gen_wB n - 1)*gen_wB n). - apply Zmult_le_compat_r;auto with zarith. - auto with zarith. - rewrite <- gen_wB_wwB. - replace ((gen_wB n - 1) * gen_wB n + gen_wB n) with (gen_wB n * gen_wB n); - [auto with zarith | ring]. - Qed. - - Lemma spec_get_low: - forall n x, - [!n | x!] < wB -> [|get_low n x|] = [!n | x!]. - Proof. - clear spec_w_1 spec_w_Bm1. - intros n; elim n; auto; clear n. - intros n Hrec x; case x; clear x; auto. - intros xx yy H1; simpl in H1. - assert (F1: [!n | xx!] = 0). - case (Zle_lt_or_eq 0 ([!n | xx!])); auto. - case (spec_gen_to_Z n xx); auto. - intros F2. - assert (F3 := gen_wB_more_digits n). - assert (F4: 0 <= [!n | yy!]). - case (spec_gen_to_Z n yy); auto. - assert (F5: 1 * wB <= [!n | xx!] * gen_wB n); - auto with zarith. - apply Zmult_le_compat; auto with zarith. - unfold base; auto with zarith. - simpl get_low; simpl gen_to_Z. - generalize H1; clear H1. - rewrite F1; rewrite Zmult_0_l; rewrite Zplus_0_l. - intros H1; apply Hrec; auto. - Qed. - - Lemma spec_gen_WW : forall n (h l : word w n), - [!S n|gen_WW n h l!] = [!n|h!] * gen_wB n + [!n|l!]. - Proof. - induction n;simpl;intros;trivial. - destruct h;auto. - destruct l;auto. - Qed. - - Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. - Proof. induction n;simpl;trivial. Qed. - - Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. - Proof. - intros n x;assert (H:= spec_w_0W x);unfold extend. - destruct (w_0W x);simpl;trivial. - rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). - Qed. - - Lemma spec_gen_0 : forall n, [!n|gen_0 n!] = 0. - Proof. destruct n;trivial. Qed. - - Lemma spec_gen_split : forall n x, - let (h,l) := gen_split n x in - [!S n|x!] = [!n|h!] * gen_wB n + [!n|l!]. - Proof. - destruct x;simpl;auto. - destruct n;simpl;trivial. - rewrite spec_w_0;trivial. - Qed. - - Lemma wB_lex_inv: forall a b c d, - a < c -> - a * wB + [|b|] < c * wB + [|d|]. - Proof. - intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. - Qed. - - Lemma spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. - Proof. - destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial. - generalize (spec_w_compare w_0 yh);destruct (w_compare w_0 yh); - intros H;rewrite spec_w_0 in H. - rewrite <- H;simpl;rewrite <- spec_w_0;apply spec_w_compare. - change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;trivial. - absurd (0 <= [|yh|]). apply Zgt_not_le;trivial. - destruct (spec_to_Z yh);trivial. - generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0); - intros H;rewrite spec_w_0 in H. - rewrite H;simpl;rewrite <- spec_w_0;apply spec_w_compare. - absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial. - destruct (spec_to_Z xh);trivial. - apply Zlt_gt;change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;apply Zgt_lt;trivial. - - generalize (spec_w_compare xh yh);destruct (w_compare xh yh);intros H. - rewrite H;generalize (spec_w_compare xl yl);destruct (w_compare xl yl); - intros H1;[rewrite H1|apply Zplus_lt_compat_l|apply Zplus_gt_compat_l]; - trivial. - apply wB_lex_inv;trivial. - apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial. - Qed. - - - End GenProof. - -End GenBase. - diff --git a/theories/Ints/num/GenDiv.v b/theories/Ints/num/GenDiv.v deleted file mode 100644 index ea6868a901..0000000000 --- a/theories/Ints/num/GenDiv.v +++ /dev/null @@ -1,1536 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. -Require Import GenDivn1. -Require Import GenAdd. -Require Import GenSub. - -Open Local Scope Z_scope. - -Ltac zarith := auto with zarith. - - -Section POS_MOD. - - Variable w:Set. - Variable w_0 : w. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_pos_mod : w -> w -> w. - Variable w_compare : w -> w -> comparison. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable w_0W : w -> zn2z w. - Variable low: zn2z w -> w. - Variable ww_sub: zn2z w -> zn2z w -> zn2z w. - Variable ww_zdigits : zn2z w. - - - Definition ww_pos_mod p x := - let zdigits := w_0W w_zdigits in - match x with - | W0 => W0 - | WW xh xl => - match ww_compare p zdigits with - | Eq => w_WW w_0 xl - | Lt => w_WW w_0 (w_pos_mod (low p) xl) - | Gt => - match ww_compare p ww_zdigits with - | Lt => - let n := low (ww_sub p zdigits) in - w_WW (w_pos_mod n xh) xl - | _ => x - end - end - end. - - - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - - Variable spec_w_0 : [|w_0|] = 0. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - - Variable spec_pos_mod : forall w p, - [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). - - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. - Variable spec_ww_sub: forall x y, - [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. - Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - Variable spec_ww_zdigits : [[ww_zdigits]] = 2 * [|w_zdigits|]. - Variable spec_ww_digits : ww_digits w_digits = xO w_digits. - - - Hint Rewrite spec_w_0 spec_w_WW : w_rewrite. - - Lemma spec_ww_pos_mod : forall w p, - [[ww_pos_mod p w]] = [[w]] mod (2 ^ [[p]]). - assert (HHHHH:= lt_0_wB w_digits). - assert (F0: forall x y, x - y + y = x); auto with zarith. - intros w1 p; case (spec_to_w_Z p); intros HH1 HH2. - unfold ww_pos_mod; case w1. - simpl; rewrite Zmod_small; split; auto with zarith. - intros xh xl; generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; - rewrite spec_w_0W; rewrite spec_zdigits; fold wB; - intros H1. - rewrite H1; simpl ww_to_Z. - autorewrite with w_rewrite rm10. - rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_mult; auto with zarith. - autorewrite with rm10. - rewrite Zmod_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - autorewrite with w_rewrite rm10. - simpl ww_to_Z. - rewrite spec_pos_mod. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small; auto with zarith. - case (spec_to_w_Z p); intros HHH1 HHH2; split; auto with zarith. - apply Zlt_le_trans with (1 := H1). - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite HH0. - rewrite Zplus_mod; auto with zarith. - unfold base. - rewrite <- (F0 (Zpos w_digits) [[p]]). - rewrite Zpower_exp; auto with zarith. - rewrite Zmult_assoc. - rewrite Z_mod_mult; auto with zarith. - autorewrite with w_rewrite rm10. - rewrite Zmod_mod; auto with zarith. -generalize (spec_ww_compare p ww_zdigits); - case ww_compare; rewrite spec_ww_zdigits; - rewrite spec_zdigits; intros H2. - replace (2^[[p]]) with wwB. - rewrite Zmod_small; auto with zarith. - unfold base; rewrite H2. - rewrite spec_ww_digits; auto. - assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = - [[p]] - Zpos w_digits). - rewrite spec_low. - rewrite spec_ww_sub. - rewrite spec_w_0W; rewrite spec_zdigits. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zlt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith. - rewrite spec_ww_digits; - apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith. - simpl ww_to_Z; autorewrite with w_rewrite. - rewrite spec_pos_mod; rewrite HH0. - pattern [|xh|] at 2; - rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits)); - auto with zarith. - rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l. - unfold base; rewrite <- Zmult_assoc; rewrite <- Zpower_exp; - auto with zarith. - rewrite F0; auto with zarith. - rewrite <- Zplus_assoc; rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_mult; auto with zarith. - autorewrite with rm10. - rewrite Zmod_mod; auto with zarith. - apply sym_equal; apply Zmod_small; auto with zarith. - case (spec_to_Z xh); intros U1 U2. - case (spec_to_Z xl); intros U3 U4. - split; auto with zarith. - apply Zplus_le_0_compat; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. - match goal with |- 0 <= ?X mod ?Y => - case (Z_mod_lt X Y); auto with zarith - end. - match goal with |- ?X mod ?Y * ?U + ?Z < ?T => - apply Zle_lt_trans with ((Y - 1) * U + Z ); - [case (Z_mod_lt X Y); auto with zarith | idtac] - end. - match goal with |- ?X * ?U + ?Y < ?Z => - apply Zle_lt_trans with (X * U + (U - 1)) - end. - apply Zplus_le_compat_l; auto with zarith. - case (spec_to_Z xl); unfold base; auto with zarith. - rewrite Zmult_minus_distr_r; rewrite <- Zpower_exp; auto with zarith. - rewrite F0; auto with zarith. - rewrite Zmod_small; auto with zarith. - case (spec_to_w_Z (WW xh xl)); intros U1 U2. - split; auto with zarith. - apply Zlt_le_trans with (1:= U2). - unfold base; rewrite spec_ww_digits. - apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - rewrite Zpos_xO; auto with zarith. - Qed. - -End POS_MOD. - -Section GenDiv32. - - Variable w : Set. - Variable w_0 : w. - Variable w_Bm1 : w. - Variable w_Bm2 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_add_c : w -> w -> carry w. - Variable w_add_carry_c : w -> w -> carry w. - Variable w_add : w -> w -> w. - Variable w_add_carry : w -> w -> w. - Variable w_pred : w -> w. - Variable w_sub : w -> w -> w. - Variable w_mul_c : w -> w -> zn2z w. - Variable w_div21 : w -> w -> w -> w*w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - - Definition w_div32 a1 a2 a3 b1 b2 := - Eval lazy beta iota delta [ww_add_c_cont ww_add] in - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. - - (* Proof *) - - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_Bm2 : [|w_Bm2|] = wB - 2. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : - forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. - - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - Variable spec_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Theorem wB_div2: forall x, wB/2 <= x -> wB <= 2 * x. - intros x H; rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. - Qed. - - Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m. - Proof. - intros n m H1 H2;apply Zmult_lt_0_reg_r with n;trivial. - destruct (Zle_lt_or_eq _ _ H1);trivial. - subst;rewrite Zmult_0_r in H2;discriminate H2. - Qed. - - Theorem spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - Proof. - intros a1 a2 a3 b1 b2 Hle Hlt. - assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). - Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. - rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_assoc;rewrite <- Zmult_plus_distr_l. - change (w_div32 a1 a2 a3 b1 b2) with - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. - assert (Hcmp:=spec_compare a1 b1);destruct (w_compare a1 b1). - simpl in Hlt. - rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. - assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB). - simpl;rewrite spec_sub. - assert ([|a2|] - [|b2|] = wB*(-1) + ([|a2|] - [|b2|] + wB)). ring. - assert (0 <= [|a2|] - [|b2|] + wB < wB). omega. - rewrite <-(Zmod_unique ([|a2|]-[|b2|]) wB (-1) ([|a2|]-[|b2|]+wB) H1 H0). - rewrite wwB_wBwB;ring. - assert (U2 := wB_pos w_digits). - eapply spec_ww_add_c_cont with (P := - fun (x y:zn2z w) (res:w*zn2z w) => - let (q, r) := res in - ([|a1|] * wB + [|a2|]) * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. - rewrite H0;intros r. - repeat - (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); - simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. - assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). - Spec_ww_to_Z r;split;zarith. - rewrite H1. - assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). - rewrite wwB_wBwB; rewrite Zpower_2; zarith. - assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0). - split. apply Zlt_le_trans with (([|a2|] - [|b2|]) * wB);zarith. - rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring]. - apply Zmult_lt_compat_r;zarith. - apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. - replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with - (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring]. - assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. - replace 0 with (0*wB);zarith. - replace (([|a2|] - [|b2|]) * wB + [|a3|] + wwB + ([|b1|] * wB + [|b2|]) + - ([|b1|] * wB + [|b2|]) - wwB) with - (([|a2|] - [|b2|]) * wB + [|a3|] + 2*[|b1|] * wB + 2*[|b2|]); - [zarith | ring]. - rewrite <- (Zmod_unique ([[r]] + ([|b1|] * wB + [|b2|])) wwB - 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). - split. rewrite H1;rewrite Hcmp;ring. trivial. - Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. - rewrite H0;intros r;repeat - (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); - simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. - assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. - split. rewrite H2;rewrite Hcmp;ring. - split. Spec_ww_to_Z r;zarith. - rewrite H2. - assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith. - apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. - replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with - (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring]. - assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. - replace 0 with (0*wB);zarith. - (* Cas Lt *) - assert (Hdiv21 := spec_div21 a2 Hle Hcmp); - destruct (w_div21 a1 a2 b1) as (q, r);destruct Hdiv21. - rewrite H. - assert (Hq := spec_to_Z q). - generalize - (spec_ww_sub_c (w_WW r a3) (w_mul_c q b2)); - destruct (ww_sub_c (w_WW r a3) (w_mul_c q b2)) - as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); - unfold interp_carry;intros H1. - rewrite H1. - split. ring. split. - rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. - apply Zle_lt_trans with ([|r|] * wB + [|a3|]). - assert ( 0 <= [|q|] * [|b2|]);zarith. - apply beta_lex_inv;zarith. - assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB). - rewrite <- H1;ring. - Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. - assert (0 < [|q|] * [|b2|]). zarith. - assert (0 < [|q|]). - apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. - eapply spec_ww_add_c_cont with (P := - fun (x y:zn2z w) (res:w*zn2z w) => - let (q0, r0) := res in - ([|q|] * [|b1|] + [|r|]) * wB + [|a3|] = - [|q0|] * ([|b1|] * wB + [|b2|]) + [[r0]] /\ - 0 <= [[r0]] < [|b1|] * wB + [|b2|]);eauto. - intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto); - simpl ww_to_Z;intros H7. - assert (0 < [|q|] - 1). - assert (1 <= [|q|]). zarith. - destruct (Zle_lt_or_eq _ _ H6);zarith. - rewrite <- H8 in H2;rewrite H2 in H7. - assert (0 < [|b1|]*wB). apply Zmult_lt_0_compat;zarith. - Spec_ww_to_Z r2. zarith. - rewrite (Zmod_small ([|q|] -1));zarith. - rewrite (Zmod_small ([|q|] -1 -1));zarith. - assert ([[r2]] + ([|b1|] * wB + [|b2|]) = - wwB * 1 + - ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). - rewrite H7;rewrite H2;ring. - assert - ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) - < [|b1|]*wB + [|b2|]). - Spec_ww_to_Z r2;omega. - Spec_ww_to_Z (WW b1 b2). simpl in HH5. - assert - (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) - < wwB). split;try omega. - replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. - assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). - rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega. - rewrite <- (Zmod_unique - ([[r2]] + ([|b1|] * wB + [|b2|])) - wwB - 1 - ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2*([|b1|] * wB + [|b2|])) - H10 H8). - split. ring. zarith. - intros r2;repeat (rewrite spec_pred);simpl ww_to_Z;intros H7. - rewrite (Zmod_small ([|q|] -1));zarith. - split. - replace [[r2]] with ([[r1]] + ([|b1|] * wB + [|b2|]) -wwB). - rewrite H2; ring. rewrite <- H7; ring. - Spec_ww_to_Z r2;Spec_ww_to_Z r1. omega. - simpl in Hlt. - assert ([|a1|] * wB + [|a2|] <= [|b1|] * wB + [|b2|]). zarith. - assert (H1 := beta_lex _ _ _ _ _ H HH0 HH3). rewrite spec_w_0;simpl;zarith. - Qed. - - -End GenDiv32. - -Section GenDiv21. - Variable w : Set. - Variable w_0 : w. - - Variable w_0W : w -> zn2z w. - Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. - - Variable ww_1 : zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable ww_sub : zn2z w -> zn2z w -> zn2z w. - - - Definition ww_div21 a1 a2 b := - match a1 with - | W0 => - match ww_compare a2 b with - | Gt => (ww_1, ww_sub a2 b) - | Eq => (ww_1, W0) - | Lt => (W0, a2) - end - | WW a1h a1l => - match a2 with - | W0 => - match b with - | W0 => (W0,W0) (* cas absurde *) - | WW b1 b2 => - let (q1, r) := w_div32 a1h a1l w_0 b1 b2 in - match r with - | W0 => (WW q1 w_0, W0) - | WW r1 r2 => - let (q2, s) := w_div32 r1 r2 w_0 b1 b2 in - (WW q1 q2, s) - end - end - | WW a2h a2l => - match b with - | W0 => (W0,W0) (* cas absurde *) - | WW b1 b2 => - let (q1, r) := w_div32 a1h a1l a2h b1 b2 in - match r with - | W0 => (WW q1 w_0, w_0W a2l) - | WW r1 r2 => - let (q2, s) := w_div32 r1 r2 a2l b1 b2 in - (WW q1 q2, s) - end - end - end - end. - - (* Proof *) - - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. - Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Theorem wwB_div: wwB = 2 * (wwB / 2). - Proof. - rewrite wwB_div_2; rewrite Zmult_assoc; rewrite wB_div_2; auto. - rewrite <- Zpower_2; apply wwB_wBwB. - Qed. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Theorem spec_ww_div21 : forall a1 a2 b, - wwB/2 <= [[b]] -> - [[a1]] < [[b]] -> - let (q,r) := ww_div21 a1 a2 b in - [[a1]] *wwB+[[a2]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. - Proof. - assert (U:= lt_0_wB w_digits). - assert (U1:= lt_0_wwB w_digits). - intros a1 a2 b H Hlt; unfold ww_div21. - Spec_ww_to_Z b; assert (Eq: 0 < [[b]]). Spec_ww_to_Z a1;omega. - generalize Hlt H ;clear Hlt H;case a1. - intros H1 H2;simpl in H1;Spec_ww_to_Z a2; - match goal with |-context [ww_compare ?Y ?Z] => - generalize (spec_ww_compare Y Z); case (ww_compare Y Z) - end; simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith. - rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith. - split. ring. - assert (wwB <= 2*[[b]]);zarith. - rewrite wwB_div;zarith. - intros a1h a1l. Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2. - destruct a2 as [ |a3 a4]; - (destruct b as [ |b1 b2];[unfold Zle in Eq;discriminate Eq|idtac]); - try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2; - intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q1 r H0 - end; (assert (Eq1: wB / 2 <= [|b1|]);[ - apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; - autorewrite with rm10;repeat rewrite (Zmult_comm wB); - rewrite <- wwB_div_2; trivial - | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; - try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r; - intros (H1,H2) ]). - split;[rewrite wwB_wBwB; rewrite Zpower_2 | trivial]. - rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc; - rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H1;ring. - destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. - split;[rewrite wwB_wBwB | trivial]. - rewrite Zpower_2. - rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc; - rewrite <- Zpower_2. - rewrite <- wwB_wBwB;rewrite H1. - rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4. - repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]). - rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. - split;[rewrite wwB_wBwB | split;zarith]. - replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) - with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). - rewrite H1;ring. rewrite wwB_wBwB;ring. - change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. - assert (1 <= wB/2);zarith. - assert (H_:= wB_pos w_digits);apply Zdiv_le_lower_bound;zarith. - destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. - split;trivial. - replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with - (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); - [rewrite H1 | rewrite wwB_wBwB;ring]. - replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with - (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); - [rewrite H4;simpl|rewrite wwB_wBwB];ring. - Qed. - -End GenDiv21. - -Section GenDivGt. - Variable w : Set. - Variable w_digits : positive. - Variable w_0 : w. - - Variable w_WW : w -> w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_eq0 : w -> bool. - Variable w_opp_c : w -> carry w. - Variable w_opp w_opp_carry : w -> w. - Variable w_sub_c : w -> w -> carry w. - Variable w_sub w_sub_carry : w -> w -> w. - - Variable w_div_gt : w -> w -> w*w. - Variable w_mod_gt : w -> w -> w. - Variable w_gcd_gt : w -> w -> w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_head0 : w -> w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. - - - Variable _ww_zdigits : zn2z w. - Variable ww_1 : zn2z w. - Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. - - Variable w_zdigits : w. - - Definition ww_div_gt_aux ah al bh bl := - Eval lazy beta iota delta [ww_sub ww_opp] in - let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div - (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) - | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) - end. - - Definition ww_div_gt a b := - Eval lazy beta iota delta [ww_div_gt_aux gen_divn1 - gen_divn1_p gen_divn1_p_aux gen_divn1_0 gen_divn1_0_aux - gen_split gen_0 gen_WW] in - match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - gen_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end. - - Definition ww_mod_gt_aux ah al bh bl := - Eval lazy beta iota delta [ww_sub ww_opp] in - let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r - | _ => - ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) - end. - - Definition ww_mod_gt a b := - Eval lazy beta iota delta [ww_mod_gt_aux gen_modn1 - gen_modn1_p gen_modn1_p_aux gen_modn1_0 gen_modn1_0_aux - gen_split gen_0 gen_WW snd] in - match a, b with - | W0, _ => W0 - | _, W0 => W0 - | WW ah al, WW bh bl => - if w_eq0 ah then w_0W (w_mod_gt al bl) - else - match w_compare w_0 bh with - | Eq => - w_0W (gen_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl) - | Lt => ww_mod_gt_aux ah al bh bl - | Gt => W0 (* cas absurde *) - end - end. - - Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := - Eval lazy beta iota delta [ww_mod_gt_aux gen_modn1 - gen_modn1_p gen_modn1_p_aux gen_modn1_0 gen_modn1_0_aux - gen_split gen_0 gen_WW snd] in - match w_compare w_0 bh with - | Eq => - match w_compare w_0 bl with - | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => - let m := gen_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW ah al) bl in - WW w_0 (w_gcd_gt bl m) - | Gt => W0 (* absurde *) - end - | Lt => - let m := ww_mod_gt_aux ah al bh bl in - match m with - | W0 => WW bh bl - | WW mh ml => - match w_compare w_0 mh with - | Eq => - match w_compare w_0 ml with - | Eq => WW bh bl - | _ => - let r := gen_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW bh bl) ml in - WW w_0 (w_gcd_gt ml r) - end - | Lt => - let r := ww_mod_gt_aux bh bl mh ml in - match r with - | W0 => m - | WW rh rl => cont mh ml rh rl - end - | Gt => W0 (* absurde *) - end - end - | Gt => W0 (* absurde *) - end. - - Fixpoint ww_gcd_gt_aux - (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) - {struct p} : zn2z w := - ww_gcd_gt_body - (fun mh ml rh rl => match p with - | xH => cont mh ml rh rl - | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl - | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl - end) ah al bh bl. - - - (* Proof *) - - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - - Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. - Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. - Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. - - Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - - Variable spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := w_div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|w_mod_gt a b|] = [|a|] mod [|b|]. - Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - - Variable spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ ([|p|])) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. - - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - - Variable spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - - Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. - - Variable spec_ww_digits_ : [[_ww_zdigits]] = Zpos (xO w_digits). - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^[[p]]) + - [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Lemma to_Z_div_minus_p : forall x p, - 0 < [|p|] < Zpos w_digits -> - 0 <= [|x|] / 2 ^ (Zpos w_digits - [|p|]) < 2 ^ [|p|]. - Proof. - intros x p H;Spec_w_to_Z x. - split. apply Zdiv_le_lower_bound;zarith. - apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - ring_simplify ([|p|] + (Zpos w_digits - [|p|])); unfold base in HH;zarith. - Qed. - Hint Resolve to_Z_div_minus_p : zarith. - - Lemma spec_ww_div_gt_aux : forall ah al bh bl, - [[WW ah al]] > [[WW bh bl]] -> - 0 < [|bh|] -> - let (q,r) := ww_div_gt_aux ah al bh bl in - [[WW ah al]] = [[q]] * [[WW bh bl]] + [[r]] /\ - 0 <= [[r]] < [[WW bh bl]]. - Proof. - intros ah al bh bl Hgt Hpos;unfold ww_div_gt_aux. - change - (let (q, r) := let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div - (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) - | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) - end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]). - assert (Hh := spec_head0 Hpos). - lazy zeta. - generalize (spec_compare (w_head0 bh) w_0); case w_compare; - rewrite spec_w_0; intros HH. - generalize Hh; rewrite HH; simpl Zpower; - rewrite Zmult_1_l; intros (HH1, HH2); clear HH. - assert (wwB <= 2*[[WW bh bl]]). - apply Zle_trans with (2*[|bh|]*wB). - rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat_r; zarith. - rewrite <- wB_div_2; apply Zmult_le_compat_l; zarith. - simpl ww_to_Z;rewrite Zmult_plus_distr_r;rewrite Zmult_assoc. - Spec_w_to_Z bl;zarith. - Spec_ww_to_Z (WW ah al). - rewrite spec_ww_sub;eauto. - simpl;rewrite spec_ww_1;rewrite Zmult_1_l;simpl. - simpl ww_to_Z in Hgt, H, HH;rewrite Zmod_small;split;zarith. - case (spec_to_Z (w_head0 bh)); auto with zarith. - assert ([|w_head0 bh|] < Zpos w_digits). - destruct (Z_lt_ge_dec [|w_head0 bh|] (Zpos w_digits));trivial. - elimtype False. - assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith. - apply Zle_ge; replace wB with (wB * 1);try ring. - Spec_w_to_Z bh;apply Zmult_le_compat;zarith. - unfold base;apply Zpower_le_monotone;zarith. - assert (HHHH : 0 < [|w_head0 bh|] < Zpos w_digits); auto with zarith. - assert (Hb:= Zlt_le_weak _ _ H). - generalize (spec_add_mul_div w_0 ah Hb) - (spec_add_mul_div ah al Hb) - (spec_add_mul_div al w_0 Hb) - (spec_add_mul_div bh bl Hb) - (spec_add_mul_div bl w_0 Hb); - rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l; - rewrite Zdiv_0_l;repeat rewrite Zplus_0_r. - Spec_w_to_Z ah;Spec_w_to_Z bh. - unfold base;repeat rewrite Zmod_shift_r;zarith. - assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); - assert (H5:=to_Z_div_minus_p bl HHHH). - rewrite Zmult_comm in Hh. - assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith. - unfold base in H0;rewrite Zmod_small;zarith. - fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith. - intros U1 U2 U3 V1 V2. - generalize (@spec_w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) - (w_add_mul_div (w_head0 bh) ah al) - (w_add_mul_div (w_head0 bh) al w_0) - (w_add_mul_div (w_head0 bh) bh bl) - (w_add_mul_div (w_head0 bh) bl w_0)). - destruct (w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) - (w_add_mul_div (w_head0 bh) ah al) - (w_add_mul_div (w_head0 bh) al w_0) - (w_add_mul_div (w_head0 bh) bh bl) - (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r). - rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. - rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). - unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. - replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with - ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring. - fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3. - rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. - rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)). - rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. - unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. - replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with - ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring. - intros Hd;destruct Hd;zarith. - simpl. apply beta_lex_inv;zarith. rewrite U1;rewrite V1. - assert ([|ah|] / 2 ^ (Zpos (w_digits) - [|w_head0 bh|]) < wB/2);zarith. - apply Zdiv_lt_upper_bound;zarith. - unfold base. - replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2). - rewrite Z_div_mult;zarith. rewrite <- Zpower_exp;zarith. - apply Zlt_le_trans with wB;zarith. - unfold base;apply Zpower_le_monotone;zarith. - pattern 2 at 2;replace 2 with (2^1);trivial. - rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial. - change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite - Zmult_0_l;rewrite Zplus_0_l. - replace [[ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry - _ww_zdigits (w_0W (w_head0 bh))) W0 r]] with ([[r]]/2^[|w_head0 bh|]). - assert (0 < 2^[|w_head0 bh|]). apply Zpower_gt_0;zarith. - split. - rewrite <- (Z_div_mult [[WW ah al]] (2^[|w_head0 bh|]));zarith. - rewrite H1;rewrite Zmult_assoc;apply Z_div_plus_l;trivial. - split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. - rewrite spec_ww_add_mul_div. - rewrite spec_ww_sub; auto with zarith. - rewrite spec_ww_digits_. - change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith. - simpl ww_to_Z;rewrite Zmult_0_l;rewrite Zplus_0_l. - rewrite spec_w_0W. - rewrite (fun x y => Zmod_small (x-y)); auto with zarith. - ring_simplify (2 * Zpos w_digits - (2 * Zpos w_digits - [|w_head0 bh|])). - rewrite Zmod_small;zarith. - split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. - Spec_ww_to_Z r. - apply Zlt_le_trans with wwB;zarith. - rewrite <- (Zmult_1_r wwB);apply Zmult_le_compat;zarith. - split; auto with zarith. - apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith. - unfold base, ww_digits; rewrite (Zpos_xO w_digits). - apply Zpower2_lt_lin; auto with zarith. - rewrite spec_ww_sub; auto with zarith. - rewrite spec_ww_digits_; rewrite spec_w_0W. - rewrite Zmod_small;zarith. - rewrite Zpos_xO; split; auto with zarith. - apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith. - unfold base, ww_digits; rewrite (Zpos_xO w_digits). - apply Zpower2_lt_lin; auto with zarith. - Qed. - - Lemma spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - let (q,r) := ww_div_gt a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Proof. - intros a b Hgt Hpos;unfold ww_div_gt. - change (let (q,r) := match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - gen_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). - destruct a as [ |ah al]. simpl in Hgt;omega. - destruct b as [ |bh bl]. simpl in Hpos;omega. - Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. - assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). - simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. - simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. - assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl). - repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial. - clear H. - assert (Hcmp := spec_compare w_0 bh); destruct (w_compare w_0 bh). - rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]). - rewrite <- Hcmp;rewrite Zmult_0_l;rewrite Zplus_0_l. - simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos. - assert (H2:= @spec_gen_divn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 - spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos). - unfold gen_to_Z,gen_wB,gen_digits in H2. - destruct (gen_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 - (WW ah al) bl). - rewrite spec_w_0W;unfold ww_to_Z;trivial. - apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial. - rewrite spec_w_0 in Hcmp;elimtype False;omega. - Qed. - - Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl, - ww_mod_gt_aux ah al bh bl = snd (ww_div_gt_aux ah al bh bl). - Proof. - intros ah al bh bl. unfold ww_mod_gt_aux, ww_div_gt_aux. - case w_compare; auto. - case w_div32; auto. - Qed. - - Lemma spec_ww_mod_gt_aux : forall ah al bh bl, - [[WW ah al]] > [[WW bh bl]] -> - 0 < [|bh|] -> - [[ww_mod_gt_aux ah al bh bl]] = [[WW ah al]] mod [[WW bh bl]]. - Proof. - intros. rewrite spec_ww_mod_gt_aux_eq;trivial. - assert (H3 := spec_ww_div_gt_aux ah al bl H H0). - destruct (ww_div_gt_aux ah al bh bl) as (q,r);simpl. simpl in H,H3. - destruct H3;apply Zmod_unique with [[q]];zarith. - rewrite H1;ring. - Qed. - - Lemma spec_w_mod_gt_eq : forall a b, [|a|] > [|b|] -> 0 <[|b|] -> - [|w_mod_gt a b|] = [|snd (w_div_gt a b)|]. - Proof. - intros a b Hgt Hpos. - rewrite spec_mod_gt;trivial. - assert (H:=spec_div_gt Hgt Hpos). - destruct (w_div_gt a b) as (q,r);simpl. - rewrite Zmult_comm in H;destruct H. - symmetry;apply Zmod_unique with [|q|];trivial. - Qed. - - Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. - Proof. - intros a b Hgt Hpos. - change (ww_mod_gt a b) with - (match a, b with - | W0, _ => W0 - | _, W0 => W0 - | WW ah al, WW bh bl => - if w_eq0 ah then w_0W (w_mod_gt al bl) - else - match w_compare w_0 bh with - | Eq => - w_0W (gen_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl) - | Lt => ww_mod_gt_aux ah al bh bl - | Gt => W0 (* cas absurde *) - end end). - change (ww_div_gt a b) with - (match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - gen_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end). - destruct a as [ |ah al];trivial. - destruct b as [ |bh bl];trivial. - Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. - assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). - simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. - simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. - rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial. - destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. - clear H. - assert (H2 := spec_compare w_0 bh);destruct (w_compare w_0 bh). - rewrite (@spec_gen_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl). - destruct (gen_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 - (WW ah al) bl);simpl;trivial. - rewrite spec_ww_mod_gt_aux_eq;trivial;symmetry;trivial. - trivial. - Qed. - - Lemma spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[a]] mod [[b]]. - Proof. - intros a b Hgt Hpos. - assert (H:= spec_ww_div_gt a b Hgt Hpos). - rewrite (spec_ww_mod_gt_eq a b Hgt Hpos). - destruct (ww_div_gt a b)as(q,r);destruct H. - apply Zmod_unique with[[q]];simpl;trivial. - rewrite Zmult_comm;trivial. - Qed. - - Lemma Zis_gcd_mod : forall a b d, - 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. - Proof. - intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). - pattern a at 1;rewrite (Z_div_mod_eq a b). - ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. - Qed. - - Lemma spec_ww_gcd_gt_aux_body : - forall ah al bh bl n cont, - [[WW bh bl]] <= 2^n -> - [[WW ah al]] > [[WW bh bl]] -> - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. - Proof. - intros ah al bh bl n cont Hlog Hgt Hcont. - change (ww_gcd_gt_body cont ah al bh bl) with (match w_compare w_0 bh with - | Eq => - match w_compare w_0 bl with - | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => - let m := gen_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW ah al) bl in - WW w_0 (w_gcd_gt bl m) - | Gt => W0 (* absurde *) - end - | Lt => - let m := ww_mod_gt_aux ah al bh bl in - match m with - | W0 => WW bh bl - | WW mh ml => - match w_compare w_0 mh with - | Eq => - match w_compare w_0 ml with - | Eq => WW bh bl - | _ => - let r := gen_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW bh bl) ml in - WW w_0 (w_gcd_gt ml r) - end - | Lt => - let r := ww_mod_gt_aux bh bl mh ml in - match r with - | W0 => m - | WW rh rl => cont mh ml rh rl - end - | Gt => W0 (* absurde *) - end - end - | Gt => W0 (* absurde *) - end). - assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). - simpl ww_to_Z in *. rewrite spec_w_0 in Hbh;rewrite <- Hbh; - rewrite Zmult_0_l;rewrite Zplus_0_l. - assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). - rewrite spec_w_0 in Hbl;rewrite <- Hbl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l. - rewrite spec_w_0 in Hbl. - apply Zis_gcd_mod;zarith. - change ([|ah|] * wB + [|al|]) with (gen_to_Z w_digits w_to_Z 1 (WW ah al)). - rewrite <- (@spec_gen_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div - spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl). - apply spec_gcd_gt. - rewrite (@spec_gen_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;elimtype False;omega. - rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). - assert (H2 : 0 < [[WW bh bl]]). - simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith. - apply Zmult_lt_0_compat;zarith. - apply Zis_gcd_mod;trivial. rewrite <- H. - simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. - simpl;apply Zis_gcd_0;zarith. - assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). - simpl;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl. - assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). - rewrite <- Hml;rewrite spec_w_0;simpl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;simpl. - rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith. - change ([|bh|] * wB + [|bl|]) with (gen_to_Z w_digits w_to_Z 1 (WW bh bl)). - rewrite <- (@spec_gen_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div - spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml). - apply spec_gcd_gt. - rewrite (@spec_gen_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - rewrite spec_w_0 in Hml;Spec_w_to_Z ml;elimtype False;omega. - rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]). - rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). - assert (H3 : 0 < [[WW mh ml]]). - simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith. - apply Zmult_lt_0_compat;zarith. - apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. - destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. - simpl;apply Hcont. simpl in H1;rewrite H1. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - apply Zle_trans with (2^n/2). - apply Zdiv_le_lower_bound;zarith. - apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith. - assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)). - assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]). - apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. - pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. - destruct (Zle_lt_or_eq _ _ H4'). - assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = - [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). - simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. - assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). - simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Zmult_1_r;zarith. - simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8; - zarith. - assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith. - rewrite <- H4 in H3';rewrite Zmult_0_r in H3';simpl in H3';zarith. - pattern n at 1;replace n with (n-1+1);try ring. - rewrite Zpower_exp;zarith. change (2^1) with 2. - rewrite Z_div_mult;zarith. - assert (2^1 <= 2^n). change (2^1) with 2;zarith. - assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith. - rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;elimtype False;zarith. - rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;elimtype False;zarith. - Qed. - - Lemma spec_ww_gcd_gt_aux : - forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 2^n -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> - [[WW bh bl]] <= 2^(Zpos p + n) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] - [[ww_gcd_gt_aux p cont ah al bh bl]]. - Proof. - induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux. - assert (0 < Zpos p). unfold Zlt;reflexivity. - apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n); - trivial;rewrite Zpos_xI. - intros. apply IHp with (n := Zpos p + n);zarith. - intros. apply IHp with (n := n );zarith. - apply Zle_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith. - apply Zpower_le_monotone2;zarith. - assert (0 < Zpos p). unfold Zlt;reflexivity. - apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial. - rewrite (Zpos_xO p). - intros. apply IHp with (n := Zpos p + n - 1);zarith. - intros. apply IHp with (n := n -1 );zarith. - intros;apply Hcont;zarith. - apply Zle_trans with (2^(n-1));zarith. - apply Zpower_le_monotone2;zarith. - apply Zle_trans with (2 ^ (Zpos p + n -1));zarith. - apply Zpower_le_monotone2;zarith. - apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith. - apply Zpower_le_monotone2;zarith. - apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. - rewrite Zplus_comm;trivial. - ring_simplify (n + 1 - 1);trivial. - Qed. - -End GenDivGt. - -Section GenDiv. - - Variable w : Set. - Variable w_digits : positive. - Variable ww_1 : zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - - Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. - Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. - - Definition ww_div a b := - match ww_compare a b with - | Gt => ww_div_gt a b - | Eq => (ww_1, W0) - | Lt => (W0, a) - end. - - Definition ww_mod a b := - match ww_compare a b with - | Gt => ww_mod_gt a b - | Eq => W0 - | Lt => a - end. - - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. - Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - let (q,r) := ww_div_gt a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Variable spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[a]] mod [[b]]. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Lemma spec_ww_div : forall a b, 0 < [[b]] -> - let (q,r) := ww_div a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Proof. - intros a b Hpos;unfold ww_div. - assert (H:=spec_ww_compare a b);destruct (ww_compare a b). - simpl;rewrite spec_ww_1;split;zarith. - simpl;split;[ring|Spec_ww_to_Z a;zarith]. - apply spec_ww_div_gt;trivial. - Qed. - - Lemma spec_ww_mod : forall a b, 0 < [[b]] -> - [[ww_mod a b]] = [[a]] mod [[b]]. - Proof. - intros a b Hpos;unfold ww_mod. - assert (H := spec_ww_compare a b);destruct (ww_compare a b). - simpl;apply Zmod_unique with 1;try rewrite H;zarith. - Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith. - apply spec_ww_mod_gt;trivial. - Qed. - - - Variable w_0 : w. - Variable w_1 : w. - Variable w_compare : w -> w -> comparison. - Variable w_eq0 : w -> bool. - Variable w_gcd_gt : w -> w -> w. - Variable _ww_digits : positive. - Variable spec_ww_digits_ : _ww_digits = xO w_digits. - Variable ww_gcd_gt_fix : - positive -> (w -> w -> w -> w -> zn2z w) -> - w -> w -> w -> w -> zn2z w. - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - Variable spec_gcd_gt_fix : - forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 2^n -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> - [[WW bh bl]] <= 2^(Zpos p + n) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] - [[ww_gcd_gt_fix p cont ah al bh bl]]. - - Definition gcd_cont (xh xl yh yl:w) := - match w_compare w_1 yl with - | Eq => ww_1 - | _ => WW xh xl - end. - - Lemma spec_gcd_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 1 -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. - Proof. - intros xh xl yh yl Hgt' Hle. simpl in Hle. - assert ([|yh|] = 0). - change 1 with (0*wB+1) in Hle. - assert (0 <= 1 < wB). split;zarith. apply wB_pos. - assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). - Spec_w_to_Z yh;zarith. - unfold gcd_cont;assert (Hcmpy:=spec_compare w_1 yl); - rewrite spec_w_1 in Hcmpy. - simpl;rewrite H;simpl;destruct (w_compare w_1 yl). - rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith. - rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith. - rewrite H in Hle; elimtype False;zarith. - assert ([|yl|] = 0). Spec_w_to_Z yl;zarith. - rewrite H0;simpl;apply Zis_gcd_0;trivial. - Qed. - - - Variable cont : w -> w -> w -> w -> zn2z w. - Variable spec_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 1 -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. - - Definition ww_gcd_gt a b := - match a, b with - | W0, _ => b - | _, W0 => a - | WW ah al, WW bh bl => - if w_eq0 ah then (WW w_0 (w_gcd_gt al bl)) - else ww_gcd_gt_fix _ww_digits cont ah al bh bl - end. - - Definition ww_gcd a b := - Eval lazy beta delta [ww_gcd_gt] in - match ww_compare a b with - | Gt => ww_gcd_gt a b - | Eq => a - | Lt => ww_gcd_gt b a - end. - - Lemma spec_ww_gcd_gt : forall a b, [[a]] > [[b]] -> - Zis_gcd [[a]] [[b]] [[ww_gcd_gt a b]]. - Proof. - intros a b Hgt;unfold ww_gcd_gt. - destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. - destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. - simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. - simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. - rewrite H1;simpl;auto. clear H. - apply spec_gcd_gt_fix with (n:= 0);trivial. - rewrite Zplus_0_r;rewrite spec_ww_digits_. - change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith. - Qed. - - Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. - Proof. - intros a b. - change (ww_gcd a b) with - (match ww_compare a b with - | Gt => ww_gcd_gt a b - | Eq => a - | Lt => ww_gcd_gt b a - end). - assert (Hcmp := spec_ww_compare a b);destruct (ww_compare a b). - Spec_ww_to_Z b;rewrite Hcmp. - apply Zis_gcd_for_euclid with 1;zarith. - ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith. - apply Zis_gcd_sym;apply spec_ww_gcd_gt;zarith. - apply spec_ww_gcd_gt;zarith. - Qed. - -End GenDiv. - diff --git a/theories/Ints/num/GenDivn1.v b/theories/Ints/num/GenDivn1.v deleted file mode 100644 index 3c70adb615..0000000000 --- a/theories/Ints/num/GenDivn1.v +++ /dev/null @@ -1,524 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section GENDIVN1. - - Variable w : Set. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable w_0 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_head0 : w -> w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_compare : w -> w -> comparison. - Variable w_sub : w -> w -> w. - - - - (* ** For proofs ** *) - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). - - Variable spec_to_Z : forall x, 0 <= [| x |] < wB. - Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. - Variable spec_0 : [|w_0|] = 0. - Variable spec_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. - Variable spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_sub: forall x y, - [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - - - Section DIVAUX. - Variable b2p : w. - Variable b2p_le : wB/2 <= [|b2p|]. - - Definition gen_divn1_0_aux n (divn1: w -> word w n -> word w n * w) r h := - let (hh,hl) := gen_split w_0 n h in - let (qh,rh) := divn1 r hh in - let (ql,rl) := divn1 rh hl in - (gen_WW w_WW n qh ql, rl). - - Fixpoint gen_divn1_0 (n:nat) : w -> word w n -> word w n * w := - match n return w -> word w n -> word w n * w with - | O => fun r x => w_div21 r x b2p - | S n => gen_divn1_0_aux n (gen_divn1_0 n) - end. - - Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), - let (h, l) := gen_split w_0 n x in - [!S n | x!] = [!n | h!] * gen_wB w_digits n + [!n | l!]. - Proof (spec_gen_split w_0 w_digits w_to_Z spec_0). - - Lemma spec_gen_divn1_0 : forall n r a, - [|r|] < [|b2p|] -> - let (q,r') := gen_divn1_0 n r a in - [|r|] * gen_wB w_digits n + [!n|a!] = [!n|q!] * [|b2p|] + [|r'|] /\ - 0 <= [|r'|] < [|b2p|]. - Proof. - induction n;intros. - exact (spec_div21 a b2p_le H). - simpl (gen_divn1_0 (S n) r a); unfold gen_divn1_0_aux. - assert (H1 := spec_split n a);destruct (gen_split w_0 n a) as (hh,hl). - rewrite H1. - assert (H2 := IHn r hh H);destruct (gen_divn1_0 n r hh) as (qh,rh). - destruct H2. - assert ([|rh|] < [|b2p|]). omega. - assert (H4 := IHn rh hl H3);destruct (gen_divn1_0 n rh hl) as (ql,rl). - destruct H4;split;trivial. - rewrite spec_gen_WW;trivial. - rewrite <- gen_wB_wwB. - rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - rewrite H0;rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc. - rewrite H4;ring. - Qed. - - Definition gen_modn1_0_aux n (modn1:w -> word w n -> w) r h := - let (hh,hl) := gen_split w_0 n h in modn1 (modn1 r hh) hl. - - Fixpoint gen_modn1_0 (n:nat) : w -> word w n -> w := - match n return w -> word w n -> w with - | O => fun r x => snd (w_div21 r x b2p) - | S n => gen_modn1_0_aux n (gen_modn1_0 n) - end. - - Lemma spec_gen_modn1_0 : forall n r x, - gen_modn1_0 n r x = snd (gen_divn1_0 n r x). - Proof. - induction n;simpl;intros;trivial. - unfold gen_modn1_0_aux, gen_divn1_0_aux. - destruct (gen_split w_0 n x) as (hh,hl). - rewrite (IHn r hh). - destruct (gen_divn1_0 n r hh) as (qh,rh);simpl. - rewrite IHn. destruct (gen_divn1_0 n rh hl);trivial. - Qed. - - Variable p : w. - Variable p_bounded : [|p|] <= Zpos w_digits. - - Lemma spec_add_mul_divp : forall x y, - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Proof. - intros;apply spec_add_mul_div;auto. - Qed. - - Definition gen_divn1_p_aux n - (divn1 : w -> word w n -> word w n -> word w n * w) r h l := - let (hh,hl) := gen_split w_0 n h in - let (lh,ll) := gen_split w_0 n l in - let (qh,rh) := divn1 r hh hl in - let (ql,rl) := divn1 rh hl lh in - (gen_WW w_WW n qh ql, rl). - - Fixpoint gen_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := - match n return w -> word w n -> word w n -> word w n * w with - | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p - | S n => gen_divn1_p_aux n (gen_divn1_p n) - end. - - Lemma p_lt_gen_digits : forall n, [|p|] <= Zpos (gen_digits w_digits n). - Proof. -(* - induction n;simpl. destruct p_bounded;trivial. - case (spec_to_Z p); rewrite Zpos_xO;auto with zarith. -*) - induction n;simpl. trivial. - case (spec_to_Z p); rewrite Zpos_xO;auto with zarith. - Qed. - - Lemma spec_gen_divn1_p : forall n r h l, - [|r|] < [|b2p|] -> - let (q,r') := gen_divn1_p n r h l in - [|r|] * gen_wB w_digits n + - ([!n|h!]*2^[|p|] + - [!n|l!] / (2^(Zpos(gen_digits w_digits n) - [|p|]))) - mod gen_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ - 0 <= [|r'|] < [|b2p|]. - Proof. - case (spec_to_Z p); intros HH0 HH1. - induction n;intros. - simpl (gen_divn1_p 0 r h l). - unfold gen_to_Z, gen_wB, gen_digits. - rewrite <- spec_add_mul_divp. - exact (spec_div21 (w_add_mul_div p h l) b2p_le H). - simpl (gen_divn1_p (S n) r h l). - unfold gen_divn1_p_aux. - assert (H1 := spec_split n h);destruct (gen_split w_0 n h) as (hh,hl). - rewrite H1. rewrite <- gen_wB_wwB. - assert (H2 := spec_split n l);destruct (gen_split w_0 n l) as (lh,ll). - rewrite H2. - replace ([|r|] * (gen_wB w_digits n * gen_wB w_digits n) + - (([!n|hh!] * gen_wB w_digits n + [!n|hl!]) * 2 ^ [|p|] + - ([!n|lh!] * gen_wB w_digits n + [!n|ll!]) / - 2^(Zpos (gen_digits w_digits (S n)) - [|p|])) mod - (gen_wB w_digits n * gen_wB w_digits n)) with - (([|r|] * gen_wB w_digits n + ([!n|hh!] * 2^[|p|] + - [!n|hl!] / 2^(Zpos (gen_digits w_digits n) - [|p|])) mod - gen_wB w_digits n) * gen_wB w_digits n + - ([!n|hl!] * 2^[|p|] + - [!n|lh!] / 2^(Zpos (gen_digits w_digits n) - [|p|])) mod - gen_wB w_digits n). - generalize (IHn r hh hl H);destruct (gen_divn1_p n r hh hl) as (qh,rh); - intros (H3,H4);rewrite H3. - assert ([|rh|] < [|b2p|]). omega. - replace (([!n|qh!] * [|b2p|] + [|rh|]) * gen_wB w_digits n + - ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (gen_digits w_digits n) - [|p|])) mod - gen_wB w_digits n) with - ([!n|qh!] * [|b2p|] *gen_wB w_digits n + ([|rh|]*gen_wB w_digits n + - ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (gen_digits w_digits n) - [|p|])) mod - gen_wB w_digits n)). 2:ring. - generalize (IHn rh hl lh H0);destruct (gen_divn1_p n rh hl lh) as (ql,rl); - intros (H5,H6);rewrite H5. - split;[rewrite spec_gen_WW;trivial;ring|trivial]. - assert (Uhh := spec_gen_to_Z w_digits w_to_Z spec_to_Z n hh); - unfold gen_wB,base in Uhh. - assert (Uhl := spec_gen_to_Z w_digits w_to_Z spec_to_Z n hl); - unfold gen_wB,base in Uhl. - assert (Ulh := spec_gen_to_Z w_digits w_to_Z spec_to_Z n lh); - unfold gen_wB,base in Ulh. - assert (Ull := spec_gen_to_Z w_digits w_to_Z spec_to_Z n ll); - unfold gen_wB,base in Ull. - unfold gen_wB,base. - assert (UU:=p_lt_gen_digits n). - rewrite Zdiv_shift_r;auto with zarith. - 2:change (Zpos (gen_digits w_digits (S n))) - with (2*Zpos (gen_digits w_digits n));auto with zarith. - replace (2 ^ (Zpos (gen_digits w_digits (S n)) - [|p|])) with - (2^(Zpos (gen_digits w_digits n) - [|p|])*2^Zpos (gen_digits w_digits n)). - rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite Zmult_plus_distr_l with (p:= 2^[|p|]). - pattern ([!n|hl!] * 2^[|p|]) at 2; - rewrite (shift_unshift_mod (Zpos(gen_digits w_digits n))([|p|])([!n|hl!])); - auto with zarith. - rewrite Zplus_assoc. - replace - ([!n|hh!] * 2^Zpos (gen_digits w_digits n)* 2^[|p|] + - ([!n|hl!] / 2^(Zpos (gen_digits w_digits n)-[|p|])* - 2^Zpos(gen_digits w_digits n))) - with - (([!n|hh!] *2^[|p|] + gen_to_Z w_digits w_to_Z n hl / - 2^(Zpos (gen_digits w_digits n)-[|p|])) - * 2^Zpos(gen_digits w_digits n));try (ring;fail). - rewrite <- Zplus_assoc. - rewrite <- (Zmod_shift_r ([|p|]));auto with zarith. - replace - (2 ^ Zpos (gen_digits w_digits n) * 2 ^ Zpos (gen_digits w_digits n)) with - (2 ^ (Zpos (gen_digits w_digits n) + Zpos (gen_digits w_digits n))). - rewrite (Zmod_shift_r (Zpos (gen_digits w_digits n)));auto with zarith. - replace (2 ^ (Zpos (gen_digits w_digits n) + Zpos (gen_digits w_digits n))) - with (2^Zpos(gen_digits w_digits n) *2^Zpos(gen_digits w_digits n)). - rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] + - [!n|hl!] / 2 ^ (Zpos (gen_digits w_digits n) - [|p|])))). - rewrite Zmult_mod_distr_l;auto with zarith. - ring. - rewrite Zpower_exp;auto with zarith. - assert (0 < Zpos (gen_digits w_digits n)). unfold Zlt;reflexivity. - auto with zarith. - apply Z_mod_lt;auto with zarith. - rewrite Zpower_exp;auto with zarith. - split;auto with zarith. - apply Zdiv_lt_upper_bound;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace ([|p|] + (Zpos (gen_digits w_digits n) - [|p|])) with - (Zpos(gen_digits w_digits n));auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (gen_digits w_digits (S n)) - [|p|]) with - (Zpos (gen_digits w_digits n) - [|p|] + - Zpos (gen_digits w_digits n));trivial. - change (Zpos (gen_digits w_digits (S n))) with - (2*Zpos (gen_digits w_digits n)). ring. - Qed. - - Definition gen_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= - let (hh,hl) := gen_split w_0 n h in - let (lh,ll) := gen_split w_0 n l in - modn1 (modn1 r hh hl) hl lh. - - Fixpoint gen_modn1_p (n:nat) : w -> word w n -> word w n -> w := - match n return w -> word w n -> word w n -> w with - | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) - | S n => gen_modn1_p_aux n (gen_modn1_p n) - end. - - Lemma spec_gen_modn1_p : forall n r h l , - gen_modn1_p n r h l = snd (gen_divn1_p n r h l). - Proof. - induction n;simpl;intros;trivial. - unfold gen_modn1_p_aux, gen_divn1_p_aux. - destruct(gen_split w_0 n h)as(hh,hl);destruct(gen_split w_0 n l) as (lh,ll). - rewrite (IHn r hh hl);destruct (gen_divn1_p n r hh hl) as (qh,rh). - rewrite IHn;simpl;destruct (gen_divn1_p n rh hl lh);trivial. - Qed. - - End DIVAUX. - - Fixpoint high (n:nat) : word w n -> w := - match n return word w n -> w with - | O => fun a => a - | S n => - fun (a:zn2z (word w n)) => - match a with - | W0 => w_0 - | WW h l => high n h - end - end. - - Lemma spec_gen_digits:forall n, Zpos w_digits <= Zpos (gen_digits w_digits n). - Proof. - induction n;simpl;auto with zarith. - change (Zpos (xO (gen_digits w_digits n))) with - (2*Zpos (gen_digits w_digits n)). - assert (0 < Zpos w_digits);auto with zarith. - exact (refl_equal Lt). - Qed. - - Lemma spec_high : forall n (x:word w n), - [|high n x|] = [!n|x!] / 2^(Zpos (gen_digits w_digits n) - Zpos w_digits). - Proof. - induction n;intros. - unfold high,gen_digits,gen_to_Z. - replace (Zpos w_digits - Zpos w_digits) with 0;try ring. - simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. - assert (U2 := spec_gen_digits n). - assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt). - destruct x;unfold high;fold high. - unfold gen_to_Z,zn2z_to_Z;rewrite spec_0. - rewrite Zdiv_0_l;trivial. - assert (U0 := spec_gen_to_Z w_digits w_to_Z spec_to_Z n w0); - assert (U1 := spec_gen_to_Z w_digits w_to_Z spec_to_Z n w1). - simpl [!S n|WW w0 w1!]. - unfold gen_wB,base;rewrite Zdiv_shift_r;auto with zarith. - replace (2 ^ (Zpos (gen_digits w_digits (S n)) - Zpos w_digits)) with - (2^(Zpos (gen_digits w_digits n) - Zpos w_digits) * - 2^Zpos (gen_digits w_digits n)). - rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (gen_digits w_digits n) - Zpos w_digits + - Zpos (gen_digits w_digits n)) with - (Zpos (gen_digits w_digits (S n)) - Zpos w_digits);trivial. - change (Zpos (gen_digits w_digits (S n))) with - (2*Zpos (gen_digits w_digits n));ring. - change (Zpos (gen_digits w_digits (S n))) with - (2*Zpos (gen_digits w_digits n)); auto with zarith. - Qed. - - Definition gen_divn1 (n:nat) (a:word w n) (b:w) := - let p := w_head0 b in - match w_compare p w_0 with - | Gt => - let b2p := w_add_mul_div p b w_0 in - let ha := high n a in - let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in - let r0 := w_add_mul_div p w_0 ha in - let (q,r) := gen_divn1_p b2p p n r0 a (gen_0 w_0 n) in - (q, lsr_n r) - | _ => gen_divn1_0 b n w_0 a - end. - - Lemma spec_gen_divn1 : forall n a b, - 0 < [|b|] -> - let (q,r) := gen_divn1 n a b in - [!n|a!] = [!n|q!] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - intros n a b H. unfold gen_divn1. - case (spec_head0 H); intros H0 H1. - case (spec_to_Z (w_head0 b)); intros HH1 HH2. - generalize (spec_compare (w_head0 b) w_0); case w_compare; - rewrite spec_0; intros H2; auto with zarith. - assert (Hv1: wB/2 <= [|b|]). - generalize H0; rewrite H2; rewrite Zpower_0_r; - rewrite Zmult_1_l; auto. - assert (Hv2: [|w_0|] < [|b|]). - rewrite spec_0; auto. - generalize (spec_gen_divn1_0 Hv1 n a Hv2). - rewrite spec_0;rewrite Zmult_0_l; rewrite Zplus_0_l; auto. - contradict H2; auto with zarith. - assert (HHHH : 0 < [|w_head0 b|]); auto with zarith. - assert ([|w_head0 b|] < Zpos w_digits). - case (Zle_or_lt (Zpos w_digits) [|w_head0 b|]); auto; intros HH. - assert (2 ^ [|w_head0 b|] < wB). - apply Zle_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith. - replace (2 ^ [|w_head0 b|]) with (2^[|w_head0 b|] * 1);try (ring;fail). - apply Zmult_le_compat;auto with zarith. - assert (wB <= 2^[|w_head0 b|]). - unfold base;apply Zpower_le_monotone;auto with zarith. omega. - assert ([|w_add_mul_div (w_head0 b) b w_0|] = - 2 ^ [|w_head0 b|] * [|b|]). - rewrite (spec_add_mul_div b w_0); auto with zarith. - rewrite spec_0;rewrite Zdiv_0_l; try omega. - rewrite Zplus_0_r; rewrite Zmult_comm. - rewrite Zmod_small; auto with zarith. - assert (H5 := spec_to_Z (high n a)). - assert - ([|w_add_mul_div (w_head0 b) w_0 (high n a)|] - <[|w_add_mul_div (w_head0 b) b w_0|]). - rewrite H4. - rewrite spec_add_mul_div;auto with zarith. - rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. - assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Zlt_le_trans with wB;auto with zarith. - pattern wB at 1;replace wB with (wB*1);try ring. - apply Zmult_le_compat;auto with zarith. - assert (H6 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|])); - auto with zarith. - rewrite Zmod_small;auto with zarith. - apply Zdiv_lt_upper_bound;auto with zarith. - apply Zlt_le_trans with wB;auto with zarith. - apply Zle_trans with (2 ^ [|w_head0 b|] * [|b|] * 2). - rewrite <- wB_div_2; try omega. - apply Zmult_le_compat;auto with zarith. - pattern 2 at 1;rewrite <- Zpower_1_r. - apply Zpower_le_monotone;split;auto with zarith. - rewrite <- H4 in H0. - assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. - assert (H7:= spec_gen_divn1_p H0 Hb3 n a (gen_0 w_0 n) H6). - destruct (gen_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n - (w_add_mul_div (w_head0 b) w_0 (high n a)) a - (gen_0 w_0 n)) as (q,r). - assert (U:= spec_gen_digits n). - rewrite spec_gen_0 in H7;trivial;rewrite Zdiv_0_l in H7. - rewrite Zplus_0_r in H7. - rewrite spec_add_mul_div in H7;auto with zarith. - rewrite spec_0 in H7;rewrite Zmult_0_l in H7;rewrite Zplus_0_l in H7. - assert (([|high n a|] / 2 ^ (Zpos w_digits - [|w_head0 b|])) mod wB - = [!n|a!] / 2^(Zpos (gen_digits w_digits n) - [|w_head0 b|])). - rewrite Zmod_small;auto with zarith. - rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (gen_digits w_digits n) - Zpos w_digits + - (Zpos w_digits - [|w_head0 b|])) - with (Zpos (gen_digits w_digits n) - [|w_head0 b|]);trivial;ring. - assert (H8 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|]));auto with zarith. - split;auto with zarith. - apply Zle_lt_trans with ([|high n a|]);auto with zarith. - apply Zdiv_le_upper_bound;auto with zarith. - pattern ([|high n a|]) at 1;rewrite <- Zmult_1_r. - apply Zmult_le_compat;auto with zarith. - rewrite H8 in H7;unfold gen_wB,base in H7. - rewrite <- shift_unshift_mod in H7;auto with zarith. - rewrite H4 in H7. - assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] - = [|r|]/2^[|w_head0 b|]). - rewrite spec_add_mul_div. - rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. - replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) - with ([|w_head0 b|]). - rewrite Zmod_small;auto with zarith. - assert (H9 := spec_to_Z r). - split;auto with zarith. - apply Zle_lt_trans with ([|r|]);auto with zarith. - apply Zdiv_le_upper_bound;auto with zarith. - pattern ([|r|]) at 1;rewrite <- Zmult_1_r. - apply Zmult_le_compat;auto with zarith. - assert (H10 := Zpower_gt_0 2 ([|w_head0 b|]));auto with zarith. - rewrite spec_sub. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - case (spec_to_Z w_zdigits); auto with zarith. - rewrite spec_sub. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - case (spec_to_Z w_zdigits); auto with zarith. - case H7; intros H71 H72. - split. - rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith. - rewrite H71;rewrite H9. - replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) - with ([!n|q!] *[|b|] * 2^[|w_head0 b|]); - try (ring;fail). - rewrite Z_div_plus_l;auto with zarith. - assert (H10 := spec_to_Z - (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split; - auto with zarith. - rewrite H9. - apply Zdiv_lt_upper_bound;auto with zarith. - rewrite Zmult_comm;auto with zarith. - exact (spec_gen_to_Z w_digits w_to_Z spec_to_Z n a). - Qed. - - - Definition gen_modn1 (n:nat) (a:word w n) (b:w) := - let p := w_head0 b in - match w_compare p w_0 with - | Gt => - let b2p := w_add_mul_div p b w_0 in - let ha := high n a in - let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in - let r0 := w_add_mul_div p w_0 ha in - let r := gen_modn1_p b2p p n r0 a (gen_0 w_0 n) in - lsr_n r - | _ => gen_modn1_0 b n w_0 a - end. - - Lemma spec_gen_modn1_aux : forall n a b, - gen_modn1 n a b = snd (gen_divn1 n a b). - Proof. - intros n a b;unfold gen_divn1,gen_modn1. - generalize (spec_compare (w_head0 b) w_0); case w_compare; - rewrite spec_0; intros H2; auto with zarith. - apply spec_gen_modn1_0. - apply spec_gen_modn1_0. - rewrite spec_gen_modn1_p. - destruct (gen_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n - (w_add_mul_div (w_head0 b) w_0 (high n a)) a (gen_0 w_0 n));simpl;trivial. - Qed. - - Lemma spec_gen_modn1 : forall n a b, 0 < [|b|] -> - [|gen_modn1 n a b|] = [!n|a!] mod [|b|]. - Proof. - intros n a b H;assert (H1 := spec_gen_divn1 n a H). - assert (H2 := spec_gen_modn1_aux n a b). - rewrite H2;destruct (gen_divn1 n a b) as (q,r). - simpl;apply Zmod_unique with (gen_to_Z w_digits w_to_Z n q);auto with zarith. - destruct H1 as (h1,h2);rewrite h1;ring. - Qed. - -End GENDIVN1. diff --git a/theories/Ints/num/GenLift.v b/theories/Ints/num/GenLift.v deleted file mode 100644 index f74cdc30bb..0000000000 --- a/theories/Ints/num/GenLift.v +++ /dev/null @@ -1,483 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section GenLift. - Variable w : Set. - Variable w_0 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable w_head0 : w -> w. - Variable w_tail0 : w -> w. - Variable w_add: w -> w -> zn2z w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable ww_sub: zn2z w -> zn2z w -> zn2z w. - Variable w_digits : positive. - Variable ww_Digits : positive. - Variable w_zdigits : w. - Variable ww_zdigits : zn2z w. - Variable low: zn2z w -> w. - - Definition ww_head0 x := - match x with - | W0 => ww_zdigits - | WW xh xl => - match w_compare w_0 xh with - | Eq => w_add w_zdigits (w_head0 xl) - | _ => w_0W (w_head0 xh) - end - end. - - - Definition ww_tail0 x := - match x with - | W0 => ww_zdigits - | WW xh xl => - match w_compare w_0 xl with - | Eq => w_add w_zdigits (w_tail0 xh) - | _ => w_0W (w_tail0 xl) - end - end. - - - (* 0 < p < ww_digits *) - Definition ww_add_mul_div p x y := - let zdigits := w_0W w_zdigits in - match x, y with - | W0, W0 => W0 - | W0, WW yh yl => - match ww_compare p zdigits with - | Eq => w_0W yh - | Lt => w_0W (w_add_mul_div (low p) w_0 yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl) - end - | WW xh xl, W0 => - match ww_compare p zdigits with - | Eq => w_W0 xl - | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0) - | Gt => - let n := low (ww_sub p zdigits) in - w_W0 (w_add_mul_div n xl w_0) - end - | WW xh xl, WW yh yl => - match ww_compare p zdigits with - | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end - end. - - Section GenProof. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_compare : forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. - Variable spec_ww_digits : ww_Digits = xO w_digits. - Variable spec_w_head00 : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits. - Variable spec_w_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB. - Variable spec_w_tail00 : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits. - Variable spec_w_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]). - Variable spec_w_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_w_add: forall x y, - [[w_add x y]] = [|x|] + [|y|]. - Variable spec_ww_sub: forall x y, - [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. - Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - - Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits. - - Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. - Ltac zarith := auto with zarith lift. - - Lemma spec_ww_head00 : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits. - Proof. - intros x; case x; unfold ww_head0. - intros HH; rewrite spec_ww_zdigits; auto. - intros xh xl; simpl; intros Hx. - case (spec_to_Z xh); intros Hx1 Hx2. - case (spec_to_Z xl); intros Hy1 Hy2. - assert (F1: [|xh|] = 0). - case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - apply Zlt_le_trans with (1 := Hy3); auto with zarith. - pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]). - apply Zplus_le_compat_r; auto with zarith. - case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - rewrite <- Hy3; rewrite Zplus_0_r; auto with zarith. - apply Zmult_lt_0_compat; auto with zarith. - generalize (spec_compare w_0 xh); case w_compare. - intros H; simpl. - rewrite spec_w_add; rewrite spec_w_head00. - rewrite spec_zdigits; rewrite spec_ww_digits. - rewrite Zpos_xO; auto with zarith. - rewrite F1 in Hx; auto with zarith. - rewrite spec_w_0; auto with zarith. - rewrite spec_w_0; auto with zarith. - Qed. - - Lemma spec_ww_head0 : forall x, 0 < [[x]] -> - wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. - Proof. - clear spec_ww_zdigits. - rewrite wwB_div_2;rewrite Zmult_comm;rewrite wwB_wBwB. - assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H. - unfold Zlt in H;discriminate H. - assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0. - destruct (w_compare w_0 xh). - rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H. - case (spec_to_Z w_zdigits); - case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. - rewrite spec_w_add. - rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. - case (spec_w_head0 H); intros H1 H2. - rewrite Zpower_2; fold wB; rewrite <- Zmult_assoc; split. - apply Zmult_le_compat_l; auto with zarith. - apply Zmult_lt_compat_l; auto with zarith. - assert (H1 := spec_w_head0 H0). - rewrite spec_w_0W. - split. - rewrite Zmult_plus_distr_r;rewrite Zmult_assoc. - apply Zle_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB). - rewrite Zmult_comm; zarith. - assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith. - assert (H2:=spec_to_Z xl);apply Zmult_le_0_compat;zarith. - case (spec_to_Z (w_head0 xh)); intros H2 _. - generalize ([|w_head0 xh|]) H1 H2;clear H1 H2; - intros p H1 H2. - assert (Eq1 : 2^p < wB). - rewrite <- (Zmult_1_r (2^p));apply Zle_lt_trans with (2^p*[|xh|]);zarith. - assert (Eq2: p < Zpos w_digits). - destruct (Zle_or_lt (Zpos w_digits) p);trivial;contradict Eq1. - apply Zle_not_lt;unfold base;apply Zpower_le_monotone;zarith. - assert (Zpos w_digits = p + (Zpos w_digits - p)). ring. - rewrite Zpower_2. - unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith. - rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith. - rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. - apply Zmult_lt_reg_r with (2 ^ p); zarith. - rewrite <- Zpower_exp;zarith. - rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. - assert (H1 := spec_to_Z xh);zarith. - Qed. - - Lemma spec_ww_tail00 : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits. - Proof. - intros x; case x; unfold ww_tail0. - intros HH; rewrite spec_ww_zdigits; auto. - intros xh xl; simpl; intros Hx. - case (spec_to_Z xh); intros Hx1 Hx2. - case (spec_to_Z xl); intros Hy1 Hy2. - assert (F1: [|xh|] = 0). - case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - apply Zlt_le_trans with (1 := Hy3); auto with zarith. - pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]). - apply Zplus_le_compat_r; auto with zarith. - case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - rewrite <- Hy3; rewrite Zplus_0_r; auto with zarith. - apply Zmult_lt_0_compat; auto with zarith. - assert (F2: [|xl|] = 0). - rewrite F1 in Hx; auto with zarith. - generalize (spec_compare w_0 xl); case w_compare. - intros H; simpl. - rewrite spec_w_add; rewrite spec_w_tail00; auto. - rewrite spec_zdigits; rewrite spec_ww_digits. - rewrite Zpos_xO; auto with zarith. - rewrite spec_w_0; auto with zarith. - rewrite spec_w_0; auto with zarith. - Qed. - - Lemma spec_ww_tail0 : forall x, 0 < [[x]] -> - exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]]. - Proof. - clear spec_ww_zdigits. - destruct x as [ |xh xl];simpl ww_to_Z;intros H. - unfold Zlt in H;discriminate H. - assert (H0 := spec_compare w_0 xl);rewrite spec_w_0 in H0. - destruct (w_compare w_0 xl). - rewrite <- H0; rewrite Zplus_0_r. - case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. - generalize H; rewrite <- H0; rewrite Zplus_0_r; clear H; intros H. - case (@spec_w_tail0 xh). - apply Zmult_lt_reg_r with wB; auto with zarith. - unfold base; auto with zarith. - intros z (Hz1, Hz2); exists z; split; auto. - rewrite spec_w_add; rewrite (fun x => Zplus_comm [|x|]). - rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. - rewrite Zmult_assoc; rewrite <- Hz2; auto. - - case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. - case (spec_w_tail0 H0); intros z (Hz1, Hz2). - assert (Hp: [|w_tail0 xl|] < Zpos w_digits). - case (Zle_or_lt (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1. - absurd (2 ^ (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]). - apply Zlt_not_le. - case (spec_to_Z xl); intros HH3 HH4. - apply Zle_lt_trans with (2 := HH4). - apply Zle_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith. - rewrite Hz2. - apply Zmult_le_compat_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split. - apply Zplus_le_0_compat; auto. - apply Zmult_le_0_compat; auto with zarith. - case (spec_to_Z xh); auto. - rewrite spec_w_0W. - rewrite (Zmult_plus_distr_r 2); rewrite <- Zplus_assoc. - rewrite Zmult_plus_distr_l; rewrite <- Hz2. - apply f_equal2 with (f := Zplus); auto. - rewrite (Zmult_comm 2). - repeat rewrite <- Zmult_assoc. - apply f_equal2 with (f := Zmult); auto. - case (spec_to_Z (w_tail0 xl)); intros HH3 HH4. - pattern 2 at 2; rewrite <- Zpower_1_r. - lazy beta; repeat rewrite <- Zpower_exp; auto with zarith. - unfold base; apply f_equal with (f := Zpower 2); auto with zarith. - - contradict H0; case (spec_to_Z xl); auto with zarith. - Qed. - - Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r - spec_w_W0 spec_w_0W spec_w_WW spec_w_0 - (wB_div w_digits w_to_Z spec_to_Z) - (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. - Ltac w_rewrite := autorewrite with w_rewrite;trivial. - - Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p, - let zdigits := w_0W w_zdigits in - [[p]] <= Zpos (xO w_digits) -> - [[match ww_compare p zdigits with - | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) - (w_add_mul_div (low p) xl yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end]] = - ([[WW xh xl]] * (2^[[p]]) + - [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - Proof. - clear spec_ww_zdigits. - intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits). - case (spec_to_w_Z p); intros Hv1 Hv2. - replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). - 2 : rewrite Zpos_xO;ring. - replace (Zpos w_digits + Zpos w_digits - [[p]]) with - (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring. - intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); - assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); - simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl); - assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy. - generalize (spec_ww_compare p zdigits); case ww_compare; intros H1. - rewrite H1; unfold zdigits; rewrite spec_w_0W. - rewrite spec_zdigits; rewrite Zminus_diag; rewrite Zplus_0_r. - simpl ww_to_Z; w_rewrite;zarith. - fold wB. - rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc. - rewrite <- Zpower_2. - rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. - simpl ww_to_Z; w_rewrite;zarith. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small. - case (spec_to_w_Z p); intros HH1 HH2; split; auto. - generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; intros tmp. - apply Zlt_le_trans with (1 := tmp). - unfold base. - apply Zpower2_le_lin; auto with zarith. - 2: generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; auto with zarith. - generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; auto; clear H1; intros H1. - assert (HH: [|low p|] <= Zpos w_digits). - rewrite HH0; auto with zarith. - repeat rewrite spec_w_add_mul_div with (1 := HH). - rewrite HH0. - rewrite Zmult_plus_distr_l. - pattern ([|xl|] * 2 ^ [[p]]) at 2; - rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. - replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. - unfold base at 5;rewrite <- Zmod_shift_r;zarith. - unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); - fold wB;fold wwB;zarith. - rewrite wwB_wBwB;rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. - unfold ww_digits;rewrite Zpos_xO;zarith. apply Z_mod_lt;zarith. - split;zarith. apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith. - assert (Hv: [[p]] > Zpos w_digits). - generalize H1; clear H1. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto. - clear H1. - assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits). - rewrite spec_low. - rewrite spec_ww_sub. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zle_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - exists wB; unfold base. - unfold ww_digits; rewrite (Zpos_xO w_digits). - rewrite <- Zpower_exp; auto with zarith. - apply f_equal with (f := fun x => 2 ^ x); auto with zarith. - assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits). - rewrite HH0; auto with zarith. - replace (Zpos w_digits + (Zpos w_digits - [[p]])) with - (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith. - lazy zeta; simpl ww_to_Z; w_rewrite;zarith. - repeat rewrite spec_w_add_mul_div;zarith. - rewrite HH0. - pattern wB at 5;replace wB with - (2^(([[p]] - Zpos w_digits) - + (Zpos w_digits - ([[p]] - Zpos w_digits)))). - rewrite Zpower_exp;zarith. rewrite Zmult_assoc. - rewrite Z_div_plus_l;zarith. - rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits) - (n := Zpos w_digits);zarith. fold wB. - set (u := [[p]] - Zpos w_digits). - replace [[p]] with (u + Zpos w_digits);zarith. - rewrite Zpower_exp;zarith. rewrite Zmult_assoc. fold wB. - repeat rewrite Zplus_assoc. rewrite <- Zmult_plus_distr_l. - repeat rewrite <- Zplus_assoc. - unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); - fold wB;fold wwB;zarith. - unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) - (b:= Zpos w_digits);fold wB;fold wwB;zarith. - rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. - rewrite Zmult_plus_distr_l. - replace ([|xh|] * wB * 2 ^ u) with - ([|xh|]*2^u*wB). 2:ring. - repeat rewrite <- Zplus_assoc. - rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)). - rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith. - unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. - split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold - wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith. - unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. - unfold u; split;zarith. - apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. - unfold u;zarith. - unfold u;zarith. - set (u := [[p]] - Zpos w_digits). - ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. - Qed. - - Lemma spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^[[p]]) + - [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - Proof. - clear spec_ww_zdigits. - intros x y p H. - destruct x as [ |xh xl]; - [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0) - |assert (H1 := @spec_ww_add_mul_div_aux xh xl)]; - (destruct y as [ |yh yl]; - [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)]; - clear H1;w_rewrite);simpl ww_add_mul_div. - replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. - intros Heq;rewrite <- Heq;clear Heq; auto. - generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; intros H1; w_rewrite. - rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. - generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small. - case (spec_to_w_Z p); intros HH1 HH2; split; auto. - apply Zlt_le_trans with (1 := H1). - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite HH0; auto with zarith. - replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. - intros Heq;rewrite <- Heq;clear Heq. - generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; intros H1; w_rewrite. - rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. - rewrite Zpos_xO in H;zarith. - assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits). - generalize H1; clear H1. - rewrite spec_low. - rewrite spec_ww_sub; w_rewrite; intros H1. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zle_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - unfold base; auto with zarith. - unfold base; auto with zarith. - exists wB; unfold base. - unfold ww_digits; rewrite (Zpos_xO w_digits). - rewrite <- Zpower_exp; auto with zarith. - apply f_equal with (f := fun x => 2 ^ x); auto with zarith. - case (spec_to_Z xh); auto with zarith. - Qed. - - End GenProof. - -End GenLift. - diff --git a/theories/Ints/num/GenMul.v b/theories/Ints/num/GenMul.v deleted file mode 100644 index 9a56f1ee3c..0000000000 --- a/theories/Ints/num/GenMul.v +++ /dev/null @@ -1,624 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section GenMul. - Variable w : Set. - Variable w_0 : w. - Variable w_1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_succ : w -> w. - Variable w_add_c : w -> w -> carry w. - Variable w_add : w -> w -> w. - Variable w_sub: w -> w -> w. - Variable w_mul_c : w -> w -> zn2z w. - Variable w_mul : w -> w -> w. - Variable w_square_c : w -> zn2z w. - Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add : zn2z w -> zn2z w -> zn2z w. - Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_sub : zn2z w -> zn2z w -> zn2z w. - - (* ** Multiplication ** *) - - (* (xh*B+xl) (yh*B + yl) - xh*yh = hh = |hhh|hhl|B2 - xh*yl +xl*yh = cc = |cch|ccl|B - xl*yl = ll = |llh|lll - *) - - Definition gen_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => - let hh := w_mul_c xh yh in - let ll := w_mul_c xl yl in - let (wc,cc) := cross xh xl yh yl hh ll in - match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end - end. - - Definition ww_mul_c := - gen_mul_c - (fun xh xl yh yl hh ll=> - match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end). - - Definition w_2 := w_add w_1 w_1. - - Definition kara_prod xh xl yh yl hh ll := - match ww_add_c hh ll with - C0 m => - match w_compare xl xh with - Eq => (w_0, m) - | Lt => - match w_compare yl yh with - Eq => (w_0, m) - | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) - | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with - C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) - end - end - | Gt => - match w_compare yl yh with - Eq => (w_0, m) - | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with - C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) - end - | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh) (w_sub yl yh))) - end - end - | C1 m => - match w_compare xl xh with - Eq => (w_1, m) - | Lt => - match w_compare yl yh with - Eq => (w_1, m) - | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with - C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) - end - | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with - C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) - end - end - | Gt => - match w_compare yl yh with - Eq => (w_1, m) - | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with - C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) - end - | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with - C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1) - end - end - end - end. - - Definition ww_karatsuba_c := gen_mul_c kara_prod. - - Definition ww_mul x y := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => - let ccl := w_add (w_mul xh yl) (w_mul xl yh) in - ww_add (w_W0 ccl) (w_mul_c xl yl) - end. - - Definition ww_square_c x := - match x with - | W0 => W0 - | WW xh xl => - let hh := w_square_c xh in - let ll := w_square_c xl in - let xhxl := w_mul_c xh xl in - let (wc,cc) := - match ww_add_c xhxl xhxl with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end in - match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end - end. - - Section GenMulAddn1. - Variable w_mul_add : w -> w -> w -> w * w. - - Fixpoint gen_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := - match n return word w n -> w -> w -> w * word w n with - | O => w_mul_add - | S n1 => - let mul_add := gen_mul_add_n1 n1 in - fun x y r => - match x with - | W0 => (w_0,extend w_0W n1 r) - | WW xh xl => - let (rl,l) := mul_add xl y r in - let (rh,h) := mul_add xh y rl in - (rh, gen_WW w_WW n1 h l) - end - end. - - End GenMulAddn1. - - Section GenMulAddmn1. - Variable wn: Set. - Variable extend_n : w -> wn. - Variable wn_0W : wn -> zn2z wn. - Variable wn_WW : wn -> wn -> zn2z wn. - Variable w_mul_add_n1 : wn -> w -> w -> w*wn. - Fixpoint gen_mul_add_mn1 (m:nat) : - word wn m -> w -> w -> w*word wn m := - match m return word wn m -> w -> w -> w*word wn m with - | O => w_mul_add_n1 - | S m1 => - let mul_add := gen_mul_add_mn1 m1 in - fun x y r => - match x with - | W0 => (w_0,extend wn_0W m1 (extend_n r)) - | WW xh xl => - let (rl,l) := mul_add xl y r in - let (rh,h) := mul_add xh y rl in - (rh, gen_WW wn_WW m1 h l) - end - end. - - End GenMulAddmn1. - - Definition w_mul_add x y r := - match w_mul_c x y with - | W0 => (w_0, r) - | WW h l => - match w_add_c l r with - | C0 lr => (h,lr) - | C1 lr => (w_succ h, lr) - end - end. - - - (*Section GenProof. *) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Variable spec_more_than_1_digit: 1 < Zpos w_digits. - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. - Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB. - Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. - - Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Variable spec_ww_add_carry : - forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. - Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - - Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. - Proof. intros x;apply spec_ww_to_Z;auto. Qed. - - Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2. - Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed. - - Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult. - Ltac zarith := auto with zarith mult. - - Lemma wBwB_lex: forall a b c d, - a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> - a <= c. - Proof. - intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. - Qed. - - Lemma wBwB_lex_inv: forall a b c d, - a < c -> - a * wB^2 + [[b]] < c * wB^2 + [[d]]. - Proof. - intros a b c d H; apply beta_lex_inv; zarith. - Qed. - - Lemma sum_mul_carry : forall xh xl yh yl wc cc, - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> - 0 <= [|wc|] <= 1. - Proof. - intros. - apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith. - apply wB_pos. - Qed. - - Theorem mult_add_ineq: forall xH yH crossH, - 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. - Proof. - intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. - Qed. - - Hint Resolve mult_add_ineq : mult. - - Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, - [[hh]] = [|xh|] * [|yh|] -> - [[ll]] = [|xl|] * [|yl|] -> - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> - [||match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). - Proof. - intros;assert (U1 := wB_pos w_digits). - replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with - ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). - 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. - assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). - destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. - rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small; - rewrite wwB_wBwB. ring. - rewrite <- (Zplus_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith. - simpl ww_to_Z in H1. assert (U:=spec_to_Z cch). - assert ([|wc|]*wB + [|cch|] <= 2*wB - 3). - destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial. - assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2). - ring_simplify ((2*wB - 4)*wB + 2). - assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). - assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). - omega. - generalize H3;clear H3;rewrite <- H1. - rewrite Zplus_assoc; rewrite Zpower_2; rewrite Zmult_assoc; - rewrite <- Zmult_plus_distr_l. - assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). - apply Zmult_le_compat;zarith. - rewrite Zmult_plus_distr_l in H3. - intros. assert (U2 := spec_to_Z ccl);omega. - generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) - as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l; - simpl zn2z_to_Z; - try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW; - rewrite Zmod_small;rewrite wwB_wBwB;intros. - rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith. - rewrite Zplus_assoc;rewrite Zmult_plus_distr_l. - rewrite Zmult_1_l;rewrite <- Zplus_assoc;rewrite H4;ring. - repeat rewrite <- Zplus_assoc;rewrite H;apply mult_add_ineq2;zarith. - Qed. - - Lemma spec_gen_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w, - (forall xh xl yh yl hh ll, - [[hh]] = [|xh|]*[|yh|] -> - [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := cross xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> - forall x y, [||gen_mul_c cross x y||] = [[x]] * [[y]]. - Proof. - intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. - destruct y as [ |yh yl];simpl. rewrite Zmult_0_r;trivial. - assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl). - generalize (Hcross _ _ _ _ _ _ H1 H2). - destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc). - intros;apply spec_mul_aux;trivial. - rewrite <- wwB_wBwB;trivial. - Qed. - - Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. - Proof. - intros x y;unfold ww_mul_c;apply spec_gen_mul_c. - intros xh xl yh yl hh ll H1 H2. - generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)); - destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c]; - unfold interp_carry;repeat rewrite spec_w_mul_c;intros H; - (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring. - Qed. - - Lemma spec_w_2: [|w_2|] = 2. - unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl. - apply Zmod_small; split; auto with zarith. - rewrite <- (Zpower_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith. - Qed. - - Lemma kara_prod_aux : forall xh xl yh yl, - xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh. - Proof. intros;ring. Qed. - - Lemma spec_kara_prod : forall xh xl yh yl hh ll, - [[hh]] = [|xh|]*[|yh|] -> - [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := kara_prod xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. - Proof. - intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; - rewrite <- H; rewrite <- H0; unfold kara_prod. - assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); - assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). - generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); - intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). - generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh; - try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh. - rewrite Hylh; rewrite spec_w_0; try (ring; fail). - rewrite spec_w_0; try (ring; fail). - repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - split; auto with zarith. - simpl in Hz; rewrite Hz; rewrite H; rewrite H0. - rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith. - apply Zle_lt_trans with ([[z]]-0); auto with zarith. - unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive. - apply Zmult_le_0_compat; auto with zarith. - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh. - rewrite Hylh; rewrite spec_w_0; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; try (ring; fail). - repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - split. - match goal with |- context[(?x - ?y) * (?z - ?t)] => - replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] - end. - simpl in Hz; rewrite Hz; rewrite H; rewrite H0. - rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith. - apply Zle_lt_trans with ([[z]]-0); auto with zarith. - unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive. - apply Zmult_le_0_compat; auto with zarith. - (** there is a carry in hh + ll **) - rewrite Zmult_1_l. - generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh; - try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; - try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). - match goal with |- context[ww_sub_c ?x ?y] => - generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l. - generalize Hz2; clear Hz2; unfold interp_carry. - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_2; unfold interp_carry in Hz2. - apply trans_equal with (wwB + (1 * wwB + [[z1]])). - ring. - rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; - try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_2; unfold interp_carry in Hz2. - apply trans_equal with (wwB + (1 * wwB + [[z1]])). - ring. - rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - match goal with |- context[ww_sub_c ?x ?y] => - generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l. - match goal with |- context[(?x - ?y) * (?z - ?t)] => - replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] - end. - generalize Hz2; clear Hz2; unfold interp_carry. - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - Qed. - - Lemma sub_carry : forall xh xl yh yl z, - 0 <= z -> - [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> - z < wwB. - Proof. - intros xh xl yh yl z Hle Heq. - destruct (Z_le_gt_dec wwB z);auto with zarith. - generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). - generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). - rewrite <- wwB_wBwB;intros H1 H2. - assert (H3 := wB_pos w_digits). - assert (2*wB <= wwB). - rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith. - omega. - Qed. - - Ltac Spec_ww_to_Z x := - let H:= fresh "H" in - assert (H:= spec_ww_to_Z x). - - Ltac Zmult_lt_b x y := - let H := fresh "H" in - assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). - - Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]]. - Proof. - intros x y; unfold ww_karatsuba_c;apply spec_gen_mul_c. - intros; apply spec_kara_prod; auto. - Qed. - - Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB. - Proof. - assert (U:= lt_0_wB w_digits). - assert (U1:= lt_0_wwB w_digits). - intros x y; case x; auto; intros xh xl. - case y; auto. - simpl; rewrite Zmult_0_r; rewrite Zmod_small; auto with zarith. - intros yh yl;simpl. - repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c - || rewrite spec_w_add || rewrite spec_w_mul). - rewrite <- Zplus_mod; auto with zarith. - repeat (rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r). - rewrite <- Zmult_mod_distr_r; auto with zarith. - rewrite <- Zpower_2; rewrite <- wwB_wBwB; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_mod; auto with zarith. - rewrite <- Zplus_mod; auto with zarith. - match goal with |- ?X mod _ = _ => - rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|]) - end; auto with zarith. - f_equal; auto; rewrite wwB_wBwB; ring. - Qed. - - Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]]. - Proof. - destruct x as [ |xh xl];simpl;trivial. - case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end;intros wc cc Heq. - apply (spec_mul_aux xh xl xh xl wc cc);trivial. - generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq. - rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl)); - unfold interp_carry;try rewrite Zmult_1_l;intros Heq Heq';inversion Heq; - rewrite (Zmult_comm [|xl|]);subst. - rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l;trivial. - rewrite spec_w_1;rewrite Zmult_1_l;rewrite <- wwB_wBwB;trivial. - Qed. - - Section GenMulAddn1Proof. - - Variable w_mul_add : w -> w -> w -> w * w. - Variable spec_w_mul_add : forall x y r, - let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. - - Lemma spec_gen_mul_add_n1 : forall n x y r, - let (h,l) := gen_mul_add_n1 w_mul_add n x y r in - [|h|]*gen_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|]. - Proof. - induction n;intros x y r;trivial. - exact (spec_w_mul_add x y r). - unfold gen_mul_add_n1;destruct x as[ |xh xl]; - fold(gen_mul_add_n1 w_mul_add). - rewrite spec_w_0;rewrite spec_extend;simpl;trivial. - assert(H:=IHn xl y r);destruct (gen_mul_add_n1 w_mul_add n xl y r)as(rl,l). - assert(U:=IHn xh y rl);destruct(gen_mul_add_n1 w_mul_add n xh y rl)as(rh,h). - rewrite <- gen_wB_wwB. rewrite spec_gen_WW;simpl;trivial. - rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H. - rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - rewrite U;ring. - Qed. - - End GenMulAddn1Proof. - - Lemma spec_w_mul_add : forall x y r, - let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. - Proof. - intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); - destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. - rewrite spec_w_0;trivial. - assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold - interp_carry in U;try rewrite Zmult_1_l in H;simpl. - rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small. - rewrite <- Zplus_assoc;rewrite <- U;ring. - simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). - rewrite <- H in H1. - assert (H2:=spec_to_Z h);split;zarith. - case H1;clear H1;intro H1;clear H1. - replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring. - intros H0;assert (U1:= wB_pos w_digits). - assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith. - Qed. - -(* End GenProof. *) - -End GenMul. diff --git a/theories/Ints/num/GenSqrt.v b/theories/Ints/num/GenSqrt.v deleted file mode 100644 index 63a0930edc..0000000000 --- a/theories/Ints/num/GenSqrt.v +++ /dev/null @@ -1,1385 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section GenSqrt. - Variable w : Set. - Variable w_is_even : w -> bool. - Variable w_compare : w -> w -> comparison. - Variable w_0 : w. - Variable w_1 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_sub : w -> w -> w. - Variable w_sub_c : w -> w -> carry w. - Variable w_square_c : w -> zn2z w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable ww_zdigits : zn2z w. - Variable w_add_c : w -> w -> carry w. - Variable w_sqrt2 : w -> w -> w * carry w. - Variable w_pred : w -> w. - Variable ww_pred_c : zn2z w -> carry (zn2z w). - Variable ww_pred : zn2z w -> zn2z w. - Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add : zn2z w -> zn2z w -> zn2z w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. - Variable ww_head0 : zn2z w -> zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable low : zn2z w -> w. - - Let wwBm1 := ww_Bm1 w_Bm1. - - Definition ww_is_even x := - match x with - | W0 => true - | WW xh xl => w_is_even xl - end. - - Let w_div21c x y z := - match w_compare x z with - | Eq => - match w_compare y z with - Eq => (C1 w_1, w_0) - | Gt => (C1 w_1, w_sub y z) - | Lt => (C1 w_0, y) - end - | Gt => - let x1 := w_sub x z in - let (q, r) := w_div21 x1 y z in - (C1 q, r) - | Lt => - let (q, r) := w_div21 x y z in - (C0 q, r) - end. - - Let w_div2s x y s := - match x with - C1 x1 => - let x2 := w_sub x1 s in - let (q, r) := w_div21c x2 y s in - match q with - C0 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) - | C1 q1 => - if w_is_even q1 then - (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) - else - (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) - end - | C0 x1 => - let (q, r) := w_div21c x1 y s in - match q with - C0 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) - | C1 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) - end - end. - - Definition split x := - match x with - | W0 => (w_0,w_0) - | WW h l => (h,l) - end. - - Definition ww_sqrt2 x y := - let (x1, x2) := split x in - let (y1, y2) := split y in - let ( q, r) := w_sqrt2 x1 x2 in - let (q1, r1) := w_div2s r y1 q in - match q1 with - C0 q1 => - let q2 := w_square_c q1 in - let a := WW q q1 in - match r1 with - C1 r2 => - match ww_sub_c (WW r2 y2) q2 with - C0 r3 => (a, C1 r3) - | C1 r3 => (a, C0 r3) - end - | C0 r2 => - match ww_sub_c (WW r2 y2) q2 with - C0 r3 => (a, C0 r3) - | C1 r3 => - let a2 := ww_add_mul_div (w_0W w_1) a W0 in - match ww_pred_c a2 with - C0 a3 => - (ww_pred a, ww_add_c a3 r3) - | C1 a3 => - (ww_pred a, C0 (ww_add a3 r3)) - end - end - end - | C1 q1 => - let a1 := WW q w_Bm1 in - let a2 := ww_add_mul_div (w_0W w_1) a1 wwBm1 in - (a1, ww_add_c a2 y) - end. - - Definition ww_is_zero x := - match ww_compare W0 x with - Eq => true - | _ => false - end. - - Definition ww_head1 x := - let p := ww_head0 x in - if (ww_is_even p) then p else ww_pred p. - - Definition ww_sqrt x := - if (ww_is_zero x) then W0 - else - let p := ww_head1 x in - match ww_compare p W0 with - | Gt => - match ww_add_mul_div p x W0 with - W0 => W0 - | WW x1 x2 => - let (r, _) := w_sqrt2 x1 x2 in - WW w_0 (w_add_mul_div - (w_sub w_zdigits - (low (ww_add_mul_div (ww_pred ww_zdigits) - W0 p))) w_0 r) - end - | _ => - match x with - W0 => W0 - | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) - end - end. - - - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_zdigits : [|w_zdigits|] = Zpos w_digits. - Variable spec_more_than_1_digit: 1 < Zpos w_digits. - - Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos (xO w_digits). - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_is_even : forall x, - if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. - Variable spec_w_compare : forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. - Variable spec_w_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_w_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (Zpower 2 ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^ [[p]]) + - [[y]] / (2^ (Zpos (xO w_digits) - [[p]]))) mod wwB. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Variable spec_w_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := w_sqrt2 x y in - [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - Variable spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. - Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Variable spec_ww_compare : forall x y, - match ww_compare x y with - | Eq => [[x]] = [[y]] - | Lt => [[x]] < [[y]] - | Gt => [[x]] > [[y]] - end. - Variable spec_ww_head0 : forall x, 0 < [[x]] -> - wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. - Variable spec_low: forall x, [|low x|] = [[x]] mod wB. - - Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - - - Hint Rewrite spec_w_0 spec_w_1 w_Bm1 spec_w_WW spec_w_sub - spec_w_div21 spec_w_add_mul_div spec_ww_Bm1 - spec_w_add_c spec_w_sqrt2: w_rewrite. - - Lemma spec_ww_is_even : forall x, - if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. -clear spec_more_than_1_digit. -intros x; case x; simpl ww_is_even. - simpl. - rewrite Zmod_small; auto with zarith. - intros w1 w2; simpl. - unfold base. - rewrite Zplus_mod; auto with zarith. - rewrite (fun x y => (Zdivide_mod (x * y))); auto with zarith. - rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. - apply spec_w_is_even; auto with zarith. - apply Zdivide_mult_r; apply Zpower_divide; auto with zarith. - red; simpl; auto. - Qed. - - - Theorem spec_w_div21c : forall a1 a2 b, - wB/2 <= [|b|] -> - let (q,r) := w_div21c a1 a2 b in - [|a1|] * wB + [|a2|] = [+|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. - intros a1 a2 b Hb; unfold w_div21c. - assert (H: 0 < [|b|]); auto with zarith. - assert (U := wB_pos w_digits). - apply Zlt_le_trans with (2 := Hb); auto with zarith. - apply Zlt_le_trans with 1; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - repeat match goal with |- context[w_compare ?y ?z] => - generalize (spec_w_compare y z); - case (w_compare y z) - end. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H1; rewrite H2; ring. - autorewrite with w_rewrite; auto with zarith. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H2; ring. - destruct (spec_to_Z a2);auto with zarith. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H2; rewrite Zmod_small; auto with zarith. - ring. - destruct (spec_to_Z a2);auto with zarith. - rewrite spec_w_sub; auto with zarith. - destruct (spec_to_Z a2) as [H3 H4];auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - assert ([|a2|] < 2 * [|b|]); auto with zarith. - apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - intros H1. - match goal with |- context[w_div21 ?y ?z ?t] => - generalize (@spec_w_div21 y z t Hb H1); - case (w_div21 y z t); simpl; autorewrite with w_rewrite; - auto - end. - intros H1. - assert (H2: [|w_sub a1 b|] < [|b|]). - rewrite spec_w_sub; auto with zarith. - rewrite Zmod_small; auto with zarith. - assert ([|a1|] < 2 * [|b|]); auto with zarith. - apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - destruct (spec_to_Z a1);auto with zarith. - destruct (spec_to_Z a1);auto with zarith. - match goal with |- context[w_div21 ?y ?z ?t] => - generalize (@spec_w_div21 y z t Hb H2); - case (w_div21 y z t); autorewrite with w_rewrite; - auto - end. - intros w0 w1; replace [+|C1 w0|] with (wB + [|w0|]). - rewrite Zmod_small; auto with zarith. - intros (H3, H4); split; auto. - rewrite Zmult_plus_distr_l. - rewrite <- Zplus_assoc; rewrite <- H3; ring. - split; auto with zarith. - assert ([|a1|] < 2 * [|b|]); auto with zarith. - apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - destruct (spec_to_Z a1);auto with zarith. - destruct (spec_to_Z a1);auto with zarith. - simpl; case wB; auto. - Qed. - - Theorem C0_id: forall p, [+|C0 p|] = [|p|]. - intros p; simpl; auto. - Qed. - - Theorem add_mult_div_2: forall w, - [|w_add_mul_div (w_pred w_zdigits) w_0 w|] = [|w|] / 2. - intros w1. - assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). - rewrite spec_pred; rewrite spec_w_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zlt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite spec_w_add_mul_div; auto with zarith. - autorewrite with w_rewrite rm10. - match goal with |- context[?X - ?Y] => - replace (X - Y) with 1 - end. - rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. - destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite Hp; ring. - Qed. - - Theorem add_mult_div_2_plus_1: forall w, - [|w_add_mul_div (w_pred w_zdigits) w_1 w|] = - [|w|] / 2 + 2 ^ Zpos (w_digits - 1). - intros w1. - assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). - rewrite spec_pred; rewrite spec_w_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zlt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - autorewrite with w_rewrite rm10; auto with zarith. - match goal with |- context[?X - ?Y] => - replace (X - Y) with 1 - end; rewrite Hp; try ring. - rewrite Zpos_minus; auto with zarith. - rewrite Zmax_right; auto with zarith. - rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. - destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - unfold base. - match goal with |- _ < _ ^ ?X => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp - end. - rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith. - assert (tmp: forall p, 1 + (p -1) - 1 = p - 1); auto with zarith; - rewrite tmp; clear tmp; auto with zarith. - match goal with |- ?X + ?Y < _ => - assert (Y < X); auto with zarith - end. - apply Zdiv_lt_upper_bound; auto with zarith. - pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; - auto with zarith. - assert (tmp: forall p, (p - 1) + 1 = p); auto with zarith; - rewrite tmp; clear tmp; auto with zarith. - Qed. - - Theorem add_mult_mult_2: forall w, - [|w_add_mul_div w_1 w w_0|] = 2 * [|w|] mod wB. - intros w1. - autorewrite with w_rewrite rm10; auto with zarith. - rewrite Zpower_1_r; auto with zarith. - rewrite Zmult_comm; auto. - Qed. - - Theorem ww_add_mult_mult_2: forall w, - [[ww_add_mul_div (w_0W w_1) w W0]] = 2 * [[w]] mod wwB. - intros w1. - rewrite spec_ww_add_mul_div; auto with zarith. - autorewrite with w_rewrite rm10. - rewrite spec_w_0W; rewrite spec_w_1. - rewrite Zpower_1_r; auto with zarith. - rewrite Zmult_comm; auto. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - red; simpl; intros; discriminate. - Qed. - - Theorem ww_add_mult_mult_2_plus_1: forall w, - [[ww_add_mul_div (w_0W w_1) w wwBm1]] = - (2 * [[w]] + 1) mod wwB. - intros w1. - rewrite spec_ww_add_mul_div; auto with zarith. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - rewrite Zpower_1_r; auto with zarith. - f_equal; auto. - rewrite Zmult_comm; f_equal; auto. - autorewrite with w_rewrite rm10. - unfold ww_digits, base. - apply sym_equal; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1); - auto with zarith. - unfold ww_digits; split; auto with zarith. - match goal with |- 0 <= ?X - 1 => - assert (0 < X); auto with zarith - end. - apply Zpower_gt_0; auto with zarith. - match goal with |- 0 <= ?X - 1 => - assert (0 < X); auto with zarith; red; reflexivity - end. - unfold ww_digits; autorewrite with rm10. - assert (tmp: forall p q r, p + (q - r) = p + q - r); auto with zarith; - rewrite tmp; clear tmp. - assert (tmp: forall p, p + p = 2 * p); auto with zarith; - rewrite tmp; clear tmp. - f_equal; auto. - pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; - auto with zarith. - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite tmp; clear tmp; auto. - match goal with |- ?X - 1 >= 0 => - assert (0 < X); auto with zarith; red; reflexivity - end. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - red; simpl; intros; discriminate. - Qed. - - Theorem Zplus_mod_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1. - intros a1 b1 H; rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_same; try rewrite Zplus_0_r; auto with zarith. - apply Zmod_mod; auto. - Qed. - - Lemma C1_plus_wB: forall x, [+|C1 x|] = wB + [|x|]. - unfold interp_carry; auto with zarith. - Qed. - - Theorem spec_w_div2s : forall a1 a2 b, - wB/2 <= [|b|] -> [+|a1|] <= 2 * [|b|] -> - let (q,r) := w_div2s a1 a2 b in - [+|a1|] * wB + [|a2|] = [+|q|] * (2 * [|b|]) + [+|r|] /\ 0 <= [+|r|] < 2 * [|b|]. - intros a1 a2 b H. - assert (HH: 0 < [|b|]); auto with zarith. - assert (U := wB_pos w_digits). - apply Zlt_le_trans with (2 := H); auto with zarith. - apply Zlt_le_trans with 1; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - unfold w_div2s; case a1; intros w0 H0. - match goal with |- context[w_div21c ?y ?z ?t] => - generalize (@spec_w_div21c y z t H); - case (w_div21c y z t); autorewrite with w_rewrite; - auto - end. - intros c w1; case c. - simpl interp_carry; intros w2 (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - rewrite add_mult_div_2. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - repeat rewrite C0_id. - rewrite add_mult_div_2. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - intros w2; rewrite C1_plus_wB. - intros (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1. - repeat rewrite C0_id. - rewrite add_mult_div_2_plus_1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Zpower_1_r; auto with zarith - end. - rewrite Zpos_minus; auto with zarith. - rewrite Zmax_right; auto with zarith. - ring. - repeat rewrite C0_id. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite add_mult_div_2_plus_1. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1. - unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Zpower_1_r; auto with zarith - end. - rewrite Zpos_minus; auto with zarith. - rewrite Zmax_right; auto with zarith. - ring. - repeat rewrite C1_plus_wB in H0. - rewrite C1_plus_wB. - match goal with |- context[w_div21c ?y ?z ?t] => - generalize (@spec_w_div21c y z t H); - case (w_div21c y z t); autorewrite with w_rewrite; - auto - end. - intros c w1; case c. - intros w2 (Hw1, Hw2); rewrite C0_id in Hw1. - rewrite <- Zplus_mod_one in Hw1; auto with zarith. - rewrite Zmod_small in Hw1; auto with zarith. - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - intros H1; split; auto with zarith. - rewrite add_mult_div_2_plus_1. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Zpower_1_r; auto with zarith - end. - rewrite Zpos_minus; auto with zarith. - rewrite Zmax_right; auto with zarith. - ring. - repeat rewrite C0_id. - rewrite add_mult_div_2_plus_1. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Zpower_1_r; auto with zarith - end. - rewrite Zpos_minus; auto with zarith. - rewrite Zmax_right; auto with zarith. - ring. - split; auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - intros w2; rewrite C1_plus_wB. - rewrite <- Zplus_mod_one; auto with zarith. - rewrite Zmod_small; auto with zarith. - intros (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros H1; split; auto with zarith. - rewrite add_mult_div_2. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - repeat (rewrite C0_id || rewrite C1_plus_wB). - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite add_mult_div_2. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - split; auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - Qed. - - Theorem wB_div_4: 4 * (wB / 4) = wB. - Proof. - unfold base. - assert (2 ^ Zpos w_digits = - 4 * (2 ^ (Zpos w_digits - 2))). - change 4 with (2 ^ 2). - rewrite <- Zpower_exp; auto with zarith. - f_equal; auto with zarith. - rewrite H. - rewrite (fun x => (Zmult_comm 4 (2 ^x))). - rewrite Z_div_mult; auto with zarith. - Qed. - - Theorem Zsquare_mult: forall p, p ^ 2 = p * p. - intros p; change 2 with (1 + 1); rewrite Zpower_exp; - try rewrite Zpower_1_r; auto with zarith. - Qed. - - Theorem Zsquare_pos: forall p, 0 <= p ^ 2. - intros p; case (Zle_or_lt 0 p); intros H1. - rewrite Zsquare_mult; apply Zmult_le_0_compat; auto with zarith. - rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. - apply Zmult_le_0_compat; auto with zarith. - Qed. - - Lemma spec_split: forall x, - [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. - intros x; case x; simpl; autorewrite with w_rewrite; - auto with zarith. - Qed. - - Theorem mult_wwB: forall x y, [|x|] * [|y|] < wwB. - Proof. - intros x y; rewrite wwB_wBwB; rewrite Zpower_2. - generalize (spec_to_Z x); intros U. - generalize (spec_to_Z y); intros U1. - apply Zle_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith. - apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_r || rewrite Zmult_minus_distr_l); - auto with zarith. - Qed. - Hint Resolve mult_wwB. - - Lemma spec_ww_sqrt2 : forall x y, - wwB/ 4 <= [[x]] -> - let (s,r) := ww_sqrt2 x y in - [||WW x y||] = [[s]] ^ 2 + [+[r]] /\ - [+[r]] <= 2 * [[s]]. - intros x y H; unfold ww_sqrt2. - repeat match goal with |- context[split ?x] => - generalize (spec_split x); case (split x) - end; simpl fst; simpl snd. - intros w0 w1 Hw0 w2 w3 Hw1. - assert (U: wB/4 <= [|w2|]). - case (Zle_or_lt (wB / 4) [|w2|]); auto; intros H1. - contradict H; apply Zlt_not_le. - rewrite wwB_wBwB; rewrite Zpower_2. - pattern wB at 1; rewrite <- wB_div_4; rewrite <- Zmult_assoc; - rewrite Zmult_comm. - rewrite Z_div_mult; auto with zarith. - rewrite <- Hw1. - match goal with |- _ < ?X => - pattern X; rewrite <- Zplus_0_r; apply beta_lex_inv; - auto with zarith - end. - destruct (spec_to_Z w3);auto with zarith. - generalize (@spec_w_sqrt2 w2 w3 U); case (w_sqrt2 w2 w3). - intros w4 c (H1, H2). - assert (U1: wB/2 <= [|w4|]). - case (Zle_or_lt (wB/2) [|w4|]); auto with zarith. - intros U1. - assert (U2 : [|w4|] <= wB/2 -1); auto with zarith. - assert (U3 : [|w4|] ^ 2 <= wB/4 * wB - wB + 1); auto with zarith. - match goal with |- ?X ^ 2 <= ?Y => - rewrite Zsquare_mult; - replace Y with ((wB/2 - 1) * (wB/2 -1)) - end. - apply Zmult_le_compat; auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - pattern wB at 4 5; rewrite <- wB_div_2. - rewrite Zmult_assoc. - replace ((wB / 4) * 2) with (wB / 2). - ring. - pattern wB at 1; rewrite <- wB_div_4. - change 4 with (2 * 2). - rewrite <- Zmult_assoc; rewrite (Zmult_comm 2). - rewrite Z_div_mult; try ring; auto with zarith. - assert (U4 : [+|c|] <= wB -2); auto with zarith. - apply Zle_trans with (1 := H2). - match goal with |- ?X <= ?Y => - replace Y with (2 * (wB/ 2 - 1)); auto with zarith - end. - pattern wB at 2; rewrite <- wB_div_2; auto with zarith. - match type of H1 with ?X = _ => - assert (U5: X < wB / 4 * wB) - end. - rewrite H1; auto with zarith. - contradict U; apply Zlt_not_le. - apply Zmult_lt_reg_r with wB; auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - apply Zle_lt_trans with (2 := U5). - unfold ww_to_Z, zn2z_to_Z. - destruct (spec_to_Z w3);auto with zarith. - generalize (@spec_w_div2s c w0 w4 U1 H2). - case (w_div2s c w0 w4). - intros c0; case c0; intros w5; - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros c1; case c1; intros w6; - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros (H3, H4). - match goal with |- context [ww_sub_c ?y ?z] => - generalize (spec_ww_sub_c y z); case (ww_sub_c y z) - end. - intros z; change [-[C0 z]] with ([[z]]). - change [+[C0 z]] with ([[z]]). - intros H5; rewrite spec_w_square_c in H5; - auto. - split. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite H5. - unfold ww_to_Z, zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - rewrite H5. - unfold ww_to_Z, zn2z_to_Z. - match goal with |- ?X - ?Y * ?Y <= _ => - assert (V := Zsquare_pos Y); - rewrite Zsquare_mult in V; - apply Zle_trans with X; auto with zarith; - clear V - end. - match goal with |- ?X * wB + ?Y <= 2 * (?Z * wB + ?T) => - apply Zle_trans with ((2 * Z - 1) * wB + wB); auto with zarith - end. - destruct (spec_to_Z w1);auto with zarith. - match goal with |- ?X <= _ => - replace X with (2 * [|w4|] * wB); auto with zarith - end. - rewrite Zmult_plus_distr_r; rewrite Zmult_assoc. - destruct (spec_to_Z w5); auto with zarith. - ring. - intros z; replace [-[C1 z]] with (- wwB + [[z]]). - 2: simpl; case wwB; auto with zarith. - intros H5; rewrite spec_w_square_c in H5; - auto. - match goal with |- context [ww_pred_c ?y] => - generalize (spec_ww_pred_c y); case (ww_pred_c y) - end. - intros z1; change [-[C0 z1]] with ([[z1]]). - rewrite ww_add_mult_mult_2. - rewrite spec_ww_add_c. - rewrite spec_ww_pred. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); - auto with zarith. - intros Hz1; rewrite Zmod_small; auto with zarith. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - split. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - rewrite Hz1. - unfold ww_to_Z; simpl zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - rewrite Hz1. - destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)). - assert (0 < [[WW w4 w5]]); auto with zarith. - apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith. - autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. - apply Zmult_lt_reg_r with 2; auto with zarith. - autorewrite with rm10. - rewrite Zmult_comm; rewrite wB_div_2; auto with zarith. - case (spec_to_Z w5);auto with zarith. - case (spec_to_Z w5);auto with zarith. - simpl. - assert (V2 := spec_to_Z w5);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. - split; auto with zarith. - assert (wwB <= 2 * [[WW w4 w5]]); auto with zarith. - apply Zle_trans with (2 * ([|w4|] * wB)). - rewrite wwB_wBwB; rewrite Zpower_2. - rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. - rewrite <- wB_div_2; auto with zarith. - assert (V2 := spec_to_Z w5);auto with zarith. - simpl ww_to_Z; assert (V2 := spec_to_Z w5);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. - intros z1; change [-[C1 z1]] with (-wwB + [[z1]]). - match goal with |- context[([+[C0 ?z]])] => - change [+[C0 z]] with ([[z]]) - end. - rewrite spec_ww_add; auto with zarith. - rewrite spec_ww_pred; auto with zarith. - rewrite ww_add_mult_mult_2. - rename V1 into VV1. - assert (VV2: 0 < [[WW w4 w5]]); auto with zarith. - apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith. - autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. - apply Zmult_lt_reg_r with 2; auto with zarith. - autorewrite with rm10. - rewrite Zmult_comm; rewrite wB_div_2; auto with zarith. - assert (VV3 := spec_to_Z w5);auto with zarith. - assert (VV3 := spec_to_Z w5);auto with zarith. - simpl. - assert (VV3 := spec_to_Z w5);auto with zarith. - assert (VV3: wwB <= 2 * [[WW w4 w5]]); auto with zarith. - apply Zle_trans with (2 * ([|w4|] * wB)). - rewrite wwB_wBwB; rewrite Zpower_2. - rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. - rewrite <- wB_div_2; auto with zarith. - case (spec_to_Z w5);auto with zarith. - simpl ww_to_Z; assert (V4 := spec_to_Z w5);auto with zarith. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); - auto with zarith. - intros Hz1; rewrite Zmod_small; auto with zarith. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - match type of Hz1 with -?X + ?Y = -?X + ?Z - 1 => - assert (V1: Y = Z - 1); - [replace (Z - 1) with (X + (-X + Z -1)); - [rewrite <- Hz1 | idtac]; ring - | idtac] - end. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + [[z1]] + [[z]]); - auto with zarith. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - split. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - rewrite Hz1. - unfold ww_to_Z; simpl zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V3 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z1);auto with zarith. - split; auto with zarith. - rewrite (Zplus_comm (-wwB)); rewrite <- Zplus_assoc. - rewrite H5. - match goal with |- 0 <= ?X + (?Y - ?Z) => - apply Zle_trans with (X - Z); auto with zarith - end. - 2: generalize (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w6 w1)); unfold ww_to_Z; auto with zarith. - rewrite V1. - match goal with |- 0 <= ?X - 1 - ?Y => - assert (Y < X); auto with zarith - end. - apply Zlt_le_trans with wwB; auto with zarith. - intros (H3, H4). - match goal with |- context [ww_sub_c ?y ?z] => - generalize (spec_ww_sub_c y z); case (ww_sub_c y z) - end. - intros z; change [-[C0 z]] with ([[z]]). - match goal with |- context[([+[C1 ?z]])] => - replace [+[C1 z]] with (wwB + [[z]]) - end. - 2: simpl; case wwB; auto. - intros H5; rewrite spec_w_square_c in H5; - auto. - split. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite H5. - unfold ww_to_Z; simpl zn2z_to_Z. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - simpl ww_to_Z. - rewrite H5. - simpl ww_to_Z. - rewrite wwB_wBwB; rewrite Zpower_2. - match goal with |- ?X * ?Y + (?Z * ?Y + ?T - ?U) <= _ => - apply Zle_trans with (X * Y + (Z * Y + T - 0)); - auto with zarith - end. - assert (V := Zsquare_pos [|w5|]); - rewrite Zsquare_mult in V; auto with zarith. - autorewrite with rm10. - match goal with |- _ <= 2 * (?U * ?V + ?W) => - apply Zle_trans with (2 * U * V + 0); - auto with zarith - end. - match goal with |- ?X * ?Y + (?Z * ?Y + ?T) <= _ => - replace (X * Y + (Z * Y + T)) with ((X + Z) * Y + T); - try ring - end. - apply Zlt_le_weak; apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w1);auto with zarith. - destruct (spec_to_Z w5);auto with zarith. - rewrite Zmult_plus_distr_r; auto with zarith. - rewrite Zmult_assoc; auto with zarith. - intros z; replace [-[C1 z]] with (- wwB + [[z]]). - 2: simpl; case wwB; auto with zarith. - intros H5; rewrite spec_w_square_c in H5; - auto. - match goal with |- context[([+[C0 ?z]])] => - change [+[C0 z]] with ([[z]]) - end. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - simpl ww_to_Z. - rewrite <- Hw1. - simpl ww_to_Z in H1; rewrite H1. - rewrite <- Hw0. - split. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - simpl ww_to_Z. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - rewrite V. - simpl ww_to_Z. - rewrite wwB_wBwB; rewrite Zpower_2. - match goal with |- (?Z * ?Y + ?T - ?U) + ?X * ?Y <= _ => - apply Zle_trans with ((Z * Y + T - 0) + X * Y); - auto with zarith - end. - assert (V1 := Zsquare_pos [|w5|]); - rewrite Zsquare_mult in V1; auto with zarith. - autorewrite with rm10. - match goal with |- _ <= 2 * (?U * ?V + ?W) => - apply Zle_trans with (2 * U * V + 0); - auto with zarith - end. - match goal with |- (?Z * ?Y + ?T) + ?X * ?Y <= _ => - replace ((Z * Y + T) + X * Y) with ((X + Z) * Y + T); - try ring - end. - apply Zlt_le_weak; apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w1);auto with zarith. - destruct (spec_to_Z w5);auto with zarith. - rewrite Zmult_plus_distr_r; auto with zarith. - rewrite Zmult_assoc; auto with zarith. - case Zle_lt_or_eq with (1 := H2); clear H2; intros H2. - intros c1 (H3, H4). - match type of H3 with ?X = ?Y => - absurd (X < Y) - end. - apply Zle_not_lt; rewrite <- H3; auto with zarith. - rewrite Zmult_plus_distr_l. - apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); - auto with zarith. - apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - assert (V1 := spec_to_Z w5);auto with zarith. - rewrite (Zmult_comm wB); auto with zarith. - assert (0 <= [|w5|] * (2 * [|w4|])); auto with zarith. - intros c1 (H3, H4); rewrite H2 in H3. - match type of H3 with ?X + ?Y = (?Z + ?T) * ?U + ?V => - assert (VV: (Y = (T * U) + V)); - [replace Y with ((X + Y) - X); - [rewrite H3; ring | ring] | idtac] - end. - assert (V1 := spec_to_Z w0);auto with zarith. - assert (V2 := spec_to_Z w5);auto with zarith. - case (Zle_lt_or_eq 0 [|w5|]); auto with zarith; intros V3. - match type of VV with ?X = ?Y => - absurd (X < Y) - end. - apply Zle_not_lt; rewrite <- VV; auto with zarith. - apply Zlt_le_trans with wB; auto with zarith. - match goal with |- _ <= ?X + _ => - apply Zle_trans with X; auto with zarith - end. - match goal with |- _ <= _ * ?X => - apply Zle_trans with (1 * X); auto with zarith - end. - autorewrite with rm10. - rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. - rewrite <- V3 in VV; generalize VV; autorewrite with rm10; - clear VV; intros VV. - rewrite spec_ww_add_c; auto with zarith. - rewrite ww_add_mult_mult_2_plus_1. - match goal with |- context[?X mod wwB] => - rewrite <- Zmod_unique with (q := 1) (r := -wwB + X) - end; auto with zarith. - simpl ww_to_Z. - rewrite spec_w_Bm1; auto with zarith. - split. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - rewrite <- Hw1. - simpl ww_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H2. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. - simpl ww_to_Z; unfold ww_to_Z. - rewrite spec_w_Bm1; auto with zarith. - split. - rewrite wwB_wBwB; rewrite Zpower_2. - match goal with |- _ <= -?X + (2 * (?Z * ?T + ?U) + ?V) => - assert (X <= 2 * Z * T); auto with zarith - end. - apply Zmult_le_compat_r; auto with zarith. - rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. - rewrite Zmult_plus_distr_r; auto with zarith. - rewrite Zmult_assoc; auto with zarith. - match goal with |- _ + ?X < _ => - replace X with ((2 * (([|w4|]) + 1) * wB) - 1); try ring - end. - assert (2 * ([|w4|] + 1) * wB <= 2 * wwB); auto with zarith. - rewrite <- Zmult_assoc; apply Zmult_le_compat_l; auto with zarith. - rewrite wwB_wBwB; rewrite Zpower_2. - apply Zmult_le_compat_r; auto with zarith. - case (spec_to_Z w4);auto with zarith. - Qed. - - Lemma spec_ww_is_zero: forall x, - if ww_is_zero x then [[x]] = 0 else 0 < [[x]]. - intro x; unfold ww_is_zero. - generalize (spec_ww_compare W0 x); case (ww_compare W0 x); - auto with zarith. - simpl ww_to_Z. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. - Qed. - - Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. - pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2. - rewrite <- wB_div_2. - match goal with |- context[(2 * ?X) * (2 * ?Z)] => - replace ((2 * X) * (2 * Z)) with ((X * Z) * 4); try ring - end. - rewrite Z_div_mult; auto with zarith. - rewrite Zmult_assoc; rewrite wB_div_2. - rewrite wwB_div_2; ring. - Qed. - - - Lemma spec_ww_head1 - : forall x : zn2z w, - (ww_is_even (ww_head1 x) = true) /\ - (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB). - assert (U := wB_pos w_digits). - intros x; unfold ww_head1. - generalize (spec_ww_is_even (ww_head0 x)); case_eq (ww_is_even (ww_head0 x)). - intros HH H1; rewrite HH; split; auto. - intros H2. - generalize (spec_ww_head0 x H2); case (ww_head0 x); autorewrite with rm10. - intros (H3, H4); split; auto with zarith. - apply Zle_trans with (2 := H3). - apply Zdiv_le_compat_l; auto with zarith. - intros xh xl (H3, H4); split; auto with zarith. - apply Zle_trans with (2 := H3). - apply Zdiv_le_compat_l; auto with zarith. - intros H1. - case (spec_to_w_Z (ww_head0 x)); intros Hv1 Hv2. - assert (Hp0: 0 < [[ww_head0 x]]). - generalize (spec_ww_is_even (ww_head0 x)); rewrite H1. - generalize Hv1; case [[ww_head0 x]]. - rewrite Zmod_small; auto with zarith. - intros; assert (0 < Zpos p); auto with zarith. - red; simpl; auto. - intros p H2; case H2; auto. - assert (Hp: [[ww_pred (ww_head0 x)]] = [[ww_head0 x]] - 1). - rewrite spec_ww_pred. - rewrite Zmod_small; auto with zarith. - intros H2; split. - generalize (spec_ww_is_even (ww_pred (ww_head0 x))); - case ww_is_even; auto. - rewrite Hp. - rewrite Zminus_mod; auto with zarith. - rewrite H2; repeat rewrite Zmod_small; auto with zarith. - intros H3; rewrite Hp. - case (spec_ww_head0 x); auto; intros Hv3 Hv4. - assert (Hu: forall u, 0 < u -> 2 * 2 ^ (u - 1) = 2 ^u). - intros u Hu. - pattern 2 at 1; rewrite <- Zpower_1_r. - rewrite <- Zpower_exp; auto with zarith. - ring_simplify (1 + (u - 1)); auto with zarith. - split; auto with zarith. - apply Zmult_le_reg_r with 2; auto with zarith. - repeat rewrite (fun x => Zmult_comm x 2). - rewrite wwB_4_2. - rewrite Zmult_assoc; rewrite Hu; auto with zarith. - apply Zle_lt_trans with (2 * 2 ^ ([[ww_head0 x]] - 1) * [[x]]); auto with zarith; - rewrite Hu; auto with zarith. - apply Zmult_le_compat_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - Qed. - - Theorem wwB_4_wB_4: wwB / 4 = wB / 4 * wB. - apply sym_equal; apply Zdiv_unique with 0; - auto with zarith. - rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith. - rewrite wwB_wBwB; ring. - Qed. - - Lemma spec_ww_sqrt : forall x, - [[ww_sqrt x]] ^ 2 <= [[x]] < ([[ww_sqrt x]] + 1) ^ 2. - assert (U := wB_pos w_digits). - intro x; unfold ww_sqrt. - generalize (spec_ww_is_zero x); case (ww_is_zero x). - simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl; - auto with zarith. - intros H1. - generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare; - simpl ww_to_Z; autorewrite with rm10. - generalize H1; case x. - intros HH; contradict HH; simpl ww_to_Z; auto with zarith. - intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. - intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. - generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10. - intros (H4, H5). - assert (V: wB/4 <= [|w0|]). - apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. - rewrite <- wwB_4_wB_4; auto. - generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. - case (w_sqrt2 w0 w1); intros w2 c. - simpl ww_to_Z; simpl fst. - case c; unfold interp_carry; autorewrite with rm10. - intros w3 (H6, H7); rewrite H6. - assert (V1 := spec_to_Z w3);auto with zarith. - split; auto with zarith. - apply Zle_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. - match goal with |- ?X < ?Z => - replace Z with (X + 1); auto with zarith - end. - repeat rewrite Zsquare_mult; ring. - intros w3 (H6, H7); rewrite H6. - assert (V1 := spec_to_Z w3);auto with zarith. - split; auto with zarith. - apply Zle_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. - match goal with |- ?X < ?Z => - replace Z with (X + 1); auto with zarith - end. - repeat rewrite Zsquare_mult; ring. - intros HH; case (spec_to_w_Z (ww_head1 x)); auto with zarith. - intros Hv1. - case (spec_ww_head1 x); intros Hp1 Hp2. - generalize (Hp2 H1); clear Hp2; intros Hp2. - assert (Hv2: [[ww_head1 x]] <= Zpos (xO w_digits)). - case (Zle_or_lt (Zpos (xO w_digits)) [[ww_head1 x]]); auto with zarith; intros HH1. - case Hp2; intros _ HH2; contradict HH2. - apply Zle_not_lt; unfold base. - apply Zle_trans with (2 ^ [[ww_head1 x]]). - apply Zpower_le_monotone; auto with zarith. - pattern (2 ^ [[ww_head1 x]]) at 1; - rewrite <- (Zmult_1_r (2 ^ [[ww_head1 x]])). - apply Zmult_le_compat_l; auto with zarith. - generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2); - case ww_add_mul_div. - simpl ww_to_Z; autorewrite with w_rewrite rm10. - rewrite Zmod_small; auto with zarith. - intros H2; case (Zmult_integral _ _ (sym_equal H2)); clear H2; intros H2. - rewrite H2; unfold Zpower, Zpower_pos; simpl; auto with zarith. - match type of H2 with ?X = ?Y => - absurd (Y < X); try (rewrite H2; auto with zarith; fail) - end. - apply Zpower_gt_0; auto with zarith. - split; auto with zarith. - case Hp2; intros _ tmp; apply Zle_lt_trans with (2 := tmp); - clear tmp. - rewrite Zmult_comm; apply Zmult_le_compat_r; auto with zarith. - assert (Hv0: [[ww_head1 x]] = 2 * ([[ww_head1 x]]/2)). - pattern [[ww_head1 x]] at 1; rewrite (Z_div_mod_eq [[ww_head1 x]] 2); - auto with zarith. - generalize (spec_ww_is_even (ww_head1 x)); rewrite Hp1; - intros tmp; rewrite tmp; rewrite Zplus_0_r; auto. - intros w0 w1; autorewrite with w_rewrite rm10. - rewrite Zmod_small; auto with zarith. - 2: rewrite Zmult_comm; auto with zarith. - intros H2. - assert (V: wB/4 <= [|w0|]). - apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. - simpl ww_to_Z in H2; rewrite H2. - rewrite <- wwB_4_wB_4; auto with zarith. - rewrite Zmult_comm; auto with zarith. - assert (V1 := spec_to_Z w1);auto with zarith. - generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. - case (w_sqrt2 w0 w1); intros w2 c. - case (spec_to_Z w2); intros HH1 HH2. - simpl ww_to_Z; simpl fst. - assert (Hv3: [[ww_pred ww_zdigits]] - = Zpos (xO w_digits) - 1). - rewrite spec_ww_pred; rewrite spec_ww_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zlt_le_trans with (Zpos (xO w_digits)); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - assert (Hv4: [[ww_head1 x]]/2 < wB). - apply Zle_lt_trans with (Zpos w_digits). - apply Zmult_le_reg_r with 2; auto with zarith. - repeat rewrite (fun x => Zmult_comm x 2). - rewrite <- Hv0; rewrite <- Zpos_xO; auto. - unfold base; apply Zpower2_lt_lin; auto with zarith. - assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]] - = [[ww_head1 x]]/2). - rewrite spec_ww_add_mul_div. - simpl ww_to_Z; autorewrite with rm10. - rewrite Hv3. - ring_simplify (Zpos (xO w_digits) - (Zpos (xO w_digits) - 1)). - rewrite Zpower_1_r. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Zlt_le_trans with (1 := Hv4); auto with zarith. - unfold base; apply Zpower_le_monotone; auto with zarith. - split; unfold ww_digits; try rewrite Zpos_xO; auto with zarith. - rewrite Hv3; auto with zarith. - assert (Hv6: [|low(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))|] - = [[ww_head1 x]]/2). - rewrite spec_low. - rewrite Hv5; rewrite Zmod_small; auto with zarith. - rewrite spec_w_add_mul_div; auto with zarith. - rewrite spec_w_sub; auto with zarith. - rewrite spec_w_0. - simpl ww_to_Z; autorewrite with rm10. - rewrite Hv6; rewrite spec_w_zdigits. - rewrite (fun x y => Zmod_small (x - y)). - ring_simplify (Zpos w_digits - (Zpos w_digits - [[ww_head1 x]] / 2)). - rewrite Zmod_small. - simpl ww_to_Z in H2; rewrite H2; auto with zarith. - intros (H4, H5); split. - apply Zmult_le_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith. - rewrite H4. - apply Zle_trans with ([|w2|] ^ 2); auto with zarith. - rewrite Zmult_comm. - pattern [[ww_head1 x]] at 1; - rewrite Hv0; auto with zarith. - rewrite (Zmult_comm 2); rewrite Zpower_mult; - auto with zarith. - assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); - try (intros; repeat rewrite Zsquare_mult; ring); - rewrite tmp; clear tmp. - apply Zpower_le_monotone3; auto with zarith. - split; auto with zarith. - pattern [|w2|] at 2; - rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2))); - auto with zarith. - match goal with |- ?X <= ?X + ?Y => - assert (0 <= Y); auto with zarith - end. - case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. - case c; unfold interp_carry; autorewrite with rm10; - intros w3; assert (V3 := spec_to_Z w3);auto with zarith. - apply Zmult_lt_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith. - rewrite H4. - apply Zle_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith. - apply Zlt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith. - match goal with |- ?X < ?Y => - replace Y with (X + 1); auto with zarith - end. - repeat rewrite (Zsquare_mult); ring. - rewrite Zmult_comm. - pattern [[ww_head1 x]] at 1; rewrite Hv0. - rewrite (Zmult_comm 2); rewrite Zpower_mult; - auto with zarith. - assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); - try (intros; repeat rewrite Zsquare_mult; ring); - rewrite tmp; clear tmp. - apply Zpower_le_monotone3; auto with zarith. - split; auto with zarith. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]]/2))); - auto with zarith. - rewrite <- Zplus_assoc; rewrite Zmult_plus_distr_r. - autorewrite with rm10; apply Zplus_le_compat_l; auto with zarith. - case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]]/2))); auto with zarith. - split; auto with zarith. - apply Zle_lt_trans with ([|w2|]); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern [|w2|] at 1; replace [|w2|] with ([|w2|] * 2 ^0); - auto with zarith. - apply Zmult_le_compat_l; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zpower_0_r; autorewrite with rm10; auto. - split; auto with zarith. - rewrite Hv0 in Hv2; rewrite (Zpos_xO w_digits) in Hv2; auto with zarith. - apply Zle_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - rewrite spec_w_sub; auto with zarith. - rewrite Hv6; rewrite spec_w_zdigits; auto with zarith. - assert (Hv7: 0 < [[ww_head1 x]]/2); auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - assert ([[ww_head1 x]]/2 <= Zpos w_digits); auto with zarith. - apply Zmult_le_reg_r with 2; auto with zarith. - repeat rewrite (fun x => Zmult_comm x 2). - rewrite <- Hv0; rewrite <- Zpos_xO; auto with zarith. - apply Zle_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - Qed. - -End GenSqrt. diff --git a/theories/Ints/num/GenSub.v b/theories/Ints/num/GenSub.v deleted file mode 100644 index 6ffb245757..0000000000 --- a/theories/Ints/num/GenSub.v +++ /dev/null @@ -1,353 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section GenSub. - Variable w : Set. - Variable w_0 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable ww_Bm1 : zn2z w. - Variable w_opp_c : w -> carry w. - Variable w_opp_carry : w -> w. - Variable w_pred_c : w -> carry w. - Variable w_sub_c : w -> w -> carry w. - Variable w_sub_carry_c : w -> w -> carry w. - Variable w_opp : w -> w. - Variable w_pred : w -> w. - Variable w_sub : w -> w -> w. - Variable w_sub_carry : w -> w -> w. - - (* ** Opposites ** *) - Definition ww_opp_c x := - match x with - | W0 => C0 W0 - | WW xh xl => - match w_opp_c xl with - | C0 _ => - match w_opp_c xh with - | C0 h => C0 W0 - | C1 h => C1 (WW h w_0) - end - | C1 l => C1 (WW (w_opp_carry xh) l) - end - end. - - Definition ww_opp x := - match x with - | W0 => W0 - | WW xh xl => - match w_opp_c xl with - | C0 _ => WW (w_opp xh) w_0 - | C1 l => WW (w_opp_carry xh) l - end - end. - - Definition ww_opp_carry x := - match x with - | W0 => ww_Bm1 - | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl) - end. - - Definition ww_pred_c x := - match x with - | W0 => C1 ww_Bm1 - | WW xh xl => - match w_pred_c xl with - | C0 l => C0 (w_WW xh l) - | C1 _ => - match w_pred_c xh with - | C0 h => C0 (WW h w_Bm1) - | C1 _ => C1 ww_Bm1 - end - end - end. - - Definition ww_pred x := - match x with - | W0 => ww_Bm1 - | WW xh xl => - match w_pred_c xl with - | C0 l => w_WW xh l - | C1 l => WW (w_pred xh) w_Bm1 - end - end. - - Definition ww_sub_c x y := - match y, x with - | W0, _ => C0 x - | WW yh yl, W0 => ww_opp_c (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_c xl yl with - | C0 l => - match w_sub_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_sub_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (WW h l) - end - end - end. - - Definition ww_sub x y := - match y, x with - | W0, _ => x - | WW yh yl, W0 => ww_opp (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_c xl yl with - | C0 l => w_WW (w_sub xh yh) l - | C1 l => WW (w_sub_carry xh yh) l - end - end. - - Definition ww_sub_carry_c x y := - match y, x with - | W0, W0 => C1 ww_Bm1 - | W0, WW xh xl => ww_pred_c (WW xh xl) - | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) - | WW yh yl, WW xh xl => - match w_sub_carry_c xl yl with - | C0 l => - match w_sub_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_sub_carry_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Definition ww_sub_carry x y := - match y, x with - | W0, W0 => ww_Bm1 - | W0, WW xh xl => ww_pred (WW xh xl) - | WW yh yl, W0 => ww_opp_carry (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_carry_c xl yl with - | C0 l => w_WW (w_sub xh yh) l - | C1 l => w_WW (w_sub_carry xh yh) l - end - end. - - (*Section GenProof.*) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - - Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. - Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. - Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. - - Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1. - Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. - Variable spec_sub_carry_c : - forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. - - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - - - Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. - Proof. - destruct x as [ |xh xl];simpl. reflexivity. - rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H; - rewrite Zopp_mult_distr_l. - assert ([|l|] = 0). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) - as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. - assert ([|h|] = 0). - assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. - rewrite H2;reflexivity. - simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring. - unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry; - ring. - Qed. - - Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. reflexivity. - rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l. - generalize (spec_opp_c xl);destruct (w_opp_c xl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB. - assert ([|l|] = 0). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;rewrite Zplus_0_r; rewrite Zpower_2; - rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite spec_opp;trivial. - apply Zmod_unique with (q:= -1). - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)). - rewrite spec_opp_carry;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1. - Proof. - destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring. - rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. - Proof. - destruct x as [ |xh xl];unfold ww_pred_c. - unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring. - simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)). - 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l]; - intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - assert ([|l|] = wB - 1). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). - generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. - simpl;rewrite spec_w_Bm1;ring. - assert ([|h|] = wB - 1). - assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. - rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - Proof. - destruct y as [ |yh yl];simpl. ring. - destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) - with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. - generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; - unfold interp_carry in H;rewrite <- H. - generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; - unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; - try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). - generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; - try rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_sub_carry_c : - forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. - Proof. - destruct y as [ |yh yl];simpl. - unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x). - destruct x as [ |xh xl]. - unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; - repeat rewrite spec_opp_carry;ring. - simpl ww_to_Z. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) - with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; - unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; - try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). - generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; - simpl ww_to_Z; try rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. - apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial. - rewrite spec_ww_Bm1;ring. - replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. - generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; - unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite Zmod_small. apply spec_w_WW. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - change ([|xh|] + -1) with ([|xh|] - 1). - assert ([|l|] = wB - 1). - assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. - rewrite (mod_wwB w_digits w_to_Z);trivial. - rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial. - Qed. - - Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - Proof. - destruct y as [ |yh yl];simpl. - ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. - destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) - with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. - generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; - unfold interp_carry in H;rewrite <- H. - rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z). - rewrite spec_sub;trivial. - simpl ww_to_Z;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. - Qed. - - Lemma spec_ww_sub_carry : - forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB. - Proof. - destruct y as [ |yh yl];simpl. - ring_simplify ([[x]] - 0);exact (spec_ww_pred x). - destruct x as [ |xh xl];simpl. - apply Zmod_unique with (-1). - apply spec_ww_to_Z;trivial. - fold (ww_opp_carry (WW yh yl)). - rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) - with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; - intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. - Qed. - -(* End GenProof. *) - -End GenSub. - - - - - diff --git a/theories/Ints/num/MemoFn.v b/theories/Ints/num/MemoFn.v deleted file mode 100644 index 7d2c7af015..0000000000 --- a/theories/Ints/num/MemoFn.v +++ /dev/null @@ -1,185 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import Eqdep_dec. - -Section MemoFunction. - -Variable A: Type. -Variable f: nat -> A. -Variable g: A -> A. - -Hypothesis Hg_correct: forall n, f (S n) = g (f n). - -(* Memo Stream *) -CoInductive MStream: Type := - MSeq : A -> MStream -> MStream. - -(* Hd and Tl function *) -Definition mhd (x: MStream) := - let (a,s) := x in a. -Definition mtl (x: MStream) := - let (a,s) := x in s. - -CoFixpoint memo_make (n: nat): MStream:= MSeq (f n) (memo_make (S n)). - -Definition memo_list := memo_make 0. - -Fixpoint memo_get (n: nat) (l: MStream) {struct n}: A := - match n with O => mhd l | S n1 => - memo_get n1 (mtl l) end. - -Theorem memo_get_correct: forall n, memo_get n memo_list = f n. -Proof. -assert (F1: forall n m, memo_get n (memo_make m) = f (n + m)). - induction n as [| n Hrec]; try (intros m; refine (refl_equal _)). - intros m; simpl; rewrite Hrec. - rewrite plus_n_Sm; auto. -intros n; apply trans_equal with (f (n + 0)); try exact (F1 n 0). -rewrite <- plus_n_O; auto. -Qed. - -(* Building with possible sharing using g *) -CoFixpoint imemo_make (fn: A): MStream := - let fn1 := g fn in - MSeq fn1 (imemo_make fn1). - -Definition imemo_list := let f0 := f 0 in - MSeq f0 (imemo_make f0). - -Theorem imemo_get_correct: forall n, memo_get n imemo_list = f n. -Proof. -assert (F1: forall n m, - memo_get n (imemo_make (f m)) = f (S (n + m))). - induction n as [| n Hrec]; try (intros m; exact (sym_equal (Hg_correct m))). - simpl; intros m; rewrite <- Hg_correct; rewrite Hrec; rewrite <- plus_n_Sm; auto. -destruct n as [| n]; try apply refl_equal. -unfold imemo_list; simpl; rewrite F1. -rewrite <- plus_n_O; auto. -Qed. - -End MemoFunction. - -Section DependentMemoFunction. - -Variable A: nat -> Type. -Variable f: forall n, A n. -Variable g: forall n, A n -> A (S n). - -Hypothesis Hg_correct: forall n, f (S n) = g n (f n). - -Inductive memo_val: Type := - memo_mval: forall n, A n -> memo_val. - -Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} := - match n, m return {n = m} + {True} with - | 0, 0 =>left True (refl_equal 0) - | 0, S m1 => right (0 = S m1) I - | S n1, 0 => right (S n1 = 0) I - | S n1, S m1 => - match is_eq n1 m1 with - | left H => left True (f_equal S H) - | right _ => right (S n1 = S m1) I - end - end. - -Definition memo_get_val n (v: memo_val): A n := -match v with -| memo_mval m x => - match is_eq n m with - | left H => - match H in (@eq _ _ y) return (A y -> A n) with - | refl_equal => fun v1 : A n => v1 - end - | right _ => fun _ : A m => f n - end x -end. - -Let mf n := memo_mval n (f n). -Let mg v := match v with - memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. - - -Definition dmemo_list := memo_list _ mf. - -Definition dmemo_get n l := memo_get_val n (memo_get _ n l). - -Definition dimemo_list := imemo_list _ mf mg. - -Theorem dmemo_get_correct: forall n, dmemo_get n dmemo_list = f n. -Proof. -intros n; unfold dmemo_get, dmemo_list. -rewrite (memo_get_correct memo_val mf n); simpl. -case (is_eq n n); simpl; auto; intros e. -assert (e = refl_equal n). - apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - left; auto. - right; intros HH; discriminate HH. - right; intros HH; discriminate HH. - case (Hx y). - intros HH; left; case HH; auto. - intros HH; right; intros HH1; case HH. - injection HH1; auto. -rewrite H; auto. -Qed. - -Theorem dimemo_get_correct: forall n, dmemo_get n dimemo_list = f n. -Proof. -intros n; unfold dmemo_get, dimemo_list. -rewrite (imemo_get_correct memo_val mf mg); simpl. -case (is_eq n n); simpl; auto; intros e. -assert (e = refl_equal n). - apply eq_proofs_unicity. - induction x as [| x Hx]; destruct y as [| y]. - left; auto. - right; intros HH; discriminate HH. - right; intros HH; discriminate HH. - case (Hx y). - intros HH; left; case HH; auto. - intros HH; right; intros HH1; case HH. - injection HH1; auto. -rewrite H; auto. -intros n1; unfold mf; rewrite Hg_correct; auto. -Qed. - -End DependentMemoFunction. - -(* An example with the memo function on factorial *) - -(* -Require Import ZArith. - -Fixpoint tfact (n: nat) {struct n} := - match n with O => 1%Z | - S n1 => (Z_of_nat n * tfact n1)%Z end. - -Definition lfact_list := - dimemo_list _ tfact (fun n z => (Z_of_nat (S n) * z)%Z). - -Definition lfact n := dmemo_get _ tfact n lfact_list. - -Theorem lfact_correct n: lfact n = tfact n. -Proof. -intros n; unfold lfact, lfact_list. -rewrite dimemo_get_correct; auto. -Qed. - -Fixpoint nop p := match p with -xH => 0 | xI p1 => nop p1 | xO p1 => nop p1 end. - -Fixpoint test z := match z with -Z0 => 0 | Zpos p1 => nop p1 | Zneg p1 => nop p1 end. - -Time Eval vm_compute in test (lfact 2000). -Time Eval vm_compute in test (lfact 2000). -Time Eval vm_compute in test (lfact 1500). -Time Eval vm_compute in (lfact 1500). - -*) - diff --git a/theories/Ints/num/NMake.v b/theories/Ints/num/NMake.v deleted file mode 100644 index 8cb779350a..0000000000 --- a/theories/Ints/num/NMake.v +++ /dev/null @@ -1,6809 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(* $Id$ *) - -(** * *) - -(** -- Authors: Benjamin Grégoire, Laurent Théry -- Institution: INRIA -- Date: 2007 -- Remark: File automatically generated -*) - -Require Import Zaux. -Require Import ZArith. -Require Import Basic_type. -Require Import ZnZ. -Require Import Zn2Z. -Require Import Nbasic. -Require Import GenMul. -Require Import GenDivn1. -Require Import Wf_nat. -Require Import MemoFn. - -Module Type W0Type. - Parameter w : Set. - Parameter w_op : znz_op w. - Parameter w_spec : znz_spec w_op. -End W0Type. - -Module Make (W0:W0Type). - Import W0. - - Definition w0 := W0.w. - Definition w1 := zn2z w0. - Definition w2 := zn2z w1. - Definition w3 := zn2z w2. - Definition w4 := zn2z w3. - Definition w5 := zn2z w4. - Definition w6 := zn2z w5. - - Definition w0_op := W0.w_op. - Definition w1_op := mk_zn2z_op w0_op. - Definition w2_op := mk_zn2z_op w1_op. - Definition w3_op := mk_zn2z_op w2_op. - Definition w4_op := mk_zn2z_op_karatsuba w3_op. - Definition w5_op := mk_zn2z_op_karatsuba w4_op. - Definition w6_op := mk_zn2z_op_karatsuba w5_op. - Definition w7_op := mk_zn2z_op_karatsuba w6_op. - Definition w8_op := mk_zn2z_op_karatsuba w7_op. - Definition w9_op := mk_zn2z_op_karatsuba w8_op. - - Section Make_op. - Variable mk : forall w', znz_op w' -> znz_op (zn2z w'). - - Fixpoint make_op_aux (n:nat) : znz_op (word w6 (S n)):= - match n return znz_op (word w6 (S n)) with - | O => w7_op - | S n1 => - match n1 return znz_op (word w6 (S (S n1))) with - | O => w8_op - | S n2 => - match n2 return znz_op (word w6 (S (S (S n2)))) with - | O => w9_op - | S n3 => mk _ (mk _ (mk _ (make_op_aux n3))) - end - end - end. - - End Make_op. - - Definition omake_op := make_op_aux mk_zn2z_op_karatsuba. - - - Definition make_op_list := dmemo_list _ omake_op. - - Definition make_op n := dmemo_get _ omake_op n make_op_list. - - Lemma make_op_omake: forall n, make_op n = omake_op n. - intros n; unfold make_op, make_op_list. - refine (dmemo_get_correct _ _ _). - Qed. - - Inductive t_ : Set := - | N0 : w0 -> t_ - | N1 : w1 -> t_ - | N2 : w2 -> t_ - | N3 : w3 -> t_ - | N4 : w4 -> t_ - | N5 : w5 -> t_ - | N6 : w6 -> t_ - | Nn : forall n, word w6 (S n) -> t_. - - Definition t := t_. - - Definition w_0 := w0_op.(znz_0). - - Definition one0 := w0_op.(znz_1). - Definition one1 := w1_op.(znz_1). - Definition one2 := w2_op.(znz_1). - Definition one3 := w3_op.(znz_1). - Definition one4 := w4_op.(znz_1). - Definition one5 := w5_op.(znz_1). - Definition one6 := w6_op.(znz_1). - - Definition zero := N0 w_0. - Definition one := N0 one0. - - Definition to_Z x := - match x with - | N0 wx => w0_op.(znz_to_Z) wx - | N1 wx => w1_op.(znz_to_Z) wx - | N2 wx => w2_op.(znz_to_Z) wx - | N3 wx => w3_op.(znz_to_Z) wx - | N4 wx => w4_op.(znz_to_Z) wx - | N5 wx => w5_op.(znz_to_Z) wx - | N6 wx => w6_op.(znz_to_Z) wx - | Nn n wx => (make_op n).(znz_to_Z) wx - end. - - Open Scope Z_scope. - Notation "[ x ]" := (to_Z x). - - (* Regular make op (no karatsuba) *) - Fixpoint nmake_op (ww:Set) (ww_op: znz_op ww) (n: nat) : - znz_op (word ww n) := - match n return znz_op (word ww n) with - O => ww_op - | S n1 => mk_zn2z_op (nmake_op ww ww_op n1) - end. - - (* Simplification by rewriting for nmake_op *) - Theorem nmake_op_S: forall ww (w_op: znz_op ww) x, - nmake_op _ w_op (S x) = mk_zn2z_op (nmake_op _ w_op x). - auto. - Qed. - - (* Eval and extend functions for each level *) - Let nmake_op0 := nmake_op _ w0_op. - Let eval0n n := znz_to_Z (nmake_op0 n). - Let extend0 := GenBase.extend (WW w_0). - Let nmake_op1 := nmake_op _ w1_op. - Let eval1n n := znz_to_Z (nmake_op1 n). - Let extend1 := GenBase.extend (WW (W0: w1)). - Let nmake_op2 := nmake_op _ w2_op. - Let eval2n n := znz_to_Z (nmake_op2 n). - Let extend2 := GenBase.extend (WW (W0: w2)). - Let nmake_op3 := nmake_op _ w3_op. - Let eval3n n := znz_to_Z (nmake_op3 n). - Let extend3 := GenBase.extend (WW (W0: w3)). - Let nmake_op4 := nmake_op _ w4_op. - Let eval4n n := znz_to_Z (nmake_op4 n). - Let extend4 := GenBase.extend (WW (W0: w4)). - Let nmake_op5 := nmake_op _ w5_op. - Let eval5n n := znz_to_Z (nmake_op5 n). - Let extend5 := GenBase.extend (WW (W0: w5)). - Let nmake_op6 := nmake_op _ w6_op. - Let eval6n n := znz_to_Z (nmake_op6 n). - Let extend6 := GenBase.extend (WW (W0: w6)). - - Theorem digits_gend:forall n ww (w_op: znz_op ww), - znz_digits (nmake_op _ w_op n) = - GenBase.gen_digits (znz_digits w_op) n. - Proof. intros n; elim n; auto; clear n. - intros n Hrec ww ww_op; simpl GenBase.gen_digits. - rewrite <- Hrec; auto. - Qed. - - Theorem nmake_gen: forall n ww (w_op: znz_op ww), - znz_to_Z (nmake_op _ w_op n) = - @GenBase.gen_to_Z _ (znz_digits w_op) (znz_to_Z w_op) n. - Proof. intros n; elim n; auto; clear n. - intros n Hrec ww ww_op; simpl GenBase.gen_to_Z; unfold zn2z_to_Z. - rewrite <- Hrec; auto. - unfold GenBase.gen_wB; rewrite <- digits_gend; auto. - Qed. - - Theorem digits_nmake:forall n ww (w_op: znz_op ww), - znz_digits (nmake_op _ w_op (S n)) = - xO (znz_digits (nmake_op _ w_op n)). - Proof. - auto. - Qed. - - Theorem znz_nmake_op: forall ww ww_op n xh xl, - znz_to_Z (nmake_op ww ww_op (S n)) (WW xh xl) = - znz_to_Z (nmake_op ww ww_op n) xh * - base (znz_digits (nmake_op ww ww_op n)) + - znz_to_Z (nmake_op ww ww_op n) xl. - Proof. - auto. - Qed. - - Theorem make_op_S: forall n, - make_op (S n) = mk_zn2z_op_karatsuba (make_op n). - intro n. - do 2 rewrite make_op_omake. - pattern n; apply lt_wf_ind; clear n. - intros n; case n; clear n. - intros _; unfold omake_op, make_op_aux, w8_op; apply refl_equal. - intros n; case n; clear n. - intros _; unfold omake_op, make_op_aux, w9_op; apply refl_equal. - intros n; case n; clear n. - intros _; unfold omake_op, make_op_aux, w9_op, w8_op; apply refl_equal. - intros n Hrec. - change (omake_op (S (S (S (S n))))) with - (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op (S n))))). - change (omake_op (S (S (S n)))) with - (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op n)))). - rewrite Hrec; auto with arith. - Qed. - - Let znz_to_Z_1: forall x y, - znz_to_Z w1_op (WW x y) = - znz_to_Z w0_op x * base (znz_digits w0_op) + znz_to_Z w0_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_2: forall x y, - znz_to_Z w2_op (WW x y) = - znz_to_Z w1_op x * base (znz_digits w1_op) + znz_to_Z w1_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_3: forall x y, - znz_to_Z w3_op (WW x y) = - znz_to_Z w2_op x * base (znz_digits w2_op) + znz_to_Z w2_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_4: forall x y, - znz_to_Z w4_op (WW x y) = - znz_to_Z w3_op x * base (znz_digits w3_op) + znz_to_Z w3_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_5: forall x y, - znz_to_Z w5_op (WW x y) = - znz_to_Z w4_op x * base (znz_digits w4_op) + znz_to_Z w4_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_6: forall x y, - znz_to_Z w6_op (WW x y) = - znz_to_Z w5_op x * base (znz_digits w5_op) + znz_to_Z w5_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_7: forall x y, - znz_to_Z w7_op (WW x y) = - znz_to_Z w6_op x * base (znz_digits w6_op) + znz_to_Z w6_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_8: forall x y, - znz_to_Z w8_op (WW x y) = - znz_to_Z w7_op x * base (znz_digits w7_op) + znz_to_Z w7_op y. - Proof. - auto. - Qed. - - Let znz_to_Z_n: forall n x y, - znz_to_Z (make_op (S n)) (WW x y) = - znz_to_Z (make_op n) x * base (znz_digits (make_op n)) + znz_to_Z (make_op n) y. - Proof. - intros n x y; rewrite make_op_S; auto. - Qed. - - Let w0_spec: znz_spec w0_op := W0.w_spec. - Let w1_spec: znz_spec w1_op := mk_znz2_spec w0_spec. - Let w2_spec: znz_spec w2_op := mk_znz2_spec w1_spec. - Let w3_spec: znz_spec w3_op := mk_znz2_spec w2_spec. - Let w4_spec : znz_spec w4_op := mk_znz2_karatsuba_spec w3_spec. - Let w5_spec : znz_spec w5_op := mk_znz2_karatsuba_spec w4_spec. - Let w6_spec : znz_spec w6_op := mk_znz2_karatsuba_spec w5_spec. - Let w7_spec : znz_spec w7_op := mk_znz2_karatsuba_spec w6_spec. - Let w8_spec : znz_spec w8_op := mk_znz2_karatsuba_spec w7_spec. - Let w9_spec : znz_spec w9_op := mk_znz2_karatsuba_spec w8_spec. - - Let wn_spec: forall n, znz_spec (make_op n). - intros n; elim n; clear n. - exact w7_spec. - intros n Hrec; rewrite make_op_S. - exact (mk_znz2_karatsuba_spec Hrec). - Qed. - - Definition w0_eq0 := w0_op.(znz_eq0). - Let spec_w0_eq0: forall x, if w0_eq0 x then [N0 x] = 0 else True. - intros x; unfold w0_eq0, to_Z; generalize (spec_eq0 w0_spec x); - case znz_eq0; auto. - Qed. - - Definition w1_eq0 := w1_op.(znz_eq0). - Let spec_w1_eq0: forall x, if w1_eq0 x then [N1 x] = 0 else True. - intros x; unfold w1_eq0, to_Z; generalize (spec_eq0 w1_spec x); - case znz_eq0; auto. - Qed. - - Definition w2_eq0 := w2_op.(znz_eq0). - Let spec_w2_eq0: forall x, if w2_eq0 x then [N2 x] = 0 else True. - intros x; unfold w2_eq0, to_Z; generalize (spec_eq0 w2_spec x); - case znz_eq0; auto. - Qed. - - Definition w3_eq0 := w3_op.(znz_eq0). - Let spec_w3_eq0: forall x, if w3_eq0 x then [N3 x] = 0 else True. - intros x; unfold w3_eq0, to_Z; generalize (spec_eq0 w3_spec x); - case znz_eq0; auto. - Qed. - - Definition w4_eq0 := w4_op.(znz_eq0). - Let spec_w4_eq0: forall x, if w4_eq0 x then [N4 x] = 0 else True. - intros x; unfold w4_eq0, to_Z; generalize (spec_eq0 w4_spec x); - case znz_eq0; auto. - Qed. - - Definition w5_eq0 := w5_op.(znz_eq0). - Let spec_w5_eq0: forall x, if w5_eq0 x then [N5 x] = 0 else True. - intros x; unfold w5_eq0, to_Z; generalize (spec_eq0 w5_spec x); - case znz_eq0; auto. - Qed. - - Definition w6_eq0 := w6_op.(znz_eq0). - Let spec_w6_eq0: forall x, if w6_eq0 x then [N6 x] = 0 else True. - intros x; unfold w6_eq0, to_Z; generalize (spec_eq0 w6_spec x); - case znz_eq0; auto. - Qed. - - - Theorem digits_w0: znz_digits w0_op = znz_digits (nmake_op _ w0_op 0). - auto. - Qed. - - Let spec_gen_eval0n: forall n, eval0n n = GenBase.gen_to_Z (znz_digits w0_op) (znz_to_Z w0_op) n. - intros n; exact (nmake_gen n w0 w0_op). - Qed. - - Theorem digits_w1: znz_digits w1_op = znz_digits (nmake_op _ w0_op 1). - rewrite digits_nmake; rewrite <- digits_w0; auto. - Qed. - - Let spec_gen_eval1n: forall n, eval1n n = GenBase.gen_to_Z (znz_digits w1_op) (znz_to_Z w1_op) n. - intros n; exact (nmake_gen n w1 w1_op). - Qed. - - Theorem digits_w2: znz_digits w2_op = znz_digits (nmake_op _ w0_op 2). - rewrite digits_nmake; rewrite <- digits_w1; auto. - Qed. - - Let spec_gen_eval2n: forall n, eval2n n = GenBase.gen_to_Z (znz_digits w2_op) (znz_to_Z w2_op) n. - intros n; exact (nmake_gen n w2 w2_op). - Qed. - - Theorem digits_w3: znz_digits w3_op = znz_digits (nmake_op _ w0_op 3). - rewrite digits_nmake; rewrite <- digits_w2; auto. - Qed. - - Let spec_gen_eval3n: forall n, eval3n n = GenBase.gen_to_Z (znz_digits w3_op) (znz_to_Z w3_op) n. - intros n; exact (nmake_gen n w3 w3_op). - Qed. - - Theorem digits_w4: znz_digits w4_op = znz_digits (nmake_op _ w0_op 4). - rewrite digits_nmake; rewrite <- digits_w3; auto. - Qed. - - Let spec_gen_eval4n: forall n, eval4n n = GenBase.gen_to_Z (znz_digits w4_op) (znz_to_Z w4_op) n. - intros n; exact (nmake_gen n w4 w4_op). - Qed. - - Theorem digits_w5: znz_digits w5_op = znz_digits (nmake_op _ w0_op 5). - rewrite digits_nmake; rewrite <- digits_w4; auto. - Qed. - - Let spec_gen_eval5n: forall n, eval5n n = GenBase.gen_to_Z (znz_digits w5_op) (znz_to_Z w5_op) n. - intros n; exact (nmake_gen n w5 w5_op). - Qed. - - Theorem digits_w6: znz_digits w6_op = znz_digits (nmake_op _ w0_op 6). - rewrite digits_nmake; rewrite <- digits_w5; auto. - Qed. - - Let spec_gen_eval6n: forall n, eval6n n = GenBase.gen_to_Z (znz_digits w6_op) (znz_to_Z w6_op) n. - intros n; exact (nmake_gen n w6 w6_op). - Qed. - - Theorem digits_w0n0: znz_digits w0_op = znz_digits (nmake_op _ w0_op 0). - auto. - Qed. - - Let spec_eval0n0: forall x, [N0 x] = eval0n 0 x. - intros x; rewrite spec_gen_eval0n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Let spec_extend0n1: forall x, [N0 x] = [N1 (extend0 0 x)]. - intros x; change (extend0 0 x) with (WW (znz_0 w0_op) x). - unfold to_Z; rewrite znz_to_Z_1. - rewrite (spec_0 w0_spec); auto. - Qed. - - Theorem digits_w0n1: znz_digits w1_op = znz_digits (nmake_op _ w0_op 1). - apply trans_equal with (xO (znz_digits w0_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n0. - auto. - Qed. - - Let spec_eval0n1: forall x, [N1 x] = eval0n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_1. - rewrite digits_w0n0. - generalize (spec_eval0n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 0); auto. - Qed. - Let spec_extend0n2: forall x, [N0 x] = [N2 (extend0 1 x)]. - intros x; change (extend0 1 x) with (WW (znz_0 w1_op) (extend0 0 x)). - unfold to_Z; rewrite znz_to_Z_2. - rewrite (spec_0 w1_spec). - generalize (spec_extend0n1 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w0n2: znz_digits w2_op = znz_digits (nmake_op _ w0_op 2). - apply trans_equal with (xO (znz_digits w1_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n1. - auto. - Qed. - - Let spec_eval0n2: forall x, [N2 x] = eval0n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_2. - rewrite digits_w0n1. - generalize (spec_eval0n1); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 1); auto. - Qed. - Let spec_extend0n3: forall x, [N0 x] = [N3 (extend0 2 x)]. - intros x; change (extend0 2 x) with (WW (znz_0 w2_op) (extend0 1 x)). - unfold to_Z; rewrite znz_to_Z_3. - rewrite (spec_0 w2_spec). - generalize (spec_extend0n2 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w0n3: znz_digits w3_op = znz_digits (nmake_op _ w0_op 3). - apply trans_equal with (xO (znz_digits w2_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n2. - auto. - Qed. - - Let spec_eval0n3: forall x, [N3 x] = eval0n 3 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_3. - rewrite digits_w0n2. - generalize (spec_eval0n2); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 2); auto. - Qed. - Let spec_extend0n4: forall x, [N0 x] = [N4 (extend0 3 x)]. - intros x; change (extend0 3 x) with (WW (znz_0 w3_op) (extend0 2 x)). - unfold to_Z; rewrite znz_to_Z_4. - rewrite (spec_0 w3_spec). - generalize (spec_extend0n3 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w0n4: znz_digits w4_op = znz_digits (nmake_op _ w0_op 4). - apply trans_equal with (xO (znz_digits w3_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n3. - auto. - Qed. - - Let spec_eval0n4: forall x, [N4 x] = eval0n 4 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_4. - rewrite digits_w0n3. - generalize (spec_eval0n3); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 3); auto. - Qed. - Let spec_extend0n5: forall x, [N0 x] = [N5 (extend0 4 x)]. - intros x; change (extend0 4 x) with (WW (znz_0 w4_op) (extend0 3 x)). - unfold to_Z; rewrite znz_to_Z_5. - rewrite (spec_0 w4_spec). - generalize (spec_extend0n4 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w0n5: znz_digits w5_op = znz_digits (nmake_op _ w0_op 5). - apply trans_equal with (xO (znz_digits w4_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n4. - auto. - Qed. - - Let spec_eval0n5: forall x, [N5 x] = eval0n 5 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_5. - rewrite digits_w0n4. - generalize (spec_eval0n4); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 4); auto. - Qed. - Let spec_extend0n6: forall x, [N0 x] = [N6 (extend0 5 x)]. - intros x; change (extend0 5 x) with (WW (znz_0 w5_op) (extend0 4 x)). - unfold to_Z; rewrite znz_to_Z_6. - rewrite (spec_0 w5_spec). - generalize (spec_extend0n5 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w0n6: znz_digits w6_op = znz_digits (nmake_op _ w0_op 6). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n5. - auto. - Qed. - - Let spec_eval0n6: forall x, [N6 x] = eval0n 6 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_6. - rewrite digits_w0n5. - generalize (spec_eval0n5); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 5); auto. - Qed. - Theorem digits_w0n7: znz_digits w7_op = znz_digits (nmake_op _ w0_op 7). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w0n6. - auto. - Qed. - - Let spec_eval0n7: forall x, [Nn 0 x] = eval0n 7 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w0n6. - generalize (spec_eval0n6); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 6); auto. - Qed. - - Let spec_eval0n8: forall x, [Nn 1 x] = eval0n 8 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w0n7. - generalize (spec_eval0n7); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval0n, nmake_op0. - rewrite (znz_nmake_op _ w0_op 7); auto. - Qed. - - Theorem digits_w1n0: znz_digits w1_op = znz_digits (nmake_op _ w1_op 0). - apply trans_equal with (xO (znz_digits w0_op)). - auto. - unfold nmake_op; auto. - Qed. - - Let spec_eval1n0: forall x, [N1 x] = eval1n 0 x. - intros x; rewrite spec_gen_eval1n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Let spec_extend1n2: forall x, [N1 x] = [N2 (extend1 0 x)]. - intros x; change (extend1 0 x) with (WW (znz_0 w1_op) x). - unfold to_Z; rewrite znz_to_Z_2. - rewrite (spec_0 w1_spec); auto. - Qed. - - Theorem digits_w1n1: znz_digits w2_op = znz_digits (nmake_op _ w1_op 1). - apply trans_equal with (xO (znz_digits w1_op)). - auto. - rewrite digits_nmake. - rewrite digits_w1n0. - auto. - Qed. - - Let spec_eval1n1: forall x, [N2 x] = eval1n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_2. - rewrite digits_w1n0. - generalize (spec_eval1n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 0); auto. - Qed. - Let spec_extend1n3: forall x, [N1 x] = [N3 (extend1 1 x)]. - intros x; change (extend1 1 x) with (WW (znz_0 w2_op) (extend1 0 x)). - unfold to_Z; rewrite znz_to_Z_3. - rewrite (spec_0 w2_spec). - generalize (spec_extend1n2 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w1n2: znz_digits w3_op = znz_digits (nmake_op _ w1_op 2). - apply trans_equal with (xO (znz_digits w2_op)). - auto. - rewrite digits_nmake. - rewrite digits_w1n1. - auto. - Qed. - - Let spec_eval1n2: forall x, [N3 x] = eval1n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_3. - rewrite digits_w1n1. - generalize (spec_eval1n1); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 1); auto. - Qed. - Let spec_extend1n4: forall x, [N1 x] = [N4 (extend1 2 x)]. - intros x; change (extend1 2 x) with (WW (znz_0 w3_op) (extend1 1 x)). - unfold to_Z; rewrite znz_to_Z_4. - rewrite (spec_0 w3_spec). - generalize (spec_extend1n3 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w1n3: znz_digits w4_op = znz_digits (nmake_op _ w1_op 3). - apply trans_equal with (xO (znz_digits w3_op)). - auto. - rewrite digits_nmake. - rewrite digits_w1n2. - auto. - Qed. - - Let spec_eval1n3: forall x, [N4 x] = eval1n 3 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_4. - rewrite digits_w1n2. - generalize (spec_eval1n2); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 2); auto. - Qed. - Let spec_extend1n5: forall x, [N1 x] = [N5 (extend1 3 x)]. - intros x; change (extend1 3 x) with (WW (znz_0 w4_op) (extend1 2 x)). - unfold to_Z; rewrite znz_to_Z_5. - rewrite (spec_0 w4_spec). - generalize (spec_extend1n4 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w1n4: znz_digits w5_op = znz_digits (nmake_op _ w1_op 4). - apply trans_equal with (xO (znz_digits w4_op)). - auto. - rewrite digits_nmake. - rewrite digits_w1n3. - auto. - Qed. - - Let spec_eval1n4: forall x, [N5 x] = eval1n 4 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_5. - rewrite digits_w1n3. - generalize (spec_eval1n3); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 3); auto. - Qed. - Let spec_extend1n6: forall x, [N1 x] = [N6 (extend1 4 x)]. - intros x; change (extend1 4 x) with (WW (znz_0 w5_op) (extend1 3 x)). - unfold to_Z; rewrite znz_to_Z_6. - rewrite (spec_0 w5_spec). - generalize (spec_extend1n5 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w1n5: znz_digits w6_op = znz_digits (nmake_op _ w1_op 5). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - rewrite digits_nmake. - rewrite digits_w1n4. - auto. - Qed. - - Let spec_eval1n5: forall x, [N6 x] = eval1n 5 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_6. - rewrite digits_w1n4. - generalize (spec_eval1n4); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 4); auto. - Qed. - Theorem digits_w1n6: znz_digits w7_op = znz_digits (nmake_op _ w1_op 6). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w1n5. - auto. - Qed. - - Let spec_eval1n6: forall x, [Nn 0 x] = eval1n 6 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w1n5. - generalize (spec_eval1n5); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 5); auto. - Qed. - - Let spec_eval1n7: forall x, [Nn 1 x] = eval1n 7 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w1n6. - generalize (spec_eval1n6); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval1n, nmake_op1. - rewrite (znz_nmake_op _ w1_op 6); auto. - Qed. - - Theorem digits_w2n0: znz_digits w2_op = znz_digits (nmake_op _ w2_op 0). - apply trans_equal with (xO (znz_digits w1_op)). - auto. - unfold nmake_op; auto. - Qed. - - Let spec_eval2n0: forall x, [N2 x] = eval2n 0 x. - intros x; rewrite spec_gen_eval2n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Let spec_extend2n3: forall x, [N2 x] = [N3 (extend2 0 x)]. - intros x; change (extend2 0 x) with (WW (znz_0 w2_op) x). - unfold to_Z; rewrite znz_to_Z_3. - rewrite (spec_0 w2_spec); auto. - Qed. - - Theorem digits_w2n1: znz_digits w3_op = znz_digits (nmake_op _ w2_op 1). - apply trans_equal with (xO (znz_digits w2_op)). - auto. - rewrite digits_nmake. - rewrite digits_w2n0. - auto. - Qed. - - Let spec_eval2n1: forall x, [N3 x] = eval2n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_3. - rewrite digits_w2n0. - generalize (spec_eval2n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval2n, nmake_op2. - rewrite (znz_nmake_op _ w2_op 0); auto. - Qed. - Let spec_extend2n4: forall x, [N2 x] = [N4 (extend2 1 x)]. - intros x; change (extend2 1 x) with (WW (znz_0 w3_op) (extend2 0 x)). - unfold to_Z; rewrite znz_to_Z_4. - rewrite (spec_0 w3_spec). - generalize (spec_extend2n3 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w2n2: znz_digits w4_op = znz_digits (nmake_op _ w2_op 2). - apply trans_equal with (xO (znz_digits w3_op)). - auto. - rewrite digits_nmake. - rewrite digits_w2n1. - auto. - Qed. - - Let spec_eval2n2: forall x, [N4 x] = eval2n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_4. - rewrite digits_w2n1. - generalize (spec_eval2n1); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval2n, nmake_op2. - rewrite (znz_nmake_op _ w2_op 1); auto. - Qed. - Let spec_extend2n5: forall x, [N2 x] = [N5 (extend2 2 x)]. - intros x; change (extend2 2 x) with (WW (znz_0 w4_op) (extend2 1 x)). - unfold to_Z; rewrite znz_to_Z_5. - rewrite (spec_0 w4_spec). - generalize (spec_extend2n4 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w2n3: znz_digits w5_op = znz_digits (nmake_op _ w2_op 3). - apply trans_equal with (xO (znz_digits w4_op)). - auto. - rewrite digits_nmake. - rewrite digits_w2n2. - auto. - Qed. - - Let spec_eval2n3: forall x, [N5 x] = eval2n 3 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_5. - rewrite digits_w2n2. - generalize (spec_eval2n2); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval2n, nmake_op2. - rewrite (znz_nmake_op _ w2_op 2); auto. - Qed. - Let spec_extend2n6: forall x, [N2 x] = [N6 (extend2 3 x)]. - intros x; change (extend2 3 x) with (WW (znz_0 w5_op) (extend2 2 x)). - unfold to_Z; rewrite znz_to_Z_6. - rewrite (spec_0 w5_spec). - generalize (spec_extend2n5 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w2n4: znz_digits w6_op = znz_digits (nmake_op _ w2_op 4). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - rewrite digits_nmake. - rewrite digits_w2n3. - auto. - Qed. - - Let spec_eval2n4: forall x, [N6 x] = eval2n 4 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_6. - rewrite digits_w2n3. - generalize (spec_eval2n3); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval2n, nmake_op2. - rewrite (znz_nmake_op _ w2_op 3); auto. - Qed. - Theorem digits_w2n5: znz_digits w7_op = znz_digits (nmake_op _ w2_op 5). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w2n4. - auto. - Qed. - - Let spec_eval2n5: forall x, [Nn 0 x] = eval2n 5 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w2n4. - generalize (spec_eval2n4); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval2n, nmake_op2. - rewrite (znz_nmake_op _ w2_op 4); auto. - Qed. - - Let spec_eval2n6: forall x, [Nn 1 x] = eval2n 6 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w2n5. - generalize (spec_eval2n5); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval2n, nmake_op2. - rewrite (znz_nmake_op _ w2_op 5); auto. - Qed. - - Theorem digits_w3n0: znz_digits w3_op = znz_digits (nmake_op _ w3_op 0). - apply trans_equal with (xO (znz_digits w2_op)). - auto. - unfold nmake_op; auto. - Qed. - - Let spec_eval3n0: forall x, [N3 x] = eval3n 0 x. - intros x; rewrite spec_gen_eval3n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Let spec_extend3n4: forall x, [N3 x] = [N4 (extend3 0 x)]. - intros x; change (extend3 0 x) with (WW (znz_0 w3_op) x). - unfold to_Z; rewrite znz_to_Z_4. - rewrite (spec_0 w3_spec); auto. - Qed. - - Theorem digits_w3n1: znz_digits w4_op = znz_digits (nmake_op _ w3_op 1). - apply trans_equal with (xO (znz_digits w3_op)). - auto. - rewrite digits_nmake. - rewrite digits_w3n0. - auto. - Qed. - - Let spec_eval3n1: forall x, [N4 x] = eval3n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_4. - rewrite digits_w3n0. - generalize (spec_eval3n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval3n, nmake_op3. - rewrite (znz_nmake_op _ w3_op 0); auto. - Qed. - Let spec_extend3n5: forall x, [N3 x] = [N5 (extend3 1 x)]. - intros x; change (extend3 1 x) with (WW (znz_0 w4_op) (extend3 0 x)). - unfold to_Z; rewrite znz_to_Z_5. - rewrite (spec_0 w4_spec). - generalize (spec_extend3n4 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w3n2: znz_digits w5_op = znz_digits (nmake_op _ w3_op 2). - apply trans_equal with (xO (znz_digits w4_op)). - auto. - rewrite digits_nmake. - rewrite digits_w3n1. - auto. - Qed. - - Let spec_eval3n2: forall x, [N5 x] = eval3n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_5. - rewrite digits_w3n1. - generalize (spec_eval3n1); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval3n, nmake_op3. - rewrite (znz_nmake_op _ w3_op 1); auto. - Qed. - Let spec_extend3n6: forall x, [N3 x] = [N6 (extend3 2 x)]. - intros x; change (extend3 2 x) with (WW (znz_0 w5_op) (extend3 1 x)). - unfold to_Z; rewrite znz_to_Z_6. - rewrite (spec_0 w5_spec). - generalize (spec_extend3n5 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w3n3: znz_digits w6_op = znz_digits (nmake_op _ w3_op 3). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - rewrite digits_nmake. - rewrite digits_w3n2. - auto. - Qed. - - Let spec_eval3n3: forall x, [N6 x] = eval3n 3 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_6. - rewrite digits_w3n2. - generalize (spec_eval3n2); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval3n, nmake_op3. - rewrite (znz_nmake_op _ w3_op 2); auto. - Qed. - Theorem digits_w3n4: znz_digits w7_op = znz_digits (nmake_op _ w3_op 4). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w3n3. - auto. - Qed. - - Let spec_eval3n4: forall x, [Nn 0 x] = eval3n 4 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w3n3. - generalize (spec_eval3n3); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval3n, nmake_op3. - rewrite (znz_nmake_op _ w3_op 3); auto. - Qed. - - Let spec_eval3n5: forall x, [Nn 1 x] = eval3n 5 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w3n4. - generalize (spec_eval3n4); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval3n, nmake_op3. - rewrite (znz_nmake_op _ w3_op 4); auto. - Qed. - - Theorem digits_w4n0: znz_digits w4_op = znz_digits (nmake_op _ w4_op 0). - apply trans_equal with (xO (znz_digits w3_op)). - auto. - unfold nmake_op; auto. - Qed. - - Let spec_eval4n0: forall x, [N4 x] = eval4n 0 x. - intros x; rewrite spec_gen_eval4n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Let spec_extend4n5: forall x, [N4 x] = [N5 (extend4 0 x)]. - intros x; change (extend4 0 x) with (WW (znz_0 w4_op) x). - unfold to_Z; rewrite znz_to_Z_5. - rewrite (spec_0 w4_spec); auto. - Qed. - - Theorem digits_w4n1: znz_digits w5_op = znz_digits (nmake_op _ w4_op 1). - apply trans_equal with (xO (znz_digits w4_op)). - auto. - rewrite digits_nmake. - rewrite digits_w4n0. - auto. - Qed. - - Let spec_eval4n1: forall x, [N5 x] = eval4n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_5. - rewrite digits_w4n0. - generalize (spec_eval4n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval4n, nmake_op4. - rewrite (znz_nmake_op _ w4_op 0); auto. - Qed. - Let spec_extend4n6: forall x, [N4 x] = [N6 (extend4 1 x)]. - intros x; change (extend4 1 x) with (WW (znz_0 w5_op) (extend4 0 x)). - unfold to_Z; rewrite znz_to_Z_6. - rewrite (spec_0 w5_spec). - generalize (spec_extend4n5 x); unfold to_Z. - intros HH; rewrite <- HH; auto. - Qed. - - Theorem digits_w4n2: znz_digits w6_op = znz_digits (nmake_op _ w4_op 2). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - rewrite digits_nmake. - rewrite digits_w4n1. - auto. - Qed. - - Let spec_eval4n2: forall x, [N6 x] = eval4n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_6. - rewrite digits_w4n1. - generalize (spec_eval4n1); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval4n, nmake_op4. - rewrite (znz_nmake_op _ w4_op 1); auto. - Qed. - Theorem digits_w4n3: znz_digits w7_op = znz_digits (nmake_op _ w4_op 3). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w4n2. - auto. - Qed. - - Let spec_eval4n3: forall x, [Nn 0 x] = eval4n 3 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w4n2. - generalize (spec_eval4n2); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval4n, nmake_op4. - rewrite (znz_nmake_op _ w4_op 2); auto. - Qed. - - Let spec_eval4n4: forall x, [Nn 1 x] = eval4n 4 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w4n3. - generalize (spec_eval4n3); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval4n, nmake_op4. - rewrite (znz_nmake_op _ w4_op 3); auto. - Qed. - - Theorem digits_w5n0: znz_digits w5_op = znz_digits (nmake_op _ w5_op 0). - apply trans_equal with (xO (znz_digits w4_op)). - auto. - unfold nmake_op; auto. - Qed. - - Let spec_eval5n0: forall x, [N5 x] = eval5n 0 x. - intros x; rewrite spec_gen_eval5n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Let spec_extend5n6: forall x, [N5 x] = [N6 (extend5 0 x)]. - intros x; change (extend5 0 x) with (WW (znz_0 w5_op) x). - unfold to_Z; rewrite znz_to_Z_6. - rewrite (spec_0 w5_spec); auto. - Qed. - - Theorem digits_w5n1: znz_digits w6_op = znz_digits (nmake_op _ w5_op 1). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - rewrite digits_nmake. - rewrite digits_w5n0. - auto. - Qed. - - Let spec_eval5n1: forall x, [N6 x] = eval5n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_6. - rewrite digits_w5n0. - generalize (spec_eval5n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval5n, nmake_op5. - rewrite (znz_nmake_op _ w5_op 0); auto. - Qed. - Theorem digits_w5n2: znz_digits w7_op = znz_digits (nmake_op _ w5_op 2). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w5n1. - auto. - Qed. - - Let spec_eval5n2: forall x, [Nn 0 x] = eval5n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w5n1. - generalize (spec_eval5n1); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval5n, nmake_op5. - rewrite (znz_nmake_op _ w5_op 1); auto. - Qed. - - Let spec_eval5n3: forall x, [Nn 1 x] = eval5n 3 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w5n2. - generalize (spec_eval5n2); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval5n, nmake_op5. - rewrite (znz_nmake_op _ w5_op 2); auto. - Qed. - - Theorem digits_w6n0: znz_digits w6_op = znz_digits (nmake_op _ w6_op 0). - apply trans_equal with (xO (znz_digits w5_op)). - auto. - unfold nmake_op; auto. - Qed. - - Let spec_eval6n0: forall x, [N6 x] = eval6n 0 x. - intros x; rewrite spec_gen_eval6n; unfold GenBase.gen_to_Z, to_Z; auto. - Qed. - Theorem digits_w6n1: znz_digits w7_op = znz_digits (nmake_op _ w6_op 1). - apply trans_equal with (xO (znz_digits w6_op)). - auto. - rewrite digits_nmake. - rewrite digits_w6n0. - auto. - Qed. - - Let spec_eval6n1: forall x, [Nn 0 x] = eval6n 1 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_7. - rewrite digits_w6n0. - generalize (spec_eval6n0); unfold to_Z; intros HH; repeat rewrite HH. - unfold eval6n, nmake_op6. - rewrite (znz_nmake_op _ w6_op 0); auto. - Qed. - - Let spec_eval6n2: forall x, [Nn 1 x] = eval6n 2 x. - intros x; case x. - auto. - intros xh xl; unfold to_Z; rewrite znz_to_Z_8. - rewrite digits_w6n1. - generalize (spec_eval6n1); unfold to_Z; change (make_op 0) with (w7_op); intros HH; repeat rewrite HH. - unfold eval6n, nmake_op6. - rewrite (znz_nmake_op _ w6_op 1); auto. - Qed. - - Let digits_w6n: forall n, - znz_digits (make_op n) = znz_digits (nmake_op _ w6_op (S n)). - intros n; elim n; clear n. - change (znz_digits (make_op 0)) with (xO (znz_digits w6_op)). - rewrite nmake_op_S; apply sym_equal; auto. - intros n Hrec. - replace (znz_digits (make_op (S n))) with (xO (znz_digits (make_op n))). - rewrite Hrec. - rewrite nmake_op_S; apply sym_equal; auto. - rewrite make_op_S; apply sym_equal; auto. - Qed. - - Let spec_eval6n: forall n x, [Nn n x] = eval6n (S n) x. - intros n; elim n; clear n. - exact spec_eval6n1. - intros n Hrec x; case x; clear x. - unfold to_Z, eval6n, nmake_op6. - rewrite make_op_S; rewrite nmake_op_S; auto. - intros xh xl. - unfold to_Z in Hrec |- *. - rewrite znz_to_Z_n. - rewrite digits_w6n. - repeat rewrite Hrec. - unfold eval6n, nmake_op6. - apply sym_equal; rewrite nmake_op_S; auto. - Qed. - - Let spec_extend6n: forall n x, [N6 x] = [Nn n (extend6 n x)]. - intros n; elim n; clear n. - intros x; change (extend6 0 x) with (WW (znz_0 w6_op) x). - unfold to_Z. - change (make_op 0) with w7_op. - rewrite znz_to_Z_7; rewrite (spec_0 w6_spec); auto. - intros n Hrec x. - change (extend6 (S n) x) with (WW W0 (extend6 n x)). - unfold to_Z in Hrec |- *; rewrite znz_to_Z_n; auto. - rewrite <- Hrec. - replace (znz_to_Z (make_op n) W0) with 0; auto. - case n; auto; intros; rewrite make_op_S; auto. - Qed. - - Theorem spec_pos: forall x, 0 <= [x]. - Proof. - intros x; case x; clear x. - intros x; case (spec_to_Z w0_spec x); auto. - intros x; case (spec_to_Z w1_spec x); auto. - intros x; case (spec_to_Z w2_spec x); auto. - intros x; case (spec_to_Z w3_spec x); auto. - intros x; case (spec_to_Z w4_spec x); auto. - intros x; case (spec_to_Z w5_spec x); auto. - intros x; case (spec_to_Z w6_spec x); auto. - intros n x; case (spec_to_Z (wn_spec n) x); auto. - Qed. - - Let spec_extendn_0: forall n wx, [Nn n (extend n _ wx)] = [Nn 0 wx]. - intros n; elim n; auto. - intros n1 Hrec wx; simpl extend; rewrite <- Hrec; auto. - unfold to_Z. - case n1; auto; intros n2; repeat rewrite make_op_S; auto. - Qed. - Hint Rewrite spec_extendn_0: extr. - - Let spec_extendn0_0: forall n wx, [Nn (S n) (WW W0 wx)] = [Nn n wx]. - Proof. - intros n x; unfold to_Z. - rewrite znz_to_Z_n. - rewrite <- (Zplus_0_l (znz_to_Z (make_op n) x)). - apply (f_equal2 Zplus); auto. - case n; auto. - intros n1; rewrite make_op_S; auto. - Qed. - Hint Rewrite spec_extendn_0: extr. - - Let spec_extend_tr: forall m n (w: word _ (S n)), - [Nn (m + n) (extend_tr w m)] = [Nn n w]. - Proof. - induction m; auto. - intros n x; simpl extend_tr. - simpl plus; rewrite spec_extendn0_0; auto. - Qed. - Hint Rewrite spec_extend_tr: extr. - - Let spec_cast_l: forall n m x1, - [Nn (Max.max n m) - (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))] = - [Nn n x1]. - Proof. - intros n m x1; case (diff_r n m); simpl castm. - rewrite spec_extend_tr; auto. - Qed. - Hint Rewrite spec_cast_l: extr. - - Let spec_cast_r: forall n m x1, - [Nn (Max.max n m) - (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))] = - [Nn m x1]. - Proof. - intros n m x1; case (diff_l n m); simpl castm. - rewrite spec_extend_tr; auto. - Qed. - Hint Rewrite spec_cast_r: extr. - - Section LevelAndIter. - - Variable res: Set. - Variable xxx: res. - Variable P: Z -> Z -> res -> Prop. - (* Abstraction function for each level *) - Variable f0: w0 -> w0 -> res. - Variable f0n: forall n, w0 -> word w0 (S n) -> res. - Variable fn0: forall n, word w0 (S n) -> w0 -> res. - Variable Pf0: forall x y, P [N0 x] [N0 y] (f0 x y). - Variable Pf0n: forall n x y, Z_of_nat n <= 6 -> P [N0 x] (eval0n (S n) y) (f0n n x y). - Variable Pfn0: forall n x y, Z_of_nat n <= 6 -> P (eval0n (S n) x) [N0 y] (fn0 n x y). - - Variable f1: w1 -> w1 -> res. - Variable f1n: forall n, w1 -> word w1 (S n) -> res. - Variable fn1: forall n, word w1 (S n) -> w1 -> res. - Variable Pf1: forall x y, P [N1 x] [N1 y] (f1 x y). - Variable Pf1n: forall n x y, Z_of_nat n <= 5 -> P [N1 x] (eval1n (S n) y) (f1n n x y). - Variable Pfn1: forall n x y, Z_of_nat n <= 5 -> P (eval1n (S n) x) [N1 y] (fn1 n x y). - - Variable f2: w2 -> w2 -> res. - Variable f2n: forall n, w2 -> word w2 (S n) -> res. - Variable fn2: forall n, word w2 (S n) -> w2 -> res. - Variable Pf2: forall x y, P [N2 x] [N2 y] (f2 x y). - Variable Pf2n: forall n x y, Z_of_nat n <= 4 -> P [N2 x] (eval2n (S n) y) (f2n n x y). - Variable Pfn2: forall n x y, Z_of_nat n <= 4 -> P (eval2n (S n) x) [N2 y] (fn2 n x y). - - Variable f3: w3 -> w3 -> res. - Variable f3n: forall n, w3 -> word w3 (S n) -> res. - Variable fn3: forall n, word w3 (S n) -> w3 -> res. - Variable Pf3: forall x y, P [N3 x] [N3 y] (f3 x y). - Variable Pf3n: forall n x y, Z_of_nat n <= 3 -> P [N3 x] (eval3n (S n) y) (f3n n x y). - Variable Pfn3: forall n x y, Z_of_nat n <= 3 -> P (eval3n (S n) x) [N3 y] (fn3 n x y). - - Variable f4: w4 -> w4 -> res. - Variable f4n: forall n, w4 -> word w4 (S n) -> res. - Variable fn4: forall n, word w4 (S n) -> w4 -> res. - Variable Pf4: forall x y, P [N4 x] [N4 y] (f4 x y). - Variable Pf4n: forall n x y, Z_of_nat n <= 2 -> P [N4 x] (eval4n (S n) y) (f4n n x y). - Variable Pfn4: forall n x y, Z_of_nat n <= 2 -> P (eval4n (S n) x) [N4 y] (fn4 n x y). - - Variable f5: w5 -> w5 -> res. - Variable f5n: forall n, w5 -> word w5 (S n) -> res. - Variable fn5: forall n, word w5 (S n) -> w5 -> res. - Variable Pf5: forall x y, P [N5 x] [N5 y] (f5 x y). - Variable Pf5n: forall n x y, Z_of_nat n <= 1 -> P [N5 x] (eval5n (S n) y) (f5n n x y). - Variable Pfn5: forall n x y, Z_of_nat n <= 1 -> P (eval5n (S n) x) [N5 y] (fn5 n x y). - - Variable f6: w6 -> w6 -> res. - Variable f6n: forall n, w6 -> word w6 (S n) -> res. - Variable fn6: forall n, word w6 (S n) -> w6 -> res. - Variable Pf6: forall x y, P [N6 x] [N6 y] (f6 x y). - Variable Pf6n: forall n x y, P [N6 x] (eval6n (S n) y) (f6n n x y). - Variable Pfn6: forall n x y, P (eval6n (S n) x) [N6 y] (fn6 n x y). - - Variable fnn: forall n, word w6 (S n) -> word w6 (S n) -> res. - Variable Pfnn: forall n x y, P [Nn n x] [Nn n y] (fnn n x y). - Variable fnm: forall n m, word w6 (S n) -> word w6 (S m) -> res. - Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). - - (* Special zero functions *) - Variable f0t: t_ -> res. - Variable Pf0t: forall x, P 0 [x] (f0t x). - Variable ft0: t_ -> res. - Variable Pft0: forall x, P [x] 0 (ft0 x). - - (* We level the two arguments before applying *) - (* the functions at each leval *) - Definition same_level (x y: t_): res := - Eval lazy zeta beta iota delta [extend0 extend1 extend2 extend3 extend4 extend5 extend6 - GenBase.extend GenBase.extend_aux - ] in - match x, y with - | N0 wx, N0 wy => f0 wx wy - | N0 wx, N1 wy => f1 (extend0 0 wx) wy - | N0 wx, N2 wy => f2 (extend0 1 wx) wy - | N0 wx, N3 wy => f3 (extend0 2 wx) wy - | N0 wx, N4 wy => f4 (extend0 3 wx) wy - | N0 wx, N5 wy => f5 (extend0 4 wx) wy - | N0 wx, N6 wy => f6 (extend0 5 wx) wy - | N0 wx, Nn m wy => fnn m (extend6 m (extend0 5 wx)) wy - | N1 wx, N0 wy => f1 wx (extend0 0 wy) - | N1 wx, N1 wy => f1 wx wy - | N1 wx, N2 wy => f2 (extend1 0 wx) wy - | N1 wx, N3 wy => f3 (extend1 1 wx) wy - | N1 wx, N4 wy => f4 (extend1 2 wx) wy - | N1 wx, N5 wy => f5 (extend1 3 wx) wy - | N1 wx, N6 wy => f6 (extend1 4 wx) wy - | N1 wx, Nn m wy => fnn m (extend6 m (extend1 4 wx)) wy - | N2 wx, N0 wy => f2 wx (extend0 1 wy) - | N2 wx, N1 wy => f2 wx (extend1 0 wy) - | N2 wx, N2 wy => f2 wx wy - | N2 wx, N3 wy => f3 (extend2 0 wx) wy - | N2 wx, N4 wy => f4 (extend2 1 wx) wy - | N2 wx, N5 wy => f5 (extend2 2 wx) wy - | N2 wx, N6 wy => f6 (extend2 3 wx) wy - | N2 wx, Nn m wy => fnn m (extend6 m (extend2 3 wx)) wy - | N3 wx, N0 wy => f3 wx (extend0 2 wy) - | N3 wx, N1 wy => f3 wx (extend1 1 wy) - | N3 wx, N2 wy => f3 wx (extend2 0 wy) - | N3 wx, N3 wy => f3 wx wy - | N3 wx, N4 wy => f4 (extend3 0 wx) wy - | N3 wx, N5 wy => f5 (extend3 1 wx) wy - | N3 wx, N6 wy => f6 (extend3 2 wx) wy - | N3 wx, Nn m wy => fnn m (extend6 m (extend3 2 wx)) wy - | N4 wx, N0 wy => f4 wx (extend0 3 wy) - | N4 wx, N1 wy => f4 wx (extend1 2 wy) - | N4 wx, N2 wy => f4 wx (extend2 1 wy) - | N4 wx, N3 wy => f4 wx (extend3 0 wy) - | N4 wx, N4 wy => f4 wx wy - | N4 wx, N5 wy => f5 (extend4 0 wx) wy - | N4 wx, N6 wy => f6 (extend4 1 wx) wy - | N4 wx, Nn m wy => fnn m (extend6 m (extend4 1 wx)) wy - | N5 wx, N0 wy => f5 wx (extend0 4 wy) - | N5 wx, N1 wy => f5 wx (extend1 3 wy) - | N5 wx, N2 wy => f5 wx (extend2 2 wy) - | N5 wx, N3 wy => f5 wx (extend3 1 wy) - | N5 wx, N4 wy => f5 wx (extend4 0 wy) - | N5 wx, N5 wy => f5 wx wy - | N5 wx, N6 wy => f6 (extend5 0 wx) wy - | N5 wx, Nn m wy => fnn m (extend6 m (extend5 0 wx)) wy - | N6 wx, N0 wy => f6 wx (extend0 5 wy) - | N6 wx, N1 wy => f6 wx (extend1 4 wy) - | N6 wx, N2 wy => f6 wx (extend2 3 wy) - | N6 wx, N3 wy => f6 wx (extend3 2 wy) - | N6 wx, N4 wy => f6 wx (extend4 1 wy) - | N6 wx, N5 wy => f6 wx (extend5 0 wy) - | N6 wx, N6 wy => f6 wx wy - | N6 wx, Nn m wy => fnn m (extend6 m wx) wy - | Nn n wx, N0 wy => fnn n wx (extend6 n (extend0 5 wy)) - | Nn n wx, N1 wy => fnn n wx (extend6 n (extend1 4 wy)) - | Nn n wx, N2 wy => fnn n wx (extend6 n (extend2 3 wy)) - | Nn n wx, N3 wy => fnn n wx (extend6 n (extend3 2 wy)) - | Nn n wx, N4 wy => fnn n wx (extend6 n (extend4 1 wy)) - | Nn n wx, N5 wy => fnn n wx (extend6 n (extend5 0 wy)) - | Nn n wx, N6 wy => fnn n wx (extend6 n wy) - | Nn n wx, Nn m wy => - let mn := Max.max n m in - let d := diff n m in - fnn mn - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) - end. - - Lemma spec_same_level: forall x y, P [x] [y] (same_level x y). - Proof. - intros x; case x; clear x; unfold same_level. - intros x y; case y; clear y. - intros y; apply Pf0. - intros y; rewrite spec_extend0n1; apply Pf1. - intros y; rewrite spec_extend0n2; apply Pf2. - intros y; rewrite spec_extend0n3; apply Pf3. - intros y; rewrite spec_extend0n4; apply Pf4. - intros y; rewrite spec_extend0n5; apply Pf5. - intros y; rewrite spec_extend0n6; apply Pf6. - intros m y; rewrite spec_extend0n6; rewrite (spec_extend6n m); apply Pfnn. - intros x y; case y; clear y. - intros y; rewrite spec_extend0n1; apply Pf1. - intros y; apply Pf1. - intros y; rewrite spec_extend1n2; apply Pf2. - intros y; rewrite spec_extend1n3; apply Pf3. - intros y; rewrite spec_extend1n4; apply Pf4. - intros y; rewrite spec_extend1n5; apply Pf5. - intros y; rewrite spec_extend1n6; apply Pf6. - intros m y; rewrite spec_extend1n6; rewrite (spec_extend6n m); apply Pfnn. - intros x y; case y; clear y. - intros y; rewrite spec_extend0n2; apply Pf2. - intros y; rewrite spec_extend1n2; apply Pf2. - intros y; apply Pf2. - intros y; rewrite spec_extend2n3; apply Pf3. - intros y; rewrite spec_extend2n4; apply Pf4. - intros y; rewrite spec_extend2n5; apply Pf5. - intros y; rewrite spec_extend2n6; apply Pf6. - intros m y; rewrite spec_extend2n6; rewrite (spec_extend6n m); apply Pfnn. - intros x y; case y; clear y. - intros y; rewrite spec_extend0n3; apply Pf3. - intros y; rewrite spec_extend1n3; apply Pf3. - intros y; rewrite spec_extend2n3; apply Pf3. - intros y; apply Pf3. - intros y; rewrite spec_extend3n4; apply Pf4. - intros y; rewrite spec_extend3n5; apply Pf5. - intros y; rewrite spec_extend3n6; apply Pf6. - intros m y; rewrite spec_extend3n6; rewrite (spec_extend6n m); apply Pfnn. - intros x y; case y; clear y. - intros y; rewrite spec_extend0n4; apply Pf4. - intros y; rewrite spec_extend1n4; apply Pf4. - intros y; rewrite spec_extend2n4; apply Pf4. - intros y; rewrite spec_extend3n4; apply Pf4. - intros y; apply Pf4. - intros y; rewrite spec_extend4n5; apply Pf5. - intros y; rewrite spec_extend4n6; apply Pf6. - intros m y; rewrite spec_extend4n6; rewrite (spec_extend6n m); apply Pfnn. - intros x y; case y; clear y. - intros y; rewrite spec_extend0n5; apply Pf5. - intros y; rewrite spec_extend1n5; apply Pf5. - intros y; rewrite spec_extend2n5; apply Pf5. - intros y; rewrite spec_extend3n5; apply Pf5. - intros y; rewrite spec_extend4n5; apply Pf5. - intros y; apply Pf5. - intros y; rewrite spec_extend5n6; apply Pf6. - intros m y; rewrite spec_extend5n6; rewrite (spec_extend6n m); apply Pfnn. - intros x y; case y; clear y. - intros y; rewrite spec_extend0n6; apply Pf6. - intros y; rewrite spec_extend1n6; apply Pf6. - intros y; rewrite spec_extend2n6; apply Pf6. - intros y; rewrite spec_extend3n6; apply Pf6. - intros y; rewrite spec_extend4n6; apply Pf6. - intros y; rewrite spec_extend5n6; apply Pf6. - intros y; apply Pf6. - intros m y; rewrite (spec_extend6n m); apply Pfnn. - intros n x y; case y; clear y. - intros y; rewrite spec_extend0n6; rewrite (spec_extend6n n); apply Pfnn. - intros y; rewrite spec_extend1n6; rewrite (spec_extend6n n); apply Pfnn. - intros y; rewrite spec_extend2n6; rewrite (spec_extend6n n); apply Pfnn. - intros y; rewrite spec_extend3n6; rewrite (spec_extend6n n); apply Pfnn. - intros y; rewrite spec_extend4n6; rewrite (spec_extend6n n); apply Pfnn. - intros y; rewrite spec_extend5n6; rewrite (spec_extend6n n); apply Pfnn. - intros y; rewrite (spec_extend6n n); apply Pfnn. - intros m y; rewrite <- (spec_cast_l n m x); - rewrite <- (spec_cast_r n m y); apply Pfnn. - Qed. - - (* We level the two arguments before applying *) - (* the functions at each level (special zero case) *) - Definition same_level0 (x y: t_): res := - Eval lazy zeta beta iota delta [extend0 extend1 extend2 extend3 extend4 extend5 extend6 - GenBase.extend GenBase.extend_aux - ] in - match x with - | N0 wx => - if w0_eq0 wx then f0t y else - match y with - | N0 wy => f0 wx wy - | N1 wy => f1 (extend0 0 wx) wy - | N2 wy => f2 (extend0 1 wx) wy - | N3 wy => f3 (extend0 2 wx) wy - | N4 wy => f4 (extend0 3 wx) wy - | N5 wy => f5 (extend0 4 wx) wy - | N6 wy => f6 (extend0 5 wx) wy - | Nn m wy => fnn m (extend6 m (extend0 5 wx)) wy - end - | N1 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - f1 wx (extend0 0 wy) - | N1 wy => f1 wx wy - | N2 wy => f2 (extend1 0 wx) wy - | N3 wy => f3 (extend1 1 wx) wy - | N4 wy => f4 (extend1 2 wx) wy - | N5 wy => f5 (extend1 3 wx) wy - | N6 wy => f6 (extend1 4 wx) wy - | Nn m wy => fnn m (extend6 m (extend1 4 wx)) wy - end - | N2 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - f2 wx (extend0 1 wy) - | N1 wy => - f2 wx (extend1 0 wy) - | N2 wy => f2 wx wy - | N3 wy => f3 (extend2 0 wx) wy - | N4 wy => f4 (extend2 1 wx) wy - | N5 wy => f5 (extend2 2 wx) wy - | N6 wy => f6 (extend2 3 wx) wy - | Nn m wy => fnn m (extend6 m (extend2 3 wx)) wy - end - | N3 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - f3 wx (extend0 2 wy) - | N1 wy => - f3 wx (extend1 1 wy) - | N2 wy => - f3 wx (extend2 0 wy) - | N3 wy => f3 wx wy - | N4 wy => f4 (extend3 0 wx) wy - | N5 wy => f5 (extend3 1 wx) wy - | N6 wy => f6 (extend3 2 wx) wy - | Nn m wy => fnn m (extend6 m (extend3 2 wx)) wy - end - | N4 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - f4 wx (extend0 3 wy) - | N1 wy => - f4 wx (extend1 2 wy) - | N2 wy => - f4 wx (extend2 1 wy) - | N3 wy => - f4 wx (extend3 0 wy) - | N4 wy => f4 wx wy - | N5 wy => f5 (extend4 0 wx) wy - | N6 wy => f6 (extend4 1 wx) wy - | Nn m wy => fnn m (extend6 m (extend4 1 wx)) wy - end - | N5 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - f5 wx (extend0 4 wy) - | N1 wy => - f5 wx (extend1 3 wy) - | N2 wy => - f5 wx (extend2 2 wy) - | N3 wy => - f5 wx (extend3 1 wy) - | N4 wy => - f5 wx (extend4 0 wy) - | N5 wy => f5 wx wy - | N6 wy => f6 (extend5 0 wx) wy - | Nn m wy => fnn m (extend6 m (extend5 0 wx)) wy - end - | N6 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - f6 wx (extend0 5 wy) - | N1 wy => - f6 wx (extend1 4 wy) - | N2 wy => - f6 wx (extend2 3 wy) - | N3 wy => - f6 wx (extend3 2 wy) - | N4 wy => - f6 wx (extend4 1 wy) - | N5 wy => - f6 wx (extend5 0 wy) - | N6 wy => f6 wx wy - | Nn m wy => fnn m (extend6 m wx) wy - end - | Nn n wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fnn n wx (extend6 n (extend0 5 wy)) - | N1 wy => - fnn n wx (extend6 n (extend1 4 wy)) - | N2 wy => - fnn n wx (extend6 n (extend2 3 wy)) - | N3 wy => - fnn n wx (extend6 n (extend3 2 wy)) - | N4 wy => - fnn n wx (extend6 n (extend4 1 wy)) - | N5 wy => - fnn n wx (extend6 n (extend5 0 wy)) - | N6 wy => - fnn n wx (extend6 n wy) - | Nn m wy => - let mn := Max.max n m in - let d := diff n m in - fnn mn - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) - end - end. - - Lemma spec_same_level0: forall x y, P [x] [y] (same_level0 x y). - Proof. - intros x; case x; clear x; unfold same_level0. - intros x. - generalize (spec_w0_eq0 x); case w0_eq0; intros H. - intros y; rewrite H; apply Pf0t. - clear H. - intros y; case y; clear y. - intros y; apply Pf0. - intros y; rewrite spec_extend0n1; apply Pf1. - intros y; rewrite spec_extend0n2; apply Pf2. - intros y; rewrite spec_extend0n3; apply Pf3. - intros y; rewrite spec_extend0n4; apply Pf4. - intros y; rewrite spec_extend0n5; apply Pf5. - intros y; rewrite spec_extend0n6; apply Pf6. - intros m y; rewrite spec_extend0n6; rewrite (spec_extend6n m); apply Pfnn. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n1; apply Pf1. - intros y; apply Pf1. - intros y; rewrite spec_extend1n2; apply Pf2. - intros y; rewrite spec_extend1n3; apply Pf3. - intros y; rewrite spec_extend1n4; apply Pf4. - intros y; rewrite spec_extend1n5; apply Pf5. - intros y; rewrite spec_extend1n6; apply Pf6. - intros m y; rewrite spec_extend1n6; rewrite (spec_extend6n m); apply Pfnn. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n2; apply Pf2. - intros y. - rewrite spec_extend1n2; apply Pf2. - intros y; apply Pf2. - intros y; rewrite spec_extend2n3; apply Pf3. - intros y; rewrite spec_extend2n4; apply Pf4. - intros y; rewrite spec_extend2n5; apply Pf5. - intros y; rewrite spec_extend2n6; apply Pf6. - intros m y; rewrite spec_extend2n6; rewrite (spec_extend6n m); apply Pfnn. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n3; apply Pf3. - intros y. - rewrite spec_extend1n3; apply Pf3. - intros y. - rewrite spec_extend2n3; apply Pf3. - intros y; apply Pf3. - intros y; rewrite spec_extend3n4; apply Pf4. - intros y; rewrite spec_extend3n5; apply Pf5. - intros y; rewrite spec_extend3n6; apply Pf6. - intros m y; rewrite spec_extend3n6; rewrite (spec_extend6n m); apply Pfnn. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n4; apply Pf4. - intros y. - rewrite spec_extend1n4; apply Pf4. - intros y. - rewrite spec_extend2n4; apply Pf4. - intros y. - rewrite spec_extend3n4; apply Pf4. - intros y; apply Pf4. - intros y; rewrite spec_extend4n5; apply Pf5. - intros y; rewrite spec_extend4n6; apply Pf6. - intros m y; rewrite spec_extend4n6; rewrite (spec_extend6n m); apply Pfnn. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n5; apply Pf5. - intros y. - rewrite spec_extend1n5; apply Pf5. - intros y. - rewrite spec_extend2n5; apply Pf5. - intros y. - rewrite spec_extend3n5; apply Pf5. - intros y. - rewrite spec_extend4n5; apply Pf5. - intros y; apply Pf5. - intros y; rewrite spec_extend5n6; apply Pf6. - intros m y; rewrite spec_extend5n6; rewrite (spec_extend6n m); apply Pfnn. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n6; apply Pf6. - intros y. - rewrite spec_extend1n6; apply Pf6. - intros y. - rewrite spec_extend2n6; apply Pf6. - intros y. - rewrite spec_extend3n6; apply Pf6. - intros y. - rewrite spec_extend4n6; apply Pf6. - intros y. - rewrite spec_extend5n6; apply Pf6. - intros y; apply Pf6. - intros m y; rewrite (spec_extend6n m); apply Pfnn. - intros n x y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n6; rewrite (spec_extend6n n); apply Pfnn. - intros y. - rewrite spec_extend1n6; rewrite (spec_extend6n n); apply Pfnn. - intros y. - rewrite spec_extend2n6; rewrite (spec_extend6n n); apply Pfnn. - intros y. - rewrite spec_extend3n6; rewrite (spec_extend6n n); apply Pfnn. - intros y. - rewrite spec_extend4n6; rewrite (spec_extend6n n); apply Pfnn. - intros y. - rewrite spec_extend5n6; rewrite (spec_extend6n n); apply Pfnn. - intros y. - rewrite (spec_extend6n n); apply Pfnn. - intros m y; rewrite <- (spec_cast_l n m x); - rewrite <- (spec_cast_r n m y); apply Pfnn. - Qed. - - (* We iter the smaller argument with the bigger *) - Definition iter (x y: t_): res := - Eval lazy zeta beta iota delta [extend0 extend1 extend2 extend3 extend4 extend5 extend6 - GenBase.extend GenBase.extend_aux - ] in - match x, y with - | N0 wx, N0 wy => f0 wx wy - | N0 wx, N1 wy => f0n 0 wx wy - | N0 wx, N2 wy => f0n 1 wx wy - | N0 wx, N3 wy => f0n 2 wx wy - | N0 wx, N4 wy => f0n 3 wx wy - | N0 wx, N5 wy => f0n 4 wx wy - | N0 wx, N6 wy => f0n 5 wx wy - | N0 wx, Nn m wy => f6n m (extend0 5 wx) wy - | N1 wx, N0 wy => fn0 0 wx wy - | N1 wx, N1 wy => f1 wx wy - | N1 wx, N2 wy => f1n 0 wx wy - | N1 wx, N3 wy => f1n 1 wx wy - | N1 wx, N4 wy => f1n 2 wx wy - | N1 wx, N5 wy => f1n 3 wx wy - | N1 wx, N6 wy => f1n 4 wx wy - | N1 wx, Nn m wy => f6n m (extend1 4 wx) wy - | N2 wx, N0 wy => fn0 1 wx wy - | N2 wx, N1 wy => fn1 0 wx wy - | N2 wx, N2 wy => f2 wx wy - | N2 wx, N3 wy => f2n 0 wx wy - | N2 wx, N4 wy => f2n 1 wx wy - | N2 wx, N5 wy => f2n 2 wx wy - | N2 wx, N6 wy => f2n 3 wx wy - | N2 wx, Nn m wy => f6n m (extend2 3 wx) wy - | N3 wx, N0 wy => fn0 2 wx wy - | N3 wx, N1 wy => fn1 1 wx wy - | N3 wx, N2 wy => fn2 0 wx wy - | N3 wx, N3 wy => f3 wx wy - | N3 wx, N4 wy => f3n 0 wx wy - | N3 wx, N5 wy => f3n 1 wx wy - | N3 wx, N6 wy => f3n 2 wx wy - | N3 wx, Nn m wy => f6n m (extend3 2 wx) wy - | N4 wx, N0 wy => fn0 3 wx wy - | N4 wx, N1 wy => fn1 2 wx wy - | N4 wx, N2 wy => fn2 1 wx wy - | N4 wx, N3 wy => fn3 0 wx wy - | N4 wx, N4 wy => f4 wx wy - | N4 wx, N5 wy => f4n 0 wx wy - | N4 wx, N6 wy => f4n 1 wx wy - | N4 wx, Nn m wy => f6n m (extend4 1 wx) wy - | N5 wx, N0 wy => fn0 4 wx wy - | N5 wx, N1 wy => fn1 3 wx wy - | N5 wx, N2 wy => fn2 2 wx wy - | N5 wx, N3 wy => fn3 1 wx wy - | N5 wx, N4 wy => fn4 0 wx wy - | N5 wx, N5 wy => f5 wx wy - | N5 wx, N6 wy => f5n 0 wx wy - | N5 wx, Nn m wy => f6n m (extend5 0 wx) wy - | N6 wx, N0 wy => fn0 5 wx wy - | N6 wx, N1 wy => fn1 4 wx wy - | N6 wx, N2 wy => fn2 3 wx wy - | N6 wx, N3 wy => fn3 2 wx wy - | N6 wx, N4 wy => fn4 1 wx wy - | N6 wx, N5 wy => fn5 0 wx wy - | N6 wx, N6 wy => f6 wx wy - | N6 wx, Nn m wy => f6n m wx wy - | Nn n wx, N0 wy => fn6 n wx (extend0 5 wy) - | Nn n wx, N1 wy => fn6 n wx (extend1 4 wy) - | Nn n wx, N2 wy => fn6 n wx (extend2 3 wy) - | Nn n wx, N3 wy => fn6 n wx (extend3 2 wy) - | Nn n wx, N4 wy => fn6 n wx (extend4 1 wy) - | Nn n wx, N5 wy => fn6 n wx (extend5 0 wy) - | Nn n wx, N6 wy => fn6 n wx wy - | Nn n wx, Nn m wy => fnm n m wx wy - end. - - Ltac zg_tac := try - (red; simpl Zcompare; auto; - let t := fresh "H" in (intros t; discriminate H)). - Lemma spec_iter: forall x y, P [x] [y] (iter x y). - Proof. - intros x; case x; clear x; unfold iter. - intros x y; case y; clear y. - intros y; apply Pf0. - intros y; rewrite spec_eval0n1; apply (Pf0n 0); zg_tac. - intros y; rewrite spec_eval0n2; apply (Pf0n 1); zg_tac. - intros y; rewrite spec_eval0n3; apply (Pf0n 2); zg_tac. - intros y; rewrite spec_eval0n4; apply (Pf0n 3); zg_tac. - intros y; rewrite spec_eval0n5; apply (Pf0n 4); zg_tac. - intros y; rewrite spec_eval0n6; apply (Pf0n 5); zg_tac. - intros m y; rewrite spec_extend0n6; rewrite spec_eval6n; apply Pf6n. - intros x y; case y; clear y. - intros y; rewrite spec_eval0n1; apply (Pfn0 0); zg_tac. - intros y; apply Pf1. - intros y; rewrite spec_eval1n1; apply (Pf1n 0); zg_tac. - intros y; rewrite spec_eval1n2; apply (Pf1n 1); zg_tac. - intros y; rewrite spec_eval1n3; apply (Pf1n 2); zg_tac. - intros y; rewrite spec_eval1n4; apply (Pf1n 3); zg_tac. - intros y; rewrite spec_eval1n5; apply (Pf1n 4); zg_tac. - intros m y; rewrite spec_extend1n6; rewrite spec_eval6n; apply Pf6n. - intros x y; case y; clear y. - intros y; rewrite spec_eval0n2; apply (Pfn0 1); zg_tac. - intros y; rewrite spec_eval1n1; apply (Pfn1 0); zg_tac. - intros y; apply Pf2. - intros y; rewrite spec_eval2n1; apply (Pf2n 0); zg_tac. - intros y; rewrite spec_eval2n2; apply (Pf2n 1); zg_tac. - intros y; rewrite spec_eval2n3; apply (Pf2n 2); zg_tac. - intros y; rewrite spec_eval2n4; apply (Pf2n 3); zg_tac. - intros m y; rewrite spec_extend2n6; rewrite spec_eval6n; apply Pf6n. - intros x y; case y; clear y. - intros y; rewrite spec_eval0n3; apply (Pfn0 2); zg_tac. - intros y; rewrite spec_eval1n2; apply (Pfn1 1); zg_tac. - intros y; rewrite spec_eval2n1; apply (Pfn2 0); zg_tac. - intros y; apply Pf3. - intros y; rewrite spec_eval3n1; apply (Pf3n 0); zg_tac. - intros y; rewrite spec_eval3n2; apply (Pf3n 1); zg_tac. - intros y; rewrite spec_eval3n3; apply (Pf3n 2); zg_tac. - intros m y; rewrite spec_extend3n6; rewrite spec_eval6n; apply Pf6n. - intros x y; case y; clear y. - intros y; rewrite spec_eval0n4; apply (Pfn0 3); zg_tac. - intros y; rewrite spec_eval1n3; apply (Pfn1 2); zg_tac. - intros y; rewrite spec_eval2n2; apply (Pfn2 1); zg_tac. - intros y; rewrite spec_eval3n1; apply (Pfn3 0); zg_tac. - intros y; apply Pf4. - intros y; rewrite spec_eval4n1; apply (Pf4n 0); zg_tac. - intros y; rewrite spec_eval4n2; apply (Pf4n 1); zg_tac. - intros m y; rewrite spec_extend4n6; rewrite spec_eval6n; apply Pf6n. - intros x y; case y; clear y. - intros y; rewrite spec_eval0n5; apply (Pfn0 4); zg_tac. - intros y; rewrite spec_eval1n4; apply (Pfn1 3); zg_tac. - intros y; rewrite spec_eval2n3; apply (Pfn2 2); zg_tac. - intros y; rewrite spec_eval3n2; apply (Pfn3 1); zg_tac. - intros y; rewrite spec_eval4n1; apply (Pfn4 0); zg_tac. - intros y; apply Pf5. - intros y; rewrite spec_eval5n1; apply (Pf5n 0); zg_tac. - intros m y; rewrite spec_extend5n6; rewrite spec_eval6n; apply Pf6n. - intros x y; case y; clear y. - intros y; rewrite spec_eval0n6; apply (Pfn0 5); zg_tac. - intros y; rewrite spec_eval1n5; apply (Pfn1 4); zg_tac. - intros y; rewrite spec_eval2n4; apply (Pfn2 3); zg_tac. - intros y; rewrite spec_eval3n3; apply (Pfn3 2); zg_tac. - intros y; rewrite spec_eval4n2; apply (Pfn4 1); zg_tac. - intros y; rewrite spec_eval5n1; apply (Pfn5 0); zg_tac. - intros y; apply Pf6. - intros m y; rewrite spec_eval6n; apply Pf6n. - intros n x y; case y; clear y. - intros y; rewrite spec_extend0n6; rewrite spec_eval6n; apply Pfn6. - intros y; rewrite spec_extend1n6; rewrite spec_eval6n; apply Pfn6. - intros y; rewrite spec_extend2n6; rewrite spec_eval6n; apply Pfn6. - intros y; rewrite spec_extend3n6; rewrite spec_eval6n; apply Pfn6. - intros y; rewrite spec_extend4n6; rewrite spec_eval6n; apply Pfn6. - intros y; rewrite spec_extend5n6; rewrite spec_eval6n; apply Pfn6. - intros y; rewrite spec_eval6n; apply Pfn6. - intros m y; apply Pfnm. - Qed. - - (* We iter the smaller argument with the bigger (zero case) *) - Definition iter0 (x y: t_): res := - Eval lazy zeta beta iota delta [extend0 extend1 extend2 extend3 extend4 extend5 extend6 - GenBase.extend GenBase.extend_aux - ] in - match x with - | N0 wx => - if w0_eq0 wx then f0t y else - match y with - | N0 wy => f0 wx wy - | N1 wy => f0n 0 wx wy - | N2 wy => f0n 1 wx wy - | N3 wy => f0n 2 wx wy - | N4 wy => f0n 3 wx wy - | N5 wy => f0n 4 wx wy - | N6 wy => f0n 5 wx wy - | Nn m wy => f6n m (extend0 5 wx) wy - end - | N1 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn0 0 wx wy - | N1 wy => f1 wx wy - | N2 wy => f1n 0 wx wy - | N3 wy => f1n 1 wx wy - | N4 wy => f1n 2 wx wy - | N5 wy => f1n 3 wx wy - | N6 wy => f1n 4 wx wy - | Nn m wy => f6n m (extend1 4 wx) wy - end - | N2 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn0 1 wx wy - | N1 wy => - fn1 0 wx wy - | N2 wy => f2 wx wy - | N3 wy => f2n 0 wx wy - | N4 wy => f2n 1 wx wy - | N5 wy => f2n 2 wx wy - | N6 wy => f2n 3 wx wy - | Nn m wy => f6n m (extend2 3 wx) wy - end - | N3 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn0 2 wx wy - | N1 wy => - fn1 1 wx wy - | N2 wy => - fn2 0 wx wy - | N3 wy => f3 wx wy - | N4 wy => f3n 0 wx wy - | N5 wy => f3n 1 wx wy - | N6 wy => f3n 2 wx wy - | Nn m wy => f6n m (extend3 2 wx) wy - end - | N4 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn0 3 wx wy - | N1 wy => - fn1 2 wx wy - | N2 wy => - fn2 1 wx wy - | N3 wy => - fn3 0 wx wy - | N4 wy => f4 wx wy - | N5 wy => f4n 0 wx wy - | N6 wy => f4n 1 wx wy - | Nn m wy => f6n m (extend4 1 wx) wy - end - | N5 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn0 4 wx wy - | N1 wy => - fn1 3 wx wy - | N2 wy => - fn2 2 wx wy - | N3 wy => - fn3 1 wx wy - | N4 wy => - fn4 0 wx wy - | N5 wy => f5 wx wy - | N6 wy => f5n 0 wx wy - | Nn m wy => f6n m (extend5 0 wx) wy - end - | N6 wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn0 5 wx wy - | N1 wy => - fn1 4 wx wy - | N2 wy => - fn2 3 wx wy - | N3 wy => - fn3 2 wx wy - | N4 wy => - fn4 1 wx wy - | N5 wy => - fn5 0 wx wy - | N6 wy => f6 wx wy - | Nn m wy => f6n m wx wy - end - | Nn n wx => - match y with - | N0 wy => - if w0_eq0 wy then ft0 x else - fn6 n wx (extend0 5 wy) - | N1 wy => - fn6 n wx (extend1 4 wy) - | N2 wy => - fn6 n wx (extend2 3 wy) - | N3 wy => - fn6 n wx (extend3 2 wy) - | N4 wy => - fn6 n wx (extend4 1 wy) - | N5 wy => - fn6 n wx (extend5 0 wy) - | N6 wy => - fn6 n wx wy - | Nn m wy => fnm n m wx wy - end - end. - - Lemma spec_iter0: forall x y, P [x] [y] (iter0 x y). - Proof. - intros x; case x; clear x; unfold iter0. - intros x. - generalize (spec_w0_eq0 x); case w0_eq0; intros H. - intros y; rewrite H; apply Pf0t. - clear H. - intros y; case y; clear y. - intros y; apply Pf0. - intros y; rewrite spec_eval0n1; apply (Pf0n 0); zg_tac. - intros y; rewrite spec_eval0n2; apply (Pf0n 1); zg_tac. - intros y; rewrite spec_eval0n3; apply (Pf0n 2); zg_tac. - intros y; rewrite spec_eval0n4; apply (Pf0n 3); zg_tac. - intros y; rewrite spec_eval0n5; apply (Pf0n 4); zg_tac. - intros y; rewrite spec_eval0n6; apply (Pf0n 5); zg_tac. - intros m y; rewrite spec_extend0n6; rewrite spec_eval6n; apply Pf6n. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_eval0n1; apply (Pfn0 0); zg_tac. - intros y; apply Pf1. - intros y; rewrite spec_eval1n1; apply (Pf1n 0); zg_tac. - intros y; rewrite spec_eval1n2; apply (Pf1n 1); zg_tac. - intros y; rewrite spec_eval1n3; apply (Pf1n 2); zg_tac. - intros y; rewrite spec_eval1n4; apply (Pf1n 3); zg_tac. - intros y; rewrite spec_eval1n5; apply (Pf1n 4); zg_tac. - intros m y; rewrite spec_extend1n6; rewrite spec_eval6n; apply Pf6n. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_eval0n2; apply (Pfn0 1); zg_tac. - intros y. - rewrite spec_eval1n1; apply (Pfn1 0); zg_tac. - intros y; apply Pf2. - intros y; rewrite spec_eval2n1; apply (Pf2n 0); zg_tac. - intros y; rewrite spec_eval2n2; apply (Pf2n 1); zg_tac. - intros y; rewrite spec_eval2n3; apply (Pf2n 2); zg_tac. - intros y; rewrite spec_eval2n4; apply (Pf2n 3); zg_tac. - intros m y; rewrite spec_extend2n6; rewrite spec_eval6n; apply Pf6n. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_eval0n3; apply (Pfn0 2); zg_tac. - intros y. - rewrite spec_eval1n2; apply (Pfn1 1); zg_tac. - intros y. - rewrite spec_eval2n1; apply (Pfn2 0); zg_tac. - intros y; apply Pf3. - intros y; rewrite spec_eval3n1; apply (Pf3n 0); zg_tac. - intros y; rewrite spec_eval3n2; apply (Pf3n 1); zg_tac. - intros y; rewrite spec_eval3n3; apply (Pf3n 2); zg_tac. - intros m y; rewrite spec_extend3n6; rewrite spec_eval6n; apply Pf6n. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_eval0n4; apply (Pfn0 3); zg_tac. - intros y. - rewrite spec_eval1n3; apply (Pfn1 2); zg_tac. - intros y. - rewrite spec_eval2n2; apply (Pfn2 1); zg_tac. - intros y. - rewrite spec_eval3n1; apply (Pfn3 0); zg_tac. - intros y; apply Pf4. - intros y; rewrite spec_eval4n1; apply (Pf4n 0); zg_tac. - intros y; rewrite spec_eval4n2; apply (Pf4n 1); zg_tac. - intros m y; rewrite spec_extend4n6; rewrite spec_eval6n; apply Pf6n. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_eval0n5; apply (Pfn0 4); zg_tac. - intros y. - rewrite spec_eval1n4; apply (Pfn1 3); zg_tac. - intros y. - rewrite spec_eval2n3; apply (Pfn2 2); zg_tac. - intros y. - rewrite spec_eval3n2; apply (Pfn3 1); zg_tac. - intros y. - rewrite spec_eval4n1; apply (Pfn4 0); zg_tac. - intros y; apply Pf5. - intros y; rewrite spec_eval5n1; apply (Pf5n 0); zg_tac. - intros m y; rewrite spec_extend5n6; rewrite spec_eval6n; apply Pf6n. - intros x. - intros y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_eval0n6; apply (Pfn0 5); zg_tac. - intros y. - rewrite spec_eval1n5; apply (Pfn1 4); zg_tac. - intros y. - rewrite spec_eval2n4; apply (Pfn2 3); zg_tac. - intros y. - rewrite spec_eval3n3; apply (Pfn3 2); zg_tac. - intros y. - rewrite spec_eval4n2; apply (Pfn4 1); zg_tac. - intros y. - rewrite spec_eval5n1; apply (Pfn5 0); zg_tac. - intros y; apply Pf6. - intros m y; rewrite spec_eval6n; apply Pf6n. - intros n x y; case y; clear y. - intros y. - generalize (spec_w0_eq0 y); case w0_eq0; intros H. - rewrite H; apply Pft0. - clear H. - rewrite spec_extend0n6; rewrite spec_eval6n; apply Pfn6. - intros y. - rewrite spec_extend1n6; rewrite spec_eval6n; apply Pfn6. - intros y. - rewrite spec_extend2n6; rewrite spec_eval6n; apply Pfn6. - intros y. - rewrite spec_extend3n6; rewrite spec_eval6n; apply Pfn6. - intros y. - rewrite spec_extend4n6; rewrite spec_eval6n; apply Pfn6. - intros y. - rewrite spec_extend5n6; rewrite spec_eval6n; apply Pfn6. - intros y. - rewrite spec_eval6n; apply Pfn6. - intros m y; apply Pfnm. - Qed. - - End LevelAndIter. - - (***************************************************************) - (* *) - (* Reduction *) - (* *) - (***************************************************************) - - Definition reduce_0 (x:w) := N0 x. - Definition reduce_1 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w0_eq0 N0 N1. - Definition reduce_2 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w1_eq0 reduce_1 N2. - Definition reduce_3 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w2_eq0 reduce_2 N3. - Definition reduce_4 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w3_eq0 reduce_3 N4. - Definition reduce_5 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w4_eq0 reduce_4 N5. - Definition reduce_6 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w5_eq0 reduce_5 N6. - Definition reduce_7 := - Eval lazy beta iota delta[reduce_n1] in - reduce_n1 _ _ zero w6_eq0 reduce_6 (Nn 0). - Definition reduce_n n := - Eval lazy beta iota delta[reduce_n] in - reduce_n _ _ zero reduce_7 Nn n. - - Let spec_reduce_0: forall x, [reduce_0 x] = [N0 x]. - Proof. - intros x; unfold to_Z, reduce_0. - auto. - Qed. - - Let spec_reduce_1: forall x, [reduce_1 x] = [N1 x]. - Proof. - intros x; case x; unfold reduce_1. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w0_eq0 x1); - case w0_eq0; intros H1; auto. - unfold to_Z; rewrite znz_to_Z_1. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_2: forall x, [reduce_2 x] = [N2 x]. - Proof. - intros x; case x; unfold reduce_2. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w1_eq0 x1); - case w1_eq0; intros H1; auto. - rewrite spec_reduce_1. - unfold to_Z; rewrite znz_to_Z_2. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_3: forall x, [reduce_3 x] = [N3 x]. - Proof. - intros x; case x; unfold reduce_3. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w2_eq0 x1); - case w2_eq0; intros H1; auto. - rewrite spec_reduce_2. - unfold to_Z; rewrite znz_to_Z_3. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_4: forall x, [reduce_4 x] = [N4 x]. - Proof. - intros x; case x; unfold reduce_4. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w3_eq0 x1); - case w3_eq0; intros H1; auto. - rewrite spec_reduce_3. - unfold to_Z; rewrite znz_to_Z_4. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_5: forall x, [reduce_5 x] = [N5 x]. - Proof. - intros x; case x; unfold reduce_5. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w4_eq0 x1); - case w4_eq0; intros H1; auto. - rewrite spec_reduce_4. - unfold to_Z; rewrite znz_to_Z_5. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_6: forall x, [reduce_6 x] = [N6 x]. - Proof. - intros x; case x; unfold reduce_6. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w5_eq0 x1); - case w5_eq0; intros H1; auto. - rewrite spec_reduce_5. - unfold to_Z; rewrite znz_to_Z_6. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_7: forall x, [reduce_7 x] = [Nn 0 x]. - Proof. - intros x; case x; unfold reduce_7. - exact (spec_0 w0_spec). - intros x1 y1. - generalize (spec_w6_eq0 x1); - case w6_eq0; intros H1; auto. - rewrite spec_reduce_6. - unfold to_Z; rewrite znz_to_Z_7. - unfold to_Z in H1; rewrite H1; auto. - Qed. - - Let spec_reduce_n: forall n x, [reduce_n n x] = [Nn n x]. - Proof. - intros n; elim n; simpl reduce_n. - intros x; rewrite <- spec_reduce_7; auto. - intros n1 Hrec x; case x. - unfold to_Z; rewrite make_op_S; auto. - exact (spec_0 w0_spec). - intros x1 y1; case x1; auto. - rewrite Hrec. - rewrite spec_extendn0_0; auto. - Qed. - - (***************************************************************) - (* *) - (* Successor *) - (* *) - (***************************************************************) - - Definition w0_succ_c := w0_op.(znz_succ_c). - Definition w1_succ_c := w1_op.(znz_succ_c). - Definition w2_succ_c := w2_op.(znz_succ_c). - Definition w3_succ_c := w3_op.(znz_succ_c). - Definition w4_succ_c := w4_op.(znz_succ_c). - Definition w5_succ_c := w5_op.(znz_succ_c). - Definition w6_succ_c := w6_op.(znz_succ_c). - - Definition w0_succ := w0_op.(znz_succ). - Definition w1_succ := w1_op.(znz_succ). - Definition w2_succ := w2_op.(znz_succ). - Definition w3_succ := w3_op.(znz_succ). - Definition w4_succ := w4_op.(znz_succ). - Definition w5_succ := w5_op.(znz_succ). - Definition w6_succ := w6_op.(znz_succ). - - Definition succ x := - match x with - | N0 wx => - match w0_succ_c wx with - | C0 r => N0 r - | C1 r => N1 (WW one0 r) - end - | N1 wx => - match w1_succ_c wx with - | C0 r => N1 r - | C1 r => N2 (WW one1 r) - end - | N2 wx => - match w2_succ_c wx with - | C0 r => N2 r - | C1 r => N3 (WW one2 r) - end - | N3 wx => - match w3_succ_c wx with - | C0 r => N3 r - | C1 r => N4 (WW one3 r) - end - | N4 wx => - match w4_succ_c wx with - | C0 r => N4 r - | C1 r => N5 (WW one4 r) - end - | N5 wx => - match w5_succ_c wx with - | C0 r => N5 r - | C1 r => N6 (WW one5 r) - end - | N6 wx => - match w6_succ_c wx with - | C0 r => N6 r - | C1 r => Nn 0 (WW one6 r) - end - | Nn n wx => - let op := make_op n in - match op.(znz_succ_c) wx with - | C0 r => Nn n r - | C1 r => Nn (S n) (WW op.(znz_1) r) - end - end. - - Theorem spec_succ: forall n, [succ n] = [n] + 1. - Proof. - intros n; case n; unfold succ, to_Z. - intros n1; generalize (spec_succ_c w0_spec n1); - unfold succ, to_Z, w0_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_1; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w0_spec)). - intros n1; generalize (spec_succ_c w1_spec n1); - unfold succ, to_Z, w1_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_2; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w1_spec)). - intros n1; generalize (spec_succ_c w2_spec n1); - unfold succ, to_Z, w2_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_3; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w2_spec)). - intros n1; generalize (spec_succ_c w3_spec n1); - unfold succ, to_Z, w3_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_4; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w3_spec)). - intros n1; generalize (spec_succ_c w4_spec n1); - unfold succ, to_Z, w4_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_5; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w4_spec)). - intros n1; generalize (spec_succ_c w5_spec n1); - unfold succ, to_Z, w5_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_6; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w5_spec)). - intros n1; generalize (spec_succ_c w6_spec n1); - unfold succ, to_Z, w6_succ_c; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite znz_to_Z_7; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w6_spec)). - intros k n1; generalize (spec_succ_c (wn_spec k) n1). - unfold succ, to_Z; case znz_succ_c; auto. - intros ww H; rewrite <- H. - (rewrite (znz_to_Z_n k); unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 (wn_spec k))). - Qed. - - (***************************************************************) - (* *) - (* Adddition *) - (* *) - (***************************************************************) - - Definition w0_add_c := znz_add_c w0_op. - Definition w0_add x y := - match w0_add_c x y with - | C0 r => N0 r - | C1 r => N1 (WW one0 r) - end. - - Definition w1_add_c := znz_add_c w1_op. - Definition w1_add x y := - match w1_add_c x y with - | C0 r => N1 r - | C1 r => N2 (WW one1 r) - end. - - Definition w2_add_c := znz_add_c w2_op. - Definition w2_add x y := - match w2_add_c x y with - | C0 r => N2 r - | C1 r => N3 (WW one2 r) - end. - - Definition w3_add_c := znz_add_c w3_op. - Definition w3_add x y := - match w3_add_c x y with - | C0 r => N3 r - | C1 r => N4 (WW one3 r) - end. - - Definition w4_add_c := znz_add_c w4_op. - Definition w4_add x y := - match w4_add_c x y with - | C0 r => N4 r - | C1 r => N5 (WW one4 r) - end. - - Definition w5_add_c := znz_add_c w5_op. - Definition w5_add x y := - match w5_add_c x y with - | C0 r => N5 r - | C1 r => N6 (WW one5 r) - end. - - Definition w6_add_c := znz_add_c w6_op. - Definition w6_add x y := - match w6_add_c x y with - | C0 r => N6 r - | C1 r => Nn 0 (WW one6 r) - end. - - Definition addn n (x y : word w6 (S n)) := - let op := make_op n in - match op.(znz_add_c) x y with - | C0 r => Nn n r - | C1 r => Nn (S n) (WW op.(znz_1) r) end. - - Let spec_w0_add: forall x y, [w0_add x y] = [N0 x] + [N0 y]. - Proof. - intros n m; unfold to_Z, w0_add, w0_add_c. - generalize (spec_add_c w0_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_1; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w0_spec). - Qed. - Hint Rewrite spec_w0_add: addr. - - Let spec_w1_add: forall x y, [w1_add x y] = [N1 x] + [N1 y]. - Proof. - intros n m; unfold to_Z, w1_add, w1_add_c. - generalize (spec_add_c w1_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_2; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w1_spec). - Qed. - Hint Rewrite spec_w1_add: addr. - - Let spec_w2_add: forall x y, [w2_add x y] = [N2 x] + [N2 y]. - Proof. - intros n m; unfold to_Z, w2_add, w2_add_c. - generalize (spec_add_c w2_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_3; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w2_spec). - Qed. - Hint Rewrite spec_w2_add: addr. - - Let spec_w3_add: forall x y, [w3_add x y] = [N3 x] + [N3 y]. - Proof. - intros n m; unfold to_Z, w3_add, w3_add_c. - generalize (spec_add_c w3_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_4; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w3_spec). - Qed. - Hint Rewrite spec_w3_add: addr. - - Let spec_w4_add: forall x y, [w4_add x y] = [N4 x] + [N4 y]. - Proof. - intros n m; unfold to_Z, w4_add, w4_add_c. - generalize (spec_add_c w4_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_5; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w4_spec). - Qed. - Hint Rewrite spec_w4_add: addr. - - Let spec_w5_add: forall x y, [w5_add x y] = [N5 x] + [N5 y]. - Proof. - intros n m; unfold to_Z, w5_add, w5_add_c. - generalize (spec_add_c w5_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_6; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w5_spec). - Qed. - Hint Rewrite spec_w5_add: addr. - - Let spec_w6_add: forall x y, [w6_add x y] = [N6 x] + [N6 y]. - Proof. - intros n m; unfold to_Z, w6_add, w6_add_c. - generalize (spec_add_c w6_spec n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite znz_to_Z_7; unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 w6_spec). - Qed. - Hint Rewrite spec_w6_add: addr. - - Let spec_wn_add: forall n x y, [addn n x y] = [Nn n x] + [Nn n y]. - Proof. - intros k n m; unfold to_Z, addn. - generalize (spec_add_c (wn_spec k) n m); case znz_add_c; auto. - intros ww H; rewrite <- H. - rewrite (znz_to_Z_n k); unfold interp_carry; - apply f_equal2 with (f := Zplus); auto; - apply f_equal2 with (f := Zmult); auto; - exact (spec_1 (wn_spec k)). - Qed. - Hint Rewrite spec_wn_add: addr. - Definition add := Eval lazy beta delta [same_level] in - (same_level t_ w0_add w1_add w2_add w3_add w4_add w5_add w6_add addn). - - Theorem spec_add: forall x y, [add x y] = [x] + [y]. - Proof. - unfold add. - generalize (spec_same_level t_ (fun x y res => [res] = x + y)). - unfold same_level; intros HH; apply HH; clear HH. - exact spec_w0_add. - exact spec_w1_add. - exact spec_w2_add. - exact spec_w3_add. - exact spec_w4_add. - exact spec_w5_add. - exact spec_w6_add. - exact spec_wn_add. - Qed. - - (***************************************************************) - (* *) - (* Predecessor *) - (* *) - (***************************************************************) - - Definition w0_pred_c := w0_op.(znz_pred_c). - Definition w1_pred_c := w1_op.(znz_pred_c). - Definition w2_pred_c := w2_op.(znz_pred_c). - Definition w3_pred_c := w3_op.(znz_pred_c). - Definition w4_pred_c := w4_op.(znz_pred_c). - Definition w5_pred_c := w5_op.(znz_pred_c). - Definition w6_pred_c := w6_op.(znz_pred_c). - - Definition pred x := - match x with - | N0 wx => - match w0_pred_c wx with - | C0 r => reduce_0 r - | C1 r => zero - end - | N1 wx => - match w1_pred_c wx with - | C0 r => reduce_1 r - | C1 r => zero - end - | N2 wx => - match w2_pred_c wx with - | C0 r => reduce_2 r - | C1 r => zero - end - | N3 wx => - match w3_pred_c wx with - | C0 r => reduce_3 r - | C1 r => zero - end - | N4 wx => - match w4_pred_c wx with - | C0 r => reduce_4 r - | C1 r => zero - end - | N5 wx => - match w5_pred_c wx with - | C0 r => reduce_5 r - | C1 r => zero - end - | N6 wx => - match w6_pred_c wx with - | C0 r => reduce_6 r - | C1 r => zero - end - | Nn n wx => - let op := make_op n in - match op.(znz_pred_c) wx with - | C0 r => reduce_n n r - | C1 r => zero - end - end. - - Theorem spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1. - Proof. - intros x; case x; unfold pred. - intros x1 H1; unfold w0_pred_c; - generalize (spec_pred_c w0_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_0; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w0_spec x1); intros HH1 HH2. - case (spec_to_Z w0_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w0_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros x1 H1; unfold w1_pred_c; - generalize (spec_pred_c w1_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_1; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w1_spec x1); intros HH1 HH2. - case (spec_to_Z w1_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w1_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros x1 H1; unfold w2_pred_c; - generalize (spec_pred_c w2_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_2; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w2_spec x1); intros HH1 HH2. - case (spec_to_Z w2_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w2_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros x1 H1; unfold w3_pred_c; - generalize (spec_pred_c w3_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_3; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w3_spec x1); intros HH1 HH2. - case (spec_to_Z w3_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w3_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros x1 H1; unfold w4_pred_c; - generalize (spec_pred_c w4_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_4; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w4_spec x1); intros HH1 HH2. - case (spec_to_Z w4_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w4_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros x1 H1; unfold w5_pred_c; - generalize (spec_pred_c w5_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_5; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w5_spec x1); intros HH1 HH2. - case (spec_to_Z w5_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w5_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros x1 H1; unfold w6_pred_c; - generalize (spec_pred_c w6_spec x1); case znz_pred_c; intros y1. - rewrite spec_reduce_6; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z w6_spec x1); intros HH1 HH2. - case (spec_to_Z w6_spec y1); intros HH3 HH4 HH5. - assert (znz_to_Z w6_op x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - intros n x1 H1; - generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1. - rewrite spec_reduce_n; auto. - unfold interp_carry; unfold to_Z. - case (spec_to_Z (wn_spec n) x1); intros HH1 HH2. - case (spec_to_Z (wn_spec n) y1); intros HH3 HH4 HH5. - assert (znz_to_Z (make_op n) x1 - 1 < 0); auto with zarith. - unfold to_Z in H1; auto with zarith. - Qed. - - Let spec_pred0: forall x, [x] = 0 -> [pred x] = 0. - Proof. - intros x; case x; unfold pred. - intros x1 H1; unfold w0_pred_c; - generalize (spec_pred_c w0_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w0_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros x1 H1; unfold w1_pred_c; - generalize (spec_pred_c w1_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w1_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros x1 H1; unfold w2_pred_c; - generalize (spec_pred_c w2_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w2_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros x1 H1; unfold w3_pred_c; - generalize (spec_pred_c w3_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w3_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros x1 H1; unfold w4_pred_c; - generalize (spec_pred_c w4_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w4_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros x1 H1; unfold w5_pred_c; - generalize (spec_pred_c w5_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w5_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros x1 H1; unfold w6_pred_c; - generalize (spec_pred_c w6_spec x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z w6_spec y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - intros n x1 H1; - generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1. - unfold interp_carry; unfold to_Z. - unfold to_Z in H1; auto with zarith. - case (spec_to_Z (wn_spec n) y1); intros HH3 HH4; auto with zarith. - intros; exact (spec_0 w0_spec). - Qed. - - (***************************************************************) - (* *) - (* Subtraction *) - (* *) - (***************************************************************) - - Definition w0_sub_c := w0_op.(znz_sub_c). - Definition w1_sub_c := w1_op.(znz_sub_c). - Definition w2_sub_c := w2_op.(znz_sub_c). - Definition w3_sub_c := w3_op.(znz_sub_c). - Definition w4_sub_c := w4_op.(znz_sub_c). - Definition w5_sub_c := w5_op.(znz_sub_c). - Definition w6_sub_c := w6_op.(znz_sub_c). - - Definition w0_sub x y := - match w0_sub_c x y with - | C0 r => reduce_0 r - | C1 r => zero - end. - Definition w1_sub x y := - match w1_sub_c x y with - | C0 r => reduce_1 r - | C1 r => zero - end. - Definition w2_sub x y := - match w2_sub_c x y with - | C0 r => reduce_2 r - | C1 r => zero - end. - Definition w3_sub x y := - match w3_sub_c x y with - | C0 r => reduce_3 r - | C1 r => zero - end. - Definition w4_sub x y := - match w4_sub_c x y with - | C0 r => reduce_4 r - | C1 r => zero - end. - Definition w5_sub x y := - match w5_sub_c x y with - | C0 r => reduce_5 r - | C1 r => zero - end. - Definition w6_sub x y := - match w6_sub_c x y with - | C0 r => reduce_6 r - | C1 r => zero - end. - - Definition subn n (x y : word w6 (S n)) := - let op := make_op n in - match op.(znz_sub_c) x y with - | C0 r => Nn n r - | C1 r => N0 w_0 end. - - Let spec_w0_sub: forall x y, [N0 y] <= [N0 x] -> [w0_sub x y] = [N0 x] - [N0 y]. - Proof. - intros n m; unfold w0_sub, w0_sub_c. - generalize (spec_sub_c w0_spec n m); case znz_sub_c; - intros x; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w0_spec x); intros; auto with zarith. - Qed. - - Let spec_w1_sub: forall x y, [N1 y] <= [N1 x] -> [w1_sub x y] = [N1 x] - [N1 y]. - Proof. - intros n m; unfold w1_sub, w1_sub_c. - generalize (spec_sub_c w1_spec n m); case znz_sub_c; - intros x; try rewrite spec_reduce_1; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w1_spec x); intros; auto with zarith. - Qed. - - Let spec_w2_sub: forall x y, [N2 y] <= [N2 x] -> [w2_sub x y] = [N2 x] - [N2 y]. - Proof. - intros n m; unfold w2_sub, w2_sub_c. - generalize (spec_sub_c w2_spec n m); case znz_sub_c; - intros x; try rewrite spec_reduce_2; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w2_spec x); intros; auto with zarith. - Qed. - - Let spec_w3_sub: forall x y, [N3 y] <= [N3 x] -> [w3_sub x y] = [N3 x] - [N3 y]. - Proof. - intros n m; unfold w3_sub, w3_sub_c. - generalize (spec_sub_c w3_spec n m); case znz_sub_c; - intros x; try rewrite spec_reduce_3; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w3_spec x); intros; auto with zarith. - Qed. - - Let spec_w4_sub: forall x y, [N4 y] <= [N4 x] -> [w4_sub x y] = [N4 x] - [N4 y]. - Proof. - intros n m; unfold w4_sub, w4_sub_c. - generalize (spec_sub_c w4_spec n m); case znz_sub_c; - intros x; try rewrite spec_reduce_4; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w4_spec x); intros; auto with zarith. - Qed. - - Let spec_w5_sub: forall x y, [N5 y] <= [N5 x] -> [w5_sub x y] = [N5 x] - [N5 y]. - Proof. - intros n m; unfold w5_sub, w5_sub_c. - generalize (spec_sub_c w5_spec n m); case znz_sub_c; - intros x; try rewrite spec_reduce_5; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w5_spec x); intros; auto with zarith. - Qed. - - Let spec_w6_sub: forall x y, [N6 y] <= [N6 x] -> [w6_sub x y] = [N6 x] - [N6 y]. - Proof. - intros n m; unfold w6_sub, w6_sub_c. - generalize (spec_sub_c w6_spec n m); case znz_sub_c; - intros x; try rewrite spec_reduce_6; auto. - unfold interp_carry; unfold zero, w_0, to_Z. - rewrite (spec_0 w0_spec). - case (spec_to_Z w6_spec x); intros; auto with zarith. - Qed. - - Let spec_wn_sub: forall n x y, [Nn n y] <= [Nn n x] -> [subn n x y] = [Nn n x] - [Nn n y]. - Proof. - intros k n m; unfold subn. - generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; - intros x; auto. - unfold interp_carry, to_Z. - case (spec_to_Z (wn_spec k) x); intros; auto with zarith. - Qed. - - Definition sub := Eval lazy beta delta [same_level] in - (same_level t_ w0_sub w1_sub w2_sub w3_sub w4_sub w5_sub w6_sub subn). - - Theorem spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y]. - Proof. - unfold sub. - generalize (spec_same_level t_ (fun x y res => y <= x -> [res] = x - y)). - unfold same_level; intros HH; apply HH; clear HH. - exact spec_w0_sub. - exact spec_w1_sub. - exact spec_w2_sub. - exact spec_w3_sub. - exact spec_w4_sub. - exact spec_w5_sub. - exact spec_w6_sub. - exact spec_wn_sub. - Qed. - - Let spec_w0_sub0: forall x y, [N0 x] < [N0 y] -> [w0_sub x y] = 0. - Proof. - intros n m; unfold w0_sub, w0_sub_c. - generalize (spec_sub_c w0_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w0_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_w1_sub0: forall x y, [N1 x] < [N1 y] -> [w1_sub x y] = 0. - Proof. - intros n m; unfold w1_sub, w1_sub_c. - generalize (spec_sub_c w1_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w1_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_w2_sub0: forall x y, [N2 x] < [N2 y] -> [w2_sub x y] = 0. - Proof. - intros n m; unfold w2_sub, w2_sub_c. - generalize (spec_sub_c w2_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w2_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_w3_sub0: forall x y, [N3 x] < [N3 y] -> [w3_sub x y] = 0. - Proof. - intros n m; unfold w3_sub, w3_sub_c. - generalize (spec_sub_c w3_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w3_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_w4_sub0: forall x y, [N4 x] < [N4 y] -> [w4_sub x y] = 0. - Proof. - intros n m; unfold w4_sub, w4_sub_c. - generalize (spec_sub_c w4_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w4_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_w5_sub0: forall x y, [N5 x] < [N5 y] -> [w5_sub x y] = 0. - Proof. - intros n m; unfold w5_sub, w5_sub_c. - generalize (spec_sub_c w5_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w5_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_w6_sub0: forall x y, [N6 x] < [N6 y] -> [w6_sub x y] = 0. - Proof. - intros n m; unfold w6_sub, w6_sub_c. - generalize (spec_sub_c w6_spec n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z w6_spec x); intros; auto with zarith. - intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto. - Qed. - - Let spec_wn_sub0: forall n x y, [Nn n x] < [Nn n y] -> [subn n x y] = 0. - Proof. - intros k n m; unfold subn. - generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; - intros x; unfold interp_carry. - unfold to_Z; case (spec_to_Z (wn_spec k) x); intros; auto with zarith. - intros; unfold to_Z, w_0; rewrite (spec_0 (w0_spec)); auto. - Qed. - - Theorem spec_sub0: forall x y, [x] < [y] -> [sub x y] = 0. - Proof. - unfold sub. - generalize (spec_same_level t_ (fun x y res => x < y -> [res] = 0)). - unfold same_level; intros HH; apply HH; clear HH. - exact spec_w0_sub0. - exact spec_w1_sub0. - exact spec_w2_sub0. - exact spec_w3_sub0. - exact spec_w4_sub0. - exact spec_w5_sub0. - exact spec_w6_sub0. - exact spec_wn_sub0. - Qed. - - (***************************************************************) - (* *) - (* Comparison *) - (* *) - (***************************************************************) - - Definition compare_0 := w0_op.(znz_compare). - Definition comparen_0 := - compare_mn_1 w0 w0 w_0 compare_0 (compare_0 w_0) compare_0. - Definition compare_1 := w1_op.(znz_compare). - Definition comparen_1 := - compare_mn_1 w1 w1 W0 compare_1 (compare_1 W0) compare_1. - Definition compare_2 := w2_op.(znz_compare). - Definition comparen_2 := - compare_mn_1 w2 w2 W0 compare_2 (compare_2 W0) compare_2. - Definition compare_3 := w3_op.(znz_compare). - Definition comparen_3 := - compare_mn_1 w3 w3 W0 compare_3 (compare_3 W0) compare_3. - Definition compare_4 := w4_op.(znz_compare). - Definition comparen_4 := - compare_mn_1 w4 w4 W0 compare_4 (compare_4 W0) compare_4. - Definition compare_5 := w5_op.(znz_compare). - Definition comparen_5 := - compare_mn_1 w5 w5 W0 compare_5 (compare_5 W0) compare_5. - Definition compare_6 := w6_op.(znz_compare). - Definition comparen_6 := - compare_mn_1 w6 w6 W0 compare_6 (compare_6 W0) compare_6. - - Definition comparenm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - op.(znz_compare) - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))). - - Definition compare := Eval lazy beta delta [iter] in - (iter _ - compare_0 - (fun n x y => opp_compare (comparen_0 (S n) y x)) - (fun n => comparen_0 (S n)) - compare_1 - (fun n x y => opp_compare (comparen_1 (S n) y x)) - (fun n => comparen_1 (S n)) - compare_2 - (fun n x y => opp_compare (comparen_2 (S n) y x)) - (fun n => comparen_2 (S n)) - compare_3 - (fun n x y => opp_compare (comparen_3 (S n) y x)) - (fun n => comparen_3 (S n)) - compare_4 - (fun n x y => opp_compare (comparen_4 (S n) y x)) - (fun n => comparen_4 (S n)) - compare_5 - (fun n x y => opp_compare (comparen_5 (S n) y x)) - (fun n => comparen_5 (S n)) - compare_6 - (fun n x y => opp_compare (comparen_6 (S n) y x)) - (fun n => comparen_6 (S n)) - comparenm). - - Let spec_compare_0: forall x y, - match compare_0 x y with - Eq => [N0 x] = [N0 y] - | Lt => [N0 x] < [N0 y] - | Gt => [N0 x] > [N0 y] - end. - Proof. - unfold compare_0, to_Z; exact (spec_compare w0_spec). - Qed. - - Let spec_comparen_0: - forall (n : nat) (x : word w0 n) (y : w0), - match comparen_0 n x y with - | Eq => eval0n n x = [N0 y] - | Lt => eval0n n x < [N0 y] - | Gt => eval0n n x > [N0 y] - end. - intros n x y. - unfold comparen_0, to_Z; rewrite spec_gen_eval0n. - apply spec_compare_mn_1. - exact (spec_0 w0_spec). - intros x1; exact (spec_compare w0_spec w_0 x1). - exact (spec_to_Z w0_spec). - exact (spec_compare w0_spec). - exact (spec_compare w0_spec). - exact (spec_to_Z w0_spec). - Qed. - - Let spec_compare_1: forall x y, - match compare_1 x y with - Eq => [N1 x] = [N1 y] - | Lt => [N1 x] < [N1 y] - | Gt => [N1 x] > [N1 y] - end. - Proof. - unfold compare_1, to_Z; exact (spec_compare w1_spec). - Qed. - - Let spec_comparen_1: - forall (n : nat) (x : word w1 n) (y : w1), - match comparen_1 n x y with - | Eq => eval1n n x = [N1 y] - | Lt => eval1n n x < [N1 y] - | Gt => eval1n n x > [N1 y] - end. - intros n x y. - unfold comparen_1, to_Z; rewrite spec_gen_eval1n. - apply spec_compare_mn_1. - exact (spec_0 w1_spec). - intros x1; exact (spec_compare w1_spec W0 x1). - exact (spec_to_Z w1_spec). - exact (spec_compare w1_spec). - exact (spec_compare w1_spec). - exact (spec_to_Z w1_spec). - Qed. - - Let spec_compare_2: forall x y, - match compare_2 x y with - Eq => [N2 x] = [N2 y] - | Lt => [N2 x] < [N2 y] - | Gt => [N2 x] > [N2 y] - end. - Proof. - unfold compare_2, to_Z; exact (spec_compare w2_spec). - Qed. - - Let spec_comparen_2: - forall (n : nat) (x : word w2 n) (y : w2), - match comparen_2 n x y with - | Eq => eval2n n x = [N2 y] - | Lt => eval2n n x < [N2 y] - | Gt => eval2n n x > [N2 y] - end. - intros n x y. - unfold comparen_2, to_Z; rewrite spec_gen_eval2n. - apply spec_compare_mn_1. - exact (spec_0 w2_spec). - intros x1; exact (spec_compare w2_spec W0 x1). - exact (spec_to_Z w2_spec). - exact (spec_compare w2_spec). - exact (spec_compare w2_spec). - exact (spec_to_Z w2_spec). - Qed. - - Let spec_compare_3: forall x y, - match compare_3 x y with - Eq => [N3 x] = [N3 y] - | Lt => [N3 x] < [N3 y] - | Gt => [N3 x] > [N3 y] - end. - Proof. - unfold compare_3, to_Z; exact (spec_compare w3_spec). - Qed. - - Let spec_comparen_3: - forall (n : nat) (x : word w3 n) (y : w3), - match comparen_3 n x y with - | Eq => eval3n n x = [N3 y] - | Lt => eval3n n x < [N3 y] - | Gt => eval3n n x > [N3 y] - end. - intros n x y. - unfold comparen_3, to_Z; rewrite spec_gen_eval3n. - apply spec_compare_mn_1. - exact (spec_0 w3_spec). - intros x1; exact (spec_compare w3_spec W0 x1). - exact (spec_to_Z w3_spec). - exact (spec_compare w3_spec). - exact (spec_compare w3_spec). - exact (spec_to_Z w3_spec). - Qed. - - Let spec_compare_4: forall x y, - match compare_4 x y with - Eq => [N4 x] = [N4 y] - | Lt => [N4 x] < [N4 y] - | Gt => [N4 x] > [N4 y] - end. - Proof. - unfold compare_4, to_Z; exact (spec_compare w4_spec). - Qed. - - Let spec_comparen_4: - forall (n : nat) (x : word w4 n) (y : w4), - match comparen_4 n x y with - | Eq => eval4n n x = [N4 y] - | Lt => eval4n n x < [N4 y] - | Gt => eval4n n x > [N4 y] - end. - intros n x y. - unfold comparen_4, to_Z; rewrite spec_gen_eval4n. - apply spec_compare_mn_1. - exact (spec_0 w4_spec). - intros x1; exact (spec_compare w4_spec W0 x1). - exact (spec_to_Z w4_spec). - exact (spec_compare w4_spec). - exact (spec_compare w4_spec). - exact (spec_to_Z w4_spec). - Qed. - - Let spec_compare_5: forall x y, - match compare_5 x y with - Eq => [N5 x] = [N5 y] - | Lt => [N5 x] < [N5 y] - | Gt => [N5 x] > [N5 y] - end. - Proof. - unfold compare_5, to_Z; exact (spec_compare w5_spec). - Qed. - - Let spec_comparen_5: - forall (n : nat) (x : word w5 n) (y : w5), - match comparen_5 n x y with - | Eq => eval5n n x = [N5 y] - | Lt => eval5n n x < [N5 y] - | Gt => eval5n n x > [N5 y] - end. - intros n x y. - unfold comparen_5, to_Z; rewrite spec_gen_eval5n. - apply spec_compare_mn_1. - exact (spec_0 w5_spec). - intros x1; exact (spec_compare w5_spec W0 x1). - exact (spec_to_Z w5_spec). - exact (spec_compare w5_spec). - exact (spec_compare w5_spec). - exact (spec_to_Z w5_spec). - Qed. - - Let spec_compare_6: forall x y, - match compare_6 x y with - Eq => [N6 x] = [N6 y] - | Lt => [N6 x] < [N6 y] - | Gt => [N6 x] > [N6 y] - end. - Proof. - unfold compare_6, to_Z; exact (spec_compare w6_spec). - Qed. - - Let spec_comparen_6: - forall (n : nat) (x : word w6 n) (y : w6), - match comparen_6 n x y with - | Eq => eval6n n x = [N6 y] - | Lt => eval6n n x < [N6 y] - | Gt => eval6n n x > [N6 y] - end. - intros n x y. - unfold comparen_6, to_Z; rewrite spec_gen_eval6n. - apply spec_compare_mn_1. - exact (spec_0 w6_spec). - intros x1; exact (spec_compare w6_spec W0 x1). - exact (spec_to_Z w6_spec). - exact (spec_compare w6_spec). - exact (spec_compare w6_spec). - exact (spec_to_Z w6_spec). - Qed. - - Let spec_opp_compare: forall c (u v: Z), - match c with Eq => u = v | Lt => u < v | Gt => u > v end -> - match opp_compare c with Eq => v = u | Lt => v < u | Gt => v > u end. - Proof. - intros c u v; case c; unfold opp_compare; auto with zarith. - Qed. - - Theorem spec_compare: forall x y, - match compare x y with - Eq => [x] = [y] - | Lt => [x] < [y] - | Gt => [x] > [y] - end. - Proof. - refine (spec_iter _ (fun x y res => - match res with - Eq => x = y - | Lt => x < y - | Gt => x > y - end) - compare_0 - (fun n x y => opp_compare (comparen_0 (S n) y x)) - (fun n => comparen_0 (S n)) _ _ _ - compare_1 - (fun n x y => opp_compare (comparen_1 (S n) y x)) - (fun n => comparen_1 (S n)) _ _ _ - compare_2 - (fun n x y => opp_compare (comparen_2 (S n) y x)) - (fun n => comparen_2 (S n)) _ _ _ - compare_3 - (fun n x y => opp_compare (comparen_3 (S n) y x)) - (fun n => comparen_3 (S n)) _ _ _ - compare_4 - (fun n x y => opp_compare (comparen_4 (S n) y x)) - (fun n => comparen_4 (S n)) _ _ _ - compare_5 - (fun n x y => opp_compare (comparen_5 (S n) y x)) - (fun n => comparen_5 (S n)) _ _ _ - compare_6 - (fun n x y => opp_compare (comparen_6 (S n) y x)) - (fun n => comparen_6 (S n)) _ _ _ - comparenm _). - exact spec_compare_0. - intros n x y H;apply spec_opp_compare; apply spec_comparen_0. - intros n x y H; exact (spec_comparen_0 (S n) x y). - exact spec_compare_1. - intros n x y H;apply spec_opp_compare; apply spec_comparen_1. - intros n x y H; exact (spec_comparen_1 (S n) x y). - exact spec_compare_2. - intros n x y H;apply spec_opp_compare; apply spec_comparen_2. - intros n x y H; exact (spec_comparen_2 (S n) x y). - exact spec_compare_3. - intros n x y H;apply spec_opp_compare; apply spec_comparen_3. - intros n x y H; exact (spec_comparen_3 (S n) x y). - exact spec_compare_4. - intros n x y H;apply spec_opp_compare; apply spec_comparen_4. - intros n x y H; exact (spec_comparen_4 (S n) x y). - exact spec_compare_5. - intros n x y H;apply spec_opp_compare; apply spec_comparen_5. - intros n x y H; exact (spec_comparen_5 (S n) x y). - exact spec_compare_6. - intros n x y;apply spec_opp_compare; apply spec_comparen_6. - intros n; exact (spec_comparen_6 (S n)). - intros n m x y; unfold comparenm. - rewrite <- (spec_cast_l n m x); rewrite <- (spec_cast_r n m y). - unfold to_Z; apply (spec_compare (wn_spec (Max.max n m))). - Qed. - - Definition eq_bool x y := - match compare x y with - | Eq => true - | _ => false - end. - - Theorem spec_eq_bool: forall x y, - if eq_bool x y then [x] = [y] else [x] <> [y]. - Proof. - intros x y; unfold eq_bool. - generalize (spec_compare x y); case compare; auto with zarith. - Qed. - - (***************************************************************) - (* *) - (* Multiplication *) - (* *) - (***************************************************************) - - Definition w0_mul_c := w0_op.(znz_mul_c). - Definition w1_mul_c := w1_op.(znz_mul_c). - Definition w2_mul_c := w2_op.(znz_mul_c). - Definition w3_mul_c := w3_op.(znz_mul_c). - Definition w4_mul_c := w4_op.(znz_mul_c). - Definition w5_mul_c := w5_op.(znz_mul_c). - Definition w6_mul_c := w6_op.(znz_mul_c). - - Definition w0_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w0 w_0 w0_succ w0_add_c w0_mul_c. - Definition w1_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w1 W0 w1_succ w1_add_c w1_mul_c. - Definition w2_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w2 W0 w2_succ w2_add_c w2_mul_c. - Definition w3_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w3 W0 w3_succ w3_add_c w3_mul_c. - Definition w4_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w4 W0 w4_succ w4_add_c w4_mul_c. - Definition w5_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w5 W0 w5_succ w5_add_c w5_mul_c. - Definition w6_mul_add := - Eval lazy beta delta [w_mul_add] in - @w_mul_add w6 W0 w6_succ w6_add_c w6_mul_c. - - Definition w0_0W := w0_op.(znz_0W). - Definition w1_0W := w1_op.(znz_0W). - Definition w2_0W := w2_op.(znz_0W). - Definition w3_0W := w3_op.(znz_0W). - Definition w4_0W := w4_op.(znz_0W). - Definition w5_0W := w5_op.(znz_0W). - Definition w6_0W := w6_op.(znz_0W). - - Definition w0_mul_add_n1 := - @gen_mul_add_n1 w0 w_0 w0_op.(znz_WW) w0_0W w0_mul_add. - Definition w1_mul_add_n1 := - @gen_mul_add_n1 w1 W0 w1_op.(znz_WW) w1_0W w1_mul_add. - Definition w2_mul_add_n1 := - @gen_mul_add_n1 w2 W0 w2_op.(znz_WW) w2_0W w2_mul_add. - Definition w3_mul_add_n1 := - @gen_mul_add_n1 w3 W0 w3_op.(znz_WW) w3_0W w3_mul_add. - Definition w4_mul_add_n1 := - @gen_mul_add_n1 w4 W0 w4_op.(znz_WW) w4_0W w4_mul_add. - Definition w5_mul_add_n1 := - @gen_mul_add_n1 w5 W0 w5_op.(znz_WW) w5_0W w5_mul_add. - Definition w6_mul_add_n1 := - @gen_mul_add_n1 w6 W0 w6_op.(znz_WW) w6_0W w6_mul_add. - - Let to_Z0 n := - match n return word w0 (S n) -> t_ with - | 0%nat => fun x => N1 x - | 1%nat => fun x => N2 x - | 2%nat => fun x => N3 x - | 3%nat => fun x => N4 x - | 4%nat => fun x => N5 x - | 5%nat => fun x => N6 x - | 6%nat => fun x => Nn 0 x - | 7%nat => fun x => Nn 1 x - | _ => fun _ => N0 w_0 - end. - - Let to_Z1 n := - match n return word w1 (S n) -> t_ with - | 0%nat => fun x => N2 x - | 1%nat => fun x => N3 x - | 2%nat => fun x => N4 x - | 3%nat => fun x => N5 x - | 4%nat => fun x => N6 x - | 5%nat => fun x => Nn 0 x - | 6%nat => fun x => Nn 1 x - | _ => fun _ => N0 w_0 - end. - - Let to_Z2 n := - match n return word w2 (S n) -> t_ with - | 0%nat => fun x => N3 x - | 1%nat => fun x => N4 x - | 2%nat => fun x => N5 x - | 3%nat => fun x => N6 x - | 4%nat => fun x => Nn 0 x - | 5%nat => fun x => Nn 1 x - | _ => fun _ => N0 w_0 - end. - - Let to_Z3 n := - match n return word w3 (S n) -> t_ with - | 0%nat => fun x => N4 x - | 1%nat => fun x => N5 x - | 2%nat => fun x => N6 x - | 3%nat => fun x => Nn 0 x - | 4%nat => fun x => Nn 1 x - | _ => fun _ => N0 w_0 - end. - - Let to_Z4 n := - match n return word w4 (S n) -> t_ with - | 0%nat => fun x => N5 x - | 1%nat => fun x => N6 x - | 2%nat => fun x => Nn 0 x - | 3%nat => fun x => Nn 1 x - | _ => fun _ => N0 w_0 - end. - - Let to_Z5 n := - match n return word w5 (S n) -> t_ with - | 0%nat => fun x => N6 x - | 1%nat => fun x => Nn 0 x - | 2%nat => fun x => Nn 1 x - | _ => fun _ => N0 w_0 - end. - -Theorem to_Z0_spec: - forall n x, Z_of_nat n <= 7 -> [to_Z0 n x] = znz_to_Z (nmake_op _ w0_op (S n)) x. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n1; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n2; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n3; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n4; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n5; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n6; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n7; auto. - intros n; case n; clear n. - unfold to_Z0. - intros x H; rewrite spec_eval0n8; auto. - intros n x. - repeat rewrite inj_S; unfold Zsucc; auto with zarith. - Qed. - -Theorem to_Z1_spec: - forall n x, Z_of_nat n <= 6 -> [to_Z1 n x] = znz_to_Z (nmake_op _ w1_op (S n)) x. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n1; auto. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n2; auto. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n3; auto. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n4; auto. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n5; auto. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n6; auto. - intros n; case n; clear n. - unfold to_Z1. - intros x H; rewrite spec_eval1n7; auto. - intros n x. - repeat rewrite inj_S; unfold Zsucc; auto with zarith. - Qed. - -Theorem to_Z2_spec: - forall n x, Z_of_nat n <= 5 -> [to_Z2 n x] = znz_to_Z (nmake_op _ w2_op (S n)) x. - intros n; case n; clear n. - unfold to_Z2. - intros x H; rewrite spec_eval2n1; auto. - intros n; case n; clear n. - unfold to_Z2. - intros x H; rewrite spec_eval2n2; auto. - intros n; case n; clear n. - unfold to_Z2. - intros x H; rewrite spec_eval2n3; auto. - intros n; case n; clear n. - unfold to_Z2. - intros x H; rewrite spec_eval2n4; auto. - intros n; case n; clear n. - unfold to_Z2. - intros x H; rewrite spec_eval2n5; auto. - intros n; case n; clear n. - unfold to_Z2. - intros x H; rewrite spec_eval2n6; auto. - intros n x. - repeat rewrite inj_S; unfold Zsucc; auto with zarith. - Qed. - -Theorem to_Z3_spec: - forall n x, Z_of_nat n <= 4 -> [to_Z3 n x] = znz_to_Z (nmake_op _ w3_op (S n)) x. - intros n; case n; clear n. - unfold to_Z3. - intros x H; rewrite spec_eval3n1; auto. - intros n; case n; clear n. - unfold to_Z3. - intros x H; rewrite spec_eval3n2; auto. - intros n; case n; clear n. - unfold to_Z3. - intros x H; rewrite spec_eval3n3; auto. - intros n; case n; clear n. - unfold to_Z3. - intros x H; rewrite spec_eval3n4; auto. - intros n; case n; clear n. - unfold to_Z3. - intros x H; rewrite spec_eval3n5; auto. - intros n x. - repeat rewrite inj_S; unfold Zsucc; auto with zarith. - Qed. - -Theorem to_Z4_spec: - forall n x, Z_of_nat n <= 3 -> [to_Z4 n x] = znz_to_Z (nmake_op _ w4_op (S n)) x. - intros n; case n; clear n. - unfold to_Z4. - intros x H; rewrite spec_eval4n1; auto. - intros n; case n; clear n. - unfold to_Z4. - intros x H; rewrite spec_eval4n2; auto. - intros n; case n; clear n. - unfold to_Z4. - intros x H; rewrite spec_eval4n3; auto. - intros n; case n; clear n. - unfold to_Z4. - intros x H; rewrite spec_eval4n4; auto. - intros n x. - repeat rewrite inj_S; unfold Zsucc; auto with zarith. - Qed. - -Theorem to_Z5_spec: - forall n x, Z_of_nat n <= 2 -> [to_Z5 n x] = znz_to_Z (nmake_op _ w5_op (S n)) x. - intros n; case n; clear n. - unfold to_Z5. - intros x H; rewrite spec_eval5n1; auto. - intros n; case n; clear n. - unfold to_Z5. - intros x H; rewrite spec_eval5n2; auto. - intros n; case n; clear n. - unfold to_Z5. - intros x H; rewrite spec_eval5n3; auto. - intros n x. - repeat rewrite inj_S; unfold Zsucc; auto with zarith. - Qed. - - Definition w0_mul n x y := - let (w,r) := w0_mul_add_n1 (S n) x y w_0 in - if w0_eq0 w then to_Z0 n r - else to_Z0 (S n) (WW (extend0 n w) r). - - Definition w1_mul n x y := - let (w,r) := w1_mul_add_n1 (S n) x y W0 in - if w1_eq0 w then to_Z1 n r - else to_Z1 (S n) (WW (extend1 n w) r). - - Definition w2_mul n x y := - let (w,r) := w2_mul_add_n1 (S n) x y W0 in - if w2_eq0 w then to_Z2 n r - else to_Z2 (S n) (WW (extend2 n w) r). - - Definition w3_mul n x y := - let (w,r) := w3_mul_add_n1 (S n) x y W0 in - if w3_eq0 w then to_Z3 n r - else to_Z3 (S n) (WW (extend3 n w) r). - - Definition w4_mul n x y := - let (w,r) := w4_mul_add_n1 (S n) x y W0 in - if w4_eq0 w then to_Z4 n r - else to_Z4 (S n) (WW (extend4 n w) r). - - Definition w5_mul n x y := - let (w,r) := w5_mul_add_n1 (S n) x y W0 in - if w5_eq0 w then to_Z5 n r - else to_Z5 (S n) (WW (extend5 n w) r). - - Definition w6_mul n x y := - let (w,r) := w6_mul_add_n1 (S n) x y W0 in - if w6_eq0 w then Nn n r - else Nn (S n) (WW (extend6 n w) r). - - Definition mulnm n m x y := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - reduce_n (S mn) (op.(znz_mul_c) - (castm (diff_r n m) (extend_tr x (snd d))) - (castm (diff_l n m) (extend_tr y (fst d)))). - - Definition mul := Eval lazy beta delta [iter0] in - (iter0 t_ - (fun x y => reduce_1 (w0_mul_c x y)) - (fun n x y => w0_mul n y x) - w0_mul - (fun x y => reduce_2 (w1_mul_c x y)) - (fun n x y => w1_mul n y x) - w1_mul - (fun x y => reduce_3 (w2_mul_c x y)) - (fun n x y => w2_mul n y x) - w2_mul - (fun x y => reduce_4 (w3_mul_c x y)) - (fun n x y => w3_mul n y x) - w3_mul - (fun x y => reduce_5 (w4_mul_c x y)) - (fun n x y => w4_mul n y x) - w4_mul - (fun x y => reduce_6 (w5_mul_c x y)) - (fun n x y => w5_mul n y x) - w5_mul - (fun x y => reduce_7 (w6_mul_c x y)) - (fun n x y => w6_mul n y x) - w6_mul - mulnm - (fun _ => N0 w_0) - (fun _ => N0 w_0) - ). - - Let spec_w0_mul_add: forall x y z, - let (q,r) := w0_mul_add x y z in - znz_to_Z w0_op q * (base (znz_digits w0_op)) + znz_to_Z w0_op r = - znz_to_Z w0_op x * znz_to_Z w0_op y + znz_to_Z w0_op z := - (spec_mul_add w0_spec). - - Let spec_w1_mul_add: forall x y z, - let (q,r) := w1_mul_add x y z in - znz_to_Z w1_op q * (base (znz_digits w1_op)) + znz_to_Z w1_op r = - znz_to_Z w1_op x * znz_to_Z w1_op y + znz_to_Z w1_op z := - (spec_mul_add w1_spec). - - Let spec_w2_mul_add: forall x y z, - let (q,r) := w2_mul_add x y z in - znz_to_Z w2_op q * (base (znz_digits w2_op)) + znz_to_Z w2_op r = - znz_to_Z w2_op x * znz_to_Z w2_op y + znz_to_Z w2_op z := - (spec_mul_add w2_spec). - - Let spec_w3_mul_add: forall x y z, - let (q,r) := w3_mul_add x y z in - znz_to_Z w3_op q * (base (znz_digits w3_op)) + znz_to_Z w3_op r = - znz_to_Z w3_op x * znz_to_Z w3_op y + znz_to_Z w3_op z := - (spec_mul_add w3_spec). - - Let spec_w4_mul_add: forall x y z, - let (q,r) := w4_mul_add x y z in - znz_to_Z w4_op q * (base (znz_digits w4_op)) + znz_to_Z w4_op r = - znz_to_Z w4_op x * znz_to_Z w4_op y + znz_to_Z w4_op z := - (spec_mul_add w4_spec). - - Let spec_w5_mul_add: forall x y z, - let (q,r) := w5_mul_add x y z in - znz_to_Z w5_op q * (base (znz_digits w5_op)) + znz_to_Z w5_op r = - znz_to_Z w5_op x * znz_to_Z w5_op y + znz_to_Z w5_op z := - (spec_mul_add w5_spec). - - Let spec_w6_mul_add: forall x y z, - let (q,r) := w6_mul_add x y z in - znz_to_Z w6_op q * (base (znz_digits w6_op)) + znz_to_Z w6_op r = - znz_to_Z w6_op x * znz_to_Z w6_op y + znz_to_Z w6_op z := - (spec_mul_add w6_spec). - - Theorem spec_w0_mul_add_n1: forall n x y z, - let (q,r) := w0_mul_add_n1 n x y z in - znz_to_Z w0_op q * (base (znz_digits (nmake_op _ w0_op n))) + - znz_to_Z (nmake_op _ w0_op n) r = - znz_to_Z (nmake_op _ w0_op n) x * znz_to_Z w0_op y + - znz_to_Z w0_op z. - Proof. - intros n x y z; unfold w0_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w0_op) n)) with - (GenBase.gen_wB (znz_digits w0_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_0 w0_spec). - exact (spec_WW w0_spec). - exact (spec_0W w0_spec). - exact (spec_mul_add w0_spec). - Qed. - - Theorem spec_w1_mul_add_n1: forall n x y z, - let (q,r) := w1_mul_add_n1 n x y z in - znz_to_Z w1_op q * (base (znz_digits (nmake_op _ w1_op n))) + - znz_to_Z (nmake_op _ w1_op n) r = - znz_to_Z (nmake_op _ w1_op n) x * znz_to_Z w1_op y + - znz_to_Z w1_op z. - Proof. - intros n x y z; unfold w1_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w1_op) n)) with - (GenBase.gen_wB (znz_digits w1_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_WW w1_spec). - exact (spec_0W w1_spec). - exact (spec_mul_add w1_spec). - Qed. - - Theorem spec_w2_mul_add_n1: forall n x y z, - let (q,r) := w2_mul_add_n1 n x y z in - znz_to_Z w2_op q * (base (znz_digits (nmake_op _ w2_op n))) + - znz_to_Z (nmake_op _ w2_op n) r = - znz_to_Z (nmake_op _ w2_op n) x * znz_to_Z w2_op y + - znz_to_Z w2_op z. - Proof. - intros n x y z; unfold w2_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w2_op) n)) with - (GenBase.gen_wB (znz_digits w2_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_WW w2_spec). - exact (spec_0W w2_spec). - exact (spec_mul_add w2_spec). - Qed. - - Theorem spec_w3_mul_add_n1: forall n x y z, - let (q,r) := w3_mul_add_n1 n x y z in - znz_to_Z w3_op q * (base (znz_digits (nmake_op _ w3_op n))) + - znz_to_Z (nmake_op _ w3_op n) r = - znz_to_Z (nmake_op _ w3_op n) x * znz_to_Z w3_op y + - znz_to_Z w3_op z. - Proof. - intros n x y z; unfold w3_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w3_op) n)) with - (GenBase.gen_wB (znz_digits w3_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_WW w3_spec). - exact (spec_0W w3_spec). - exact (spec_mul_add w3_spec). - Qed. - - Theorem spec_w4_mul_add_n1: forall n x y z, - let (q,r) := w4_mul_add_n1 n x y z in - znz_to_Z w4_op q * (base (znz_digits (nmake_op _ w4_op n))) + - znz_to_Z (nmake_op _ w4_op n) r = - znz_to_Z (nmake_op _ w4_op n) x * znz_to_Z w4_op y + - znz_to_Z w4_op z. - Proof. - intros n x y z; unfold w4_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w4_op) n)) with - (GenBase.gen_wB (znz_digits w4_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_WW w4_spec). - exact (spec_0W w4_spec). - exact (spec_mul_add w4_spec). - Qed. - - Theorem spec_w5_mul_add_n1: forall n x y z, - let (q,r) := w5_mul_add_n1 n x y z in - znz_to_Z w5_op q * (base (znz_digits (nmake_op _ w5_op n))) + - znz_to_Z (nmake_op _ w5_op n) r = - znz_to_Z (nmake_op _ w5_op n) x * znz_to_Z w5_op y + - znz_to_Z w5_op z. - Proof. - intros n x y z; unfold w5_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w5_op) n)) with - (GenBase.gen_wB (znz_digits w5_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_WW w5_spec). - exact (spec_0W w5_spec). - exact (spec_mul_add w5_spec). - Qed. - - Theorem spec_w6_mul_add_n1: forall n x y z, - let (q,r) := w6_mul_add_n1 n x y z in - znz_to_Z w6_op q * (base (znz_digits (nmake_op _ w6_op n))) + - znz_to_Z (nmake_op _ w6_op n) r = - znz_to_Z (nmake_op _ w6_op n) x * znz_to_Z w6_op y + - znz_to_Z w6_op z. - Proof. - intros n x y z; unfold w6_mul_add_n1. - rewrite nmake_gen. - rewrite digits_gend. - change (base (GenBase.gen_digits (znz_digits w6_op) n)) with - (GenBase.gen_wB (znz_digits w6_op) n). - apply spec_gen_mul_add_n1; auto. - exact (spec_WW w6_spec). - exact (spec_0W w6_spec). - exact (spec_mul_add w6_spec). - Qed. - - Lemma nmake_op_WW: forall ww ww1 n x y, - znz_to_Z (nmake_op ww ww1 (S n)) (WW x y) = - znz_to_Z (nmake_op ww ww1 n) x * base (znz_digits (nmake_op ww ww1 n)) + - znz_to_Z (nmake_op ww ww1 n) y. - auto. - Qed. - - Lemma extend0n_spec: forall n x1, - znz_to_Z (nmake_op _ w0_op (S n)) (extend0 n x1) = - znz_to_Z w0_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend0. - rewrite GenBase.spec_extend; auto. - intros l; simpl; unfold w_0; rewrite (spec_0 w0_spec); ring. - Qed. - - Lemma extend1n_spec: forall n x1, - znz_to_Z (nmake_op _ w1_op (S n)) (extend1 n x1) = - znz_to_Z w1_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend1. - rewrite GenBase.spec_extend; auto. - Qed. - - Lemma extend2n_spec: forall n x1, - znz_to_Z (nmake_op _ w2_op (S n)) (extend2 n x1) = - znz_to_Z w2_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend2. - rewrite GenBase.spec_extend; auto. - Qed. - - Lemma extend3n_spec: forall n x1, - znz_to_Z (nmake_op _ w3_op (S n)) (extend3 n x1) = - znz_to_Z w3_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend3. - rewrite GenBase.spec_extend; auto. - Qed. - - Lemma extend4n_spec: forall n x1, - znz_to_Z (nmake_op _ w4_op (S n)) (extend4 n x1) = - znz_to_Z w4_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend4. - rewrite GenBase.spec_extend; auto. - Qed. - - Lemma extend5n_spec: forall n x1, - znz_to_Z (nmake_op _ w5_op (S n)) (extend5 n x1) = - znz_to_Z w5_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend5. - rewrite GenBase.spec_extend; auto. - Qed. - - Lemma extend6n_spec: forall n x1, - znz_to_Z (nmake_op _ w6_op (S n)) (extend6 n x1) = - znz_to_Z w6_op x1. - Proof. - intros n1 x2; rewrite nmake_gen. - unfold extend6. - rewrite GenBase.spec_extend; auto. - Qed. - - Lemma spec_muln: - forall n (x: word _ (S n)) y, - [Nn (S n) (znz_mul_c (make_op n) x y)] = [Nn n x] * [Nn n y]. - Proof. - intros n x y; unfold to_Z. - rewrite <- (spec_mul_c (wn_spec n)). - rewrite make_op_S. - case znz_mul_c; auto. - Qed. - Theorem spec_mul: forall x y, [mul x y] = [x] * [y]. - Proof. - assert(F0: - forall n x y, - Z_of_nat n <= 6 -> [w0_mul n x y] = eval0n (S n) x * [N0 y]). - intros n x y H; unfold w0_mul. - generalize (spec_w0_mul_add_n1 (S n) x y w_0). - case w0_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w0_op (S n)) x) with (eval0n (S n) x). - change (znz_to_Z w0_op y) with ([N0 y]). - unfold w_0; rewrite (spec_0 w0_spec); rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w0_eq0 x1); case w0_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite to_Z0_spec; auto with zarith. - rewrite to_Z0_spec; try (rewrite inj_S; auto with zarith). - rewrite nmake_op_WW; rewrite extend0n_spec; auto. - assert(F1: - forall n x y, - Z_of_nat n <= 5 -> [w1_mul n x y] = eval1n (S n) x * [N1 y]). - intros n x y H; unfold w1_mul. - generalize (spec_w1_mul_add_n1 (S n) x y W0). - case w1_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w1_op (S n)) x) with (eval1n (S n) x). - change (znz_to_Z w1_op y) with ([N1 y]). - change (znz_to_Z w1_op W0) with 0; rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w1_eq0 x1); case w1_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite to_Z1_spec; auto with zarith. - rewrite to_Z1_spec; try (rewrite inj_S; auto with zarith). - rewrite nmake_op_WW; rewrite extend1n_spec; auto. - assert(F2: - forall n x y, - Z_of_nat n <= 4 -> [w2_mul n x y] = eval2n (S n) x * [N2 y]). - intros n x y H; unfold w2_mul. - generalize (spec_w2_mul_add_n1 (S n) x y W0). - case w2_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w2_op (S n)) x) with (eval2n (S n) x). - change (znz_to_Z w2_op y) with ([N2 y]). - change (znz_to_Z w2_op W0) with 0; rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w2_eq0 x1); case w2_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite to_Z2_spec; auto with zarith. - rewrite to_Z2_spec; try (rewrite inj_S; auto with zarith). - rewrite nmake_op_WW; rewrite extend2n_spec; auto. - assert(F3: - forall n x y, - Z_of_nat n <= 3 -> [w3_mul n x y] = eval3n (S n) x * [N3 y]). - intros n x y H; unfold w3_mul. - generalize (spec_w3_mul_add_n1 (S n) x y W0). - case w3_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w3_op (S n)) x) with (eval3n (S n) x). - change (znz_to_Z w3_op y) with ([N3 y]). - change (znz_to_Z w3_op W0) with 0; rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w3_eq0 x1); case w3_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite to_Z3_spec; auto with zarith. - rewrite to_Z3_spec; try (rewrite inj_S; auto with zarith). - rewrite nmake_op_WW; rewrite extend3n_spec; auto. - assert(F4: - forall n x y, - Z_of_nat n <= 2 -> [w4_mul n x y] = eval4n (S n) x * [N4 y]). - intros n x y H; unfold w4_mul. - generalize (spec_w4_mul_add_n1 (S n) x y W0). - case w4_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w4_op (S n)) x) with (eval4n (S n) x). - change (znz_to_Z w4_op y) with ([N4 y]). - change (znz_to_Z w4_op W0) with 0; rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w4_eq0 x1); case w4_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite to_Z4_spec; auto with zarith. - rewrite to_Z4_spec; try (rewrite inj_S; auto with zarith). - rewrite nmake_op_WW; rewrite extend4n_spec; auto. - assert(F5: - forall n x y, - Z_of_nat n <= 1 -> [w5_mul n x y] = eval5n (S n) x * [N5 y]). - intros n x y H; unfold w5_mul. - generalize (spec_w5_mul_add_n1 (S n) x y W0). - case w5_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w5_op (S n)) x) with (eval5n (S n) x). - change (znz_to_Z w5_op y) with ([N5 y]). - change (znz_to_Z w5_op W0) with 0; rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w5_eq0 x1); case w5_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite to_Z5_spec; auto with zarith. - rewrite to_Z5_spec; try (rewrite inj_S; auto with zarith). - rewrite nmake_op_WW; rewrite extend5n_spec; auto. - assert(F6: - forall n x y, - [w6_mul n x y] = eval6n (S n) x * [N6 y]). - intros n x y; unfold w6_mul. - generalize (spec_w6_mul_add_n1 (S n) x y W0). - case w6_mul_add_n1; intros x1 y1. - change (znz_to_Z (nmake_op _ w6_op (S n)) x) with (eval6n (S n) x). - change (znz_to_Z w6_op y) with ([N6 y]). - change (znz_to_Z w6_op W0) with 0; rewrite Zplus_0_r. - intros H1; rewrite <- H1; clear H1. - generalize (spec_w6_eq0 x1); case w6_eq0; intros HH. - unfold to_Z in HH; rewrite HH. - rewrite spec_eval6n; unfold eval6n, nmake_op6; auto. - rewrite spec_eval6n; unfold eval6n, nmake_op6. - rewrite nmake_op_WW; rewrite extend6n_spec; auto. - refine (spec_iter0 t_ (fun x y res => [res] = x * y) - (fun x y => reduce_1 (w0_mul_c x y)) - (fun n x y => w0_mul n y x) - w0_mul _ _ _ - (fun x y => reduce_2 (w1_mul_c x y)) - (fun n x y => w1_mul n y x) - w1_mul _ _ _ - (fun x y => reduce_3 (w2_mul_c x y)) - (fun n x y => w2_mul n y x) - w2_mul _ _ _ - (fun x y => reduce_4 (w3_mul_c x y)) - (fun n x y => w3_mul n y x) - w3_mul _ _ _ - (fun x y => reduce_5 (w4_mul_c x y)) - (fun n x y => w4_mul n y x) - w4_mul _ _ _ - (fun x y => reduce_6 (w5_mul_c x y)) - (fun n x y => w5_mul n y x) - w5_mul _ _ _ - (fun x y => reduce_7 (w6_mul_c x y)) - (fun n x y => w6_mul n y x) - w6_mul _ _ _ - mulnm _ - (fun _ => N0 w_0) _ - (fun _ => N0 w_0) _ - ). - intros x y; rewrite spec_reduce_1. - unfold w0_mul_c, to_Z. - generalize (spec_mul_c w0_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y H; rewrite F0; auto with zarith. - intros n x y H; rewrite F0; auto with zarith. - intros x y; rewrite spec_reduce_2. - unfold w1_mul_c, to_Z. - generalize (spec_mul_c w1_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y H; rewrite F1; auto with zarith. - intros n x y H; rewrite F1; auto with zarith. - intros x y; rewrite spec_reduce_3. - unfold w2_mul_c, to_Z. - generalize (spec_mul_c w2_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y H; rewrite F2; auto with zarith. - intros n x y H; rewrite F2; auto with zarith. - intros x y; rewrite spec_reduce_4. - unfold w3_mul_c, to_Z. - generalize (spec_mul_c w3_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y H; rewrite F3; auto with zarith. - intros n x y H; rewrite F3; auto with zarith. - intros x y; rewrite spec_reduce_5. - unfold w4_mul_c, to_Z. - generalize (spec_mul_c w4_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y H; rewrite F4; auto with zarith. - intros n x y H; rewrite F4; auto with zarith. - intros x y; rewrite spec_reduce_6. - unfold w5_mul_c, to_Z. - generalize (spec_mul_c w5_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y H; rewrite F5; auto with zarith. - intros n x y H; rewrite F5; auto with zarith. - intros x y; rewrite spec_reduce_7. - unfold w6_mul_c, to_Z. - generalize (spec_mul_c w6_spec x y). - intros HH; rewrite <- HH; clear HH; auto. - intros n x y; rewrite F6; auto with zarith. - intros n x y; rewrite F6; auto with zarith. - intros n m x y; unfold mulnm. - rewrite spec_reduce_n. - rewrite <- (spec_cast_l n m x). - rewrite <- (spec_cast_r n m y). - rewrite spec_muln; rewrite spec_cast_l; rewrite spec_cast_r; auto. - intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring. - intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring. - Qed. - - (***************************************************************) - (* *) - (* Square *) - (* *) - (***************************************************************) - - Definition w0_square_c := w0_op.(znz_square_c). - Definition w1_square_c := w1_op.(znz_square_c). - Definition w2_square_c := w2_op.(znz_square_c). - Definition w3_square_c := w3_op.(znz_square_c). - Definition w4_square_c := w4_op.(znz_square_c). - Definition w5_square_c := w5_op.(znz_square_c). - Definition w6_square_c := w6_op.(znz_square_c). - - Definition square x := - match x with - | N0 wx => reduce_1 (w0_square_c wx) - | N1 wx => N2 (w1_square_c wx) - | N2 wx => N3 (w2_square_c wx) - | N3 wx => N4 (w3_square_c wx) - | N4 wx => N5 (w4_square_c wx) - | N5 wx => N6 (w5_square_c wx) - | N6 wx => Nn 0 (w6_square_c wx) - | Nn n wx => - let op := make_op n in - Nn (S n) (op.(znz_square_c) wx) - end. - - Theorem spec_square: forall x, [square x] = [x] * [x]. - Proof. - intros x; case x; unfold square; clear x. - intros x; rewrite spec_reduce_1; unfold to_Z. - exact (spec_square_c w0_spec x). - intros x; unfold to_Z. - exact (spec_square_c w1_spec x). - intros x; unfold to_Z. - exact (spec_square_c w2_spec x). - intros x; unfold to_Z. - exact (spec_square_c w3_spec x). - intros x; unfold to_Z. - exact (spec_square_c w4_spec x). - intros x; unfold to_Z. - exact (spec_square_c w5_spec x). - intros x; unfold to_Z. - exact (spec_square_c w6_spec x). - intros n x; unfold to_Z. - rewrite make_op_S. - exact (spec_square_c (wn_spec n) x). -Qed. - - (***************************************************************) - (* *) - (* Power *) - (* *) - (***************************************************************) - - Fixpoint power_pos (x:t) (p:positive) {struct p} : t := - match p with - | xH => x - | xO p => square (power_pos x p) - | xI p => mul (square (power_pos x p)) x - end. - - Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n. - Proof. - intros x n; generalize x; elim n; clear n x; simpl power_pos. - intros; rewrite spec_mul; rewrite spec_square; rewrite H. - rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith. - rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. - rewrite Zpower_2; rewrite Zpower_1_r; auto. - intros; rewrite spec_square; rewrite H. - rewrite Zpos_xO; auto with zarith. - rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith. - rewrite Zpower_2; auto. - intros; rewrite Zpower_1_r; auto. - Qed. - - - (***************************************************************) - (* *) - (* Square root *) - (* *) - (***************************************************************) - - Definition w0_sqrt := w0_op.(znz_sqrt). - Definition w1_sqrt := w1_op.(znz_sqrt). - Definition w2_sqrt := w2_op.(znz_sqrt). - Definition w3_sqrt := w3_op.(znz_sqrt). - Definition w4_sqrt := w4_op.(znz_sqrt). - Definition w5_sqrt := w5_op.(znz_sqrt). - Definition w6_sqrt := w6_op.(znz_sqrt). - - Definition sqrt x := - match x with - | N0 wx => reduce_0 (w0_sqrt wx) - | N1 wx => reduce_1 (w1_sqrt wx) - | N2 wx => reduce_2 (w2_sqrt wx) - | N3 wx => reduce_3 (w3_sqrt wx) - | N4 wx => reduce_4 (w4_sqrt wx) - | N5 wx => reduce_5 (w5_sqrt wx) - | N6 wx => reduce_6 (w6_sqrt wx) - | Nn n wx => - let op := make_op n in - reduce_n n (op.(znz_sqrt) wx) - end. - - Theorem spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. - Proof. - intros x; unfold sqrt; case x; clear x. - intros x; rewrite spec_reduce_0; exact (spec_sqrt w0_spec x). - intros x; rewrite spec_reduce_1; exact (spec_sqrt w1_spec x). - intros x; rewrite spec_reduce_2; exact (spec_sqrt w2_spec x). - intros x; rewrite spec_reduce_3; exact (spec_sqrt w3_spec x). - intros x; rewrite spec_reduce_4; exact (spec_sqrt w4_spec x). - intros x; rewrite spec_reduce_5; exact (spec_sqrt w5_spec x). - intros x; rewrite spec_reduce_6; exact (spec_sqrt w6_spec x). - intros n x; rewrite spec_reduce_n; exact (spec_sqrt (wn_spec n) x). - Qed. - - (***************************************************************) - (* *) - (* Division *) - (* *) - (***************************************************************) - - Definition w0_div_gt := w0_op.(znz_div_gt). - Definition w1_div_gt := w1_op.(znz_div_gt). - Definition w2_div_gt := w2_op.(znz_div_gt). - Definition w3_div_gt := w3_op.(znz_div_gt). - Definition w4_div_gt := w4_op.(znz_div_gt). - Definition w5_div_gt := w5_op.(znz_div_gt). - Definition w6_div_gt := w6_op.(znz_div_gt). - - Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := - (spec_gen_divn1 - ww_op.(znz_zdigits) ww_op.(znz_0) - ww_op.(znz_WW) ww_op.(znz_head0) - ww_op.(znz_add_mul_div) ww_op.(znz_div21) - ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op) - (spec_to_Z ww_spec) - (spec_zdigits ww_spec) - (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec) - (spec_add_mul_div ww_spec) (spec_div21 ww_spec) - (ZnZ.spec_compare ww_spec) (ZnZ.spec_sub ww_spec)). - - Definition w0_divn1 n x y := - let (u, v) := - gen_divn1 w0_op.(znz_zdigits) w0_op.(znz_0) - w0_op.(znz_WW) w0_op.(znz_head0) - w0_op.(znz_add_mul_div) w0_op.(znz_div21) - w0_op.(znz_compare) w0_op.(znz_sub) (S n) x y in - (to_Z0 _ u, N0 v). - Definition w1_divn1 n x y := - let (u, v) := - gen_divn1 w1_op.(znz_zdigits) w1_op.(znz_0) - w1_op.(znz_WW) w1_op.(znz_head0) - w1_op.(znz_add_mul_div) w1_op.(znz_div21) - w1_op.(znz_compare) w1_op.(znz_sub) (S n) x y in - (to_Z1 _ u, N1 v). - Definition w2_divn1 n x y := - let (u, v) := - gen_divn1 w2_op.(znz_zdigits) w2_op.(znz_0) - w2_op.(znz_WW) w2_op.(znz_head0) - w2_op.(znz_add_mul_div) w2_op.(znz_div21) - w2_op.(znz_compare) w2_op.(znz_sub) (S n) x y in - (to_Z2 _ u, N2 v). - Definition w3_divn1 n x y := - let (u, v) := - gen_divn1 w3_op.(znz_zdigits) w3_op.(znz_0) - w3_op.(znz_WW) w3_op.(znz_head0) - w3_op.(znz_add_mul_div) w3_op.(znz_div21) - w3_op.(znz_compare) w3_op.(znz_sub) (S n) x y in - (to_Z3 _ u, N3 v). - Definition w4_divn1 n x y := - let (u, v) := - gen_divn1 w4_op.(znz_zdigits) w4_op.(znz_0) - w4_op.(znz_WW) w4_op.(znz_head0) - w4_op.(znz_add_mul_div) w4_op.(znz_div21) - w4_op.(znz_compare) w4_op.(znz_sub) (S n) x y in - (to_Z4 _ u, N4 v). - Definition w5_divn1 n x y := - let (u, v) := - gen_divn1 w5_op.(znz_zdigits) w5_op.(znz_0) - w5_op.(znz_WW) w5_op.(znz_head0) - w5_op.(znz_add_mul_div) w5_op.(znz_div21) - w5_op.(znz_compare) w5_op.(znz_sub) (S n) x y in - (to_Z5 _ u, N5 v). - Definition w6_divn1 n x y := - let (u, v) := - gen_divn1 w6_op.(znz_zdigits) w6_op.(znz_0) - w6_op.(znz_WW) w6_op.(znz_head0) - w6_op.(znz_add_mul_div) w6_op.(znz_div21) - w6_op.(znz_compare) w6_op.(znz_sub) (S n) x y in - (Nn _ u, N6 v). - - Lemma spec_get_end0: forall n x y, - eval0n n x <= [N0 y] -> - [N0 (GenBase.get_low w_0 n x)] = eval0n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval0n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w0_spec). - exact (spec_to_Z w0_spec). - apply Zle_lt_trans with [N0 y]; auto. - rewrite <- spec_gen_eval0n; auto. - unfold to_Z; case (spec_to_Z w0_spec y); auto. - Qed. - - Lemma spec_get_end1: forall n x y, - eval1n n x <= [N1 y] -> - [N1 (GenBase.get_low W0 n x)] = eval1n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval1n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w1_spec). - exact (spec_to_Z w1_spec). - apply Zle_lt_trans with [N1 y]; auto. - rewrite <- spec_gen_eval1n; auto. - unfold to_Z; case (spec_to_Z w1_spec y); auto. - Qed. - - Lemma spec_get_end2: forall n x y, - eval2n n x <= [N2 y] -> - [N2 (GenBase.get_low W0 n x)] = eval2n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval2n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w2_spec). - exact (spec_to_Z w2_spec). - apply Zle_lt_trans with [N2 y]; auto. - rewrite <- spec_gen_eval2n; auto. - unfold to_Z; case (spec_to_Z w2_spec y); auto. - Qed. - - Lemma spec_get_end3: forall n x y, - eval3n n x <= [N3 y] -> - [N3 (GenBase.get_low W0 n x)] = eval3n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval3n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w3_spec). - exact (spec_to_Z w3_spec). - apply Zle_lt_trans with [N3 y]; auto. - rewrite <- spec_gen_eval3n; auto. - unfold to_Z; case (spec_to_Z w3_spec y); auto. - Qed. - - Lemma spec_get_end4: forall n x y, - eval4n n x <= [N4 y] -> - [N4 (GenBase.get_low W0 n x)] = eval4n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval4n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w4_spec). - exact (spec_to_Z w4_spec). - apply Zle_lt_trans with [N4 y]; auto. - rewrite <- spec_gen_eval4n; auto. - unfold to_Z; case (spec_to_Z w4_spec y); auto. - Qed. - - Lemma spec_get_end5: forall n x y, - eval5n n x <= [N5 y] -> - [N5 (GenBase.get_low W0 n x)] = eval5n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval5n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w5_spec). - exact (spec_to_Z w5_spec). - apply Zle_lt_trans with [N5 y]; auto. - rewrite <- spec_gen_eval5n; auto. - unfold to_Z; case (spec_to_Z w5_spec y); auto. - Qed. - - Lemma spec_get_end6: forall n x y, - eval6n n x <= [N6 y] -> - [N6 (GenBase.get_low W0 n x)] = eval6n n x. - Proof. - intros n x y H. - rewrite spec_gen_eval6n; unfold to_Z. - apply GenBase.spec_get_low. - exact (spec_0 w6_spec). - exact (spec_to_Z w6_spec). - apply Zle_lt_trans with [N6 y]; auto. - rewrite <- spec_gen_eval6n; auto. - unfold to_Z; case (spec_to_Z w6_spec y); auto. - Qed. - - Let div_gt0 x y := let (u,v) := (w0_div_gt x y) in (reduce_0 u, reduce_0 v). - Let div_gt1 x y := let (u,v) := (w1_div_gt x y) in (reduce_1 u, reduce_1 v). - Let div_gt2 x y := let (u,v) := (w2_div_gt x y) in (reduce_2 u, reduce_2 v). - Let div_gt3 x y := let (u,v) := (w3_div_gt x y) in (reduce_3 u, reduce_3 v). - Let div_gt4 x y := let (u,v) := (w4_div_gt x y) in (reduce_4 u, reduce_4 v). - Let div_gt5 x y := let (u,v) := (w5_div_gt x y) in (reduce_5 u, reduce_5 v). - Let div_gt6 x y := let (u,v) := (w6_div_gt x y) in (reduce_6 u, reduce_6 v). - - Let div_gtnm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - let (q, r):= op.(znz_div_gt) - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) in - (reduce_n mn q, reduce_n mn r). - - Definition div_gt := Eval lazy beta delta [iter] in - (iter _ - div_gt0 - (fun n x y => div_gt0 x (GenBase.get_low w_0 (S n) y)) - w0_divn1 - div_gt1 - (fun n x y => div_gt1 x (GenBase.get_low W0 (S n) y)) - w1_divn1 - div_gt2 - (fun n x y => div_gt2 x (GenBase.get_low W0 (S n) y)) - w2_divn1 - div_gt3 - (fun n x y => div_gt3 x (GenBase.get_low W0 (S n) y)) - w3_divn1 - div_gt4 - (fun n x y => div_gt4 x (GenBase.get_low W0 (S n) y)) - w4_divn1 - div_gt5 - (fun n x y => div_gt5 x (GenBase.get_low W0 (S n) y)) - w5_divn1 - div_gt6 - (fun n x y => div_gt6 x (GenBase.get_low W0 (S n) y)) - w6_divn1 - div_gtnm). - - Theorem spec_div_gt: forall x y, - [x] > [y] -> 0 < [y] -> - let (q,r) := div_gt x y in - [q] = [x] / [y] /\ [r] = [x] mod [y]. - Proof. - assert (FO: - forall x y, [x] > [y] -> 0 < [y] -> - let (q,r) := div_gt x y in - [x] = [q] * [y] + [r] /\ 0 <= [r] < [y]). - refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y -> - let (q,r) := res in - x = [q] * y + [r] /\ 0 <= [r] < y) - div_gt0 - (fun n x y => div_gt0 x (GenBase.get_low w_0 (S n) y)) - w0_divn1 _ _ _ - div_gt1 - (fun n x y => div_gt1 x (GenBase.get_low W0 (S n) y)) - w1_divn1 _ _ _ - div_gt2 - (fun n x y => div_gt2 x (GenBase.get_low W0 (S n) y)) - w2_divn1 _ _ _ - div_gt3 - (fun n x y => div_gt3 x (GenBase.get_low W0 (S n) y)) - w3_divn1 _ _ _ - div_gt4 - (fun n x y => div_gt4 x (GenBase.get_low W0 (S n) y)) - w4_divn1 _ _ _ - div_gt5 - (fun n x y => div_gt5 x (GenBase.get_low W0 (S n) y)) - w5_divn1 _ _ _ - div_gt6 - (fun n x y => div_gt6 x (GenBase.get_low W0 (S n) y)) - w6_divn1 _ _ _ - div_gtnm _). - intros x y H1 H2; unfold div_gt0, w0_div_gt. - generalize (spec_div_gt w0_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_0; auto. - intros n x y H1 H2 H3; unfold div_gt0, w0_div_gt. - generalize (spec_div_gt w0_spec x - (GenBase.get_low w_0 (S n) y)). - unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_0. - generalize (spec_get_end0 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H1 H2 H3. - generalize - (spec_divn1 w0 w0_op w0_spec (S n) x y H3). - unfold w0_divn1;unfold w0; case gen_divn1. - intros xx yy H4. - rewrite to_Z0_spec; auto with zarith. - repeat rewrite <- spec_gen_eval0n in H4; auto. - intros x y H1 H2; unfold div_gt1, w1_div_gt. - generalize (spec_div_gt w1_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_1; auto. - intros n x y H1 H2 H3; unfold div_gt1, w1_div_gt. - generalize (spec_div_gt w1_spec x - (GenBase.get_low W0 (S n) y)). - unfold w1;unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_1. - generalize (spec_get_end1 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H1 H2 H3. - generalize - (spec_divn1 w1 w1_op w1_spec (S n) x y H3). - unfold w1_divn1;unfold w1;unfold w0; case gen_divn1. - intros xx yy H4. - rewrite to_Z1_spec; auto with zarith. - repeat rewrite <- spec_gen_eval1n in H4; auto. - intros x y H1 H2; unfold div_gt2, w2_div_gt. - generalize (spec_div_gt w2_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_2; auto. - intros n x y H1 H2 H3; unfold div_gt2, w2_div_gt. - generalize (spec_div_gt w2_spec x - (GenBase.get_low W0 (S n) y)). - unfold w2;unfold w1;unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_2. - generalize (spec_get_end2 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H1 H2 H3. - generalize - (spec_divn1 w2 w2_op w2_spec (S n) x y H3). - unfold w2_divn1;unfold w2;unfold w1;unfold w0; case gen_divn1. - intros xx yy H4. - rewrite to_Z2_spec; auto with zarith. - repeat rewrite <- spec_gen_eval2n in H4; auto. - intros x y H1 H2; unfold div_gt3, w3_div_gt. - generalize (spec_div_gt w3_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_3; auto. - intros n x y H1 H2 H3; unfold div_gt3, w3_div_gt. - generalize (spec_div_gt w3_spec x - (GenBase.get_low W0 (S n) y)). - unfold w3;unfold w2;unfold w1;unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_3. - generalize (spec_get_end3 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H1 H2 H3. - generalize - (spec_divn1 w3 w3_op w3_spec (S n) x y H3). - unfold w3_divn1;unfold w3;unfold w2;unfold w1;unfold w0; case gen_divn1. - intros xx yy H4. - rewrite to_Z3_spec; auto with zarith. - repeat rewrite <- spec_gen_eval3n in H4; auto. - intros x y H1 H2; unfold div_gt4, w4_div_gt. - generalize (spec_div_gt w4_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_4; auto. - intros n x y H1 H2 H3; unfold div_gt4, w4_div_gt. - generalize (spec_div_gt w4_spec x - (GenBase.get_low W0 (S n) y)). - unfold w4;unfold w3;unfold w2;unfold w1;unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_4. - generalize (spec_get_end4 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H1 H2 H3. - generalize - (spec_divn1 w4 w4_op w4_spec (S n) x y H3). - unfold w4_divn1;unfold w4;unfold w3;unfold w2;unfold w1;unfold w0; case gen_divn1. - intros xx yy H4. - rewrite to_Z4_spec; auto with zarith. - repeat rewrite <- spec_gen_eval4n in H4; auto. - intros x y H1 H2; unfold div_gt5, w5_div_gt. - generalize (spec_div_gt w5_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_5; auto. - intros n x y H1 H2 H3; unfold div_gt5, w5_div_gt. - generalize (spec_div_gt w5_spec x - (GenBase.get_low W0 (S n) y)). - unfold w5;unfold w4;unfold w3;unfold w2;unfold w1;unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_5. - generalize (spec_get_end5 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H1 H2 H3. - generalize - (spec_divn1 w5 w5_op w5_spec (S n) x y H3). - unfold w5_divn1;unfold w5;unfold w4;unfold w3;unfold w2;unfold w1;unfold w0; case gen_divn1. - intros xx yy H4. - rewrite to_Z5_spec; auto with zarith. - repeat rewrite <- spec_gen_eval5n in H4; auto. - intros x y H1 H2; unfold div_gt6, w6_div_gt. - generalize (spec_div_gt w6_spec x y H1 H2); case znz_div_gt. - intros xx yy; repeat rewrite spec_reduce_6; auto. - intros n x y H2 H3; unfold div_gt6, w6_div_gt. - generalize (spec_div_gt w6_spec x - (GenBase.get_low W0 (S n) y)). - unfold w6;unfold w5;unfold w4;unfold w3;unfold w2;unfold w1;unfold w0;case znz_div_gt. - intros xx yy H4; repeat rewrite spec_reduce_6. - generalize (spec_get_end6 (S n) y x); unfold to_Z; intros H5. - unfold to_Z in H2; rewrite H5 in H4; auto with zarith. - intros n x y H2 H3. - generalize - (spec_divn1 w6 w6_op w6_spec (S n) x y H3). - unfold w6_divn1;unfold w6;unfold w5;unfold w4;unfold w3;unfold w2;unfold w1;unfold w0; case gen_divn1. - intros xx yy H4. - repeat rewrite <- spec_gen_eval6n in H4; auto. - rewrite spec_eval6n; auto. - intros n m x y H1 H2; unfold div_gtnm. - generalize (spec_div_gt (wn_spec (Max.max n m)) - (castm (diff_r n m) - (extend_tr x (snd (diff n m)))) - (castm (diff_l n m) - (extend_tr y (fst (diff n m))))). - case znz_div_gt. - intros xx yy HH. - repeat rewrite spec_reduce_n. - rewrite <- (spec_cast_l n m x). - rewrite <- (spec_cast_r n m y). - unfold to_Z; apply HH. - rewrite <- (spec_cast_l n m x) in H1; auto. - rewrite <- (spec_cast_r n m y) in H1; auto. - rewrite <- (spec_cast_r n m y) in H2; auto. - intros x y H1 H2; generalize (FO x y H1 H2); case div_gt. - intros q r (H3, H4); split. - apply (Zdiv_unique [x] [y] [q] [r]); auto. - rewrite Zmult_comm; auto. - apply (Zmod_unique [x] [y] [q] [r]); auto. - rewrite Zmult_comm; auto. - Qed. - - Definition div_eucl x y := - match compare x y with - | Eq => (one, zero) - | Lt => (zero, x) - | Gt => div_gt x y - end. - - Theorem spec_div_eucl: forall x y, - 0 < [y] -> - let (q,r) := div_eucl x y in - ([q], [r]) = Zdiv_eucl [x] [y]. - Proof. - assert (F0: [zero] = 0). - exact (spec_0 w0_spec). - assert (F1: [one] = 1). - exact (spec_1 w0_spec). - intros x y H; generalize (spec_compare x y); - unfold div_eucl; case compare; try rewrite F0; - try rewrite F1; intros; auto with zarith. - rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H)) - (Z_mod_same [y] (Zlt_gt _ _ H)); - unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto. - assert (F2: 0 <= [x] < [y]). - generalize (spec_pos x); auto. - generalize (Zdiv_small _ _ F2) - (Zmod_small _ _ F2); - unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto. - generalize (spec_div_gt _ _ H0 H); auto. - unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt. - intros a b c d (H1, H2); subst; auto. - Qed. - - Definition div x y := fst (div_eucl x y). - - Theorem spec_div: - forall x y, 0 < [y] -> [div x y] = [x] / [y]. - Proof. - intros x y H1; unfold div; generalize (spec_div_eucl x y H1); - case div_eucl; simpl fst. - intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H; - injection H; auto. - Qed. - - (***************************************************************) - (* *) - (* Modulo *) - (* *) - (***************************************************************) - - Definition w0_mod_gt := w0_op.(znz_mod_gt). - Definition w1_mod_gt := w1_op.(znz_mod_gt). - Definition w2_mod_gt := w2_op.(znz_mod_gt). - Definition w3_mod_gt := w3_op.(znz_mod_gt). - Definition w4_mod_gt := w4_op.(znz_mod_gt). - Definition w5_mod_gt := w5_op.(znz_mod_gt). - Definition w6_mod_gt := w6_op.(znz_mod_gt). - - Definition w0_modn1 := - gen_modn1 w0_op.(znz_zdigits) w0_op.(znz_0) - w0_op.(znz_head0) w0_op.(znz_add_mul_div) w0_op.(znz_div21) - w0_op.(znz_compare) w0_op.(znz_sub). - Definition w1_modn1 := - gen_modn1 w1_op.(znz_zdigits) w1_op.(znz_0) - w1_op.(znz_head0) w1_op.(znz_add_mul_div) w1_op.(znz_div21) - w1_op.(znz_compare) w1_op.(znz_sub). - Definition w2_modn1 := - gen_modn1 w2_op.(znz_zdigits) w2_op.(znz_0) - w2_op.(znz_head0) w2_op.(znz_add_mul_div) w2_op.(znz_div21) - w2_op.(znz_compare) w2_op.(znz_sub). - Definition w3_modn1 := - gen_modn1 w3_op.(znz_zdigits) w3_op.(znz_0) - w3_op.(znz_head0) w3_op.(znz_add_mul_div) w3_op.(znz_div21) - w3_op.(znz_compare) w3_op.(znz_sub). - Definition w4_modn1 := - gen_modn1 w4_op.(znz_zdigits) w4_op.(znz_0) - w4_op.(znz_head0) w4_op.(znz_add_mul_div) w4_op.(znz_div21) - w4_op.(znz_compare) w4_op.(znz_sub). - Definition w5_modn1 := - gen_modn1 w5_op.(znz_zdigits) w5_op.(znz_0) - w5_op.(znz_head0) w5_op.(znz_add_mul_div) w5_op.(znz_div21) - w5_op.(znz_compare) w5_op.(znz_sub). - Definition w6_modn1 := - gen_modn1 w6_op.(znz_zdigits) w6_op.(znz_0) - w6_op.(znz_head0) w6_op.(znz_add_mul_div) w6_op.(znz_div21) - w6_op.(znz_compare) w6_op.(znz_sub). - - Let mod_gtnm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - reduce_n mn (op.(znz_mod_gt) - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d)))). - - Definition mod_gt := Eval lazy beta delta[iter] in - (iter _ - (fun x y => reduce_0 (w0_mod_gt x y)) - (fun n x y => reduce_0 (w0_mod_gt x (GenBase.get_low w_0 (S n) y))) - (fun n x y => reduce_0 (w0_modn1 (S n) x y)) - (fun x y => reduce_1 (w1_mod_gt x y)) - (fun n x y => reduce_1 (w1_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_1 (w1_modn1 (S n) x y)) - (fun x y => reduce_2 (w2_mod_gt x y)) - (fun n x y => reduce_2 (w2_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_2 (w2_modn1 (S n) x y)) - (fun x y => reduce_3 (w3_mod_gt x y)) - (fun n x y => reduce_3 (w3_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_3 (w3_modn1 (S n) x y)) - (fun x y => reduce_4 (w4_mod_gt x y)) - (fun n x y => reduce_4 (w4_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_4 (w4_modn1 (S n) x y)) - (fun x y => reduce_5 (w5_mod_gt x y)) - (fun n x y => reduce_5 (w5_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_5 (w5_modn1 (S n) x y)) - (fun x y => reduce_6 (w6_mod_gt x y)) - (fun n x y => reduce_6 (w6_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_6 (w6_modn1 (S n) x y)) - mod_gtnm). - - Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := - (spec_gen_modn1 - ww_op.(znz_zdigits) ww_op.(znz_0) - ww_op.(znz_WW) ww_op.(znz_head0) - ww_op.(znz_add_mul_div) ww_op.(znz_div21) - ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op) - (spec_to_Z ww_spec) - (spec_zdigits ww_spec) - (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec) - (spec_add_mul_div ww_spec) (spec_div21 ww_spec) - (ZnZ.spec_compare ww_spec) (ZnZ.spec_sub ww_spec)). - - Theorem spec_mod_gt: - forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y]. - Proof. - refine (spec_iter _ (fun x y res => x > y -> 0 < y -> - [res] = x mod y) - (fun x y => reduce_0 (w0_mod_gt x y)) - (fun n x y => reduce_0 (w0_mod_gt x (GenBase.get_low w_0 (S n) y))) - (fun n x y => reduce_0 (w0_modn1 (S n) x y)) _ _ _ - (fun x y => reduce_1 (w1_mod_gt x y)) - (fun n x y => reduce_1 (w1_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_1 (w1_modn1 (S n) x y)) _ _ _ - (fun x y => reduce_2 (w2_mod_gt x y)) - (fun n x y => reduce_2 (w2_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_2 (w2_modn1 (S n) x y)) _ _ _ - (fun x y => reduce_3 (w3_mod_gt x y)) - (fun n x y => reduce_3 (w3_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_3 (w3_modn1 (S n) x y)) _ _ _ - (fun x y => reduce_4 (w4_mod_gt x y)) - (fun n x y => reduce_4 (w4_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_4 (w4_modn1 (S n) x y)) _ _ _ - (fun x y => reduce_5 (w5_mod_gt x y)) - (fun n x y => reduce_5 (w5_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_5 (w5_modn1 (S n) x y)) _ _ _ - (fun x y => reduce_6 (w6_mod_gt x y)) - (fun n x y => reduce_6 (w6_mod_gt x (GenBase.get_low W0 (S n) y))) - (fun n x y => reduce_6 (w6_modn1 (S n) x y)) _ _ _ - mod_gtnm _). - intros x y H1 H2; rewrite spec_reduce_0. - exact (spec_mod_gt w0_spec x y H1 H2). - intros n x y H1 H2 H3; rewrite spec_reduce_0. - unfold w0_mod_gt. - rewrite <- (spec_get_end0 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w0_spec); auto. - rewrite <- (spec_get_end0 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end0 (S n) y x) in H3; auto with zarith. - intros n x y H1 H2 H3; rewrite spec_reduce_0. - unfold w0_modn1, to_Z; rewrite spec_gen_eval0n. - apply (spec_modn1 _ _ w0_spec); auto. - intros x y H1 H2; rewrite spec_reduce_1. - exact (spec_mod_gt w1_spec x y H1 H2). - intros n x y H1 H2 H3; rewrite spec_reduce_1. - unfold w1_mod_gt. - rewrite <- (spec_get_end1 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w1_spec); auto. - rewrite <- (spec_get_end1 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end1 (S n) y x) in H3; auto with zarith. - intros n x y H1 H2 H3; rewrite spec_reduce_1. - unfold w1_modn1, to_Z; rewrite spec_gen_eval1n. - apply (spec_modn1 _ _ w1_spec); auto. - intros x y H1 H2; rewrite spec_reduce_2. - exact (spec_mod_gt w2_spec x y H1 H2). - intros n x y H1 H2 H3; rewrite spec_reduce_2. - unfold w2_mod_gt. - rewrite <- (spec_get_end2 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w2_spec); auto. - rewrite <- (spec_get_end2 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end2 (S n) y x) in H3; auto with zarith. - intros n x y H1 H2 H3; rewrite spec_reduce_2. - unfold w2_modn1, to_Z; rewrite spec_gen_eval2n. - apply (spec_modn1 _ _ w2_spec); auto. - intros x y H1 H2; rewrite spec_reduce_3. - exact (spec_mod_gt w3_spec x y H1 H2). - intros n x y H1 H2 H3; rewrite spec_reduce_3. - unfold w3_mod_gt. - rewrite <- (spec_get_end3 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w3_spec); auto. - rewrite <- (spec_get_end3 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end3 (S n) y x) in H3; auto with zarith. - intros n x y H1 H2 H3; rewrite spec_reduce_3. - unfold w3_modn1, to_Z; rewrite spec_gen_eval3n. - apply (spec_modn1 _ _ w3_spec); auto. - intros x y H1 H2; rewrite spec_reduce_4. - exact (spec_mod_gt w4_spec x y H1 H2). - intros n x y H1 H2 H3; rewrite spec_reduce_4. - unfold w4_mod_gt. - rewrite <- (spec_get_end4 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w4_spec); auto. - rewrite <- (spec_get_end4 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end4 (S n) y x) in H3; auto with zarith. - intros n x y H1 H2 H3; rewrite spec_reduce_4. - unfold w4_modn1, to_Z; rewrite spec_gen_eval4n. - apply (spec_modn1 _ _ w4_spec); auto. - intros x y H1 H2; rewrite spec_reduce_5. - exact (spec_mod_gt w5_spec x y H1 H2). - intros n x y H1 H2 H3; rewrite spec_reduce_5. - unfold w5_mod_gt. - rewrite <- (spec_get_end5 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w5_spec); auto. - rewrite <- (spec_get_end5 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end5 (S n) y x) in H3; auto with zarith. - intros n x y H1 H2 H3; rewrite spec_reduce_5. - unfold w5_modn1, to_Z; rewrite spec_gen_eval5n. - apply (spec_modn1 _ _ w5_spec); auto. - intros x y H1 H2; rewrite spec_reduce_6. - exact (spec_mod_gt w6_spec x y H1 H2). - intros n x y H2 H3; rewrite spec_reduce_6. - unfold w6_mod_gt. - rewrite <- (spec_get_end6 (S n) y x); auto with zarith. - unfold to_Z; apply (spec_mod_gt w6_spec); auto. - rewrite <- (spec_get_end6 (S n) y x) in H2; auto with zarith. - rewrite <- (spec_get_end6 (S n) y x) in H3; auto with zarith. - intros n x y H2 H3; rewrite spec_reduce_6. - unfold w6_modn1, to_Z; rewrite spec_gen_eval6n. - apply (spec_modn1 _ _ w6_spec); auto. - intros n m x y H1 H2; unfold mod_gtnm. - repeat rewrite spec_reduce_n. - rewrite <- (spec_cast_l n m x). - rewrite <- (spec_cast_r n m y). - unfold to_Z; apply (spec_mod_gt (wn_spec (Max.max n m))). - rewrite <- (spec_cast_l n m x) in H1; auto. - rewrite <- (spec_cast_r n m y) in H1; auto. - rewrite <- (spec_cast_r n m y) in H2; auto. - Qed. - - Definition modulo x y := - match compare x y with - | Eq => zero - | Lt => x - | Gt => mod_gt x y - end. - - Theorem spec_modulo: - forall x y, 0 < [y] -> [modulo x y] = [x] mod [y]. - Proof. - assert (F0: [zero] = 0). - exact (spec_0 w0_spec). - assert (F1: [one] = 1). - exact (spec_1 w0_spec). - intros x y H; generalize (spec_compare x y); - unfold modulo; case compare; try rewrite F0; - try rewrite F1; intros; try split; auto with zarith. - rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith. - apply sym_equal; apply Zmod_small; auto with zarith. - generalize (spec_pos x); auto with zarith. - apply spec_mod_gt; auto. - Qed. - - (***************************************************************) - (* *) - (* Gcd *) - (* *) - (***************************************************************) - - Definition digits x := - match x with - | N0 _ => w0_op.(znz_digits) - | N1 _ => w1_op.(znz_digits) - | N2 _ => w2_op.(znz_digits) - | N3 _ => w3_op.(znz_digits) - | N4 _ => w4_op.(znz_digits) - | N5 _ => w5_op.(znz_digits) - | N6 _ => w6_op.(znz_digits) - | Nn n _ => (make_op n).(znz_digits) - end. - - Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x). - Proof. - intros x; case x; clear x. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w0_spec x); unfold base; intros H; exact H. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w1_spec x); unfold base; intros H; exact H. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w2_spec x); unfold base; intros H; exact H. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w3_spec x); unfold base; intros H; exact H. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w4_spec x); unfold base; intros H; exact H. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w5_spec x); unfold base; intros H; exact H. - intros x; unfold to_Z, digits; - generalize (spec_to_Z w6_spec x); unfold base; intros H; exact H. - intros n x; unfold to_Z, digits; - generalize (spec_to_Z (wn_spec n) x); unfold base; intros H; exact H. - Qed. - - Definition gcd_gt_body a b cont := - match compare b zero with - | Gt => - let r := mod_gt a b in - match compare r zero with - | Gt => cont r (mod_gt b r) - | _ => b - end - | _ => a - end. - - Theorem Zspec_gcd_gt_body: forall a b cont p, - [a] > [b] -> [a] < 2 ^ p -> - (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] -> - Zis_gcd [a1] [b1] [cont a1 b1]) -> - Zis_gcd [a] [b] [gcd_gt_body a b cont]. - Proof. - assert (F1: [zero] = 0). - unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto. - intros a b cont p H2 H3 H4; unfold gcd_gt_body. - generalize (spec_compare b zero); case compare; try rewrite F1. - intros HH; rewrite HH; apply Zis_gcd_0. - intros HH; absurd (0 <= [b]); auto with zarith. - case (spec_digits b); auto with zarith. - intros H5; generalize (spec_compare (mod_gt a b) zero); - case compare; try rewrite F1. - intros H6; rewrite <- (Zmult_1_r [b]). - rewrite (Z_div_mod_eq [a] [b]); auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - rewrite H6; rewrite Zplus_0_r. - apply Zis_gcd_mult; apply Zis_gcd_1. - intros; apply False_ind. - case (spec_digits (mod_gt a b)); auto with zarith. - intros H6; apply GenDiv.Zis_gcd_mod; auto with zarith. - apply GenDiv.Zis_gcd_mod; auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - assert (F2: [b] > [mod_gt a b]). - case (Z_mod_lt [a] [b]); auto with zarith. - repeat rewrite <- spec_mod_gt; auto with zarith. - assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)]). - case (Z_mod_lt [b] [mod_gt a b]); auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - repeat rewrite <- spec_mod_gt; auto with zarith. - apply H4; auto with zarith. - apply Zmult_lt_reg_r with 2; auto with zarith. - apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith. - apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith. - apply Zplus_le_compat_r. - pattern [b] at 1; rewrite <- (Zmult_1_l [b]). - apply Zmult_le_compat_r; auto with zarith. - case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith. - intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2; - try rewrite <- HH in H2; auto with zarith. - case (Z_mod_lt [a] [b]); auto with zarith. - rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith. - rewrite <- Z_div_mod_eq; auto with zarith. - pattern 2 at 2; rewrite <- (Zpower_1_r 2). - rewrite <- Zpower_exp; auto with zarith. - ring_simplify (p - 1 + 1); auto. - case (Zle_lt_or_eq 0 p); auto with zarith. - generalize H3; case p; simpl Zpower; auto with zarith. - intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith. - Qed. - - Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t := - gcd_gt_body a b - (fun a b => - match p with - | xH => cont a b - | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b - | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b - end). - - Theorem Zspec_gcd_gt_aux: forall p n a b cont, - [a] > [b] -> [a] < 2 ^ (Zpos p + n) -> - (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] -> - Zis_gcd [a1] [b1] [cont a1 b1]) -> - Zis_gcd [a] [b] [gcd_gt_aux p cont a b]. - intros p; elim p; clear p. - intros p Hrec n a b cont H2 H3 H4. - unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto. - intros a1 b1 H6 H7. - apply Hrec with (Zpos p + n); auto. - replace (Zpos p + (Zpos p + n)) with - (Zpos (xI p) + n - 1); auto. - rewrite Zpos_xI; ring. - intros a2 b2 H9 H10. - apply Hrec with n; auto. - intros p Hrec n a b cont H2 H3 H4. - unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto. - intros a1 b1 H6 H7. - apply Hrec with (Zpos p + n - 1); auto. - replace (Zpos p + (Zpos p + n - 1)) with - (Zpos (xO p) + n - 1); auto. - rewrite Zpos_xO; ring. - intros a2 b2 H9 H10. - apply Hrec with (n - 1); auto. - replace (Zpos p + (n - 1)) with - (Zpos p + n - 1); auto with zarith. - intros a3 b3 H12 H13; apply H4; auto with zarith. - apply Zlt_le_trans with (1 := H12). - case (Zle_or_lt 1 n); intros HH. - apply Zpower_le_monotone; auto with zarith. - apply Zle_trans with 0; auto with zarith. - assert (HH1: n - 1 < 0); auto with zarith. - generalize HH1; case (n - 1); auto with zarith. - intros p1 HH2; discriminate. - intros n a b cont H H2 H3. - simpl gcd_gt_aux. - apply Zspec_gcd_gt_body with (n + 1); auto with zarith. - rewrite Zplus_comm; auto. - intros a1 b1 H5 H6; apply H3; auto. - replace n with (n + 1 - 1); auto; try ring. - Qed. - - Definition gcd_cont a b := - match compare one b with - | Eq => one - | _ => a - end. - - Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b. - - Theorem spec_gcd_gt: forall a b, - [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b]. - Proof. - intros a b H2. - case (spec_digits (gcd_gt a b)); intros H3 H4. - case (spec_digits a); intros H5 H6. - apply sym_equal; apply Zis_gcd_gcd; auto with zarith. - unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith. - intros a1 a2; rewrite Zpower_0_r. - case (spec_digits a2); intros H7 H8; - intros; apply False_ind; auto with zarith. - Qed. - - Definition gcd a b := - match compare a b with - | Eq => a - | Lt => gcd_gt b a - | Gt => gcd_gt a b - end. - - Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b]. - Proof. - intros a b. - case (spec_digits a); intros H1 H2. - case (spec_digits b); intros H3 H4. - unfold gcd; generalize (spec_compare a b); case compare. - intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto. - apply Zis_gcd_refl. - intros; apply trans_equal with (Zgcd [b] [a]). - apply spec_gcd_gt; auto with zarith. - apply Zis_gcd_gcd; auto with zarith. - apply Zgcd_is_pos. - apply Zis_gcd_sym; apply Zgcd_is_gcd. - intros; apply spec_gcd_gt; auto. - Qed. - - (***************************************************************) - (* *) - (* Conversion *) - (* *) - (***************************************************************) - - Definition pheight p := - Peano.pred (nat_of_P (get_height w0_op.(znz_digits) (plength p))). - - Theorem pheight_correct: forall p, - Zpos p < 2 ^ (Zpos (znz_digits w0_op) * 2 ^ (Z_of_nat (pheight p))). - Proof. - intros p; unfold pheight. - assert (F1: forall x, Z_of_nat (Peano.pred (nat_of_P x)) = Zpos x - 1). - intros x. - assert (Zsucc (Z_of_nat (Peano.pred (nat_of_P x))) = Zpos x); auto with zarith. - rewrite <- inj_S. - rewrite <- (fun x => S_pred x 0); auto with zarith. - rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto. - apply lt_le_trans with 1%nat; auto with zarith. - exact (le_Pmult_nat x 1). - rewrite F1; clear F1. - assert (F2:= (get_height_correct (znz_digits w0_op) (plength p))). - apply Zlt_le_trans with (Zpos (Psucc p)). - rewrite Zpos_succ_morphism; auto with zarith. - apply Zle_trans with (1 := plength_pred_correct (Psucc p)). - rewrite Ppred_succ. - apply Zpower_le_monotone; auto with zarith. - Qed. - - Definition of_pos x := - let h := pheight x in - match h with - | 0%nat => reduce_0 (snd (w0_op.(znz_of_pos) x)) - | 1%nat => reduce_1 (snd (w1_op.(znz_of_pos) x)) - | 2%nat => reduce_2 (snd (w2_op.(znz_of_pos) x)) - | 3%nat => reduce_3 (snd (w3_op.(znz_of_pos) x)) - | 4%nat => reduce_4 (snd (w4_op.(znz_of_pos) x)) - | 5%nat => reduce_5 (snd (w5_op.(znz_of_pos) x)) - | 6%nat => reduce_6 (snd (w6_op.(znz_of_pos) x)) - | _ => - let n := minus h 7 in - reduce_n n (snd ((make_op n).(znz_of_pos) x)) - end. - - Theorem spec_of_pos: forall x, - [of_pos x] = Zpos x. - Proof. - assert (F := spec_more_than_1_digit w0_spec). - intros x; unfold of_pos; case_eq (pheight x). - intros H1; rewrite spec_reduce_0; unfold to_Z. - apply (znz_of_pos_correct w0_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^0) with (1). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - intros n; case n; clear n. - intros H1; rewrite spec_reduce_1; unfold to_Z. - apply (znz_of_pos_correct w1_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^1) with (2). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - apply Zeq_le; apply Zmult_comm. - intros n; case n; clear n. - intros H1; rewrite spec_reduce_2; unfold to_Z. - apply (znz_of_pos_correct w2_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^2) with (2 * 2). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - apply Zeq_le; apply Zmult_comm. - intros n; case n; clear n. - intros H1; rewrite spec_reduce_3; unfold to_Z. - apply (znz_of_pos_correct w3_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^3) with (2 * 2 * 2). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - apply Zeq_le; apply Zmult_comm. - intros n; case n; clear n. - intros H1; rewrite spec_reduce_4; unfold to_Z. - apply (znz_of_pos_correct w4_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^4) with (2 * 2 * 2 * 2). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - apply Zeq_le; apply Zmult_comm. - intros n; case n; clear n. - intros H1; rewrite spec_reduce_5; unfold to_Z. - apply (znz_of_pos_correct w5_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^5) with (2 * 2 * 2 * 2 * 2). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - apply Zeq_le; apply Zmult_comm. - intros n; case n; clear n. - intros H1; rewrite spec_reduce_6; unfold to_Z. - apply (znz_of_pos_correct w6_spec). - apply Zlt_le_trans with (1 := pheight_correct x). - rewrite H1; simpl Z_of_nat; change (2^6) with (2 * 2 * 2 * 2 * 2 * 2). - unfold base. - apply Zpower_le_monotone; split; auto with zarith. - apply Zeq_le; apply Zmult_comm. - intros n. - intros H1; rewrite spec_reduce_n; unfold to_Z. - simpl minus; rewrite <- minus_n_O. - apply (znz_of_pos_correct (wn_spec n)). - apply Zlt_le_trans with (1 := pheight_correct x). - unfold base. - apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - rewrite H1. - elim n; clear n H1. - simpl Z_of_nat; change (2^7) with (2 * 2 * 2 * 2 * 2 * 2 * 2). - rewrite Zmult_comm; repeat rewrite <- Zmult_assoc. - repeat rewrite <- Zpos_xO. - refine (Zle_refl _). - intros n Hrec. - rewrite make_op_S. - change (@znz_digits (word _ (S (S n))) (mk_zn2z_op_karatsuba (make_op n))) with - (xO (znz_digits (make_op n))). - rewrite (fun x y => (Zpos_xO (@znz_digits x y))). - rewrite inj_S; unfold Zsucc. - rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r. - assert (tmp: forall x y z, x * (y * z) = y * (x * z)); - [intros; ring | rewrite tmp; clear tmp]. - apply Zmult_le_compat_l; auto with zarith. - Qed. - - Definition of_N x := - match x with - | BinNat.N0 => zero - | Npos p => of_pos p - end. - - Theorem spec_of_N: forall x, - [of_N x] = Z_of_N x. - Proof. - intros x; case x. - simpl of_N. - unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto. - intros p; exact (spec_of_pos p). - Qed. - - (***************************************************************) - (* *) - (* Shift *) - (* *) - (***************************************************************) - - Definition head0 w := match w with - | N0 w=> reduce_0 (w0_op.(znz_head0) w) - | N1 w=> reduce_1 (w1_op.(znz_head0) w) - | N2 w=> reduce_2 (w2_op.(znz_head0) w) - | N3 w=> reduce_3 (w3_op.(znz_head0) w) - | N4 w=> reduce_4 (w4_op.(znz_head0) w) - | N5 w=> reduce_5 (w5_op.(znz_head0) w) - | N6 w=> reduce_6 (w6_op.(znz_head0) w) - | Nn n w=> reduce_n n ((make_op n).(znz_head0) w) - end. - - Theorem spec_head00: forall x, [x] = 0 ->[head0 x] = Zpos (digits x). - Proof. - intros x; case x; unfold head0; clear x. - intros x; rewrite spec_reduce_0; exact (spec_head00 w0_spec x). - intros x; rewrite spec_reduce_1; exact (spec_head00 w1_spec x). - intros x; rewrite spec_reduce_2; exact (spec_head00 w2_spec x). - intros x; rewrite spec_reduce_3; exact (spec_head00 w3_spec x). - intros x; rewrite spec_reduce_4; exact (spec_head00 w4_spec x). - intros x; rewrite spec_reduce_5; exact (spec_head00 w5_spec x). - intros x; rewrite spec_reduce_6; exact (spec_head00 w6_spec x). - intros n x; rewrite spec_reduce_n; exact (spec_head00 (wn_spec n) x). - Qed. - - Theorem spec_head0: forall x, 0 < [x] -> - 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x). - Proof. - assert (F0: forall x, (x - 1) + 1 = x). - intros; ring. - intros x; case x; unfold digits, head0; clear x. - intros x Hx; rewrite spec_reduce_0. - assert (F1:= spec_more_than_1_digit w0_spec). - generalize (spec_head0 w0_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w0_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros x Hx; rewrite spec_reduce_1. - assert (F1:= spec_more_than_1_digit w1_spec). - generalize (spec_head0 w1_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w1_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros x Hx; rewrite spec_reduce_2. - assert (F1:= spec_more_than_1_digit w2_spec). - generalize (spec_head0 w2_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w2_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros x Hx; rewrite spec_reduce_3. - assert (F1:= spec_more_than_1_digit w3_spec). - generalize (spec_head0 w3_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w3_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros x Hx; rewrite spec_reduce_4. - assert (F1:= spec_more_than_1_digit w4_spec). - generalize (spec_head0 w4_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w4_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros x Hx; rewrite spec_reduce_5. - assert (F1:= spec_more_than_1_digit w5_spec). - generalize (spec_head0 w5_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w5_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros x Hx; rewrite spec_reduce_6. - assert (F1:= spec_more_than_1_digit w6_spec). - generalize (spec_head0 w6_spec x Hx). - unfold base. - pattern (Zpos (znz_digits w6_op)) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - intros n x Hx; rewrite spec_reduce_n. - assert (F1:= spec_more_than_1_digit (wn_spec n)). - generalize (spec_head0 (wn_spec n) x Hx). - unfold base. - pattern (Zpos (znz_digits (make_op n))) at 1; - rewrite <- (fun x => (F0 (Zpos x))). - rewrite Zpower_exp; auto with zarith. - rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith. - Qed. - - Definition tail0 w := match w with - | N0 w=> reduce_0 (w0_op.(znz_tail0) w) - | N1 w=> reduce_1 (w1_op.(znz_tail0) w) - | N2 w=> reduce_2 (w2_op.(znz_tail0) w) - | N3 w=> reduce_3 (w3_op.(znz_tail0) w) - | N4 w=> reduce_4 (w4_op.(znz_tail0) w) - | N5 w=> reduce_5 (w5_op.(znz_tail0) w) - | N6 w=> reduce_6 (w6_op.(znz_tail0) w) - | Nn n w=> reduce_n n ((make_op n).(znz_tail0) w) - end. - - Theorem spec_tail00: forall x, [x] = 0 ->[tail0 x] = Zpos (digits x). - Proof. - intros x; case x; unfold tail0; clear x. - intros x; rewrite spec_reduce_0; exact (spec_tail00 w0_spec x). - intros x; rewrite spec_reduce_1; exact (spec_tail00 w1_spec x). - intros x; rewrite spec_reduce_2; exact (spec_tail00 w2_spec x). - intros x; rewrite spec_reduce_3; exact (spec_tail00 w3_spec x). - intros x; rewrite spec_reduce_4; exact (spec_tail00 w4_spec x). - intros x; rewrite spec_reduce_5; exact (spec_tail00 w5_spec x). - intros x; rewrite spec_reduce_6; exact (spec_tail00 w6_spec x). - intros n x; rewrite spec_reduce_n; exact (spec_tail00 (wn_spec n) x). - Qed. - - Theorem spec_tail0: forall x, - 0 < [x] -> exists y, 0 <= y /\ [x] = (2 * y + 1) * 2 ^ [tail0 x]. - Proof. - intros x; case x; clear x; unfold tail0. - intros x Hx; rewrite spec_reduce_0; exact (spec_tail0 w0_spec x Hx). - intros x Hx; rewrite spec_reduce_1; exact (spec_tail0 w1_spec x Hx). - intros x Hx; rewrite spec_reduce_2; exact (spec_tail0 w2_spec x Hx). - intros x Hx; rewrite spec_reduce_3; exact (spec_tail0 w3_spec x Hx). - intros x Hx; rewrite spec_reduce_4; exact (spec_tail0 w4_spec x Hx). - intros x Hx; rewrite spec_reduce_5; exact (spec_tail0 w5_spec x Hx). - intros x Hx; rewrite spec_reduce_6; exact (spec_tail0 w6_spec x Hx). - intros n x Hx; rewrite spec_reduce_n; exact (spec_tail0 (wn_spec n) x Hx). - Qed. - - Definition Ndigits x := - match x with - | N0 _ => N0 w0_op.(znz_zdigits) - | N1 _ => reduce_1 w1_op.(znz_zdigits) - | N2 _ => reduce_2 w2_op.(znz_zdigits) - | N3 _ => reduce_3 w3_op.(znz_zdigits) - | N4 _ => reduce_4 w4_op.(znz_zdigits) - | N5 _ => reduce_5 w5_op.(znz_zdigits) - | N6 _ => reduce_6 w6_op.(znz_zdigits) - | Nn n _ => reduce_n n (make_op n).(znz_zdigits) - end. - - Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x). - Proof. - intros x; case x; clear x; unfold Ndigits, digits. - intros _; try rewrite spec_reduce_0; exact (spec_zdigits w0_spec). - intros _; try rewrite spec_reduce_1; exact (spec_zdigits w1_spec). - intros _; try rewrite spec_reduce_2; exact (spec_zdigits w2_spec). - intros _; try rewrite spec_reduce_3; exact (spec_zdigits w3_spec). - intros _; try rewrite spec_reduce_4; exact (spec_zdigits w4_spec). - intros _; try rewrite spec_reduce_5; exact (spec_zdigits w5_spec). - intros _; try rewrite spec_reduce_6; exact (spec_zdigits w6_spec). - intros n _; try rewrite spec_reduce_n; exact (spec_zdigits (wn_spec n)). - Qed. - - Definition shiftr0 n x := w0_op.(znz_add_mul_div) (w0_op.(znz_sub) w0_op.(znz_zdigits) n) w0_op.(znz_0) x. - Definition shiftr1 n x := w1_op.(znz_add_mul_div) (w1_op.(znz_sub) w1_op.(znz_zdigits) n) w1_op.(znz_0) x. - Definition shiftr2 n x := w2_op.(znz_add_mul_div) (w2_op.(znz_sub) w2_op.(znz_zdigits) n) w2_op.(znz_0) x. - Definition shiftr3 n x := w3_op.(znz_add_mul_div) (w3_op.(znz_sub) w3_op.(znz_zdigits) n) w3_op.(znz_0) x. - Definition shiftr4 n x := w4_op.(znz_add_mul_div) (w4_op.(znz_sub) w4_op.(znz_zdigits) n) w4_op.(znz_0) x. - Definition shiftr5 n x := w5_op.(znz_add_mul_div) (w5_op.(znz_sub) w5_op.(znz_zdigits) n) w5_op.(znz_0) x. - Definition shiftr6 n x := w6_op.(znz_add_mul_div) (w6_op.(znz_sub) w6_op.(znz_zdigits) n) w6_op.(znz_0) x. - Definition shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x. - - Definition shiftr := Eval lazy beta delta [same_level] in - same_level _ (fun n x => N0 (shiftr0 n x)) - (fun n x => reduce_1 (shiftr1 n x)) - (fun n x => reduce_2 (shiftr2 n x)) - (fun n x => reduce_3 (shiftr3 n x)) - (fun n x => reduce_4 (shiftr4 n x)) - (fun n x => reduce_5 (shiftr5 n x)) - (fun n x => reduce_6 (shiftr6 n x)) - (fun n p x => reduce_n n (shiftrn n p x)). - - Theorem spec_shiftr: forall n x, - [n] <= [Ndigits x] -> [shiftr n x] = [x] / 2 ^ [n]. - Proof. - assert (F0: forall x y, x - (x - y) = y). - intros; ring. - assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z). - intros x y z HH HH1 HH2. - split; auto with zarith. - apply Zle_lt_trans with (2 := HH2); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith. - apply Zmult_le_compat_l; auto. - apply Zpower_le_monotone; auto with zarith. - rewrite Zpower_0_r; ring. - assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x). - intros xx y HH HH1. - split; auto with zarith. - apply Zle_lt_trans with xx; auto with zarith. - apply Zpower2_lt_lin; auto with zarith. - assert (F4: forall ww ww1 ww2 - (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2) - xx yy xx1 yy1, - znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_zdigits ww1_op) -> - znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) -> - znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op -> - znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx -> - znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy -> - znz_to_Z ww_op - (znz_add_mul_div ww_op (znz_sub ww_op (znz_zdigits ww_op) yy1) - (znz_0 ww_op) xx1) = znz_to_Z ww1_op xx / 2 ^ znz_to_Z ww2_op yy). - intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy. - case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2. - case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4. - rewrite <- Hx. - rewrite <- Hy. - generalize (spec_add_mul_div Hw - (znz_0 ww_op) xx1 - (znz_sub ww_op (znz_zdigits ww_op) - yy1) - ). - rewrite (spec_0 Hw). - rewrite Zmult_0_l; rewrite Zplus_0_l. - rewrite (ZnZ.spec_sub Hw). - rewrite Zmod_small; auto with zarith. - rewrite (spec_zdigits Hw). - rewrite F0. - rewrite Zmod_small; auto with zarith. - unfold base; rewrite (spec_zdigits Hw) in Hl1 |- *; - auto with zarith. - assert (F5: forall n m, (n <= m)%nat -> - Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m))). - intros n m HH; elim HH; clear m HH; auto with zarith. - intros m HH Hrec; apply Zle_trans with (1 := Hrec). - rewrite make_op_S. - match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end. - rewrite Zpos_xO. - assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith. - assert (F6: forall n, Zpos (znz_digits w6_op) <= Zpos (znz_digits (make_op n))). - intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0))). - change (znz_digits (make_op 0)) with (xO (znz_digits w6_op)). - rewrite Zpos_xO. - assert (0 <= Zpos (znz_digits w6_op)); auto with zarith. - apply F5; auto with arith. - intros x; case x; clear x; unfold shiftr, same_level. - intros x y; case y; clear y. - intros y; unfold shiftr0, Ndigits. - repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w0_spec)(4:=w0_spec)(5:=w0_spec); auto with zarith. - intros y; unfold shiftr1, Ndigits. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w1_spec)(4:=w1_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n1 x)). - intros y; unfold shiftr2, Ndigits. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w2_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n2 x)). - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n3 x)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n4 x)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n5 x)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n6 x)). - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w0_spec); auto with zarith. - change ([Nn m (extend6 m (extend0 5 x))] = [N0 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend0n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftr1, Ndigits. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w1_spec)(4:=w0_spec)(5:=w1_spec); auto with zarith. - rewrite (spec_zdigits w1_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w1_op) with (xO (znz_digits w0_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n1 y)). - intros y; unfold shiftr1, Ndigits. - repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w1_spec)(4:=w1_spec)(5:=w1_spec); auto with zarith. - intros y; unfold shiftr2, Ndigits. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w2_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n2 x)). - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n3 x)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n4 x)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n5 x)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n6 x)). - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w1_spec); auto with zarith. - change ([Nn m (extend6 m (extend1 4 x))] = [N1 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend1n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftr2, Ndigits. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w0_spec)(5:=w2_spec); auto with zarith. - rewrite (spec_zdigits w2_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w2_op) with (xO (xO (znz_digits w0_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n2 y)). - intros y; unfold shiftr2, Ndigits. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w1_spec)(5:=w2_spec); auto with zarith. - rewrite (spec_zdigits w2_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w2_op) with (xO (znz_digits w1_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n2 y)). - intros y; unfold shiftr2, Ndigits. - repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w2_spec)(5:=w2_spec); auto with zarith. - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n3 x)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n4 x)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n5 x)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n6 x)). - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w2_spec); auto with zarith. - change ([Nn m (extend6 m (extend2 3 x))] = [N2 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend2n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w0_spec)(5:=w3_spec); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w3_op) with (xO (xO (xO (znz_digits w0_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n3 y)). - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w1_spec)(5:=w3_spec); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w3_op) with (xO (xO (znz_digits w1_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n3 y)). - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w2_spec)(5:=w3_spec); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w3_op) with (xO (znz_digits w2_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n3 y)). - intros y; unfold shiftr3, Ndigits. - repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w3_spec); auto with zarith. - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w3_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend3n4 x)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w3_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend3n5 x)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w3_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend3n6 x)). - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w3_spec); auto with zarith. - change ([Nn m (extend6 m (extend3 2 x))] = [N3 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend3n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w0_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w4_op) with (xO (xO (xO (xO (znz_digits w0_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n4 y)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w1_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w4_op) with (xO (xO (xO (znz_digits w1_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n4 y)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w2_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w4_op) with (xO (xO (znz_digits w2_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n4 y)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w3_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w3_spec). - change (znz_digits w4_op) with (xO (znz_digits w3_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w3_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend3n4 y)). - intros y; unfold shiftr4, Ndigits. - repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w4_spec); auto with zarith. - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w4_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend4n5 x)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w4_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend4n6 x)). - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w4_spec); auto with zarith. - change ([Nn m (extend6 m (extend4 1 x))] = [N4 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend4n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w0_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w5_op) with (xO (xO (xO (xO (xO (znz_digits w0_op)))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n5 y)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w1_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w5_op) with (xO (xO (xO (xO (znz_digits w1_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n5 y)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w2_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w5_op) with (xO (xO (xO (znz_digits w2_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n5 y)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w3_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w3_spec). - change (znz_digits w5_op) with (xO (xO (znz_digits w3_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w3_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend3n5 y)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w4_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w4_spec). - change (znz_digits w5_op) with (xO (znz_digits w4_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w4_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend4n5 y)). - intros y; unfold shiftr5, Ndigits. - repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w5_spec); auto with zarith. - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w5_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend5n6 x)). - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w5_spec); auto with zarith. - change ([Nn m (extend6 m (extend5 0 x))] = [N5 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend5n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w0_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO (xO (znz_digits w0_op))))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n6 y)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w1_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO (znz_digits w1_op)))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n6 y)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w2_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w6_op) with (xO (xO (xO (xO (znz_digits w2_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n6 y)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w3_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w3_spec). - change (znz_digits w6_op) with (xO (xO (xO (znz_digits w3_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w3_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend3n6 y)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w4_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w4_spec). - change (znz_digits w6_op) with (xO (xO (znz_digits w4_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w4_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend4n6 y)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w5_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w5_spec). - change (znz_digits w6_op) with (xO (znz_digits w5_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w5_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend5n6 y)). - intros y; unfold shiftr6, Ndigits. - repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w6_spec); auto with zarith. - intros m y; unfold shiftrn, Ndigits. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w6_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend6n m x)). - intros n x y; case y; clear y; - intros y; unfold shiftrn, Ndigits; try rewrite spec_reduce_n. - try rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w0_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w0_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO (xO(znz_digits w0_op))))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w0_op)); auto with zarith. - change ([Nn n (extend6 n (extend0 5 y))] = [N0 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend0n6; auto). - try rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w1_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w1_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO(znz_digits w1_op)))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w1_op)); auto with zarith. - change ([Nn n (extend6 n (extend1 4 y))] = [N1 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend1n6; auto). - try rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w2_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w2_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO (xO(znz_digits w2_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w2_op)); auto with zarith. - change ([Nn n (extend6 n (extend2 3 y))] = [N2 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend2n6; auto). - try rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w3_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO(znz_digits w3_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w3_op)); auto with zarith. - change ([Nn n (extend6 n (extend3 2 y))] = [N3 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend3n6; auto). - try rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w4_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO(znz_digits w4_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w4_op)); auto with zarith. - change ([Nn n (extend6 n (extend4 1 y))] = [N4 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend4n6; auto). - try rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w5_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO(znz_digits w5_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w5_op)); auto with zarith. - change ([Nn n (extend6 n (extend5 0 y))] = [N5 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend5n6; auto). - try rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w6_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (znz_digits w6_op). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w6_op)); auto with zarith. - change ([Nn n (extend6 n y)] = [N6 y]). - rewrite <- (spec_extend6n n); auto. - generalize y; clear y; intros m y. - rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits (wn_spec m)). - rewrite (spec_zdigits (wn_spec (Max.max n m))). - apply F5; auto with arith. - exact (spec_cast_r n m y). - exact (spec_cast_l n m x). - Qed. - - Definition safe_shiftr n x := - match compare n (Ndigits x) with - | Lt => shiftr n x - | _ => N0 w_0 - end. - - Theorem spec_safe_shiftr: forall n x, - [safe_shiftr n x] = [x] / 2 ^ [n]. - Proof. - intros n x; unfold safe_shiftr; - generalize (spec_compare n (Ndigits x)); case compare; intros H. - apply trans_equal with (1 := spec_0 w0_spec). - apply sym_equal; apply Zdiv_small; rewrite H. - rewrite spec_Ndigits; exact (spec_digits x). - rewrite <- spec_shiftr; auto with zarith. - apply trans_equal with (1 := spec_0 w0_spec). - apply sym_equal; apply Zdiv_small. - rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2. - split; auto. - apply Zlt_le_trans with (1 := H2). - apply Zpower_le_monotone; auto with zarith. - Qed. - - - Definition shiftl0 n x := w0_op.(znz_add_mul_div) n x w0_op.(znz_0). - Definition shiftl1 n x := w1_op.(znz_add_mul_div) n x w1_op.(znz_0). - Definition shiftl2 n x := w2_op.(znz_add_mul_div) n x w2_op.(znz_0). - Definition shiftl3 n x := w3_op.(znz_add_mul_div) n x w3_op.(znz_0). - Definition shiftl4 n x := w4_op.(znz_add_mul_div) n x w4_op.(znz_0). - Definition shiftl5 n x := w5_op.(znz_add_mul_div) n x w5_op.(znz_0). - Definition shiftl6 n x := w6_op.(znz_add_mul_div) n x w6_op.(znz_0). - Definition shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0). - Definition shiftl := Eval lazy beta delta [same_level] in - same_level _ (fun n x => N0 (shiftl0 n x)) - (fun n x => reduce_1 (shiftl1 n x)) - (fun n x => reduce_2 (shiftl2 n x)) - (fun n x => reduce_3 (shiftl3 n x)) - (fun n x => reduce_4 (shiftl4 n x)) - (fun n x => reduce_5 (shiftl5 n x)) - (fun n x => reduce_6 (shiftl6 n x)) - (fun n p x => reduce_n n (shiftln n p x)). - - - Theorem spec_shiftl: forall n x, - [n] <= [head0 x] -> [shiftl n x] = [x] * 2 ^ [n]. - Proof. - assert (F0: forall x y, x - (x - y) = y). - intros; ring. - assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z). - intros x y z HH HH1 HH2. - split; auto with zarith. - apply Zle_lt_trans with (2 := HH2); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith. - apply Zmult_le_compat_l; auto. - apply Zpower_le_monotone; auto with zarith. - rewrite Zpower_0_r; ring. - assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x). - intros xx y HH HH1. - split; auto with zarith. - apply Zle_lt_trans with xx; auto with zarith. - apply Zpower2_lt_lin; auto with zarith. - assert (F4: forall ww ww1 ww2 - (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2) - xx yy xx1 yy1, - znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_head0 ww1_op xx) -> - znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) -> - znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op -> - znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx -> - znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy -> - znz_to_Z ww_op - (znz_add_mul_div ww_op yy1 - xx1 (znz_0 ww_op)) = znz_to_Z ww1_op xx * 2 ^ znz_to_Z ww2_op yy). - intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy. - case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2. - case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4. - rewrite <- Hx. - rewrite <- Hy. - generalize (spec_add_mul_div Hw xx1 (znz_0 ww_op) yy1). - rewrite (spec_0 Hw). - assert (F1: znz_to_Z ww1_op (znz_head0 ww1_op xx) <= Zpos (znz_digits ww1_op)). - case (Zle_lt_or_eq _ _ HH1); intros HH5. - apply Zlt_le_weak. - case (ZnZ.spec_head0 Hw1 xx). - rewrite <- Hx; auto. - intros _ Hu; unfold base in Hu. - case (Zle_or_lt (Zpos (znz_digits ww1_op)) - (znz_to_Z ww1_op (znz_head0 ww1_op xx))); auto; intros H1. - absurd (2 ^ (Zpos (znz_digits ww1_op)) <= 2 ^ (znz_to_Z ww1_op (znz_head0 ww1_op xx))). - apply Zlt_not_le. - case (spec_to_Z Hw1 xx); intros HHx3 HHx4. - rewrite <- (Zmult_1_r (2 ^ znz_to_Z ww1_op (znz_head0 ww1_op xx))). - apply Zle_lt_trans with (2 := Hu). - apply Zmult_le_compat_l; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite (ZnZ.spec_head00 Hw1 xx); auto with zarith. - rewrite Zdiv_0_l; auto with zarith. - rewrite Zplus_0_r. - case (Zle_lt_or_eq _ _ HH1); intros HH5. - rewrite Zmod_small; auto with zarith. - intros HH; apply HH. - rewrite Hy; apply Zle_trans with (1:= Hl). - rewrite <- (spec_zdigits Hw). - apply Zle_trans with (2 := Hl1); auto. - rewrite (spec_zdigits Hw1); auto with zarith. - split; auto with zarith . - apply Zlt_le_trans with (base (znz_digits ww1_op)). - rewrite Hx. - case (ZnZ.spec_head0 Hw1 xx); auto. - rewrite <- Hx; auto. - intros _ Hu; rewrite Zmult_comm in Hu. - apply Zle_lt_trans with (2 := Hu). - apply Zmult_le_compat_l; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - unfold base; apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - rewrite <- (spec_zdigits Hw); auto with zarith. - rewrite <- (spec_zdigits Hw1); auto with zarith. - rewrite <- HH5. - rewrite Zmult_0_l. - rewrite Zmod_small; auto with zarith. - intros HH; apply HH. - rewrite Hy; apply Zle_trans with (1 := Hl). - rewrite (ZnZ.spec_head00 Hw1 xx); auto with zarith. - rewrite <- (spec_zdigits Hw); auto with zarith. - rewrite <- (spec_zdigits Hw1); auto with zarith. - assert (F5: forall n m, (n <= m)%nat -> - Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m))). - intros n m HH; elim HH; clear m HH; auto with zarith. - intros m HH Hrec; apply Zle_trans with (1 := Hrec). - rewrite make_op_S. - match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end. - rewrite Zpos_xO. - assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith. - assert (F6: forall n, Zpos (znz_digits w6_op) <= Zpos (znz_digits (make_op n))). - intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0))). - change (znz_digits (make_op 0)) with (xO (znz_digits w6_op)). - rewrite Zpos_xO. - assert (0 <= Zpos (znz_digits w6_op)); auto with zarith. - apply F5; auto with arith. - intros x; case x; clear x; unfold shiftl, same_level. - intros x y; case y; clear y. - intros y; unfold shiftl0, head0. - repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w0_spec)(4:=w0_spec)(5:=w0_spec); auto with zarith. - intros y; unfold shiftl1, head0. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w1_spec)(4:=w1_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n1 x)). - intros y; unfold shiftl2, head0. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w2_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n2 x)). - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n3 x)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n4 x)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n5 x)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_0; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w0_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend0n6 x)). - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w0_spec); auto with zarith. - change ([Nn m (extend6 m (extend0 5 x))] = [N0 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend0n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftl1, head0. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w1_spec)(4:=w0_spec)(5:=w1_spec); auto with zarith. - rewrite (spec_zdigits w1_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w1_op) with (xO (znz_digits w0_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n1 y)). - intros y; unfold shiftl1, head0. - repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w1_spec)(4:=w1_spec)(5:=w1_spec); auto with zarith. - intros y; unfold shiftl2, head0. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w2_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n2 x)). - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n3 x)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n4 x)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n5 x)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_1; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w1_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend1n6 x)). - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w1_spec); auto with zarith. - change ([Nn m (extend6 m (extend1 4 x))] = [N1 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend1n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftl2, head0. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w0_spec)(5:=w2_spec); auto with zarith. - rewrite (spec_zdigits w2_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w2_op) with (xO (xO (znz_digits w0_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n2 y)). - intros y; unfold shiftl2, head0. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w1_spec)(5:=w2_spec); auto with zarith. - rewrite (spec_zdigits w2_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w2_op) with (xO (znz_digits w1_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n2 y)). - intros y; unfold shiftl2, head0. - repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w2_spec)(4:=w2_spec)(5:=w2_spec); auto with zarith. - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n3 x)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n4 x)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n5 x)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_2; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w2_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend2n6 x)). - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w2_spec); auto with zarith. - change ([Nn m (extend6 m (extend2 3 x))] = [N2 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend2n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w0_spec)(5:=w3_spec); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w3_op) with (xO (xO (xO (znz_digits w0_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n3 y)). - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w1_spec)(5:=w3_spec); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w3_op) with (xO (xO (znz_digits w1_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n3 y)). - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w2_spec)(5:=w3_spec); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w3_op) with (xO (znz_digits w2_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n3 y)). - intros y; unfold shiftl3, head0. - repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w3_spec)(4:=w3_spec)(5:=w3_spec); auto with zarith. - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w3_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend3n4 x)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w3_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend3n5 x)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_3; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w3_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend3n6 x)). - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w3_spec); auto with zarith. - change ([Nn m (extend6 m (extend3 2 x))] = [N3 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend3n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w0_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w4_op) with (xO (xO (xO (xO (znz_digits w0_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n4 y)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w1_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w4_op) with (xO (xO (xO (znz_digits w1_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n4 y)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w2_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w4_op) with (xO (xO (znz_digits w2_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n4 y)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w3_spec)(5:=w4_spec); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits w3_spec). - change (znz_digits w4_op) with (xO (znz_digits w3_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w3_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend3n4 y)). - intros y; unfold shiftl4, head0. - repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w4_spec)(4:=w4_spec)(5:=w4_spec); auto with zarith. - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w4_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend4n5 x)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_4; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w4_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend4n6 x)). - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w4_spec); auto with zarith. - change ([Nn m (extend6 m (extend4 1 x))] = [N4 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend4n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w0_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w5_op) with (xO (xO (xO (xO (xO (znz_digits w0_op)))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n5 y)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w1_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w5_op) with (xO (xO (xO (xO (znz_digits w1_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n5 y)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w2_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w5_op) with (xO (xO (xO (znz_digits w2_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n5 y)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w3_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w3_spec). - change (znz_digits w5_op) with (xO (xO (znz_digits w3_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w3_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend3n5 y)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w4_spec)(5:=w5_spec); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits w4_spec). - change (znz_digits w5_op) with (xO (znz_digits w4_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w4_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend4n5 y)). - intros y; unfold shiftl5, head0. - repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w5_spec)(4:=w5_spec)(5:=w5_spec); auto with zarith. - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_5; repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w5_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend5n6 x)). - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w5_spec); auto with zarith. - change ([Nn m (extend6 m (extend5 0 x))] = [N5 x]). - rewrite <- (spec_extend6n m); rewrite <- spec_extend5n6; auto. - intros x y; case y; clear y. - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w0_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w0_spec). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO (xO (znz_digits w0_op))))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w0_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend0n6 y)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w1_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w1_spec). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO (znz_digits w1_op)))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w1_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend1n6 y)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w2_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w2_spec). - change (znz_digits w6_op) with (xO (xO (xO (xO (znz_digits w2_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w2_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend2n6 y)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w3_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w3_spec). - change (znz_digits w6_op) with (xO (xO (xO (znz_digits w3_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w3_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend3n6 y)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w4_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w4_spec). - change (znz_digits w6_op) with (xO (xO (znz_digits w4_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w4_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend4n6 y)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; repeat rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w5_spec)(5:=w6_spec); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits w5_spec). - change (znz_digits w6_op) with (xO (znz_digits w5_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (0 <= Zpos (znz_digits w5_op)); auto with zarith. - try (apply sym_equal; exact (spec_extend5n6 y)). - intros y; unfold shiftl6, head0. - repeat rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=w6_spec)(4:=w6_spec)(5:=w6_spec); auto with zarith. - intros m y; unfold shiftln, head0. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w6_spec); auto with zarith. - try (apply sym_equal; exact (spec_extend6n m x)). - intros n x y; case y; clear y; - intros y; unfold shiftln, head0; try rewrite spec_reduce_n. - try rewrite spec_reduce_0; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w0_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w0_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO (xO(znz_digits w0_op))))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w0_op)); auto with zarith. - change ([Nn n (extend6 n (extend0 5 y))] = [N0 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend0n6; auto). - try rewrite spec_reduce_1; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w1_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w1_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO (xO (xO(znz_digits w1_op)))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w1_op)); auto with zarith. - change ([Nn n (extend6 n (extend1 4 y))] = [N1 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend1n6; auto). - try rewrite spec_reduce_2; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w2_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w2_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO (xO(znz_digits w2_op))))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w2_op)); auto with zarith. - change ([Nn n (extend6 n (extend2 3 y))] = [N2 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend2n6; auto). - try rewrite spec_reduce_3; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w3_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w3_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO (xO(znz_digits w3_op)))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w3_op)); auto with zarith. - change ([Nn n (extend6 n (extend3 2 y))] = [N3 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend3n6; auto). - try rewrite spec_reduce_4; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w4_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w4_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO (xO(znz_digits w4_op))). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w4_op)); auto with zarith. - change ([Nn n (extend6 n (extend4 1 y))] = [N4 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend4n6; auto). - try rewrite spec_reduce_5; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w5_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w5_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (xO(znz_digits w5_op)). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w5_op)); auto with zarith. - change ([Nn n (extend6 n (extend5 0 y))] = [N5 y]). - rewrite <- (spec_extend6n n); auto. - try (rewrite <- spec_extend5n6; auto). - try rewrite spec_reduce_6; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec n))(4:=w6_spec)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits w6_spec). - rewrite (spec_zdigits (wn_spec n)). - apply Zle_trans with (2 := F6 n). - change (znz_digits w6_op) with (znz_digits w6_op). - repeat rewrite (fun x => Zpos_xO (xO x)). - repeat rewrite (fun x y => Zpos_xO (@znz_digits x y)). - assert (H: 0 <= Zpos (znz_digits w6_op)); auto with zarith. - change ([Nn n (extend6 n y)] = [N6 y]). - rewrite <- (spec_extend6n n); auto. - generalize y; clear y; intros m y. - repeat rewrite spec_reduce_n; unfold to_Z; intros H1. - apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith. - rewrite (spec_zdigits (wn_spec m)). - rewrite (spec_zdigits (wn_spec (Max.max n m))). - apply F5; auto with arith. - exact (spec_cast_r n m y). - exact (spec_cast_l n m x). - Qed. - - Definition double_size w := match w with - | N0 x => N1 (WW (znz_0 w0_op) x) - | N1 x => N2 (WW (znz_0 w1_op) x) - | N2 x => N3 (WW (znz_0 w2_op) x) - | N3 x => N4 (WW (znz_0 w3_op) x) - | N4 x => N5 (WW (znz_0 w4_op) x) - | N5 x => N6 (WW (znz_0 w5_op) x) - | N6 x => Nn 0 (WW (znz_0 w6_op) x) - | Nn n x => Nn (S n) (WW (znz_0 (make_op n)) x) - end. - - Theorem spec_double_size_digits: - forall x, digits (double_size x) = xO (digits x). - Proof. - intros x; case x; unfold double_size, digits; clear x; auto. - intros n x; rewrite make_op_S; auto. - Qed. - - Theorem spec_double_size: forall x, [double_size x] = [x]. - Proof. - intros x; case x; unfold double_size; clear x. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_1; rewrite (spec_0 w0_spec); auto with zarith. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_2; rewrite (spec_0 w1_spec); auto with zarith. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_3; rewrite (spec_0 w2_spec); auto with zarith. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_4; rewrite (spec_0 w3_spec); auto with zarith. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_5; rewrite (spec_0 w4_spec); auto with zarith. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_6; rewrite (spec_0 w5_spec); auto with zarith. - intros x; unfold to_Z, make_op; - rewrite znz_to_Z_7; rewrite (spec_0 w6_spec); auto with zarith. - intros n x; unfold to_Z; - generalize (znz_to_Z_n n); simpl word. - intros HH; rewrite HH; clear HH. - generalize (spec_0 (wn_spec n)); simpl word. - intros HH; rewrite HH; clear HH; auto with zarith. - Qed. - - Theorem spec_double_size_head0: - forall x, 2 * [head0 x] <= [head0 (double_size x)]. - Proof. - intros x. - assert (F1:= spec_pos (head0 x)). - assert (F2: 0 < Zpos (digits x)). - red; auto. - case (Zle_lt_or_eq _ _ (spec_pos x)); intros HH. - generalize HH; rewrite <- (spec_double_size x); intros HH1. - case (spec_head0 x HH); intros _ HH2. - case (spec_head0 _ HH1). - rewrite (spec_double_size x); rewrite (spec_double_size_digits x). - intros HH3 _. - case (Zle_or_lt ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4. - absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto. - apply Zle_not_lt. - apply Zmult_le_compat_r; auto with zarith. - apply Zpower_le_monotone; auto; auto with zarith. - generalize (spec_pos (head0 (double_size x))); auto with zarith. - assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)). - case (Zle_lt_or_eq 1 [x]); auto with zarith; intros HH5. - apply Zmult_le_reg_r with (2 ^ 1); auto with zarith. - rewrite <- (fun x y z => Zpower_exp x (y - z)); auto with zarith. - assert (tmp: forall x, x - 1 + 1 = x); [intros; ring | rewrite tmp; clear tmp]. - apply Zle_trans with (2 := Zlt_le_weak _ _ HH2). - apply Zmult_le_compat_l; auto with zarith. - rewrite Zpower_1_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6. - absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith. - rewrite <- HH5; rewrite Zmult_1_r. - apply Zpower_le_monotone; auto with zarith. - rewrite (Zmult_comm 2). - rewrite Zpower_mult; auto with zarith. - rewrite Zpower_2. - apply Zlt_le_trans with (2 := HH3). - rewrite <- Zmult_assoc. - replace (Zpos (xO (digits x)) - 1) with - ((Zpos (digits x) - 1) + (Zpos (digits x))). - rewrite Zpower_exp; auto with zarith. - apply Zmult_lt_compat2; auto with zarith. - split; auto with zarith. - apply Zmult_lt_0_compat; auto with zarith. - rewrite Zpos_xO; ring. - apply Zlt_le_weak; auto. - repeat rewrite spec_head00; auto. - rewrite spec_double_size_digits. - rewrite Zpos_xO; auto with zarith. - rewrite spec_double_size; auto. - Qed. - - Theorem spec_double_size_head0_pos: - forall x, 0 < [head0 (double_size x)]. - Proof. - intros x. - assert (F: 0 < Zpos (digits x)). - red; auto. - case (Zle_lt_or_eq _ _ (spec_pos (head0 (double_size x)))); auto; intros F0. - case (Zle_lt_or_eq _ _ (spec_pos (head0 x))); intros F1. - apply Zlt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith. - case (Zle_lt_or_eq _ _ (spec_pos x)); intros F3. - generalize F3; rewrite <- (spec_double_size x); intros F4. - absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))). - apply Zle_not_lt. - apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - rewrite Zpos_xO; auto with zarith. - case (spec_head0 x F3). - rewrite <- F1; rewrite Zpower_0_r; rewrite Zmult_1_l; intros _ HH. - apply Zle_lt_trans with (2 := HH). - case (spec_head0 _ F4). - rewrite (spec_double_size x); rewrite (spec_double_size_digits x). - rewrite <- F0; rewrite Zpower_0_r; rewrite Zmult_1_l; auto. - generalize F1; rewrite (spec_head00 _ (sym_equal F3)); auto with zarith. - Qed. - - Definition safe_shiftl_aux_body cont n x := - match compare n (head0 x) with - Gt => cont n (double_size x) - | _ => shiftl n x - end. - - Theorem spec_safe_shift_aux_body: forall n p x cont, - 2^ Zpos p <= [head0 x] -> - (forall x, 2 ^ (Zpos p + 1) <= [head0 x]-> - [cont n x] = [x] * 2 ^ [n]) -> - [safe_shiftl_aux_body cont n x] = [x] * 2 ^ [n]. - Proof. - intros n p x cont H1 H2; unfold safe_shiftl_aux_body. - generalize (spec_compare n (head0 x)); case compare; intros H. - apply spec_shiftl; auto with zarith. - apply spec_shiftl; auto with zarith. - rewrite H2. - rewrite spec_double_size; auto. - rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith. - apply Zle_trans with (2 := spec_double_size_head0 x). - rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith. - Qed. - - Fixpoint safe_shiftl_aux p cont n x {struct p} := - safe_shiftl_aux_body - (fun n x => match p with - | xH => cont n x - | xO p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x - | xI p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x - end) n x. - - Theorem spec_safe_shift_aux: forall p q n x cont, - 2 ^ (Zpos q) <= [head0 x] -> - (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] -> - [cont n x] = [x] * 2 ^ [n]) -> - [safe_shiftl_aux p cont n x] = [x] * 2 ^ [n]. - Proof. - intros p; elim p; unfold safe_shiftl_aux; fold safe_shiftl_aux; clear p. - intros p Hrec q n x cont H1 H2. - apply spec_safe_shift_aux_body with (q); auto. - intros x1 H3; apply Hrec with (q + 1)%positive; auto. - intros x2 H4; apply Hrec with (p + q + 1)%positive; auto. - rewrite <- Pplus_assoc. - rewrite Zpos_plus_distr; auto. - intros x3 H5; apply H2. - rewrite Zpos_xI. - replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1)); - auto. - repeat rewrite Zpos_plus_distr; ring. - intros p Hrec q n x cont H1 H2. - apply spec_safe_shift_aux_body with (q); auto. - intros x1 H3; apply Hrec with (q); auto. - apply Zle_trans with (2 := H3); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - intros x2 H4; apply Hrec with (p + q)%positive; auto. - intros x3 H5; apply H2. - rewrite (Zpos_xO p). - replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q)); - auto. - repeat rewrite Zpos_plus_distr; ring. - intros q n x cont H1 H2. - apply spec_safe_shift_aux_body with (q); auto. - rewrite Zplus_comm; auto. - Qed. - - Definition safe_shiftl n x := - safe_shiftl_aux_body - (safe_shiftl_aux_body - (safe_shiftl_aux (digits n) shiftl)) n x. - - Theorem spec_safe_shift: forall n x, - [safe_shiftl n x] = [x] * 2 ^ [n]. - Proof. - intros n x; unfold safe_shiftl, safe_shiftl_aux_body. - generalize (spec_compare n (head0 x)); case compare; intros H. - apply spec_shiftl; auto with zarith. - apply spec_shiftl; auto with zarith. - rewrite <- (spec_double_size x). - generalize (spec_compare n (head0 (double_size x))); case compare; intros H1. - apply spec_shiftl; auto with zarith. - apply spec_shiftl; auto with zarith. - rewrite <- (spec_double_size (double_size x)). - apply spec_safe_shift_aux with 1%positive. - apply Zle_trans with (2 := spec_double_size_head0 (double_size x)). - replace (2 ^ 1) with (2 * 1). - apply Zmult_le_compat_l; auto with zarith. - generalize (spec_double_size_head0_pos x); auto with zarith. - rewrite Zpower_1_r; ring. - intros x1 H2; apply spec_shiftl. - apply Zle_trans with (2 := H2). - apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith. - case (spec_digits n); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - Qed. - - Definition is_even x := - match x with - | N0 wx => w0_op.(znz_is_even) wx - | N1 wx => w1_op.(znz_is_even) wx - | N2 wx => w2_op.(znz_is_even) wx - | N3 wx => w3_op.(znz_is_even) wx - | N4 wx => w4_op.(znz_is_even) wx - | N5 wx => w5_op.(znz_is_even) wx - | N6 wx => w6_op.(znz_is_even) wx - | Nn n wx => (make_op n).(znz_is_even) wx - end. - - Theorem spec_is_even: forall x, - if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1. - Proof. - intros x; case x; unfold is_even, to_Z; clear x. - intros x; exact (spec_is_even w0_spec x). - intros x; exact (spec_is_even w1_spec x). - intros x; exact (spec_is_even w2_spec x). - intros x; exact (spec_is_even w3_spec x). - intros x; exact (spec_is_even w4_spec x). - intros x; exact (spec_is_even w5_spec x). - intros x; exact (spec_is_even w6_spec x). - intros n x; exact (spec_is_even (wn_spec n) x). - Qed. - - Theorem spec_0: [zero] = 0. - Proof. - exact (spec_0 w0_spec). - Qed. - - Theorem spec_1: [one] = 1. - Proof. - exact (spec_1 w0_spec). - Qed. - -End Make. diff --git a/theories/Ints/num/Nbasic.v b/theories/Ints/num/Nbasic.v deleted file mode 100644 index 1398e8f559..0000000000 --- a/theories/Ints/num/Nbasic.v +++ /dev/null @@ -1,510 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import Max. -Require Import GenBase. -Require Import ZnZ. -Require Import Zn2Z. - -(* 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:Set, zn2z w -> word w (S n) := - match n return forall w:Set, 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: Set. - - 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 : Set. - Variable nT : Set. - 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 : Set. - Variable nT : Set. - 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 : Set. - 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 gen_to_Z := gen_to_Z wm_base wm_to_Z. - Let gen_wB := gen_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 gen_to_Z_pos: forall n x, 0 <= gen_to_Z n x < gen_wB n := - (spec_gen_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 = gen_to_Z n x - | Lt => 0 < gen_to_Z n x - | Gt => 0 > gen_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 gen_to_Z; intros H1 H2; rewrite H1; rewrite <- H2; auto. - simpl gen_to_Z; intros H1 H2; rewrite <- H2; auto. - case (gen_to_Z_pos n xl); auto with zarith. - intros H1; simpl gen_to_Z. - set (u := GenBase.gen_wB wm_base n). - case (gen_to_Z_pos n xl); intros H2 H3. - assert (0 < u); auto with zarith. - unfold u, GenBase.gen_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 (gen_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 gen_wB_lt: forall n x, - 0 <= w_to_Z x < (gen_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 gen_wB, GenBase.gen_wB; simpl. - rewrite base_xO. - set (u := base (gen_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 => gen_to_Z n x = w_to_Z y - | Lt => gen_to_Z n x < w_to_Z y - | Gt => gen_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 (gen_wB_lt n y); intros _ H0. - apply Zlt_le_trans with (1:= H0). - fold gen_wB. - case (gen_to_Z_pos n xl); intros H1 H2. - apply Zle_trans with (gen_to_Z n xh * gen_wB n); auto with zarith. - apply Zle_trans with (1 * gen_wB n); auto with zarith. - case (gen_to_Z_pos n xh); auto with zarith. - Qed. - -End CompareRec. - - -Section AddS. - - Variable w wm: Set. - 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: Set. - - 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. diff --git a/theories/Ints/num/Q0Make.v b/theories/Ints/num/Q0Make.v deleted file mode 100644 index d5809ea591..0000000000 --- a/theories/Ints/num/Q0Make.v +++ /dev/null @@ -1,1349 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import Bool. -Require Import ZArith. -Require Import Znumtheory. -Require Import Zaux. -Require Import Arith. -Require Export BigN. -Require Export BigZ. -Require Import QArith. -Require Import Qcanon. -Require Import Qpower. -Require Import QMake_base. - -Module Q0. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a naturel - number y interpreted as x/y. The pairs (x,0) and (0,y) are all - interpreted as 0. *) - - Definition t := q_type. - - Definition zero: t := Qz BigZ.zero. - Definition one: t := Qz BigZ.one. - Definition minus_one: t := Qz BigZ.minus_one. - - Definition of_Z x: t := Qz (BigZ.of_Z x). - - Definition of_Q q: t := - match q with x # y => - Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) - end. - - Definition of_Qc q := of_Q (this q). - - Definition to_Q (q: t) := - match q with - Qz x => BigZ.to_Z x # 1 - |Qq x y => if BigN.eq_bool y BigN.zero then 0%Q - else BigZ.to_Z x # Z2P (BigN.to_Z y) - end. - - Definition to_Qc q := !!(to_Q q). - - Notation "[[ x ]]" := (to_Qc x). - - Notation "[ x ]" := (to_Q x). - - Theorem spec_to_Q: forall q: Q, [of_Q q] = q. - intros (x,y); simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigN.spec_of_pos; intros HH; discriminate HH. - rewrite BigZ.spec_of_Z; simpl. - rewrite (BigN.spec_of_pos); auto. - Qed. - - Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. - intros (x, Hx); unfold of_Qc, to_Qc; simpl. - apply Qc_decomp; simpl. - intros; rewrite spec_to_Q; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (BigZ.opp zx) - | Qq nx dx => Qq (BigZ.opp nx) dx - end. - - Theorem spec_opp: forall q, ([opp q] = -[q])%Q. - intros [z | x y]; simpl. - rewrite BigZ.spec_opp; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigZ.spec_opp; auto. - Qed. - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - rewrite spec_opp. - rewrite <- Qred_opp. - rewrite Qred_involutive; auto. - Qed. - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => BigZ.compare zx zy - | Qz zx, Qq ny dy => - if BigN.eq_bool dy BigN.zero then BigZ.compare zx BigZ.zero - else BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny - | Qq nx dx, Qz zy => - if BigN.eq_bool dx BigN.zero then BigZ.compare BigZ.zero zy - else BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) - | Qq nx dx, Qq ny dy => - match BigN.eq_bool dx BigN.zero, BigN.eq_bool dy BigN.zero with - | true, true => Eq - | true, false => BigZ.compare BigZ.zero ny - | false, true => BigZ.compare nx BigZ.zero - | false, false => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) - end - end. - - Theorem spec_compare: forall q1 q2, - compare q1 q2 = ([q1] ?= [q2])%Q. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare, to_Q, Qnum, Qden. - repeat rewrite Zmult_1_r. - generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. - rewrite H; rewrite Zcompare_refl; auto. - rewrite Zmult_1_r. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - rewrite Zmult_1_r; generalize (BigZ.spec_compare z1 BigZ.zero); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH1; rewrite HH1; rewrite Zcompare_refl; auto. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (z1 * BigZ.Pos y2) x2)%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare BigZ.zero z2); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH1; rewrite <- HH1; rewrite Zcompare_refl; auto. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y1); auto with zarith. - rewrite Zmult_1_r. - generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1))%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - rewrite Zcompare_refl; auto. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare BigZ.zero x2); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare x1 BigZ.zero)%bigZ; case BigZ.compare; - auto; rewrite BigZ.spec_0. - intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. - repeat rewrite Z2P_correct. - 2: generalize (BigN.spec_pos y1); auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (x1 * BigZ.Pos y2) - (x2 * BigZ.Pos y1))%bigZ; case BigZ.compare; - repeat rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - Qed. - - Theorem spec_comparec: forall q1 q2, - compare q1 q2 = ([[q1]] ?= [[q2]]). - unfold Qccompare, to_Qc. - intros q1 q2; rewrite spec_compare; simpl; auto. - apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. - Qed. - -(* Je pense que cette fonction normalise bien ... *) - Definition norm n d: t := - let gcd := BigN.gcd (BigZ.to_N n) d in - match BigN.compare BigN.one gcd with - | Lt => - let n := BigZ.div n (BigZ.Pos gcd) in - let d := BigN.div d gcd in - match BigN.compare d BigN.one with - | Gt => Qq n d - | Eq => Qz n - | Lt => zero - end - | Eq => Qq n d - | Gt => zero (* gcd = 0 => both numbers are 0 *) - end. - - - - Theorem spec_norm: forall n q, - ([norm n q] == [Qq n q])%Q. - intros p q; unfold norm. - assert (Hp := BigN.spec_pos (BigZ.to_N p)). - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; auto; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. - apply Qeq_refl. - generalize (BigN.spec_pos (q / BigN.gcd (BigZ.to_N p) q)%bigN). - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; auto; rewrite BigN.spec_1; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; intros H2 HH. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H3; simpl; - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - auto with zarith. - generalize H2; rewrite H3; - rewrite Zdiv_0_l; auto with zarith. - generalize H1 H2 H3 (BigN.spec_pos q); clear H1 H2 H3. - rewrite spec_to_N. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 H4; rewrite Z2P_correct; auto with zarith. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H3; simpl. - case H3. - generalize H1 H2 H3 HH; clear H1 H2 H3 HH. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 HH. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto with zarith. - case (Zle_lt_or_eq _ _ HH); auto with zarith. - intros HH1; rewrite <- HH1; ring. - generalize (Zgcd_is_gcd a b); intros HH1; inversion HH1; auto. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; intros H3. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H4. - case H3; rewrite H4; rewrite Zdiv_0_l; auto with zarith. - simpl. - assert (FF := BigN.spec_pos q). - rewrite Z2P_correct; auto with zarith. - rewrite <- BigN.spec_gcd; rewrite <- BigN.spec_div; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto with zarith. - simpl; rewrite BigZ.spec_div; simpl. - rewrite BigN.spec_gcd; auto with zarith. - generalize H1 H2 H3 H4 HH FF; clear H1 H2 H3 H4 HH FF. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 H4 HH FF. - rewrite spec_to_N; fold a. - rewrite Zgcd_div_swap; auto with zarith. - rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_gcd; auto with zarith. - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (BigN.gcd (BigZ.to_N p) q))); - rewrite BigN.spec_gcd; auto with zarith. - intros; apply False_ind; auto with zarith. - intros HH2; assert (FF1 := Zgcd_inv_0_l _ _ (sym_equal HH2)). - assert (FF2 := Zgcd_inv_0_l _ _ (sym_equal HH2)). - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2; simpl. - rewrite spec_to_N. - rewrite FF2; ring. - Qed. - - - Definition add (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (BigZ.add zx zy) - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - end - | Qq nx dx => - if BigN.eq_bool dx BigN.zero then y - else match y with - | Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - Qq n d - end - end. - - Theorem spec_add x y: - ([add x y] == [x] + [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. - rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - assert (F1:= BigN.spec_pos dy). - rewrite Zmult_1_r; red; simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH; simpl; try ring. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH1; simpl; try ring. - case HH; auto. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH; simpl; try ring. - rewrite Zmult_1_r; apply Qeq_refl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH1; simpl; try ring. - case HH; auto. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. - rewrite Zmult_1_r; rewrite Pmult_1_r. - apply Qeq_refl. - assert (F1:= BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - apply Qeq_refl. - case HH2; auto. - simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - case HH2; auto. - case HH1; auto. - rewrite Zmult_1_r; apply Qeq_refl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - simpl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - case HH; auto. - rewrite Zmult_1_r; rewrite Zplus_0_r; rewrite Pmult_1_r. - apply Qeq_refl. - simpl. - generalize (BigN.spec_eq_bool (dx * dy)%bigN BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_mul; - rewrite BigN.spec_0; intros HH2. - (case (Zmult_integral _ _ HH2); intros HH3); - [case HH| case HH1]; auto. - rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. - assert (Fx: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (Fy: (0 < BigN.to_Z dy)%Z). - generalize (BigN.spec_pos dy); auto with zarith. - red; simpl; rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto with zarith. - apply Zmult_lt_0_compat; auto. - Qed. - - Theorem spec_addc x y: - [[add x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition add_norm (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (BigZ.add zx zy) - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - end - | Qq nx dx => - if BigN.eq_bool dx BigN.zero then y - else match y with - | Qz zy => norm (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - norm n d - end - end. - - - Theorem spec_add_norm x y: - ([add_norm x y] == [x] + [y])%Q. - intros x y; rewrite <- spec_add; auto. - case x; case y; clear x y; unfold add_norm, add. - intros; apply Qeq_refl. - intros p1 n p2. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - simpl. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - apply Qeq_refl. - apply Qeq_refl. - intros p1 p2 n. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - apply Qeq_refl. - intros p1 q1 p2 q2. - generalize (BigN.spec_eq_bool q2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - apply Qeq_refl. - generalize (BigN.spec_eq_bool q1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - apply Qeq_refl. - Qed. - - Theorem spec_add_normc x y: - [[add_norm x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add_norm; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition sub x y := add x (opp y). - - - Theorem spec_sub x y: - ([sub x y] == [x] - [y])%Q. - intros x y; unfold sub; rewrite spec_add; auto. - rewrite spec_opp; ring. - Qed. - - Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. - intros x y; unfold sub; rewrite spec_addc; auto. - rewrite spec_oppc; ring. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem spec_sub_norm x y: - ([sub_norm x y] == [x] - [y])%Q. - intros x y; unfold sub_norm; rewrite spec_add_norm; auto. - rewrite spec_opp; ring. - Qed. - - Theorem spec_sub_normc x y: - [[sub_norm x y]] = [[x]] - [[y]]. - intros x y; unfold sub_norm; rewrite spec_add_normc; auto. - rewrite spec_oppc; ring. - Qed. - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => Qq (BigZ.mul nx ny) (BigN.mul dx dy) - end. - - - Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. - rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH1. - red; simpl; ring. - rewrite BigZ.spec_mul; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH1. - red; simpl; ring. - rewrite BigZ.spec_mul; rewrite Pmult_1_r. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_mul; - intros HH1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH2. - red; simpl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH3. - red; simpl; ring. - case (Zmult_integral _ _ HH1); intros HH. - case HH2; auto. - case HH3; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH2. - case HH1; rewrite HH2; ring. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH3. - case HH1; rewrite HH3; ring. - rewrite BigZ.spec_mul. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - apply Qeq_refl. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dy); auto with zarith. - Qed. - - Theorem spec_mulc x y: - [[mul x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - -Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => - if BigZ.eq_bool zx BigZ.zero then zero - else - let gcd := BigN.gcd (BigZ.to_N zx) dy in - match BigN.compare gcd BigN.one with - Gt => - let zx := BigZ.div zx (BigZ.Pos gcd) in - let d := BigN.div dy gcd in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul zx ny) - else Qq (BigZ.mul zx ny) d - | _ => Qq (BigZ.mul zx ny) dy - end - | Qq nx dx, Qz zy => - if BigZ.eq_bool zy BigZ.zero then zero - else - let gcd := BigN.gcd (BigZ.to_N zy) dx in - match BigN.compare gcd BigN.one with - Gt => - let zy := BigZ.div zy (BigZ.Pos gcd) in - let d := BigN.div dx gcd in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul zy nx) - else Qq (BigZ.mul zy nx) d - | _ => Qq (BigZ.mul zy nx) dx - end - | Qq nx dx, Qq ny dy => - let (nx, dy) := - let gcd := BigN.gcd (BigZ.to_N nx) dy in - match BigN.compare gcd BigN.one with - Gt => (BigZ.div nx (BigZ.Pos gcd), BigN.div dy gcd) - | _ => (nx, dy) - end in - let (ny, dx) := - let gcd := BigN.gcd (BigZ.to_N ny) dx in - match BigN.compare gcd BigN.one with - Gt => (BigZ.div ny (BigZ.Pos gcd), BigN.div dx gcd) - | _ => (ny, dx) - end in - let d := (BigN.mul dx dy) in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul ny nx) - else Qq (BigZ.mul ny nx) d - end. - - Theorem spec_mul_norm x y: - ([mul_norm x y] == [x] * [y])%Q. - intros x y; rewrite <- spec_mul; auto. - unfold mul_norm, mul; case x; case y; clear x y. - intros; apply Qeq_refl. - intros p1 n p2. - set (a := BigN.to_Z (BigZ.to_N p2)). - set (b := BigN.to_Z n). - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. - case BigN.eq_bool; try apply Qeq_refl. - rewrite BigZ.spec_mul; rewrite H. - red; simpl; ring. - assert (F: (0 < a)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p2))); auto. - intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; - fold a b; intros H1. - apply Qeq_refl. - apply Qeq_refl. - assert (F0 : (0 < (Zgcd a b))%Z). - apply Zlt_trans with 1%Z. - red; auto. - apply Zgt_lt; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; - fold a b; intros H2. - assert (F1: b = Zgcd a b). - pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); - auto with zarith. - rewrite H2; ring. - assert (FF := Zgcd_is_gcd a b); inversion FF; auto. - assert (F2: (0 < b)%Z). - rewrite F1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; fold b; intros H3. - rewrite H3 in F2; discriminate F2. - rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - rewrite BigZ.spec_mul. - red; simpl; rewrite Z2P_correct; auto. - rewrite Zmult_1_r; rewrite spec_to_N; fold a b. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p1)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; fold a b; auto; intros H3. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H4. - apply Qeq_refl. - case H4; fold b. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite H3; ring. - assert (FF := Zgcd_is_gcd a b); inversion FF; auto. - simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; fold b; intros H4. - case H3; rewrite H4; rewrite Zdiv_0_l; auto. - rewrite BigZ.spec_mul; rewrite BigZ.spec_div; simpl; - rewrite BigN.spec_gcd; fold a b; auto with zarith. - assert (F1: (0 < b)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos n)); fold b; auto with zarith. - red; simpl. - rewrite BigZ.spec_mul. - repeat rewrite Z2P_correct; auto. - rewrite spec_to_N; fold a. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p1)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - ring. - apply Zgcd_div_pos; auto. - intros p1 p2 n. - set (a := BigN.to_Z (BigZ.to_N p1)). - set (b := BigN.to_Z n). - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. - case BigN.eq_bool; try apply Qeq_refl. - rewrite BigZ.spec_mul; rewrite H. - red; simpl; ring. - assert (F: (0 < a)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p1))); auto. - intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; - fold a b; intros H1. - repeat rewrite BigZ.spec_mul; rewrite Zmult_comm. - apply Qeq_refl. - repeat rewrite BigZ.spec_mul; rewrite Zmult_comm. - apply Qeq_refl. - assert (F0 : (0 < (Zgcd a b))%Z). - apply Zlt_trans with 1%Z. - red; auto. - apply Zgt_lt; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; - fold a b; intros H2. - assert (F1: b = Zgcd a b). - pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); - auto with zarith. - rewrite H2; ring. - assert (FF := Zgcd_is_gcd a b); inversion FF; auto. - assert (F2: (0 < b)%Z). - rewrite F1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; fold b; intros H3. - rewrite H3 in F2; discriminate F2. - rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - rewrite BigZ.spec_mul. - red; simpl; rewrite Z2P_correct; auto. - rewrite Zmult_1_r; rewrite spec_to_N; fold a b. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p2)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; fold a b; auto; intros H3. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H4. - apply Qeq_refl. - case H4; fold b. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite H3; ring. - assert (FF := Zgcd_is_gcd a b); inversion FF; auto. - simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; fold b; intros H4. - case H3; rewrite H4; rewrite Zdiv_0_l; auto. - rewrite BigZ.spec_mul; rewrite BigZ.spec_div; simpl; - rewrite BigN.spec_gcd; fold a b; auto with zarith. - assert (F1: (0 < b)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos n)); fold b; auto with zarith. - red; simpl. - rewrite BigZ.spec_mul. - repeat rewrite Z2P_correct; auto. - rewrite spec_to_N; fold a. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p2)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - ring. - apply Zgcd_div_pos; auto. - set (f := fun p t => - match (BigN.gcd (BigZ.to_N p) t ?= BigN.one)%bigN with - | Eq => (p, t) - | Lt => (p, t) - | Gt => - ((p / BigZ.Pos (BigN.gcd (BigZ.to_N p) t))%bigZ, - (t / BigN.gcd (BigZ.to_N p) t)%bigN) - end). - assert (F: forall p t, - let (n, d) := f p t in [Qq p t] == [Qq n d]). - intros p t1; unfold f. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. - apply Qeq_refl. - apply Qeq_refl. - set (a := BigN.to_Z (BigZ.to_N p)). - set (b := BigN.to_Z t1). - fold a b in H1. - assert (F0 : (0 < (Zgcd a b))%Z). - apply Zlt_trans with 1%Z. - red; auto. - apply Zgt_lt; auto. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; fold b; intros HH1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; fold b; intros HH2. - simpl; ring. - case HH2. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a b; auto. - rewrite HH1; rewrite Zdiv_0_l; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; - rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a b; auto; - intros HH2. - case HH1. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite HH2; ring. - assert (FF := Zgcd_is_gcd a b); inversion FF; auto. - simpl. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; fold a b; auto with zarith. - assert (F1: (0 < b)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos t1)); fold b; auto with zarith. - intros HH; case HH1; auto. - repeat rewrite Z2P_correct; auto. - rewrite spec_to_N; fold a. - rewrite Zgcd_div_swap; auto. - apply Zgcd_div_pos; auto. - intros HH; rewrite HH in F0; discriminate F0. - intros p1 n1 p2 n2. - change ([let (nx , dy) := f p2 n1 in - let (ny, dx) := f p1 n2 in - if BigN.eq_bool (dx * dy)%bigN BigN.one - then Qz (ny * nx) - else Qq (ny * nx) (dx * dy)] == [Qq (p2 * p1) (n2 * n1)]). - generalize (F p2 n1) (F p1 n2). - case f; case f. - intros u1 u2 v1 v2 Hu1 Hv1. - apply Qeq_trans with [mul (Qq p2 n1) (Qq p1 n2)]. - rewrite spec_mul; rewrite Hu1; rewrite Hv1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; rewrite BigN.spec_mul; intros HH1. - assert (F1: BigN.to_Z u2 = 1%Z). - case (Zmult_1_inversion_l _ _ HH1); auto. - generalize (BigN.spec_pos u2); auto with zarith. - assert (F2: BigN.to_Z v2 = 1%Z). - rewrite Zmult_comm in HH1. - case (Zmult_1_inversion_l _ _ HH1); auto. - generalize (BigN.spec_pos v2); auto with zarith. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - rewrite H1 in F2; discriminate F2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2. - rewrite H2 in F1; discriminate F1. - simpl; rewrite BigZ.spec_mul. - rewrite F1; rewrite F2; simpl; ring. - rewrite Qmult_comm; rewrite <- spec_mul. - apply Qeq_refl. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_mul; - rewrite Zmult_comm; intros H1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_mul; intros H2; auto. - case H2; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_mul; intros H2; auto. - case H1; auto. - Qed. - - Theorem spec_mul_normc x y: - [[mul_norm x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul_norm; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - -Definition inv (x: t): t := - match x with - | Qz (BigZ.Pos n) => Qq BigZ.one n - | Qz (BigZ.Neg n) => Qq BigZ.minus_one n - | Qq (BigZ.Pos n) d => Qq (BigZ.Pos d) n - | Qq (BigZ.Neg n) d => Qq (BigZ.Neg d) n - end. - - Theorem spec_inv x: - ([inv x] == /[x])%Q. - intros [ [x | x] | [nx | nx] dx]; unfold inv, Qinv; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - rewrite H1; apply Qeq_refl. - generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); auto. - intros HH; case HH; auto. - intros; red; simpl; auto. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - rewrite H1; apply Qeq_refl. - generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl; auto. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - apply Qeq_refl. - rewrite H1; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - rewrite H2; red; simpl; auto. - generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - apply Qeq_refl. - rewrite H1; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - rewrite H2; red; simpl; auto. - generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p _ HH; case HH; auto. - Qed. - - Theorem spec_invc x: - [[inv x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - -Definition inv_norm (x: t): t := - match x with - | Qz (BigZ.Pos n) => - match BigN.compare n BigN.one with - Gt => Qq BigZ.one n - | _ => x - end - | Qz (BigZ.Neg n) => - match BigN.compare n BigN.one with - Gt => Qq BigZ.minus_one n - | _ => x - end - | Qq (BigZ.Pos n) d => - match BigN.compare n BigN.one with - Gt => Qq (BigZ.Pos d) n - | Eq => Qz (BigZ.Pos d) - | Lt => Qz (BigZ.zero) - end - | Qq (BigZ.Neg n) d => - match BigN.compare n BigN.one with - Gt => Qq (BigZ.Neg d) n - | Eq => Qz (BigZ.Neg d) - | Lt => Qz (BigZ.zero) - end - end. - - Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. - intros [ [x | x] | [nx | nx] dx]; unfold inv_norm, Qinv. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H. - simpl; rewrite H; apply Qeq_refl. - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. - generalize H; case BigN.to_Z. - intros _ HH; discriminate HH. - intros p; case p; auto. - intros p1 HH; discriminate HH. - intros p1 HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; discriminate HH. - intros HH; rewrite <- HH. - apply Qeq_refl. - generalize H; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - rewrite H1; intros HH; discriminate. - generalize H; case BigN.to_Z. - intros HH; discriminate HH. - intros; red; simpl; auto. - intros p HH; discriminate HH. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H. - simpl; rewrite H; apply Qeq_refl. - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. - generalize H; case BigN.to_Z. - intros _ HH; discriminate HH. - intros p; case p; auto. - intros p1 HH; discriminate HH. - intros p1 HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; discriminate HH. - intros HH; rewrite <- HH. - apply Qeq_refl. - generalize H; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - rewrite H1; intros HH; discriminate. - generalize H; case BigN.to_Z. - intros HH; discriminate HH. - intros; red; simpl; auto. - intros p HH; discriminate HH. - simpl Qnum. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; simpl. - case BigN.compare; red; simpl; auto. - rewrite H1; auto. - case BigN.eq_bool; auto. - simpl; rewrite H1; auto. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H2. - rewrite H2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - red; simpl. - rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). - intros; apply Qeq_refl. - intros p; case p; clear p. - intros p HH; discriminate HH. - intros p HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - simpl; generalize H2; case (BigN.to_Z nx). - intros HH; discriminate HH. - intros p Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H4. - rewrite H4 in H2; discriminate H2. - red; simpl. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - intros p HH; discriminate HH. - simpl Qnum. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; simpl. - case BigN.compare; red; simpl; auto. - rewrite H1; auto. - case BigN.eq_bool; auto. - simpl; rewrite H1; auto. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H2. - rewrite H2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). - intros; apply Qeq_refl. - intros p; case p; clear p. - intros p HH; discriminate HH. - intros p HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - simpl; generalize H2; case (BigN.to_Z nx). - intros HH; discriminate HH. - intros p Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H4. - rewrite H4 in H2; discriminate H2. - red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p HH; discriminate HH. - Qed. - - Theorem spec_inv_normc x: - [[inv_norm x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv_norm; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition div x y := mul x (inv y). - - Theorem spec_div x y: ([div x y] == [x] / [y])%Q. - intros x y; unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. - intros x y; unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv y). - - Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. - intros x y; unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. - intros x y; unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Definition square (x: t): t := - match x with - | Qz zx => Qz (BigZ.square zx) - | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) - end. - - Theorem spec_square x: ([square x] == [x] ^ 2)%Q. - intros [ x | nx dx]; unfold square. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - simpl Qpower. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H. - red; simpl. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; - intros H1. - case H1; rewrite H; auto. - red; simpl. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; - intros H1. - case H; case (Zmult_integral _ _ H1); auto. - simpl. - rewrite BigZ.spec_square. - rewrite Zpos_mult_morphism. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dx); auto with zarith. - Qed. - - Theorem spec_squarec x: [[square x]] = [[x]]^2. - intros x; unfold to_Qc. - apply trans_equal with (!! ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_square; auto. - simpl Qcpower. - replace (!! [x] * 1) with (!![x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition power_pos (x: t) p: t := - match x with - | Qz zx => Qz (BigZ.power_pos zx p) - | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.power_pos dx p) - end. - - Theorem spec_power_pos x p: ([power_pos x p] == [x] ^ Zpos p)%Q. - Proof. - intros [x | nx dx] p; unfold power_pos. - unfold power_pos; red; simpl. - generalize (Qpower_decomp p (BigZ.to_Z x) 1). - unfold Qeq; simpl. - rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Zmult_1_r. - intros H; rewrite H. - rewrite BigZ.spec_power_pos; simpl; ring. - simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_power_pos; intros H1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2. - elim p; simpl. - intros; red; simpl; auto. - intros p1 Hp1; rewrite <- Hp1; red; simpl; auto. - apply Qeq_refl. - case H2; generalize H1. - elim p; simpl. - intros p1 Hrec. - change (xI p1) with (1 + (xO p1))%positive. - rewrite Zpower_pos_is_exp; rewrite Zpower_pos_1_r. - intros HH; case (Zmult_integral _ _ HH); auto. - rewrite <- Pplus_diag. - rewrite Zpower_pos_is_exp. - intros HH1; case (Zmult_integral _ _ HH1); auto. - intros p1 Hrec. - rewrite <- Pplus_diag. - rewrite Zpower_pos_is_exp. - intros HH1; case (Zmult_integral _ _ HH1); auto. - rewrite Zpower_pos_1_r; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2. - case H1; rewrite H2; auto. - simpl; rewrite Zpower_pos_0_l; auto. - assert (F1: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (F2: (0 < BigN.to_Z dx ^ ' p)%Z). - unfold Zpower; apply Zpower_pos_pos; auto. - unfold power_pos; red; simpl. - generalize (Qpower_decomp p (BigZ.to_Z nx) - (Z2P (BigN.to_Z dx))). - unfold Qeq; simpl. - repeat rewrite Z2P_correct; auto. - unfold Qeq; simpl; intros HH. - rewrite HH. - rewrite BigZ.spec_power_pos; simpl; ring. - Qed. - - Theorem spec_power_posc x p: - [[power_pos x p]] = [[x]] ^ nat_of_P p. - intros x p; unfold to_Qc. - apply trans_equal with (!! ([x]^Zpos p)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_power_pos; auto. - pattern p; apply Pind; clear p. - simpl; ring. - intros p Hrec. - rewrite nat_of_P_succ_morphism; simpl Qcpower. - rewrite <- Hrec. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; - unfold this. - apply Qred_complete. - assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). - simpl; case x; simpl; clear x Hrec. - intros x; simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - intros nx dx. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - unfold Qpower_positive. - assert (tmp: forall p, pow_pos Qmult 0%Q p = 0%Q). - intros p1; elim p1; simpl; auto; clear p1. - intros p1 Hp1; rewrite Hp1; auto. - intros p1 Hp1; rewrite Hp1; auto. - repeat rewrite tmp; intros; red; simpl; auto. - intros H1. - assert (F1: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - repeat rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto. - 2: apply Zpower_pos_pos; auto. - 2: apply Zpower_pos_pos; auto. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - rewrite F. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - -End Q0. diff --git a/theories/Ints/num/QMake_base.v b/theories/Ints/num/QMake_base.v deleted file mode 100644 index 0cd2d2122f..0000000000 --- a/theories/Ints/num/QMake_base.v +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -(* $Id:$ *) - -(** * An implementation of rational numbers based on big integers *) - -(** -- Authors: Benjamin Grégoire, Laurent Théry -- Institution: INRIA -- Date: 2007 -*) - -Require Export BigN. -Require Export BigZ. - -(* Basic type for Q: a Z or a pair of a Z and an N *) - -Inductive q_type : Set := - | Qz : BigZ.t -> q_type - | Qq : BigZ.t -> BigN.t -> q_type. - -Definition print_type x := - match x with - | Qz _ => Z - | _ => (Z*Z)%type - end. - -Definition print x := - match x return print_type x with - | Qz zx => BigZ.to_Z zx - | Qq nx dx => (BigZ.to_Z nx, BigN.to_Z dx) - end. diff --git a/theories/Ints/num/QbiMake.v b/theories/Ints/num/QbiMake.v deleted file mode 100644 index a98fda9d7f..0000000000 --- a/theories/Ints/num/QbiMake.v +++ /dev/null @@ -1,1058 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import Bool. -Require Import ZArith. -Require Import Znumtheory. -Require Import Zaux. -Require Import Arith. -Require Export BigN. -Require Export BigZ. -Require Import QArith. -Require Import Qcanon. -Require Import Qpower. -Require Import QMake_base. - -Module Qbi. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a naturel - number y interpreted as x/y. The pairs (x,0) and (0,y) are all - interpreted as 0. *) - - Definition t := q_type. - - Definition zero: t := Qz BigZ.zero. - Definition one: t := Qz BigZ.one. - Definition minus_one: t := Qz BigZ.minus_one. - - Definition of_Z x: t := Qz (BigZ.of_Z x). - - - Definition of_Q q: t := - match q with x # y => - Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) - end. - - Definition of_Qc q := of_Q (this q). - - Definition to_Q (q: t) := - match q with - Qz x => BigZ.to_Z x # 1 - |Qq x y => if BigN.eq_bool y BigN.zero then 0%Q - else BigZ.to_Z x # Z2P (BigN.to_Z y) - end. - - Definition to_Qc q := !!(to_Q q). - - Notation "[[ x ]]" := (to_Qc x). - - Notation "[ x ]" := (to_Q x). - - Theorem spec_to_Q: forall q: Q, [of_Q q] = q. - intros (x,y); simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigN.spec_of_pos; intros HH; discriminate HH. - rewrite BigZ.spec_of_Z; simpl. - rewrite (BigN.spec_of_pos); auto. - Qed. - - Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. - intros (x, Hx); unfold of_Qc, to_Qc; simpl. - apply Qc_decomp; simpl. - intros; rewrite spec_to_Q; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (BigZ.opp zx) - | Qq nx dx => Qq (BigZ.opp nx) dx - end. - - Theorem spec_opp: forall q, ([opp q] = -[q])%Q. - intros [z | x y]; simpl. - rewrite BigZ.spec_opp; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigZ.spec_opp; auto. - Qed. - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - rewrite spec_opp. - rewrite <- Qred_opp. - rewrite Qred_involutive; auto. - Qed. - - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => BigZ.compare zx zy - | Qz zx, Qq ny dy => - if BigN.eq_bool dy BigN.zero then BigZ.compare zx BigZ.zero - else - match BigZ.cmp_sign zx ny with - | Lt => Lt - | Gt => Gt - | Eq => BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny - end - | Qq nx dx, Qz zy => - if BigN.eq_bool dx BigN.zero then BigZ.compare BigZ.zero zy - else - match BigZ.cmp_sign nx zy with - | Lt => Lt - | Gt => Gt - | Eq => BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) - end - | Qq nx dx, Qq ny dy => - match BigN.eq_bool dx BigN.zero, BigN.eq_bool dy BigN.zero with - | true, true => Eq - | true, false => BigZ.compare BigZ.zero ny - | false, true => BigZ.compare nx BigZ.zero - | false, false => - match BigZ.cmp_sign nx ny with - | Lt => Lt - | Gt => Gt - | Eq => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) - end - end - end. - - Theorem spec_compare: forall q1 q2, - compare q1 q2 = ([q1] ?= [q2])%Q. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare, to_Q, Qnum, Qden. - repeat rewrite Zmult_1_r. - generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. - rewrite H; rewrite Zcompare_refl; auto. - rewrite Zmult_1_r. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - rewrite Zmult_1_r; generalize (BigZ.spec_compare z1 BigZ.zero); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH1; rewrite HH1; rewrite Zcompare_refl; auto. - set (a := BigZ.to_Z z1); set (b := BigZ.to_Z x2); - set (c := BigN.to_Z y2); fold c in HH. - assert (F: (0 < c)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos y2)); fold c; auto. - intros H1; case HH; rewrite <- H1; auto. - rewrite Z2P_correct; auto with zarith. - generalize (BigZ.spec_cmp_sign z1 x2); case BigZ.cmp_sign; fold a b c. - intros _; generalize (BigZ.spec_compare (z1 * BigZ.Pos y2)%bigZ x2); - case BigZ.compare; rewrite BigZ.spec_mul; simpl; fold a b c; auto. - intros H1; rewrite H1; rewrite Zcompare_refl; auto. - intros (H1, H2); apply sym_equal; change (a * c < b)%Z. - apply Zlt_le_trans with (2 := H2). - change 0%Z with (0 * c)%Z. - apply Zmult_lt_compat_r; auto with zarith. - intros (H1, H2); apply sym_equal; change (a * c > b)%Z. - apply Zlt_gt. - apply Zlt_le_trans with (1 := H2). - change 0%Z with (0 * c)%Z. - apply Zmult_le_compat_r; auto with zarith. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare BigZ.zero z2); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH1; rewrite <- HH1; rewrite Zcompare_refl; auto. - set (a := BigZ.to_Z z2); set (b := BigZ.to_Z x1); - set (c := BigN.to_Z y1); fold c in HH. - assert (F: (0 < c)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos y1)); fold c; auto. - intros H1; case HH; rewrite <- H1; auto. - rewrite Zmult_1_r; rewrite Z2P_correct; auto with zarith. - generalize (BigZ.spec_cmp_sign x1 z2); case BigZ.cmp_sign; fold a b c. - intros _; generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1)%bigZ); - case BigZ.compare; rewrite BigZ.spec_mul; simpl; fold a b c; auto. - intros H1; rewrite H1; rewrite Zcompare_refl; auto. - intros (H1, H2); apply sym_equal; change (b < a * c)%Z. - apply Zlt_le_trans with (1 := H1). - change 0%Z with (0 * c)%Z. - apply Zmult_le_compat_r; auto with zarith. - intros (H1, H2); apply sym_equal; change (b > a * c)%Z. - apply Zlt_gt. - apply Zlt_le_trans with (2 := H1). - change 0%Z with (0 * c)%Z. - apply Zmult_lt_compat_r; auto with zarith. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - rewrite Zcompare_refl; auto. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare BigZ.zero x2); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare x1 BigZ.zero)%bigZ; case BigZ.compare; - auto; rewrite BigZ.spec_0. - intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. - set (a := BigZ.to_Z x1); set (b := BigZ.to_Z x2); - set (c1 := BigN.to_Z y1); set (c2 := BigN.to_Z y2). - fold c1 in HH; fold c2 in HH1. - assert (F1: (0 < c1)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos y1)); fold c1; auto. - intros H1; case HH; rewrite <- H1; auto. - assert (F2: (0 < c2)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos y2)); fold c2; auto. - intros H1; case HH1; rewrite <- H1; auto. - repeat rewrite Z2P_correct; auto. - generalize (BigZ.spec_cmp_sign x1 x2); case BigZ.cmp_sign. - intros _; generalize (BigZ.spec_compare (x1 * BigZ.Pos y2)%bigZ - (x2 * BigZ.Pos y1)%bigZ); - case BigZ.compare; rewrite BigZ.spec_mul; simpl; fold a b c1 c2; auto. - rewrite BigZ.spec_mul; simpl; fold a b c1; intros HH2; rewrite HH2; - rewrite Zcompare_refl; auto. - rewrite BigZ.spec_mul; simpl; auto. - rewrite BigZ.spec_mul; simpl; auto. - fold a b; intros (H1, H2); apply sym_equal; change (a * c2 < b * c1)%Z. - apply Zlt_le_trans with 0%Z. - change 0%Z with (0 * c2)%Z. - apply Zmult_lt_compat_r; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. - fold a b; intros (H1, H2); apply sym_equal; change (a * c2 > b * c1)%Z. - apply Zlt_gt; apply Zlt_le_trans with 0%Z. - change 0%Z with (0 * c1)%Z. - apply Zmult_lt_compat_r; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. - Qed. - - - Definition do_norm_n n := - match n with - | BigN.N0 _ => false - | BigN.N1 _ => false - | BigN.N2 _ => false - | BigN.N3 _ => false - | BigN.N4 _ => false - | BigN.N5 _ => false - | BigN.N6 _ => false - | _ => true - end. - - Definition do_norm_z z := - match z with - | BigZ.Pos n => do_norm_n n - | BigZ.Neg n => do_norm_n n - end. - -(* Je pense que cette fonction normalise bien ... *) - Definition norm n d: t := - if andb (do_norm_z n) (do_norm_n d) then - let gcd := BigN.gcd (BigZ.to_N n) d in - match BigN.compare BigN.one gcd with - | Lt => - let n := BigZ.div n (BigZ.Pos gcd) in - let d := BigN.div d gcd in - match BigN.compare d BigN.one with - | Gt => Qq n d - | Eq => Qz n - | Lt => zero - end - | Eq => Qq n d - | Gt => zero (* gcd = 0 => both numbers are 0 *) - end - else Qq n d. - - Theorem spec_norm: forall n q, - ([norm n q] == [Qq n q])%Q. - intros p q; unfold norm. - case do_norm_z; simpl andb. - 2: apply Qeq_refl. - case do_norm_n. - 2: apply Qeq_refl. - assert (Hp := BigN.spec_pos (BigZ.to_N p)). - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; auto; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. - apply Qeq_refl. - generalize (BigN.spec_pos (q / BigN.gcd (BigZ.to_N p) q)%bigN). - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; auto; rewrite BigN.spec_1; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; intros H2 HH. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H3; simpl; - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - auto with zarith. - generalize H2; rewrite H3; - rewrite Zdiv_0_l; auto with zarith. - generalize H1 H2 H3 (BigN.spec_pos q); clear H1 H2 H3. - rewrite spec_to_N. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 H4; rewrite Z2P_correct; auto with zarith. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H3; simpl. - case H3. - generalize H1 H2 H3 HH; clear H1 H2 H3 HH. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 HH. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto with zarith. - case (Zle_lt_or_eq _ _ HH); auto with zarith. - intros HH1; rewrite <- HH1; ring. - generalize (Zgcd_is_gcd a b); intros HH1; inversion HH1; auto. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; intros H3. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H4. - case H3; rewrite H4; rewrite Zdiv_0_l; auto with zarith. - simpl. - assert (FF := BigN.spec_pos q). - rewrite Z2P_correct; auto with zarith. - rewrite <- BigN.spec_gcd; rewrite <- BigN.spec_div; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto with zarith. - simpl; rewrite BigZ.spec_div; simpl. - rewrite BigN.spec_gcd; auto with zarith. - generalize H1 H2 H3 H4 HH FF; clear H1 H2 H3 H4 HH FF. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 H4 HH FF. - rewrite spec_to_N; fold a. - rewrite Zgcd_div_swap; auto with zarith. - rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_gcd; auto with zarith. - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (BigN.gcd (BigZ.to_N p) q))); - rewrite BigN.spec_gcd; auto with zarith. - intros; apply False_ind; auto with zarith. - intros HH2; assert (FF1 := Zgcd_inv_0_l _ _ (sym_equal HH2)). - assert (FF2 := Zgcd_inv_0_l _ _ (sym_equal HH2)). - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2; simpl. - rewrite spec_to_N. - rewrite FF2; ring. - Qed. - - Definition add (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (BigZ.add zx zy) - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - end - | Qq nx dx => - if BigN.eq_bool dx BigN.zero then y - else match y with - | Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - if BigN.eq_bool dx dy then - let n := BigZ.add nx ny in - Qq n dx - else - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - Qq n d - end - end. - - - - Theorem spec_add x y: - ([add x y] == [x] + [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. - rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - assert (F1:= BigN.spec_pos dy). - rewrite Zmult_1_r; red; simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH; simpl; try ring. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH1; simpl; try ring. - case HH; auto. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH; simpl; try ring. - rewrite Zmult_1_r; apply Qeq_refl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH1; simpl; try ring. - case HH; auto. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. - rewrite Zmult_1_r; rewrite Pmult_1_r. - apply Qeq_refl. - assert (F1:= BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - apply Qeq_refl. - case HH2; auto. - simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - case HH2; auto. - case HH1; auto. - rewrite Zmult_1_r; apply Qeq_refl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - simpl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - case HH; auto. - rewrite Zmult_1_r; rewrite Zplus_0_r; rewrite Pmult_1_r. - apply Qeq_refl. - simpl. - generalize (BigN.spec_eq_bool (dx * dy)%bigN BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_mul; - rewrite BigN.spec_0; intros HH2. - (case (Zmult_integral _ _ HH2); intros HH3); - [case HH| case HH1]; auto. - generalize (BigN.spec_eq_bool dx dy); - case BigN.eq_bool; intros HH3. - rewrite <- HH3. - assert (Fx: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - red; simpl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH4. - case HH; auto. - simpl; rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. - ring. - assert (Fx: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (Fy: (0 < BigN.to_Z dy)%Z). - generalize (BigN.spec_pos dy); auto with zarith. - red; simpl; rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_mul; - rewrite BigN.spec_0; intros H3; simpl. - absurd (0 < 0)%Z; auto with zarith. - rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. - repeat rewrite Z2P_correct; auto with zarith. - apply Zmult_lt_0_compat; auto. - Qed. - - Theorem spec_addc x y: - [[add x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition add_norm (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (BigZ.add zx zy) - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - end - | Qq nx dx => - if BigN.eq_bool dx BigN.zero then y - else match y with - | Qz zy => norm (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - if BigN.eq_bool dx dy then - let n := BigZ.add nx ny in - norm n dx - else - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - norm n d - end - end. - - Theorem spec_add_norm x y: - ([add_norm x y] == [x] + [y])%Q. - intros x y; rewrite <- spec_add; auto. - case x; case y; clear x y; unfold add_norm, add. - intros; apply Qeq_refl. - intros p1 n p2. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - simpl. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - apply Qeq_refl. - apply Qeq_refl. - intros p1 p2 n. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - apply Qeq_refl. - intros p1 q1 p2 q2. - generalize (BigN.spec_eq_bool q2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - apply Qeq_refl. - generalize (BigN.spec_eq_bool q1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; intros HH3; - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end; apply Qeq_refl. - Qed. - - Theorem spec_add_normc x y: - [[add_norm x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add_norm; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition sub x y := add x (opp y). - - Theorem spec_sub x y: - ([sub x y] == [x] - [y])%Q. - intros x y; unfold sub; rewrite spec_add; auto. - rewrite spec_opp; ring. - Qed. - - Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. - intros x y; unfold sub; rewrite spec_addc; auto. - rewrite spec_oppc; ring. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem spec_sub_norm x y: - ([sub_norm x y] == [x] - [y])%Q. - intros x y; unfold sub_norm; rewrite spec_add_norm; auto. - rewrite spec_opp; ring. - Qed. - - Theorem spec_sub_normc x y: - [[sub_norm x y]] = [[x]] - [[y]]. - intros x y; unfold sub_norm; rewrite spec_add_normc; auto. - rewrite spec_oppc; ring. - Qed. - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => Qq (BigZ.mul nx ny) (BigN.mul dx dy) - end. - - Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. - rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH1. - red; simpl; ring. - rewrite BigZ.spec_mul; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH1. - red; simpl; ring. - rewrite BigZ.spec_mul; rewrite Pmult_1_r. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_mul; - intros HH1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH2. - red; simpl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH3. - red; simpl; ring. - case (Zmult_integral _ _ HH1); intros HH. - case HH2; auto. - case HH3; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH2. - case HH1; rewrite HH2; ring. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH3. - case HH1; rewrite HH3; ring. - rewrite BigZ.spec_mul. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - apply Qeq_refl. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dy); auto with zarith. - Qed. - - Theorem spec_mulc x y: - [[mul x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => mul (Qz ny) (norm zx dy) - | Qq nx dx, Qz zy => mul (Qz nx) (norm zy dx) - | Qq nx dx, Qq ny dy => mul (norm nx dy) (norm ny dx) - end. - - Theorem spec_mul_norm x y: - ([mul_norm x y] == [x] * [y])%Q. - intros x y; rewrite <- spec_mul; auto. - unfold mul_norm; case x; case y; clear x y. - intros; apply Qeq_refl. - intros p1 n p2. - repeat rewrite spec_mul. - match goal with |- ?Z == _ => - match Z with context id [norm ?X ?Y] => - let y := context id [Qq X Y] in - apply Qeq_trans with y; [repeat apply Qmult_comp; - repeat apply Qplus_comp; repeat apply Qeq_refl; - apply spec_norm | idtac] - end - end. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH; simpl; ring. - intros p1 p2 n. - repeat rewrite spec_mul. - match goal with |- ?Z == _ => - match Z with context id [norm ?X ?Y] => - let y := context id [Qq X Y] in - apply Qeq_trans with y; [repeat apply Qmult_comp; - repeat apply Qplus_comp; repeat apply Qeq_refl; - apply spec_norm | idtac] - end - end. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH; simpl; try ring. - rewrite Pmult_1_r; auto. - intros p1 n1 p2 n2. - repeat rewrite spec_mul. - repeat match goal with |- ?Z == _ => - match Z with context id [norm ?X ?Y] => - let y := context id [Qq X Y] in - apply Qeq_trans with y; [repeat apply Qmult_comp; - repeat apply Qplus_comp; repeat apply Qeq_refl; - apply spec_norm | idtac] - end - end. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; try ring. - repeat rewrite Zpos_mult_morphism; ring. - Qed. - - Theorem spec_mul_normc x y: - [[mul_norm x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul_norm; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition inv (x: t): t := - match x with - | Qz (BigZ.Pos n) => Qq BigZ.one n - | Qz (BigZ.Neg n) => Qq BigZ.minus_one n - | Qq (BigZ.Pos n) d => Qq (BigZ.Pos d) n - | Qq (BigZ.Neg n) d => Qq (BigZ.Neg d) n - end. - - - Theorem spec_inv x: - ([inv x] == /[x])%Q. - intros [ [x | x] | [nx | nx] dx]; unfold inv, Qinv; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - rewrite H1; apply Qeq_refl. - generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); auto. - intros HH; case HH; auto. - intros; red; simpl; auto. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - rewrite H1; apply Qeq_refl. - generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl; auto. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - apply Qeq_refl. - rewrite H1; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - rewrite H2; red; simpl; auto. - generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - apply Qeq_refl. - rewrite H1; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - rewrite H2; red; simpl; auto. - generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p _ HH; case HH; auto. - Qed. - - Theorem spec_invc x: - [[inv x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition inv_norm (x: t): t := - match x with - | Qz (BigZ.Pos n) => - if BigN.eq_bool n BigN.zero then zero else Qq BigZ.one n - | Qz (BigZ.Neg n) => - if BigN.eq_bool n BigN.zero then zero else Qq BigZ.minus_one n - | Qq (BigZ.Pos n) d => - if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Pos d) n - | Qq (BigZ.Neg n) d => - if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Neg d) n - end. - - Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. - intros x; rewrite <- spec_inv; generalize x; clear x. - intros [ [x | x] | [nx | nx] dx]; unfold inv_norm, inv; - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; try apply Qeq_refl; - red; simpl; - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; auto; - case H2; auto. - Qed. - - Theorem spec_inv_normc x: - [[inv_norm x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv_norm; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition div x y := mul x (inv y). - - Theorem spec_div x y: ([div x y] == [x] / [y])%Q. - intros x y; unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. - intros x y; unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv y). - - Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. - intros x y; unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. - intros x y; unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - - Definition square (x: t): t := - match x with - | Qz zx => Qz (BigZ.square zx) - | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) - end. - - - Theorem spec_square x: ([square x] == [x] ^ 2)%Q. - intros [ x | nx dx]; unfold square. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - simpl Qpower. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H. - red; simpl. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; - intros H1. - case H1; rewrite H; auto. - red; simpl. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; - intros H1. - case H; case (Zmult_integral _ _ H1); auto. - simpl. - rewrite BigZ.spec_square. - rewrite Zpos_mult_morphism. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dx); auto with zarith. - Qed. - - Theorem spec_squarec x: [[square x]] = [[x]]^2. - intros x; unfold to_Qc. - apply trans_equal with (!! ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_square; auto. - simpl Qcpower. - replace (!! [x] * 1) with (!![x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition power_pos (x: t) p: t := - match x with - | Qz zx => Qz (BigZ.power_pos zx p) - | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.power_pos dx p) - end. - - Theorem spec_power_pos x p: ([power_pos x p] == [x] ^ Zpos p)%Q. - Proof. - intros [x | nx dx] p; unfold power_pos. - unfold power_pos; red; simpl. - generalize (Qpower_decomp p (BigZ.to_Z x) 1). - unfold Qeq; simpl. - rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Zmult_1_r. - intros H; rewrite H. - rewrite BigZ.spec_power_pos; simpl; ring. - simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_power_pos; intros H1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2. - elim p; simpl. - intros; red; simpl; auto. - intros p1 Hp1; rewrite <- Hp1; red; simpl; auto. - apply Qeq_refl. - case H2; generalize H1. - elim p; simpl. - intros p1 Hrec. - change (xI p1) with (1 + (xO p1))%positive. - rewrite Zpower_pos_is_exp; rewrite Zpower_pos_1_r. - intros HH; case (Zmult_integral _ _ HH); auto. - rewrite <- Pplus_diag. - rewrite Zpower_pos_is_exp. - intros HH1; case (Zmult_integral _ _ HH1); auto. - intros p1 Hrec. - rewrite <- Pplus_diag. - rewrite Zpower_pos_is_exp. - intros HH1; case (Zmult_integral _ _ HH1); auto. - rewrite Zpower_pos_1_r; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2. - case H1; rewrite H2; auto. - simpl; rewrite Zpower_pos_0_l; auto. - assert (F1: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (F2: (0 < BigN.to_Z dx ^ ' p)%Z). - unfold Zpower; apply Zpower_pos_pos; auto. - unfold power_pos; red; simpl. - generalize (Qpower_decomp p (BigZ.to_Z nx) - (Z2P (BigN.to_Z dx))). - unfold Qeq; simpl. - repeat rewrite Z2P_correct; auto. - unfold Qeq; simpl; intros HH. - rewrite HH. - rewrite BigZ.spec_power_pos; simpl; ring. - Qed. - - Theorem spec_power_posc x p: - [[power_pos x p]] = [[x]] ^ nat_of_P p. - intros x p; unfold to_Qc. - apply trans_equal with (!! ([x]^Zpos p)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_power_pos; auto. - pattern p; apply Pind; clear p. - simpl; ring. - intros p Hrec. - rewrite nat_of_P_succ_morphism; simpl Qcpower. - rewrite <- Hrec. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; - unfold this. - apply Qred_complete. - assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). - simpl; case x; simpl; clear x Hrec. - intros x; simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - intros nx dx. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - unfold Qpower_positive. - assert (tmp: forall p, pow_pos Qmult 0%Q p = 0%Q). - intros p1; elim p1; simpl; auto; clear p1. - intros p1 Hp1; rewrite Hp1; auto. - intros p1 Hp1; rewrite Hp1; auto. - repeat rewrite tmp; intros; red; simpl; auto. - intros H1. - assert (F1: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - repeat rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto. - 2: apply Zpower_pos_pos; auto. - 2: apply Zpower_pos_pos; auto. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - rewrite F. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - -End Qbi. diff --git a/theories/Ints/num/QifMake.v b/theories/Ints/num/QifMake.v deleted file mode 100644 index 83c182ee08..0000000000 --- a/theories/Ints/num/QifMake.v +++ /dev/null @@ -1,971 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import Bool. -Require Import ZArith. -Require Import Znumtheory. -Require Import Zaux. -Require Import Arith. -Require Export BigN. -Require Export BigZ. -Require Import QArith. -Require Import Qcanon. -Require Import Qpower. -Require Import QMake_base. - -Module Qif. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a naturel - number y interpreted as x/y. The pairs (x,0) and (0,y) are all - interpreted as 0. *) - - Definition t := q_type. - - Definition zero: t := Qz BigZ.zero. - Definition one: t := Qz BigZ.one. - Definition minus_one: t := Qz BigZ.minus_one. - - Definition of_Z x: t := Qz (BigZ.of_Z x). - - Definition of_Q q: t := - match q with x # y => - Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) - end. - - Definition of_Qc q := of_Q (this q). - - Definition to_Q (q: t) := - match q with - Qz x => BigZ.to_Z x # 1 - |Qq x y => if BigN.eq_bool y BigN.zero then 0%Q - else BigZ.to_Z x # Z2P (BigN.to_Z y) - end. - - Definition to_Qc q := !!(to_Q q). - - Notation "[[ x ]]" := (to_Qc x). - - Notation "[ x ]" := (to_Q x). - - Theorem spec_to_Q: forall q: Q, [of_Q q] = q. - intros (x,y); simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigN.spec_of_pos; intros HH; discriminate HH. - rewrite BigZ.spec_of_Z; simpl. - rewrite (BigN.spec_of_pos); auto. - Qed. - - Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. - intros (x, Hx); unfold of_Qc, to_Qc; simpl. - apply Qc_decomp; simpl. - intros; rewrite spec_to_Q; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (BigZ.opp zx) - | Qq nx dx => Qq (BigZ.opp nx) dx - end. - - Theorem spec_opp: forall q, ([opp q] = -[q])%Q. - intros [z | x y]; simpl. - rewrite BigZ.spec_opp; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigZ.spec_opp; auto. - Qed. - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - rewrite spec_opp. - rewrite <- Qred_opp. - rewrite Qred_involutive; auto. - Qed. - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => BigZ.compare zx zy - | Qz zx, Qq ny dy => - if BigN.eq_bool dy BigN.zero then BigZ.compare zx BigZ.zero - else BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny - | Qq nx dx, Qz zy => - if BigN.eq_bool dx BigN.zero then BigZ.compare BigZ.zero zy - else BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) - | Qq nx dx, Qq ny dy => - match BigN.eq_bool dx BigN.zero, BigN.eq_bool dy BigN.zero with - | true, true => Eq - | true, false => BigZ.compare BigZ.zero ny - | false, true => BigZ.compare nx BigZ.zero - | false, false => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) - end - end. - - Theorem spec_compare: forall q1 q2, - compare q1 q2 = ([q1] ?= [q2])%Q. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare, to_Q, Qnum, Qden. - repeat rewrite Zmult_1_r. - generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. - rewrite H; rewrite Zcompare_refl; auto. - rewrite Zmult_1_r. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - rewrite Zmult_1_r; generalize (BigZ.spec_compare z1 BigZ.zero); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH1; rewrite HH1; rewrite Zcompare_refl; auto. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (z1 * BigZ.Pos y2) x2)%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare BigZ.zero z2); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH1; rewrite <- HH1; rewrite Zcompare_refl; auto. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y1); auto with zarith. - rewrite Zmult_1_r. - generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1))%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - rewrite Zcompare_refl; auto. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare BigZ.zero x2); - case BigZ.compare; auto. - rewrite BigZ.spec_0; intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - rewrite Zmult_0_l; rewrite Zmult_1_r. - generalize (BigZ.spec_compare x1 BigZ.zero)%bigZ; case BigZ.compare; - auto; rewrite BigZ.spec_0. - intros HH2; rewrite <- HH2; rewrite Zcompare_refl; auto. - repeat rewrite Z2P_correct. - 2: generalize (BigN.spec_pos y1); auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (x1 * BigZ.Pos y2) - (x2 * BigZ.Pos y1))%bigZ; case BigZ.compare; - repeat rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - Qed. - - Definition do_norm_n n := - match n with - | BigN.N0 _ => false - | BigN.N1 _ => false - | BigN.N2 _ => false - | BigN.N3 _ => false - | BigN.N4 _ => false - | BigN.N5 _ => false - | BigN.N6 _ => false - | _ => true - end. - - Definition do_norm_z z := - match z with - | BigZ.Pos n => do_norm_n n - | BigZ.Neg n => do_norm_n n - end. - -(* Je pense que cette fonction normalise bien ... *) - Definition norm n d: t := - if andb (do_norm_z n) (do_norm_n d) then - let gcd := BigN.gcd (BigZ.to_N n) d in - match BigN.compare BigN.one gcd with - | Lt => - let n := BigZ.div n (BigZ.Pos gcd) in - let d := BigN.div d gcd in - match BigN.compare d BigN.one with - | Gt => Qq n d - | Eq => Qz n - | Lt => zero - end - | Eq => Qq n d - | Gt => zero (* gcd = 0 => both numbers are 0 *) - end - else Qq n d. - - Theorem spec_norm: forall n q, - ([norm n q] == [Qq n q])%Q. - intros p q; unfold norm. - case do_norm_z; simpl andb. - 2: apply Qeq_refl. - case do_norm_n. - 2: apply Qeq_refl. - assert (Hp := BigN.spec_pos (BigZ.to_N p)). - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; auto; rewrite BigN.spec_1; rewrite BigN.spec_gcd; intros H1. - apply Qeq_refl. - generalize (BigN.spec_pos (q / BigN.gcd (BigZ.to_N p) q)%bigN). - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; auto; rewrite BigN.spec_1; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; intros H2 HH. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H3; simpl; - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - auto with zarith. - generalize H2; rewrite H3; - rewrite Zdiv_0_l; auto with zarith. - generalize H1 H2 H3 (BigN.spec_pos q); clear H1 H2 H3. - rewrite spec_to_N. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 H4; rewrite Z2P_correct; auto with zarith. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H3; simpl. - case H3. - generalize H1 H2 H3 HH; clear H1 H2 H3 HH. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 HH. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto with zarith. - case (Zle_lt_or_eq _ _ HH); auto with zarith. - intros HH1; rewrite <- HH1; ring. - generalize (Zgcd_is_gcd a b); intros HH1; inversion HH1; auto. - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith; intros H3. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H4. - case H3; rewrite H4; rewrite Zdiv_0_l; auto with zarith. - simpl. - assert (FF := BigN.spec_pos q). - rewrite Z2P_correct; auto with zarith. - rewrite <- BigN.spec_gcd; rewrite <- BigN.spec_div; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto with zarith. - simpl; rewrite BigZ.spec_div; simpl. - rewrite BigN.spec_gcd; auto with zarith. - generalize H1 H2 H3 H4 HH FF; clear H1 H2 H3 H4 HH FF. - set (a := (BigN.to_Z (BigZ.to_N p))). - set (b := (BigN.to_Z q)). - intros H1 H2 H3 H4 HH FF. - rewrite spec_to_N; fold a. - rewrite Zgcd_div_swap; auto with zarith. - rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_div; - rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_gcd; auto with zarith. - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (BigN.gcd (BigZ.to_N p) q))); - rewrite BigN.spec_gcd; auto with zarith. - intros; apply False_ind; auto with zarith. - intros HH2; assert (FF1 := Zgcd_inv_0_l _ _ (sym_equal HH2)). - assert (FF2 := Zgcd_inv_0_l _ _ (sym_equal HH2)). - red; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H2; simpl. - rewrite spec_to_N. - rewrite FF2; ring. - Qed. - - - Definition add (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (BigZ.add zx zy) - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - end - | Qq nx dx => - if BigN.eq_bool dx BigN.zero then y - else match y with - | Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - Qq n d - end - end. - - - Theorem spec_add x y: - ([add x y] == [x] + [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. - rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - assert (F1:= BigN.spec_pos dy). - rewrite Zmult_1_r; red; simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH; simpl; try ring. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH1; simpl; try ring. - case HH; auto. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH; simpl; try ring. - rewrite Zmult_1_r; apply Qeq_refl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; - rewrite BigN.spec_0; intros HH1; simpl; try ring. - case HH; auto. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl; auto. - rewrite Zmult_1_r; rewrite Pmult_1_r. - apply Qeq_refl. - assert (F1:= BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - apply Qeq_refl. - case HH2; auto. - simpl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - case HH2; auto. - case HH1; auto. - rewrite Zmult_1_r; apply Qeq_refl. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - simpl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - case HH; auto. - rewrite Zmult_1_r; rewrite Zplus_0_r; rewrite Pmult_1_r. - apply Qeq_refl. - simpl. - generalize (BigN.spec_eq_bool (dx * dy)%bigN BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_mul; - rewrite BigN.spec_0; intros HH2. - (case (Zmult_integral _ _ HH2); intros HH3); - [case HH| case HH1]; auto. - rewrite BigZ.spec_add; repeat rewrite BigZ.spec_mul; simpl. - assert (Fx: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (Fy: (0 < BigN.to_Z dy)%Z). - generalize (BigN.spec_pos dy); auto with zarith. - red; simpl; rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto with zarith. - apply Zmult_lt_0_compat; auto. - Qed. - - Theorem spec_addc x y: - [[add x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition add_norm (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (BigZ.add zx zy) - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - end - | Qq nx dx => - if BigN.eq_bool dx BigN.zero then y - else match y with - | Qz zy => norm (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq ny dy => - if BigN.eq_bool dy BigN.zero then x - else - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - norm n d - end - end. - - Theorem spec_add_norm x y: - ([add_norm x y] == [x] + [y])%Q. - intros x y; rewrite <- spec_add; auto. - case x; case y; clear x y; unfold add_norm, add. - intros; apply Qeq_refl. - intros p1 n p2. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - simpl. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - apply Qeq_refl. - apply Qeq_refl. - intros p1 p2 n. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - apply Qeq_refl. - intros p1 q1 p2 q2. - generalize (BigN.spec_eq_bool q2 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH1. - apply Qeq_refl. - generalize (BigN.spec_eq_bool q1 BigN.zero); - case BigN.eq_bool; rewrite BigN.spec_0; intros HH2. - apply Qeq_refl. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - apply Qeq_refl. - Qed. - - Theorem spec_add_normc x y: - [[add_norm x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add_norm; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition sub x y := add x (opp y). - - - Theorem spec_sub x y: - ([sub x y] == [x] - [y])%Q. - intros x y; unfold sub; rewrite spec_add; auto. - rewrite spec_opp; ring. - Qed. - - Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. - intros x y; unfold sub; rewrite spec_addc; auto. - rewrite spec_oppc; ring. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem spec_sub_norm x y: - ([sub_norm x y] == [x] - [y])%Q. - intros x y; unfold sub_norm; rewrite spec_add_norm; auto. - rewrite spec_opp; ring. - Qed. - - Theorem spec_sub_normc x y: - [[sub_norm x y]] = [[x]] - [[y]]. - intros x y; unfold sub_norm; rewrite spec_add_normc; auto. - rewrite spec_oppc; ring. - Qed. - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => Qq (BigZ.mul nx ny) (BigN.mul dx dy) - end. - - - Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. - rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH1. - red; simpl; ring. - rewrite BigZ.spec_mul; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH1. - red; simpl; ring. - rewrite BigZ.spec_mul; rewrite Pmult_1_r. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; rewrite BigN.spec_mul; - intros HH1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH2. - red; simpl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH3. - red; simpl; ring. - case (Zmult_integral _ _ HH1); intros HH. - case HH2; auto. - case HH3; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH2. - case HH1; rewrite HH2; ring. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros HH3. - case HH1; rewrite HH3; ring. - rewrite BigZ.spec_mul. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - apply Qeq_refl. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dy); auto with zarith. - Qed. - - Theorem spec_mulc x y: - [[mul x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => norm (BigZ.mul zx ny) dy - | Qq nx dx, Qz zy => norm (BigZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => norm (BigZ.mul nx ny) (BigN.mul dx dy) - end. - - Theorem spec_mul_norm x y: - ([mul_norm x y] == [x] * [y])%Q. - intros x y; rewrite <- spec_mul; auto. - unfold mul_norm, mul; case x; case y; clear x y. - intros; apply Qeq_refl. - intros p1 n p2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end; apply Qeq_refl. - intros p1 p2 n. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end; apply Qeq_refl. - intros p1 n1 p2 n2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end; apply Qeq_refl. - Qed. - - Theorem spec_mul_normc x y: - [[mul_norm x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul_norm; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - - Definition inv (x: t): t := - match x with - | Qz (BigZ.Pos n) => Qq BigZ.one n - | Qz (BigZ.Neg n) => Qq BigZ.minus_one n - | Qq (BigZ.Pos n) d => Qq (BigZ.Pos d) n - | Qq (BigZ.Neg n) d => Qq (BigZ.Neg d) n - end. - - Theorem spec_inv x: - ([inv x] == /[x])%Q. - intros [ [x | x] | [nx | nx] dx]; unfold inv, Qinv; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - rewrite H1; apply Qeq_refl. - generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); auto. - intros HH; case HH; auto. - intros; red; simpl; auto. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - rewrite H1; apply Qeq_refl. - generalize H1 (BigN.spec_pos x); case (BigN.to_Z x); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl; auto. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - apply Qeq_refl. - rewrite H1; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - rewrite H2; red; simpl; auto. - generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - apply Qeq_refl. - rewrite H1; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H2; simpl; auto. - rewrite H2; red; simpl; auto. - generalize H1 (BigN.spec_pos nx); case (BigN.to_Z nx); simpl; - auto. - intros HH; case HH; auto. - intros; red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p _ HH; case HH; auto. - Qed. - - Theorem spec_invc x: - [[inv x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - -Definition inv_norm (x: t): t := - match x with - | Qz (BigZ.Pos n) => - match BigN.compare n BigN.one with - Gt => Qq BigZ.one n - | _ => x - end - | Qz (BigZ.Neg n) => - match BigN.compare n BigN.one with - Gt => Qq BigZ.minus_one n - | _ => x - end - | Qq (BigZ.Pos n) d => - match BigN.compare n BigN.one with - Gt => Qq (BigZ.Pos d) n - | Eq => Qz (BigZ.Pos d) - | Lt => Qz (BigZ.zero) - end - | Qq (BigZ.Neg n) d => - match BigN.compare n BigN.one with - Gt => Qq (BigZ.Neg d) n - | Eq => Qz (BigZ.Neg d) - | Lt => Qz (BigZ.zero) - end - end. - - Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. - intros [ [x | x] | [nx | nx] dx]; unfold inv_norm, Qinv. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H. - simpl; rewrite H; apply Qeq_refl. - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. - generalize H; case BigN.to_Z. - intros _ HH; discriminate HH. - intros p; case p; auto. - intros p1 HH; discriminate HH. - intros p1 HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; discriminate HH. - intros HH; rewrite <- HH. - apply Qeq_refl. - generalize H; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - rewrite H1; intros HH; discriminate. - generalize H; case BigN.to_Z. - intros HH; discriminate HH. - intros; red; simpl; auto. - intros p HH; discriminate HH. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H. - simpl; rewrite H; apply Qeq_refl. - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); simpl. - generalize H; case BigN.to_Z. - intros _ HH; discriminate HH. - intros p; case p; auto. - intros p1 HH; discriminate HH. - intros p1 HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; discriminate HH. - intros HH; rewrite <- HH. - apply Qeq_refl. - generalize H; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - rewrite H1; intros HH; discriminate. - generalize H; case BigN.to_Z. - intros HH; discriminate HH. - intros; red; simpl; auto. - intros p HH; discriminate HH. - simpl Qnum. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; simpl. - case BigN.compare; red; simpl; auto. - rewrite H1; auto. - case BigN.eq_bool; auto. - simpl; rewrite H1; auto. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H2. - rewrite H2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - red; simpl. - rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). - intros; apply Qeq_refl. - intros p; case p; clear p. - intros p HH; discriminate HH. - intros p HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - simpl; generalize H2; case (BigN.to_Z nx). - intros HH; discriminate HH. - intros p Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H4. - rewrite H4 in H2; discriminate H2. - red; simpl. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - intros p HH; discriminate HH. - simpl Qnum. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1; simpl. - case BigN.compare; red; simpl; auto. - rewrite H1; auto. - case BigN.eq_bool; auto. - simpl; rewrite H1; auto. - match goal with |- context[BigN.compare ?X ?Y] => - generalize (BigN.spec_compare X Y); case BigN.compare - end; rewrite BigN.spec_1; intros H2. - rewrite H2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zmult_1_r; rewrite Pmult_1_r; rewrite Z2P_correct; auto. - generalize (BigN.spec_pos dx); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - generalize H2 (BigN.spec_pos nx); case (BigN.to_Z nx). - intros; apply Qeq_refl. - intros p; case p; clear p. - intros p HH; discriminate HH. - intros p HH; discriminate HH. - intros HH; discriminate HH. - intros p _ HH; case HH; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H3. - case H1; auto. - simpl; generalize H2; case (BigN.to_Z nx). - intros HH; discriminate HH. - intros p Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H4. - rewrite H4 in H2; discriminate H2. - red; simpl. - assert (tmp: forall x, Zneg x = Zopp (Zpos x)); auto. - rewrite tmp. - rewrite Zpos_mult_morphism. - rewrite Z2P_correct; auto. - ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p HH; discriminate HH. - Qed. - - Theorem spec_inv_normc x: - [[inv_norm x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv_norm; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition div x y := mul x (inv y). - - Theorem spec_div x y: ([div x y] == [x] / [y])%Q. - intros x y; unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. - intros x y; unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv y). - - Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. - intros x y; unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. - intros x y; unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - - Definition square (x: t): t := - match x with - | Qz zx => Qz (BigZ.square zx) - | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) - end. - - Theorem spec_square x: ([square x] == [x] ^ 2)%Q. - intros [ x | nx dx]; unfold square. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - simpl Qpower. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; intros H. - red; simpl. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; - intros H1. - case H1; rewrite H; auto. - red; simpl. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_square; - intros H1. - case H; case (Zmult_integral _ _ H1); auto. - simpl. - rewrite BigZ.spec_square. - rewrite Zpos_mult_morphism. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dx); auto with zarith. - Qed. - - Theorem spec_squarec x: [[square x]] = [[x]]^2. - intros x; unfold to_Qc. - apply trans_equal with (!! ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_square; auto. - simpl Qcpower. - replace (!! [x] * 1) with (!![x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - -End Qif. diff --git a/theories/Ints/num/QpMake.v b/theories/Ints/num/QpMake.v deleted file mode 100644 index a28434baf2..0000000000 --- a/theories/Ints/num/QpMake.v +++ /dev/null @@ -1,888 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import Bool. -Require Import ZArith. -Require Import Znumtheory. -Require Import Zaux. -Require Import Arith. -Require Export BigN. -Require Export BigZ. -Require Import QArith. -Require Import Qcanon. -Require Import Qpower. -Require Import QMake_base. - -Module Qp. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a naturel - number y interpreted as x/(y+1). *) - - Definition t := q_type. - - Definition zero: t := Qz BigZ.zero. - Definition one: t := Qz BigZ.one. - Definition minus_one: t := Qz BigZ.minus_one. - - Definition of_Z x: t := Qz (BigZ.of_Z x). - - Definition d_to_Z d := BigZ.Pos (BigN.succ d). - - Definition of_Q q: t := - match q with x # y => - Qq (BigZ.of_Z x) (BigN.pred (BigN.of_N (Npos y))) - end. - - Definition of_Qc q := of_Q (this q). - - Definition to_Q (q: t) := - match q with - Qz x => BigZ.to_Z x # 1 - |Qq x y => BigZ.to_Z x # Z2P (BigN.to_Z (BigN.succ y)) - end. - - Definition to_Qc q := !!(to_Q q). - - Notation "[[ x ]]" := (to_Qc x). - - Notation "[ x ]" := (to_Q x). - - Theorem spec_to_Q: forall q: Q, [of_Q q] = q. - intros (x,y); simpl. - rewrite BigZ.spec_of_Z; auto. - rewrite BigN.spec_succ; simpl. simpl. - rewrite BigN.spec_pred; rewrite (BigN.spec_of_pos). - replace (Zpos y - 1 + 1)%Z with (Zpos y); auto; ring. - red; auto. - Qed. - - Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. - intros (x, Hx); unfold of_Qc, to_Qc; simpl. - apply Qc_decomp; simpl. - intros; rewrite spec_to_Q; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (BigZ.opp zx) - | Qq nx dx => Qq (BigZ.opp nx) dx - end. - - - Theorem spec_opp: forall q, ([opp q] = -[q])%Q. - intros [z | x y]; simpl. - rewrite BigZ.spec_opp; auto. - rewrite BigZ.spec_opp; auto. - Qed. - - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - rewrite spec_opp. - rewrite <- Qred_opp. - rewrite Qred_involutive; auto. - Qed. - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => BigZ.compare zx zy - | Qz zx, Qq ny dy => BigZ.compare (BigZ.mul zx (d_to_Z dy)) ny - | Qq nx dy, Qz zy => BigZ.compare nx (BigZ.mul zy (d_to_Z dy)) - | Qq nx dx, Qq ny dy => - BigZ.compare (BigZ.mul nx (d_to_Z dy)) (BigZ.mul ny (d_to_Z dx)) - end. - - Theorem spec_compare: forall q1 q2, - compare q1 q2 = ([q1] ?= [q2])%Q. - intros [z1 | x1 y1] [z2 | x2 y2]; unfold Qcompare; simpl. - repeat rewrite Zmult_1_r. - generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. - rewrite H; rewrite Zcompare_refl; auto. - rewrite Zmult_1_r. - rewrite BigN.spec_succ. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (z1 * d_to_Z y2) x2)%bigZ; case BigZ.compare; - intros H; rewrite <- H. - rewrite BigZ.spec_mul; unfold d_to_Z; simpl. - rewrite BigN.spec_succ. - rewrite Zcompare_refl; auto. - rewrite BigZ.spec_mul; unfold d_to_Z; simpl. - rewrite BigN.spec_succ; auto. - rewrite BigZ.spec_mul; unfold d_to_Z; simpl. - rewrite BigN.spec_succ; auto. - rewrite Zmult_1_r. - rewrite BigN.spec_succ. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y1); auto with zarith. - generalize (BigZ.spec_compare x1 (z2 * d_to_Z y1))%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; unfold d_to_Z; simpl; - rewrite BigN.spec_succ; intros H; auto. - rewrite H; rewrite Zcompare_refl; auto. - repeat rewrite BigN.spec_succ; auto. - repeat rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y1); auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (x1 * d_to_Z y2) - (x2 * d_to_Z y1))%bigZ; case BigZ.compare; - repeat rewrite BigZ.spec_mul; unfold d_to_Z; simpl; - repeat rewrite BigN.spec_succ; intros H; auto. - rewrite H; auto. - rewrite Zcompare_refl; auto. - Qed. - - - Theorem spec_comparec: forall q1 q2, - compare q1 q2 = ([[q1]] ?= [[q2]]). - unfold Qccompare, to_Qc. - intros q1 q2; rewrite spec_compare; simpl. - apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. - Qed. - -(* Inv d > 0, Pour la forme normal unique on veut d > 1 *) - Definition norm n d: t := - if BigZ.eq_bool n BigZ.zero then zero - else - let gcd := BigN.gcd (BigZ.to_N n) d in - if BigN.eq_bool gcd BigN.one then Qq n (BigN.pred d) - else - let n := BigZ.div n (BigZ.Pos gcd) in - let d := BigN.div d gcd in - if BigN.eq_bool d BigN.one then Qz n - else Qq n (BigN.pred d). - - Theorem spec_norm: forall n q, - ((0 < BigN.to_Z q)%Z -> [norm n q] == [Qq n (BigN.pred q)])%Q. - intros p q; unfold norm; intros Hq. - assert (Hp := BigN.spec_pos (BigZ.to_N p)). - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; auto; rewrite BigZ.spec_0; intros H1. - red; simpl; rewrite H1; ring. - case (Zle_lt_or_eq _ _ Hp); clear Hp; intros Hp. - case (Zle_lt_or_eq _ _ - (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p)) (BigN.to_Z q))); intros H4. - 2: generalize Hq; rewrite (Zgcd_inv_0_r _ _ (sym_equal H4)); auto with zarith. - 2: red; simpl; auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_1; intros H2. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_1. - red; simpl. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite Zmult_1_r. - rewrite BigN.succ_pred; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite spec_to_N; intros; rewrite Zgcd_div_swap; auto. - rewrite H; ring. - intros H3. - red; simpl. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.succ_pred; auto with zarith. - assert (F: (0 < BigN.to_Z (q / BigN.gcd (BigZ.to_N p) q)%bigN)%Z). - rewrite BigN.spec_div; auto with zarith. - rewrite BigN.spec_gcd. - apply Zgcd_div_pos; auto. - rewrite BigN.spec_gcd; auto. - rewrite BigN.succ_pred; auto with zarith. - rewrite Z2P_correct; auto. - rewrite Z2P_correct; auto. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite spec_to_N; apply Zgcd_div_swap; auto. - case H1; rewrite spec_to_N; rewrite <- Hp; ring. - Qed. - - Theorem spec_normc: forall n q, - (0 < BigN.to_Z q)%Z -> [[norm n q]] = [[Qq n (BigN.pred q)]]. - intros n q H; unfold to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_norm; auto. - Qed. - - Definition add (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.add zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.add (BigZ.mul zx (d_to_Z dy)) ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.add nx (BigZ.mul zy (d_to_Z dx))) dx - | Qq nx dx, Qq ny dy => - let dx' := BigN.succ dx in - let dy' := BigN.succ dy in - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy')) (BigZ.mul ny (BigZ.Pos dx')) in - let d := BigN.pred (BigN.mul dx' dy') in - Qq n d - end. - - Theorem spec_d_to_Z: forall dy, - (BigZ.to_Z (d_to_Z dy) = BigN.to_Z dy + 1)%Z. - intros dy; unfold d_to_Z; simpl. - rewrite BigN.spec_succ; auto. - Qed. - - Theorem spec_succ_pos: forall p, - (0 < BigN.to_Z (BigN.succ p))%Z. - intros p; rewrite BigN.spec_succ; - generalize (BigN.spec_pos p); auto with zarith. - Qed. - - Theorem spec_add x y: ([add x y] == [x] + [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. - rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. - apply Qeq_refl; auto. - assert (F1:= BigN.spec_pos dy). - rewrite Zmult_1_r. - simpl; rewrite Z2P_correct; rewrite BigN.spec_succ; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul. - rewrite spec_d_to_Z; apply Qeq_refl. - assert (F1:= BigN.spec_pos dx). - rewrite Zmult_1_r; rewrite Pmult_1_r. - simpl; rewrite Z2P_correct; rewrite BigN.spec_succ; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul. - rewrite spec_d_to_Z; apply Qeq_refl. - repeat rewrite BigN.spec_succ. - assert (Fx: (0 < BigN.to_Z dx + 1)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (Fy: (0 < BigN.to_Z dy + 1)%Z). - generalize (BigN.spec_pos dy); auto with zarith. - repeat rewrite BigN.spec_pred. - rewrite BigZ.spec_add; repeat rewrite BigN.spec_mul; - repeat rewrite BigN.spec_succ. - assert (tmp: forall x, (x-1+1 = x)%Z); [intros; ring | rewrite tmp; clear tmp]. - repeat rewrite Z2P_correct; auto. - repeat rewrite BigZ.spec_mul; simpl. - repeat rewrite BigN.spec_succ. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto; apply Qeq_refl. - rewrite BigN.spec_mul; repeat rewrite BigN.spec_succ; auto with zarith. - apply Zmult_lt_0_compat; auto. - Qed. - - Theorem spec_addc x y: [[add x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition add_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.add zx zy) - | Qz zx, Qq ny dy => - let d := BigN.succ dy in - norm (BigZ.add (BigZ.mul zx (BigZ.Pos d)) ny) d - | Qq nx dx, Qz zy => - let d := BigN.succ dx in - norm (BigZ.add (BigZ.mul zy (BigZ.Pos d)) nx) d - | Qq nx dx, Qq ny dy => - let dx' := BigN.succ dx in - let dy' := BigN.succ dy in - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy')) (BigZ.mul ny (BigZ.Pos dx')) in - let d := BigN.mul dx' dy' in - norm n d - end. - - Theorem spec_add_norm x y: ([add_norm x y] == [x] + [y])%Q. - intros x y; rewrite <- spec_add. - unfold add_norm, add; case x; case y. - intros; apply Qeq_refl. - intros p1 n p2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X (BigN.pred Y)]); - [apply spec_norm | idtac] - end. - rewrite BigN.spec_succ; generalize (BigN.spec_pos n); auto with zarith. - simpl. - repeat rewrite BigZ.spec_add. - repeat rewrite BigZ.spec_mul; simpl. - rewrite BigN.succ_pred; try apply Qeq_refl; apply spec_succ_pos. - intros p1 n p2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X (BigN.pred Y)]); - [apply spec_norm | idtac] - end. - rewrite BigN.spec_succ; generalize (BigN.spec_pos p2); auto with zarith. - simpl. - repeat rewrite BigZ.spec_add. - repeat rewrite BigZ.spec_mul; simpl. - rewrite Zplus_comm. - rewrite BigN.succ_pred; try apply Qeq_refl; apply spec_succ_pos. - intros p1 q1 p2 q2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X (BigN.pred Y)]); - [apply spec_norm | idtac] - end; try apply Qeq_refl. - rewrite BigN.spec_mul. - apply Zmult_lt_0_compat; apply spec_succ_pos. - Qed. - - Theorem spec_add_normc x y: [[add_norm x y]] = [[x]] + [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add_norm. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition sub (x y: t): t := add x (opp y). - - Theorem spec_sub x y: ([sub x y] == [x] - [y])%Q. - intros x y; unfold sub; rewrite spec_add. - rewrite spec_opp; ring. - Qed. - - Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. - intros x y; unfold sub; rewrite spec_addc. - rewrite spec_oppc; ring. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem spec_sub_norm x y: ([sub_norm x y] == [x] - [y])%Q. - intros x y; unfold sub_norm; rewrite spec_add_norm. - rewrite spec_opp; ring. - Qed. - - Theorem spec_sub_normc x y: [[sub_norm x y]] = [[x]] - [[y]]. - intros x y; unfold sub_norm; rewrite spec_add_normc. - rewrite spec_oppc; ring. - Qed. - - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => - Qq (BigZ.mul nx ny) (BigN.pred (BigN.mul (BigN.succ dx) (BigN.succ dy))) - end. - - Theorem spec_mul x y: ([mul x y] == [x] * [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. - rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. - apply Qeq_refl; auto. - rewrite BigZ.spec_mul; apply Qeq_refl. - rewrite BigZ.spec_mul; rewrite Pmult_1_r; auto. - apply Qeq_refl; auto. - assert (F1:= spec_succ_pos dx). - assert (F2:= spec_succ_pos dy). - rewrite BigN.succ_pred; rewrite BigN.spec_mul. - rewrite BigZ.spec_mul. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto; apply Qeq_refl. - apply Zmult_lt_0_compat; apply spec_succ_pos. - Qed. - - Theorem spec_mulc x y: [[mul x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => - if BigZ.eq_bool zx BigZ.zero then zero - else - let d := BigN.succ dy in - let gcd := BigN.gcd (BigZ.to_N zx) d in - if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zx ny) dy - else - let zx := BigZ.div zx (BigZ.Pos gcd) in - let d := BigN.div d gcd in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul zx ny) - else Qq (BigZ.mul zx ny) (BigN.pred d) - | Qq nx dx, Qz zy => - if BigZ.eq_bool zy BigZ.zero then zero - else - let d := BigN.succ dx in - let gcd := BigN.gcd (BigZ.to_N zy) d in - if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zy nx) dx - else - let zy := BigZ.div zy (BigZ.Pos gcd) in - let d := BigN.div d gcd in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul zy nx) - else Qq (BigZ.mul zy nx) (BigN.pred d) - | Qq nx dx, Qq ny dy => - norm (BigZ.mul nx ny) (BigN.mul (BigN.succ dx) (BigN.succ dy)) - end. - - Theorem spec_mul_norm x y: ([mul_norm x y] == [x] * [y])%Q. - intros x y; rewrite <- spec_mul. - unfold mul_norm, mul; case x; case y. - intros; apply Qeq_refl. - intros p1 n p2. - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. - rewrite BigZ.spec_mul; rewrite H; red; auto. - assert (F: (0 < BigN.to_Z (BigZ.to_N p2))%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p2))); auto. - intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. - assert (F1: (0 < BigN.to_Z (BigN.succ n))%Z). - rewrite BigN.spec_succ; generalize (BigN.spec_pos n); auto with zarith. - assert (F2: (0 < Zgcd (BigN.to_Z (BigZ.to_N p2)) (BigN.to_Z (BigN.succ n)))%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p2)) - (BigN.to_Z (BigN.succ n)))); intros H3; auto. - generalize F; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; intros H1. - intros; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; - auto with zarith. - intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite spec_to_N. - rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p1)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite (spec_to_N p2). - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (BigN.succ n / - BigN.gcd (BigZ.to_N p2) - (BigN.succ n)))%bigN); intros F3. - rewrite BigN.succ_pred; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p1)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto; try ring. - apply False_ind; generalize F1. - rewrite (Zdivide_Zdiv_eq - (Zgcd (BigN.to_Z (BigZ.to_N p2)) (BigN.to_Z (BigN.succ n))) - (BigN.to_Z (BigN.succ n))); auto. - generalize F3; rewrite BigN.spec_div; rewrite BigN.spec_gcd; - auto with zarith. - intros HH; rewrite <- HH; auto with zarith. - assert (FF:= Zgcd_is_gcd (BigN.to_Z (BigZ.to_N p2)) - (BigN.to_Z (BigN.succ n))); inversion FF; auto. - intros p1 p2 n. - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. - rewrite BigZ.spec_mul; rewrite H; red; simpl; ring. - assert (F: (0 < BigN.to_Z (BigZ.to_N p1))%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p1))); auto. - intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. - assert (F1: (0 < BigN.to_Z (BigN.succ n))%Z). - rewrite BigN.spec_succ; generalize (BigN.spec_pos n); auto with zarith. - assert (F2: (0 < Zgcd (BigN.to_Z (BigZ.to_N p1)) (BigN.to_Z (BigN.succ n)))%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p1)) - (BigN.to_Z (BigN.succ n)))); intros H3; auto. - generalize F; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; intros H1. - intros; repeat rewrite BigZ.spec_mul; rewrite Zmult_comm; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; - auto with zarith. - intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite spec_to_N. - rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p2)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite (spec_to_N p1). - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (BigN.succ n / - BigN.gcd (BigZ.to_N p1) - (BigN.succ n)))%bigN); intros F3. - rewrite BigN.succ_pred; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p2)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto; try ring. - apply False_ind; generalize F1. - rewrite (Zdivide_Zdiv_eq - (Zgcd (BigN.to_Z (BigZ.to_N p1)) (BigN.to_Z (BigN.succ n))) - (BigN.to_Z (BigN.succ n))); auto. - generalize F3; rewrite BigN.spec_div; rewrite BigN.spec_gcd; - auto with zarith. - intros HH; rewrite <- HH; auto with zarith. - assert (FF:= Zgcd_is_gcd (BigN.to_Z (BigZ.to_N p1)) - (BigN.to_Z (BigN.succ n))); inversion FF; auto. - intros p1 n1 p2 n2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X (BigN.pred Y)]); - [apply spec_norm | idtac] - end; try apply Qeq_refl. - rewrite BigN.spec_mul. - apply Zmult_lt_0_compat; rewrite BigN.spec_succ; - generalize (BigN.spec_pos n1) (BigN.spec_pos n2); auto with zarith. - Qed. - - Theorem spec_mul_normc x y: [[mul_norm x y]] = [[x]] * [[y]]. - intros x y; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul_norm. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition inv (x: t): t := - match x with - | Qz (BigZ.Pos n) => - if BigN.eq_bool n BigN.zero then zero else Qq BigZ.one (BigN.pred n) - | Qz (BigZ.Neg n) => - if BigN.eq_bool n BigN.zero then zero else Qq BigZ.minus_one (BigN.pred n) - | Qq (BigZ.Pos n) d => - if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Pos (BigN.succ d)) (BigN.pred n) - | Qq (BigZ.Neg n) d => - if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Neg (BigN.succ d)) (BigN.pred n) - end. - - Theorem spec_inv x: ([inv x] == /[x])%Q. - intros [ [x | x] | [nx | nx] dx]; unfold inv. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z x)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. - unfold to_Q; rewrite BigZ.spec_1. - rewrite BigN.succ_pred; auto. - red; unfold Qinv; simpl. - generalize F; case BigN.to_Z; auto with zarith. - intros p Hp; discriminate Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z x)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. - red; unfold Qinv; simpl. - rewrite BigN.succ_pred; auto. - generalize F; case BigN.to_Z; simpl; auto with zarith. - intros p Hp; discriminate Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z nx)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. - red; unfold Qinv; simpl. - rewrite BigN.succ_pred; auto. - rewrite BigN.spec_succ; rewrite Z2P_correct; auto with zarith. - generalize F; case BigN.to_Z; auto with zarith. - intros p Hp; discriminate Hp. - generalize (BigN.spec_pos dx); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z nx)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. - red; unfold Qinv; simpl. - rewrite BigN.succ_pred; auto. - rewrite BigN.spec_succ; rewrite Z2P_correct; auto with zarith. - generalize F; case BigN.to_Z; auto with zarith. - simpl; intros. - match goal with |- (?X = Zneg ?Y)%Z => - replace (Zneg Y) with (Zopp (Zpos Y)); - try rewrite Z2P_correct; auto with zarith - end. - rewrite Zpos_mult_morphism; - rewrite Z2P_correct; auto with zarith; try ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p Hp; discriminate Hp. - generalize (BigN.spec_pos dx); auto with zarith. - Qed. - - Theorem spec_invc x: [[inv x]] = /[[x]]. - intros x; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - -Definition inv_norm x := - match x with - | Qz (BigZ.Pos n) => - if BigN.eq_bool n BigN.zero then zero else - if BigN.eq_bool n BigN.one then x else Qq BigZ.one (BigN.pred n) - | Qz (BigZ.Neg n) => - if BigN.eq_bool n BigN.zero then zero else - if BigN.eq_bool n BigN.one then x else Qq BigZ.minus_one (BigN.pred n) - | Qq (BigZ.Pos n) d => let d := BigN.succ d in - if BigN.eq_bool n BigN.zero then zero else - if BigN.eq_bool n BigN.one then Qz (BigZ.Pos d) - else Qq (BigZ.Pos d) (BigN.pred n) - | Qq (BigZ.Neg n) d => let d := BigN.succ d in - if BigN.eq_bool n BigN.zero then zero else - if BigN.eq_bool n BigN.one then Qz (BigZ.Neg d) - else Qq (BigZ.Neg d) (BigN.pred n) - end. - - Theorem spec_inv_norm x: ([inv_norm x] == /[x])%Q. - intros x; rewrite <- spec_inv. - (case x; clear x); [intros [x | x] | intros nx dx]; - unfold inv_norm, inv. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - apply Qeq_refl. - assert (F: (0 < BigN.to_Z x)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; intros H1. - red; simpl. - rewrite BigN.succ_pred; auto. - rewrite Z2P_correct; try rewrite H1; auto with zarith. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - apply Qeq_refl. - assert (F: (0 < BigN.to_Z x)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; intros H1. - red; simpl. - rewrite BigN.succ_pred; auto. - rewrite Z2P_correct; try rewrite H1; auto with zarith. - apply Qeq_refl. - case nx; clear nx; intros nx. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; intros H1. - red; simpl. - rewrite BigN.succ_pred; try rewrite H1; auto with zarith. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; intros H1. - red; simpl. - rewrite BigN.succ_pred; try rewrite H1; auto with zarith. - apply Qeq_refl. - Qed. - - - Definition div x y := mul x (inv y). - - Theorem spec_div x y: ([div x y] == [x] / [y])%Q. - intros x y; unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. - intros x y; unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv y). - - Theorem spec_div_norm x y: ([div_norm x y] == [x] / [y])%Q. - intros x y; unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. - intros x y; unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - - Definition square (x: t): t := - match x with - | Qz zx => Qz (BigZ.square zx) - | Qq nx dx => Qq (BigZ.square nx) (BigN.pred (BigN.square (BigN.succ dx))) - end. - - Theorem spec_square x: ([square x] == [x] ^ 2)%Q. - intros [ x | nx dx]; unfold square. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - assert (F: (0 < BigN.to_Z (BigN.succ dx))%Z). - rewrite BigN.spec_succ; - case (Zle_lt_or_eq _ _ (BigN.spec_pos dx)); auto with zarith. - assert (F1 : (0 < BigN.to_Z (BigN.square (BigN.succ dx)))%Z). - rewrite BigN.spec_square; apply Zmult_lt_0_compat; - auto with zarith. - rewrite BigN.succ_pred; auto. - rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto with zarith. - repeat rewrite BigN.spec_succ; auto with zarith. - rewrite BigN.spec_square; auto with zarith. - repeat rewrite BigN.spec_succ; auto with zarith. - Qed. - - Theorem spec_squarec x: [[square x]] = [[x]]^2. - intros x; unfold to_Qc. - apply trans_equal with (!! ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_square. - simpl Qcpower. - replace (!! [x] * 1) with (!![x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition power_pos (x: t) p: t := - match x with - | Qz zx => Qz (BigZ.power_pos zx p) - | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.pred (BigN.power_pos (BigN.succ dx) p)) - end. - - - Theorem spec_power_pos x p: ([power_pos x p] == [x] ^ Zpos p)%Q. - Proof. - intros [x | nx dx] p; unfold power_pos. - unfold power_pos; red; simpl. - generalize (Qpower_decomp p (BigZ.to_Z x) 1). - unfold Qeq; simpl. - rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Zmult_1_r. - intros H; rewrite H. - rewrite BigZ.spec_power_pos; simpl; ring. - assert (F1: (0 < BigN.to_Z (BigN.succ dx))%Z). - rewrite BigN.spec_succ; - generalize (BigN.spec_pos dx); auto with zarith. - assert (F2: (0 < BigN.to_Z (BigN.succ dx) ^ ' p)%Z). - unfold Zpower; apply Zpower_pos_pos; auto. - unfold power_pos; red; simpl. - rewrite BigN.succ_pred; rewrite BigN.spec_power_pos; auto. - rewrite Z2P_correct; auto. - generalize (Qpower_decomp p (BigZ.to_Z nx) - (Z2P (BigN.to_Z (BigN.succ dx)))). - unfold Qeq; simpl. - repeat rewrite Z2P_correct; auto. - unfold Qeq; simpl; intros HH. - rewrite HH. - rewrite BigZ.spec_power_pos; simpl; ring. - Qed. - - Theorem spec_power_posc x p: [[power_pos x p]] = [[x]] ^ nat_of_P p. - intros x p; unfold to_Qc. - apply trans_equal with (!! ([x]^Zpos p)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_power_pos. - pattern p; apply Pind; clear p. - simpl; ring. - intros p Hrec. - rewrite nat_of_P_succ_morphism; simpl Qcpower. - rewrite <- Hrec. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; - unfold this. - apply Qred_complete. - assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). - simpl; case x; simpl; clear x Hrec. - intros x; simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - intros nx dx; simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - assert (F1: (0 < BigN.to_Z (BigN.succ dx))%Z). - rewrite BigN.spec_succ; generalize (BigN.spec_pos dx); - auto with zarith. - repeat rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto. - 2: apply Zpower_pos_pos; auto. - 2: apply Zpower_pos_pos; auto. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - rewrite F. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - -End Qp. diff --git a/theories/Ints/num/QvMake.v b/theories/Ints/num/QvMake.v deleted file mode 100644 index 85655dafcd..0000000000 --- a/theories/Ints/num/QvMake.v +++ /dev/null @@ -1,1143 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import Bool. -Require Import ZArith. -Require Import Znumtheory. -Require Import Zaux. -Require Import Arith. -Require Export BigN. -Require Export BigZ. -Require Import QArith. -Require Import Qcanon. -Require Import Qpower. -Require Import QMake_base. - -Module Qv. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a naturel - number y interpreted as x/y. All functions maintain the invariant - that y is never zero. *) - - Definition t := q_type. - - Definition zero: t := Qz BigZ.zero. - Definition one: t := Qz BigZ.one. - Definition minus_one: t := Qz BigZ.minus_one. - - Definition of_Z x: t := Qz (BigZ.of_Z x). - - Definition wf x := - match x with - | Qz _ => True - | Qq n d => if BigN.eq_bool d BigN.zero then False else True - end. - - Definition of_Q q: t := - match q with x # y => - Qq (BigZ.of_Z x) (BigN.of_N (Npos y)) - end. - - Definition of_Qc q := of_Q (this q). - - Definition to_Q (q: t) := - match q with - Qz x => BigZ.to_Z x # 1 - |Qq x y => BigZ.to_Z x # Z2P (BigN.to_Z y) - end. - - Definition to_Qc q := !!(to_Q q). - - Notation "[[ x ]]" := (to_Qc x). - - Notation "[ x ]" := (to_Q x). - - Theorem spec_to_Q: forall q: Q, [of_Q q] = q. - intros (x,y); simpl. - rewrite BigZ.spec_of_Z; simpl. - rewrite (BigN.spec_of_pos); auto. - Qed. - - Theorem spec_to_Qc: forall q, [[of_Qc q]] = q. - intros (x, Hx); unfold of_Qc, to_Qc; simpl. - apply Qc_decomp; simpl. - intros; rewrite spec_to_Q; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (BigZ.opp zx) - | Qq nx dx => Qq (BigZ.opp nx) dx - end. - - Theorem wf_opp: forall x, wf x -> wf (opp x). - intros [zx | nx dx]; unfold opp, wf; auto. - Qed. - - Theorem spec_opp: forall q, ([opp q] = -[q])%Q. - intros [z | x y]; simpl. - rewrite BigZ.spec_opp; auto. - rewrite BigZ.spec_opp; auto. - Qed. - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - rewrite spec_opp. - rewrite <- Qred_opp. - rewrite Qred_involutive; auto. - Qed. - - (* Les fonctions doivent assurer que si leur arguments sont valides alors - le resultat est correct et valide (si c'est un Q) - *) - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => BigZ.compare zx zy - | Qz zx, Qq ny dy => BigZ.compare (BigZ.mul zx (BigZ.Pos dy)) ny - | Qq nx dx, Qz zy => BigZ.compare nx (BigZ.mul zy (BigZ.Pos dx)) - | Qq nx dx, Qq ny dy => BigZ.compare (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) - end. - - Theorem spec_compare: forall q1 q2, wf q1 -> wf q2 -> - compare q1 q2 = ([q1] ?= [q2])%Q. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare, to_Q, Qnum, Qden, wf. - repeat rewrite Zmult_1_r. - generalize (BigZ.spec_compare z1 z2); case BigZ.compare; intros H; auto. - rewrite H; rewrite Zcompare_refl; auto. - rewrite Zmult_1_r. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool. - intros _ _ HH; case HH. - rewrite BigN.spec_0; intros HH _ _. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (z1 * BigZ.Pos y2) x2)%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH _ _. - rewrite Z2P_correct; auto with zarith. - 2: generalize (BigN.spec_pos y1); auto with zarith. - rewrite Zmult_1_r. - generalize (BigZ.spec_compare x1 (z2 * BigZ.Pos y1))%bigZ; case BigZ.compare; - rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - generalize (BigN.spec_eq_bool y1 BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH1. - generalize (BigN.spec_eq_bool y2 BigN.zero); - case BigN.eq_bool. - intros _ _ HH; case HH. - rewrite BigN.spec_0; intros HH2 _ _. - repeat rewrite Z2P_correct. - 2: generalize (BigN.spec_pos y1); auto with zarith. - 2: generalize (BigN.spec_pos y2); auto with zarith. - generalize (BigZ.spec_compare (x1 * BigZ.Pos y2) - (x2 * BigZ.Pos y1))%bigZ; case BigZ.compare; - repeat rewrite BigZ.spec_mul; simpl; intros H; apply sym_equal; auto. - rewrite H; rewrite Zcompare_refl; auto. - Qed. - - Theorem spec_comparec: forall q1 q2, wf q1 -> wf q2 -> - compare q1 q2 = ([[q1]] ?= [[q2]]). - unfold Qccompare, to_Qc. - intros q1 q2 Hq1 Hq2; rewrite spec_compare; simpl; auto. - apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition norm n d: t := - if BigZ.eq_bool n BigZ.zero then zero - else - let gcd := BigN.gcd (BigZ.to_N n) d in - if BigN.eq_bool gcd BigN.one then Qq n d - else - let n := BigZ.div n (BigZ.Pos gcd) in - let d := BigN.div d gcd in - if BigN.eq_bool d BigN.one then Qz n - else Qq n d. - - Theorem wf_norm: forall n q, - (BigN.to_Z q <> 0)%Z -> wf (norm n q). - intros p q; unfold norm, wf; intros Hq. - assert (Hp := BigN.spec_pos (BigZ.to_N p)). - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; auto; rewrite BigZ.spec_0; intros H1. - simpl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_1. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - set (a := BigN.to_Z (BigZ.to_N p)). - set (b := (BigN.to_Z q)). - assert (F: (0 < Zgcd a b)%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); auto. - intros HH1; case Hq; apply (Zgcd_inv_0_r _ _ (sym_equal HH1)). - rewrite BigN.spec_div; rewrite BigN.spec_gcd; auto; fold a; fold b. - intros H; case Hq; fold b. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite H; auto with zarith. - assert (F1:= Zgcd_is_gcd a b); inversion F1; auto. - Qed. - - Theorem spec_norm: forall n q, - ((0 < BigN.to_Z q)%Z -> [norm n q] == [Qq n q])%Q. - intros p q; unfold norm; intros Hq. - assert (Hp := BigN.spec_pos (BigZ.to_N p)). - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; auto; rewrite BigZ.spec_0; intros H1. - red; simpl; rewrite H1; ring. - case (Zle_lt_or_eq _ _ Hp); clear Hp; intros Hp. - case (Zle_lt_or_eq _ _ - (Zgcd_is_pos (BigN.to_Z (BigZ.to_N p)) (BigN.to_Z q))); intros H4. - 2: generalize Hq; rewrite (Zgcd_inv_0_r _ _ (sym_equal H4)); auto with zarith. - 2: red; simpl; auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_1; intros H2. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_1. - red; simpl. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite Zmult_1_r. - rewrite Z2P_correct; auto with zarith. - rewrite spec_to_N; intros; rewrite Zgcd_div_swap; auto. - rewrite H; ring. - intros H3. - red; simpl. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - assert (F: (0 < BigN.to_Z (q / BigN.gcd (BigZ.to_N p) q)%bigN)%Z). - rewrite BigN.spec_div; auto with zarith. - rewrite BigN.spec_gcd. - apply Zgcd_div_pos; auto. - rewrite BigN.spec_gcd; auto. - rewrite Z2P_correct; auto. - rewrite Z2P_correct; auto. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; auto with zarith. - rewrite spec_to_N; apply Zgcd_div_swap; auto. - case H1; rewrite spec_to_N; rewrite <- Hp; ring. - Qed. - - Theorem spec_normc: forall n q, - (0 < BigN.to_Z q)%Z -> [[norm n q]] = [[Qq n q]]. - intros n q H; unfold to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_norm; auto. - Qed. - - Definition add (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.add zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.add nx (BigZ.mul zy (BigZ.Pos dx))) dx - | Qq nx dx, Qq ny dy => - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - Qq n d - end. - - Theorem wf_add: forall x y, wf x -> wf y -> wf (add x y). - intros [zx | nx dx] [zy | ny dy]; unfold add, wf; auto. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. - intros H1 H2 H3. - case (Zmult_integral _ _ H1); auto with zarith. - Qed. - - Theorem spec_add x y: wf x -> wf y -> - ([add x y] == [x] + [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qplus; simpl. - rewrite BigZ.spec_add; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - assert (F1:= BigN.spec_pos dy). - rewrite Zmult_1_r. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool. - intros _ _ HH; case HH. - rewrite BigN.spec_0; intros HH _ _. - rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul. - simpl; apply Qeq_refl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH _ _. - assert (F1:= BigN.spec_pos dx). - rewrite Zmult_1_r; rewrite Pmult_1_r. - simpl; rewrite Z2P_correct; auto with zarith. - rewrite BigZ.spec_add; rewrite BigZ.spec_mul; simpl. - apply Qeq_refl. - generalize (BigN.spec_eq_bool dx BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH1. - generalize (BigN.spec_eq_bool dy BigN.zero); - case BigN.eq_bool. - intros _ _ HH; case HH. - rewrite BigN.spec_0; intros HH2 _ _. - assert (Fx: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (Fy: (0 < BigN.to_Z dy)%Z). - generalize (BigN.spec_pos dy); auto with zarith. - rewrite BigZ.spec_add; repeat rewrite BigN.spec_mul. - red; simpl. - rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto. - repeat rewrite BigZ.spec_mul; simpl; auto. - apply Zmult_lt_0_compat; auto. - Qed. - - Theorem spec_addc x y: wf x -> wf y -> - [[add x y]] = [[x]] + [[y]]. - intros x y H1 H2; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition add_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.add zx zy) - | Qz zx, Qq ny dy => - norm (BigZ.add (BigZ.mul zx (BigZ.Pos dy)) ny) dy - | Qq nx dx, Qz zy => - norm (BigZ.add (BigZ.mul zy (BigZ.Pos dx)) nx) dx - | Qq nx dx, Qq ny dy => - let n := BigZ.add (BigZ.mul nx (BigZ.Pos dy)) (BigZ.mul ny (BigZ.Pos dx)) in - let d := BigN.mul dx dy in - norm n d - end. - - Theorem wf_add_norm: forall x y, wf x -> wf y -> wf (add_norm x y). - intros [zx | nx dx] [zy | ny dy]; unfold add_norm; auto. - intros HH1 HH2; apply wf_norm. - generalize HH2; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros HH1 HH2; apply wf_norm. - generalize HH1; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros HH1 HH2; apply wf_norm. - rewrite BigN.spec_mul; intros HH3. - case (Zmult_integral _ _ HH3). - generalize HH1; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - generalize HH2; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - Qed. - - Theorem spec_add_norm x y: wf x -> wf y -> - ([add_norm x y] == [x] + [y])%Q. - intros x y H1 H2; rewrite <- spec_add; auto. - generalize H1 H2; unfold add_norm, add, wf; case x; case y; clear H1 H2. - intros; apply Qeq_refl. - intros p1 n p2 _. - generalize (BigN.spec_eq_bool n BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH _. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - generalize (BigN.spec_pos n); auto with zarith. - simpl. - repeat rewrite BigZ.spec_add. - repeat rewrite BigZ.spec_mul; simpl. - apply Qeq_refl. - intros p1 n p2. - generalize (BigN.spec_eq_bool p2 BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH _ _. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end. - generalize (BigN.spec_pos p2); auto with zarith. - simpl. - repeat rewrite BigZ.spec_add. - repeat rewrite BigZ.spec_mul; simpl. - rewrite Zplus_comm. - apply Qeq_refl. - intros p1 q1 p2 q2. - generalize (BigN.spec_eq_bool q2 BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH1 _. - generalize (BigN.spec_eq_bool q1 BigN.zero); - case BigN.eq_bool. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH2 _. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end; try apply Qeq_refl. - rewrite BigN.spec_mul. - apply Zmult_lt_0_compat. - generalize (BigN.spec_pos q2); auto with zarith. - generalize (BigN.spec_pos q1); auto with zarith. - Qed. - - Theorem spec_add_normc x y: wf x -> wf y -> - [[add_norm x y]] = [[x]] + [[y]]. - intros x y Hx Hy; unfold to_Qc. - apply trans_equal with (!! ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_add_norm; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition sub x y := add x (opp y). - - Theorem wf_sub x y: wf x -> wf y -> wf (sub x y). - intros x y Hx Hy; unfold sub; apply wf_add; auto. - apply wf_opp; auto. - Qed. - - Theorem spec_sub x y: wf x -> wf y -> - ([sub x y] == [x] - [y])%Q. - intros x y Hx Hy; unfold sub; rewrite spec_add; auto. - rewrite spec_opp; ring. - apply wf_opp; auto. - Qed. - - Theorem spec_subc x y: wf x -> wf y -> - [[sub x y]] = [[x]] - [[y]]. - intros x y Hx Hy; unfold sub; rewrite spec_addc; auto. - rewrite spec_oppc; ring. - apply wf_opp; auto. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem wf_sub_norm x y: wf x -> wf y -> wf (sub_norm x y). - intros x y Hx Hy; unfold sub_norm; apply wf_add_norm; auto. - apply wf_opp; auto. - Qed. - - Theorem spec_sub_norm x y: wf x -> wf y -> - ([sub_norm x y] == [x] - [y])%Q. - intros x y Hx Hy; unfold sub_norm; rewrite spec_add_norm; auto. - rewrite spec_opp; ring. - apply wf_opp; auto. - Qed. - - Theorem spec_sub_normc x y: wf x -> wf y -> - [[sub_norm x y]] = [[x]] - [[y]]. - intros x y Hx Hy; unfold sub_norm; rewrite spec_add_normc; auto. - rewrite spec_oppc; ring. - apply wf_opp; auto. - Qed. - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (BigZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (BigZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => - Qq (BigZ.mul nx ny) (BigN.mul dx dy) - end. - - Theorem wf_mul: forall x y, wf x -> wf y -> wf (mul x y). - intros [zx | nx dx] [zy | ny dy]; unfold mul, wf; auto. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. - intros H1 H2 H3. - case (Zmult_integral _ _ H1); auto with zarith. - Qed. - - Theorem spec_mul x y: wf x -> wf y -> ([mul x y] == [x] * [y])%Q. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl. - rewrite BigZ.spec_mul; repeat rewrite Zmult_1_r; auto. - intros; apply Qeq_refl; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros _ _ HH; case HH. - rewrite BigN.spec_0; intros HH1 _ _. - rewrite BigZ.spec_mul; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros _ HH; case HH. - rewrite BigN.spec_0; intros HH1 _ _. - rewrite BigZ.spec_mul; rewrite Pmult_1_r. - apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros _ HH; case HH. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros _ _ _ HH; case HH. - rewrite BigN.spec_0; intros H1 H2 _ _. - rewrite BigZ.spec_mul; rewrite BigN.spec_mul. - assert (tmp: - (forall a b, 0 < a -> 0 < b -> Z2P (a * b) = (Z2P a * Z2P b)%positive)%Z). - intros [|a|a] [|b|b]; simpl; auto; intros; apply False_ind; auto with zarith. - rewrite tmp; auto. - apply Qeq_refl. - generalize (BigN.spec_pos dx); auto with zarith. - generalize (BigN.spec_pos dy); auto with zarith. - Qed. - - Theorem spec_mulc x y: wf x -> wf y -> - [[mul x y]] = [[x]] * [[y]]. - intros x y Hx Hy; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (BigZ.mul zx zy) - | Qz zx, Qq ny dy => - if BigZ.eq_bool zx BigZ.zero then zero - else - let gcd := BigN.gcd (BigZ.to_N zx) dy in - if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zx ny) dy - else - let zx := BigZ.div zx (BigZ.Pos gcd) in - let d := BigN.div dy gcd in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul zx ny) - else Qq (BigZ.mul zx ny) d - | Qq nx dx, Qz zy => - if BigZ.eq_bool zy BigZ.zero then zero - else - let gcd := BigN.gcd (BigZ.to_N zy) dx in - if BigN.eq_bool gcd BigN.one then Qq (BigZ.mul zy nx) dx - else - let zy := BigZ.div zy (BigZ.Pos gcd) in - let d := BigN.div dx gcd in - if BigN.eq_bool d BigN.one then Qz (BigZ.mul zy nx) - else Qq (BigZ.mul zy nx) d - | Qq nx dx, Qq ny dy => norm (BigZ.mul nx ny) (BigN.mul dx dy) - end. - - Theorem wf_mul_norm: forall x y, wf x -> wf y -> wf (mul_norm x y). - intros [zx | nx dx] [zy | ny dy]; unfold mul_norm; auto. - intros HH1 HH2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - rewrite BigN.spec_1; rewrite BigZ.spec_0. - intros H1 H2; unfold wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - rewrite BigN.spec_0. - set (a := BigN.to_Z (BigZ.to_N zx)). - set (b := (BigN.to_Z dy)). - assert (F: (0 < Zgcd a b)%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); auto. - intros HH3; case H2; rewrite spec_to_N; fold a. - rewrite (Zgcd_inv_0_l _ _ (sym_equal HH3)); try ring. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a; fold b; auto. - intros H. - generalize HH2; simpl wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - rewrite BigN.spec_0; intros HH; case HH; fold b. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite H; auto with zarith. - assert (F1:= Zgcd_is_gcd a b); inversion F1; auto. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - rewrite BigN.spec_1; rewrite BigN.spec_gcd. - intros HH1 H1 H2. - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; auto. - rewrite BigN.spec_1; rewrite BigN.spec_gcd. - intros HH1 H1 H2. - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; auto. - rewrite BigZ.spec_0. - intros HH2. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - set (a := BigN.to_Z (BigZ.to_N zy)). - set (b := (BigN.to_Z dx)). - assert (F: (0 < Zgcd a b)%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); auto. - intros HH3; case HH2; rewrite spec_to_N; fold a. - rewrite (Zgcd_inv_0_l _ _ (sym_equal HH3)); try ring. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a; fold b; auto. - intros H; unfold wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - rewrite BigN.spec_0. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a; fold b; auto. - intros HH; generalize H1; simpl wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - rewrite BigN.spec_0. - intros HH3; case HH3; fold b. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite HH; auto with zarith. - assert (F1:= Zgcd_is_gcd a b); inversion F1; auto. - intros HH1 HH2; apply wf_norm. - rewrite BigN.spec_mul; intros HH3. - case (Zmult_integral _ _ HH3). - generalize HH1; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - generalize HH2; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - Qed. - - Theorem spec_mul_norm x y: wf x -> wf y -> - ([mul_norm x y] == [x] * [y])%Q. - intros x y Hx Hy; rewrite <- spec_mul; auto. - unfold mul_norm, mul; generalize Hx Hy; case x; case y; clear Hx Hy. - intros; apply Qeq_refl. - intros p1 n p2 Hx Hy. - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. - rewrite BigZ.spec_mul; rewrite H; red; auto. - assert (F: (0 < BigN.to_Z (BigZ.to_N p2))%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p2))); auto. - intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. - assert (F1: (0 < BigN.to_Z n)%Z). - generalize Hy; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto. - intros _ HH; case HH. - rewrite BigN.spec_0; generalize (BigN.spec_pos n); auto with zarith. - set (a := BigN.to_Z (BigZ.to_N p2)). - set (b := BigN.to_Z n). - assert (F2: (0 < Zgcd a b )%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); intros H3; auto. - generalize F; fold a; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; try rewrite BigN.spec_gcd; - fold a b; intros H1. - intros; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; - auto with zarith; fold a b; intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite spec_to_N; fold a; fold b. - rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p1)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - intros H2; red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite Z2P_correct; auto with zarith. - rewrite (spec_to_N p2); fold a b. - rewrite Z2P_correct; auto with zarith. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p1)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto; try ring. - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (n / - BigN.gcd (BigZ.to_N p2) - n))%bigN); - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - intros H3. - apply False_ind; generalize F1. - generalize Hy; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; auto with zarith. - intros HH; case HH; fold b. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - rewrite <- H3; ring. - assert (FF:= Zgcd_is_gcd a b); inversion FF; auto. - intros p1 p2 n Hx Hy. - match goal with |- context[BigZ.eq_bool ?X ?Y] => - generalize (BigZ.spec_eq_bool X Y); case BigZ.eq_bool - end; unfold zero, to_Q; repeat rewrite BigZ.spec_0; intros H. - rewrite BigZ.spec_mul; rewrite H; red; simpl; ring. - set (a := BigN.to_Z (BigZ.to_N p1)). - set (b := BigN.to_Z n). - assert (F: (0 < a)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos (BigZ.to_N p1))); auto. - intros H1; case H; rewrite spec_to_N; rewrite <- H1; ring. - assert (F1: (0 < b)%Z). - generalize Hx; unfold wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; auto with zarith. - generalize (BigN.spec_pos n); fold b; auto with zarith. - assert (F2: (0 < Zgcd a b)%Z). - case (Zle_lt_or_eq _ _ (Zgcd_is_pos a b)); intros H3; auto. - generalize F; rewrite (Zgcd_inv_0_l _ _ (sym_equal H3)); auto with zarith. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1; rewrite BigN.spec_gcd; fold a b; intros H1. - intros; repeat rewrite BigZ.spec_mul; rewrite Zmult_comm; apply Qeq_refl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_1. - rewrite BigN.spec_div; rewrite BigN.spec_gcd; - auto with zarith. - fold a b; intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite spec_to_N; fold a b. - rewrite Zmult_1_r; repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p2)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto with zarith. - rewrite H2; ring. - intros H2. - red; simpl. - repeat rewrite BigZ.spec_mul. - rewrite BigZ.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - rewrite Z2P_correct; auto with zarith. - rewrite (spec_to_N p1); fold a b. - case (Zle_lt_or_eq _ _ - (BigN.spec_pos (n / BigN.gcd (BigZ.to_N p1) n))%bigN); intros F3. - rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_div; simpl; rewrite BigN.spec_gcd; - fold a b; auto with zarith. - repeat rewrite <- Zmult_assoc. - rewrite (Zmult_comm (BigZ.to_Z p2)). - repeat rewrite Zmult_assoc. - rewrite Zgcd_div_swap; auto; try ring. - apply False_ind; generalize F1. - rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto. - generalize F3; rewrite BigN.spec_div; rewrite BigN.spec_gcd; fold a b; - auto with zarith. - intros HH; rewrite <- HH; auto with zarith. - assert (FF:= Zgcd_is_gcd a b); inversion FF; auto. - intros p1 n1 p2 n2 Hn1 Hn2. - match goal with |- [norm ?X ?Y] == _ => - apply Qeq_trans with ([Qq X Y]); - [apply spec_norm | idtac] - end; try apply Qeq_refl. - rewrite BigN.spec_mul. - apply Zmult_lt_0_compat. - generalize Hn1; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; auto with zarith. - generalize (BigN.spec_pos n1) (BigN.spec_pos n2); auto with zarith. - generalize Hn2; simpl. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; auto with zarith. - generalize (BigN.spec_pos n1) (BigN.spec_pos n2); auto with zarith. - Qed. - - Theorem spec_mul_normc x y: wf x -> wf y -> - [[mul_norm x y]] = [[x]] * [[y]]. - intros x y Hx Hy; unfold to_Qc. - apply trans_equal with (!! ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_mul_norm; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Definition inv (x: t): t := - match x with - | Qz (BigZ.Pos n) => - if BigN.eq_bool n BigN.zero then zero else Qq BigZ.one n - | Qz (BigZ.Neg n) => - if BigN.eq_bool n BigN.zero then zero else Qq BigZ.minus_one n - | Qq (BigZ.Pos n) d => - if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Pos d) n - | Qq (BigZ.Neg n) d => - if BigN.eq_bool n BigN.zero then zero else Qq (BigZ.Neg d) n - end. - - - Theorem wf_inv: forall x, wf x -> wf (inv x). - intros [ zx | nx dx]; unfold inv, wf; auto. - case zx; clear zx. - intros nx. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. - intros nx. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0; rewrite BigN.spec_mul. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - intros _ HH; case HH. - intros H1 _. - case nx; clear nx. - intros nx. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; simpl; auto. - intros nx. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; simpl; auto. - Qed. - - Theorem spec_inv x: wf x -> - ([inv x] == /[x])%Q. - intros [ [x | x] _ | [nx | nx] dx]; unfold inv. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z x)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. - unfold to_Q; rewrite BigZ.spec_1. - red; unfold Qinv; simpl. - generalize F; case BigN.to_Z; auto with zarith. - intros p Hp; discriminate Hp. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z x)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos x)); auto with zarith. - red; unfold Qinv; simpl. - generalize F; case BigN.to_Z; simpl; auto with zarith. - intros p Hp; discriminate Hp. - simpl wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - intros HH; case HH. - intros _. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z nx)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. - red; unfold Qinv; simpl. - rewrite Z2P_correct; auto with zarith. - generalize F; case BigN.to_Z; auto with zarith. - intros p Hp; discriminate Hp. - generalize (BigN.spec_pos dx); auto with zarith. - simpl wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H1. - intros HH; case HH. - intros _. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; rewrite BigN.spec_0; intros H. - unfold zero, to_Q; rewrite BigZ.spec_0. - unfold BigZ.to_Z; rewrite H; apply Qeq_refl. - assert (F: (0 < BigN.to_Z nx)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos nx)); auto with zarith. - red; unfold Qinv; simpl. - rewrite Z2P_correct; auto with zarith. - generalize F; case BigN.to_Z; auto with zarith. - simpl; intros. - match goal with |- (?X = Zneg ?Y)%Z => - replace (Zneg Y) with (Zopp (Zpos Y)); - try rewrite Z2P_correct; auto with zarith - end. - rewrite Zpos_mult_morphism; - rewrite Z2P_correct; auto with zarith; try ring. - generalize (BigN.spec_pos dx); auto with zarith. - intros p Hp; discriminate Hp. - generalize (BigN.spec_pos dx); auto with zarith. - Qed. - - Theorem spec_invc x: wf x -> - [[inv x]] = /[[x]]. - intros x Hx; unfold to_Qc. - apply trans_equal with (!! (/[x])). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_inv; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition div x y := mul x (inv y). - - Theorem wf_div x y: wf x -> wf y -> wf (div x y). - intros x y Hx Hy; unfold div; apply wf_mul; auto. - apply wf_inv; auto. - Qed. - - Theorem spec_div x y: wf x -> wf y -> - ([div x y] == [x] / [y])%Q. - intros x y Hx Hy; unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - apply wf_inv; auto. - Qed. - - Theorem spec_divc x y: wf x -> wf y -> - [[div x y]] = [[x]] / [[y]]. - intros x y Hx Hy; unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - apply wf_inv; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv y). - - Theorem wf_div_norm x y: wf x -> wf y -> wf (div_norm x y). - intros x y Hx Hy; unfold div_norm; apply wf_mul_norm; auto. - apply wf_inv; auto. - Qed. - - Theorem spec_div_norm x y: wf x -> wf y -> - ([div_norm x y] == [x] / [y])%Q. - intros x y Hx Hy; unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - apply wf_inv; auto. - Qed. - - Theorem spec_div_normc x y: wf x -> wf y -> - [[div_norm x y]] = [[x]] / [[y]]. - intros x y Hx Hy; unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - apply wf_inv; auto. - Qed. - - Definition square (x: t): t := - match x with - | Qz zx => Qz (BigZ.square zx) - | Qq nx dx => Qq (BigZ.square nx) (BigN.square dx) - end. - - Theorem wf_square: forall x, wf x -> wf (square x). - intros [ zx | nx dx]; unfold square, wf; auto. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigN.spec_square; intros H1 H2; case H2. - case (Zmult_integral _ _ H1); auto. - Qed. - - Theorem spec_square x: wf x -> ([square x] == [x] ^ 2)%Q. - intros [ x | nx dx]; unfold square. - intros _. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - unfold wf. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - intros _ HH; case HH. - intros H1 _. - red; simpl; rewrite BigZ.spec_square; auto with zarith. - assert (F: (0 < BigN.to_Z dx)%Z). - case (Zle_lt_or_eq _ _ (BigN.spec_pos dx)); auto with zarith. - assert (F1 : (0 < BigN.to_Z (BigN.square dx))%Z). - rewrite BigN.spec_square; apply Zmult_lt_0_compat; - auto with zarith. - rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto with zarith. - rewrite BigN.spec_square; auto with zarith. - Qed. - - Theorem spec_squarec x: wf x -> [[square x]] = [[x]]^2. - intros x Hx; unfold to_Qc. - apply trans_equal with (!! ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_square; auto. - simpl Qcpower. - replace (!! [x] * 1) with (!![x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - - Definition power_pos (x: t) p: t := - match x with - | Qz zx => Qz (BigZ.power_pos zx p) - | Qq nx dx => Qq (BigZ.power_pos nx p) (BigN.power_pos dx p) - end. - - Theorem wf_power_pos: forall x p, wf x -> wf (power_pos x p). - intros [ zx | nx dx] p; unfold power_pos, wf; auto. - repeat match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - rewrite BigN.spec_power_pos; simpl. - intros H1 H2 _. - case (Zle_lt_or_eq _ _ (BigN.spec_pos dx)); auto with zarith. - intros H3; generalize (Zpower_pos_pos _ p H3); auto with zarith. - Qed. - - Theorem spec_power_pos x p: wf x -> ([power_pos x p] == [x] ^ Zpos p)%Q. - Proof. - intros [x | nx dx] p; unfold power_pos. - intros _; unfold power_pos; red; simpl. - generalize (Qpower_decomp p (BigZ.to_Z x) 1). - unfold Qeq; simpl. - rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Zmult_1_r. - intros H; rewrite H. - rewrite BigZ.spec_power_pos; simpl; ring. - unfold wf. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - intros _ HH; case HH. - intros H1 _. - assert (F1: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - assert (F2: (0 < BigN.to_Z dx ^ ' p)%Z). - unfold Zpower; apply Zpower_pos_pos; auto. - unfold power_pos; red; simpl. - rewrite Z2P_correct; rewrite BigN.spec_power_pos; auto. - generalize (Qpower_decomp p (BigZ.to_Z nx) - (Z2P (BigN.to_Z dx))). - unfold Qeq; simpl. - repeat rewrite Z2P_correct; auto. - unfold Qeq; simpl; intros HH. - rewrite HH. - rewrite BigZ.spec_power_pos; simpl; ring. - Qed. - - Theorem spec_power_posc x p: wf x -> - [[power_pos x p]] = [[x]] ^ nat_of_P p. - intros x p Hx; unfold to_Qc. - apply trans_equal with (!! ([x]^Zpos p)). - unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. - apply Qred_complete; apply spec_power_pos; auto. - pattern p; apply Pind; clear p. - simpl; ring. - intros p Hrec. - rewrite nat_of_P_succ_morphism; simpl Qcpower. - rewrite <- Hrec. - unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; - unfold this. - apply Qred_complete. - assert (F: [x] ^ ' Psucc p == [x] * [x] ^ ' p). - simpl; generalize Hx; case x; simpl; clear x Hx Hrec. - intros x _; simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - intros nx dx. - match goal with |- context[BigN.eq_bool ?X ?Y] => - generalize (BigN.spec_eq_bool X Y); case BigN.eq_bool - end; auto; rewrite BigN.spec_0. - intros _ HH; case HH. - intros H1 _. - assert (F1: (0 < BigN.to_Z dx)%Z). - generalize (BigN.spec_pos dx); auto with zarith. - simpl; repeat rewrite Qpower_decomp; simpl. - red; simpl; repeat rewrite Zpower_pos_1_l; simpl Z2P. - rewrite Pplus_one_succ_l. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - repeat rewrite Zpos_mult_morphism. - repeat rewrite Z2P_correct; auto. - 2: apply Zpower_pos_pos; auto. - 2: apply Zpower_pos_pos; auto. - rewrite Zpower_pos_is_exp. - rewrite Zpower_pos_1_r; auto. - rewrite F. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - -End Qv. - diff --git a/theories/Ints/num/ZMake.v b/theories/Ints/num/ZMake.v deleted file mode 100644 index 75fc19584d..0000000000 --- a/theories/Ints/num/ZMake.v +++ /dev/null @@ -1,558 +0,0 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) - -Require Import ZArith. -Require Import Zaux. - -Open Scope Z_scope. - -Module Type NType. - - Parameter t : Set. - - Parameter zero : t. - Parameter one : t. - - Parameter of_N : N -> t. - Parameter to_Z : t -> Z. - Parameter spec_pos: forall x, 0 <= to_Z x. - Parameter spec_0: to_Z zero = 0. - Parameter spec_1: to_Z one = 1. - Parameter spec_of_N: forall x, to_Z (of_N x) = Z_of_N x. - - Parameter compare : t -> t -> comparison. - - Parameter spec_compare: forall x y, - match compare x y with - Eq => to_Z x = to_Z y - | Lt => to_Z x < to_Z y - | Gt => to_Z x > to_Z y - end. - - Parameter eq_bool : t -> t -> bool. - - Parameter spec_eq_bool: forall x y, - if eq_bool x y then to_Z x = to_Z y else to_Z x <> to_Z y. - - Parameter succ : t -> t. - - Parameter spec_succ: forall n, to_Z (succ n) = to_Z n + 1. - - Parameter add : t -> t -> t. - - Parameter spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. - - Parameter pred : t -> t. - - Parameter spec_pred: forall x, 0 < to_Z x -> to_Z (pred x) = to_Z x - 1. - - Parameter sub : t -> t -> t. - - Parameter spec_sub: forall x y, to_Z y <= to_Z x -> - to_Z (sub x y) = to_Z x - to_Z y. - - Parameter mul : t -> t -> t. - - Parameter spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y. - - Parameter square : t -> t. - - Parameter spec_square: forall x, to_Z (square x) = to_Z x * to_Z x. - - Parameter power_pos : t -> positive -> t. - - Parameter spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n. - - Parameter sqrt : t -> t. - - Parameter spec_sqrt: forall x, to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2. - - Parameter div_eucl : t -> t -> t * t. - - Parameter spec_div_eucl: forall x y, - 0 < to_Z y -> - let (q,r) := div_eucl x y in (to_Z q, to_Z r) = (Zdiv_eucl (to_Z x) (to_Z y)). - - Parameter div : t -> t -> t. - - Parameter spec_div: forall x y, - 0 < to_Z y -> to_Z (div x y) = to_Z x / to_Z y. - - Parameter modulo : t -> t -> t. - - Parameter spec_modulo: - forall x y, 0 < to_Z y -> to_Z (modulo x y) = to_Z x mod to_Z y. - - Parameter gcd : t -> t -> t. - - Parameter spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b). - - -End NType. - -Module Make (N:NType). - - Inductive t_ : Set := - | Pos : N.t -> t_ - | Neg : N.t -> t_. - - Definition t := t_. - - Definition zero := Pos N.zero. - Definition one := Pos N.one. - Definition minus_one := Neg N.one. - - Definition of_Z x := - match x with - | Zpos x => Pos (N.of_N (Npos x)) - | Z0 => zero - | Zneg x => Neg (N.of_N (Npos x)) - end. - - Definition to_Z x := - match x with - | Pos nx => N.to_Z nx - | Neg nx => Zopp (N.to_Z nx) - end. - - Theorem spec_of_Z: forall x, to_Z (of_Z x) = x. - intros x; case x; unfold to_Z, of_Z, zero. - exact N.spec_0. - intros; rewrite N.spec_of_N; auto. - intros; rewrite N.spec_of_N; auto. - Qed. - - - Theorem spec_0: to_Z zero = 0. - exact N.spec_0. - Qed. - - Theorem spec_1: to_Z one = 1. - exact N.spec_1. - Qed. - - Theorem spec_m1: to_Z minus_one = -1. - simpl; rewrite N.spec_1; auto. - Qed. - - Definition compare x y := - match x, y with - | Pos nx, Pos ny => N.compare nx ny - | Pos nx, Neg ny => - match N.compare nx N.zero with - | Gt => Gt - | _ => N.compare ny N.zero - end - | Neg nx, Pos ny => - match N.compare N.zero nx with - | Lt => Lt - | _ => N.compare N.zero ny - end - | Neg nx, Neg ny => N.compare ny nx - end. - - - Theorem spec_compare: forall x y, - match compare x y with - Eq => to_Z x = to_Z y - | Lt => to_Z x < to_Z y - | Gt => to_Z x > to_Z y - end. - unfold compare, to_Z; intros x y; case x; case y; clear x y; - intros x y; auto; generalize (N.spec_pos x) (N.spec_pos y). - generalize (N.spec_compare y x); case N.compare; auto with zarith. - generalize (N.spec_compare y N.zero); case N.compare; - try rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare x N.zero); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare x N.zero); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero y); case N.compare; - try rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare x y); case N.compare; auto with zarith. - Qed. - - Definition eq_bool x y := - match compare x y with - | Eq => true - | _ => false - end. - - Theorem spec_eq_bool: forall x y, - if eq_bool x y then to_Z x = to_Z y else to_Z x <> to_Z y. - intros x y; unfold eq_bool; - generalize (spec_compare x y); case compare; auto with zarith. - Qed. - - Definition cmp_sign x y := - match x, y with - | Pos nx, Neg ny => - if N.eq_bool ny N.zero then Eq else Gt - | Neg nx, Pos ny => - if N.eq_bool nx N.zero then Eq else Lt - | _, _ => Eq - end. - - Theorem spec_cmp_sign: forall x y, - match cmp_sign x y with - | Gt => 0 <= to_Z x /\ to_Z y < 0 - | Lt => to_Z x < 0 /\ 0 <= to_Z y - | Eq => True - end. - Proof. - intros [x | x] [y | y]; unfold cmp_sign; auto. - generalize (N.spec_eq_bool y N.zero); case N.eq_bool; auto. - rewrite N.spec_0; unfold to_Z. - generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. - generalize (N.spec_eq_bool x N.zero); case N.eq_bool; auto. - rewrite N.spec_0; unfold to_Z. - generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. - Qed. - - Definition to_N x := - match x with - | Pos nx => nx - | Neg nx => nx - end. - - Definition abs x := Pos (to_N x). - - Theorem spec_abs: forall x, to_Z (abs x) = Zabs (to_Z x). - intros x; case x; clear x; intros x; assert (F:=N.spec_pos x). - simpl; rewrite Zabs_eq; auto. - simpl; rewrite Zabs_non_eq; simpl; auto with zarith. - Qed. - - Definition opp x := - match x with - | Pos nx => Neg nx - | Neg nx => Pos nx - end. - - Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x. - intros x; case x; simpl; auto with zarith. - Qed. - - Definition succ x := - match x with - | Pos n => Pos (N.succ n) - | Neg n => - match N.compare N.zero n with - | Lt => Neg (N.pred n) - | _ => one - end - end. - - Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1. - intros x; case x; clear x; intros x. - exact (N.spec_succ x). - simpl; generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; simpl. - intros HH; rewrite <- HH; rewrite N.spec_1; ring. - intros HH; rewrite N.spec_pred; auto with zarith. - generalize (N.spec_pos x); auto with zarith. - Qed. - - Definition add x y := - match x, y with - | Pos nx, Pos ny => Pos (N.add nx ny) - | Pos nx, Neg ny => - match N.compare nx ny with - | Gt => Pos (N.sub nx ny) - | Eq => zero - | Lt => Neg (N.sub ny nx) - end - | Neg nx, Pos ny => - match N.compare nx ny with - | Gt => Neg (N.sub nx ny) - | Eq => zero - | Lt => Pos (N.sub ny nx) - end - | Neg nx, Neg ny => Neg (N.add nx ny) - end. - - Theorem spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. - unfold add, to_Z; intros [x | x] [y | y]. - exact (N.spec_add x y). - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_add; try ring; auto with zarith. - Qed. - - Definition pred x := - match x with - | Pos nx => - match N.compare N.zero nx with - | Lt => Pos (N.pred nx) - | _ => minus_one - end - | Neg nx => Neg (N.succ nx) - end. - - Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1. - unfold pred, to_Z, minus_one; intros [x | x]. - generalize (N.spec_compare N.zero x); case N.compare; - rewrite N.spec_0; try rewrite N.spec_1; auto with zarith. - intros H; exact (N.spec_pred _ H). - generalize (N.spec_pos x); auto with zarith. - rewrite N.spec_succ; ring. - Qed. - - Definition sub x y := - match x, y with - | Pos nx, Pos ny => - match N.compare nx ny with - | Gt => Pos (N.sub nx ny) - | Eq => zero - | Lt => Neg (N.sub ny nx) - end - | Pos nx, Neg ny => Pos (N.add nx ny) - | Neg nx, Pos ny => Neg (N.add nx ny) - | Neg nx, Neg ny => - match N.compare nx ny with - | Gt => Neg (N.sub nx ny) - | Eq => zero - | Lt => Pos (N.sub ny nx) - end - end. - - Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y. - unfold sub, to_Z; intros [x | x] [y | y]. - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - rewrite N.spec_add; ring. - rewrite N.spec_add; ring. - unfold zero; generalize (N.spec_compare x y); case N.compare. - rewrite N.spec_0; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - intros; rewrite N.spec_sub; try ring; auto with zarith. - Qed. - - Definition mul x y := - match x, y with - | Pos nx, Pos ny => Pos (N.mul nx ny) - | Pos nx, Neg ny => Neg (N.mul nx ny) - | Neg nx, Pos ny => Neg (N.mul nx ny) - | Neg nx, Neg ny => Pos (N.mul nx ny) - end. - - - Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y. - unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring. - Qed. - - Definition square x := - match x with - | Pos nx => Pos (N.square nx) - | Neg nx => Pos (N.square nx) - end. - - Theorem spec_square: forall x, to_Z (square x) = to_Z x * to_Z x. - unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring. - Qed. - - Definition power_pos x p := - match x with - | Pos nx => Pos (N.power_pos nx p) - | Neg nx => - match p with - | xH => x - | xO _ => Pos (N.power_pos nx p) - | xI _ => Neg (N.power_pos nx p) - end - end. - - Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n. - assert (F0: forall x, (-x)^2 = x^2). - intros x; rewrite Zpower_2; ring. - unfold power_pos, to_Z; intros [x | x] [p | p |]; - try rewrite N.spec_power_pos; try ring. - assert (F: 0 <= 2 * Zpos p). - assert (0 <= Zpos p); auto with zarith. - rewrite Zpos_xI; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Zpower_mult; auto with zarith. - rewrite F0; ring. - assert (F: 0 <= 2 * Zpos p). - assert (0 <= Zpos p); auto with zarith. - rewrite Zpos_xO; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Zpower_mult; auto with zarith. - rewrite F0; ring. - Qed. - - Definition sqrt x := - match x with - | Pos nx => Pos (N.sqrt nx) - | Neg nx => Neg N.zero - end. - - - Theorem spec_sqrt: forall x, 0 <= to_Z x -> - to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2. - unfold to_Z, sqrt; intros [x | x] H. - exact (N.spec_sqrt x). - replace (N.to_Z x) with 0. - rewrite N.spec_0; simpl Zpower; unfold Zpower_pos, iter_pos; - auto with zarith. - generalize (N.spec_pos x); auto with zarith. - Qed. - - Definition div_eucl x y := - match x, y with - | Pos nx, Pos ny => - let (q, r) := N.div_eucl nx ny in - (Pos q, Pos r) - | Pos nx, Neg ny => - let (q, r) := N.div_eucl nx ny in - match N.compare N.zero r with - | Eq => (Neg q, zero) - | _ => (Neg (N.succ q), Neg (N.sub ny r)) - end - | Neg nx, Pos ny => - let (q, r) := N.div_eucl nx ny in - match N.compare N.zero r with - | Eq => (Neg q, zero) - | _ => (Neg (N.succ q), Pos (N.sub ny r)) - end - | Neg nx, Neg ny => - let (q, r) := N.div_eucl nx ny in - (Pos q, Neg r) - end. - - - Theorem spec_div_eucl: forall x y, - to_Z y <> 0 -> - let (q,r) := div_eucl x y in - (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y). - unfold div_eucl, to_Z; intros [x | x] [y | y] H. - assert (H1: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. - assert (HH: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. - intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); - try (intros; apply False_ind; auto with zarith; fail). - intros p He1 He2 _ _ H1; injection H1; intros H2 H3. - generalize (N.spec_compare N.zero r); case N.compare; - unfold zero; rewrite N.spec_0; try rewrite H3; auto. - rewrite H2; intros; apply False_ind; auto with zarith. - rewrite H2; intros; apply False_ind; auto with zarith. - intros p _ _ _ H1; discriminate H1. - intros p He p1 He1 H1 _. - generalize (N.spec_compare N.zero r); case N.compare. - change (- Zpos p) with (Zneg p). - unfold zero; lazy zeta. - rewrite N.spec_0; intros H2; rewrite <- H2. - intros H3; rewrite <- H3; auto. - rewrite N.spec_0; intros H2. - change (- Zpos p) with (Zneg p); lazy iota beta. - intros H3; rewrite <- H3; auto. - rewrite N.spec_succ; rewrite N.spec_sub. - generalize H2; case (N.to_Z r). - intros; apply False_ind; auto with zarith. - intros p2 _; rewrite He; auto with zarith. - change (Zneg p) with (- (Zpos p)); apply f_equal2 with (f := @pair Z Z); ring. - intros p2 H4; discriminate H4. - assert (N.to_Z r = (Zpos p1 mod (Zpos p))). - unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. - case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. - rewrite N.spec_0; intros H2; generalize (N.spec_pos r); - intros; apply False_ind; auto with zarith. - assert (HH: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. - intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); - try (intros; apply False_ind; auto with zarith; fail). - intros p He1 He2 _ _ H1; injection H1; intros H2 H3. - generalize (N.spec_compare N.zero r); case N.compare; - unfold zero; rewrite N.spec_0; try rewrite H3; auto. - rewrite H2; intros; apply False_ind; auto with zarith. - rewrite H2; intros; apply False_ind; auto with zarith. - intros p _ _ _ H1; discriminate H1. - intros p He p1 He1 H1 _. - generalize (N.spec_compare N.zero r); case N.compare. - change (- Zpos p1) with (Zneg p1). - unfold zero; lazy zeta. - rewrite N.spec_0; intros H2; rewrite <- H2. - intros H3; rewrite <- H3; auto. - rewrite N.spec_0; intros H2. - change (- Zpos p1) with (Zneg p1); lazy iota beta. - intros H3; rewrite <- H3; auto. - rewrite N.spec_succ; rewrite N.spec_sub. - generalize H2; case (N.to_Z r). - intros; apply False_ind; auto with zarith. - intros p2 _; rewrite He; auto with zarith. - intros p2 H4; discriminate H4. - assert (N.to_Z r = (Zpos p1 mod (Zpos p))). - unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. - case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. - rewrite N.spec_0; generalize (N.spec_pos r); intros; apply False_ind; auto with zarith. - assert (H1: 0 < N.to_Z y). - generalize (N.spec_pos y); auto with zarith. - generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. - intros q r; generalize (N.spec_pos x) H1; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); - try (intros; apply False_ind; auto with zarith; fail). - change (-0) with 0; lazy iota beta; auto. - intros p _ _ _ _ H2; injection H2. - intros H3 H4; rewrite H3; rewrite H4; auto. - intros p _ _ _ H2; discriminate H2. - intros p He p1 He1 _ _ H2. - change (- Zpos p1) with (Zneg p1); lazy iota beta. - change (- Zpos p) with (Zneg p); lazy iota beta. - rewrite <- H2; auto. - Qed. - - Definition div x y := fst (div_eucl x y). - - Definition spec_div: forall x y, - to_Z y <> 0 -> to_Z (div x y) = to_Z x / to_Z y. - intros x y H1; generalize (spec_div_eucl x y H1); unfold div, Zdiv. - case div_eucl; case Zdiv_eucl; simpl; auto. - intros q r q11 r1 H; injection H; auto. - Qed. - - Definition modulo x y := snd (div_eucl x y). - - Theorem spec_modulo: - forall x y, to_Z y <> 0 -> to_Z (modulo x y) = to_Z x mod to_Z y. - intros x y H1; generalize (spec_div_eucl x y H1); unfold modulo, Zmod. - case div_eucl; case Zdiv_eucl; simpl; auto. - intros q r q11 r1 H; injection H; auto. - Qed. - - Definition gcd x y := - match x, y with - | Pos nx, Pos ny => Pos (N.gcd nx ny) - | Pos nx, Neg ny => Pos (N.gcd nx ny) - | Neg nx, Pos ny => Pos (N.gcd nx ny) - | Neg nx, Neg ny => Pos (N.gcd nx ny) - end. - - Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b). - unfold gcd, Zgcd, to_Z; intros [x | x] [y | y]; rewrite N.spec_gcd; unfold Zgcd; - auto; case N.to_Z; simpl; auto with zarith; - try rewrite Zabs_Zopp; auto; - case N.to_Z; simpl; auto with zarith. - Qed. - -End Make. diff --git a/theories/Ints/num/Zn2Z.v b/theories/Ints/num/Zn2Z.v deleted file mode 100644 index 48cf268409..0000000000 --- a/theories/Ints/num/Zn2Z.v +++ /dev/null @@ -1,917 +0,0 @@ - -(*************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(*************************************************************) -(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) -(*************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Zaux. -Require Import Basic_type. -Require Import GenBase. -Require Import GenAdd. -Require Import GenSub. -Require Import GenMul. -Require Import GenSqrt. -Require Import GenLift. -Require Import GenDivn1. -Require Import GenDiv. -Require Import ZnZ. - -Open Local Scope Z_scope. - - -Section Zn2Z. - - Variable w : Set. - Variable w_op : znz_op w. - Let w_digits := w_op.(znz_digits). - Let w_zdigits := w_op.(znz_zdigits). - - Let w_to_Z := w_op.(znz_to_Z). - Let w_of_pos := w_op.(znz_of_pos). - Let w_head0 := w_op.(znz_head0). - Let w_tail0 := w_op.(znz_tail0). - - Let w_0 := w_op.(znz_0). - Let w_1 := w_op.(znz_1). - Let w_Bm1 := w_op.(znz_Bm1). - - Let w_WW := w_op.(znz_WW). - Let w_W0 := w_op.(znz_W0). - Let w_0W := w_op.(znz_0W). - - Let w_compare := w_op.(znz_compare). - Let w_eq0 := w_op.(znz_eq0). - - Let w_opp_c := w_op.(znz_opp_c). - Let w_opp := w_op.(znz_opp). - Let w_opp_carry := w_op.(znz_opp_carry). - - Let w_succ_c := w_op.(znz_succ_c). - Let w_add_c := w_op.(znz_add_c). - Let w_add_carry_c := w_op.(znz_add_carry_c). - Let w_succ := w_op.(znz_succ). - Let w_add := w_op.(znz_add). - Let w_add_carry := w_op.(znz_add_carry). - - Let w_pred_c := w_op.(znz_pred_c). - Let w_sub_c := w_op.(znz_sub_c). - Let w_sub_carry_c := w_op.(znz_sub_carry_c). - Let w_pred := w_op.(znz_pred). - Let w_sub := w_op.(znz_sub). - Let w_sub_carry := w_op.(znz_sub_carry). - - - Let w_mul_c := w_op.(znz_mul_c). - Let w_mul := w_op.(znz_mul). - Let w_square_c := w_op.(znz_square_c). - - Let w_div21 := w_op.(znz_div21). - Let w_div_gt := w_op.(znz_div_gt). - Let w_div := w_op.(znz_div). - - Let w_mod_gt := w_op.(znz_mod_gt). - Let w_mod := w_op.(znz_mod). - - Let w_gcd_gt := w_op.(znz_gcd_gt). - Let w_gcd := w_op.(znz_gcd). - - Let w_add_mul_div := w_op.(znz_add_mul_div). - - Let w_pos_mod := w_op.(znz_pos_mod). - - Let w_is_even := w_op.(znz_is_even). - Let w_sqrt2 := w_op.(znz_sqrt2). - Let w_sqrt := w_op.(znz_sqrt). - - Let _zn2z := zn2z w. - - Let wB := base w_digits. - - Let w_Bm2 := w_pred w_Bm1. - - Let ww_1 := ww_1 w_0 w_1. - Let ww_Bm1 := ww_Bm1 w_Bm1. - - Let w_add2 a b := match w_add_c a b with C0 p => WW w_0 p | C1 p => WW w_1 p end. - - Let _ww_digits := xO w_digits. - - Let _ww_zdigits := w_add2 w_zdigits w_zdigits. - - Let to_Z := zn2z_to_Z wB w_to_Z. - - Let ww_of_pos p := - match w_of_pos p with - | (N0, l) => (N0, WW w_0 l) - | (Npos ph,l) => - let (n,h) := w_of_pos ph in (n, w_WW h l) - end. - - - Let head0 := - Eval lazy beta delta [ww_head0] in - ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits. - - Let tail0 := - Eval lazy beta delta [ww_tail0] in - ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits. - - Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w). - Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W w). - Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 w). - - (* ** Comparison ** *) - Let compare := - Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. - - Let eq0 (x:zn2z w) := - match x with - | W0 => true - | _ => false - end. - - (* ** Opposites ** *) - Let opp_c := - Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry. - - Let opp := - Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp. - - Let opp_carry := - Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. - - (* ** Additions ** *) - - Let succ_c := - Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c. - - Let add_c := - Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. - - Let add_carry_c := - Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in - ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. - - Let succ := - Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. - - Let add := - Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. - - Let add_carry := - Eval lazy beta iota delta [ww_add_carry ww_succ] in - ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. - - (* ** Subtractions ** *) - - Let pred_c := - Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. - - Let sub_c := - Eval lazy beta iota delta [ww_sub_c ww_opp_c] in - ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. - - Let sub_carry_c := - Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in - ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c. - - Let pred := - Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. - - Let sub := - Eval lazy beta iota delta [ww_sub ww_opp] in - ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. - - Let sub_carry := - Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in - ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred - w_sub w_sub_carry. - - - (* ** Multiplication ** *) - - Let mul_c := - Eval lazy beta iota delta [ww_mul_c gen_mul_c] in - ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry. - - Let karatsuba_c := - Eval lazy beta iota delta [ww_karatsuba_c gen_mul_c kara_prod] in - ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c - add_c add add_carry sub_c sub. - - Let mul := - Eval lazy beta delta [ww_mul] in - ww_mul w_W0 w_add w_mul_c w_mul add. - - Let square_c := - Eval lazy beta delta [ww_square_c] in - ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry. - - (* Division operation *) - - Let div32 := - Eval lazy beta iota delta [w_div32] in - w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c - w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. - - Let div21 := - Eval lazy beta iota delta [ww_div21] in - ww_div21 w_0 w_0W div32 ww_1 compare sub. - - Let low (p: zn2z w) := match p with WW _ p1 => p1 | _ => w_0 end. - - Let add_mul_div := - Eval lazy beta delta [ww_add_mul_div] in - ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low. - - Let div_gt := - Eval lazy beta delta [ww_div_gt] in - ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry - w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits. - - Let div := - Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. - - Let mod_gt := - Eval lazy beta delta [ww_mod_gt] in - ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry - w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits. - - Let mod_ := - Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. - - Let pos_mod := - Eval lazy beta delta [ww_pos_mod] in - ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits. - - Let is_even := - Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. - - Let sqrt2 := - Eval lazy beta delta [ww_sqrt2] in - ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c - w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c - pred add_c add sub_c add_mul_div. - - Let sqrt := - Eval lazy beta delta [ww_sqrt] in - ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits - _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low. - - Let gcd_gt_fix := - Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in - ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry - w_sub_c w_sub w_sub_carry w_gcd_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div - w_zdigits. - - Let gcd_cont := - Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. - - Let gcd_gt := - Eval lazy beta delta [ww_gcd_gt] in - ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. - - Let gcd := - Eval lazy beta delta [ww_gcd] in - ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. - - (* ** Record of operators on 2 words *) - - Definition mk_zn2z_op := - mk_znz_op _ww_digits _ww_zdigits - to_Z ww_of_pos head0 tail0 - W0 ww_1 ww_Bm1 - ww_WW ww_W0 ww_0W - compare eq0 - opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c - pred sub sub_carry - mul_c mul square_c - div21 div_gt div - mod_gt mod_ - gcd_gt gcd - add_mul_div - pos_mod - is_even - sqrt2 - sqrt. - - Definition mk_zn2z_op_karatsuba := - mk_znz_op _ww_digits _ww_zdigits - to_Z ww_of_pos head0 tail0 - W0 ww_1 ww_Bm1 - ww_WW ww_W0 ww_0W - compare eq0 - opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c - pred sub sub_carry - karatsuba_c mul square_c - div21 div_gt div - mod_gt mod_ - gcd_gt gcd - add_mul_div - pos_mod - is_even - sqrt2 - sqrt. - - (* Proof *) - Variable op_spec : znz_spec w_op. - - Hint Resolve - (spec_to_Z op_spec) - (spec_of_pos op_spec) - (spec_0 op_spec) - (spec_1 op_spec) - (spec_Bm1 op_spec) - (spec_WW op_spec) - (spec_0W op_spec) - (spec_W0 op_spec) - (spec_compare op_spec) - (spec_eq0 op_spec) - (spec_opp_c op_spec) - (spec_opp op_spec) - (spec_opp_carry op_spec) - (spec_succ_c op_spec) - (spec_add_c op_spec) - (spec_add_carry_c op_spec) - (spec_succ op_spec) - (spec_add op_spec) - (spec_add_carry op_spec) - (spec_pred_c op_spec) - (spec_sub_c op_spec) - (spec_sub_carry_c op_spec) - (spec_pred op_spec) - (spec_sub op_spec) - (spec_sub_carry op_spec) - (spec_mul_c op_spec) - (spec_mul op_spec) - (spec_square_c op_spec) - (spec_div21 op_spec) - (spec_div_gt op_spec) - (spec_div op_spec) - (spec_mod_gt op_spec) - (spec_mod op_spec) - (spec_gcd_gt op_spec) - (spec_gcd op_spec) - (spec_head0 op_spec) - (spec_tail0 op_spec) - (spec_add_mul_div op_spec) - (spec_pos_mod) - (spec_is_even) - (spec_sqrt2) - (spec_sqrt). - - Let wwB := base _ww_digits. - - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - Notation "[+| c |]" := - (interp_carry 1 wwB to_Z c) (at level 0, x at level 99). - - Notation "[-| c |]" := - (interp_carry (-1) wwB to_Z c) (at level 0, x at level 99). - - Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x) (at level 0, x at level 99). - - Let spec_ww_to_Z : forall x, 0 <= [| x |] < wwB. - Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed. - - Let spec_ww_of_pos : forall p, - Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|]. - Proof. - unfold ww_of_pos;intros. - assert (H:= spec_of_pos op_spec p);unfold w_of_pos; - destruct (znz_of_pos w_op p). simpl in H. - rewrite H;clear H;destruct n;simpl to_Z. - simpl;unfold w_to_Z,w_0;rewrite (spec_0 op_spec);trivial. - unfold Z_of_N; assert (H:= spec_of_pos op_spec p0); - destruct (znz_of_pos w_op p0). simpl in H. - rewrite H;unfold fst, snd,Z_of_N, w_WW, to_Z. - rewrite (spec_WW op_spec). replace wwB with (wB*wB). - unfold wB,w_digits;clear H;destruct n;ring. - symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits). - Qed. - - Let spec_ww_0 : [|W0|] = 0. - Proof. reflexivity. Qed. - - Let spec_ww_1 : [|ww_1|] = 1. - Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed. - - Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - - Let spec_ww_WW : forall h l, [[ww_WW h l]] = [|h|] * wwB + [|l|]. - Proof. - intros h l. replace wwB with (wB*wB). destruct h;simpl. - destruct l;simpl;ring. ring. - symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits). - Qed. - - Let spec_ww_0W : forall l, [[ww_0W l]] = [|l|]. - Proof. - intros l. replace wwB with (wB*wB). - destruct l;simpl;ring. - symmetry. ring_simplify; exact (wwB_wBwB w_digits). - Qed. - - Let spec_ww_W0 : forall h, [[ww_W0 h]] = [|h|]*wwB. - Proof. - intros h. replace wwB with (wB*wB). - destruct h;simpl;ring. - symmetry. ring_simplify; exact (wwB_wBwB w_digits). - Qed. - - Let spec_ww_compare : - forall x y, - match compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end. - Proof. - refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. - exact (spec_compare op_spec). - Qed. - - Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. - Proof. destruct x;simpl;intros;trivial;discriminate. Qed. - - Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. - Proof. - refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _); - auto. - Qed. - - Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. - Proof. - refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp - w_digits w_to_Z _ _ _ _ _); - auto. - Qed. - - Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1. - Proof. - refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _); - auto. exact (spec_WW op_spec). - Qed. - - Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. - Proof. - refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto. - Qed. - - Let spec_ww_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. - Proof. - refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);auto. - exact (spec_WW op_spec). - Qed. - - Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1. - Proof. - refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c - w_digits w_to_Z _ _ _ _ _ _ _);auto. exact (spec_WW op_spec). - Qed. - - Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB. - Proof. - refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _); - auto. exact (spec_W0 op_spec). - Qed. - - Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB. - Proof. - refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto. - Qed. - - Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. - Proof. - refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ - w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);auto. - exact (spec_W0 op_spec). - Qed. - - Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. - Proof. - refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z - _ _ _ _ _);auto. exact (spec_WW op_spec). - Qed. - - Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. - Proof. - refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c - w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);auto. exact (spec_WW op_spec). - Qed. - - Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. - Proof. - refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c - w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - Qed. - - Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB. - Proof. - refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z - _ _ _ _ _ _);auto. exact (spec_WW op_spec). - Qed. - - Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB. - Proof. - refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp - w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - Qed. - - Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB. - Proof. - refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c - w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _); - auto. exact (spec_WW op_spec). - Qed. - - Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|]. - Proof. - refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits - w_to_Z _ _ _ _ _ _ _ _ _);auto. exact (spec_WW op_spec). - exact (spec_W0 op_spec). exact (spec_mul_c op_spec). - Qed. - - Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|]. - Proof. - refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _); auto. - unfold w_digits; apply spec_more_than_1_digit; auto. - exact (spec_WW op_spec). - exact (spec_W0 op_spec). - exact (spec_compare op_spec). - exact (spec_mul_c op_spec). - Qed. - - Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. - Proof. - refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); - auto. exact (spec_W0 op_spec). exact (spec_mul_c op_spec). - Qed. - - Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. - Proof. - refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add - add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). exact (spec_W0 op_spec). - exact (spec_mul_c op_spec). exact (spec_square_c op_spec). - Qed. - - Let spec_w_div32 : forall a1 a2 a3 b1 b2, - wB / 2 <= (w_to_Z b1) -> - [|WW a1 a2|] < [|WW b1 b2|] -> - let (q, r) := div32 a1 a2 a3 b1 b2 in - (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) = - (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\ - 0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2. - Proof. - refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c - w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. - unfold w_Bm2, w_to_Z, w_pred, w_Bm1. - rewrite (spec_pred op_spec);rewrite (spec_Bm1 op_spec). - unfold w_digits;rewrite Zmod_small. ring. - assert (H:= wB_pos(znz_digits w_op)). omega. - exact (spec_WW op_spec). exact (spec_compare op_spec). - exact (spec_mul_c op_spec). exact (spec_div21 op_spec). - Qed. - - Let spec_ww_div21 : forall a1 a2 b, - wwB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := div21 a1 a2 b in - [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z - _ _ _ _ _ _ _);auto. exact (spec_0W op_spec). - Qed. - - Let spec_add2: forall x y, - [|w_add2 x y|] = w_to_Z x + w_to_Z y. - unfold w_add2. - intros xh xl; generalize (spec_add_c op_spec xh xl). - unfold w_add_c; case znz_add_c; unfold interp_carry; simpl ww_to_Z. - intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0. - unfold w_0; rewrite spec_0; simpl; auto with zarith. - intros w0; rewrite Zmult_1_l; simpl. - unfold w_to_Z, w_1; rewrite spec_1; auto with zarith. - rewrite Zmult_1_l; auto. - Qed. - - Let spec_low: forall x, - w_to_Z (low x) = [|x|] mod wB. - intros x; case x; simpl low. - unfold ww_to_Z, w_to_Z, w_0; rewrite (spec_0 op_spec); simpl. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - unfold wB, base; auto with zarith. - intros xh xl; simpl. - rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith. - rewrite Zmod_small; auto with zarith. - unfold wB, base; auto with zarith. - Qed. - - Let spec_ww_digits: - [|_ww_zdigits|] = Zpos (xO w_digits). - Proof. - unfold w_to_Z, _ww_zdigits. - rewrite spec_add2. - unfold w_to_Z, w_zdigits, w_digits. - rewrite spec_zdigits; auto. - rewrite Zpos_xO; auto with zarith. - Qed. - - - Let spec_ww_head00 : forall x, [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits. - Proof. - refine (spec_ww_head00 w_0 w_0W - w_compare w_head0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto. - exact (spec_compare op_spec). - exact (spec_head00 op_spec). - exact (spec_zdigits op_spec). - Qed. - - Let spec_ww_head0 : forall x, 0 < [|x|] -> - wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB. - Proof. - refine (spec_ww_head0 w_0 w_0W w_compare w_head0 - w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ _ _ _ _);auto. - exact (spec_0W op_spec). - exact (spec_compare op_spec). - exact (spec_zdigits op_spec). - Qed. - - Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. - Proof. - refine (spec_ww_tail00 w_0 w_0W - w_compare w_tail0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto. - exact (spec_compare op_spec). - exact (spec_tail00 op_spec). - exact (spec_zdigits op_spec). - Qed. - - - Let spec_ww_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|]. - Proof. - refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 - w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);auto. - exact (spec_0W op_spec). - exact (spec_compare op_spec). - exact (spec_zdigits op_spec). - Qed. - - Lemma spec_ww_add_mul_div : forall x y p, - [|p|] <= Zpos _ww_digits -> - [| add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB. - Proof. - refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div - sub w_digits w_zdigits low w_to_Z - _ _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - exact (spec_W0 op_spec). - exact (spec_0W op_spec). - exact (spec_zdigits op_spec). - Qed. - - Let spec_ww_div_gt : forall a b, - [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. - Proof. -refine -(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 - w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -). - exact (spec_0 op_spec). - exact (spec_to_Z op_spec). - exact (spec_WW op_spec). - exact (spec_0W op_spec). - exact (spec_compare op_spec). - exact (spec_eq0 op_spec). - exact (spec_opp_c op_spec). - exact (spec_opp op_spec). - exact (spec_opp_carry op_spec). - exact (spec_sub_c op_spec). - exact (spec_sub op_spec). - exact (spec_sub_carry op_spec). - exact (spec_div_gt op_spec). - exact (spec_add_mul_div op_spec). - exact (spec_head0 op_spec). - exact (spec_div21 op_spec). - exact spec_w_div32. - exact (spec_zdigits op_spec). - exact spec_ww_digits. - exact spec_ww_1. - exact spec_ww_add_mul_div. - Qed. - - Let spec_ww_div : forall a b, 0 < [|b|] -> - let (q,r) := div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto. - Qed. - - Let spec_ww_mod_gt : forall a b, - [|a|] > [|b|] -> 0 < [|b|] -> - [|mod_gt a b|] = [|a|] mod [|b|]. - Proof. - refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 - w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div - w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - exact (spec_0W op_spec). - exact (spec_compare op_spec). - exact (spec_div_gt op_spec). - exact (spec_div21 op_spec). - exact (spec_zdigits op_spec). - exact spec_ww_add_mul_div. - Qed. - - Let spec_ww_mod : forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|]. - Proof. - refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto. - Qed. - - Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. - Proof. - refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ - w_0 w_0 w_eq0 w_gcd_gt _ww_digits - _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. - refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - exact (spec_0W op_spec). - exact (spec_compare op_spec). - exact (spec_div21 op_spec). - exact (spec_zdigits op_spec). - exact spec_ww_add_mul_div. - refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);auto. - exact (spec_compare op_spec). - Qed. - - Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. - Proof. - refine (@spec_ww_gcd w w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt - _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. - refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - exact (spec_0W op_spec). - exact (spec_compare op_spec). - exact (spec_div21 op_spec). - exact (spec_zdigits op_spec). - exact spec_ww_add_mul_div. - refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);auto. - exact (spec_compare op_spec). - Qed. - - Let spec_ww_is_even : forall x, - match is_even x with - true => [|x|] mod 2 = 0 - | false => [|x|] mod 2 = 1 - end. - Proof. - refine (@spec_ww_is_even w w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto. - exact (spec_is_even op_spec). - Qed. - - Let spec_ww_sqrt2 : forall x y, - wwB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Proof. - intros x y H. - refine (@spec_ww_sqrt2 w w_is_even w_compare w_0 w_1 w_Bm1 - w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits - _ww_zdigits - w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); auto. - exact (spec_zdigits op_spec). - exact (spec_more_than_1_digit op_spec). - exact (spec_0W op_spec). - exact (spec_is_even op_spec). - exact (spec_compare op_spec). - exact (spec_square_c op_spec). - exact (spec_div21 op_spec). - exact (spec_ww_add_mul_div). - exact (spec_sqrt2 op_spec). - Qed. - - Let spec_ww_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. - Proof. - refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1 - w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits - w_sqrt2 pred add_mul_div head0 compare - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); auto. - exact (spec_zdigits op_spec). - exact (spec_more_than_1_digit op_spec). - exact (spec_is_even op_spec). - exact (spec_ww_add_mul_div). - exact (spec_sqrt2 op_spec). - Qed. - - Lemma mk_znz2_spec : znz_spec mk_zn2z_op. - Proof. - apply mk_znz_spec;auto. - exact spec_ww_add_mul_div. - - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW - w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - exact (spec_pos_mod op_spec). - exact (spec_0W op_spec). - exact (spec_zdigits op_spec). - unfold w_to_Z, w_zdigits. - rewrite (spec_zdigits op_spec). - rewrite <- Zpos_xO; exact spec_ww_digits. - Qed. - - Lemma mk_znz2_karatsuba_spec : znz_spec mk_zn2z_op_karatsuba. - Proof. - apply mk_znz_spec;auto. - exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW - w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _);auto. - exact (spec_WW op_spec). - exact (spec_pos_mod op_spec). - exact (spec_0W op_spec). - exact (spec_zdigits op_spec). - unfold w_to_Z, w_zdigits. - rewrite (spec_zdigits op_spec). - rewrite <- Zpos_xO; exact spec_ww_digits. - Qed. -End Zn2Z. - -Section MulAdd. - - Variable w: Set. - Variable op: znz_op w. - Variable sop: znz_spec op. - - Definition mul_add:= w_mul_add (znz_0 op) (znz_succ op) (znz_add_c op) (znz_mul_c op). - - Notation "[| x |]" := (znz_to_Z op x) (at level 0, x at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z (base (znz_digits op)) (znz_to_Z op) x) (at level 0, x at level 99). - - - Lemma spec_mul_add: forall x y z, - let (zh, zl) := mul_add x y z in - [||WW zh zl||] = [|x|] * [|y|] + [|z|]. - Proof. - intros x y z. - refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto. - exact (spec_0 sop). - exact (spec_to_Z sop). - exact (spec_succ sop). - exact (spec_add_c sop). - exact (spec_mul_c sop). - Qed. - -End MulAdd. - - - - diff --git a/theories/Ints/num/ZnZ.v b/theories/Ints/num/ZnZ.v deleted file mode 100644 index d5b798a18c..0000000000 --- a/theories/Ints/num/ZnZ.v +++ /dev/null @@ -1,323 +0,0 @@ -(************************************************************************) -(* 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, INRIA Laurent Thery, INRIA *) -(************************************************************************) - -(* $Id:$ *) - -(** * Signature and specification of a bounded integer structure *) - -(** -- Authors: Benjamin Grégoire, Laurent Théry -- Institution: INRIA -- Date: 2007 -*) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import Znumtheory. -Require Import Basic_type. -Require Import GenBase. - -Open Local Scope Z_scope. - -Section ZnZ_Op. - - Variable znz : Set. - - Record znz_op : Set := mk_znz_op { - - (* Conversion functions with Z *) - znz_digits : positive; - znz_zdigits: znz; - znz_to_Z : znz -> Z; - znz_of_pos : positive -> N * znz; - znz_head0 : znz -> znz; - znz_tail0 : znz -> znz; - - (* Basic constructors *) - znz_0 : znz; - znz_1 : znz; - znz_Bm1 : znz; - znz_WW : znz -> znz -> zn2z znz; - znz_W0 : znz -> zn2z znz; - znz_0W : znz -> zn2z znz; - - (* Comparison *) - znz_compare : znz -> znz -> comparison; - znz_eq0 : znz -> bool; - - (* Basic arithmetic operations *) - znz_opp_c : znz -> carry znz; - znz_opp : znz -> znz; - znz_opp_carry : znz -> znz; (* the carry is known to be -1 *) - - znz_succ_c : znz -> carry znz; - znz_add_c : znz -> znz -> carry znz; - znz_add_carry_c : znz -> znz -> carry znz; - znz_succ : znz -> znz; - znz_add : znz -> znz -> znz; - znz_add_carry : znz -> znz -> znz; - - znz_pred_c : znz -> carry znz; - znz_sub_c : znz -> znz -> carry znz; - znz_sub_carry_c : znz -> znz -> carry znz; - znz_pred : znz -> znz; - znz_sub : znz -> znz -> znz; - znz_sub_carry : znz -> znz -> znz; - - znz_mul_c : znz -> znz -> zn2z znz; - znz_mul : znz -> znz -> znz; - znz_square_c : znz -> zn2z znz; - - (* Special divisions operations *) - znz_div21 : znz -> znz -> znz -> znz*znz; - znz_div_gt : znz -> znz -> znz * znz; - znz_div : znz -> znz -> znz * znz; - - znz_mod_gt : znz -> znz -> znz; - znz_mod : znz -> znz -> znz; - - znz_gcd_gt : znz -> znz -> znz; - znz_gcd : znz -> znz -> znz; - znz_add_mul_div : znz -> znz -> znz -> znz; - znz_pos_mod : znz -> znz -> znz; - - (* square root *) - znz_is_even : znz -> bool; - znz_sqrt2 : znz -> znz -> znz * carry znz; - znz_sqrt : znz -> znz }. - -End ZnZ_Op. - -Section Spec. - Variable w : Set. - Variable w_op : znz_op w. - - Let w_digits := w_op.(znz_digits). - Let w_zdigits := w_op.(znz_zdigits). - Let w_to_Z := w_op.(znz_to_Z). - Let w_of_pos := w_op.(znz_of_pos). - Let w_head0 := w_op.(znz_head0). - Let w_tail0 := w_op.(znz_tail0). - - Let w0 := w_op.(znz_0). - Let w1 := w_op.(znz_1). - Let wBm1 := w_op.(znz_Bm1). - - Let wWW := w_op.(znz_WW). - Let w0W := w_op.(znz_0W). - Let wW0 := w_op.(znz_W0). - - Let w_compare := w_op.(znz_compare). - Let w_eq0 := w_op.(znz_eq0). - - Let w_opp_c := w_op.(znz_opp_c). - Let w_opp := w_op.(znz_opp). - Let w_opp_carry := w_op.(znz_opp_carry). - - Let w_succ_c := w_op.(znz_succ_c). - Let w_add_c := w_op.(znz_add_c). - Let w_add_carry_c := w_op.(znz_add_carry_c). - Let w_succ := w_op.(znz_succ). - Let w_add := w_op.(znz_add). - Let w_add_carry := w_op.(znz_add_carry). - - Let w_pred_c := w_op.(znz_pred_c). - Let w_sub_c := w_op.(znz_sub_c). - Let w_sub_carry_c := w_op.(znz_sub_carry_c). - Let w_pred := w_op.(znz_pred). - Let w_sub := w_op.(znz_sub). - Let w_sub_carry := w_op.(znz_sub_carry). - - Let w_mul_c := w_op.(znz_mul_c). - Let w_mul := w_op.(znz_mul). - Let w_square_c := w_op.(znz_square_c). - - Let w_div21 := w_op.(znz_div21). - Let w_div_gt := w_op.(znz_div_gt). - Let w_div := w_op.(znz_div). - - Let w_mod_gt := w_op.(znz_mod_gt). - Let w_mod := w_op.(znz_mod). - - Let w_gcd_gt := w_op.(znz_gcd_gt). - Let w_gcd := w_op.(znz_gcd). - - Let w_add_mul_div := w_op.(znz_add_mul_div). - - Let w_pos_mod := w_op.(znz_pos_mod). - - Let w_is_even := w_op.(znz_is_even). - Let w_sqrt2 := w_op.(znz_sqrt2). - Let w_sqrt := w_op.(znz_sqrt). - - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - - Let wB := base w_digits. - - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). - - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Record znz_spec : Set := mk_znz_spec { - - (* Conversion functions with Z *) - spec_to_Z : forall x, 0 <= [| x |] < wB; - spec_of_pos : forall p, - Zpos p = (Z_of_N (fst (w_of_pos p)))*wB + [|(snd (w_of_pos p))|]; - spec_zdigits : [| w_zdigits |] = Zpos w_digits; - spec_more_than_1_digit: 1 < Zpos w_digits; - - (* Basic constructors *) - spec_0 : [|w0|] = 0; - spec_1 : [|w1|] = 1; - spec_Bm1 : [|wBm1|] = wB - 1; - spec_WW : forall h l, [||wWW h l||] = [|h|] * wB + [|l|]; - spec_0W : forall l, [||w0W l||] = [|l|]; - spec_W0 : forall h, [||wW0 h||] = [|h|]*wB; - - (* Comparison *) - spec_compare : - forall x y, - match w_compare x y with - | Eq => [|x|] = [|y|] - | Lt => [|x|] < [|y|] - | Gt => [|x|] > [|y|] - end; - spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0; - (* Basic arithmetic operations *) - spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]; - spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB; - spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1; - - spec_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1; - spec_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]; - spec_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1; - spec_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB; - spec_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB; - spec_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; - - spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1; - spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]; - spec_sub_carry_c : forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1; - spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB; - spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB; - spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; - - spec_mul_c : forall x y, [|| w_mul_c x y ||] = [|x|] * [|y|]; - spec_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB; - spec_square_c : forall x, [|| w_square_c x||] = [|x|] * [|x|]; - - (* Special divisions operations *) - spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := w_div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - spec_div : forall a b, 0 < [|b|] -> - let (q,r) := w_div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - - spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|w_mod_gt a b|] = [|a|] mod [|b|]; - spec_mod : forall a b, 0 < [|b|] -> - [|w_mod a b|] = [|a|] mod [|b|]; - - spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]; - spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|w_gcd a b|]; - - - (* shift operations *) - spec_head00: forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits; - spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB; - spec_tail00: forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits; - spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ; - spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB; - spec_pos_mod : forall w p, - [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]); - (* sqrt *) - spec_is_even : forall x, - if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; - spec_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := w_sqrt2 x y in - [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]; - spec_sqrt : forall x, - [|w_sqrt x|] ^ 2 <= [|x|] < ([|w_sqrt x|] + 1) ^ 2 - }. - -End Spec. - - -Section znz_of_pos. - - Variable w : Set. - Variable w_op : znz_op w. - Variable op_spec : znz_spec w_op. - - Notation "[| x |]" := (znz_to_Z w_op x) (at level 0, x at level 99). - - Definition znz_of_Z (w:Set) (op:znz_op w) z := - match z with - | Zpos p => snd (op.(znz_of_pos) p) - | _ => op.(znz_0) - end. - - Theorem znz_of_pos_correct: - forall p, Zpos p < base (znz_digits w_op) -> [|(snd (znz_of_pos w_op p))|] = Zpos p. - intros p Hp. - generalize (spec_of_pos op_spec p). - case (znz_of_pos w_op p); intros n w1; simpl. - case n; simpl Npos; auto with zarith. - intros p1 Hp1; contradict Hp; apply Zle_not_lt. - rewrite Hp1; auto with zarith. - match goal with |- _ <= ?X + ?Y => - apply Zle_trans with X; auto with zarith - end. - match goal with |- ?X <= _ => - pattern X at 1; rewrite <- (Zmult_1_l); - apply Zmult_le_compat_r; auto with zarith - end. - case p1; simpl; intros; red; simpl; intros; discriminate. - unfold base; auto with zarith. - case (spec_to_Z op_spec w1); auto with zarith. - Qed. - - Theorem znz_of_Z_correct: - forall p, 0 <= p < base (znz_digits w_op) -> [|znz_of_Z w_op p|] = p. - intros p; case p; simpl; try rewrite spec_0; auto. - intros; rewrite znz_of_pos_correct; auto with zarith. - intros p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto. - Qed. -End znz_of_pos. diff --git a/theories/Ints/num/genN.ml b/theories/Ints/num/genN.ml deleted file mode 100644 index 8bf583ab6b..0000000000 --- a/theories/Ints/num/genN.ml +++ /dev/null @@ -1,3407 +0,0 @@ -open Format - -let size = 6 -let sizeaux = 1 -let gen_proof = true - -let t = "t" -let c = "N" -let pz n = if n == 0 then "w_0" else "W0" -let rec gen2 n = if n == 0 then "1" else if n == 1 then "2" - else "2 * " ^ (gen2 (n - 1)) -let rec genxO n s = - if n == 0 then s else " (xO" ^ (genxO (n - 1) s) ^ ")" - - -(******* Start Printing ********) -let basename = "N" - - -let print_header fmt l = - let l = "ZAux"::"ZArith"::"Basic_type"::"ZnZ"::"Zn2Z"::"Nbasic"::"GenMul":: - "GenDivn1"::"Wf_nat"::"MemoFn"::l in - List.iter (fun s -> fprintf fmt "Require Import %s.\n" s) l; - fprintf fmt "\n" - -let start_file post l = - let outname = basename^post^".v" in - let fd = - try - Unix.openfile outname [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC] 0o640 - with _ -> - print_string ("can not open file "^outname^"\n"); - exit 1 in - let out = Unix.out_channel_of_descr fd in - set_binary_mode_out out false; - let fmt = formatter_of_out_channel out in - print_header fmt l; - fmt - - - -(****** Print types *******) - -let print_Make () = - let fmt = start_file "Make" [] in - - fprintf fmt "(***************************************************************)\n"; - fprintf fmt "(* *)\n"; - fprintf fmt "(* File automatically generated DO NOT EDIT *)\n"; - fprintf fmt "(* Constructors: %i Generated Proofs: %b %s %s *)\n" size gen_proof (if size < 10 then " " else "") (if gen_proof then " " else ""); - fprintf fmt "(* *)\n"; - fprintf fmt "(* To change this file, edit in genN.ml the two lines *)\n"; - fprintf fmt "(* let size = %i%s *)\n" size (if size < 10 then " " else ""); - fprintf fmt "(* let gen_proof = %s *)\n" (if gen_proof then "true " else "false"); - fprintf fmt "(* Recompile the file *)\n"; - fprintf fmt "(* camlopt -o genN unix.cmxa genN.ml *)\n"; - fprintf fmt "(* Regenerate NMake.v *)\n"; - fprintf fmt "(* ./genN *)\n"; - fprintf fmt "(***************************************************************)\n\n"; - - - fprintf fmt "Module Type W0Type.\n"; - fprintf fmt " Parameter w : Set.\n"; - fprintf fmt " Parameter w_op : znz_op w.\n"; - fprintf fmt " Parameter w_spec : znz_spec w_op.\n"; - fprintf fmt "End W0Type.\n"; - fprintf fmt "\n"; - - fprintf fmt "Module Make (W0:W0Type).\n"; - fprintf fmt " Import W0.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition w0 := W0.w.\n"; - for i = 1 to size do - fprintf fmt " Definition w%i := zn2z w%i.\n" i (i-1) - done; - fprintf fmt "\n"; - - fprintf fmt " Definition w0_op := W0.w_op.\n"; - for i = 1 to 3 do - fprintf fmt " Definition w%i_op := mk_zn2z_op w%i_op.\n" i (i-1) - done; - for i = 4 to size + 3 do - fprintf fmt " Definition w%i_op := mk_zn2z_op_karatsuba w%i_op.\n" i (i-1) - done; - fprintf fmt "\n"; - - fprintf fmt " Section Make_op.\n"; - fprintf fmt " Variable mk : forall w', znz_op w' -> znz_op (zn2z w').\n"; - fprintf fmt "\n"; - fprintf fmt - " Fixpoint make_op_aux (n:nat) : znz_op (word w%i (S n)):=\n" size; - fprintf fmt " match n return znz_op (word w%i (S n)) with\n" size; - fprintf fmt " | O => w%i_op\n" (size+1); - fprintf fmt " | S n1 =>\n"; - fprintf fmt " match n1 return znz_op (word w%i (S (S n1))) with\n" size; - fprintf fmt " | O => w%i_op\n" (size+2); - fprintf fmt " | S n2 =>\n"; - fprintf fmt " match n2 return znz_op (word w%i (S (S (S n2)))) with\n" - size; - fprintf fmt " | O => w%i_op\n" (size+3); - fprintf fmt " | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))\n"; - fprintf fmt " end\n"; - fprintf fmt " end\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - fprintf fmt " End Make_op.\n"; - fprintf fmt "\n"; - fprintf fmt " Definition omake_op := make_op_aux mk_zn2z_op_karatsuba.\n"; - fprintf fmt "\n"; - fprintf fmt "\n"; - fprintf fmt " Definition make_op_list := dmemo_list _ omake_op.\n"; - fprintf fmt "\n"; - fprintf fmt " Definition make_op n := dmemo_get _ omake_op n make_op_list.\n"; - fprintf fmt "\n"; - fprintf fmt " Lemma make_op_omake: forall n, make_op n = omake_op n.\n"; - fprintf fmt " intros n; unfold make_op, make_op_list.\n"; - fprintf fmt " refine (dmemo_get_correct _ _ _).\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Inductive %s_ : Set :=\n" t; - for i = 0 to size do - fprintf fmt " | %s%i : w%i -> %s_\n" c i i t - done; - fprintf fmt " | %sn : forall n, word w%i (S n) -> %s_.\n" c size t; - fprintf fmt "\n"; - fprintf fmt " Definition %s := %s_.\n" t t; - fprintf fmt "\n"; - - fprintf fmt " Definition w_0 := w0_op.(znz_0).\n"; - fprintf fmt "\n"; - - for i = 0 to size do - fprintf fmt " Definition one%i := w%i_op.(znz_1).\n" i i - done; - fprintf fmt "\n"; - - - fprintf fmt " Definition zero := %s0 w_0.\n" c; - fprintf fmt " Definition one := %s0 one0.\n" c; - fprintf fmt "\n"; - - fprintf fmt " Definition to_Z x :=\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wx => w%i_op.(znz_to_Z) wx\n" c i i - done; - fprintf fmt " | %sn n wx => (make_op n).(znz_to_Z) wx\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Open Scope Z_scope.\n"; - fprintf fmt " Notation \"[ x ]\" := (to_Z x).\n"; - fprintf fmt " \n"; - - - - - if gen_proof then - begin - fprintf fmt " (* Regular make op (no karatsuba) *)\n"; - fprintf fmt " Fixpoint nmake_op (ww:Set) (ww_op: znz_op ww) (n: nat) : \n"; - fprintf fmt " znz_op (word ww n) :=\n"; - fprintf fmt " match n return znz_op (word ww n) with \n"; - fprintf fmt " O => ww_op\n"; - fprintf fmt " | S n1 => mk_zn2z_op (nmake_op ww ww_op n1) \n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - fprintf fmt " (* Simplification by rewriting for nmake_op *)\n"; - fprintf fmt " Theorem nmake_op_S: forall ww (w_op: znz_op ww) x, \n"; - fprintf fmt " nmake_op _ w_op (S x) = mk_zn2z_op (nmake_op _ w_op x).\n"; - fprintf fmt " auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - - fprintf fmt " (* Eval and extend functions for each level *)\n"; - for i = 0 to size do - if gen_proof then - fprintf fmt " Let nmake_op%i := nmake_op _ w%i_op.\n" i i; - if gen_proof then - fprintf fmt " Let eval%in n := znz_to_Z (nmake_op%i n).\n" i i; - if i == 0 then - fprintf fmt " Let extend%i := GenBase.extend (WW w_0).\n" i - else - fprintf fmt " Let extend%i := GenBase.extend (WW (W0: w%i)).\n" i i; - done; - fprintf fmt "\n"; - - - if gen_proof then - begin - fprintf fmt " Theorem digits_gend:forall n ww (w_op: znz_op ww), \n"; - fprintf fmt " znz_digits (nmake_op _ w_op n) = \n"; - fprintf fmt " GenBase.gen_digits (znz_digits w_op) n.\n"; - fprintf fmt " Proof."; - fprintf fmt " intros n; elim n; auto; clear n.\n"; - fprintf fmt " intros n Hrec ww ww_op; simpl GenBase.gen_digits.\n"; - fprintf fmt " rewrite <- Hrec; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - fprintf fmt " Theorem nmake_gen: forall n ww (w_op: znz_op ww), \n"; - fprintf fmt " znz_to_Z (nmake_op _ w_op n) =\n"; - fprintf fmt " %sGenBase.gen_to_Z _ (znz_digits w_op) (znz_to_Z w_op) n.\n" "@"; - fprintf fmt " Proof."; - fprintf fmt " intros n; elim n; auto; clear n.\n"; - fprintf fmt " intros n Hrec ww ww_op; simpl GenBase.gen_to_Z; unfold zn2z_to_Z.\n"; - fprintf fmt " rewrite <- Hrec; auto.\n"; - fprintf fmt " unfold GenBase.gen_wB; rewrite <- digits_gend; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem digits_nmake:forall n ww (w_op: znz_op ww), \n"; - fprintf fmt " znz_digits (nmake_op _ w_op (S n)) = \n"; - fprintf fmt " xO (znz_digits (nmake_op _ w_op n)).\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem znz_nmake_op: forall ww ww_op n xh xl,\n"; - fprintf fmt " znz_to_Z (nmake_op ww ww_op (S n)) (WW xh xl) =\n"; - fprintf fmt " znz_to_Z (nmake_op ww ww_op n) xh *\n"; - fprintf fmt " base (znz_digits (nmake_op ww ww_op n)) +\n"; - fprintf fmt " znz_to_Z (nmake_op ww ww_op n) xl.\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem make_op_S: forall n,\n"; - fprintf fmt " make_op (S n) = mk_zn2z_op_karatsuba (make_op n).\n"; - fprintf fmt " intro n.\n"; - fprintf fmt " do 2 rewrite make_op_omake.\n"; - fprintf fmt " pattern n; apply lt_wf_ind; clear n.\n"; - fprintf fmt " intros n; case n; clear n.\n"; - fprintf fmt " intros _; unfold omake_op, make_op_aux, w%i_op; apply refl_equal.\n" (size + 2); - fprintf fmt " intros n; case n; clear n.\n"; - fprintf fmt " intros _; unfold omake_op, make_op_aux, w%i_op; apply refl_equal.\n" (size + 3); - fprintf fmt " intros n; case n; clear n.\n"; - fprintf fmt " intros _; unfold omake_op, make_op_aux, w%i_op, w%i_op; apply refl_equal.\n" (size + 3) (size + 2); - fprintf fmt " intros n Hrec.\n"; - fprintf fmt " change (omake_op (S (S (S (S n))))) with\n"; - fprintf fmt " (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op (S n))))).\n"; - fprintf fmt " change (omake_op (S (S (S n)))) with\n"; - fprintf fmt " (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (mk_zn2z_op_karatsuba (omake_op n)))).\n"; - fprintf fmt " rewrite Hrec; auto with arith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " \n"; - - - for i = 1 to size + 2 do - fprintf fmt " Let znz_to_Z_%i: forall x y,\n" i; - fprintf fmt " znz_to_Z w%i_op (WW x y) = \n" i; - fprintf fmt " znz_to_Z w%i_op x * base (znz_digits w%i_op) + znz_to_Z w%i_op y.\n" (i-1) (i-1) (i-1); - fprintf fmt " Proof.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " Qed. \n"; - fprintf fmt "\n"; - done; - - fprintf fmt " Let znz_to_Z_n: forall n x y,\n"; - fprintf fmt " znz_to_Z (make_op (S n)) (WW x y) = \n"; - fprintf fmt " znz_to_Z (make_op n) x * base (znz_digits (make_op n)) + znz_to_Z (make_op n) y.\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x y; rewrite make_op_S; auto.\n"; - fprintf fmt " Qed. \n"; - fprintf fmt "\n"; - end; - - if gen_proof then - begin - fprintf fmt " Let w0_spec: znz_spec w0_op := W0.w_spec.\n"; - for i = 1 to 3 do - fprintf fmt " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec.\n" i i (i-1) - done; - for i = 4 to size + 3 do - fprintf fmt " Let w%i_spec : znz_spec w%i_op := mk_znz2_karatsuba_spec w%i_spec.\n" i i (i-1) - done; - fprintf fmt "\n"; - - fprintf fmt " Let wn_spec: forall n, znz_spec (make_op n).\n"; - fprintf fmt " intros n; elim n; clear n.\n"; - fprintf fmt " exact w%i_spec.\n" (size + 1); - fprintf fmt " intros n Hrec; rewrite make_op_S.\n"; - fprintf fmt " exact (mk_znz2_karatsuba_spec Hrec).\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " \n"; - end; - - for i = 0 to size do - fprintf fmt " Definition w%i_eq0 := w%i_op.(znz_eq0).\n" i i; - fprintf fmt " Let spec_w%i_eq0: forall x, if w%i_eq0 x then [%s%i x] = 0 else True.\n" i i c i; - if gen_proof then - begin - fprintf fmt " intros x; unfold w%i_eq0, to_Z; generalize (spec_eq0 w%i_spec x);\n" i i; - fprintf fmt " case znz_eq0; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - done; - fprintf fmt "\n"; - - - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Theorem digits_w%i: znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i).\n" i i i; - if i == 0 then - fprintf fmt " auto.\n" - else - fprintf fmt " rewrite digits_nmake; rewrite <- digits_w%i; auto.\n" (i - 1); - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Let spec_gen_eval%in: forall n, eval%in n = GenBase.gen_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n.\n" i i i i; - if gen_proof then - begin - fprintf fmt " intros n; exact (nmake_gen n w%i w%i_op).\n" i i; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - done; - - for i = 0 to size do - for j = 0 to (size - i) do - fprintf fmt " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i).\n" i j (i + j) i j; - if j == 0 then - if i == 0 then - fprintf fmt " auto.\n" - else - begin - fprintf fmt " apply trans_equal with (xO (znz_digits w%i_op)).\n" (i + j -1); - fprintf fmt " auto.\n"; - fprintf fmt " unfold nmake_op; auto.\n"; - end - else - begin - fprintf fmt " apply trans_equal with (xO (znz_digits w%i_op)).\n" (i + j -1); - fprintf fmt " auto.\n"; - fprintf fmt " rewrite digits_nmake.\n"; - fprintf fmt " rewrite digits_w%in%i.\n" i (j - 1); - fprintf fmt " auto.\n"; - end; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - fprintf fmt " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x.\n" i j c (i + j) i j; - if gen_proof then - begin - if j == 0 then - fprintf fmt " intros x; rewrite spec_gen_eval%in; unfold GenBase.gen_to_Z, to_Z; auto.\n" i - else - begin - fprintf fmt " intros x; case x.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i.\n" (i + j); - fprintf fmt " rewrite digits_w%in%i.\n" i (j - 1); - fprintf fmt " generalize (spec_eval%in%i); unfold to_Z; intros HH; repeat rewrite HH.\n" i (j - 1); - fprintf fmt " unfold eval%in, nmake_op%i.\n" i i; - fprintf fmt " rewrite (znz_nmake_op _ w%i_op %i); auto.\n" i (j - 1); - - end; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - if i + j <> size then - begin - fprintf fmt " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)].\n" i (i + j + 1) c i c (i + j + 1) i j; - if j == 0 then - begin - fprintf fmt " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x).\n" i (i + j); - fprintf fmt " unfold to_Z; rewrite znz_to_Z_%i.\n" (i + j + 1); - fprintf fmt " rewrite (spec_0 w%i_spec); auto.\n" (i + j); - - end - else - begin - fprintf fmt " intros x; change (extend%i %i x) with (WW (znz_0 w%i_op) (extend%i %i x)).\n" i j (i + j) i (j - 1); - fprintf fmt " unfold to_Z; rewrite znz_to_Z_%i.\n" (i + j + 1); - fprintf fmt " rewrite (spec_0 w%i_spec).\n" (i + j); - fprintf fmt " generalize (spec_extend%in%i x); unfold to_Z.\n" i (i + j); - fprintf fmt " intros HH; rewrite <- HH; auto.\n"; - - end; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - done; - - fprintf fmt " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i).\n" i (size - i + 1) (size + 1) i (size - i + 1); - fprintf fmt " apply trans_equal with (xO (znz_digits w%i_op)).\n" size; - fprintf fmt " auto.\n"; - fprintf fmt " rewrite digits_nmake.\n"; - fprintf fmt " rewrite digits_w%in%i.\n" i (size - i); - fprintf fmt " auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Let spec_eval%in%i: forall x, [%sn 0 x] = eval%in %i x.\n" i (size - i + 1) c i (size - i + 1); - fprintf fmt " intros x; case x.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i.\n" (size + 1); - fprintf fmt " rewrite digits_w%in%i.\n" i (size - i); - fprintf fmt " generalize (spec_eval%in%i); unfold to_Z; intros HH; repeat rewrite HH.\n" i (size - i); - fprintf fmt " unfold eval%in, nmake_op%i.\n" i i; - fprintf fmt " rewrite (znz_nmake_op _ w%i_op %i); auto.\n" i (size - i); - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Let spec_eval%in%i: forall x, [%sn 1 x] = eval%in %i x.\n" i (size - i + 2) c i (size - i + 2); - fprintf fmt " intros x; case x.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i.\n" (size + 2); - fprintf fmt " rewrite digits_w%in%i.\n" i (size + 1 - i); - fprintf fmt " generalize (spec_eval%in%i); unfold to_Z; change (make_op 0) with (w%i_op); intros HH; repeat rewrite HH.\n" i (size + 1 - i) (size + 1); - fprintf fmt " unfold eval%in, nmake_op%i.\n" i i; - fprintf fmt " rewrite (znz_nmake_op _ w%i_op %i); auto.\n" i (size + 1 - i); - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - done; - - fprintf fmt " Let digits_w%in: forall n,\n" size; - fprintf fmt " znz_digits (make_op n) = znz_digits (nmake_op _ w%i_op (S n)).\n" size; - fprintf fmt " intros n; elim n; clear n.\n"; - fprintf fmt " change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op)).\n" size; - fprintf fmt " rewrite nmake_op_S; apply sym_equal; auto.\n"; - fprintf fmt " intros n Hrec.\n"; - fprintf fmt " replace (znz_digits (make_op (S n))) with (xO (znz_digits (make_op n))).\n"; - fprintf fmt " rewrite Hrec.\n"; - fprintf fmt " rewrite nmake_op_S; apply sym_equal; auto.\n"; - fprintf fmt " rewrite make_op_S; apply sym_equal; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x.\n" size c size; - fprintf fmt " intros n; elim n; clear n.\n"; - fprintf fmt " exact spec_eval%in1.\n" size; - fprintf fmt " intros n Hrec x; case x; clear x.\n"; - fprintf fmt " unfold to_Z, eval%in, nmake_op%i.\n" size size; - fprintf fmt " rewrite make_op_S; rewrite nmake_op_S; auto.\n"; - fprintf fmt " intros xh xl.\n"; - fprintf fmt " unfold to_Z in Hrec |- *.\n"; - fprintf fmt " rewrite znz_to_Z_n.\n"; - fprintf fmt " rewrite digits_w%in.\n" size; - fprintf fmt " repeat rewrite Hrec.\n"; - fprintf fmt " unfold eval%in, nmake_op%i.\n" size size; - fprintf fmt " apply sym_equal; rewrite nmake_op_S; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)].\n" size c size c size ; - fprintf fmt " intros n; elim n; clear n.\n"; - fprintf fmt " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x).\n" size size; - fprintf fmt " unfold to_Z.\n"; - fprintf fmt " change (make_op 0) with w%i_op.\n" (size + 1); - fprintf fmt " rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto.\n" (size + 1) size; - fprintf fmt " intros n Hrec x.\n"; - fprintf fmt " change (extend%i (S n) x) with (WW W0 (extend%i n x)).\n" size size; - fprintf fmt " unfold to_Z in Hrec |- *; rewrite znz_to_Z_n; auto.\n"; - fprintf fmt " rewrite <- Hrec.\n"; - fprintf fmt " replace (znz_to_Z (make_op n) W0) with 0; auto.\n"; - fprintf fmt " case n; auto; intros; rewrite make_op_S; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - - - fprintf fmt " Theorem spec_pos: forall x, 0 <= [x].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; case (spec_to_Z w%i_spec x); auto.\n" i; - done; - fprintf fmt " intros n x; case (spec_to_Z (wn_spec n) x); auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - if gen_proof then - begin - fprintf fmt " Let spec_extendn_0: forall n wx, [%sn n (extend n _ wx)] = [%sn 0 wx].\n" c c; - fprintf fmt " intros n; elim n; auto.\n"; - fprintf fmt " intros n1 Hrec wx; simpl extend; rewrite <- Hrec; auto.\n"; - fprintf fmt " unfold to_Z.\n"; - fprintf fmt " case n1; auto; intros n2; repeat rewrite make_op_S; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_extendn_0: extr.\n"; - fprintf fmt "\n"; - fprintf fmt " Let spec_extendn0_0: forall n wx, [%sn (S n) (WW W0 wx)] = [%sn n wx].\n" c c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x; unfold to_Z.\n"; - fprintf fmt " rewrite znz_to_Z_n.\n"; - fprintf fmt " rewrite <- (Zplus_0_l (znz_to_Z (make_op n) x)).\n"; - fprintf fmt " apply (f_equal2 Zplus); auto.\n"; - fprintf fmt " case n; auto.\n"; - fprintf fmt " intros n1; rewrite make_op_S; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_extendn_0: extr.\n"; - fprintf fmt "\n"; - fprintf fmt " Let spec_extend_tr: forall m n (w: word _ (S n)),\n"; - fprintf fmt " [%sn (m + n) (extend_tr w m)] = [%sn n w].\n" c c; - fprintf fmt " Proof.\n"; - fprintf fmt " induction m; auto.\n"; - fprintf fmt " intros n x; simpl extend_tr.\n"; - fprintf fmt " simpl plus; rewrite spec_extendn0_0; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_extend_tr: extr.\n"; - fprintf fmt "\n"; - fprintf fmt " Let spec_cast_l: forall n m x1,\n"; - fprintf fmt " [%sn (Max.max n m)\n" c; - fprintf fmt " (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))] =\n"; - fprintf fmt " [%sn n x1].\n" c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n m x1; case (diff_r n m); simpl castm.\n"; - fprintf fmt " rewrite spec_extend_tr; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_cast_l: extr.\n"; - fprintf fmt "\n"; - fprintf fmt " Let spec_cast_r: forall n m x1,\n"; - fprintf fmt " [%sn (Max.max n m)\n" c; - fprintf fmt " (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))] =\n"; - fprintf fmt " [%sn m x1].\n" c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n m x1; case (diff_l n m); simpl castm.\n"; - fprintf fmt " rewrite spec_extend_tr; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_cast_r: extr.\n"; - fprintf fmt "\n"; - end; - - - fprintf fmt " Section LevelAndIter.\n"; - fprintf fmt "\n"; - fprintf fmt " Variable res: Set.\n"; - fprintf fmt " Variable xxx: res.\n"; - fprintf fmt " Variable P: Z -> Z -> res -> Prop.\n"; - fprintf fmt " (* Abstraction function for each level *)\n"; - for i = 0 to size do - fprintf fmt " Variable f%i: w%i -> w%i -> res.\n" i i i; - fprintf fmt " Variable f%in: forall n, w%i -> word w%i (S n) -> res.\n" i i i; - fprintf fmt " Variable fn%i: forall n, word w%i (S n) -> w%i -> res.\n" i i i; - if gen_proof then - begin - fprintf fmt " Variable Pf%i: forall x y, P [%s%i x] [%s%i y] (f%i x y).\n" i c i c i i; - if i == size then - begin - fprintf fmt " Variable Pf%in: forall n x y, P [%s%i x] (eval%in (S n) y) (f%in n x y).\n" i c i i i; - fprintf fmt " Variable Pfn%i: forall n x y, P (eval%in (S n) x) [%s%i y] (fn%i n x y).\n" i i c i i; - end - else - begin - - fprintf fmt " Variable Pf%in: forall n x y, Z_of_nat n <= %i -> P [%s%i x] (eval%in (S n) y) (f%in n x y).\n" i (size - i) c i i i; - fprintf fmt " Variable Pfn%i: forall n x y, Z_of_nat n <= %i -> P (eval%in (S n) x) [%s%i y] (fn%i n x y).\n" i (size - i) i c i i; - end; - end; - fprintf fmt "\n"; - done; - fprintf fmt " Variable fnn: forall n, word w%i (S n) -> word w%i (S n) -> res.\n" size size; - if gen_proof then - fprintf fmt " Variable Pfnn: forall n x y, P [%sn n x] [%sn n y] (fnn n x y).\n" c c; - fprintf fmt " Variable fnm: forall n m, word w%i (S n) -> word w%i (S m) -> res.\n" size size; - if gen_proof then - fprintf fmt " Variable Pfnm: forall n m x y, P [%sn n x] [%sn m y] (fnm n m x y).\n" c c; - fprintf fmt "\n"; - fprintf fmt " (* Special zero functions *)\n"; - fprintf fmt " Variable f0t: t_ -> res.\n"; - if gen_proof then - fprintf fmt " Variable Pf0t: forall x, P 0 [x] (f0t x).\n"; - fprintf fmt " Variable ft0: t_ -> res.\n"; - if gen_proof then - fprintf fmt " Variable Pft0: forall x, P [x] 0 (ft0 x).\n"; - fprintf fmt "\n"; - - - fprintf fmt " (* We level the two arguments before applying *)\n"; - fprintf fmt " (* the functions at each leval *)\n"; - fprintf fmt " Definition same_level (x y: t_): res :=\n"; - fprintf fmt " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - fprintf fmt "extend%i " i; - done; - fprintf fmt "\n"; - fprintf fmt " GenBase.extend GenBase.extend_aux\n"; - fprintf fmt " ] in\n"; - fprintf fmt " match x, y with\n"; - for i = 0 to size do - for j = 0 to i - 1 do - fprintf fmt " | %s%i wx, %s%i wy => f%i wx (extend%i %i wy)\n" c i c j i j (i - j -1); - done; - fprintf fmt " | %s%i wx, %s%i wy => f%i wx wy\n" c i c i i; - for j = i + 1 to size do - fprintf fmt " | %s%i wx, %s%i wy => f%i (extend%i %i wx) wy\n" c i c j j i (j - i - 1); - done; - if i == size then - fprintf fmt " | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy\n" c size c size - else - fprintf fmt " | %s%i wx, %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy\n" c i c size i (size - i - 1); - done; - for i = 0 to size do - if i == size then - fprintf fmt " | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)\n" c c size size - else - fprintf fmt " | %sn n wx, %s%i wy => fnn n wx (extend%i n (extend%i %i wy))\n" c c i size i (size - i - 1); - done; - fprintf fmt " | %sn n wx, Nn m wy =>\n" c; - fprintf fmt " let mn := Max.max n m in\n"; - fprintf fmt " let d := diff n m in\n"; - fprintf fmt " fnn mn\n"; - fprintf fmt " (castm (diff_r n m) (extend_tr wx (snd d)))\n"; - fprintf fmt " (castm (diff_l n m) (extend_tr wy (fst d)))\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - if gen_proof then - begin - fprintf fmt " Lemma spec_same_level: forall x y, P [x] [y] (same_level x y).\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x; unfold same_level.\n"; - for i = 0 to size do - fprintf fmt " intros x y; case y; clear y.\n"; - for j = 0 to i - 1 do - fprintf fmt " intros y; rewrite spec_extend%in%i; apply Pf%i.\n" j i i; - done; - fprintf fmt " intros y; apply Pf%i.\n" i; - for j = i + 1 to size do - fprintf fmt " intros y; rewrite spec_extend%in%i; apply Pf%i.\n" i j j; - done; - if i == size then - fprintf fmt " intros m y; rewrite (spec_extend%in m); apply Pfnn.\n" size - else - fprintf fmt " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn.\n" i size size; - done; - fprintf fmt " intros n x y; case y; clear y.\n"; - for i = 0 to size do - if i == size then - fprintf fmt " intros y; rewrite (spec_extend%in n); apply Pfnn.\n" size - else - fprintf fmt " intros y; rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn.\n" i size size; - done; - fprintf fmt " intros m y; rewrite <- (spec_cast_l n m x); \n"; - fprintf fmt " rewrite <- (spec_cast_r n m y); apply Pfnn.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " (* We level the two arguments before applying *)\n"; - fprintf fmt " (* the functions at each level (special zero case) *)\n"; - fprintf fmt " Definition same_level0 (x y: t_): res :=\n"; - fprintf fmt " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - fprintf fmt "extend%i " i; - done; - fprintf fmt "\n"; - fprintf fmt " GenBase.extend GenBase.extend_aux\n"; - fprintf fmt " ] in\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wx =>\n" c i; - if (i == 0) then - fprintf fmt " if w0_eq0 wx then f0t y else\n"; - fprintf fmt " match y with\n"; - for j = 0 to i - 1 do - fprintf fmt " | %s%i wy =>\n" c j; - if j == 0 then - fprintf fmt " if w0_eq0 wy then ft0 x else\n"; - fprintf fmt " f%i wx (extend%i %i wy)\n" i j (i - j -1); - done; - fprintf fmt " | %s%i wy => f%i wx wy\n" c i i; - for j = i + 1 to size do - fprintf fmt " | %s%i wy => f%i (extend%i %i wx) wy\n" c j j i (j - i - 1); - done; - if i == size then - fprintf fmt " | %sn m wy => fnn m (extend%i m wx) wy\n" c size - else - fprintf fmt " | %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy\n" c size i (size - i - 1); - fprintf fmt" end\n"; - done; - fprintf fmt " | %sn n wx =>\n" c; - fprintf fmt " match y with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wy =>\n" c i; - if i == 0 then - fprintf fmt " if w0_eq0 wy then ft0 x else\n"; - if i == size then - fprintf fmt " fnn n wx (extend%i n wy)\n" size - else - fprintf fmt " fnn n wx (extend%i n (extend%i %i wy))\n" size i (size - i - 1); - done; - fprintf fmt " | %sn m wy =>\n" c; - fprintf fmt " let mn := Max.max n m in\n"; - fprintf fmt " let d := diff n m in\n"; - fprintf fmt " fnn mn\n"; - fprintf fmt " (castm (diff_r n m) (extend_tr wx (snd d)))\n"; - fprintf fmt " (castm (diff_l n m) (extend_tr wy (fst d)))\n"; - fprintf fmt " end\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Lemma spec_same_level0: forall x y, P [x] [y] (same_level0 x y).\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x; unfold same_level0.\n"; - for i = 0 to size do - fprintf fmt " intros x.\n"; - if i == 0 then - begin - fprintf fmt " generalize (spec_w0_eq0 x); case w0_eq0; intros H.\n"; - fprintf fmt " intros y; rewrite H; apply Pf0t.\n"; - fprintf fmt " clear H.\n"; - end; - fprintf fmt " intros y; case y; clear y.\n"; - for j = 0 to i - 1 do - fprintf fmt " intros y.\n"; - if j == 0 then - begin - fprintf fmt " generalize (spec_w0_eq0 y); case w0_eq0; intros H.\n"; - fprintf fmt " rewrite H; apply Pft0.\n"; - fprintf fmt " clear H.\n"; - end; - fprintf fmt " rewrite spec_extend%in%i; apply Pf%i.\n" j i i; - done; - fprintf fmt " intros y; apply Pf%i.\n" i; - for j = i + 1 to size do - fprintf fmt " intros y; rewrite spec_extend%in%i; apply Pf%i.\n" i j j; - done; - if i == size then - fprintf fmt " intros m y; rewrite (spec_extend%in m); apply Pfnn.\n" size - else - fprintf fmt " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn.\n" i size size; - done; - fprintf fmt " intros n x y; case y; clear y.\n"; - for i = 0 to size do - fprintf fmt " intros y.\n"; - if i = 0 then - begin - fprintf fmt " generalize (spec_w0_eq0 y); case w0_eq0; intros H.\n"; - fprintf fmt " rewrite H; apply Pft0.\n"; - fprintf fmt " clear H.\n"; - end; - if i == size then - fprintf fmt " rewrite (spec_extend%in n); apply Pfnn.\n" size - else - fprintf fmt " rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn.\n" i size size; - done; - fprintf fmt " intros m y; rewrite <- (spec_cast_l n m x); \n"; - fprintf fmt " rewrite <- (spec_cast_r n m y); apply Pfnn.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " (* We iter the smaller argument with the bigger *)\n"; - fprintf fmt " Definition iter (x y: t_): res := \n"; - fprintf fmt " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - fprintf fmt "extend%i " i; - done; - fprintf fmt "\n"; - fprintf fmt " GenBase.extend GenBase.extend_aux\n"; - fprintf fmt " ] in\n"; - fprintf fmt " match x, y with\n"; - for i = 0 to size do - for j = 0 to i - 1 do - fprintf fmt " | %s%i wx, %s%i wy => fn%i %i wx wy\n" c i c j j (i - j - 1); - done; - fprintf fmt " | %s%i wx, %s%i wy => f%i wx wy\n" c i c i i; - for j = i + 1 to size do - fprintf fmt " | %s%i wx, %s%i wy => f%in %i wx wy\n" c i c j i (j - i - 1); - done; - if i == size then - fprintf fmt " | %s%i wx, %sn m wy => f%in m wx wy\n" c size c size - else - fprintf fmt " | %s%i wx, %sn m wy => f%in m (extend%i %i wx) wy\n" c i c size i (size - i - 1); - done; - for i = 0 to size do - if i == size then - fprintf fmt " | %sn n wx, %s%i wy => fn%i n wx wy\n" c c size size - else - fprintf fmt " | %sn n wx, %s%i wy => fn%i n wx (extend%i %i wy)\n" c c i size i (size - i - 1); - done; - fprintf fmt " | %sn n wx, %sn m wy => fnm n m wx wy\n" c c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Ltac zg_tac := try\n"; - fprintf fmt " (red; simpl Zcompare; auto;\n"; - fprintf fmt " let t := fresh \"H\" in (intros t; discriminate H)).\n"; - fprintf fmt " Lemma spec_iter: forall x y, P [x] [y] (iter x y).\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x; unfold iter.\n"; - for i = 0 to size do - fprintf fmt " intros x y; case y; clear y.\n"; - for j = 0 to i - 1 do - fprintf fmt " intros y; rewrite spec_eval%in%i; apply (Pfn%i %i); zg_tac.\n" j (i - j) j (i - j - 1); - done; - fprintf fmt " intros y; apply Pf%i.\n" i; - for j = i + 1 to size do - fprintf fmt " intros y; rewrite spec_eval%in%i; apply (Pf%in %i); zg_tac.\n" i (j - i) i (j - i - 1); - done; - if i == size then - fprintf fmt " intros m y; rewrite spec_eval%in; apply Pf%in.\n" size size - else - fprintf fmt " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in.\n" i size size size; - done; - fprintf fmt " intros n x y; case y; clear y.\n"; - for i = 0 to size do - if i == size then - fprintf fmt " intros y; rewrite spec_eval%in; apply Pfn%i.\n" size size - else - fprintf fmt " intros y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i.\n" i size size size; - done; - fprintf fmt " intros m y; apply Pfnm.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - - fprintf fmt " (* We iter the smaller argument with the bigger (zero case) *)\n"; - fprintf fmt " Definition iter0 (x y: t_): res :=\n"; - fprintf fmt " Eval lazy zeta beta iota delta ["; - for i = 0 to size do - fprintf fmt "extend%i " i; - done; - fprintf fmt "\n"; - fprintf fmt " GenBase.extend GenBase.extend_aux\n"; - fprintf fmt " ] in\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wx =>\n" c i; - if (i == 0) then - fprintf fmt " if w0_eq0 wx then f0t y else\n"; - fprintf fmt " match y with\n"; - for j = 0 to i - 1 do - fprintf fmt " | %s%i wy =>\n" c j; - if j == 0 then - fprintf fmt " if w0_eq0 wy then ft0 x else\n"; - fprintf fmt " fn%i %i wx wy\n" j (i - j - 1); - done; - fprintf fmt " | %s%i wy => f%i wx wy\n" c i i; - for j = i + 1 to size do - fprintf fmt " | %s%i wy => f%in %i wx wy\n" c j i (j - i - 1); - done; - if i == size then - fprintf fmt " | %sn m wy => f%in m wx wy\n" c size - else - fprintf fmt " | %sn m wy => f%in m (extend%i %i wx) wy\n" c size i (size - i - 1); - fprintf fmt " end\n"; - done; - fprintf fmt " | %sn n wx =>\n" c; - fprintf fmt " match y with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wy =>\n" c i; - if i == 0 then - fprintf fmt " if w0_eq0 wy then ft0 x else\n"; - if i == size then - fprintf fmt " fn%i n wx wy\n" size - else - fprintf fmt " fn%i n wx (extend%i %i wy)\n" size i (size - i - 1); - done; - fprintf fmt " | %sn m wy => fnm n m wx wy\n" c; - fprintf fmt " end\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Lemma spec_iter0: forall x y, P [x] [y] (iter0 x y).\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x; unfold iter0.\n"; - for i = 0 to size do - fprintf fmt " intros x.\n"; - if i == 0 then - begin - fprintf fmt " generalize (spec_w0_eq0 x); case w0_eq0; intros H.\n"; - fprintf fmt " intros y; rewrite H; apply Pf0t.\n"; - fprintf fmt " clear H.\n"; - end; - fprintf fmt " intros y; case y; clear y.\n"; - for j = 0 to i - 1 do - fprintf fmt " intros y.\n"; - if j == 0 then - begin - fprintf fmt " generalize (spec_w0_eq0 y); case w0_eq0; intros H.\n"; - fprintf fmt " rewrite H; apply Pft0.\n"; - fprintf fmt " clear H.\n"; - end; - fprintf fmt " rewrite spec_eval%in%i; apply (Pfn%i %i); zg_tac.\n" j (i - j) j (i - j - 1); - done; - fprintf fmt " intros y; apply Pf%i.\n" i; - for j = i + 1 to size do - fprintf fmt " intros y; rewrite spec_eval%in%i; apply (Pf%in %i); zg_tac.\n" i (j - i) i (j - i - 1); - done; - if i == size then - fprintf fmt " intros m y; rewrite spec_eval%in; apply Pf%in.\n" size size - else - fprintf fmt " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in.\n" i size size size; - done; - fprintf fmt " intros n x y; case y; clear y.\n"; - for i = 0 to size do - fprintf fmt " intros y.\n"; - if i = 0 then - begin - fprintf fmt " generalize (spec_w0_eq0 y); case w0_eq0; intros H.\n"; - fprintf fmt " rewrite H; apply Pft0.\n"; - fprintf fmt " clear H.\n"; - end; - if i == size then - fprintf fmt " rewrite spec_eval%in; apply Pfn%i.\n" size size - else - fprintf fmt " rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i.\n" i size size size; - done; - fprintf fmt " intros m y; apply Pfnm.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - - fprintf fmt " End LevelAndIter.\n"; - fprintf fmt "\n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Reduction *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - fprintf fmt " Definition reduce_0 (x:w) := %s0 x.\n" c; - fprintf fmt " Definition reduce_1 :=\n"; - fprintf fmt " Eval lazy beta iota delta[reduce_n1] in\n"; - fprintf fmt " reduce_n1 _ _ zero w0_eq0 %s0 %s1.\n" c c; - for i = 2 to size do - fprintf fmt " Definition reduce_%i :=\n" i; - fprintf fmt " Eval lazy beta iota delta[reduce_n1] in\n"; - fprintf fmt " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i.\n" - (i-1) (i-1) c i - done; - fprintf fmt " Definition reduce_%i :=\n" (size+1); - fprintf fmt " Eval lazy beta iota delta[reduce_n1] in\n"; - fprintf fmt " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0).\n" - size size c; - - fprintf fmt " Definition reduce_n n := \n"; - fprintf fmt " Eval lazy beta iota delta[reduce_n] in\n"; - fprintf fmt " reduce_n _ _ zero reduce_%i %sn n.\n" (size + 1) c; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Let spec_reduce_0: forall x, [reduce_0 x] = [%s0 x].\n" c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; unfold to_Z, reduce_0.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " \n"; - - for i = 1 to size + 1 do - if (i == size + 1) then - fprintf fmt " Let spec_reduce_%i: forall x, [reduce_%i x] = [%sn 0 x].\n" i i c - else - fprintf fmt " Let spec_reduce_%i: forall x, [reduce_%i x] = [%s%i x].\n" i i c i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold reduce_%i.\n" i; - fprintf fmt " exact (spec_0 w0_spec).\n"; - fprintf fmt " intros x1 y1.\n"; - fprintf fmt " generalize (spec_w%i_eq0 x1); \n" (i - 1); - fprintf fmt " case w%i_eq0; intros H1; auto.\n" (i - 1); - if i <> 1 then - fprintf fmt " rewrite spec_reduce_%i.\n" (i - 1); - fprintf fmt " unfold to_Z; rewrite znz_to_Z_%i.\n" i; - fprintf fmt " unfold to_Z in H1; rewrite H1; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " \n"; - done; - - fprintf fmt " Let spec_reduce_n: forall n x, [reduce_n n x] = [%sn n x].\n" c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n; elim n; simpl reduce_n.\n"; - fprintf fmt " intros x; rewrite <- spec_reduce_%i; auto.\n" (size + 1); - fprintf fmt " intros n1 Hrec x; case x.\n"; - fprintf fmt " unfold to_Z; rewrite make_op_S; auto.\n"; - fprintf fmt " exact (spec_0 w0_spec).\n"; - fprintf fmt " intros x1 y1; case x1; auto.\n"; - fprintf fmt " rewrite Hrec.\n"; - fprintf fmt " rewrite spec_extendn0_0; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " \n"; - end; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Successor *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_succ_c := w%i_op.(znz_succ_c).\n" i i - done; - fprintf fmt "\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_succ := w%i_op.(znz_succ).\n" i i - done; - fprintf fmt "\n"; - - fprintf fmt " Definition succ x :=\n"; - fprintf fmt " match x with\n"; - for i = 0 to size-1 do - fprintf fmt " | %s%i wx =>\n" c i; - fprintf fmt " match w%i_succ_c wx with\n" i; - fprintf fmt " | C0 r => %s%i r\n" c i; - fprintf fmt " | C1 r => %s%i (WW one%i r)\n" c (i+1) i; - fprintf fmt " end\n"; - done; - fprintf fmt " | %s%i wx =>\n" c size; - fprintf fmt " match w%i_succ_c wx with\n" size; - fprintf fmt " | C0 r => %s%i r\n" c size; - fprintf fmt " | C1 r => %sn 0 (WW one%i r)\n" c size ; - fprintf fmt " end\n"; - fprintf fmt " | %sn n wx =>\n" c; - fprintf fmt " let op := make_op n in\n"; - fprintf fmt " match op.(znz_succ_c) wx with\n"; - fprintf fmt " | C0 r => %sn n r\n" c; - fprintf fmt " | C1 r => %sn (S n) (WW op.(znz_1) r)\n" c; - fprintf fmt " end\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_succ: forall n, [succ n] = [n] + 1.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros n; case n; unfold succ, to_Z.\n"; - for i = 0 to size do - fprintf fmt " intros n1; generalize (spec_succ_c w%i_spec n1);\n" i; - fprintf fmt " unfold succ, to_Z, w%i_succ_c; case znz_succ_c; auto.\n" i; - fprintf fmt " intros ww H; rewrite <- H.\n"; - fprintf fmt " (rewrite znz_to_Z_%i; unfold interp_carry;\n" (i + 1); - fprintf fmt " apply f_equal2 with (f := Zplus); auto;\n"; - fprintf fmt " apply f_equal2 with (f := Zmult); auto;\n"; - fprintf fmt " exact (spec_1 w%i_spec)).\n" i; - done; - fprintf fmt " intros k n1; generalize (spec_succ_c (wn_spec k) n1).\n"; - fprintf fmt " unfold succ, to_Z; case znz_succ_c; auto.\n"; - fprintf fmt " intros ww H; rewrite <- H.\n"; - fprintf fmt " (rewrite (znz_to_Z_n k); unfold interp_carry;\n"; - fprintf fmt " apply f_equal2 with (f := Zplus); auto;\n"; - fprintf fmt " apply f_equal2 with (f := Zmult); auto;\n"; - fprintf fmt " exact (spec_1 (wn_spec k))).\n"; - fprintf fmt " Qed.\n"; - end - else fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Adddition *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - for i = 0 to size do - fprintf fmt " Definition w%i_add_c := znz_add_c w%i_op.\n" i i; - fprintf fmt " Definition w%i_add x y :=\n" i; - fprintf fmt " match w%i_add_c x y with\n" i; - fprintf fmt " | C0 r => %s%i r\n" c i; - if i == size then - fprintf fmt " | C1 r => %sn 0 (WW one%i r)\n" c size - else - fprintf fmt " | C1 r => %s%i (WW one%i r)\n" c (i + 1) i; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - done ; - fprintf fmt " Definition addn n (x y : word w%i (S n)) :=\n" size; - fprintf fmt " let op := make_op n in\n"; - fprintf fmt " match op.(znz_add_c) x y with\n"; - fprintf fmt " | C0 r => %sn n r\n" c; - fprintf fmt " | C1 r => %sn (S n) (WW op.(znz_1) r) end.\n" c; - fprintf fmt "\n"; - - - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Let spec_w%i_add: forall x y, [w%i_add x y] = [%s%i x] + [%s%i y].\n" i i c i c i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n m; unfold to_Z, w%i_add, w%i_add_c.\n" i i; - fprintf fmt " generalize (spec_add_c w%i_spec n m); case znz_add_c; auto.\n" i; - fprintf fmt " intros ww H; rewrite <- H.\n"; - fprintf fmt " rewrite znz_to_Z_%i; unfold interp_carry;\n" (i + 1); - fprintf fmt " apply f_equal2 with (f := Zplus); auto;\n"; - fprintf fmt " apply f_equal2 with (f := Zmult); auto;\n"; - fprintf fmt " exact (spec_1 w%i_spec).\n" i; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_w%i_add: addr.\n" i; - fprintf fmt "\n"; - done; - fprintf fmt " Let spec_wn_add: forall n x y, [addn n x y] = [%sn n x] + [%sn n y].\n" c c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros k n m; unfold to_Z, addn.\n"; - fprintf fmt " generalize (spec_add_c (wn_spec k) n m); case znz_add_c; auto.\n"; - fprintf fmt " intros ww H; rewrite <- H.\n"; - fprintf fmt " rewrite (znz_to_Z_n k); unfold interp_carry;\n"; - fprintf fmt " apply f_equal2 with (f := Zplus); auto;\n"; - fprintf fmt " apply f_equal2 with (f := Zmult); auto;\n"; - fprintf fmt " exact (spec_1 (wn_spec k)).\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " Hint Rewrite spec_wn_add: addr.\n"; - end; - - fprintf fmt " Definition add := Eval lazy beta delta [same_level] in\n"; - fprintf fmt " (same_level t_ "; - for i = 0 to size do - fprintf fmt "w%i_add " i; - done; - fprintf fmt "addn).\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_add: forall x y, [add x y] = [x] + [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " unfold add.\n"; - fprintf fmt " generalize (spec_same_level t_ (fun x y res => [res] = x + y)).\n"; - fprintf fmt " unfold same_level; intros HH; apply HH; clear HH.\n"; - for i = 0 to size do - fprintf fmt " exact spec_w%i_add.\n" i; - done; - fprintf fmt " exact spec_wn_add.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Predecessor *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_pred_c := w%i_op.(znz_pred_c).\n" i i - done; - fprintf fmt "\n"; - - fprintf fmt " Definition pred x :=\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wx =>\n" c i; - fprintf fmt " match w%i_pred_c wx with\n" i; - fprintf fmt " | C0 r => reduce_%i r\n" i; - fprintf fmt " | C1 r => zero\n"; - fprintf fmt " end\n"; - done; - fprintf fmt " | %sn n wx =>\n" c; - fprintf fmt " let op := make_op n in\n"; - fprintf fmt " match op.(znz_pred_c) wx with\n"; - fprintf fmt " | C0 r => reduce_n n r\n"; - fprintf fmt " | C1 r => zero\n"; - fprintf fmt " end\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_pred: forall x, 0 < [x] -> [pred x] = [x] - 1.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold pred.\n"; - for i = 0 to size do - fprintf fmt " intros x1 H1; unfold w%i_pred_c; \n" i; - fprintf fmt " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1.\n" i; - fprintf fmt " rewrite spec_reduce_%i; auto.\n" i; - fprintf fmt " unfold interp_carry; unfold to_Z.\n"; - fprintf fmt " case (spec_to_Z w%i_spec x1); intros HH1 HH2.\n" i; - fprintf fmt " case (spec_to_Z w%i_spec y1); intros HH3 HH4 HH5.\n" i; - fprintf fmt " assert (znz_to_Z w%i_op x1 - 1 < 0); auto with zarith.\n" i; - fprintf fmt " unfold to_Z in H1; auto with zarith.\n"; - done; - fprintf fmt " intros n x1 H1; \n"; - fprintf fmt " generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1.\n"; - fprintf fmt " rewrite spec_reduce_n; auto.\n"; - fprintf fmt " unfold interp_carry; unfold to_Z.\n"; - fprintf fmt " case (spec_to_Z (wn_spec n) x1); intros HH1 HH2.\n"; - fprintf fmt " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4 HH5.\n"; - fprintf fmt " assert (znz_to_Z (make_op n) x1 - 1 < 0); auto with zarith.\n"; - fprintf fmt " unfold to_Z in H1; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt " \n"; - - fprintf fmt " Let spec_pred0: forall x, [x] = 0 -> [pred x] = 0.\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold pred.\n"; - for i = 0 to size do - fprintf fmt " intros x1 H1; unfold w%i_pred_c; \n" i; - fprintf fmt " generalize (spec_pred_c w%i_spec x1); case znz_pred_c; intros y1.\n" i; - fprintf fmt " unfold interp_carry; unfold to_Z.\n"; - fprintf fmt " unfold to_Z in H1; auto with zarith.\n"; - fprintf fmt " case (spec_to_Z w%i_spec y1); intros HH3 HH4; auto with zarith.\n" i; - fprintf fmt " intros; exact (spec_0 w0_spec).\n"; - done; - fprintf fmt " intros n x1 H1; \n"; - fprintf fmt " generalize (spec_pred_c (wn_spec n) x1); case znz_pred_c; intros y1.\n"; - fprintf fmt " unfold interp_carry; unfold to_Z.\n"; - fprintf fmt " unfold to_Z in H1; auto with zarith.\n"; - fprintf fmt " case (spec_to_Z (wn_spec n) y1); intros HH3 HH4; auto with zarith.\n"; - fprintf fmt " intros; exact (spec_0 w0_spec).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt " \n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Subtraction *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_sub_c := w%i_op.(znz_sub_c).\n" i i - done; - fprintf fmt "\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_sub x y :=\n" i; - fprintf fmt " match w%i_sub_c x y with\n" i; - fprintf fmt " | C0 r => reduce_%i r\n" i; - fprintf fmt " | C1 r => zero\n"; - fprintf fmt " end.\n" - done; - fprintf fmt "\n"; - - fprintf fmt " Definition subn n (x y : word w%i (S n)) :=\n" size; - fprintf fmt " let op := make_op n in\n"; - fprintf fmt " match op.(znz_sub_c) x y with\n"; - fprintf fmt " | C0 r => %sn n r\n" c; - fprintf fmt " | C1 r => N0 w_0"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Let spec_w%i_sub: forall x y, [%s%i y] <= [%s%i x] -> [w%i_sub x y] = [%s%i x] - [%s%i y].\n" i c i c i i c i c i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n m; unfold w%i_sub, w%i_sub_c.\n" i i; - fprintf fmt " generalize (spec_sub_c w%i_spec n m); case znz_sub_c; \n" i; - if i == 0 then - fprintf fmt " intros x; auto.\n" - else - fprintf fmt " intros x; try rewrite spec_reduce_%i; auto.\n" i; - fprintf fmt " unfold interp_carry; unfold zero, w_0, to_Z.\n"; - fprintf fmt " rewrite (spec_0 w0_spec).\n"; - fprintf fmt " case (spec_to_Z w%i_spec x); intros; auto with zarith.\n" i; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - done; - - fprintf fmt " Let spec_wn_sub: forall n x y, [%sn n y] <= [%sn n x] -> [subn n x y] = [%sn n x] - [%sn n y].\n" c c c c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros k n m; unfold subn.\n"; - fprintf fmt " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; \n"; - fprintf fmt " intros x; auto.\n"; - fprintf fmt " unfold interp_carry, to_Z.\n"; - fprintf fmt " case (spec_to_Z (wn_spec k) x); intros; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " Definition sub := Eval lazy beta delta [same_level] in\n"; - fprintf fmt " (same_level t_ "; - for i = 0 to size do - fprintf fmt "w%i_sub " i; - done; - fprintf fmt "subn).\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_sub: forall x y, [y] <= [x] -> [sub x y] = [x] - [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " unfold sub.\n"; - fprintf fmt " generalize (spec_same_level t_ (fun x y res => y <= x -> [res] = x - y)).\n"; - fprintf fmt " unfold same_level; intros HH; apply HH; clear HH.\n"; - for i = 0 to size do - fprintf fmt " exact spec_w%i_sub.\n" i; - done; - fprintf fmt " exact spec_wn_sub.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Let spec_w%i_sub0: forall x y, [%s%i x] < [%s%i y] -> [w%i_sub x y] = 0.\n" i c i c i i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n m; unfold w%i_sub, w%i_sub_c.\n" i i; - fprintf fmt " generalize (spec_sub_c w%i_spec n m); case znz_sub_c; \n" i; - fprintf fmt " intros x; unfold interp_carry.\n"; - fprintf fmt " unfold to_Z; case (spec_to_Z w%i_spec x); intros; auto with zarith.\n" i; - fprintf fmt " intros; unfold to_Z, zero, w_0; rewrite (spec_0 w0_spec); auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - done; - - fprintf fmt " Let spec_wn_sub0: forall n x y, [%sn n x] < [%sn n y] -> [subn n x y] = 0.\n" c c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros k n m; unfold subn.\n"; - fprintf fmt " generalize (spec_sub_c (wn_spec k) n m); case znz_sub_c; \n"; - fprintf fmt " intros x; unfold interp_carry.\n"; - fprintf fmt " unfold to_Z; case (spec_to_Z (wn_spec k) x); intros; auto with zarith.\n"; - fprintf fmt " intros; unfold to_Z, w_0; rewrite (spec_0 (w0_spec)); auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " Theorem spec_sub0: forall x y, [x] < [y] -> [sub x y] = 0.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " unfold sub.\n"; - fprintf fmt " generalize (spec_same_level t_ (fun x y res => x < y -> [res] = 0)).\n"; - fprintf fmt " unfold same_level; intros HH; apply HH; clear HH.\n"; - for i = 0 to size do - fprintf fmt " exact spec_w%i_sub0.\n" i; - done; - fprintf fmt " exact spec_wn_sub0.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Comparison *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - for i = 0 to size do - fprintf fmt " Definition compare_%i := w%i_op.(znz_compare).\n" i i; - fprintf fmt " Definition comparen_%i :=\n" i; - let s0 = if i = 0 then "w_0" else "W0" in - fprintf fmt - " compare_mn_1 w%i w%i %s compare_%i (compare_%i %s) compare_%i.\n" - i i s0 i i s0 i - done; - fprintf fmt "\n"; - - fprintf fmt " Definition comparenm n m wx wy :=\n"; - fprintf fmt " let mn := Max.max n m in\n"; - fprintf fmt " let d := diff n m in\n"; - fprintf fmt " let op := make_op mn in\n"; - fprintf fmt " op.(znz_compare)\n"; - fprintf fmt " (castm (diff_r n m) (extend_tr wx (snd d)))\n"; - fprintf fmt " (castm (diff_l n m) (extend_tr wy (fst d))).\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition compare := Eval lazy beta delta [iter] in \n"; - fprintf fmt " (iter _ \n"; - for i = 0 to size do - fprintf fmt " compare_%i\n" i; - fprintf fmt " (fun n x y => opp_compare (comparen_%i (S n) y x))\n" i; - fprintf fmt " (fun n => comparen_%i (S n))\n" i; - done; - fprintf fmt " comparenm).\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Let spec_compare_%i: forall x y,\n" i; - fprintf fmt " match compare_%i x y with \n" i; - fprintf fmt " Eq => [%s%i x] = [%s%i y]\n" c i c i; - fprintf fmt " | Lt => [%s%i x] < [%s%i y]\n" c i c i; - fprintf fmt " | Gt => [%s%i x] > [%s%i y]\n" c i c i; - fprintf fmt " end.\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " unfold compare_%i, to_Z; exact (spec_compare w%i_spec).\n" i i; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Let spec_comparen_%i:\n" i; - fprintf fmt " forall (n : nat) (x : word w%i n) (y : w%i),\n" i i; - fprintf fmt " match comparen_%i n x y with\n" i; - fprintf fmt " | Eq => eval%in n x = [%s%i y]\n" i c i; - fprintf fmt " | Lt => eval%in n x < [%s%i y]\n" i c i; - fprintf fmt " | Gt => eval%in n x > [%s%i y]\n" i c i; - fprintf fmt " end.\n"; - fprintf fmt " intros n x y.\n"; - fprintf fmt " unfold comparen_%i, to_Z; rewrite spec_gen_eval%in.\n" i i; - fprintf fmt " apply spec_compare_mn_1.\n"; - fprintf fmt " exact (spec_0 w%i_spec).\n" i; - if i == 0 then - fprintf fmt " intros x1; exact (spec_compare w%i_spec w_0 x1).\n" i - else - fprintf fmt " intros x1; exact (spec_compare w%i_spec W0 x1).\n" i; - fprintf fmt " exact (spec_to_Z w%i_spec).\n" i; - fprintf fmt " exact (spec_compare w%i_spec).\n" i; - fprintf fmt " exact (spec_compare w%i_spec).\n" i; - fprintf fmt " exact (spec_to_Z w%i_spec).\n" i; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - done; - - fprintf fmt " Let spec_opp_compare: forall c (u v: Z),\n"; - fprintf fmt " match c with Eq => u = v | Lt => u < v | Gt => u > v end ->\n"; - fprintf fmt " match opp_compare c with Eq => v = u | Lt => v < u | Gt => v > u end.\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros c u v; case c; unfold opp_compare; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " Theorem spec_compare: forall x y,\n"; - fprintf fmt " match compare x y with \n"; - fprintf fmt " Eq => [x] = [y]\n"; - fprintf fmt " | Lt => [x] < [y]\n"; - fprintf fmt " | Gt => [x] > [y]\n"; - fprintf fmt " end.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " refine (spec_iter _ (fun x y res => \n"; - fprintf fmt " match res with \n"; - fprintf fmt " Eq => x = y\n"; - fprintf fmt " | Lt => x < y\n"; - fprintf fmt " | Gt => x > y\n"; - fprintf fmt " end)\n"; - for i = 0 to size do - fprintf fmt " compare_%i\n" i; - fprintf fmt " (fun n x y => opp_compare (comparen_%i (S n) y x))\n" i; - fprintf fmt " (fun n => comparen_%i (S n)) _ _ _\n" i; - done; - fprintf fmt " comparenm _).\n"; - - for i = 0 to size - 1 do - fprintf fmt " exact spec_compare_%i.\n" i; - fprintf fmt " intros n x y H;apply spec_opp_compare; apply spec_comparen_%i.\n" i; - fprintf fmt " intros n x y H; exact (spec_comparen_%i (S n) x y).\n" i; - done; - fprintf fmt " exact spec_compare_%i.\n" size; - fprintf fmt " intros n x y;apply spec_opp_compare; apply spec_comparen_%i.\n" size; - fprintf fmt " intros n; exact (spec_comparen_%i (S n)).\n" size; - fprintf fmt " intros n m x y; unfold comparenm.\n"; - fprintf fmt " rewrite <- (spec_cast_l n m x); rewrite <- (spec_cast_r n m y).\n"; - fprintf fmt " unfold to_Z; apply (spec_compare (wn_spec (Max.max n m))).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition eq_bool x y :=\n"; - fprintf fmt " match compare x y with\n"; - fprintf fmt " | Eq => true\n"; - fprintf fmt " | _ => false\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_eq_bool: forall x y,\n"; - fprintf fmt " if eq_bool x y then [x] = [y] else [x] <> [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x y; unfold eq_bool.\n"; - fprintf fmt " generalize (spec_compare x y); case compare; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Multiplication *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - for i = 0 to size do - fprintf fmt " Definition w%i_mul_c := w%i_op.(znz_mul_c).\n" i i - done; - fprintf fmt "\n"; - - for i = 0 to size do - let s0 = if i = 0 then "w_0" else "W0" in - fprintf fmt " Definition w%i_mul_add :=\n" i; - fprintf fmt " Eval lazy beta delta [w_mul_add] in\n"; - fprintf fmt " %sw_mul_add w%i %s w%i_succ w%i_add_c w%i_mul_c.\n" - "@" i s0 i i i - done; - fprintf fmt "\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_0W := w%i_op.(znz_0W).\n" i i - done; - fprintf fmt "\n"; - - for i = 0 to size do - let s0 = if i = 0 then "w_0" else "W0" in - fprintf fmt " Definition w%i_mul_add_n1 :=\n" i; - fprintf fmt - " %sgen_mul_add_n1 w%i %s w%i_op.(znz_WW) w%i_0W w%i_mul_add.\n" - "@" i s0 i i i - done; - fprintf fmt "\n"; - - begin - for i = 0 to size - 1 do - fprintf fmt " Let to_Z%i n :=\n" i; - fprintf fmt " match n return word w%i (S n) -> t_ with\n" i; - for j = 0 to size - i do - if (i + j) == size then - begin - fprintf fmt " | %i%s => fun x => %sn 0 x\n" j "%nat" c; - fprintf fmt " | %i%s => fun x => %sn 1 x\n" (j + 1) "%nat" c - end - else - fprintf fmt " | %i%s => fun x => %s%i x\n" j "%nat" c (i + j + 1) - done; - fprintf fmt " | _ => fun _ => N0 w_0\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - done; - - - if gen_proof then - for i = 0 to size - 1 do - fprintf fmt "Theorem to_Z%i_spec:\n" i; - fprintf fmt " forall n x, Z_of_nat n <= %i -> [to_Z%i n x] = znz_to_Z (nmake_op _ w%i_op (S n)) x.\n" (size + 1 - i) i i; - for j = 1 to size + 2 - i do - fprintf fmt " intros n; case n; clear n.\n"; - fprintf fmt " unfold to_Z%i.\n" i; - fprintf fmt " intros x H; rewrite spec_eval%in%i; auto.\n" i j; - done; - fprintf fmt " intros n x.\n"; - fprintf fmt " repeat rewrite inj_S; unfold Zsucc; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - done; - end; - - for i = 0 to size do - fprintf fmt " Definition w%i_mul n x y :=\n" i; - if i == 0 then - fprintf fmt " let (w,r) := w%i_mul_add_n1 (S n) x y w_0 in\n" i - else - fprintf fmt " let (w,r) := w%i_mul_add_n1 (S n) x y W0 in\n" i; - if i == size then - begin - fprintf fmt " if w%i_eq0 w then %sn n r\n" i c; - fprintf fmt " else %sn (S n) (WW (extend%i n w) r).\n" c i; - end - else - begin - fprintf fmt " if w%i_eq0 w then to_Z%i n r\n" i i; - fprintf fmt " else to_Z%i (S n) (WW (extend%i n w) r).\n" i i; - end; - fprintf fmt "\n"; - done; - - fprintf fmt " Definition mulnm n m x y :=\n"; - fprintf fmt " let mn := Max.max n m in\n"; - fprintf fmt " let d := diff n m in\n"; - fprintf fmt " let op := make_op mn in\n"; - fprintf fmt " reduce_n (S mn) (op.(znz_mul_c)\n"; - fprintf fmt " (castm (diff_r n m) (extend_tr x (snd d)))\n"; - fprintf fmt " (castm (diff_l n m) (extend_tr y (fst d)))).\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition mul := Eval lazy beta delta [iter0] in \n"; - fprintf fmt " (iter0 t_ \n"; - for i = 0 to size do - fprintf fmt " (fun x y => reduce_%i (w%i_mul_c x y)) \n" (i + 1) i; - fprintf fmt " (fun n x y => w%i_mul n y x)\n" i; - fprintf fmt " w%i_mul\n" i; - done; - fprintf fmt " mulnm\n"; - fprintf fmt " (fun _ => N0 w_0)\n"; - fprintf fmt " (fun _ => N0 w_0)\n"; - fprintf fmt " ).\n"; - fprintf fmt "\n"; - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Let spec_w%i_mul_add: forall x y z,\n" i; - fprintf fmt " let (q,r) := w%i_mul_add x y z in\n" i; - fprintf fmt " znz_to_Z w%i_op q * (base (znz_digits w%i_op)) + znz_to_Z w%i_op r =\n" i i i; - fprintf fmt " znz_to_Z w%i_op x * znz_to_Z w%i_op y + znz_to_Z w%i_op z :=\n" i i i ; - fprintf fmt " (spec_mul_add w%i_spec).\n" i; - fprintf fmt "\n"; - done; - - for i = 0 to size do - - - fprintf fmt " Theorem spec_w%i_mul_add_n1: forall n x y z,\n" i; - fprintf fmt " let (q,r) := w%i_mul_add_n1 n x y z in\n" i; - fprintf fmt " znz_to_Z w%i_op q * (base (znz_digits (nmake_op _ w%i_op n))) +\n" i i; - fprintf fmt " znz_to_Z (nmake_op _ w%i_op n) r =\n" i; - fprintf fmt " znz_to_Z (nmake_op _ w%i_op n) x * znz_to_Z w%i_op y +\n" i i; - fprintf fmt " znz_to_Z w%i_op z.\n" i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x y z; unfold w%i_mul_add_n1.\n" i; - fprintf fmt " rewrite nmake_gen.\n"; - fprintf fmt " rewrite digits_gend.\n"; - fprintf fmt " change (base (GenBase.gen_digits (znz_digits w%i_op) n)) with\n" i; - fprintf fmt " (GenBase.gen_wB (znz_digits w%i_op) n).\n" i; - fprintf fmt " apply spec_gen_mul_add_n1; auto.\n"; - if i == 0 then fprintf fmt " exact (spec_0 w%i_spec).\n" i; - fprintf fmt " exact (spec_WW w%i_spec).\n" i; - fprintf fmt " exact (spec_0W w%i_spec).\n" i; - fprintf fmt " exact (spec_mul_add w%i_spec).\n" i; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - done; - - fprintf fmt " Lemma nmake_op_WW: forall ww ww1 n x y,\n"; - fprintf fmt " znz_to_Z (nmake_op ww ww1 (S n)) (WW x y) =\n"; - fprintf fmt " znz_to_Z (nmake_op ww ww1 n) x * base (znz_digits (nmake_op ww ww1 n)) +\n"; - fprintf fmt " znz_to_Z (nmake_op ww ww1 n) y.\n"; - fprintf fmt " auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - for i = 0 to size do - fprintf fmt " Lemma extend%in_spec: forall n x1,\n" i; - fprintf fmt " znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) = \n" i i; - fprintf fmt " znz_to_Z w%i_op x1.\n" i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n1 x2; rewrite nmake_gen.\n"; - fprintf fmt " unfold extend%i.\n" i; - fprintf fmt " rewrite GenBase.spec_extend; auto.\n"; - if (i == 0) then - fprintf fmt " intros l; simpl; unfold w_0; rewrite (spec_0 w0_spec); ring.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - done; - - fprintf fmt " Lemma spec_muln:\n"; - fprintf fmt " forall n (x: word _ (S n)) y,\n"; - fprintf fmt " [%sn (S n) (znz_mul_c (make_op n) x y)] = [%sn n x] * [%sn n y].\n" c c c; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x y; unfold to_Z.\n"; - fprintf fmt " rewrite <- (spec_mul_c (wn_spec n)).\n"; - fprintf fmt " rewrite make_op_S.\n"; - fprintf fmt " case znz_mul_c; auto.\n"; - fprintf fmt " Qed.\n"; - end; - - fprintf fmt " Theorem spec_mul: forall x y, [mul x y] = [x] * [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - for i = 0 to size do - fprintf fmt " assert(F%i: \n" i; - fprintf fmt " forall n x y,\n"; - if i <> size then - fprintf fmt " Z_of_nat n <= %i -> " (size - i); - fprintf fmt " [w%i_mul n x y] = eval%in (S n) x * [%s%i y]).\n" i i c i; - if i == size then - fprintf fmt " intros n x y; unfold w%i_mul.\n" i - else - fprintf fmt " intros n x y H; unfold w%i_mul.\n" i; - if i == 0 then - fprintf fmt " generalize (spec_w%i_mul_add_n1 (S n) x y w_0).\n" i - else - fprintf fmt " generalize (spec_w%i_mul_add_n1 (S n) x y W0).\n" i; - fprintf fmt " case w%i_mul_add_n1; intros x1 y1.\n" i; - fprintf fmt " change (znz_to_Z (nmake_op _ w%i_op (S n)) x) with (eval%in (S n) x).\n" i i; - fprintf fmt " change (znz_to_Z w%i_op y) with ([%s%i y]).\n" i c i; - if i == 0 then - fprintf fmt " unfold w_0; rewrite (spec_0 w0_spec); rewrite Zplus_0_r.\n" - else - fprintf fmt " change (znz_to_Z w%i_op W0) with 0; rewrite Zplus_0_r.\n" i; - fprintf fmt " intros H1; rewrite <- H1; clear H1.\n"; - fprintf fmt " generalize (spec_w%i_eq0 x1); case w%i_eq0; intros HH.\n" i i; - fprintf fmt " unfold to_Z in HH; rewrite HH.\n"; - if i == size then - begin - fprintf fmt " rewrite spec_eval%in; unfold eval%in, nmake_op%i; auto.\n" i i i; - fprintf fmt " rewrite spec_eval%in; unfold eval%in, nmake_op%i.\n" i i i - end - else - begin - fprintf fmt " rewrite to_Z%i_spec; auto with zarith.\n" i; - fprintf fmt " rewrite to_Z%i_spec; try (rewrite inj_S; auto with zarith).\n" i - end; - fprintf fmt " rewrite nmake_op_WW; rewrite extend%in_spec; auto.\n" i; - done; - fprintf fmt " refine (spec_iter0 t_ (fun x y res => [res] = x * y)\n"; - for i = 0 to size do - fprintf fmt " (fun x y => reduce_%i (w%i_mul_c x y)) \n" (i + 1) i; - fprintf fmt " (fun n x y => w%i_mul n y x)\n" i; - fprintf fmt " w%i_mul _ _ _\n" i; - done; - fprintf fmt " mulnm _\n"; - fprintf fmt " (fun _ => N0 w_0) _\n"; - fprintf fmt " (fun _ => N0 w_0) _\n"; - fprintf fmt " ).\n"; - for i = 0 to size do - fprintf fmt " intros x y; rewrite spec_reduce_%i.\n" (i + 1); - fprintf fmt " unfold w%i_mul_c, to_Z.\n" i; - fprintf fmt " generalize (spec_mul_c w%i_spec x y).\n" i; - fprintf fmt " intros HH; rewrite <- HH; clear HH; auto.\n"; - if i == size then - begin - fprintf fmt " intros n x y; rewrite F%i; auto with zarith.\n" i; - fprintf fmt " intros n x y; rewrite F%i; auto with zarith. \n" i; - end - else - begin - fprintf fmt " intros n x y H; rewrite F%i; auto with zarith.\n" i; - fprintf fmt " intros n x y H; rewrite F%i; auto with zarith. \n" i; - end; - done; - fprintf fmt " intros n m x y; unfold mulnm.\n"; - fprintf fmt " rewrite spec_reduce_n.\n"; - fprintf fmt " rewrite <- (spec_cast_l n m x).\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y).\n"; - fprintf fmt " rewrite spec_muln; rewrite spec_cast_l; rewrite spec_cast_r; auto.\n"; - fprintf fmt " intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring.\n"; - fprintf fmt " intros x; unfold to_Z, w_0; rewrite (spec_0 w0_spec); ring.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Square *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - for i = 0 to size do - fprintf fmt " Definition w%i_square_c := w%i_op.(znz_square_c).\n" i i - done; - fprintf fmt "\n"; - - fprintf fmt " Definition square x :=\n"; - fprintf fmt " match x with\n"; - fprintf fmt " | %s0 wx => reduce_1 (w0_square_c wx)\n" c; - for i = 1 to size - 1 do - fprintf fmt " | %s%i wx => %s%i (w%i_square_c wx)\n" c i c (i+1) i - done; - fprintf fmt " | %s%i wx => %sn 0 (w%i_square_c wx)\n" c size c size; - fprintf fmt " | %sn n wx =>\n" c; - fprintf fmt " let op := make_op n in\n"; - fprintf fmt " %sn (S n) (op.(znz_square_c) wx)\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_square: forall x, [square x] = [x] * [x].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold square; clear x.\n"; - fprintf fmt " intros x; rewrite spec_reduce_1; unfold to_Z.\n"; - fprintf fmt " exact (spec_square_c w%i_spec x).\n" 0; - for i = 1 to size do - fprintf fmt " intros x; unfold to_Z.\n"; - fprintf fmt " exact (spec_square_c w%i_spec x).\n" i; - done; - fprintf fmt " intros n x; unfold to_Z.\n"; - fprintf fmt " rewrite make_op_S.\n"; - fprintf fmt " exact (spec_square_c (wn_spec n) x).\n"; - fprintf fmt "Qed.\n"; - end - else - fprintf fmt "Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Power *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - fprintf fmt " Fixpoint power_pos (x:%s) (p:positive) {struct p} : %s :=\n" - t t; - fprintf fmt " match p with\n"; - fprintf fmt " | xH => x\n"; - fprintf fmt " | xO p => square (power_pos x p)\n"; - fprintf fmt " | xI p => mul (square (power_pos x p)) x\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x n; generalize x; elim n; clear n x; simpl power_pos.\n"; - fprintf fmt " intros; rewrite spec_mul; rewrite spec_square; rewrite H.\n"; - fprintf fmt " rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith.\n"; - fprintf fmt " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_2; rewrite Zpower_1_r; auto.\n"; - fprintf fmt " intros; rewrite spec_square; rewrite H.\n"; - fprintf fmt " rewrite Zpos_xO; auto with zarith.\n"; - fprintf fmt " rewrite (Zmult_comm 2); rewrite Zpower_mult; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_2; auto.\n"; - fprintf fmt " intros; rewrite Zpower_1_r; auto.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Square root *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_sqrt := w%i_op.(znz_sqrt).\n" i i - done; - fprintf fmt "\n"; - - fprintf fmt " Definition sqrt x :=\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wx => reduce_%i (w%i_sqrt wx)\n" c i i i; - done; - fprintf fmt " | %sn n wx =>\n" c; - fprintf fmt " let op := make_op n in\n"; - fprintf fmt " reduce_n n (op.(znz_sqrt) wx)\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - - fprintf fmt " Theorem spec_sqrt: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; unfold sqrt; case x; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; rewrite spec_reduce_%i; exact (spec_sqrt w%i_spec x).\n" i i; - done; - fprintf fmt " intros n x; rewrite spec_reduce_n; exact (spec_sqrt (wn_spec n) x).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt "Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Division *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - - (* Division *) - for i = 0 to size do - fprintf fmt " Definition w%i_div_gt := w%i_op.(znz_div_gt).\n" i i - done; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Let spec_divn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := \n"; - fprintf fmt " (spec_gen_divn1 \n"; - fprintf fmt " ww_op.(znz_zdigits) ww_op.(znz_0)\n"; - fprintf fmt " ww_op.(znz_WW) ww_op.(znz_head0)\n"; - fprintf fmt " ww_op.(znz_add_mul_div) ww_op.(znz_div21)\n"; - fprintf fmt " ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)\n"; - fprintf fmt " (spec_to_Z ww_spec) \n"; - fprintf fmt " (spec_zdigits ww_spec)\n"; - fprintf fmt " (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)\n"; - fprintf fmt " (spec_add_mul_div ww_spec) (spec_div21 ww_spec) \n"; - fprintf fmt " (ZnZ.spec_compare ww_spec) (ZnZ.spec_sub ww_spec)).\n"; - fprintf fmt " \n"; - end; - - for i = 0 to size do - fprintf fmt " Definition w%i_divn1 n x y :=\n" i; - fprintf fmt " let (u, v) :=\n"; - fprintf fmt " gen_divn1 w%i_op.(znz_zdigits) w%i_op.(znz_0)\n" i i; - fprintf fmt " w%i_op.(znz_WW) w%i_op.(znz_head0)\n" i i; - fprintf fmt " w%i_op.(znz_add_mul_div) w%i_op.(znz_div21)\n" i i; - fprintf fmt " w%i_op.(znz_compare) w%i_op.(znz_sub) (S n) x y in\n" i i; - if i == size then - fprintf fmt " (%sn _ u, %s%i v).\n" c c i - else - fprintf fmt " (to_Z%i _ u, %s%i v).\n" i c i; - done; - fprintf fmt "\n"; - - - if gen_proof then - begin - for i = 0 to size do - fprintf fmt " Lemma spec_get_end%i: forall n x y,\n" i; - fprintf fmt " eval%in n x <= [%s%i y] -> \n" i c i; - fprintf fmt " [%s%i (GenBase.get_low %s n x)] = eval%in n x.\n" c i (pz i) i; - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x y H.\n"; - fprintf fmt " rewrite spec_gen_eval%in; unfold to_Z.\n" i; - fprintf fmt " apply GenBase.spec_get_low.\n"; - fprintf fmt " exact (spec_0 w%i_spec).\n" i; - fprintf fmt " exact (spec_to_Z w%i_spec).\n" i; - fprintf fmt " apply Zle_lt_trans with [%s%i y]; auto.\n" c i; - fprintf fmt " rewrite <- spec_gen_eval%in; auto.\n" i; - fprintf fmt " unfold to_Z; case (spec_to_Z w%i_spec y); auto.\n" i; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - done ; - end; - - for i = 0 to size do - fprintf fmt " Let div_gt%i x y := let (u,v) := (w%i_div_gt x y) in (reduce_%i u, reduce_%i v).\n" i i i i; - done; - fprintf fmt "\n"; - - - fprintf fmt " Let div_gtnm n m wx wy :=\n"; - fprintf fmt " let mn := Max.max n m in\n"; - fprintf fmt " let d := diff n m in\n"; - fprintf fmt " let op := make_op mn in\n"; - fprintf fmt " let (q, r):= op.(znz_div_gt)\n"; - fprintf fmt " (castm (diff_r n m) (extend_tr wx (snd d)))\n"; - fprintf fmt " (castm (diff_l n m) (extend_tr wy (fst d))) in\n"; - fprintf fmt " (reduce_n mn q, reduce_n mn r).\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition div_gt := Eval lazy beta delta [iter] in\n"; - fprintf fmt " (iter _ \n"; - for i = 0 to size do - fprintf fmt " div_gt%i\n" i; - fprintf fmt " (fun n x y => div_gt%i x (GenBase.get_low %s (S n) y))\n" i (pz i); - fprintf fmt " w%i_divn1\n" i; - done; - fprintf fmt " div_gtnm).\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_div_gt: forall x y,\n"; - fprintf fmt " [x] > [y] -> 0 < [y] ->\n"; - fprintf fmt " let (q,r) := div_gt x y in\n"; - fprintf fmt " [q] = [x] / [y] /\\ [r] = [x] mod [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (FO:\n"; - fprintf fmt " forall x y, [x] > [y] -> 0 < [y] ->\n"; - fprintf fmt " let (q,r) := div_gt x y in\n"; - fprintf fmt " [x] = [q] * [y] + [r] /\\ 0 <= [r] < [y]).\n"; - fprintf fmt " refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->\n"; fprintf fmt " let (q,r) := res in\n"; - fprintf fmt " x = [q] * y + [r] /\\ 0 <= [r] < y)\n"; - for i = 0 to size do - fprintf fmt " div_gt%i\n" i; - fprintf fmt " (fun n x y => div_gt%i x (GenBase.get_low %s (S n) y))\n" i (pz i); - fprintf fmt " w%i_divn1 _ _ _\n" i; - done; - fprintf fmt " div_gtnm _).\n"; - for i = 0 to size do - fprintf fmt " intros x y H1 H2; unfold div_gt%i, w%i_div_gt.\n" i i; - fprintf fmt " generalize (spec_div_gt w%i_spec x y H1 H2); case znz_div_gt.\n" i; - fprintf fmt " intros xx yy; repeat rewrite spec_reduce_%i; auto.\n" i; - if i == size then - fprintf fmt " intros n x y H2 H3; unfold div_gt%i, w%i_div_gt.\n" i i - else - fprintf fmt " intros n x y H1 H2 H3; unfold div_gt%i, w%i_div_gt.\n" i i; - fprintf fmt " generalize (spec_div_gt w%i_spec x \n" i; - fprintf fmt " (GenBase.get_low %s (S n) y)).\n" (pz i); - fprintf fmt " "; - for j = 0 to i do - fprintf fmt "unfold w%i;" (i-j); - done; - fprintf fmt "case znz_div_gt.\n"; - fprintf fmt " intros xx yy H4; repeat rewrite spec_reduce_%i.\n" i; - fprintf fmt " generalize (spec_get_end%i (S n) y x); unfold to_Z; intros H5.\n" i; - fprintf fmt " unfold to_Z in H2; rewrite H5 in H4; auto with zarith.\n"; - if i == size then - fprintf fmt " intros n x y H2 H3.\n" - else - fprintf fmt " intros n x y H1 H2 H3.\n"; - fprintf fmt " generalize\n"; - fprintf fmt " (spec_divn1 w%i w%i_op w%i_spec (S n) x y H3).\n" i i i; - fprintf fmt " unfold w%i_divn1;" i; - for j = 0 to i do - fprintf fmt "unfold w%i;" (i-j); - done; - fprintf fmt " case gen_divn1.\n"; - fprintf fmt " intros xx yy H4.\n"; - if i == size then - begin - fprintf fmt " repeat rewrite <- spec_gen_eval%in in H4; auto.\n" i; - fprintf fmt " rewrite spec_eval%in; auto.\n" i; - end - else - begin - fprintf fmt " rewrite to_Z%i_spec; auto with zarith.\n" i; - fprintf fmt " repeat rewrite <- spec_gen_eval%in in H4; auto.\n" i; - end; - done; - fprintf fmt " intros n m x y H1 H2; unfold div_gtnm.\n"; - fprintf fmt " generalize (spec_div_gt (wn_spec (Max.max n m))\n"; - fprintf fmt " (castm (diff_r n m)\n"; - fprintf fmt " (extend_tr x (snd (diff n m))))\n"; - fprintf fmt " (castm (diff_l n m)\n"; - fprintf fmt " (extend_tr y (fst (diff n m))))).\n"; - fprintf fmt " case znz_div_gt.\n"; - fprintf fmt " intros xx yy HH.\n"; - fprintf fmt " repeat rewrite spec_reduce_n.\n"; - fprintf fmt " rewrite <- (spec_cast_l n m x).\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y).\n"; - fprintf fmt " unfold to_Z; apply HH.\n"; - fprintf fmt " rewrite <- (spec_cast_l n m x) in H1; auto.\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y) in H1; auto.\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y) in H2; auto.\n"; - fprintf fmt " intros x y H1 H2; generalize (FO x y H1 H2); case div_gt.\n"; - fprintf fmt " intros q r (H3, H4); split.\n"; - fprintf fmt " apply (Zdiv_unique [x] [y] [q] [r]); auto.\n"; - fprintf fmt " rewrite Zmult_comm; auto.\n"; - fprintf fmt " apply (Zmod_unique [x] [y] [q] [r]); auto.\n"; - fprintf fmt " rewrite Zmult_comm; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition div_eucl x y :=\n"; - fprintf fmt " match compare x y with\n"; - fprintf fmt " | Eq => (one, zero)\n"; - fprintf fmt " | Lt => (zero, x)\n"; - fprintf fmt " | Gt => div_gt x y\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_div_eucl: forall x y,\n"; - fprintf fmt " 0 < [y] ->\n"; - fprintf fmt " let (q,r) := div_eucl x y in\n"; - fprintf fmt " ([q], [r]) = Zdiv_eucl [x] [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F0: [zero] = 0).\n"; - fprintf fmt " exact (spec_0 w0_spec).\n"; - fprintf fmt " assert (F1: [one] = 1).\n"; - fprintf fmt " exact (spec_1 w0_spec).\n"; - fprintf fmt " intros x y H; generalize (spec_compare x y);\n"; - fprintf fmt " unfold div_eucl; case compare; try rewrite F0;\n"; - fprintf fmt " try rewrite F1; intros; auto with zarith.\n"; - fprintf fmt " rewrite H0; generalize (Z_div_same [y] (Zlt_gt _ _ H))\n"; - fprintf fmt " (Z_mod_same [y] (Zlt_gt _ _ H));\n"; - fprintf fmt " unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.\n"; - fprintf fmt " assert (F2: 0 <= [x] < [y]).\n"; - fprintf fmt " generalize (spec_pos x); auto.\n"; - fprintf fmt " generalize (Zdiv_small _ _ F2)\n"; - fprintf fmt " (Zmod_small _ _ F2);\n"; - fprintf fmt " unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.\n"; - fprintf fmt " generalize (spec_div_gt _ _ H0 H); auto.\n"; - fprintf fmt " unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt.\n"; - fprintf fmt " intros a b c d (H1, H2); subst; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition div x y := fst (div_eucl x y).\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_div:\n"; - fprintf fmt " forall x y, 0 < [y] -> [div x y] = [x] / [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x y H1; unfold div; generalize (spec_div_eucl x y H1);\n"; - fprintf fmt " case div_eucl; simpl fst.\n"; - fprintf fmt " intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H; \n"; - fprintf fmt " injection H; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Modulo *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_mod_gt := w%i_op.(znz_mod_gt).\n" i i - done; - fprintf fmt "\n"; - - for i = 0 to size do - fprintf fmt " Definition w%i_modn1 :=\n" i; - fprintf fmt " gen_modn1 w%i_op.(znz_zdigits) w%i_op.(znz_0)\n" i i; - fprintf fmt " w%i_op.(znz_head0) w%i_op.(znz_add_mul_div) w%i_op.(znz_div21)\n" i i i; - fprintf fmt " w%i_op.(znz_compare) w%i_op.(znz_sub).\n" i i; - done; - fprintf fmt "\n"; - - fprintf fmt " Let mod_gtnm n m wx wy :=\n"; - fprintf fmt " let mn := Max.max n m in\n"; - fprintf fmt " let d := diff n m in\n"; - fprintf fmt " let op := make_op mn in\n"; - fprintf fmt " reduce_n mn (op.(znz_mod_gt)\n"; - fprintf fmt " (castm (diff_r n m) (extend_tr wx (snd d)))\n"; - fprintf fmt " (castm (diff_l n m) (extend_tr wy (fst d)))).\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition mod_gt := Eval lazy beta delta[iter] in\n"; - fprintf fmt " (iter _ \n"; - for i = 0 to size do - fprintf fmt " (fun x y => reduce_%i (w%i_mod_gt x y))\n" i i; - fprintf fmt " (fun n x y => reduce_%i (w%i_mod_gt x (GenBase.get_low %s (S n) y)))\n" i i (pz i); - fprintf fmt " (fun n x y => reduce_%i (w%i_modn1 (S n) x y))\n" i i; - done; - fprintf fmt " mod_gtnm).\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Let spec_modn1 ww (ww_op: znz_op ww) (ww_spec: znz_spec ww_op) := \n"; - fprintf fmt " (spec_gen_modn1 \n"; - fprintf fmt " ww_op.(znz_zdigits) ww_op.(znz_0)\n"; - fprintf fmt " ww_op.(znz_WW) ww_op.(znz_head0)\n"; - fprintf fmt " ww_op.(znz_add_mul_div) ww_op.(znz_div21)\n"; - fprintf fmt " ww_op.(znz_compare) ww_op.(znz_sub) (znz_to_Z ww_op)\n"; - fprintf fmt " (spec_to_Z ww_spec) \n"; - fprintf fmt " (spec_zdigits ww_spec)\n"; - fprintf fmt " (spec_0 ww_spec) (spec_WW ww_spec) (spec_head0 ww_spec)\n"; - fprintf fmt " (spec_add_mul_div ww_spec) (spec_div21 ww_spec) \n"; - fprintf fmt " (ZnZ.spec_compare ww_spec) (ZnZ.spec_sub ww_spec)).\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " Theorem spec_mod_gt:\n"; - fprintf fmt " forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " refine (spec_iter _ (fun x y res => x > y -> 0 < y ->\n"; - fprintf fmt " [res] = x mod y)\n"; - for i = 0 to size do - fprintf fmt " (fun x y => reduce_%i (w%i_mod_gt x y))\n" i i; - fprintf fmt " (fun n x y => reduce_%i (w%i_mod_gt x (GenBase.get_low %s (S n) y)))\n" i i (pz i); - fprintf fmt " (fun n x y => reduce_%i (w%i_modn1 (S n) x y)) _ _ _\n" i i; - done; - fprintf fmt " mod_gtnm _).\n"; - for i = 0 to size do - fprintf fmt " intros x y H1 H2; rewrite spec_reduce_%i.\n" i; - fprintf fmt " exact (spec_mod_gt w%i_spec x y H1 H2).\n" i; - if i == size then - fprintf fmt " intros n x y H2 H3; rewrite spec_reduce_%i.\n" i - else - fprintf fmt " intros n x y H1 H2 H3; rewrite spec_reduce_%i.\n" i; - fprintf fmt " unfold w%i_mod_gt.\n" i; - fprintf fmt " rewrite <- (spec_get_end%i (S n) y x); auto with zarith.\n" i; - fprintf fmt " unfold to_Z; apply (spec_mod_gt w%i_spec); auto.\n" i; - fprintf fmt " rewrite <- (spec_get_end%i (S n) y x) in H2; auto with zarith.\n" i; - fprintf fmt " rewrite <- (spec_get_end%i (S n) y x) in H3; auto with zarith.\n" i; - if i == size then - fprintf fmt " intros n x y H2 H3; rewrite spec_reduce_%i.\n" i - else - fprintf fmt " intros n x y H1 H2 H3; rewrite spec_reduce_%i.\n" i; - fprintf fmt " unfold w%i_modn1, to_Z; rewrite spec_gen_eval%in.\n" i i; - fprintf fmt " apply (spec_modn1 _ _ w%i_spec); auto.\n" i; - done; - fprintf fmt " intros n m x y H1 H2; unfold mod_gtnm.\n"; - fprintf fmt " repeat rewrite spec_reduce_n.\n"; - fprintf fmt " rewrite <- (spec_cast_l n m x).\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y).\n"; - fprintf fmt " unfold to_Z; apply (spec_mod_gt (wn_spec (Max.max n m))).\n"; - fprintf fmt " rewrite <- (spec_cast_l n m x) in H1; auto.\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y) in H1; auto.\n"; - fprintf fmt " rewrite <- (spec_cast_r n m y) in H2; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition modulo x y := \n"; - fprintf fmt " match compare x y with\n"; - fprintf fmt " | Eq => zero\n"; - fprintf fmt " | Lt => x\n"; - fprintf fmt " | Gt => mod_gt x y\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_modulo:\n"; - fprintf fmt " forall x y, 0 < [y] -> [modulo x y] = [x] mod [y].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F0: [zero] = 0).\n"; - fprintf fmt " exact (spec_0 w0_spec).\n"; - fprintf fmt " assert (F1: [one] = 1).\n"; - fprintf fmt " exact (spec_1 w0_spec).\n"; - fprintf fmt " intros x y H; generalize (spec_compare x y);\n"; - fprintf fmt " unfold modulo; case compare; try rewrite F0;\n"; - fprintf fmt " try rewrite F1; intros; try split; auto with zarith.\n"; - fprintf fmt " rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith.\n"; - fprintf fmt " apply sym_equal; apply Zmod_small; auto with zarith.\n"; - fprintf fmt " generalize (spec_pos x); auto with zarith.\n"; - fprintf fmt " apply spec_mod_gt; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Gcd *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - fprintf fmt " Definition digits x :=\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i _ => w%i_op.(znz_digits)\n" c i i; - done; - fprintf fmt " | %sn n _ => (make_op n).(znz_digits)\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x).\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; unfold to_Z, digits;\n"; - fprintf fmt " generalize (spec_to_Z w%i_spec x); unfold base; intros H; exact H.\n" i; - done; - fprintf fmt " intros n x; unfold to_Z, digits;\n"; - fprintf fmt " generalize (spec_to_Z (wn_spec n) x); unfold base; intros H; exact H.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Definition gcd_gt_body a b cont :=\n"; - fprintf fmt " match compare b zero with\n"; - fprintf fmt " | Gt =>\n"; - fprintf fmt " let r := mod_gt a b in\n"; - fprintf fmt " match compare r zero with\n"; - fprintf fmt " | Gt => cont r (mod_gt b r)\n"; - fprintf fmt " | _ => b\n"; - fprintf fmt " end\n"; - fprintf fmt " | _ => a\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Theorem Zspec_gcd_gt_body: forall a b cont p,\n"; - fprintf fmt " [a] > [b] -> [a] < 2 ^ p ->\n"; - fprintf fmt " (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] ->\n"; - fprintf fmt " Zis_gcd [a1] [b1] [cont a1 b1]) -> \n"; - fprintf fmt " Zis_gcd [a] [b] [gcd_gt_body a b cont].\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F1: [zero] = 0).\n"; - fprintf fmt " unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.\n"; - fprintf fmt " intros a b cont p H2 H3 H4; unfold gcd_gt_body.\n"; - fprintf fmt " generalize (spec_compare b zero); case compare; try rewrite F1.\n"; - fprintf fmt " intros HH; rewrite HH; apply Zis_gcd_0.\n"; - fprintf fmt " intros HH; absurd (0 <= [b]); auto with zarith.\n"; - fprintf fmt " case (spec_digits b); auto with zarith.\n"; - fprintf fmt " intros H5; generalize (spec_compare (mod_gt a b) zero); \n"; - fprintf fmt " case compare; try rewrite F1.\n"; - fprintf fmt " intros H6; rewrite <- (Zmult_1_r [b]).\n"; - fprintf fmt " rewrite (Z_div_mod_eq [a] [b]); auto with zarith.\n"; - fprintf fmt " rewrite <- spec_mod_gt; auto with zarith.\n"; - fprintf fmt " rewrite H6; rewrite Zplus_0_r.\n"; - fprintf fmt " apply Zis_gcd_mult; apply Zis_gcd_1.\n"; - fprintf fmt " intros; apply False_ind.\n"; - fprintf fmt " case (spec_digits (mod_gt a b)); auto with zarith.\n"; - fprintf fmt " intros H6; apply GenDiv.Zis_gcd_mod; auto with zarith.\n"; - fprintf fmt " apply GenDiv.Zis_gcd_mod; auto with zarith.\n"; - fprintf fmt " rewrite <- spec_mod_gt; auto with zarith.\n"; - fprintf fmt " assert (F2: [b] > [mod_gt a b]).\n"; - fprintf fmt " case (Z_mod_lt [a] [b]); auto with zarith.\n"; - fprintf fmt " repeat rewrite <- spec_mod_gt; auto with zarith.\n"; - fprintf fmt " assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)]).\n"; - fprintf fmt " case (Z_mod_lt [b] [mod_gt a b]); auto with zarith.\n"; - fprintf fmt " rewrite <- spec_mod_gt; auto with zarith.\n"; - fprintf fmt " repeat rewrite <- spec_mod_gt; auto with zarith.\n"; - fprintf fmt " apply H4; auto with zarith.\n"; - fprintf fmt " apply Zmult_lt_reg_r with 2; auto with zarith.\n"; - fprintf fmt " apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith.\n"; - fprintf fmt " apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith.\n"; - fprintf fmt " apply Zplus_le_compat_r.\n"; - fprintf fmt " pattern [b] at 1; rewrite <- (Zmult_1_l [b]).\n"; - fprintf fmt " apply Zmult_le_compat_r; auto with zarith.\n"; - fprintf fmt " case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith.\n"; - fprintf fmt " intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2;\n"; - fprintf fmt " try rewrite <- HH in H2; auto with zarith.\n"; - fprintf fmt " case (Z_mod_lt [a] [b]); auto with zarith.\n"; - fprintf fmt " rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith.\n"; - fprintf fmt " rewrite <- Z_div_mod_eq; auto with zarith.\n"; - fprintf fmt " pattern 2 at 2; rewrite <- (Zpower_1_r 2).\n"; - fprintf fmt " rewrite <- Zpower_exp; auto with zarith.\n"; - fprintf fmt " ring_simplify (p - 1 + 1); auto.\n"; - fprintf fmt " case (Zle_lt_or_eq 0 p); auto with zarith.\n"; - fprintf fmt " generalize H3; case p; simpl Zpower; auto with zarith.\n"; - fprintf fmt " intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t :=\n"; - fprintf fmt " gcd_gt_body a b\n"; - fprintf fmt " (fun a b =>\n"; - fprintf fmt " match p with\n"; - fprintf fmt " | xH => cont a b\n"; - fprintf fmt " | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b\n"; - fprintf fmt " | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b\n"; - fprintf fmt " end).\n"; - fprintf fmt "\n"; - - if gen_proof then - begin - fprintf fmt " Theorem Zspec_gcd_gt_aux: forall p n a b cont,\n"; - fprintf fmt " [a] > [b] -> [a] < 2 ^ (Zpos p + n) ->\n"; - fprintf fmt " (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] ->\n"; - fprintf fmt " Zis_gcd [a1] [b1] [cont a1 b1]) ->\n"; - fprintf fmt " Zis_gcd [a] [b] [gcd_gt_aux p cont a b].\n"; - fprintf fmt " intros p; elim p; clear p.\n"; - fprintf fmt " intros p Hrec n a b cont H2 H3 H4.\n"; - fprintf fmt " unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto.\n"; - fprintf fmt " intros a1 b1 H6 H7.\n"; - fprintf fmt " apply Hrec with (Zpos p + n); auto.\n"; - fprintf fmt " replace (Zpos p + (Zpos p + n)) with\n"; - fprintf fmt " (Zpos (xI p) + n - 1); auto.\n"; - fprintf fmt " rewrite Zpos_xI; ring.\n"; - fprintf fmt " intros a2 b2 H9 H10.\n"; - fprintf fmt " apply Hrec with n; auto.\n"; - fprintf fmt " intros p Hrec n a b cont H2 H3 H4.\n"; - fprintf fmt " unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto.\n"; - fprintf fmt " intros a1 b1 H6 H7.\n"; - fprintf fmt " apply Hrec with (Zpos p + n - 1); auto.\n"; - fprintf fmt " replace (Zpos p + (Zpos p + n - 1)) with\n"; - fprintf fmt " (Zpos (xO p) + n - 1); auto.\n"; - fprintf fmt " rewrite Zpos_xO; ring.\n"; - fprintf fmt " intros a2 b2 H9 H10.\n"; - fprintf fmt " apply Hrec with (n - 1); auto.\n"; - fprintf fmt " replace (Zpos p + (n - 1)) with\n"; - fprintf fmt " (Zpos p + n - 1); auto with zarith.\n"; - fprintf fmt " intros a3 b3 H12 H13; apply H4; auto with zarith.\n"; - fprintf fmt " apply Zlt_le_trans with (1 := H12).\n"; - fprintf fmt " case (Zle_or_lt 1 n); intros HH.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " apply Zle_trans with 0; auto with zarith.\n"; - fprintf fmt " assert (HH1: n - 1 < 0); auto with zarith.\n"; - fprintf fmt " generalize HH1; case (n - 1); auto with zarith.\n"; - fprintf fmt " intros p1 HH2; discriminate.\n"; - fprintf fmt " intros n a b cont H H2 H3.\n"; - fprintf fmt " simpl gcd_gt_aux.\n"; - fprintf fmt " apply Zspec_gcd_gt_body with (n + 1); auto with zarith.\n"; - fprintf fmt " rewrite Zplus_comm; auto.\n"; - fprintf fmt " intros a1 b1 H5 H6; apply H3; auto.\n"; - fprintf fmt " replace n with (n + 1 - 1); auto; try ring.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - end; - - fprintf fmt " Definition gcd_cont a b :=\n"; - fprintf fmt " match compare one b with\n"; - fprintf fmt " | Eq => one\n"; - fprintf fmt " | _ => a\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_gcd_gt: forall a b,\n"; - fprintf fmt " [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros a b H2.\n"; - fprintf fmt " case (spec_digits (gcd_gt a b)); intros H3 H4.\n"; - fprintf fmt " case (spec_digits a); intros H5 H6.\n"; - fprintf fmt " apply sym_equal; apply Zis_gcd_gcd; auto with zarith.\n"; - fprintf fmt " unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith.\n"; - fprintf fmt " intros a1 a2; rewrite Zpower_0_r.\n"; - fprintf fmt " case (spec_digits a2); intros H7 H8;\n"; - fprintf fmt " intros; apply False_ind; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition gcd a b :=\n"; - fprintf fmt " match compare a b with\n"; - fprintf fmt " | Eq => a\n"; - fprintf fmt " | Lt => gcd_gt b a\n"; - fprintf fmt " | Gt => gcd_gt a b\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros a b.\n"; - fprintf fmt " case (spec_digits a); intros H1 H2.\n"; - fprintf fmt " case (spec_digits b); intros H3 H4.\n"; - fprintf fmt " unfold gcd; generalize (spec_compare a b); case compare.\n"; - fprintf fmt " intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto.\n"; - fprintf fmt " apply Zis_gcd_refl.\n"; - fprintf fmt " intros; apply trans_equal with (Zgcd [b] [a]).\n"; - fprintf fmt " apply spec_gcd_gt; auto with zarith.\n"; - fprintf fmt " apply Zis_gcd_gcd; auto with zarith.\n"; - fprintf fmt " apply Zgcd_is_pos.\n"; - fprintf fmt " apply Zis_gcd_sym; apply Zgcd_is_gcd.\n"; - fprintf fmt " intros; apply spec_gcd_gt; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Conversion *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - fprintf fmt " Definition pheight p := \n"; - fprintf fmt " Peano.pred (nat_of_P (get_height w0_op.(znz_digits) (plength p))).\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem pheight_correct: forall p, \n"; - fprintf fmt " Zpos p < 2 ^ (Zpos (znz_digits w0_op) * 2 ^ (Z_of_nat (pheight p))).\n"; - fprintf fmt " Proof.\n"; - fprintf fmt " intros p; unfold pheight.\n"; - fprintf fmt " assert (F1: forall x, Z_of_nat (Peano.pred (nat_of_P x)) = Zpos x - 1).\n"; - fprintf fmt " intros x.\n"; - fprintf fmt " assert (Zsucc (Z_of_nat (Peano.pred (nat_of_P x))) = Zpos x); auto with zarith.\n"; - fprintf fmt " rewrite <- inj_S.\n"; - fprintf fmt " rewrite <- (fun x => S_pred x 0); auto with zarith.\n"; - fprintf fmt " rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto.\n"; - fprintf fmt " apply lt_le_trans with 1%snat; auto with zarith.\n" "%"; - fprintf fmt " exact (le_Pmult_nat x 1).\n"; - fprintf fmt " rewrite F1; clear F1.\n"; - fprintf fmt " assert (F2:= (get_height_correct (znz_digits w0_op) (plength p))).\n"; - fprintf fmt " apply Zlt_le_trans with (Zpos (Psucc p)).\n"; - fprintf fmt " rewrite Zpos_succ_morphism; auto with zarith.\n"; - fprintf fmt " apply Zle_trans with (1 := plength_pred_correct (Psucc p)).\n"; - fprintf fmt " rewrite Ppred_succ.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition of_pos x :=\n"; - fprintf fmt " let h := pheight x in\n"; - fprintf fmt " match h with\n"; - for i = 0 to size do - fprintf fmt " | %i%snat => reduce_%i (snd (w%i_op.(znz_of_pos) x))\n" i "%" i i; - done; - fprintf fmt " | _ =>\n"; - fprintf fmt " let n := minus h %i in\n" (size + 1); - fprintf fmt " reduce_n n (snd ((make_op n).(znz_of_pos) x))\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_of_pos: forall x,\n"; - fprintf fmt " [of_pos x] = Zpos x.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F := spec_more_than_1_digit w0_spec).\n"; - fprintf fmt " intros x; unfold of_pos; case_eq (pheight x).\n"; - for i = 0 to size do - if i <> 0 then - fprintf fmt " intros n; case n; clear n.\n"; - fprintf fmt " intros H1; rewrite spec_reduce_%i; unfold to_Z.\n" i; - fprintf fmt " apply (znz_of_pos_correct w%i_spec).\n" i; - fprintf fmt " apply Zlt_le_trans with (1 := pheight_correct x).\n"; - fprintf fmt " rewrite H1; simpl Z_of_nat; change (2^%i) with (%s).\n" i (gen2 i); - fprintf fmt " unfold base.\n"; - fprintf fmt " apply Zpower_le_monotone; split; auto with zarith.\n"; - if i <> 0 then - begin - fprintf fmt " rewrite Zmult_comm; repeat rewrite <- Zmult_assoc.\n"; - fprintf fmt " repeat rewrite <- Zpos_xO.\n"; - fprintf fmt " refine (Zle_refl _).\n"; - end; - done; - fprintf fmt " intros n.\n"; - fprintf fmt " intros H1; rewrite spec_reduce_n; unfold to_Z.\n"; - fprintf fmt " simpl minus; rewrite <- minus_n_O.\n"; - fprintf fmt " apply (znz_of_pos_correct (wn_spec n)).\n"; - fprintf fmt " apply Zlt_le_trans with (1 := pheight_correct x).\n"; - fprintf fmt " unfold base.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " rewrite H1.\n"; - fprintf fmt " elim n; clear n H1.\n"; - fprintf fmt " simpl Z_of_nat; change (2^%i) with (%s).\n" (size + 1) (gen2 (size + 1)); - fprintf fmt " rewrite Zmult_comm; repeat rewrite <- Zmult_assoc.\n"; - fprintf fmt " repeat rewrite <- Zpos_xO.\n"; - fprintf fmt " refine (Zle_refl _).\n"; - fprintf fmt " intros n Hrec.\n"; - fprintf fmt " rewrite make_op_S.\n"; - fprintf fmt " change (%sznz_digits (word _ (S (S n))) (mk_zn2z_op_karatsuba (make_op n))) with\n" "@"; - fprintf fmt " (xO (znz_digits (make_op n))).\n"; - fprintf fmt " rewrite (fun x y => (Zpos_xO (%sznz_digits x y))).\n" "@"; - fprintf fmt " rewrite inj_S; unfold Zsucc.\n"; - fprintf fmt " rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_1_r.\n"; - fprintf fmt " assert (tmp: forall x y z, x * (y * z) = y * (x * z));\n"; - fprintf fmt " [intros; ring | rewrite tmp; clear tmp].\n"; - fprintf fmt " apply Zmult_le_compat_l; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition of_N x :=\n"; - fprintf fmt " match x with\n"; - fprintf fmt " | BinNat.N0 => zero\n"; - fprintf fmt " | Npos p => of_pos p\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_of_N: forall x,\n"; - fprintf fmt " [of_N x] = Z_of_N x.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x.\n"; - fprintf fmt " simpl of_N.\n"; - fprintf fmt " unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.\n"; - fprintf fmt " intros p; exact (spec_of_pos p).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " (***************************************************************)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (* Shift *)\n"; - fprintf fmt " (* *)\n"; - fprintf fmt " (***************************************************************)\n\n"; - - - - (* Head0 *) - fprintf fmt " Definition head0 w := match w with\n"; - for i = 0 to size do - fprintf fmt " | %s%i w=> reduce_%i (w%i_op.(znz_head0) w)\n" c i i i; - done; - fprintf fmt " | %sn n w=> reduce_n n ((make_op n).(znz_head0) w)\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_head00: forall x, [x] = 0 ->[head0 x] = Zpos (digits x).\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold head0; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; rewrite spec_reduce_%i; exact (spec_head00 w%i_spec x).\n" i i; - done; - fprintf fmt " intros n x; rewrite spec_reduce_n; exact (spec_head00 (wn_spec n) x).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt " \n"; - - fprintf fmt " Theorem spec_head0: forall x, 0 < [x] ->\n"; - fprintf fmt " 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x).\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F0: forall x, (x - 1) + 1 = x).\n"; - fprintf fmt " intros; ring. \n"; - fprintf fmt " intros x; case x; unfold digits, head0; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x Hx; rewrite spec_reduce_%i.\n" i; - fprintf fmt " assert (F1:= spec_more_than_1_digit w%i_spec).\n" i; - fprintf fmt " generalize (spec_head0 w%i_spec x Hx).\n" i; - fprintf fmt " unfold base.\n"; - fprintf fmt " pattern (Zpos (znz_digits w%i_op)) at 1; \n" i; - fprintf fmt " rewrite <- (fun x => (F0 (Zpos x))).\n"; - fprintf fmt " rewrite Zpower_exp; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith.\n"; - done; - fprintf fmt " intros n x Hx; rewrite spec_reduce_n.\n"; - fprintf fmt " assert (F1:= spec_more_than_1_digit (wn_spec n)).\n"; - fprintf fmt " generalize (spec_head0 (wn_spec n) x Hx).\n"; - fprintf fmt " unfold base.\n"; - fprintf fmt " pattern (Zpos (znz_digits (make_op n))) at 1; \n"; - fprintf fmt " rewrite <- (fun x => (F0 (Zpos x))).\n"; - fprintf fmt " rewrite Zpower_exp; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_1_r; rewrite Z_div_mult; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - (* Tail0 *) - fprintf fmt " Definition tail0 w := match w with\n"; - for i = 0 to size do - fprintf fmt " | %s%i w=> reduce_%i (w%i_op.(znz_tail0) w)\n" c i i i; - done; - fprintf fmt " | %sn n w=> reduce_n n ((make_op n).(znz_tail0) w)\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_tail00: forall x, [x] = 0 ->[tail0 x] = Zpos (digits x).\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold tail0; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; rewrite spec_reduce_%i; exact (spec_tail00 w%i_spec x).\n" i i; - done; - fprintf fmt " intros n x; rewrite spec_reduce_n; exact (spec_tail00 (wn_spec n) x).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt " \n"; - - - fprintf fmt " Theorem spec_tail0: forall x,\n"; - fprintf fmt " 0 < [x] -> exists y, 0 <= y /\\ [x] = (2 * y + 1) * 2 ^ [tail0 x].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x; unfold tail0.\n"; - for i = 0 to size do - fprintf fmt " intros x Hx; rewrite spec_reduce_%i; exact (spec_tail0 w%i_spec x Hx).\n" i i; - done; - fprintf fmt " intros n x Hx; rewrite spec_reduce_n; exact (spec_tail0 (wn_spec n) x Hx).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - (* Number of digits *) - fprintf fmt " Definition %sdigits x :=\n" c; - fprintf fmt " match x with\n"; - fprintf fmt " | %s0 _ => %s0 w0_op.(znz_zdigits)\n" c c; - for i = 1 to size do - fprintf fmt " | %s%i _ => reduce_%i w%i_op.(znz_zdigits)\n" c i i i; - done; - fprintf fmt " | %sn n _ => reduce_n n (make_op n).(znz_zdigits)\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x).\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; clear x; unfold Ndigits, digits.\n"; - for i = 0 to size do - fprintf fmt " intros _; try rewrite spec_reduce_%i; exact (spec_zdigits w%i_spec).\n" i i; - done; - fprintf fmt " intros n _; try rewrite spec_reduce_n; exact (spec_zdigits (wn_spec n)).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - (* Shiftr *) - for i = 0 to size do - fprintf fmt " Definition shiftr%i n x := w%i_op.(znz_add_mul_div) (w%i_op.(znz_sub) w%i_op.(znz_zdigits) n) w%i_op.(znz_0) x.\n" i i i i i; - done; - fprintf fmt " Definition shiftrn n p x := (make_op n).(znz_add_mul_div) ((make_op n).(znz_sub) (make_op n).(znz_zdigits) p) (make_op n).(znz_0) x.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition shiftr := Eval lazy beta delta [same_level] in \n"; - fprintf fmt " same_level _ (fun n x => %s0 (shiftr0 n x))\n" c; - for i = 1 to size do - fprintf fmt " (fun n x => reduce_%i (shiftr%i n x))\n" i i; - done; - fprintf fmt " (fun n p x => reduce_n n (shiftrn n p x)).\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_shiftr: forall n x,\n"; - fprintf fmt " [n] <= [Ndigits x] -> [shiftr n x] = [x] / 2 ^ [n].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F0: forall x y, x - (x - y) = y).\n"; - fprintf fmt " intros; ring.\n"; - fprintf fmt " assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z).\n"; - fprintf fmt " intros x y z HH HH1 HH2.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " apply Zle_lt_trans with (2 := HH2); auto with zarith.\n"; - fprintf fmt " apply Zdiv_le_upper_bound; auto with zarith.\n"; - fprintf fmt " pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith.\n"; - fprintf fmt " apply Zmult_le_compat_l; auto.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_0_r; ring.\n"; - fprintf fmt " assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x).\n"; - fprintf fmt " intros xx y HH HH1.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " apply Zle_lt_trans with xx; auto with zarith.\n"; - fprintf fmt " apply Zpower2_lt_lin; auto with zarith.\n"; - fprintf fmt " assert (F4: forall ww ww1 ww2 \n"; - fprintf fmt " (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)\n"; - fprintf fmt " xx yy xx1 yy1,\n"; - fprintf fmt " znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_zdigits ww1_op) ->\n"; - fprintf fmt " znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) ->\n"; - fprintf fmt " znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op ->\n"; - fprintf fmt " znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx ->\n"; - fprintf fmt " znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy ->\n"; - fprintf fmt " znz_to_Z ww_op\n"; - fprintf fmt " (znz_add_mul_div ww_op (znz_sub ww_op (znz_zdigits ww_op) yy1)\n"; - fprintf fmt " (znz_0 ww_op) xx1) = znz_to_Z ww1_op xx / 2 ^ znz_to_Z ww2_op yy).\n"; - fprintf fmt " intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy.\n"; - fprintf fmt " case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2.\n"; - fprintf fmt " case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4.\n"; - fprintf fmt " rewrite <- Hx.\n"; - fprintf fmt " rewrite <- Hy.\n"; - fprintf fmt " generalize (spec_add_mul_div Hw\n"; - fprintf fmt " (znz_0 ww_op) xx1\n"; - fprintf fmt " (znz_sub ww_op (znz_zdigits ww_op) \n"; - fprintf fmt " yy1)\n"; - fprintf fmt " ).\n"; - fprintf fmt " rewrite (spec_0 Hw).\n"; - fprintf fmt " rewrite Zmult_0_l; rewrite Zplus_0_l.\n"; - fprintf fmt " rewrite (ZnZ.spec_sub Hw).\n"; - fprintf fmt " rewrite Zmod_small; auto with zarith.\n"; - fprintf fmt " rewrite (spec_zdigits Hw).\n"; - fprintf fmt " rewrite F0.\n"; - fprintf fmt " rewrite Zmod_small; auto with zarith.\n"; - fprintf fmt " unfold base; rewrite (spec_zdigits Hw) in Hl1 |- *;\n"; - fprintf fmt " auto with zarith.\n"; - fprintf fmt " assert (F5: forall n m, (n <= m)%snat ->\n" "%"; - fprintf fmt " Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m))).\n"; - fprintf fmt " intros n m HH; elim HH; clear m HH; auto with zarith.\n"; - fprintf fmt " intros m HH Hrec; apply Zle_trans with (1 := Hrec).\n"; - fprintf fmt " rewrite make_op_S.\n"; - fprintf fmt " match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end.\n"; - fprintf fmt " rewrite Zpos_xO.\n"; - fprintf fmt " assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith.\n"; - fprintf fmt " assert (F6: forall n, Zpos (znz_digits w%i_op) <= Zpos (znz_digits (make_op n))).\n" size; - fprintf fmt " intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0))).\n"; - fprintf fmt " change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op)).\n" size; - fprintf fmt " rewrite Zpos_xO.\n"; - fprintf fmt " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith.\n" size; - fprintf fmt " apply F5; auto with arith.\n"; - fprintf fmt " intros x; case x; clear x; unfold shiftr, same_level.\n"; - for i = 0 to size do - fprintf fmt " intros x y; case y; clear y.\n"; - for j = 0 to i - 1 do - fprintf fmt " intros y; unfold shiftr%i, Ndigits.\n" i; - fprintf fmt " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i j; - fprintf fmt " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith.\n" i j i; - fprintf fmt " rewrite (spec_zdigits w%i_spec).\n" i; - fprintf fmt " rewrite (spec_zdigits w%i_spec).\n" j; - fprintf fmt " change (znz_digits w%i_op) with %s.\n" i (genxO (i - j) (" (znz_digits w"^(string_of_int j)^"_op)")); - fprintf fmt " repeat rewrite (fun x => Zpos_xO (xO x)).\n"; - fprintf fmt " repeat rewrite (fun x y => Zpos_xO (%sznz_digits x y)).\n" "@"; - fprintf fmt " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith.\n" j; - fprintf fmt " try (apply sym_equal; exact (spec_extend%in%i y)).\n" j i; - - done; - fprintf fmt " intros y; unfold shiftr%i, Ndigits.\n" i; - fprintf fmt " repeat rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i; - fprintf fmt " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith.\n" i i i; - for j = i + 1 to size do - fprintf fmt " intros y; unfold shiftr%i, Ndigits.\n" j; - fprintf fmt " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i j; - fprintf fmt " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith.\n" j j i; - fprintf fmt " try (apply sym_equal; exact (spec_extend%in%i x)).\n" i j; - done; - if i == size then - begin - fprintf fmt " intros m y; unfold shiftrn, Ndigits.\n"; - fprintf fmt " repeat rewrite spec_reduce_n; unfold to_Z; intros H1.\n"; - fprintf fmt " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith.\n" size; - fprintf fmt " try (apply sym_equal; exact (spec_extend%in m x)).\n" size; - - end - else - begin - fprintf fmt " intros m y; unfold shiftrn, Ndigits.\n"; - fprintf fmt " repeat rewrite spec_reduce_n; unfold to_Z; intros H1.\n"; - fprintf fmt " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith.\n" i; - fprintf fmt " change ([Nn m (extend%i m (extend%i %i x))] = [N%i x]).\n" size i (size - i - 1) i; - fprintf fmt " rewrite <- (spec_extend%in m); rewrite <- spec_extend%in%i; auto.\n" size i size; - end - done; - fprintf fmt " intros n x y; case y; clear y;\n"; - fprintf fmt " intros y; unfold shiftrn, Ndigits; try rewrite spec_reduce_n.\n"; - for i = 0 to size do - fprintf fmt " try rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i; - fprintf fmt " apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith.\n" i; - fprintf fmt " rewrite (spec_zdigits w%i_spec).\n" i; - fprintf fmt " rewrite (spec_zdigits (wn_spec n)).\n"; - fprintf fmt " apply Zle_trans with (2 := F6 n).\n"; - fprintf fmt " change (znz_digits w%i_op) with %s.\n" size (genxO (size - i) ("(znz_digits w" ^ (string_of_int i) ^ "_op)")); - fprintf fmt " repeat rewrite (fun x => Zpos_xO (xO x)).\n"; - fprintf fmt " repeat rewrite (fun x y => Zpos_xO (%sznz_digits x y)).\n" "@"; - fprintf fmt " assert (H: 0 <= Zpos (znz_digits w%i_op)); auto with zarith.\n" i; - if i == size then - fprintf fmt " change ([Nn n (extend%i n y)] = [N%i y]).\n" size i - else - fprintf fmt " change ([Nn n (extend%i n (extend%i %i y))] = [N%i y]).\n" size i (size - i - 1) i; - fprintf fmt " rewrite <- (spec_extend%in n); auto.\n" size; - if i <> size then - fprintf fmt " try (rewrite <- spec_extend%in%i; auto).\n" i size; - done; - fprintf fmt " generalize y; clear y; intros m y.\n"; - fprintf fmt " rewrite spec_reduce_n; unfold to_Z; intros H1.\n"; - fprintf fmt " apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith.\n"; - fprintf fmt " rewrite (spec_zdigits (wn_spec m)).\n"; - fprintf fmt " rewrite (spec_zdigits (wn_spec (Max.max n m))).\n"; - fprintf fmt " apply F5; auto with arith.\n"; - fprintf fmt " exact (spec_cast_r n m y).\n"; - fprintf fmt " exact (spec_cast_l n m x).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Definition safe_shiftr n x := \n"; - fprintf fmt " match compare n (Ndigits x) with\n "; - fprintf fmt " | Lt => shiftr n x \n"; - fprintf fmt " | _ => %s0 w_0\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_safe_shiftr: forall n x,\n"; - fprintf fmt " [safe_shiftr n x] = [x] / 2 ^ [n].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x; unfold safe_shiftr;\n"; - fprintf fmt " generalize (spec_compare n (Ndigits x)); case compare; intros H.\n"; - fprintf fmt " apply trans_equal with (1 := spec_0 w0_spec).\n"; - fprintf fmt " apply sym_equal; apply Zdiv_small; rewrite H.\n"; - fprintf fmt " rewrite spec_Ndigits; exact (spec_digits x).\n"; - fprintf fmt " rewrite <- spec_shiftr; auto with zarith.\n"; - fprintf fmt " apply trans_equal with (1 := spec_0 w0_spec).\n"; - fprintf fmt " apply sym_equal; apply Zdiv_small.\n"; - fprintf fmt " rewrite spec_Ndigits in H; case (spec_digits x); intros H1 H2.\n"; - fprintf fmt " split; auto.\n"; - fprintf fmt " apply Zlt_le_trans with (1 := H2).\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt "\n"; - - (* Shiftl *) - for i = 0 to size do - fprintf fmt " Definition shiftl%i n x := w%i_op.(znz_add_mul_div) n x w%i_op.(znz_0).\n" i i i - done; - fprintf fmt " Definition shiftln n p x := (make_op n).(znz_add_mul_div) p x (make_op n).(znz_0).\n"; - fprintf fmt " Definition shiftl := Eval lazy beta delta [same_level] in\n"; - fprintf fmt " same_level _ (fun n x => %s0 (shiftl0 n x))\n" c; - for i = 1 to size do - fprintf fmt " (fun n x => reduce_%i (shiftl%i n x))\n" i i; - done; - fprintf fmt " (fun n p x => reduce_n n (shiftln n p x)).\n"; - fprintf fmt "\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_shiftl: forall n x,\n"; - fprintf fmt " [n] <= [head0 x] -> [shiftl n x] = [x] * 2 ^ [n].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " assert (F0: forall x y, x - (x - y) = y).\n"; - fprintf fmt " intros; ring.\n"; - fprintf fmt " assert (F2: forall x y z, 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z).\n"; - fprintf fmt " intros x y z HH HH1 HH2.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " apply Zle_lt_trans with (2 := HH2); auto with zarith.\n"; - fprintf fmt " apply Zdiv_le_upper_bound; auto with zarith.\n"; - fprintf fmt " pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith.\n"; - fprintf fmt " apply Zmult_le_compat_l; auto.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_0_r; ring.\n"; - fprintf fmt " assert (F3: forall x y, 0 <= y -> y <= x -> 0 <= x - y < 2 ^ x).\n"; - fprintf fmt " intros xx y HH HH1.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " apply Zle_lt_trans with xx; auto with zarith.\n"; - fprintf fmt " apply Zpower2_lt_lin; auto with zarith.\n"; - fprintf fmt " assert (F4: forall ww ww1 ww2 \n"; - fprintf fmt " (ww_op: znz_op ww) (ww1_op: znz_op ww1) (ww2_op: znz_op ww2)\n"; - fprintf fmt " xx yy xx1 yy1,\n"; - fprintf fmt " znz_to_Z ww2_op yy <= znz_to_Z ww1_op (znz_head0 ww1_op xx) ->\n"; - fprintf fmt " znz_to_Z ww1_op (znz_zdigits ww1_op) <= znz_to_Z ww_op (znz_zdigits ww_op) ->\n"; - fprintf fmt " znz_spec ww_op -> znz_spec ww1_op -> znz_spec ww2_op ->\n"; - fprintf fmt " znz_to_Z ww_op xx1 = znz_to_Z ww1_op xx ->\n"; - fprintf fmt " znz_to_Z ww_op yy1 = znz_to_Z ww2_op yy ->\n"; - fprintf fmt " znz_to_Z ww_op\n"; - fprintf fmt " (znz_add_mul_div ww_op yy1\n"; - fprintf fmt " xx1 (znz_0 ww_op)) = znz_to_Z ww1_op xx * 2 ^ znz_to_Z ww2_op yy).\n"; - fprintf fmt " intros ww ww1 ww2 ww_op ww1_op ww2_op xx yy xx1 yy1 Hl Hl1 Hw Hw1 Hw2 Hx Hy.\n"; - fprintf fmt " case (spec_to_Z Hw xx1); auto with zarith; intros HH1 HH2.\n"; - fprintf fmt " case (spec_to_Z Hw yy1); auto with zarith; intros HH3 HH4.\n"; - fprintf fmt " rewrite <- Hx.\n"; - fprintf fmt " rewrite <- Hy.\n"; - fprintf fmt " generalize (spec_add_mul_div Hw xx1 (znz_0 ww_op) yy1).\n"; - fprintf fmt " rewrite (spec_0 Hw).\n"; - fprintf fmt " assert (F1: znz_to_Z ww1_op (znz_head0 ww1_op xx) <= Zpos (znz_digits ww1_op)).\n"; - fprintf fmt " case (Zle_lt_or_eq _ _ HH1); intros HH5.\n"; - fprintf fmt " apply Zlt_le_weak.\n"; - fprintf fmt " case (ZnZ.spec_head0 Hw1 xx).\n"; - fprintf fmt " rewrite <- Hx; auto.\n"; - fprintf fmt " intros _ Hu; unfold base in Hu.\n"; - fprintf fmt " case (Zle_or_lt (Zpos (znz_digits ww1_op))\n"; - fprintf fmt " (znz_to_Z ww1_op (znz_head0 ww1_op xx))); auto; intros H1.\n"; - fprintf fmt " absurd (2 ^ (Zpos (znz_digits ww1_op)) <= 2 ^ (znz_to_Z ww1_op (znz_head0 ww1_op xx))).\n"; - fprintf fmt " apply Zlt_not_le.\n"; - fprintf fmt " case (spec_to_Z Hw1 xx); intros HHx3 HHx4.\n"; - fprintf fmt " rewrite <- (Zmult_1_r (2 ^ znz_to_Z ww1_op (znz_head0 ww1_op xx))).\n"; - fprintf fmt " apply Zle_lt_trans with (2 := Hu).\n"; - fprintf fmt " apply Zmult_le_compat_l; auto with zarith.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " rewrite (ZnZ.spec_head00 Hw1 xx); auto with zarith.\n"; - fprintf fmt " rewrite Zdiv_0_l; auto with zarith.\n"; - fprintf fmt " rewrite Zplus_0_r.\n"; - fprintf fmt " case (Zle_lt_or_eq _ _ HH1); intros HH5.\n"; - fprintf fmt " rewrite Zmod_small; auto with zarith.\n"; - fprintf fmt " intros HH; apply HH.\n"; - fprintf fmt " rewrite Hy; apply Zle_trans with (1:= Hl).\n"; - fprintf fmt " rewrite <- (spec_zdigits Hw). \n"; - fprintf fmt " apply Zle_trans with (2 := Hl1); auto.\n"; - fprintf fmt " rewrite (spec_zdigits Hw1); auto with zarith.\n"; - fprintf fmt " split; auto with zarith .\n"; - fprintf fmt " apply Zlt_le_trans with (base (znz_digits ww1_op)).\n"; - fprintf fmt " rewrite Hx.\n"; - fprintf fmt " case (ZnZ.spec_head0 Hw1 xx); auto.\n"; - fprintf fmt " rewrite <- Hx; auto.\n"; - fprintf fmt " intros _ Hu; rewrite Zmult_comm in Hu.\n"; - fprintf fmt " apply Zle_lt_trans with (2 := Hu).\n"; - fprintf fmt " apply Zmult_le_compat_l; auto with zarith.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " unfold base; apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " rewrite <- (spec_zdigits Hw); auto with zarith.\n"; - fprintf fmt " rewrite <- (spec_zdigits Hw1); auto with zarith.\n"; - fprintf fmt " rewrite <- HH5.\n"; - fprintf fmt " rewrite Zmult_0_l.\n"; - fprintf fmt " rewrite Zmod_small; auto with zarith.\n"; - fprintf fmt " intros HH; apply HH.\n"; - fprintf fmt " rewrite Hy; apply Zle_trans with (1 := Hl).\n"; - fprintf fmt " rewrite (ZnZ.spec_head00 Hw1 xx); auto with zarith.\n"; - fprintf fmt " rewrite <- (spec_zdigits Hw); auto with zarith.\n"; - fprintf fmt " rewrite <- (spec_zdigits Hw1); auto with zarith.\n"; - fprintf fmt " assert (F5: forall n m, (n <= m)%snat ->\n" "%"; - fprintf fmt " Zpos (znz_digits (make_op n)) <= Zpos (znz_digits (make_op m))).\n"; - fprintf fmt " intros n m HH; elim HH; clear m HH; auto with zarith.\n"; - fprintf fmt " intros m HH Hrec; apply Zle_trans with (1 := Hrec).\n"; - fprintf fmt " rewrite make_op_S.\n"; - fprintf fmt " match goal with |- Zpos ?Y <= ?X => change X with (Zpos (xO Y)) end.\n"; - fprintf fmt " rewrite Zpos_xO.\n"; - fprintf fmt " assert (0 <= Zpos (znz_digits (make_op n))); auto with zarith.\n"; - fprintf fmt " assert (F6: forall n, Zpos (znz_digits w%i_op) <= Zpos (znz_digits (make_op n))).\n" size; - fprintf fmt " intros n ; apply Zle_trans with (Zpos (znz_digits (make_op 0))).\n"; - fprintf fmt " change (znz_digits (make_op 0)) with (xO (znz_digits w%i_op)).\n" size; - fprintf fmt " rewrite Zpos_xO.\n"; - fprintf fmt " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith.\n" size; - fprintf fmt " apply F5; auto with arith.\n"; - fprintf fmt " intros x; case x; clear x; unfold shiftl, same_level.\n"; - for i = 0 to size do - fprintf fmt " intros x y; case y; clear y.\n"; - for j = 0 to i - 1 do - fprintf fmt " intros y; unfold shiftl%i, head0.\n" i; - fprintf fmt " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i j; - fprintf fmt " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith.\n" i j i; - fprintf fmt " rewrite (spec_zdigits w%i_spec).\n" i; - fprintf fmt " rewrite (spec_zdigits w%i_spec).\n" j; - fprintf fmt " change (znz_digits w%i_op) with %s.\n" i (genxO (i - j) (" (znz_digits w"^(string_of_int j)^"_op)")); - fprintf fmt " repeat rewrite (fun x => Zpos_xO (xO x)).\n"; - fprintf fmt " repeat rewrite (fun x y => Zpos_xO (%sznz_digits x y)).\n" "@"; - fprintf fmt " assert (0 <= Zpos (znz_digits w%i_op)); auto with zarith.\n" j; - fprintf fmt " try (apply sym_equal; exact (spec_extend%in%i y)).\n" j i; - - done; - fprintf fmt " intros y; unfold shiftl%i, head0.\n" i; - fprintf fmt " repeat rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i; - fprintf fmt " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith.\n" i i i; - for j = i + 1 to size do - fprintf fmt " intros y; unfold shiftl%i, head0.\n" j; - fprintf fmt " repeat rewrite spec_reduce_%i; repeat rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i j; - fprintf fmt " apply F4 with (3:=w%i_spec)(4:=w%i_spec)(5:=w%i_spec); auto with zarith.\n" j j i; - fprintf fmt " try (apply sym_equal; exact (spec_extend%in%i x)).\n" i j; - done; - if i == size then - begin - fprintf fmt " intros m y; unfold shiftln, head0.\n"; - fprintf fmt " repeat rewrite spec_reduce_n; unfold to_Z; intros H1.\n"; - fprintf fmt " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith.\n" size; - fprintf fmt " try (apply sym_equal; exact (spec_extend%in m x)).\n" size; - - end - else - begin - fprintf fmt " intros m y; unfold shiftln, head0.\n"; - fprintf fmt " repeat rewrite spec_reduce_n; unfold to_Z; intros H1.\n"; - fprintf fmt " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith.\n" i; - fprintf fmt " change ([Nn m (extend%i m (extend%i %i x))] = [N%i x]).\n" size i (size - i - 1) i; - fprintf fmt " rewrite <- (spec_extend%in m); rewrite <- spec_extend%in%i; auto.\n" size i size; - end - done; - fprintf fmt " intros n x y; case y; clear y;\n"; - fprintf fmt " intros y; unfold shiftln, head0; try rewrite spec_reduce_n.\n"; - for i = 0 to size do - fprintf fmt " try rewrite spec_reduce_%i; unfold to_Z; intros H1.\n" i; - fprintf fmt " apply F4 with (3:=(wn_spec n))(4:=w%i_spec)(5:=wn_spec n); auto with zarith.\n" i; - fprintf fmt " rewrite (spec_zdigits w%i_spec).\n" i; - fprintf fmt " rewrite (spec_zdigits (wn_spec n)).\n"; - fprintf fmt " apply Zle_trans with (2 := F6 n).\n"; - fprintf fmt " change (znz_digits w%i_op) with %s.\n" size (genxO (size - i) ("(znz_digits w" ^ (string_of_int i) ^ "_op)")); - fprintf fmt " repeat rewrite (fun x => Zpos_xO (xO x)).\n"; - fprintf fmt " repeat rewrite (fun x y => Zpos_xO (%sznz_digits x y)).\n" "@"; - fprintf fmt " assert (H: 0 <= Zpos (znz_digits w%i_op)); auto with zarith.\n" i; - if i == size then - fprintf fmt " change ([Nn n (extend%i n y)] = [N%i y]).\n" size i - else - fprintf fmt " change ([Nn n (extend%i n (extend%i %i y))] = [N%i y]).\n" size i (size - i - 1) i; - fprintf fmt " rewrite <- (spec_extend%in n); auto.\n" size; - if i <> size then - fprintf fmt " try (rewrite <- spec_extend%in%i; auto).\n" i size; - done; - fprintf fmt " generalize y; clear y; intros m y.\n"; - fprintf fmt " repeat rewrite spec_reduce_n; unfold to_Z; intros H1.\n"; - fprintf fmt " apply F4 with (3:=(wn_spec (Max.max n m)))(4:=wn_spec m)(5:=wn_spec n); auto with zarith.\n"; - fprintf fmt " rewrite (spec_zdigits (wn_spec m)).\n"; - fprintf fmt " rewrite (spec_zdigits (wn_spec (Max.max n m))).\n"; - fprintf fmt " apply F5; auto with arith.\n"; - fprintf fmt " exact (spec_cast_r n m y).\n"; - fprintf fmt " exact (spec_cast_l n m x).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - (* Double size *) - fprintf fmt " Definition double_size w := match w with\n"; - for i = 0 to size-1 do - fprintf fmt " | %s%i x => %s%i (WW (znz_0 w%i_op) x)\n" c i c (i + 1) i; - done; - fprintf fmt " | %s%i x => %sn 0 (WW (znz_0 w%i_op) x)\n" c size c size; - fprintf fmt " | %sn n x => %sn (S n) (WW (znz_0 (make_op n)) x)\n" c c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_double_size_digits: \n"; - fprintf fmt " forall x, digits (double_size x) = xO (digits x).\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold double_size, digits; clear x; auto.\n"; - fprintf fmt " intros n x; rewrite make_op_S; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_double_size: forall x, [double_size x] = [x].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold double_size; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; unfold to_Z, make_op; \n"; - fprintf fmt " rewrite znz_to_Z_%i; rewrite (spec_0 w%i_spec); auto with zarith.\n" (i + 1) i; - done; - fprintf fmt " intros n x; unfold to_Z;\n"; - fprintf fmt " generalize (znz_to_Z_n n); simpl word.\n"; - fprintf fmt " intros HH; rewrite HH; clear HH.\n"; - fprintf fmt " generalize (spec_0 (wn_spec n)); simpl word.\n"; - fprintf fmt " intros HH; rewrite HH; clear HH; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_double_size_head0: \n"; - fprintf fmt " forall x, 2 * [head0 x] <= [head0 (double_size x)].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x.\n"; - fprintf fmt " assert (F1:= spec_pos (head0 x)).\n"; - fprintf fmt " assert (F2: 0 < Zpos (digits x)).\n"; - fprintf fmt " red; auto.\n"; - fprintf fmt " case (Zle_lt_or_eq _ _ (spec_pos x)); intros HH.\n"; - fprintf fmt " generalize HH; rewrite <- (spec_double_size x); intros HH1.\n"; - fprintf fmt " case (spec_head0 x HH); intros _ HH2.\n"; - fprintf fmt " case (spec_head0 _ HH1).\n"; - fprintf fmt " rewrite (spec_double_size x); rewrite (spec_double_size_digits x).\n"; - fprintf fmt " intros HH3 _.\n"; - fprintf fmt " case (Zle_or_lt ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4.\n"; - fprintf fmt " absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto.\n"; - fprintf fmt " apply Zle_not_lt.\n"; - fprintf fmt " apply Zmult_le_compat_r; auto with zarith.\n"; - fprintf fmt " apply Zpower_le_monotone; auto; auto with zarith.\n"; - fprintf fmt " generalize (spec_pos (head0 (double_size x))); auto with zarith.\n"; - fprintf fmt " assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)).\n"; - fprintf fmt " case (Zle_lt_or_eq 1 [x]); auto with zarith; intros HH5.\n"; - fprintf fmt " apply Zmult_le_reg_r with (2 ^ 1); auto with zarith.\n"; - fprintf fmt " rewrite <- (fun x y z => Zpower_exp x (y - z)); auto with zarith.\n"; - fprintf fmt " assert (tmp: forall x, x - 1 + 1 = x); [intros; ring | rewrite tmp; clear tmp].\n"; - fprintf fmt " apply Zle_trans with (2 := Zlt_le_weak _ _ HH2).\n"; - fprintf fmt " apply Zmult_le_compat_l; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_1_r; auto with zarith.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " split; auto with zarith. \n"; - fprintf fmt " case (Zle_or_lt (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6.\n"; - fprintf fmt " absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith.\n"; - fprintf fmt " rewrite <- HH5; rewrite Zmult_1_r.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " rewrite (Zmult_comm 2).\n"; - fprintf fmt " rewrite Zpower_mult; auto with zarith.\n"; - fprintf fmt " rewrite Zpower_2.\n"; - fprintf fmt " apply Zlt_le_trans with (2 := HH3).\n"; - fprintf fmt " rewrite <- Zmult_assoc.\n"; - fprintf fmt " replace (Zpos (xO (digits x)) - 1) with\n"; - fprintf fmt " ((Zpos (digits x) - 1) + (Zpos (digits x))).\n"; - fprintf fmt " rewrite Zpower_exp; auto with zarith.\n"; - fprintf fmt " apply Zmult_lt_compat2; auto with zarith.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " apply Zmult_lt_0_compat; auto with zarith.\n"; - fprintf fmt " rewrite Zpos_xO; ring.\n"; - fprintf fmt " apply Zlt_le_weak; auto.\n"; - fprintf fmt " repeat rewrite spec_head00; auto.\n"; - fprintf fmt " rewrite spec_double_size_digits.\n"; - fprintf fmt " rewrite Zpos_xO; auto with zarith.\n"; - fprintf fmt " rewrite spec_double_size; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_double_size_head0_pos: \n"; - fprintf fmt " forall x, 0 < [head0 (double_size x)].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x.\n"; - fprintf fmt " assert (F: 0 < Zpos (digits x)).\n"; - fprintf fmt " red; auto.\n"; - fprintf fmt " case (Zle_lt_or_eq _ _ (spec_pos (head0 (double_size x)))); auto; intros F0.\n"; - fprintf fmt " case (Zle_lt_or_eq _ _ (spec_pos (head0 x))); intros F1.\n"; - fprintf fmt " apply Zlt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith.\n"; - fprintf fmt " case (Zle_lt_or_eq _ _ (spec_pos x)); intros F3.\n"; - fprintf fmt " generalize F3; rewrite <- (spec_double_size x); intros F4.\n"; - fprintf fmt " absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))).\n"; - fprintf fmt " apply Zle_not_lt.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " split; auto with zarith.\n"; - fprintf fmt " rewrite Zpos_xO; auto with zarith.\n"; - fprintf fmt " case (spec_head0 x F3).\n"; - fprintf fmt " rewrite <- F1; rewrite Zpower_0_r; rewrite Zmult_1_l; intros _ HH.\n"; - fprintf fmt " apply Zle_lt_trans with (2 := HH).\n"; - fprintf fmt " case (spec_head0 _ F4).\n"; - fprintf fmt " rewrite (spec_double_size x); rewrite (spec_double_size_digits x).\n"; - fprintf fmt " rewrite <- F0; rewrite Zpower_0_r; rewrite Zmult_1_l; auto.\n"; - fprintf fmt " generalize F1; rewrite (spec_head00 _ (sym_equal F3)); auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - (* Safe shiftl *) - - fprintf fmt " Definition safe_shiftl_aux_body cont n x :=\n"; - fprintf fmt " match compare n (head0 x) with\n"; - fprintf fmt " Gt => cont n (double_size x)\n"; - fprintf fmt " | _ => shiftl n x\n"; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_safe_shift_aux_body: forall n p x cont,\n"; - fprintf fmt " 2^ Zpos p <= [head0 x] ->\n"; - fprintf fmt " (forall x, 2 ^ (Zpos p + 1) <= [head0 x]->\n"; - fprintf fmt " [cont n x] = [x] * 2 ^ [n]) ->\n"; - fprintf fmt " [safe_shiftl_aux_body cont n x] = [x] * 2 ^ [n].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros n p x cont H1 H2; unfold safe_shiftl_aux_body.\n"; - fprintf fmt " generalize (spec_compare n (head0 x)); case compare; intros H.\n"; - fprintf fmt " apply spec_shiftl; auto with zarith.\n"; - fprintf fmt " apply spec_shiftl; auto with zarith.\n"; - fprintf fmt " rewrite H2.\n"; - fprintf fmt " rewrite spec_double_size; auto.\n"; - fprintf fmt " rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith.\n"; - fprintf fmt " apply Zle_trans with (2 := spec_double_size_head0 x).\n"; - fprintf fmt " rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Fixpoint safe_shiftl_aux p cont n x {struct p} :=\n"; - fprintf fmt " safe_shiftl_aux_body \n"; - fprintf fmt " (fun n x => match p with\n"; - fprintf fmt " | xH => cont n x\n"; - fprintf fmt " | xO p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x\n"; - fprintf fmt " | xI p => safe_shiftl_aux p (safe_shiftl_aux p cont) n x\n"; - fprintf fmt " end) n x.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_safe_shift_aux: forall p q n x cont,\n"; - fprintf fmt " 2 ^ (Zpos q) <= [head0 x] ->\n"; - fprintf fmt " (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] ->\n"; - fprintf fmt " [cont n x] = [x] * 2 ^ [n]) -> \n"; - fprintf fmt " [safe_shiftl_aux p cont n x] = [x] * 2 ^ [n].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros p; elim p; unfold safe_shiftl_aux; fold safe_shiftl_aux; clear p.\n"; - fprintf fmt " intros p Hrec q n x cont H1 H2.\n"; - fprintf fmt " apply spec_safe_shift_aux_body with (q); auto.\n"; - fprintf fmt " intros x1 H3; apply Hrec with (q + 1)%spositive; auto.\n" "%"; - fprintf fmt " intros x2 H4; apply Hrec with (p + q + 1)%spositive; auto.\n" "%"; - fprintf fmt " rewrite <- Pplus_assoc.\n"; - fprintf fmt " rewrite Zpos_plus_distr; auto.\n"; - fprintf fmt " intros x3 H5; apply H2.\n"; - fprintf fmt " rewrite Zpos_xI.\n"; - fprintf fmt " replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1));\n"; - fprintf fmt " auto.\n"; - fprintf fmt " repeat rewrite Zpos_plus_distr; ring.\n"; - fprintf fmt " intros p Hrec q n x cont H1 H2.\n"; - fprintf fmt " apply spec_safe_shift_aux_body with (q); auto.\n"; - fprintf fmt " intros x1 H3; apply Hrec with (q); auto.\n"; - fprintf fmt " apply Zle_trans with (2 := H3); auto with zarith.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " intros x2 H4; apply Hrec with (p + q)%spositive; auto.\n" "%"; - fprintf fmt " intros x3 H5; apply H2.\n"; - fprintf fmt " rewrite (Zpos_xO p).\n"; - fprintf fmt " replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q));\n"; - fprintf fmt " auto.\n"; - fprintf fmt " repeat rewrite Zpos_plus_distr; ring.\n"; - fprintf fmt " intros q n x cont H1 H2.\n"; - fprintf fmt " apply spec_safe_shift_aux_body with (q); auto.\n"; - fprintf fmt " rewrite Zplus_comm; auto.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Definition safe_shiftl n x :=\n"; - fprintf fmt " safe_shiftl_aux_body\n"; - fprintf fmt " (safe_shiftl_aux_body\n"; - fprintf fmt " (safe_shiftl_aux (digits n) shiftl)) n x.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_safe_shift: forall n x,\n"; - fprintf fmt " [safe_shiftl n x] = [x] * 2 ^ [n].\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros n x; unfold safe_shiftl, safe_shiftl_aux_body.\n"; - fprintf fmt " generalize (spec_compare n (head0 x)); case compare; intros H.\n"; - fprintf fmt " apply spec_shiftl; auto with zarith.\n"; - fprintf fmt " apply spec_shiftl; auto with zarith.\n"; - fprintf fmt " rewrite <- (spec_double_size x).\n"; - fprintf fmt " generalize (spec_compare n (head0 (double_size x))); case compare; intros H1.\n"; - fprintf fmt " apply spec_shiftl; auto with zarith.\n"; - fprintf fmt " apply spec_shiftl; auto with zarith.\n"; - fprintf fmt " rewrite <- (spec_double_size (double_size x)).\n"; - fprintf fmt " apply spec_safe_shift_aux with 1%spositive.\n" "%"; - fprintf fmt " apply Zle_trans with (2 := spec_double_size_head0 (double_size x)).\n"; - fprintf fmt " replace (2 ^ 1) with (2 * 1).\n"; - fprintf fmt " apply Zmult_le_compat_l; auto with zarith.\n"; - fprintf fmt " generalize (spec_double_size_head0_pos x); auto with zarith.\n"; - fprintf fmt " rewrite Zpower_1_r; ring.\n"; - fprintf fmt " intros x1 H2; apply spec_shiftl.\n"; - fprintf fmt " apply Zle_trans with (2 := H2).\n"; - fprintf fmt " apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith.\n"; - fprintf fmt " case (spec_digits n); auto with zarith.\n"; - fprintf fmt " apply Zpower_le_monotone; auto with zarith.\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - (* even *) - fprintf fmt " Definition is_even x :=\n"; - fprintf fmt " match x with\n"; - for i = 0 to size do - fprintf fmt " | %s%i wx => w%i_op.(znz_is_even) wx\n" c i i - done; - fprintf fmt " | %sn n wx => (make_op n).(znz_is_even) wx\n" c; - fprintf fmt " end.\n"; - fprintf fmt "\n"; - - - fprintf fmt " Theorem spec_is_even: forall x,\n"; - fprintf fmt " if is_even x then [x] mod 2 = 0 else [x] mod 2 = 1.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " intros x; case x; unfold is_even, to_Z; clear x.\n"; - for i = 0 to size do - fprintf fmt " intros x; exact (spec_is_even w%i_spec x).\n" i; - done; - fprintf fmt " intros n x; exact (spec_is_even (wn_spec n) x).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_0: [zero] = 0.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " exact (spec_0 w0_spec).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - fprintf fmt " Theorem spec_1: [one] = 1.\n"; - if gen_proof then - begin - fprintf fmt " Proof.\n"; - fprintf fmt " exact (spec_1 w0_spec).\n"; - fprintf fmt " Qed.\n"; - end - else - fprintf fmt " Admitted.\n"; - fprintf fmt "\n"; - - - fprintf fmt "End Make.\n"; - fprintf fmt "\n"; - pp_print_flush fmt () - - - - -let _ = print_Make () - - |