src/scheme-library-4-numbers.scm

   1 ;; NUMBERS
   2
   3 ; Rational primitives
   4
   5 (define (numerator x)
   6   (if (ratnum? x)
   7     (rat:numerator x)
   8     x))
   9
  10 (define (denominator x)
  11   (if (ratnum? x)
  12     (rat:denominator x)
  13     (if (fixnum? x)
  14       1
  15       1.0)))
  16
  17 (define (rat:+ x y)
  18   (make-rational (fix:+ (fix:* (numerator x) (denominator y))
  19                         (fix:* (denominator x) (numerator y)))
  20                  (fix:* (denominator x) (denominator y))))
  21
  22 (define (rat:- x y)
  23   (make-rational (fix:- (fix:* (numerator x) (denominator y))
  24                         (fix:* (denominator x) (numerator y)))
  25                  (fix:* (denominator x) (denominator y))))
  26
  27 (define (rat:* x y)
  28   (make-rational (fix:* (numerator x) (numerator y))
  29                  (fix:* (denominator x) (denominator y))))
  30
  31 (define (rat:/ x y)
  32   (make-rational (fix:* (numerator x) (denominator y))
  33                  (fix:* (denominator x) (numerator y))))
  34
  35 (define (rat:1/ x)
  36   (make-rational (denominator x) (numerator x)))
  37
  38 ; Type dispatch and promotion
  39
  40 (define (type-dispatch ops x)
  41   (if (flonum? x)
  42     ((cdr ops) x)
  43     ((car ops) x)))
  44
  45 (define (promote-dispatch ops x y)
  46   (if (flonum? x)
  47     (if (flonum? y)
  48       ((cdr ops) x y)
  49       ((cdr ops) x (fixnum->flonum y)))
  50     (if (flonum? y)
  51       ((cdr ops) (fixnum->flonum x) y)
  52       ((car ops) x y))))
  53
  54 ; Unary ops
  55
  56 (define (neg x)
  57   (type-dispatch (cons fix:neg flo:neg) x))
  58
  59 (define (abs x)
  60   (type-dispatch (cons fix:abs flo:abs) x))
  61
  62 (define (flo:1+ x) (flo:+ x 1.0))
  63 (define (flo:1- x) (flo:- x 1.0))
  64
  65 (define (1+ n)
  66   (type-dispatch (cons fix:1+ flo:1+) n))
  67
  68 (define (1- n)
  69   (type-dispatch (cons fix:1- flo:1-) n))
  70
  71 (define (apply-to-flonum op x)
  72   (if (flonum? x) (op x) x))
  73
  74 (define (round x)
  75   (apply-to-flonum flo:round x))
  76 (define (floor x)
  77   (apply-to-flonum flo:floor x))
  78 (define (ceiling x)
  79   (apply-to-flonum flo:ceiling x))
  80 (define (truncate x)
  81   (apply-to-flonum flo:truncate x))
  82
  83 ; Binary operations
  84
  85 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
  86   (if (fix:= 0 (fix:remainder x y))
  87     (fix:quotient x y)
  88     (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
  89
  90 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
  91 (define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
  92 (define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
  93 (define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
  94
  95 (define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
  96 (define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
  97 (define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
  98 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
  99 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
 100
 101 (define (null? arg)
 102   (eq? arg '()))
 103
 104 (define (+ . args)
 105   (fold-left pair+ 0 args))
 106
 107 (define (- first . rest)
 108   (if (null? rest)
 109     (neg first)
 110     (pair- first (apply + rest))))
 111
 112 (define (* . args)
 113   (fold-left pair* 1 args))
 114
 115 (define (/ first . rest)
 116   (if (null? rest)
 117     (pair/ 1 first)
 118     (pair/ first (apply * rest))))
 119
 120 (define (quotient n1 n2)
 121   (fix:quotient n1 n2))
 122
 123 (define (remainder n1 n2)
 124   (fix:remainder n1 n2))
 125
 126 (define modulo remainder)
 127
 128 ; Relations
 129
 130 (define (test-relation rel l)
 131   (if (null? l)
 132     #t
 133     (if (null? (cdr l))
 134       #t
 135       (if (rel (car l) (car (cdr l)))
 136         (test-relation rel (cdr l))
 137         #f))))
 138
 139 (define (= . args)
 140   (test-relation pair= args))
 141
 142 (define (> . args)
 143   (test-relation pair> args))
 144
 145 (define (< . args)
 146   (test-relation pair< args))
 147
 148 (define (>= . args)
 149   (test-relation pair>= args))
 150
 151 (define (<= . args)
 152   (test-relation pair<= args))
 153
 154 ; Numeric tests
 155
 156 (define (zero? x) (pair= x 0.0))
 157 (define (positive x) (pair> x 0.0))
 158 (define (odd? n) (pair= (remainder n 2) 0))
 159 (define (odd? n) (not (pair= (remainder n 2) 0)))
 160
 161
 162 ; Current state of the numerical tower
 163 (define (complex? x) #f)
 164 (define (real? x) #t)
 165 (define (rational? x) #t)
 166 (define (integer? x) (= x (round x)))
 167 (define (exact? x) (fixnum? x))
 168 (define (inexact? x) (flonum? x))
 169 (define (number? x)
 170   (if (fixnum? x) #t
 171     (if (flonum? x) #t
 172       (if (ratnum? x) #t #f))))
 173