scsh-0.6/scheme/rts/recnum.scm

118 lines
3.5 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Rectangular complex arithmetic built on real arithmetic.
(define-extended-number-type :recnum (:complex)
(make-recnum real imag)
recnum?
(real recnum-real-part)
(imag recnum-imag-part))
(define (rectangulate x y) ; Assumes (eq? (exact? x) (exact? y))
(if (= y 0)
x
(make-recnum x y)))
(define (rectangular-real-part z)
(if (recnum? z)
(recnum-real-part z)
(real-part z)))
(define (rectangular-imag-part z)
(if (recnum? z)
(recnum-imag-part z)
(imag-part z)))
(define (rectangular+ a b)
(rectangulate (+ (rectangular-real-part a) (rectangular-real-part b))
(+ (rectangular-imag-part a) (rectangular-imag-part b))))
(define (rectangular- a b)
(rectangulate (- (rectangular-real-part a) (rectangular-real-part b))
(- (rectangular-imag-part a) (rectangular-imag-part b))))
(define (rectangular* a b)
(let ((a1 (rectangular-real-part a))
(a2 (rectangular-imag-part a))
(b1 (rectangular-real-part b))
(b2 (rectangular-imag-part b)))
(rectangulate (- (* a1 b1) (* a2 b2))
(+ (* a1 b2) (* a2 b1)))))
(define (rectangular/ a b)
(let ((a1 (rectangular-real-part a))
(a2 (rectangular-imag-part a))
(b1 (rectangular-real-part b))
(b2 (rectangular-imag-part b)))
(let ((d (+ (* b1 b1) (* b2 b2))))
(rectangulate (/ (+ (* a1 b1) (* a2 b2)) d)
(/ (- (* a2 b1) (* a1 b2)) d)))))
(define (rectangular= a b)
(let ((a1 (rectangular-real-part a))
(a2 (rectangular-imag-part a))
(b1 (rectangular-real-part b))
(b2 (rectangular-imag-part b)))
(and (= a1 b1) (= a2 b2))))
; Methods
(define-method &complex? ((z :recnum)) #t)
(define-method &real-part ((z :recnum)) (recnum-real-part z))
(define-method &imag-part ((z :recnum)) (recnum-imag-part z))
; Methods on complexes in terms of real-part and imag-part
(define-method &exact? ((z :recnum))
(exact? (recnum-real-part z)))
(define-method &inexact->exact ((z :recnum))
(make-recnum (inexact->exact (recnum-real-part z))
(inexact->exact (recnum-imag-part z))))
(define-method &exact->inexact ((z :recnum))
(make-recnum (exact->inexact (recnum-real-part z))
(exact->inexact (recnum-imag-part z))))
(define (define-recnum-method mtable proc)
(define-method mtable ((m :recnum) (n :complex)) (proc m n))
(define-method mtable ((m :complex) (n :recnum)) (proc m n)))
(define-recnum-method &+ rectangular+)
(define-recnum-method &- rectangular-)
(define-recnum-method &* rectangular*)
(define-recnum-method &/ rectangular/)
(define-recnum-method &= rectangular=)
(define-method &sqrt ((n :real))
(if (< n 0)
(make-rectangular 0 (sqrt (- 0 n)))
(next-method))) ; not that we have to
; Gleep! Can we do quotient and remainder on Gaussian integers?
; Can we do numerator and denominator on complex rationals?
(define-method &number->string ((z :recnum) radix)
(let ((x (real-part z))
(y (imag-part z)))
(let ((r (number->string x radix))
(i (number->string (abs y) radix))
(& (if (< y 0) "-" "+")))
(if (and (inexact? y) ;gross
(char=? (string-ref i 0) #\#))
(string-append (if (char=? (string-ref r 0) #\#)
""
"#i")
r &
(substring i 2 (string-length i))
"i")
(string-append r & i "i")))))
(define-method &make-rectangular ((x :real) (y :real))
(if (eq? (exact? x) (exact? y))
(rectangulate x y)
(rectangulate (if (exact? x) (exact->inexact x) x)
(if (exact? y) (exact->inexact y) y))))