X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fnumbers.lisp;h=f5dee9aeb1ecd43489c440a7a22dbf61a0c2ab86;hb=ce86ba5f70b9e35bfb795402913f417de493e23f;hp=8121b8e6d26bd12a088d8e25e73bfb5092a085e1;hpb=598ae9642e4fc7d24a4e55deced53694ec83b04a;p=jscl.git

diff --git a/src/numbers.lisp b/src/numbers.lisp
index 8121b8e..f5dee9a 100644
--- a/src/numbers.lisp
+++ b/src/numbers.lisp
@@ -13,26 +13,37 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
+(/debug "loading numbers.lisp!")
+
 ;;;; Various numeric functions and constants
 
-;; Basic functions
-(defun = (x y) (= x y))
-(defun * (x y) (* x y))
-(defun / (x y) (/ x y))
-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
+(macrolet ((def (operator initial-value)
+             (let ((init-sym   (gensym))
+                   (dolist-sym (gensym)))
+               `(defun ,operator (&rest args)
+                  (let ((,init-sym ,initial-value))
+                    (dolist (,dolist-sym args)
+                      (setq ,init-sym (,operator ,init-sym ,dolist-sym)))
+                    ,init-sym)))))
+  (def + 0)
+  (def * 1))
+
+;; - and / work differently from the above macro.
+;; If only one arg is given, it negates it or takes its reciprocal.
+;; Otherwise all the other args are subtracted from or divided by it.
+(macrolet ((def (operator unary-form)
+             `(defun ,operator (x &rest args)
+                (cond
+                  ((null args) ,unary-form)
+                  (t (dolist (y args)
+                       (setq x (,operator x y)))
+                     x)))))
+  (def - (-   x))
+  (def / (/ 1 x)))
 
-(defun + (&rest args)
-  (let ((r 0))
-    (dolist (x args r)
-      (incf r x))))
 
-(defun - (x &rest others)
-  (if (null others)
-      (- x)
-      (let ((r x))
-        (dolist (y others r)
-          (decf r y)))))
+(defun 1+ (x) (+ x 1))
+(defun 1- (x) (- x 1))
 
 (defun truncate (x &optional (y 1))
   (floor (/ x y)))
@@ -47,33 +58,68 @@
 (defun zerop (x) (= x 0))
 (defun plusp (x) (< 0 x))
 
-;; TODO: Use MACROLET when it exists
-(defmacro defcomparison (operator)
-  `(defun ,operator (x &rest args)
-     (dolist (y args) 
-       (if (,operator x y)
-         (setq x    (car args))
-         (return-from ,operator nil)))
-     t))
-
-(defcomparison >)
-(defcomparison >=)
-(defcomparison <)
-(defcomparison <=)
+(defun signum (x)
+  (if (zerop x) x (/ x (abs x))))
+
+(macrolet ((def (operator)
+             `(defun ,operator (x &rest args)
+                (dolist (y args) 
+                  (if (,operator x y)
+                      (setq x    (car args))
+                      (return-from ,operator nil)))
+                t)))
+  (def >)
+  (def >=)
+  (def =) 
+  (def <)
+  (def <=)
+  (def /=))
 
 (defconstant pi 3.141592653589793) 
 
 (defun evenp (x) (= (mod x 2) 0))
 (defun oddp  (x) (not (evenp x)))
 
-(flet ((%max-min (x xs func)
-         (dolist (y xs) 
-           (setq x  (if (funcall func x (car xs)) x y)))
-         x))
-  (defun max (x &rest xs) (%max-min x xs #'>))
-  (defun min (x &rest xs) (%max-min x xs #'<))) 
+(macrolet ((def (name comparison)
+             `(defun ,name (x &rest xs)
+                (dolist (y xs) 
+                  (when (,comparison y x)
+                    (setq x y)))
+                x)))
+  (def max >)
+  (def min <))
 
 (defun abs (x) (if (> x 0) x (- x)))
 
 (defun expt (base power) (expt base              power))
 (defun exp  (power)      (expt 2.718281828459045 power))
+
+(defun gcd-2 (a b)
+  (if (zerop b)
+      (abs a)
+    (gcd-2 b (mod a b))))
+
+(defun gcd (&rest integers)
+  (cond ((null integers)
+	 0)
+	((null (cdr integers))
+	 (abs (first integers)))
+	((null (cddr integers))
+	 (gcd-2 (first integers) (second integers)))
+	(t
+	 (apply #'gcd (gcd (first integers) (second integers)) (nthcdr 2 integers)))))
+
+(defun lcm-2 (a b)
+  (if (or (zerop a) (zerop b))
+      0
+    (/ (abs (* a b)) (gcd a b))))
+
+(defun lcm (&rest integers)
+  (cond ((null integers)
+	 1)
+	((null (cdr integers))
+	 (abs (first integers)))
+	((null (cddr integers))
+	 (lcm-2 (first integers) (second integers)))
+	(t
+	 (apply #'lcm (lcm (first integers) (second integers)) (nthcdr 2 integers)))))