mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 12:10:26 +02:00
Code Activity

Rework the testing framework for number-theoretic division operators

Browse source 
* test-suite/tests/numbers.test (test-eqv?): Remove special handling of
  zeroes.  Zeroes are now compared like all other numbers.  Exact
  numbers are compared with `eqv?' and inexact numbers are compared to
  within test-epsilon.

  Rework the testing framework for number-theoretic division operators:
  `euclidean/', `euclidean-quotient', `euclidean-remainder',
  `centered/', `centered-quotient', and `centered-remainder'.
  Previously we compared all test results against a simple scheme
  implementation of the same operations.  However, these operations have
  discontinuous jumps where a tiny change in the inputs can lead to a
  large change in the outputs, e.g.:

    (euclidean/ 130.00000000000 10/7) ==> 91.0 and 0.0
    (euclidean/ 129.99999999999 10/7) ==> 90.0 and 1.42857142856141

  In the new testing scheme, we compare values against the simple
  implementations only if the input arguments contain an infinity or a
  NaN.  In the common case of two finite arguments, we simply make sure
  that the outputs of all three operators (e.g. `euclidean/',
  `euclidean-quotient', `euclidean-remainder') equal each other, that
  outputs are exact iff both inputs are exact, and that the required
  properties of the operator are met: that Q is an integer, that R is
  within the specified range, and that N = Q*D + R.
This commit is contained in:
Mark H Weaver 2011-01-31 00:42:35 -05:00 • committed by Andy Wingo
parent 6e0975603e
commit a8591a55f0
1 changed files with 88 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

188
test-suite/tests/numbers.test
View file

@ -18,6 +18,7 @@
(define-module (test-suite test-numbers) (define-module (test-suite test-numbers)
#:use-module (test-suite lib) #:use-module (test-suite lib)
#:use-module (ice-9 documentation) #:use-module (ice-9 documentation)
#:use-module (srfi srfi-1) ; list library
#:use-module (srfi srfi-11)) ; let-values #:use-module (srfi srfi-11)) ; let-values
;;; ;;;
@ -100,12 +101,9 @@
;; ;;
;; Like eqv?, except that inexact finite numbers need only be within ;; Like eqv?, except that inexact finite numbers need only be within
;; test-epsilon (1e-10) to be considered equal. An exception is made ;; test-epsilon (1e-10) to be considered equal. For non-real complex
;; for zeroes, however. If X is zero, then it is tested using eqv? ;; numbers, each component is tested according to these rules. The
;; without any allowance for imprecision. In particular, 0.0 is ;; intent is that the known-correct value will be the first parameter.
;; considered distinct from -0.0. For non-real complex numbers,
;; each component is tested according to these rules. The intent
;; is that the known-correct value will be the first parameter.
;; ;;
(define (test-eqv? x y) (define (test-eqv? x y)
(cond ((real? x) (cond ((real? x)
@ -118,7 +116,7 @@
;; Auxiliary predicate used by test-eqv? ;; Auxiliary predicate used by test-eqv?
(define (test-real-eqv? x y) (define (test-real-eqv? x y)
(cond ((or (exact? x) (zero? x) (nan? x) (inf? x)) (cond ((or (exact? x) (nan? x) (inf? x))
(eqv? x y)) (eqv? x y))
(else (and (inexact? y) (> test-epsilon (abs (- x y))))))) (else (and (inexact? y) (> test-epsilon (abs (- x y)))))))
@ -3551,6 +3549,24 @@
(hi (+ hi test-epsilon))) (hi (+ hi test-epsilon)))
(<= lo x hi)))) (<= lo x hi))))
;; (cartesian-product-map list '(a b) '(1 2))
;; ==> ((a 1) (a 2) (b 1) (b 2))
(define (cartesian-product-map f . lsts)
(define (cartmap rev-head lsts)
(if (null? lsts)
(list (apply f (reverse rev-head)))
(append-map (lambda (x) (cartmap (cons x rev-head) (cdr lsts)))
(car lsts))))
(cartmap '() lsts))
(define (cartesian-product-for-each f . lsts)
(define (cartfor rev-head lsts)
(if (null? lsts)
(apply f (reverse rev-head))
(for-each (lambda (x) (cartfor (cons x rev-head) (cdr lsts)))
(car lsts))))
(cartfor '() lsts))
(define (safe-euclidean-quotient x y) (define (safe-euclidean-quotient x y)
(cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg)) (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg))
((zero? y) (throw 'divide-by-zero)) ((zero? y) (throw 'divide-by-zero))
@ -3560,20 +3576,19 @@
(else (throw 'unknown-problem)))) (else (throw 'unknown-problem))))
(define (safe-euclidean-remainder x y) (define (safe-euclidean-remainder x y)
(- x (* y (safe-euclidean-quotient x y)))) (let ((q (safe-euclidean-quotient x y)))
(- x (* y q))))
(define (safe-euclidean/ x y) (define (valid-euclidean-answer? x y q r)
(let ((q (safe-euclidean-quotient x y)) (if (and (finite? x) (finite? y))
(r (safe-euclidean-remainder x y))) (and (eq? (exact? q)
(if (not (and (eq? (exact? q) (exact? r)) (exact? r)
(eq? (exact? q) (and (exact? x) (exact? y))) (and (exact? x) (exact? y)))
(test-real-eqv? r (- x (* q y))) (integer? q)
(or (and (integer? q) (test-eqv? r (- x (* q y)))
(test-within-range? 0 (abs y) r)) (test-within-range? 0 (abs y) r))
(not (finite? x)) (and (test-eqv? q (safe-euclidean-quotient x y))
(not (finite? y))))) (test-eqv? r (safe-euclidean-remainder x y)))))
(throw 'safe-euclidean/-is-broken (list x y q r))
(values q r))))
(define (safe-centered-quotient x y) (define (safe-centered-quotient x y)
(cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg)) (cond ((not (and (real? x) (real? y))) (throw 'wrong-type-arg))
@ -3584,37 +3599,36 @@
(else (throw 'unknown-problem)))) (else (throw 'unknown-problem))))
(define (safe-centered-remainder x y) (define (safe-centered-remainder x y)
(- x (* y (safe-centered-quotient x y)))) (let ((q (safe-centered-quotient x y)))
(- x (* y q))))
(define (safe-centered/ x y) (define (valid-centered-answer? x y q r)
(let ((q (safe-centered-quotient x y)) (if (and (finite? x) (finite? y))
(r (safe-centered-remainder x y))) (and (eq? (exact? q)
(if (not (and (eq? (exact? q) (exact? r)) (exact? r)
(eq? (exact? q) (and (exact? x) (exact? y))) (and (exact? x) (exact? y)))
(test-real-eqv? r (- x (* q y))) (integer? q)
(or (and (integer? q) (test-eqv? r (- x (* q y)))
(test-within-range? (* -1/2 (abs y)) (test-within-range? (* -1/2 (abs y))
(* +1/2 (abs y)) (* +1/2 (abs y))
r)) r))
(not (finite? x)) (and (test-eqv? q (safe-centered-quotient x y))
(not (finite? y))))) (test-eqv? r (safe-centered-remainder x y)))))
(throw 'safe-centered/-is-broken (list x y q r))
(values q r))))
(define test-numerators (define test-numerators
(append (append (cartesian-product-map * '(1 -1)
(list 123 125 127 130 3 5 10 123.2 125.0 '(123 125 127 130 3 5 10
-123 -125 -127 -130 -3 -5 -10 -123.2 -125.0 123.2 125.0 127.2 130.0
127.2 130.0 123/7 125/7 127/7 130/7 123/7 125/7 127/7 130/7))
-127.2 -130.0 -123/7 -125/7 -127/7 -130/7 (cartesian-product-map * '(1 -1)
0 +0.0 -0.0 +inf.0 -inf.0 +nan.0 '(123 125 127 130 3 5 10)
most-negative-fixnum (1+ most-positive-fixnum) (list 1
(1- most-negative-fixnum)) (+ 1 most-positive-fixnum)
(apply append (+ 2 most-positive-fixnum)))
(map (lambda (x) (list (* x (+ 1 most-positive-fixnum)) (list 0 +0.0 -0.0 +inf.0 -inf.0 +nan.0
(* x (+ 2 most-positive-fixnum)))) most-negative-fixnum
'( 123 125 127 130 3 5 10 (1+ most-positive-fixnum)
-123 -125 -127 -130 -3 -5 -10))))) (1- most-negative-fixnum))))
(define test-denominators (define test-denominators
(list 10 5 10/7 127/2 10.0 63.5 (list 10 5 10/7 127/2 10.0 63.5
@ -3623,58 +3637,32 @@
(+ 1 most-positive-fixnum) (+ -1 most-negative-fixnum) (+ 1 most-positive-fixnum) (+ -1 most-negative-fixnum)
(+ 2 most-positive-fixnum) (+ -2 most-negative-fixnum))) (+ 2 most-positive-fixnum) (+ -2 most-negative-fixnum)))
(define (do-tests-1 op-name real-op safe-op)
(for-each (lambda (d)
(for-each (lambda (n)
(run-test (list op-name n d) #t
(lambda ()
(test-eqv? (real-op n d)
(safe-op n d)))))
test-numerators))
test-denominators))
(define (do-tests-2 op-name real-op safe-op)
(for-each (lambda (d)
(for-each (lambda (n)
(run-test (list op-name n d) #t
(lambda ()
(let-values
(((q r) (safe-op n d))
((q1 r1) (real-op n d)))
(and (test-eqv? q q1)
(test-eqv? r r1))))))
test-numerators))
test-denominators))
(pass-if (documented? euclidean/))
(pass-if (documented? euclidean-quotient))
(pass-if (documented? euclidean-remainder))
(pass-if (documented? centered/))
(pass-if (documented? centered-quotient))
(pass-if (documented? centered-remainder))
(with-test-prefix "euclidean-quotient"
(do-tests-1 'euclidean-quotient
euclidean-quotient
safe-euclidean-quotient))
(with-test-prefix "euclidean-remainder"
(do-tests-1 'euclidean-remainder
euclidean-remainder
safe-euclidean-remainder))
(with-test-prefix "euclidean/" (with-test-prefix "euclidean/"
(do-tests-2 'euclidean/ (pass-if (documented? euclidean/))
euclidean/ (pass-if (documented? euclidean-quotient))
safe-euclidean/)) (pass-if (documented? euclidean-remainder))
(cartesian-product-for-each
(lambda (n d)
(run-test (list 'euclidean/ n d) #t
(lambda ()
(let-values (((q r) (euclidean/ n d)))
(and (test-eqv? q (euclidean-quotient n d))
(test-eqv? r (euclidean-remainder n d))
(valid-euclidean-answer? n d q r))))))
test-numerators test-denominators))
(with-test-prefix "centered-quotient"
(do-tests-1 'centered-quotient
centered-quotient
safe-centered-quotient))
(with-test-prefix "centered-remainder"
(do-tests-1 'centered-remainder
centered-remainder
safe-centered-remainder))
(with-test-prefix "centered/" (with-test-prefix "centered/"
(do-tests-2 'centered/ (pass-if (documented? centered/))
centered/ (pass-if (documented? centered-quotient))
safe-centered/))) (pass-if (documented? centered-remainder))
(cartesian-product-for-each
(lambda (n d)
(run-test (list 'centered/ n d) #t
(lambda ()
(let-values (((q r) (centered/ n d)))
(and (test-eqv? q (centered-quotient n d))
(test-eqv? r (centered-remainder n d))
(valid-centered-answer? n d q r))))))
test-numerators test-denominators)))