home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / xlisp / xmath.arc / XMATH.LSP < prev   
Text File  |  1988-06-29  |  5KB  |  138 lines
  1. ;                     XLISP Math Library
  2. ;                            by
  3. ;                      George V. Wilson
  4. ;                         June 1988
  5.  
  6.  
  7. ;For instructions see MATH.DOC.
  8. ;Do not load the math library twice. It will destroy the math functions.
  9. ;When *math_lib_loaded* is bound, the following if will prevent reloading.
  10.  
  11. (if (boundp '*math_lib_loaded*)
  12.     (print "Math.lsp already loaded")
  13.     (progn
  14.        ;---------------------------------------------------------------
  15.  
  16.        ;predefined constant in Common LISP
  17.        (setq pi 3.1415926536)
  18.  
  19.        ;----------------------------------------------------------------
  20.        ;The following block of definitions is to take care of a minor
  21.        ;incompatibility with Common LISP. These functions are supposed to
  22.        ;accept any number as an arguement. Unfortunately, they don't work
  23.        ;correctly when given integers as arguements (instead of floats).
  24.        ;This group saves the old function,floats the arguement and calls
  25.        ;the (saved) old function.
  26.  
  27.        (setf oldsquareroot #'sqrt)
  28.        (defun sqrt (x) (oldsquareroot (float x)))
  29.  
  30.        (setf oldsine #'sin)
  31.        (defun sin (x) (oldsine (float x)))
  32.  
  33.        (setf oldcosine #'cos)
  34.        (defun cos (x) (oldcosine (float x)))
  35.  
  36.        (setf oldtangent #'tan)
  37.        (defun tan (x) (oldtangent (float x)))
  38.  
  39.        (setf oldexp #'exp)
  40.        (defun exp (x) (oldexp (float x)))
  41.  
  42.  
  43.        (setf oldexpt #'expt)
  44.        (defun expt (x y)
  45.           (cond ((zerop x) 0)
  46.                 ((= x 1) 1)
  47.                 ((integerp y)
  48.                     (do ((i 0 (1+ i)) (pow 1 (* pow x)))
  49.                         ((<= (abs y) i)
  50.                            (if (minusp y) (/ 1.0 pow) pow))))
  51.                 (T (oldexpt (float x) y))))
  52. ;--------------------------------------------------------------------------
  53.        ;This next block supplies some Common LISP functions
  54.        ;that are missing in XLISP.
  55.  
  56.        (defun signum (x)
  57.           (cond ((not (numberp x))
  58.                    (error "arguement to signum not a number " x))
  59.                 ((zerop x) x)
  60.                 (T (truncate (* 1.1 (/ x (abs x)))))))
  61.  
  62.        (defun round (x)
  63.           (if (numberp x)
  64.           (truncate (+ x (* (signum x) 0.5)))
  65.           (error "bad arguement type to round" x)))
  66.  
  67.        (defun atan (x &optional y &aux s)
  68.           (if (not (numberp x)) (error "bad arguement type to atan" x))
  69.           (if y (setq x (/ x y)))
  70.           (setq s (signum x))
  71.           (setq x (float (abs x)))
  72.           (cond ((< x .2679492)
  73.              (* s (* x (+ .60310579 (- (/ .55913709 (+ 1.4087812 (* x x)))
  74.                                        (* .05160454 (* x x)))))))
  75.              ((<= x 1) (* s (+ .523598776 (atan (/ (1- (* 1.73205081 x))
  76.                                                    (+ x 1.73205081))))))
  77.              (T (* s (- 1.570796327 (atan (/ 1 x)))))))
  78.  
  79.      (defun asin (x)
  80.        (cond ((> (abs x) 1) (error " arguement to asin out of range  " x))
  81.              ((= x 1) 1.570796327)
  82.              ((= x -1) -1.570796327)
  83.              (T (atan (/ x (sqrt (- 1 (* x x))))))))
  84.  
  85.      (defun acos (x)
  86.        (cond ((> (abs x) 1) (error "arguement to acos out of range  " x))
  87.              ((zerop x) 1.570796327)
  88.              ((plusp x) (atan (/ (sqrt (- 1 (* x x))) x)))
  89.              ((minusp x) (- 3.1415926536 (acos (abs x))))))))
  90.  
  91.        (defun log (x &optional y)
  92.           (let ((s 2.302585093) (m 0) coef z z2 (est 0))
  93.             (if (not (and (numberp x) (if y (numberp y) T)))
  94.                  (error "bad arguement type to log" (if y (list x y) x)))
  95.             (if (<= x 0) (error " argument to log <= 0" x)
  96.               (progn (setq coef '(0.191337714 0.094376476 0.177522071
  97.                                   0.289335524 0.868591718))
  98.                  (setq x (float x))
  99.                  (cond ((< x 0.316227766) (setq x (/ 1 x)) (setq s (- s))))
  100.                  (do () ((< x 3.16227766)) (setq x (/ x 10)) (setq m (1+ m)))
  101.                  (setq z (/ (1- x) (1+ x)))
  102.                  (setq z2 (* z z))
  103.                  (dolist (a coef) (setq est (+ a (* est z2))))
  104.                  (setq est (* s (+ m (* z est))))
  105.                  (if y (/ est (log y)) est)))))
  106.  
  107. (defun integerp (n) (eql (type-of n) ':FIXNUM))
  108.  
  109. (defun euclid_gcd (a b)         ;euclid_gcd is not CommonLISP
  110.    (do ((temp a (rem a b)))     ;it is used here to do the
  111.        ((= temp 0) b)           ;work for gcd
  112.        (setq a b)
  113.        (setq b temp)))
  114.  
  115. (defun gcd (&rest nums)
  116.   (if (do* ((args nums (cdr args))
  117.             (test (integerp (car nums)) (and test (integerp (car args)))))
  118.             ((null (cdr args)) (and test (car args))))
  119.       (if (cdr nums)
  120.           (euclid_gcd (car nums) (apply gcd (cdr nums)))
  121.           (car nums))
  122.       (error "arguments to gcd must be integers" nums)))
  123.  
  124. (defun lcm (&rest nums)
  125.    (if (cdr nums)
  126.        (let ((a (car nums)) (b (apply lcm (cdr nums))) temp)
  127.             (setq temp (gcd a b))
  128.             (if (integerp temp)
  129.                 (/ (* a b) temp)
  130.                 (error "arguements to lcm must be integers" nums)))
  131.        (car nums)))
  132.  
  133. (defmacro incf (var &optional delta)
  134.     `(setf ,var  (+ ,var (if ,delta ,delta 1))))
  135.  
  136. ;-------------------------------------------------------------------------
  137.  
  138. (setq *math_lib_loaded* T)       ;prevents loading library twice.