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 ;;;; Various numeric functions and constants
  17
  18 ;; TODO: Use MACROLET when it exists
  19 (defmacro define-variadic-op (operator initial-value)
  20   (let ((init-sym   (gensym))
  21         (dolist-sym (gensym)))
  22     `(defun ,operator (&rest args)
  23        (let ((,init-sym ,initial-value))
  24          (dolist (,dolist-sym args)
  25            (setq ,init-sym (,operator ,init-sym ,dolist-sym)))
  26          ,init-sym))))
  27
  28 (define-variadic-op + 0)
  29 (define-variadic-op * 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 ;; TODO: Use MACROLET when it exists
  35 (defmacro define-sub-or-div (operator unary-form)
  36   `(defun ,operator (x &rest args)
  37      (cond
  38        ((null args) ,unary-form)
  39        (t (dolist (y args)
  40             (setq x (,operator x y)))
  41           x))))
  42
  43 (define-sub-or-div - (-   x))
  44 (define-sub-or-div / (/ 1 x))
  45
  46 (defun 1+ (x) (+ x 1))
  47 (defun 1- (x) (- x 1))
  48
  49 (defun truncate (x &optional (y 1))
  50   (floor (/ x y)))
  51
  52 (defun integerp (x)
  53   (and (numberp x) (= (floor x) x)))
  54
  55 (defun floatp (x)
  56   (and (numberp x) (not (integerp x))))
  57
  58 (defun minusp (x) (< x 0))
  59 (defun zerop (x) (= x 0))
  60 (defun plusp (x) (< 0 x))
  61
  62 (defun signum (x)
  63   (if (zerop x) x (/ x (abs x))))
  64
  65 ;; TODO: Use MACROLET when it exists
  66 (defmacro defcomparison (operator)
  67   `(defun ,operator (x &rest args)
  68      (dolist (y args)
  69        (if (,operator x y)
  70          (setq x    (car args))
  71          (return-from ,operator nil)))
  72      t))
  73
  74 (defcomparison >)
  75 (defcomparison >=)
  76 (defcomparison =)
  77 (defcomparison <)
  78 (defcomparison <=)
  79 (defcomparison /=)
  80
  81 (defconstant pi 3.141592653589793)
  82
  83 (defun evenp (x) (= (mod x 2) 0))
  84 (defun oddp  (x) (not (evenp x)))
  85
  86 (flet ((%max-min (x xs func)
  87          (dolist (y xs)
  88            (setq x  (if (funcall func x (car xs)) x y)))
  89          x))
  90   (defun max (x &rest xs) (%max-min x xs #'>))
  91   (defun min (x &rest xs) (%max-min x xs #'<)))
  92
  93 (defun abs (x) (if (> x 0) x (- x)))
  94
  95 (defun expt (base power) (expt base              power))
  96 (defun exp  (power)      (expt 2.718281828459045 power))
  97
  98 (defun gcd-2 (a b)
  99   (if (zerop b)
 100       (abs a)
 101     (gcd-2 b (mod a b))))
 102
 103 (defun gcd (&rest integers)
 104   (cond ((null integers)
 105          0)
 106         ((null (cdr integers))
 107          (abs (first integers)))
 108         ((null (cddr integers))
 109          (gcd-2 (first integers) (second integers)))
 110         (t
 111          (apply #'gcd (gcd (first integers) (second integers)) (nthcdr 2 integers)))))
 112
 113 (defun lcm-2 (a b)
 114   (if (or (zerop a) (zerop b))
 115       0
 116     (/ (abs (* a b)) (gcd a b))))
 117
 118 (defun lcm (&rest integers)
 119   (cond ((null integers)
 120          1)
 121         ((null (cdr integers))
 122          (abs (first integers)))
 123         ((null (cddr integers))
 124          (lcm-2 (first integers) (second integers)))
 125         (t
 126          (apply #'lcm (lcm (first integers) (second integers)) (nthcdr 2 integers)))))