From e48ac76f4b26ec24080dfaf524482a839cd84fff Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 15 Sep 2003 10:10:26 +0000
Subject: [PATCH] r7861: add histogram function

---
 math.lisp    | 36 ++++++++++++++++++++++++++++++++++++
 package.lisp |  1 +
 2 files changed, 37 insertions(+)

diff --git a/math.lisp b/math.lisp
index be89825..0197d52 100644
--- a/math.lisp
+++ b/math.lisp
@@ -34,3 +34,39 @@
   `(if (stringp ,obj)
       (parse-integer ,obj)
      ,obj))
+
+(defun histogram (v n-bins &key min max)
+  (declare (fixnum n-bins))
+  (when (listp v)
+    (setq v (coerce v 'vector)))
+  (when (zerop (length v))
+    (return-from histogram (values nil nil nil)) )
+  (let ((n (length v))
+	(bins (make-array n-bins :element-type 'integer :initial-element 0))
+	found-min found-max)
+    (declare (fixnum n))
+    (unless (and min max)
+      (setq found-min (aref v 0)
+	    found-max (aref v 0))
+      (loop for i fixnum from 1 to (1- n)
+	  do
+	    (let ((x (aref v i)))
+	      (cond
+	       ((> x found-max)
+		(setq found-max x))
+	       ((< x found-min)
+		(setq found-min x)))))
+      (unless min
+	(setq min found-min))
+      (unless max
+	(setq max found-max)))
+    (let ((width (/ (- max min) n-bins)))
+      (setq width (+ width (* double-float-epsilon width)))
+      (dotimes (i n)
+	(let ((bin (nth-value 0 (truncate (- (aref v i) min) width))))
+	  (declare (fixnum bin))
+	  (when (and (not (minusp bin))
+		     (< bin n-bins))
+	    (incf (aref bins bin))))))
+    (values bins min max)))
+	      
diff --git a/package.lisp b/package.lisp
index fb555be..803dc12 100644
--- a/package.lisp
+++ b/package.lisp
@@ -111,6 +111,7 @@
    
    ;; math.lisp
    #:ensure-integer
+   #:histogram
    
    ;; macros.lisp
    #:time-iterations
-- 
2.34.1