home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / 6001 / arith.scm < prev    next >
Text File  |  1999-01-02  |  11KB  |  400 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: arith.scm,v 1.6 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Scheme Arithmetic for 6.001
  23. ;;; package: (student number)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-integrable (int:->flonum n)
  28.   ((ucode-primitive integer->flonum 2) n #b10))
  29.  
  30. (define-integrable (flonum? object)
  31.   (object-type? (ucode-type big-flonum) object))
  32.  
  33. (declare (integrate flo:integer?))
  34. (define (flo:integer? x)
  35.   (flo:= x (flo:round x)))
  36.  
  37. (define (flo:->integer x)
  38.   (if (not (flo:integer? x))
  39.       (error:wrong-type-argument x "integer" 'FLONUM->INTEGER))
  40.   (flo:truncate->exact x))
  41.  
  42. (define-integrable (guarantee-integer object procedure)
  43.   (if (not (int:integer? object))
  44.       (error:wrong-type-argument object "number" procedure)))
  45.  
  46. (let-syntax
  47.     ((define-standard-unary
  48.        (macro (name flo:op int:op)
  49.      `(DEFINE (,name X)
  50.         (IF (FLONUM? X)
  51.         (,flo:op X)
  52.         (,int:op X))))))
  53.   (define-standard-unary rational? (lambda (x) x true) int:integer?)
  54.   (define-standard-unary integer? flo:integer? int:integer?)
  55.   (define-standard-unary exact? (lambda (x) x false)
  56.     (lambda (x)
  57.       (guarantee-integer x 'EXACT?)
  58.       true))
  59.   (define-standard-unary zero? flo:zero? int:zero?)
  60.   (define-standard-unary negative? flo:negative? int:negative?)
  61.   (define-standard-unary positive? flo:positive? int:positive?)
  62.   (define-standard-unary abs flo:abs int:abs)
  63.   (define-standard-unary floor flo:floor (lambda (x) x))
  64.   (define-standard-unary ceiling flo:ceiling (lambda (x) x))
  65.   (define-standard-unary truncate flo:truncate (lambda (x) x))
  66.   (define-standard-unary round flo:round (lambda (x) x))
  67.   (define-standard-unary exact->inexact (lambda (x) x) int:->flonum)
  68.   (define-standard-unary inexact->exact
  69.     (lambda (x)
  70.       (if (not (flo:integer? x))
  71.       (error:bad-range-argument x 'INEXACT->EXACT))
  72.       (flo:truncate->exact x))
  73.     (lambda (x)
  74.       (guarantee-integer x 'INEXACT->EXACT)
  75.       x)))
  76.  
  77. (let-syntax
  78.     ((define-standard-binary
  79.        (macro (name flo:op int:op)
  80.      `(DEFINE (,name X Y)
  81.         (IF (FLONUM? X)
  82.         (IF (FLONUM? Y)
  83.             (,flo:op X Y)
  84.             (,flo:op X (INT:->FLONUM Y)))
  85.         (IF (FLONUM? Y)
  86.             (,flo:op (INT:->FLONUM X) Y)
  87.             (,int:op X Y)))))))
  88.   (define-standard-binary real:+ flo:+ int:+)
  89.   (define-standard-binary real:- flo:- int:-)
  90.   (define-standard-binary rationalize
  91.     flo:rationalize
  92.     int:rationalize))
  93.  
  94. (define (int:rationalize q e)
  95.   (int:simplest-rational (int:- q e) (int:+ q e)))
  96.  
  97. (define (int:simplest-rational x y)
  98.   (let ((x<y
  99.      (lambda (x y)
  100.        (cond ((int:positive? x) x)
  101.          ((int:negative? y) y)
  102.          (else 0)))))
  103.     (cond ((int:< x y) (x<y x y))
  104.       ((int:< y x) (x<y y x))
  105.       (else x))))
  106.  
  107. (define (real:* x y)
  108.   (cond ((flonum? x)
  109.      (cond ((flonum? y) (flo:* x y))
  110.            ((int:zero? y) y)
  111.            (else (flo:* x (int:->flonum y)))))
  112.     ((int:zero? x) x)
  113.     ((flonum? y) (flo:* (int:->flonum x) y))
  114.     (else (int:* x y))))
  115.  
  116. (define (real:/ x y)
  117.   (cond ((flonum? x) (flo:/ x (if (flonum? y) y (int:->flonum y))))
  118.     ((flonum? y) (if (int:zero? x) x (flo:/ (int:->flonum x) y)))
  119.     ((int:= (int:remainder x y) 0) (int:quotient x y))
  120.     (else (flo:/ (int:->flonum x) (int:->flonum y)))))
  121.  
  122. (define (real:invert x)
  123.   (cond ((flonum? x) (flo:/ 1. x))
  124.     ((int:= 1 x) x)
  125.     (else (flo:/ 1. (int:->flonum x)))))
  126.  
  127. (define (real:= x y)
  128.   (if (flonum? x)
  129.       (if (flonum? y)
  130.       (flo:= x y)
  131.       (begin
  132.         (guarantee-integer y '=)
  133.         (and (flo:= x (flo:truncate x))
  134.          (int:= (flo:truncate->exact x) y))))
  135.       (if (flonum? y)
  136.       (begin
  137.         (guarantee-integer x '=)
  138.         (and (flo:= y (flo:truncate y))
  139.          (int:= x (flo:truncate->exact y))))
  140.       (int:= x y))))
  141.  
  142. (define (real:< x y)
  143.   (if (flonum? x)
  144.       (if (flonum? y)
  145.       (flo:< x y)
  146.       (flo/int:< x y))
  147.       (if (flonum? y)
  148.       (int/flo:< x y)
  149.       (int:< x y))))
  150.  
  151. (define (real:max x y)
  152.   (if (flonum? x)
  153.       (if (flonum? y)
  154.       (if (flo:< x y) y x)
  155.       (if (flo/int:< x y) (int:->flonum y) x))
  156.       (if (flonum? y)
  157.       (if (int/flo:< x y) y (int:->flonum x))
  158.       (if (int:< x y) y x))))
  159.  
  160. (define (real:min x y)
  161.   (if (flonum? x)
  162.       (if (flonum? y)
  163.       (if (flo:< x y) x y)
  164.       (if (flo/int:< x y) x (int:->flonum y)))
  165.       (if (flonum? y)
  166.       (if (int/flo:< x y) (int:->flonum x) y)
  167.       (if (int:< x y) x y))))
  168.  
  169. (define-integrable (flo/int:< x y)
  170.   (let ((ix (flo:truncate->exact x)))
  171.     (cond ((int:< ix y) true)
  172.       ((int:< y ix) false)
  173.       (else (flo:< x (flo:truncate x))))))
  174.  
  175. (define-integrable (int/flo:< x y)
  176.   (let ((iy (flo:truncate->exact y)))
  177.     (cond ((int:< x iy) true)
  178.       ((int:< iy x) false)
  179.       (else (flo:< (flo:truncate y) y)))))
  180.  
  181. (define (even? n)
  182.   (int:even? (if (flonum? n) (flo:->integer n) n)))
  183.  
  184. (let-syntax
  185.     ((define-integer-binary
  186.        (macro (name operator)
  187.      `(DEFINE (,name N M)
  188.         (IF (FLONUM? N)
  189.         (INT:->FLONUM
  190.          (,operator (FLO:->INTEGER N)
  191.                 (IF (FLONUM? M) (FLO:->INTEGER M) M)))
  192.         (IF (FLONUM? M)
  193.             (INT:->FLONUM (,operator N (FLO:->INTEGER M)))
  194.             (,operator N M)))))))
  195.   (define-integer-binary quotient int:quotient)
  196.   (define-integer-binary remainder int:remainder)
  197.   (define-integer-binary modulo int:modulo)
  198.   (define-integer-binary real:gcd int:gcd)
  199.   (define-integer-binary real:lcm int:lcm))
  200.  
  201. (define (numerator q)
  202.   (if (flonum? q)
  203.       (int:->flonum (rat:numerator (flo:->rational q)))
  204.       (begin
  205.     (guarantee-integer q 'NUMERATOR)
  206.     q)))
  207.  
  208. (define (denominator q)
  209.   (if (flonum? q)
  210.       (int:->flonum (rat:denominator (flo:->rational q)))
  211.       (begin
  212.     (guarantee-integer q 'DENOMINATOR)
  213.     1)))
  214.  
  215. (let-syntax
  216.     ((define-transcendental-unary
  217.        (macro (name hole? hole-value function)
  218.      `(DEFINE (,name X)
  219.         (IF (,hole? X)
  220.         ,hole-value
  221.         (,function (REAL:->FLONUM X)))))))
  222.   (define-transcendental-unary exp real:exact0= 1 flo:exp)
  223.   (define-transcendental-unary log real:exact1= 0 flo:log)
  224.   (define-transcendental-unary sin real:exact0= 0 flo:sin)
  225.   (define-transcendental-unary cos real:exact0= 1 flo:cos)
  226.   (define-transcendental-unary tan real:exact0= 0 flo:tan)
  227.   (define-transcendental-unary asin real:exact0= 0 flo:asin)
  228.   (define-transcendental-unary acos real:exact1= 0 flo:acos)
  229.   (define-transcendental-unary real:atan real:exact0= 0 flo:atan))
  230.  
  231. (define (real:atan2 y x)
  232.   (if (and (real:exact0= y) (exact? x))
  233.       0
  234.       (flo:atan2 (real:->flonum y) (real:->flonum x))))
  235.  
  236. (define-integrable (real:exact0= x)
  237.   (if (flonum? x) false (int:zero? x)))
  238.  
  239. (define-integrable (real:exact1= x)
  240.   (if (flonum? x) false (int:= 1 x)))
  241.  
  242. (define (real:->flonum x)
  243.   (if (flonum? x)
  244.       x
  245.       (int:->flonum x)))
  246.  
  247. (define (sqrt x)
  248.   (if (flonum? x)
  249.       (begin
  250.     (if (flo:negative? x)
  251.         (error:bad-range-argument x 'SQRT))
  252.     (flo:sqrt x))
  253.       (int:sqrt x)))
  254.  
  255. (define (int:sqrt x)
  256.   (if (int:negative? x)
  257.       (error:bad-range-argument x 'SQRT))
  258.   (let ((guess (flo:sqrt (int:->flonum x))))
  259.     (let ((n (flo:round->exact guess)))
  260.       (if (int:= x (int:* n n))
  261.       n
  262.       guess))))
  263.  
  264. (define (expt x y)
  265.   (let ((general-case
  266.      (lambda (x y)
  267.        (cond ((flo:zero? y) 1.)
  268.          ((flo:zero? x)
  269.           (if (not (flo:positive? y))
  270.               (error:divide-by-zero 'EXPT (list x y)))
  271.           x)
  272.          (else
  273.           (if (and (flo:negative? x)
  274.                (not (flo:integer? y)))
  275.               (error:bad-range-argument x 'EXPT))
  276.           (flo:expt x y))))))
  277.     (if (flonum? x)
  278.     (if (flonum? y)
  279.         (general-case x y)
  280.         (let ((exact-method
  281.            (lambda (y)
  282.              (if (int:= 1 y)
  283.              x
  284.              (let loop ((x x) (y y) (answer 1.))
  285.                (let ((qr (int:divide y 2)))
  286.                  (let ((x (flo:* x x))
  287.                    (y (integer-divide-quotient qr))
  288.                    (answer
  289.                     (if (int:zero?
  290.                      (integer-divide-remainder qr))
  291.                     answer
  292.                     (flo:* answer x))))
  293.                    (if (int:= 1 y)
  294.                    (flo:* answer x)
  295.                    (loop x y answer)))))))))
  296.           (cond ((int:positive? y) (exact-method y))
  297.             ((int:negative? y)
  298.              (flo:/ 1. (exact-method (int:negate y))))
  299.             (else 1.))))
  300.     (if (flonum? y)
  301.         (general-case (int:->flonum x) y)
  302.         (if (int:negative? y)
  303.         (real:invert (int:expt x (int:negate y)))
  304.         (int:expt x y))))))
  305.  
  306. (define number? rational?)
  307. (define complex? rational?)
  308. (define real? rational?)
  309.  
  310. (define (inexact? z)
  311.   (not (exact? z)))
  312.  
  313. (define (odd? n)
  314.   (not (even? n)))
  315.  
  316. (define (inc z)
  317.   (+ z 1))
  318.  
  319. (define (dec z)
  320.   (- z 1))
  321.  
  322. (define (= . zs)
  323.   (reduce-comparator real:= zs '=))
  324.  
  325. (define (< . xs)
  326.   (reduce-comparator real:< xs '<))
  327.  
  328. (define (> . xs)
  329.   (reduce-comparator (lambda (x y) (real:< y x)) xs '>))
  330.  
  331. (define (<= . xs)
  332.   (reduce-comparator (lambda (x y) (not (real:< y x))) xs '<=))
  333.  
  334. (define (>= . xs)
  335.   (reduce-comparator (lambda (x y) (not (real:< x y))) xs '>=))
  336.  
  337. (define (max x . xs)
  338.   (reduce-max/min real:max x xs 'MAX))
  339.  
  340. (define (min x . xs)
  341.   (reduce-max/min real:min x xs 'MIN))
  342.  
  343. (define (+ . zs)
  344.   (cond ((null? zs)
  345.      0)
  346.     ((null? (cdr zs))
  347.      (if (not (number? (car zs)))
  348.          (error:wrong-type-argument (car zs) false '+))
  349.      (car zs))
  350.     ((null? (cddr zs))
  351.      (real:+ (car zs) (cadr zs)))
  352.     (else
  353.      (real:+ (car zs)
  354.          (real:+ (cadr zs)
  355.              (reduce real:+ 0 (cddr zs)))))))
  356.  
  357. (define (* . zs)
  358.   (cond ((null? zs)
  359.      1)
  360.     ((null? (cdr zs))
  361.      (if (not (number? (car zs)))
  362.          (error:wrong-type-argument (car zs) false '*))
  363.      (car zs))
  364.     ((null? (cddr zs))
  365.      (real:* (car zs) (cadr zs)))
  366.     (else
  367.      (real:* (car zs)
  368.          (real:* (cadr zs)
  369.              (reduce real:* 1 (cddr zs)))))))
  370.  
  371. (define (- z1 . zs)
  372.   (cond ((null? zs)
  373.      (if (flonum? z1) (flo:negate z1) (int:negate z1)))
  374.     ((null? (cdr zs))
  375.      (real:- z1 (car zs)))
  376.     (else
  377.      (real:- z1
  378.          (real:+ (car zs)
  379.              (real:+ (cadr zs)
  380.                  (reduce real:+ 0 (cddr zs))))))))
  381.  
  382. (define (/ z1 . zs)
  383.   (cond ((null? zs)
  384.      (real:invert z1))
  385.     ((null? (cdr zs))
  386.      (real:/ z1 (car zs)))
  387.     (else
  388.      (real:/ z1
  389.          (real:* (car zs)
  390.              (real:* (cadr zs)
  391.                  (reduce real:* 1 (cddr zs))))))))
  392.  
  393. (define (gcd . integers)
  394.   (reduce real:gcd 0 integers))
  395.  
  396. (define (lcm . integers)
  397.   (reduce real:lcm 1 integers))
  398.  
  399. (define (atan z #!optional x)
  400.   (if (default-object? x) (real:atan z) (real:atan2 z x)))