347 lines
14 KiB
Racket
347 lines
14 KiB
Racket
#lang typed/racket/base
|
||
|
||
#|
|
||
Arithmetic based on:
|
||
|
||
Jonathan Richard Shewchuk
|
||
Adaptive Precision Floating-Point Arithmetic and Fast Robust Geometric Predicates
|
||
Discrete & Computational Geometry 18(3):305–363, October 1997
|
||
|
||
Other parts shamelessly stolen from crlibm (which is LGPL)
|
||
|#
|
||
|
||
(require racket/math
|
||
"../flonum-functions.rkt"
|
||
"../flonum-bits.rkt"
|
||
"../flonum-error.rkt"
|
||
"../flonum-constants.rkt"
|
||
"../utils.rkt")
|
||
|
||
(provide fl2? fl2zero? fl2rational? fl2positive? fl2negative? fl2infinite? fl2nan?
|
||
fl2 fl2->real
|
||
fl2ulp fl2ulp-error fl2step fl2next fl2prev
|
||
+max.hi +max.lo -max.hi -max.lo
|
||
+max-subnormal.hi -max-subnormal.hi
|
||
fl2abs fl2+ fl2- fl2= fl2> fl2< fl2>= fl2<=
|
||
fl2*split-fl fl2* fl2sqr fl2/
|
||
fl2sqrt flsqrt/error)
|
||
|
||
(: floverlapping? (Flonum Flonum -> Boolean))
|
||
(define (floverlapping? x2 x1)
|
||
(define-values (s2 e2) (flonum->sig+exp (flabs x2)))
|
||
(define-values (s1 e1) (flonum->sig+exp (flabs x1)))
|
||
(define-values (n1 n2)
|
||
(if (e2 . > . e1)
|
||
(values s1 (arithmetic-shift s2 (- e2 e1)))
|
||
(values (arithmetic-shift s1 (- e1 e2)) s2)))
|
||
(not (= (bitwise-ior n1 n2)
|
||
(bitwise-xor n1 n2))))
|
||
|
||
(: fl2? (Flonum Flonum -> Boolean))
|
||
(define (fl2? x2 x1)
|
||
(cond [(flrational? x2)
|
||
(cond [(flrational? x1)
|
||
(cond [((flabs x2) . < . (flabs x1)) #f]
|
||
[else (not (floverlapping? x2 x1))])]
|
||
[else #f])]
|
||
[else
|
||
(fl= x1 0.0)]))
|
||
|
||
(define-syntax-rule (define-simple-fl2-predicate fl2pred? flpred?)
|
||
(begin
|
||
(: fl2pred? (Flonum Flonum -> Boolean))
|
||
(define (fl2pred? x2 x1)
|
||
(flpred? (fl+ x2 x1)))))
|
||
|
||
(define-simple-fl2-predicate fl2zero? (λ (x) (fl= x 0.0)))
|
||
(define-simple-fl2-predicate fl2positive? (λ (x) (fl> x 0.0)))
|
||
(define-simple-fl2-predicate fl2negative? (λ (x) (fl< x 0.0)))
|
||
(define-simple-fl2-predicate fl2rational? flrational?)
|
||
(define-simple-fl2-predicate fl2nan? flnan?)
|
||
(define-simple-fl2-predicate fl2infinite? flinfinite?)
|
||
|
||
;; ===================================================================================================
|
||
;; Conversion
|
||
|
||
(: fl2 (case-> (Real -> (Values Flonum Flonum))
|
||
(Flonum Flonum -> (Values Flonum Flonum))))
|
||
(define fl2
|
||
(case-lambda
|
||
[(x)
|
||
(cond [(flonum? x) (values x 0.0)]
|
||
[(single-flonum? x) (values (fl x) 0.0)]
|
||
[else
|
||
(define x2 (fl x))
|
||
(if (flinfinite? x2)
|
||
(values x2 0.0)
|
||
(let* ([x (- x (inexact->exact x2))]
|
||
[x1 (fl x)]
|
||
[x (- x (inexact->exact x1))])
|
||
(let-values ([(x2 x1) (fl+/error x2 x1)])
|
||
(values x2 (fl+ x1 (fl x))))))])]
|
||
[(x2 x1)
|
||
(if (and (fl= x2 0.0) (fl= x1 0.0))
|
||
(values x2 0.0)
|
||
(fl+/error x2 x1))]))
|
||
|
||
(: fl2eqv? (case-> (Flonum Flonum Flonum -> Boolean)
|
||
(Flonum Flonum Flonum Flonum -> Boolean)))
|
||
(define (fl2eqv? x2 x1 y2 [y1 0.0])
|
||
(and (eqv? x2 y2) (fl= x1 y1)))
|
||
|
||
(: fl2->real (Flonum Flonum -> Real))
|
||
(define (fl2->real x2 x1)
|
||
(if (flrational? x2)
|
||
(+ (inexact->exact x2) (inexact->exact x1))
|
||
x2))
|
||
|
||
(: fl4->fl2 (Flonum Flonum Flonum Flonum -> (Values Flonum Flonum)))
|
||
(define (fl4->fl2 e4 e3 e2 e1)
|
||
(values e4 (fl+ e3 (fl+ e2 e1))))
|
||
|
||
;; ===================================================================================================
|
||
;; Error
|
||
|
||
(: fl2ulp (Flonum Flonum -> Flonum))
|
||
(define (fl2ulp x2 x1)
|
||
(cond [(fl= x2 0.0) 0.0]
|
||
[else (flmax +min.0 (fl* (flulp x2) epsilon.0))]))
|
||
|
||
(: fl2ulp-error (Flonum Flonum Real -> Flonum))
|
||
(define (fl2ulp-error x2 x1 r)
|
||
(define x (fl2->real x2 x1))
|
||
(define-values (r2 r1) (fl2 r))
|
||
(cond [(eqv? x r) 0.0]
|
||
[(and (fl= x2 0.0) (fl= r2 0.0)) 0.0]
|
||
[(and (fl= x2 +inf.0) (fl= r2 +inf.0)) 0.0]
|
||
[(and (fl= x2 -inf.0) (fl= r2 -inf.0)) 0.0]
|
||
[(zero? r) +inf.0]
|
||
[(and (rational? x) (flrational? r2))
|
||
(flabs (fl (/ (- (inexact->exact x) (inexact->exact r))
|
||
(inexact->exact (flmax +min.0 (fl2ulp r2 r1))))))]
|
||
[else +inf.0]))
|
||
|
||
(define-values (+max.hi +max.lo)
|
||
(values +max.0 (flprev (* 0.5 (flulp +max.0)))))
|
||
|
||
(define-values (-max.hi -max.lo)
|
||
(values (- +max.hi) (- +max.lo)))
|
||
|
||
(: fl2step (Flonum Flonum Integer -> (Values Flonum Flonum)))
|
||
(define (fl2step x2 x1 n)
|
||
(let-values ([(x2 x1) (fast-fl+/error x2 x1)])
|
||
(cond [(flnan? x2) (values +nan.0 0.0)]
|
||
[(fl= x2 +inf.0) (fl+/error +max.hi (flstep +max.lo (+ n 1)))]
|
||
[(fl= x2 -inf.0) (fl+/error -max.hi (flstep -max.lo (- n 1)))]
|
||
[else (fl+/error x2 (flstep x1 n))])))
|
||
|
||
(: fl2next (Flonum Flonum -> (Values Flonum Flonum)))
|
||
(define (fl2next x2 x1) (fl2step x2 x1 1))
|
||
|
||
(: fl2prev (Flonum Flonum -> (Values Flonum Flonum)))
|
||
(define (fl2prev x2 x1) (fl2step x2 x1 -1))
|
||
|
||
(define +min-normal.hi (fl/ (flnext +max-subnormal.0) epsilon.0))
|
||
|
||
(define-values (+max-subnormal.hi +max-subnormal.lo)
|
||
(fl2prev +min-normal.hi 0.0))
|
||
|
||
(define-values (-max-subnormal.hi -max-subnormal.lo)
|
||
(values (- +max-subnormal.hi) (- +max-subnormal.lo)))
|
||
|
||
;; ===================================================================================================
|
||
;; Absolute value
|
||
|
||
(: fl2abs (case-> (Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum -> (Values Flonum Flonum))))
|
||
(define fl2abs
|
||
(case-lambda
|
||
[(x) (values (flabs x) 0.0)]
|
||
[(x2 x1)
|
||
(cond [(flnan? x2) (values +nan.0 0.0)]
|
||
[(fl= x2 0.0) (values 0.0 0.0)]
|
||
[(fl> x2 0.0) (values x2 x1)]
|
||
[else (values (- x2) (- x1))])]))
|
||
|
||
;; ===================================================================================================
|
||
;; Addition and subtraction
|
||
|
||
(: fl2+ (case-> (Flonum Flonum Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum Flonum Flonum -> (Values Flonum Flonum))))
|
||
(define (fl2+ x2 x1 y2 [y1 0.0])
|
||
(define r (fl+ x2 y2))
|
||
(cond [(not (flrational? r)) (values r 0.0)]
|
||
[(and (fl= x2 0.0) (fl= y2 0.0)) (values r 0.0)]
|
||
[else
|
||
(define s (if ((flabs x2) . fl> . (flabs y2))
|
||
(fl+ (fl+ (fl+ (fl- x2 r) y2) y1) x1)
|
||
(fl+ (fl+ (fl+ (fl- y2 r) x2) x1) y1)))
|
||
(define z2 (fl+ r s))
|
||
(values z2 (fl+ (fl- r z2) s))]))
|
||
|
||
(: fl2- (case-> (Flonum Flonum Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum Flonum Flonum -> (Values Flonum Flonum))))
|
||
(define (fl2- x2 x1 y2 [y1 0.0])
|
||
(fl2+ x2 x1 (- y2) (- y1)))
|
||
|
||
;; ===================================================================================================
|
||
;; Comparison
|
||
|
||
(define-syntax-rule (define-fl2-comparison name flcomp)
|
||
(begin
|
||
(: name (Flonum Flonum Flonum Flonum -> Boolean))
|
||
(define (name x2 x1 y2 y1)
|
||
(let-values ([(z2 z1) (fl2- x2 x1 y2 y1)])
|
||
((fl+ z2 z1) . flcomp . 0.0)))))
|
||
|
||
(define-fl2-comparison fl2= fl=)
|
||
(define-fl2-comparison fl2> fl>)
|
||
(define-fl2-comparison fl2< fl<)
|
||
(define-fl2-comparison fl2>= fl>=)
|
||
(define-fl2-comparison fl2<= fl<=)
|
||
|
||
;; ===================================================================================================
|
||
;; Multiplication and division
|
||
|
||
(: raw-split-fl2*split-fl (Flonum Flonum Flonum Flonum Flonum Flonum
|
||
-> (Values Flonum Flonum Flonum Flonum)))
|
||
(define (raw-split-fl2*split-fl e2-hi e2-lo e1-hi e1-lo b-hi b-lo)
|
||
(let*-values ([(b) (fl+ b-lo b-hi)]
|
||
[(Q1) (fl* (fl+ e1-lo e1-hi) b)]
|
||
[(h1) (- (- Q1
|
||
(fl* e1-hi b-hi)
|
||
(fl* e1-lo b-hi)
|
||
(fl* e1-hi b-lo)
|
||
(fl* e1-lo b-lo)))]
|
||
[(T) (fl* (fl+ e2-lo e2-hi) b)]
|
||
[(t) (- (- T
|
||
(fl* e2-hi b-hi)
|
||
(fl* e2-lo b-hi)
|
||
(fl* e2-hi b-lo)
|
||
(fl* e2-lo b-lo)))]
|
||
[(Q2 h2) (fast-fl+/error Q1 t)]
|
||
[(h4 h3) (fast-mono-fl+/error T Q2)])
|
||
(values h4 h3 h2 h1)))
|
||
|
||
(: split-fl2*split-fl (Flonum Flonum Flonum Flonum Flonum Flonum -> (Values Flonum Flonum)))
|
||
(define (split-fl2*split-fl e2-hi e2-lo e1-hi e1-lo b-hi b-lo)
|
||
(let-values ([(h4 h3 h2 h1) (raw-split-fl2*split-fl e2-hi e2-lo e1-hi e1-lo b-hi b-lo)])
|
||
(fl4->fl2 h4 h3 h2 h1)))
|
||
|
||
(: fl2*split-fl (Flonum Flonum Flonum Flonum -> (Values Flonum Flonum)))
|
||
(define (fl2*split-fl e2 e1 b-hi b-lo)
|
||
(let*-values ([(e2-hi e2-lo) (flsplit e2)]
|
||
[(e1-hi e1-lo) (flsplit e1)]
|
||
[(h4 h3 h2 h1) (raw-split-fl2*split-fl e2-hi e2-lo e1-hi e1-lo b-hi b-lo)])
|
||
(fl4->fl2 h4 h3 h2 h1)))
|
||
|
||
(: fl2* (case-> (Flonum Flonum Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum Flonum Flonum -> (Values Flonum Flonum))))
|
||
(define (fl2* x2 x1 y2 [y1 0.0])
|
||
(define z (fl* x2 y2))
|
||
(cond [(fl= z 0.0) (values z 0.0)]
|
||
[(flsubnormal? z) (values z 0.0)]
|
||
[(and (flrational? x2) (flrational? y2) (z . fl>= . -inf.0) (z . fl<= . +inf.0))
|
||
(define dx (near-pow2 x2))
|
||
(define dy (near-pow2 y2))
|
||
(define d (fl* dx dy))
|
||
(define d? (and (d . fl> . 0.0) (d . fl< . +inf.0)))
|
||
(let* ([x2 (fl/ x2 dx)]
|
||
[x1 (fl/ x1 dx)]
|
||
[y2 (fl/ y2 dy)]
|
||
[y1 (fl/ y1 dy)]
|
||
[up (fl* x2 (fl+ 1.0 (flexpt 2.0 27.0)))]
|
||
[vp (fl* y2 (fl+ 1.0 (flexpt 2.0 27.0)))]
|
||
[u1 (fl+ (fl- x2 up) up)]
|
||
[v1 (fl+ (fl- y2 vp) vp)]
|
||
[u2 (fl- x2 u1)]
|
||
[v2 (fl- y2 v1)]
|
||
[m2 (fl* x2 y2)]
|
||
[m1 (fl+ (fl+ (fl+ (fl+ (fl+ (fl- (fl* u1 v1) m2)
|
||
(fl* u1 v2))
|
||
(fl* u2 v1))
|
||
(fl* u2 v2))
|
||
(fl* x2 y1))
|
||
(fl* x1 y2))]
|
||
[z2 (fl+ m2 m1)]
|
||
[z1 (fl+ (fl- m2 z2) m1)]
|
||
[z2 (if d? (fl* z2 d) (fl* (fl* z2 dx) dy))])
|
||
(values z2 (if (flrational? z2) (if d? (fl* z1 d) (fl* (fl* z1 dx) dy)) 0.0)))]
|
||
[else
|
||
(values z 0.0)]))
|
||
|
||
(: fl2sqr (case-> (Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum -> (Values Flonum Flonum))))
|
||
;; Derived from fl2*
|
||
(define fl2sqr
|
||
(case-lambda
|
||
[(x) (flsqr/error x)]
|
||
[(x2 x1)
|
||
(define z (fl* x2 x2))
|
||
(cond [(fl= z 0.0) (values z 0.0)]
|
||
[(flsubnormal? z) (values z 0.0)]
|
||
[(and (flrational? x2) (z . fl>= . -inf.0) (z . fl<= . +inf.0))
|
||
(define dx (near-pow2 x2))
|
||
(define d (fl* dx dx))
|
||
(define d? (and (d . fl> . 0.0) (d . fl< . +inf.0)))
|
||
(let* ([x2 (fl/ x2 dx)]
|
||
[x1 (fl/ x1 dx)]
|
||
[up (fl* x2 (fl+ 1.0 (flexpt 2.0 27.0)))]
|
||
[u1 (fl+ (fl- x2 up) up)]
|
||
[u2 (fl- x2 u1)]
|
||
[m2 (fl* x2 x2)]
|
||
[m1 (fl+ (fl+ (fl+ (fl- (fl* u1 u1) m2)
|
||
(fl* 2.0 (fl* u1 u2)))
|
||
(fl* u2 u2))
|
||
(fl* 2.0 (fl* x2 x1)))]
|
||
[z2 (fl+ m2 m1)]
|
||
[z1 (fl+ (fl- m2 z2) m1)]
|
||
[z2 (if d? (fl* z2 d) (fl* (fl* z2 dx) dx))])
|
||
(values z2 (if (flrational? z2) (if d? (fl* z1 d) (fl* (fl* z1 dx) dx)) 0.0)))]
|
||
[else
|
||
(values z 0.0)])]))
|
||
|
||
(: fl2/ (case-> (Flonum Flonum Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum Flonum Flonum -> (Values Flonum Flonum))))
|
||
(define (fl2/ x2 x1 y2 [y1 0.0])
|
||
(define z (fl/ x2 y2))
|
||
(cond [(and (flrational? z) (not (fl= z 0.0)) (flrational? y2))
|
||
(define d (near-pow2/div x2 y2))
|
||
(let*-values ([(x2 x1) (values (fl/ x2 d) (fl/ x1 d))]
|
||
[(y2 y1) (values (fl/ y2 d) (fl/ y1 d))]
|
||
[(c2) (fl/ x2 y2)]
|
||
[(u2 u1) (fl*/error c2 y2)]
|
||
[(c1) (fl/ (fl- (fl+ (fl- (fl- x2 u2) u1) x1) (fl* c2 y1)) y2)]
|
||
[(z2) (fl+ c2 c1)])
|
||
(values z2 (if (flrational? z2) (fl+ (fl- c2 z2) c1) 0.0)))]
|
||
[else
|
||
(values z 0.0)]))
|
||
|
||
;; ===================================================================================================
|
||
;; Square roots
|
||
|
||
(: fl2sqrt (case-> (Flonum -> (Values Flonum Flonum))
|
||
(Flonum Flonum -> (Values Flonum Flonum))))
|
||
;; One-flonum estimate followed by one Newton's method iteration
|
||
(define (fl2sqrt x2 [x1 0.0])
|
||
(cond [(and (flrational? x2) (not (fl= x2 0.0)))
|
||
(define-values (d^2 d)
|
||
(cond [(x2 . fl<= . +max-subnormal.hi) (values (flexpt 2.0 -104.0)
|
||
(flexpt 2.0 -52.0))]
|
||
[(x2 . fl> . 1e300) (values (flexpt 2.0 104.0)
|
||
(flexpt 2.0 52.0))]
|
||
[else (values 1.0 1.0)]))
|
||
(let*-values ([(x2 x1) (values (fl/ x2 d^2) (fl/ x1 d^2))]
|
||
[(y) (flsqrt (fl+ x2 x1))]
|
||
[(z2 z1) (fast-flsqr/error y)]
|
||
[(dy2 dy1) (fl2- x2 x1 z2 z1)]
|
||
[(dy2 dy1) (fl2/ dy2 dy1 y)]
|
||
[(y2 y1) (fl2+ (fl* 0.5 dy2) (fl* 0.5 dy1) y)]
|
||
[(y2) (fl* y2 d)])
|
||
(values y2 (if (flrational? y2) (fl* y1 d) 0.0)))]
|
||
[else
|
||
(values (flsqrt x2) 0.0)]))
|
||
|
||
(: flsqrt/error (Flonum -> (Values Flonum Flonum)))
|
||
(define (flsqrt/error x) (fl2sqrt x 0.0))
|