conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Kind of a better implementation of ratnum->flonum.

This commit is contained in:
Abdulaziz Ghuloum 2008-01-06 02:27:23 -05:00
parent da7f05a538
commit 899be70aca
6 changed files with 100174 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
scheme/ikarus.numerics.ss
View File

@ -644,14 +644,36 @@
;;; (expt 2.0 b))))
;;; (* (->flonum (bitwise-arithmetic-shift-right n b) d)
;;; (expt 2.0 b))))))
(define (ratnum->flonum x)
(let f ([n ($ratnum-n x)] [d ($ratnum-d x)])
(let-values ([(q r) (quotient+remainder n d)])
(if (= q 0)
(/ 1.0 (f d n))
(if (= r 0)
(inexact q)
(+ q (f r d)))))))
;;; (define (ratnum->flonum x)
;;; (let f ([n ($ratnum-n x)] [d ($ratnum-d x)])
;;; (let-values ([(q r) (quotient+remainder n d)])
;;; (if (= q 0)
;;; (/ 1.0 (f d n))
;;; (if (= r 0)
;;; (inexact q)
;;; (+ q (f r d)))))))
(define (ratnum->flonum num)
(define (rat n m)
(let-values ([(q r) (quotient+remainder n m)])
(if (= r 0)
(inexact q)
(fl+ (inexact q) (fl/ 1.0 (rat m r))))))
(define (pos n d)
(cond
[(> n d) (rat n d)]
[(even? n)
(* (pos (sra n 1) d) 2.0)]
[(even? d)
(/ (pos n (sra d 1)) 2.0)]
[else
(/ (rat d n))]))
(let ([n ($ratnum-n num)] [d ($ratnum-d num)])
(if (> n 0)
(pos n d)
(- (pos n d)))))
(define binary+
(lambda (x y)
@ -1010,7 +1032,8 @@
(cond
[($fx= g y) (fxquotient x g)]
[($fx= g 1) ($make-ratnum x y)]
[else ($make-ratnum (fxquotient x g) (fxquotient y g))])))]
[else
($make-ratnum (fxquotient x g) (fxquotient y g))])))]
[else
(if ($fx= y -1)
(binary- 0 x)
@ -1066,7 +1089,12 @@
[(bignum? y)
(let ([g (binary-gcd x y)])
(cond
[($fx= g 1) ($make-ratnum x y)]
[($fx= g 1)
(if ($bignum-positive? y)
($make-ratnum x y)
($make-ratnum
(binary- 0 x)
(binary- 0 y)))]
[($bignum-positive? y)
(if (= g y)
(quotient x g)
@ -1075,8 +1103,9 @@
(let ([y (binary- 0 y)])
(if (= g y)
(binary- 0 (quotient x g))
($make-ratnum (binary- 0 (quotient x g))
(quotient y g))))]))]
($make-ratnum
(binary- 0 (quotient x g))
(quotient y g))))]))]
[(flonum? y) ($fl/ (bignum->flonum x) y)]
[(ratnum? y)
(binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
@ -2064,22 +2093,26 @@
(lambda (x)
(cond
[(flonum? x) (foreign-call "ikrt_fl_sqrt" x)]
[(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)]
[(fixnum? x)
(when ($fx< x 0)
(die 'sqrt "complex results not supported" x))
(foreign-call "ikrt_fx_sqrt" x)]
[(bignum? x)
(unless ($bignum-positive? x)
(error 'sqrt "complex results not supported" x))
(die 'sqrt "complex results not supported" x))
(let-values ([(s r) (exact-integer-sqrt x)])
(cond
[(eq? r 0) s]
[else
(let ([v (sqrt (inexact x))])
;;; could the [dropped] residual ever affect the answer?
(cond
[(infinite? v) (inexact s)]
[else v]))]))]
[(ratnum? x)
[(ratnum? x)
;;; FIXME: incorrect as per bug 180170
(/ (sqrt ($ratnum-n x)) (sqrt ($ratnum-d x)))]
[else (die 'sqrt "BUG: unsupported" x)])))
[else (die 'sqrt "not a number" x)])))
(define flsqrt
(lambda (x)
@ -2255,13 +2288,13 @@
[(>= x 0) (foreign-call "ikrt_fl_log" x)]
[else (die 'log "negative argument" x)])]
[(bignum? x)
;;; FIXME: incorrect as per bug 180170
(unless ($bignum-positive? x)
(die 'log "negative argument" x))
(let ([v (log (inexact x))])
(cond
[(infinite? v)
(let-values ([(s r) (exact-integer-sqrt x)])
;;; could the [dropped] residual ever affect the answer?
(fl* 2.0 (log s)))]
[else v]))]
[(ratnum? x)

2
scheme/last-revision
View File

@ -1 +1 @@
1330
1331

2
scheme/run-tests.ss
View File

@ -73,5 +73,5 @@
(test-fxdiv0-and-mod0)
(test-fxlength)
(test-bitwise-bit-count)
(test-io)
;(test-io)
(printf "Happy Happy Joy Joy\n")

9
scheme/tests/io.ss
View File

@ -66,6 +66,7 @@
(define (test-get-char-1 p n)
(let f ([i 0])
(printf "test-getchar1 ~s\n" i)
(let ([x (get-char p)])
(cond
[(eof-object? x)
@ -164,6 +165,14 @@
;;;
(begin
(printf "making transcoder ...\n")
(make-transcoder (latin-1-codec) 'none 'raise)
(printf "making transcoded port ...\n")
(transcoded-port (make-n-byte-bytevector-binary-input-port 256)
(make-transcoder (latin-1-codec) 'none 'raise))
(printf "OK?\n"))
(test "reading 256 latin1 chars from bytevector-input-port"
(test-get-char-1
(transcoded-port (make-n-byte-bytevector-binary-input-port 256)

113
scheme/tests/parse-flonums.ss Normal file
View File

@ -0,0 +1,113 @@
(library (tests parse-flonums)
(export test-parse-flonums)
(import (ikarus))
(define file "tests/rn100")
(define (read-all)
(with-input-from-file file
(lambda ()
(let f ([ac '()])
(let ([x (read)])
(if (eof-object? x)
(reverse ac)
(f (cons x ac))))))))
(define (read-flonum)
(define (decimal x)
(cond
[(assv x '([#\0 . 0] [#\1 . 1] [#\2 . 2] [#\3 . 3] [#\4 . 4]
[#\5 . 5] [#\6 . 6] [#\7 . 7] [#\8 . 8] [#\9 . 9]))
=> cdr]
[else #f]))
(define (st)
(let ([x (read-char)])
(cond
[(eof-object? x) x]
[(char-whitespace? x) (st)]
[(char=? x #\-) (- (sign))]
[(decimal x) => num]
[else (error 'st "invalid char" x)])))
(define (sign)
(let ([x (read-char)])
(cond
[(eof-object? x) (error 'sign "eof")]
[(decimal x) => num]
[else (error 'sign "invalid char" x)])))
(define (num n)
(let ([x (read-char)])
(cond
[(eof-object? x) (error 'num "eof")]
[(decimal x) => (lambda (m) (num (+ (* n 10) m)))]
[(char=? x #\.) (+ n (frac 0 1))]
[else (error 'num "invalid char" x)])))
(define (frac num den)
(let ([x (read-char)])
(cond
[(or (eof-object? x) (char-whitespace? x))
(/ num den)]
[(decimal x) => (lambda (m)
(frac (+ (* num 10) m)
(* den 10)))]
[else (error 'frac "invalid char" x)])))
(st))
;(define (ratnum->flonum x)
; (let f ([n (numerator x)] [d (denominator x)])
; (let-values ([(q r) (quotient+remainder n d)])
; (if (= q 0)
; (/ 1.0 (f d n))
; (if (= r 0)
; (inexact q)
; (+ q (f r d)))))))
(define smallest-flonum
(bytevector-ieee-double-ref
#vu8(1 0 0 0 0 0 0 0)
0
'little))
(define (gen-epsilon x)
(let ([x (flabs x)])
(let f ([eps smallest-flonum])
(if (fl=? x (fl- x eps))
(f (fl* eps 2.0))
eps))))
(define (inexact-close-enough? in ex)
;;; take the inexact number, and generate two
;;; additional numbers: in+epsilon, in-epsilon
;;; turn them into exacts: e1=exact(in+epsilon), e2=exact(in-epsilon)
;;; ensure that at least e1 < ex < e2
(let ([eps (gen-epsilon in)])
(< (exact (fl- in eps)) ex (exact (fl+ in eps)))))
(define (read-exact-all)
(with-input-from-file file
(lambda ()
(let f ([ac '()])
(let ([x (read-flonum)])
(if (eof-object? x)
(reverse ac)
(f (cons x ac))))))))
(define (test-parse-flonums)
(define who 'test-parse-flonums)
(define failed #f)
(define idx 0)
(let ([ls1 (read-all)]
[ls2 (read-exact-all)])
(assert (= (length ls1) (length ls2)))
(for-each
(lambda (x1 x2)
(set! idx (+ idx 1))
(unless (inexact-close-enough? x1 x2)
(set! failed #t)
(printf "test failed in line ~s on read=~s and parsed=~s\n"
idx x1 x2)))
ls1 ls2))
(when failed (error who "failed"))
))

100000
scheme/tests/rn100 Normal file
View File

File diff suppressed because it is too large Load Diff