# Changeset 30553 in project

Ignore:
Timestamp:
03/10/14 21:30:36 (7 years ago)
Message:

numbers: Improve error message when passing bad base for exact-integer-nth-root

File:
1 edited

Unmodified
Added
Removed
• ## release/4/numbers/trunk/numbers.scm

 r30545 (define (bad-integer loc x) (##sys#signal-hook #:type-error loc "bad argument type - not an integer" x)) (define (bad-natural loc x) (##sys#signal-hook #:type-error loc "bad argument type - must be an nonnegative integer" x)) (define (bad-positive loc x) (##sys#signal-hook #:type-error loc "bad argument type - must be a positive (non-zero) integer" x)) (define (bad-complex/o loc x) (##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" x)) (define (bad-base loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a valid base" x)) ;; from Wikipedia ;)  https://en.wikipedia.org/wiki/Nth_root_algorithm (define (%exact-integer-nth-root loc k n) (if (or (eq? 0 k) (eq? 1 k) (eq? 1 n))       ; Maybe call exact-integer-sqrt on n=2? (values k 0) (let ((len (integer-length k))) (if (fx< len n)        ; Idea from Gambit: 2^{len-1} <= k < 2^{len} (values 1 (- k 1)) ; Since we know x >= 2, we know x^{n} can't exist ;; Set initial guess to (at least) 2^ceil(ceil(log2(k))/n) (let* ((shift-amount (ceiling (/ (fx+ len 1) n))) (g0 (arithmetic-shift 1 shift-amount)) (n-1 (%- n 1))) (let lp ((g0 g0) (g1 (%quotient loc (%+ (%* n-1 g0) (%quotient loc k (%integer-power g0 n-1))) n))) (if (%< g1 g0 loc) (lp g1 (%quotient loc (%+ (%* n-1 g1) (%quotient loc k (%integer-power g1 n-1))) n)) (values g0 (%- k (%integer-power g0 n)))))))))) (cond ((or (eq? 0 k) (eq? 1 k) (eq? 1 n)) ; Maybe call exact-integer-sqrt on n=2? (values k 0)) ((< n 1) (bad-positive loc n)) (else (let ((len (integer-length k))) (if (< len n)       ; Idea from Gambit: 2^{len-1} <= k < 2^{len} (values 1 (- k 1)) ; Since we know x >= 2, we know x^{n} can't exist ;; Set initial guess to (at least) 2^ceil(ceil(log2(k))/n) (let* ((shift-amount (ceiling (/ (fx+ len 1) n))) (g0 (arithmetic-shift 1 shift-amount)) (n-1 (%- n 1))) (let lp ((g0 g0) (g1 (%quotient loc (%+ (%* n-1 g0) (%quotient loc k (%integer-power g0 n-1))) n))) (if (%< g1 g0 loc) (lp g1 (%quotient loc (%+ (%* n-1 g1) (%quotient loc k (%integer-power g1 n-1))) n)) (values g0 (%- k (%integer-power g0 n))))))))))) (define (exact-integer-nth-root k n)
Note: See TracChangeset for help on using the changeset viewer.