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 / runtime / numint.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  290 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: numint.scm,v 1.6 1999/01/02 06:11:34 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 Interface
  23. ;;; package: (runtime number interface)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;(define (make-=-operator =)
  28. ;;  (lambda zs
  29. ;;    (reduce-comparator = zs 'make-=-operator)))
  30.  
  31. (define (make-=-operator =)
  32.   (make-arity-dispatched-procedure
  33.    (lambda (self . zs)
  34.      self                ; ignored
  35.      (reduce-comparator = zs 'make-=-operator))
  36.    (lambda () #T)
  37.    (lambda (z) z #T)
  38.    (lambda (z1 z2) (= z1 z2))))
  39.  
  40. ;;(define (make-<-operator <)
  41. ;;  (lambda zs
  42. ;;    (reduce-comparator < zs 'make-<-operator)))
  43.  
  44. (define (make-comparison-operator comparator name)
  45.   (make-arity-dispatched-procedure
  46.    (lambda (self . zs)
  47.      self                ; ignored
  48.      (reduce-comparator comparator zs name))
  49.    (lambda () #T)
  50.    (lambda (z) z #T)
  51.    comparator))
  52.  
  53. (define (make-<-operator <)
  54.   (make-comparison-operator < 'make-<-operator))
  55.  
  56. (define (make->-operator <)
  57.   (make-comparison-operator (lambda (x y) (< y x)) 'make->-operator))
  58.  
  59. (define (make-<=-operator <)
  60.   (make-comparison-operator (lambda (x y) (not (< y x))) 'make-<=-operator))
  61.   
  62. (define (make->=-operator <)
  63.   (make-comparison-operator (lambda (x y) (not (< x y))) 'make->=-operator))
  64.  
  65. ;;(define (make-max/min-operator max/min)
  66. ;;  (lambda (x . xs)
  67. ;;    (reduce-max/min max/min x xs 'make-max/min-operator)))
  68.  
  69. (define (make-max/min-operator max/min)
  70.   (make-arity-dispatched-procedure
  71.    (lambda (self x . xs)
  72.      self                ;ignored
  73.      (reduce-max/min max/min x xs 'make-max/min-operator))
  74.    #F
  75.    (lambda (x) x)
  76.    max/min))
  77.  
  78. ;;(define (make-atan-operator atan1 atan2)
  79. ;;  (lambda (z . xs)
  80. ;;    (if (null? xs)
  81. ;;    (atan1 z)
  82. ;;    (atan2 z (car xs)))))
  83.  
  84. (define (make-atan-operator atan1 atan2)
  85.   (make-arity-dispatched-procedure
  86.    (lambda (self z1 #!optional z2)    ; required for arity
  87.      (error "ATAN operator: should never get to this case" self z1 z2))
  88.    #F
  89.    atan1
  90.    atan2))
  91.  
  92. ;;(define (make-accumulation-operator op identity)
  93. ;;  (lambda zs (reduce op identity zs)))
  94. ;;
  95. ;;(define (make-inverse-accumulation-operator
  96. ;;     accumulate-op identity unary-invert-op binary-invert-op)
  97. ;;  (lambda (z1 . zs)
  98. ;;    (if (null? zs)
  99. ;;    (unary-invert-op z1)
  100. ;;    (binary-invert-op z1
  101. ;;              (reduce accumulate-op identity zs)))))
  102.  
  103. (define (make-accumulation-operator op identity)
  104.   (make-arity-dispatched-procedure
  105.    (lambda (self . zs)
  106.      self                ; ignored
  107.      (reduce op identity zs))
  108.    (lambda () identity)
  109.    (lambda (z) z)
  110.    op))
  111.  
  112. (define (make-inverse-accumulation-operator
  113.      accumulate-op identity unary-invert-op binary-invert-op)
  114.   (make-arity-dispatched-procedure
  115.    (lambda (self z1 . zs)
  116.      self                ; ignored
  117.      (binary-invert-op z1
  118.                (reduce accumulate-op identity zs)))
  119.    #F                    ; no nullary case
  120.    unary-invert-op
  121.    binary-invert-op))
  122.  
  123.  
  124. (define (make-arithmetic-package package-name . operations) 
  125.   (lambda (m . opt)
  126.     (cond ((eq? m 'bound-names) (map car operations))
  127.       ((eq? m 'package-name) package-name)
  128.       (else
  129.        (let ((entry (assq m operations)))
  130.          (if entry
  131.          (cadr entry)
  132.          (if (not (null? opt))
  133.              (car opt)
  134.              (error "Object not available" package-name m))))))))
  135.  
  136. (define integer-package
  137.   (make-arithmetic-package
  138.    'integer-package
  139.    `(zero 0)
  140.    `(one 1)
  141.    `(integer? ,int:integer?)
  142.    `(characteristic-predicate ,int:integer?)
  143.    `(= ,(make-=-operator int:=))
  144.    `(< ,(make-<-operator int:<))
  145.    `(> ,(make->-operator int:<))
  146.    `(<= ,(make-<=-operator int:<))
  147.    `(>= ,(make->=-operator int:<))
  148.    `(zero? ,int:zero?)
  149.    `(positive? ,int:positive?)
  150.    `(negative? ,int:negative?)
  151.    `(even? ,int:even?)
  152.    `(odd? ,(lambda (n) (not (int:even? n))))
  153.    `(max ,(make-max/min-operator int:max))
  154.    `(min ,(make-max/min-operator int:min))
  155.    `(+ ,(make-accumulation-operator int:+ 0))
  156.    `(1+ ,int:1+)
  157.    `(-1+ ,int:-1+)
  158.    `(- ,(make-inverse-accumulation-operator int:+ 0 int:negate int:-))
  159.    `(* ,(make-accumulation-operator int:* 1))
  160.    `(negate ,int:negate)
  161.    `(abs ,int:abs)
  162.    `(expt ,int:expt)
  163.    `(quotient ,int:quotient)
  164.    `(remainder ,int:remainder)
  165.    `(modulo ,int:modulo)
  166.    `(integer-divide ,int:divide)
  167.    `(gcd ,(make-accumulation-operator int:gcd 0))
  168.    `(lcm ,(make-accumulation-operator int:lcm 1))
  169.    ))
  170.  
  171. (define rational-package
  172.   (make-arithmetic-package
  173.    'rational-package
  174.    `(zero 0)
  175.    `(one 1)
  176.    `(integer? ,rat:integer?)
  177.    `(rational? ,rat:rational?)
  178.    `(characteristic-predicate ,rat:rational?)
  179.    `(= ,(make-=-operator rat:=))
  180.    `(< ,(make-<-operator rat:<))
  181.    `(> ,(make->-operator rat:<))
  182.    `(<= ,(make-<=-operator rat:<))
  183.    `(>= ,(make->=-operator rat:<))
  184.    `(zero? ,rat:zero?)
  185.    `(one? ,(lambda (p) (rat:= p 1)))
  186.    `(positive? ,rat:positive?)
  187.    `(negative? rat:negative?)
  188.    `(max ,(make-max/min-operator rat:max))
  189.    `(min ,(make-max/min-operator rat:min))
  190.    `(1+ ,rat:1+)
  191.    `(-1+ ,rat:-1+)
  192.    `(+ ,(make-accumulation-operator rat:+ 0))
  193.    `(- ,(make-inverse-accumulation-operator rat:+ 0 rat:negate rat:-))
  194.    `(* ,(make-accumulation-operator rat:* 1))
  195.    `(/ ,(make-inverse-accumulation-operator rat:* 1 rat:invert rat:/))
  196.    `(negate ,rat:negate)
  197.    `(invert ,rat:invert)
  198.    `(abs ,rat:abs)
  199.    `(expt ,rat:expt)
  200.    `(make-rational ,make-rational)
  201.    `(numerator ,rat:numerator)
  202.    `(denominator ,rat:denominator)
  203.    ))
  204.  
  205. (define real-package
  206.   (make-arithmetic-package
  207.    'real-package
  208.    `(zero 0)
  209.    `(one 1)
  210.    `(integer? ,real:integer?)
  211.    `(rational? ,real:rational?)
  212.    `(real? ,real:real?)
  213.    `(characteristic-predicate ,real:real?)
  214.    `(= ,(make-=-operator real:=))
  215.    `(< ,(make-<-operator real:<))
  216.    `(> ,(make->-operator real:<))
  217.    `(<= ,(make-<=-operator real:<))
  218.    `(>= ,(make->=-operator real:<))
  219.    `(zero? ,real:zero?)
  220.    `(positive? ,real:positive?)
  221.    `(negative? ,real:negative?)
  222.    `(max ,(make-max/min-operator real:max))
  223.    `(min ,(make-max/min-operator real:min))
  224.    `(1+ ,real:1+)
  225.    `(-1+ ,real:-1+)
  226.    `(+ ,(make-accumulation-operator real:+ 0))
  227.    `(- ,(make-inverse-accumulation-operator real:+ 0 real:negate real:-))
  228.    `(* ,(make-accumulation-operator real:* 1))
  229.    `(/ ,(make-inverse-accumulation-operator real:* 1 real:invert real:/))
  230.    `(negate ,real:negate)
  231.    `(invert ,real:invert)
  232.    `(abs ,real:abs)
  233.    `(exp ,real:exp)
  234.    `(log ,real:log)
  235.    `(sin ,real:sin)
  236.    `(cos ,real:cos)
  237.    `(tan ,real:tan)
  238.    `(asin ,real:asin)
  239.    `(acos ,real:acos)
  240.    `(atan ,(make-atan-operator real:atan real:atan2))
  241.    `(sqrt ,real:sqrt)
  242.    `(expt ,real:expt)
  243.    ))
  244.  
  245. (define complex-package
  246.   (make-arithmetic-package
  247.    'complex-package
  248.    `(zero 0)
  249.    `(one 1)
  250.    `(imag-unit ,+i)
  251.    `(integer? ,complex:integer?)
  252.    `(rational? ,complex:rational?)
  253.    `(real? ,complex:real?)
  254.    `(complex? ,complex:complex?)
  255.    `(characteristic-predicate ,complex:complex?)
  256.    `(= ,(make-=-operator complex:=))
  257.    `(zero? ,complex:zero?)
  258.    `(1+ ,complex:1+)
  259.    `(-1+ ,complex:-1+)
  260.    `(+ ,(make-accumulation-operator complex:+ 0))
  261.    `(- ,(make-inverse-accumulation-operator complex:+
  262.                         0
  263.                         complex:negate
  264.                         complex:-))
  265.    `(* ,(make-accumulation-operator complex:* 1))
  266.    `(/ ,(make-inverse-accumulation-operator complex:*
  267.                         1
  268.                         complex:invert
  269.                         complex:/))
  270.    `(negate ,complex:negate)
  271.    `(invert ,complex:invert)
  272.    `(abs ,complex:abs)
  273.    `(exp ,complex:exp)
  274.    `(log ,complex:log)
  275.    `(sin ,complex:sin)
  276.    `(cos ,complex:cos)
  277.    `(tan ,complex:tan)
  278.    `(asin ,complex:asin)
  279.    `(acos ,complex:acos)
  280.    `(atan ,(make-atan-operator complex:atan complex:atan2))
  281.    `(sqrt ,complex:sqrt)
  282.    `(expt ,complex:expt)
  283.    `(make-rectangular ,complex:make-rectangular)
  284.    `(make-polar ,complex:make-polar)
  285.    `(real-part ,complex:real-part)
  286.    `(imag-part ,complex:imag-part)
  287.    `(magnitude ,complex:magnitude)
  288.    `(angle ,complex:angle)
  289.    `(conjugate ,complex:conjugate)
  290.    ))