;;; Numbers.scheme
;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on March 22, 1989 6:28:10 pm PST
;;; Michael Plass, January 20, 1989 9:18:58 pm PST
(define (zero? x)
(= x 0))
(define (positive? x)
(> x 0))
(define (negative? x)
(< x 0))
(define (max x . rest)
"N-ary maximum"
(if (pair? rest)
(if (< x (car rest))
(apply max rest)
(apply max x (cdr rest)))
x))
(define (min x . rest)
"N-ary minimum"
(if (pair? rest)
(if (> x (car rest))
(apply min rest)
(apply min x (cdr rest)))
x))
(define (abs z)
"Absolute value"
(if (real? z)
(if (negative? z)
(- z)
z)
(sqrt (+ (* (real-part z) (real-part z))
(* (imag-part z) (imag-part z))))))
(define (modulo x y)
"remainder with sign matching divisor"
(define (adjust q y)
(if (eq? (negative? q)
(negative? y))
q
(+ q y)))
(adjust (remainder x y) y))
(define (lcm . rest)
"least common multiple"
(define (lcm-list lst)
(cond
((null? (cdr lst))
(car lst))
((null? (cddr lst))
(/ (abs (* (car lst) (cadr lst)))
(gcd (car lst) (cadr lst))))
(else
(lcm (car lst) (lcm-list (cdr lst))))))
(lcm-list rest))
(define (floor x)
"greatest integer not exceeding x"
(if (negative? x)
(if (integer? x)
x
(- (truncate x) 1))
(truncate x)))
(define (ceiling x)
"smallest integer not less than x"
(if (negative? x)
(truncate x)
(if (integer? x)
x
(+ (truncate x) 1))))
(define (rationalize x . epsl)
"one or two argument rationalize"
(define (rat1 x)
(if (rational? x)
x
(+ (inexact->exact x) 0)))
(define (rat2 x eps)
The best rational approximation to a real x is obtained using continued fractions. The following algorithm is adapted from the Cedar RealFns.RationaFromReal, which in turn is adapted from Wm. J. LeVeque's book, Fundamentals of Number Theory, Addison Wesley, 1977, page 229.
(cond
((negative? x)
(- (rat2 (- x) eps)))
((> x 1)
(let ((k (inexact->exact (truncate x))))
(+ k (rat2 (- x k) eps))))
(else
; Here 0<=x<1
(let loop ((s x)
(let ((a (/ p2 q2)))
;; a is the best approximation so far
(if (> (abs (- x a)) eps)
(let* ((inv (/ s))
(k (inexact->exact (truncate inv))))
(loop (- inv k)
p2 q2
(+ (* k p2) p1)
(+ (* k q2) q1)))
a))))))
(define (ratx x eps)
(if (exact? x)
(rat2 x eps)
(exact->inexact (rat2 x eps))))
(if (null? epsl)
(rat1 x)
(ratx x (car epsl))))
(define (exp z)
"exponential function"
(if (real? z)
(real-fns-exp z)
(make-polar (real-fns-exp (real-part z)) (imag-part z))))
(define (log z)
"natural logarithm"
(if (and (real? z) (>= z 0))
(real-fns-log z)
(make-rectangular (real-fns-log (magnitude z)) (angle z))))
(define (sin z)
"sine function"
(if (real? z)
(real-fns-sin z)
(/ (- (exp (* z 0+1i))
(exp (* z 0-1i)))
0+2i)))
(define (cos z)
"cosine function"
(if (real? z)
(real-fns-cos z)
(/ (+ (exp (* z 0+1i))
(exp (* z 0-1i)))
2)))
(define (tan z)
"tangent function"
(if (real? z)
(real-fns-tan z)
(/ (sin z) (cos z))))
(define (asin z)
"arc-sine"
(* 0-1i
(log (+ (* 0+1i z)
(sqrt (- 1 (* z z)))))))
(define (acos z)
"arc-cosine"
(* 0-1i
(log (+ (* 0+1i z)
(* 0+1i (sqrt (- 1 (* z z))))))))
(define (atan z . d)
"arc-tangent (one or two arguments)"
(if (null? d)
(if (real? z)
(real-fns-atan z)
(* 0-1i
(log (* (+ 1 (* 0+1i z))
(sqrt (/ 1 (+ 1 (* z z))))))))
(if (null? (cdr d))
(real-fns-atan z (car d))
(error 'atan d "too many arguments"))))
(define (sqrt z)
"square root"
(let ((root (if (real? z) (real-fns-sqrt z) (exp (/ (log z) 2)))))
(if (exact? z)
(let ((r (inexact->exact root)))
(if (= z (* r r))
r
root))
root)))
(define (expt base exponent)
"exponentiation"
(define (integer-expt base exponent)
"exponentiation for non-negative integer exponent"
(if (positive? exponent)
(if (odd? exponent)
(* base (integer-expt base (- exponent 1)))
(let ((b (integer-expt base (quotient exponent 2))))
(* b b)))
(if (zero? exponent)
1
(error 'integer-expt exponent "not a non-negative integer"))))
(if (zero? exponent)
(+ 1 exponent) ; add to one to propagate exactness
(if (integer? exponent)
(if (positive? exponent)
(integer-expt base exponent)
(/ 1 (integer-expt base (- 0 exponent))))
(if (and (real? exponent)
(real? base))
(real-fns-expt base exponent)
(exp (* exponent (log base)))))))
(define magnitude abs)
(define (angle z)
"argument of a complex number"
(if (and (real? z)
(not (negative? z)))
0
(real-fns-atan (imag-part z) (real-part z))))