src/numbers.lisp

   1 ;;; numbers.lisp
   2
   3 ;; JSCL is free software: you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation, either version 3 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; JSCL is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (/debug "loading numbers.lisp!")
  17
  18 ;;;; Various numeric functions and constants
  19
  20 (macrolet ((def (operator initial-value)
  21              (let ((init-sym   (gensym))
  22                    (dolist-sym (gensym)))
  23                `(defun ,operator (&rest args)
  24                   (let ((,init-sym ,initial-value))
  25                     (dolist (,dolist-sym args)
  26                       (setq ,init-sym (,operator ,init-sym ,dolist-sym)))
  27                     ,init-sym)))))
  28   (def + 0)
  29   (def * 1))
  30
  31 ;; - and / work differently from the above macro.
  32 ;; If only one arg is given, it negates it or takes its reciprocal.
  33 ;; Otherwise all the other args are subtracted from or divided by it.
  34 (macrolet ((def (operator unary-form)
  35              `(defun ,operator (x &rest args)
  36                 (cond
  37                   ((null args) ,unary-form)
  38                   (t (dolist (y args)
  39                        (setq x (,operator x y)))
  40                      x)))))
  41   (def - (-   x))
  42   (def / (/ 1 x)))
  43
  44
  45 (defun 1+ (x) (+ x 1))
  46 (defun 1- (x) (- x 1))
  47
  48 (defun truncate (x &optional (y 1))
  49   (floor (/ x y)))
  50
  51 (defun integerp (x)
  52   (and (numberp x) (= (floor x) x)))
  53
  54 (defun floatp (x)
  55   (and (numberp x) (not (integerp x))))
  56
  57 (defun minusp (x) (< x 0))
  58 (defun zerop (x) (= x 0))
  59 (defun plusp (x) (< 0 x))
  60
  61 (defun signum (x)
  62   (if (zerop x) x (/ x (abs x))))
  63
  64 (macrolet ((def (operator)
  65              `(defun ,operator (x &rest args)
  66                 (dolist (y args)
  67                   (if (,operator x y)
  68                       (setq x    (car args))
  69                       (return-from ,operator nil)))
  70                 t)))
  71   (def >)
  72   (def >=)
  73   (def =)
  74   (def <)
  75   (def <=)
  76   (def /=))
  77
  78 (defconstant pi 3.141592653589793)
  79
  80 (defun evenp (x) (= (mod x 2) 0))
  81 (defun oddp  (x) (not (evenp x)))
  82
  83 (macrolet ((def (name comparison)
  84              `(defun ,name (x &rest xs)
  85                 (dolist (y xs)
  86                   (when (,comparison y x)
  87                     (setq x y)))
  88                 x)))
  89   (def max >)
  90   (def min <))
  91
  92 (defun abs (x) (if (> x 0) x (- x)))
  93
  94 (defun expt (base power) (expt base              power))
  95 (defun exp  (power)      (expt 2.718281828459045 power))
  96
  97 (defun gcd-2 (a b)
  98   (if (zerop b)
  99       (abs a)
 100     (gcd-2 b (mod a b))))
 101
 102 (defun gcd (&rest integers)
 103   (cond ((null integers)
 104          0)
 105         ((null (cdr integers))
 106          (abs (first integers)))
 107         ((null (cddr integers))
 108          (gcd-2 (first integers) (second integers)))
 109         (t
 110          (apply #'gcd (gcd (first integers) (second integers)) (nthcdr 2 integers)))))
 111
 112 (defun lcm-2 (a b)
 113   (if (or (zerop a) (zerop b))
 114       0
 115     (/ (abs (* a b)) (gcd a b))))
 116
 117 (defun lcm (&rest integers)
 118   (cond ((null integers)
 119          1)
 120         ((null (cdr integers))
 121          (abs (first integers)))
 122         ((null (cddr integers))
 123          (lcm-2 (first integers) (second integers)))
 124         (t
 125          (apply #'lcm (lcm (first integers) (second integers)) (nthcdr 2 integers)))))