285 lines
8.0 KiB
Scheme
285 lines
8.0 KiB
Scheme
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
||
; Inexact rational arithmetic using hacked-in floating point numbers.
|
||
|
||
(define floatnum? double?)
|
||
|
||
(define-enumeration flop
|
||
(+ - * / = <
|
||
fixnum->float
|
||
string->float
|
||
float->string
|
||
exp log sin cos tan asin acos atan sqrt
|
||
floor
|
||
integer?
|
||
float->fixnum
|
||
quotient
|
||
remainder))
|
||
|
||
(define-syntax floperate
|
||
(syntax-rules ()
|
||
((floperate ?which ?x)
|
||
(vm-extension (+ ?which 100) ?x))
|
||
((floperate ?which ?x ?y)
|
||
(vm-extension (+ ?which 100) (cons ?x ?y)))
|
||
((floperate ?which ?x ?y ?z)
|
||
(vm-extension (+ ?which 100) (vector ?x ?y ?z)))))
|
||
|
||
(define (float&float->float op)
|
||
(lambda (a b)
|
||
(let ((res (make-double)))
|
||
(floperate op (x->float a) (x->float b) res)
|
||
res)))
|
||
|
||
(define (float&float->boolean op)
|
||
(lambda (a b)
|
||
(floperate op (x->float a) (x->float b))))
|
||
|
||
(define (float1 op)
|
||
(lambda (float)
|
||
(floperate op float)))
|
||
|
||
(define (float->float op)
|
||
(lambda (a)
|
||
(let ((res (make-double)))
|
||
(floperate op (x->float a) res)
|
||
res)))
|
||
|
||
(define (string->float string)
|
||
(let ((res (make-double)))
|
||
(floperate (enum flop string->float) string res)
|
||
res))
|
||
|
||
; Call the OS to get a string and then add a `.' if necessary (so that
|
||
; it will be inexact).
|
||
|
||
(define (float->string float)
|
||
(let* ((res (make-string 40 #\space))
|
||
(len (floperate (enum flop float->string)
|
||
float
|
||
res))
|
||
(str (substring res 0 len)))
|
||
(let loop ((i 0))
|
||
(cond ((>= i (string-length str))
|
||
(string-append str "."))
|
||
((char=? (string-ref str i) #\.)
|
||
str)
|
||
((char=? (string-ref str i) #\e)
|
||
(string-append (substring str 0 i)
|
||
"."
|
||
(substring str i (string-length str))))
|
||
(else
|
||
(loop (+ i 1)))))))
|
||
|
||
(define (x->float x)
|
||
(cond ((double? x)
|
||
x)
|
||
((integer? x)
|
||
(exact-integer->float (if (exact? x)
|
||
x
|
||
(inexact->exact x))))
|
||
((rational? x)
|
||
;; This loses when num or den overflows flonum range
|
||
;; but x doesn't.
|
||
(float/ (numerator x) (denominator x)))
|
||
(else
|
||
(error "cannot coerce to a float" x))))
|
||
|
||
; Conversion to/from exact integer
|
||
|
||
(define (exact-integer->float k)
|
||
(or (fixnum->float k)
|
||
(float+ (float* (fixnum->float definitely-a-fixnum)
|
||
(quotient k definitely-a-fixnum))
|
||
(fixnum->float (remainder k definitely-a-fixnum)))))
|
||
|
||
(define (fixnum->float k) ;Returns #f is k is a bignum
|
||
(let ((res (make-double)))
|
||
(if (floperate (enum flop fixnum->float) k res)
|
||
res
|
||
#f)))
|
||
|
||
(define (float->exact-integer x)
|
||
(or (float->fixnum x)
|
||
(let ((d (fixnum->float definitely-a-fixnum)))
|
||
(+ (* definitely-a-fixnum
|
||
(float->exact-integer (float-quotient x d)))
|
||
(float->fixnum (loophole :double ; outsmarted ourselves
|
||
(float-remainder x d)))))))
|
||
|
||
(define definitely-a-fixnum (expt 2 23)) ;Be conservative
|
||
|
||
(define integral-floatnum? (float1 (enum flop integer?)))
|
||
(define float->fixnum (float1 (enum flop float->fixnum)))
|
||
|
||
(define float+ (float&float->float (enum flop +)))
|
||
(define float- (float&float->float (enum flop -)))
|
||
(define float* (float&float->float (enum flop *)))
|
||
(define float/ (float&float->float (enum flop /)))
|
||
(define float-quotient (float&float->float (enum flop quotient)))
|
||
(define float-remainder (float&float->float (enum flop remainder)))
|
||
(define float-atan (float&float->float (enum flop atan)))
|
||
|
||
(define float= (float&float->boolean (enum flop =)))
|
||
(define float< (float&float->boolean (enum flop <)))
|
||
|
||
(define float-exp (float->float (enum flop exp)))
|
||
(define float-log (float->float (enum flop log)))
|
||
(define float-sin (float->float (enum flop sin)))
|
||
(define float-cos (float->float (enum flop cos)))
|
||
(define float-tan (float->float (enum flop tan)))
|
||
(define float-asin (float->float (enum flop asin)))
|
||
(define float-acos (float->float (enum flop acos)))
|
||
(define float-sqrt (float->float (enum flop sqrt)))
|
||
(define float-floor (float->float (enum flop floor)))
|
||
|
||
; This lets you do ,open floatnum to get faster invocation
|
||
(begin
|
||
(define exp float-exp)
|
||
(define log float-log)
|
||
(define sin float-sin)
|
||
(define cos float-cos)
|
||
(define tan float-tan)
|
||
(define asin float-asin)
|
||
(define acos float-acos)
|
||
(define atan float-atan)
|
||
(define sqrt float-sqrt))
|
||
|
||
(define (float-fraction-length x)
|
||
(let ((two (exact-integer->float 2)))
|
||
(do ((x x (float* x two))
|
||
(i 0 (+ i 1)))
|
||
((integral-floatnum? x) i)
|
||
(if (> i 1000) (error "I'm bored." x)))))
|
||
|
||
(define (float-denominator x)
|
||
(expt (exact-integer->float 2) (float-fraction-length x)))
|
||
|
||
(define (float-numerator x)
|
||
(float* x (float-denominator x)))
|
||
|
||
(define (float->exact x)
|
||
(if (integral-floatnum? x)
|
||
(float->exact-integer x) ;+++
|
||
(let ((lose (lambda ()
|
||
(call-error "no exact representation"
|
||
inexact->exact x)))
|
||
(q (expt 2 (float-fraction-length x))))
|
||
(if (exact? q)
|
||
(let ((e (/ (float->exact-integer
|
||
(float* x (exact-integer->float q)))
|
||
q)))
|
||
(if (exact? e)
|
||
e
|
||
(lose)))
|
||
(lose)))))
|
||
|
||
|
||
; Methods on floatnums
|
||
|
||
(define-method &integer? ((x :double))
|
||
(integral-floatnum? x))
|
||
|
||
(define-method &rational? ((n :double)) #t)
|
||
|
||
(define-method &exact? ((x :double)) #f)
|
||
|
||
(define-method &inexact->exact ((x :double))
|
||
(float->exact x))
|
||
|
||
(define-method &exact->inexact ((x :rational))
|
||
(x->float x)) ;Should do this only if the number is within range.
|
||
|
||
(define-method &floor ((x :double)) (float-floor x))
|
||
|
||
; beware infinite regress
|
||
(define-method &numerator ((x :double)) (float-numerator x))
|
||
(define-method &denominator ((x :double)) (float-denominator x))
|
||
|
||
(define (define-floatnum-method mtable proc)
|
||
(define-method mtable ((m :rational) (n :rational)) (proc m n)))
|
||
|
||
(define-floatnum-method &+ float+)
|
||
(define-floatnum-method &- float-)
|
||
(define-floatnum-method &* float*)
|
||
(define-floatnum-method &/ float/)
|
||
(define-floatnum-method "ient float-quotient)
|
||
(define-floatnum-method &remainder float-remainder)
|
||
(define-floatnum-method &= float=)
|
||
(define-floatnum-method &< float<)
|
||
|
||
(define-method &numerator ((x :rational)) (float-numerator x))
|
||
(define-method &denominator ((x :rational)) (float-denominator x))
|
||
|
||
(define-method &exp ((x :rational)) (float-exp x))
|
||
(define-method &log ((x :rational)) (float-log x))
|
||
(define-method &sqrt ((x :rational)) (float-sqrt x))
|
||
(define-method &sin ((x :rational)) (float-sin x))
|
||
(define-method &cos ((x :rational)) (float-cos x))
|
||
(define-method &tan ((x :rational)) (float-tan x))
|
||
(define-method &acos ((x :rational)) (float-acos x))
|
||
|
||
(define-floatnum-method &atan float-atan)
|
||
|
||
(define-method &number->string ((n :double) radix)
|
||
(if (= radix 10)
|
||
(float->string n)
|
||
(next-method)))
|
||
|
||
; Recognizing a floating point number. This doesn't know about `#'.
|
||
|
||
(define (float-string? s)
|
||
(let ((len (string-length s)))
|
||
(define (start)
|
||
(and (< 1 len)
|
||
(let ((first (string-ref s 0))
|
||
(second (string-ref s 1)))
|
||
(if (char-numeric? first)
|
||
(digits 1 #f #f)
|
||
(case first
|
||
((#\+ #\-)
|
||
(and (char-numeric? second)
|
||
(digits 2 #f #f)))
|
||
((#\.)
|
||
(and (char-numeric? second)
|
||
(digits 2 #t #f)))
|
||
(else #f))))))
|
||
|
||
; Read digits until the end or an `e' or a `.'. E-OR-DOT? is true if
|
||
; we have seen either, E? is true if we've seen an `e'.
|
||
(define (digits i e-or-dot? e?)
|
||
(if (= i len)
|
||
e-or-dot?
|
||
(let ((next (string-ref s i)))
|
||
(if (char-numeric? next)
|
||
(digits (+ i 1) e-or-dot? e?)
|
||
(case next
|
||
((#\e #\E)
|
||
(and (not e?)
|
||
(exponent (+ i 1) #f)))
|
||
((#\.)
|
||
(and (not e-or-dot?)
|
||
(digits (+ i 1) #t #f)))
|
||
(else #f))))))
|
||
|
||
; Read in an exponent. If SIGN? is true then we have already got the sign.
|
||
(define (exponent i sign?)
|
||
(and (< i len)
|
||
(let ((next (string-ref s i)))
|
||
(if (char-numeric? next)
|
||
(digits (+ i 1) #t #t)
|
||
(case next
|
||
((#\+ #\-)
|
||
(and (not sign?)
|
||
(exponent (+ i 1) #t)))
|
||
(else #f))))))
|
||
(start)))
|
||
|
||
(define-simple-type :float-string (:string) float-string?)
|
||
|
||
(define-method &really-string->number ((s :float-string) radix exact?)
|
||
(if (and (= radix 10)
|
||
(not exact?))
|
||
(string->float s)
|
||
(next-method)))
|