From nsiivola at common-lisp.net  Fri Jan 20 15:34:24 2012
From: nsiivola at common-lisp.net (Nikodemus Siivola)
Date: Fri, 20 Jan 2012 07:34:24 -0800
Subject: [alexandria.git] updated branch master: 485544d generic MEAN and
	MEDIAN, new function DISPLACE-ARRAY
Message-ID: <E1RoGTw-00026u-8P@common-lisp.net>

The branch master has been updated:
       via  485544d4feb13d3f463f54a5605b3a480bc49046 (commit)
       via  36800ad120545e48e80ce5f2defacf6366ea8404 (commit)
       via  d92432dde897c8f249c377c727bc68d54efb1ddf (commit)
      from  77b219a8361b9549aeb8941afc945fa2e3c84eb9 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 485544d4feb13d3f463f54a5605b3a480bc49046
Author: tpapp <tkpapp at gmail.com>
Date:   Wed Jan 4 12:28:39 2012 +0100

    generic MEAN and MEDIAN, new function DISPLACE-ARRAY
    
     Objects other than sequences have means and medians (eg probability
     distributions, arrays, sequences/arrays wrapped in another object, etc), so
     it makes sense to make these functions generic.
    
     DISPLACE-ARRAY is a small utility function that is used in the implementation
     of MEDIAN for arrays, but is also of general utility because it makes the
     creation of displaced arrays simpler, dispensing with the need to specify the
     element type, and offering sensible defaults when one wants vectors.
    
     Also added tests for all the new functions/methods.

commit 36800ad120545e48e80ce5f2defacf6366ea8404
Author: Jyrki Jaakkola <jjkola at email.com>
Date:   Fri Jan 20 16:59:54 2012 +0200

    make Alexandria work with readtable-case :INVERT

commit d92432dde897c8f249c377c727bc68d54efb1ddf
Author: Ryan Davis <ryan at acceleration.net>
Date:   Wed Dec 21 13:20:47 2011 -0500

    convert ENSURE-GETHASH into a macro
    
     Evaluate the default-form only if we actually use it.

-----------------------------------------------------------------------

Summary of changes:
 arrays.lisp      |   11 +++++++++++
 hash-tables.lisp |   10 +++++-----
 numbers.lisp     |   53 +++++++++++++++++++++++++++++++++++++++++++++--------
 package.lisp     |    1 +
 tests.lisp       |   49 +++++++++++++++++++++++++++++++++++++++----------
 types.lisp       |    8 ++++----
 6 files changed, 105 insertions(+), 27 deletions(-)

diff --git a/arrays.lisp b/arrays.lisp
index 76c1879..1f30150 100644
--- a/arrays.lisp
+++ b/arrays.lisp
@@ -16,3 +16,14 @@ arguments."
      (setf (row-major-aref new-array i)
            (row-major-aref array i)))
    new-array))
+
+(declaim (inline displace-array))
+(defun displace-array (array &key (offset 0)
+                                  (dimensions (- (array-total-size array)
+                                               offset)))
+  "Return an array displaced to ARRAY with the given OFFSET and DIMENSIONS.
+Default arguments displace to a vector."
+  (make-array dimensions
+              :displaced-to array
+              :displaced-index-offset offset
+              :element-type (array-element-type array)))
diff --git a/hash-tables.lisp b/hash-tables.lisp
index a574737..65253e7 100644
--- a/hash-tables.lisp
+++ b/hash-tables.lisp
@@ -89,11 +89,11 @@ PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
       (setf (gethash (car tail) table) (cadr tail)))
     table))
 
-(defun ensure-gethash (key hash-table &optional default)
+(defmacro ensure-gethash (key hash-table &optional default)
   "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
 under key before returning it. Secondary return value is true if key was
 already in the table."
-  (multiple-value-bind (value ok) (gethash key hash-table)
-    (if ok
-        (values value ok)
-        (values (setf (gethash key hash-table) default) nil))))
+  `(multiple-value-bind (value ok) (gethash ,key ,hash-table)
+     (if ok
+         (values value ok)
+         (values (setf (gethash ,key ,hash-table) ,default) nil))))
diff --git a/numbers.lisp b/numbers.lisp
index 03430cc..7340f26 100644
--- a/numbers.lisp
+++ b/numbers.lisp
@@ -84,21 +84,58 @@ Examples:
 interpolation coefficient V."
    (+ a (* v (- b a))))
 
-(declaim (inline mean))
-(defun mean (sample)
-  "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
-  (/ (reduce #'+ sample) (length sample)))
-
-(declaim (inline median))
-(defun median (sample)
-  "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
-  (let* ((vector (sort (copy-sequence 'vector sample) #'<))
+(defgeneric mean (object)
+  (:documentation "Returns the mean of OBJECT.
+Predefined methods work on sequences and arrays of numbers. Users can
+define new methods.")
+  (:method ((object list))
+    (let ((sum 0)
+          (count 0))
+      (declare (fixnum count))
+      (dolist (elt object)
+        (incf sum elt)
+        (incf count))
+      (/ sum count)))
+  (:method ((object vector))
+    ;; Need a separate method for vectors, since
+    ;; they could have fill-pointers which we need to respect.
+    (let ((n (length object)))
+      (/ (loop for index below n
+               summing (aref object index))
+         n)))
+  (:method ((object array))
+    (let ((n (array-total-size object)))
+      (/ (loop for index below n
+               summing (row-major-aref object index))
+         n)))
+  (:method ((object sequence))
+    ;; For implementations supporting custom sequence types.
+    (/ (reduce #'+ object) (length object))))
+
+(defun median-in-place (vector)
+  (declare (vector vector))
+  (let* ((vector (sort vector #'<))
          (length (length vector))
          (middle (truncate length 2)))
     (if (oddp length)
         (aref vector middle)
         (/ (+ (aref vector middle) (aref vector (1- middle))) 2))))
 
+(defgeneric median (object)
+  (:documentation
+   "Returns median of OBJECT.
+Predefined methods work on sequences and arrays of numbers. Users can
+define new methods.")
+  (:method ((object list))
+    (median-in-place (copy-sequence 'vector object)))
+  (:method ((object array))
+    (median-in-place (copy-sequence 'vector (if (vectorp object)
+                                                object
+                                                (displace-array object)))))
+  (:method ((object sequence))
+    ;; For implementations supporting custom sequence types.
+    (median-in-place (copy-sequence 'vector object))))
+
 (declaim (inline variance))
 (defun variance (sample &key (biased t))
   "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
diff --git a/package.lisp b/package.lisp
index 673ed30..8bdf060 100644
--- a/package.lisp
+++ b/package.lisp
@@ -101,6 +101,7 @@
    #:array-index
    #:array-length
    #:copy-array
+   #:displace-array
    ;; Sequences
    #:copy-sequence
    #:deletef
diff --git a/tests.lisp b/tests.lisp
index babe0f4..7d7d1ca 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -47,6 +47,24 @@
        (typep copy 'simple-array)))
  t)
 
+(deftest displace-array.1
+    (displace-array #2A((1 2)
+                        (3 4)))
+  #(1 2 3 4))
+
+(deftest displace-array.2
+    (displace-array #2A((1 2)
+                        (3 4))
+                    :offset 1)
+  #(2 3 4))
+
+(deftest displace-array.3
+    (displace-array #2A((1 2)
+                        (3 4))
+                    :offset 1
+                    :dimensions '(3 1))
+  #2A((2) (3) (4)))
+
 (deftest array-index.1
     (typep 0 'array-index)
   t)
@@ -958,6 +976,12 @@
     (mean '(1 2 10))
   13/3)
 
+(deftest mean.4
+    (mean #2A((1 2 3)
+              (4 5 6)
+              (7 8 9)))
+  5)
+
 (deftest median.1
     (median '(100 0 99 1 98 2 97))
   97)
@@ -966,6 +990,11 @@
     (median '(100 0 99 1 98 2 97 96))
   193/2)
 
+(deftest median.3
+    (median #2A((100 0 99 1)
+                (98 2 97 96)))
+  193/2)
+
 (deftest variance.1
     (variance (list 1 2 3))
   2/3)
@@ -1584,18 +1613,18 @@
   :inherited)
 
 (deftest format-symbol.1
-    (let ((s (format-symbol nil "X-~D" 13)))
+    (let ((s (format-symbol nil '#:x-~d 13)))
       (list (symbol-package s)
-            (symbol-name s)))
-  (nil "X-13"))
+            (string= (string '#:x-13) (symbol-name s))))
+  (nil t))
 
 (deftest format-symbol.2
-    (format-symbol :keyword "SYM-~A" :bolic)
+    (format-symbol :keyword '#:sym-~a (string :bolic))
   :sym-bolic)
 
 (deftest format-symbol.3
     (let ((*package* (find-package :cl)))
-      (format-symbol t "FIND-~A" 'package))
+      (format-symbol t '#:find-~a (string 'package)))
   find-package)
 
 (deftest make-keyword.1
@@ -1657,12 +1686,12 @@
 
 (macrolet
     ((test (type numbers)
-       `(deftest ,(format-symbol t "CDR5.~A" type)
+       `(deftest ,(format-symbol t '#:cdr5.~a (string type))
 	    (let ((numbers ,numbers))
-	      (values (mapcar (of-type ',(format-symbol t "NEGATIVE-~A" type)) numbers)
-		      (mapcar (of-type ',(format-symbol t "NON-POSITIVE-~A" type)) numbers)
-		      (mapcar (of-type ',(format-symbol t "NON-NEGATIVE-~A" type)) numbers)
-		      (mapcar (of-type ',(format-symbol t "POSITIVE-~A" type)) numbers)))
+	      (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
+		      (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
+		      (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
+		      (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
 	  (t t t nil nil nil nil)
 	  (t t t t nil nil nil)
 	  (nil nil nil t t t t)
diff --git a/types.lisp b/types.lisp
index b806c0d..6aa722f 100644
--- a/types.lisp
+++ b/types.lisp
@@ -34,10 +34,10 @@ ARRAY-DIMENSION-LIMIT."
 			    type
 			    (if (equal range-beg ''*) inf (ensure-car range-beg))
 			    (if (equal range-end ''*) inf (ensure-car range-end))))))
-           (let* ((negative-name     (make-subtype-name '#:negative-~A))
-                  (non-positive-name (make-subtype-name '#:non-positive-~A))
-                  (non-negative-name (make-subtype-name '#:non-negative-~A))
-                  (positive-name     (make-subtype-name '#:positive-~A))
+           (let* ((negative-name     (make-subtype-name '#:negative-~a))
+                  (non-positive-name (make-subtype-name '#:non-positive-~a))
+                  (non-negative-name (make-subtype-name '#:non-negative-~a))
+                  (positive-name     (make-subtype-name '#:positive-~a))
                   (negative-p-name     (make-predicate-name negative-name))
                   (non-positive-p-name (make-predicate-name non-positive-name))
                   (non-negative-p-name (make-predicate-name non-negative-name))
-- 
Alexandria hooks/post-receive