scsh-0.6/scheme/rts/recnum.scm

118 lines
3.5 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

; 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))))