scsh-0.6/scheme/rts/ratnum.scm

142 lines
3.7 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.
; This is file ratnum.scm.
; Rational arithmetic
; Assumes that +, -, etc. perform integer arithmetic.
(define-simple-type :exact-rational (:rational :exact)
(lambda (n) (and (rational? n) (exact? n))))
(define-extended-number-type :ratnum (:exact-rational :exact) ;?
(make-ratnum num den)
ratnum?
(num ratnum-numerator)
(den ratnum-denominator))
(define (integer/ m n)
(cond ((< n 0)
(integer/ (- 0 m) (- 0 n)))
((= n 0)
(error "rational division by zero" m))
((and (exact? m) (exact? n))
(let ((g (gcd m n)))
(let ((m (quotient m g))
(n (quotient n g)))
(if (= n 1)
m
(make-ratnum m n)))))
(else (/ m n)))) ;In case we get flonums
(define (rational-numerator p)
(if (ratnum? p)
(ratnum-numerator p)
(numerator p)))
(define (rational-denominator p)
(if (ratnum? p)
(ratnum-denominator p)
(denominator p)))
; a/b * c/d = a*c / b*d
(define (rational* p q)
(integer/ (* (rational-numerator p) (rational-numerator q))
(* (rational-denominator p) (rational-denominator q))))
; a/b / c/d = a*d / b*c
(define (rational/ p q)
(integer/ (* (rational-numerator p) (rational-denominator q))
(* (rational-denominator p) (rational-numerator q))))
; a/b + c/d = (a*d + b*c)/(b*d)
(define (rational+ p q)
(let ((b (rational-denominator p))
(d (rational-denominator q)))
(integer/ (+ (* (rational-numerator p) d)
(* b (rational-numerator q)))
(* b d))))
; a/b - c/d = (a*d - b*c)/(b*d)
(define (rational- p q)
(let ((b (rational-denominator p))
(d (rational-denominator q)))
(integer/ (- (* (rational-numerator p) d)
(* b (rational-numerator q)))
(* b d))))
; a/b < c/d when a*d < b*c
(define (rational< p q)
(< (* (rational-numerator p) (rational-denominator q))
(* (rational-denominator p) (rational-numerator q))))
; a/b = c/d when a = b and c = d (always lowest terms)
(define (rational= p q)
(and (= (rational-numerator p) (rational-numerator q))
(= (rational-denominator p) (rational-denominator q))))
; (rational-truncate p) = integer of largest magnitude <= (abs p)
(define (rational-truncate p)
(quotient (rational-numerator p) (rational-denominator p)))
; (floor p) = greatest integer <= p
(define (rational-floor p)
(let* ((n (numerator p))
(q (quotient n (denominator p))))
(if (>= n 0)
q
(- q 1))))
; Extend the generic number procedures
(define-method &rational? ((n :ratnum)) #t)
(define-method &numerator ((n :ratnum)) (ratnum-numerator n))
(define-method &denominator ((n :ratnum)) (ratnum-denominator n))
(define-method &exact? ((n :ratnum)) #t)
;(define-method &exact->inexact ((n :ratnum))
; (/ (exact->inexact (numerator n))
; (exact->inexact (denominator n))))
;(define-method &inexact->exact ((n :rational)) ;?
; (/ (inexact->exact (numerator n))
; (inexact->exact (denominator n))))
(define-method &/ ((m :exact-integer) (n :exact-integer))
(integer/ m n))
(define (define-ratnum-method mtable proc)
(define-method mtable ((m :ratnum) (n :exact-rational)) (proc m n))
(define-method mtable ((m :exact-rational) (n :ratnum)) (proc m n)))
(define-ratnum-method &+ rational+)
(define-ratnum-method &- rational-)
(define-ratnum-method &* rational*)
(define-ratnum-method &/ rational/)
(define-ratnum-method &= rational=)
(define-ratnum-method &< rational<)
(define-method &floor ((m :ratnum)) (rational-floor m))
;(define-method &sqrt ((p :ratnum))
; (if (< p 0)
; (next-method)
; (integer/ (sqrt (numerator p))
; (sqrt (denominator p)))))
(define-method &number->string ((p :ratnum) radix)
(string-append (number->string (ratnum-numerator p) radix)
"/"
(number->string (ratnum-denominator p) radix)))