Power-Programmierung/CD1.mdf/lisp/interpre/xlispplu/xmath/xmath.lsp

Text File | 1988-06-29 | 5.3 KB | 138 lines

;                     XLISP Math Library
;                            by
;                      George V. Wilson
;                         June 1988


;For instructions see MATH.DOC.
;Do not load the math library twice. It will destroy the math functions.
;When *math_lib_loaded* is bound, the following if will prevent reloading.

(if (boundp '*math_lib_loaded*)
    (print "Math.lsp already loaded")
    (progn
       ;---------------------------------------------------------------

       ;predefined constant in Common LISP
       (setq pi 3.1415926536)

       ;----------------------------------------------------------------
       ;The following block of definitions is to take care of a minor
       ;incompatibility with Common LISP. These functions are supposed to
       ;accept any number as an arguement. Unfortunately, they don't work
       ;correctly when given integers as arguements (instead of floats).
       ;This group saves the old function,floats the arguement and calls
       ;the (saved) old function.

       (setf oldsquareroot #'sqrt)
       (defun sqrt (x) (oldsquareroot (float x)))

       (setf oldsine #'sin)
       (defun sin (x) (oldsine (float x)))

       (setf oldcosine #'cos)
       (defun cos (x) (oldcosine (float x)))

       (setf oldtangent #'tan)
       (defun tan (x) (oldtangent (float x)))

       (setf oldexp #'exp)
       (defun exp (x) (oldexp (float x)))


       (setf oldexpt #'expt)
       (defun expt (x y)
          (cond ((zerop x) 0)
                ((= x 1) 1)
                ((integerp y)
                    (do ((i 0 (1+ i)) (pow 1 (* pow x)))
                        ((<= (abs y) i)
                           (if (minusp y) (/ 1.0 pow) pow))))
                (T (oldexpt (float x) y))))
;--------------------------------------------------------------------------
       ;This next block supplies some Common LISP functions
       ;that are missing in XLISP.

       (defun signum (x)
          (cond ((not (numberp x))
                   (error "arguement to signum not a number " x))
                ((zerop x) x)
                (T (truncate (* 1.1 (/ x (abs x)))))))

       (defun round (x)
          (if (numberp x)
          (truncate (+ x (* (signum x) 0.5)))
          (error "bad arguement type to round" x)))

       (defun atan (x &optional y &aux s)
          (if (not (numberp x)) (error "bad arguement type to atan" x))
          (if y (setq x (/ x y)))
          (setq s (signum x))
          (setq x (float (abs x)))
          (cond ((< x .2679492)
             (* s (* x (+ .60310579 (- (/ .55913709 (+ 1.4087812 (* x x)))
                                       (* .05160454 (* x x)))))))
             ((<= x 1) (* s (+ .523598776 (atan (/ (1- (* 1.73205081 x))
                                                   (+ x 1.73205081))))))
             (T (* s (- 1.570796327 (atan (/ 1 x)))))))

     (defun asin (x)
       (cond ((> (abs x) 1) (error " arguement to asin out of range  " x))
             ((= x 1) 1.570796327)
             ((= x -1) -1.570796327)
             (T (atan (/ x (sqrt (- 1 (* x x))))))))

     (defun acos (x)
       (cond ((> (abs x) 1) (error "arguement to acos out of range  " x))
             ((zerop x) 1.570796327)
             ((plusp x) (atan (/ (sqrt (- 1 (* x x))) x)))
             ((minusp x) (- 3.1415926536 (acos (abs x))))))))

       (defun log (x &optional y)
          (let ((s 2.302585093) (m 0) coef z z2 (est 0))
            (if (not (and (numberp x) (if y (numberp y) T)))
                 (error "bad arguement type to log" (if y (list x y) x)))
            (if (<= x 0) (error " argument to log <= 0" x)
              (progn (setq coef '(0.191337714 0.094376476 0.177522071
                                  0.289335524 0.868591718))
                 (setq x (float x))
                 (cond ((< x 0.316227766) (setq x (/ 1 x)) (setq s (- s))))
                 (do () ((< x 3.16227766)) (setq x (/ x 10)) (setq m (1+ m)))
                 (setq z (/ (1- x) (1+ x)))
                 (setq z2 (* z z))
                 (dolist (a coef) (setq est (+ a (* est z2))))
                 (setq est (* s (+ m (* z est))))
                 (if y (/ est (log y)) est)))))

(defun integerp (n) (eql (type-of n) ':FIXNUM))

(defun euclid_gcd (a b)         ;euclid_gcd is not CommonLISP
   (do ((temp a (rem a b)))     ;it is used here to do the
       ((= temp 0) b)           ;work for gcd
       (setq a b)
       (setq b temp)))

(defun gcd (&rest nums)
  (if (do* ((args nums (cdr args))
            (test (integerp (car nums)) (and test (integerp (car args)))))
            ((null (cdr args)) (and test (car args))))
      (if (cdr nums)
          (euclid_gcd (car nums) (apply gcd (cdr nums)))
          (car nums))
      (error "arguments to gcd must be integers" nums)))

(defun lcm (&rest nums)
   (if (cdr nums)
       (let ((a (car nums)) (b (apply lcm (cdr nums))) temp)
            (setq temp (gcd a b))
            (if (integerp temp)
                (/ (* a b) temp)
                (error "arguements to lcm must be integers" nums)))
       (car nums)))

(defmacro incf (var &optional delta)
    `(setf ,var  (+ ,var (if ,delta ,delta 1))))

;-------------------------------------------------------------------------

(setq *math_lib_loaded* T)       ;prevents loading library twice.