X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/f7b60deb3e34c4655af26ac879a8d1f146209730..6390b8458f7d363a58c1d6fcb0723dc9eb61e68e:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 0f6a54b..b02fdf4 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -82,7 +82,7 @@
 	   form))))
 
 (export 'once-only)
-(defmacro once-only (binds &body body)
+(defmacro once-only ((&rest binds) &body body)
   "Macro helper for preventing repeated evaluation.
 
    The syntax is actually hairier than shown:
@@ -563,9 +563,10 @@
    candidates list if and only if an occurrence of A appears in an earlier
    input list than any occurrence of item B.  (This completely determines the
    order of the candidates: it is not possible that two candidates appear in
-   the same input list would resolve the ambiguity between them.)  If PICK is
-   omitted then the item chosen is the one appearing in the earliest of the
-   input lists: i.e., effectively, the default PICK function is
+   the same input list, since that would resolve the ambiguity between them.)
+   If PICK is omitted then the item chosen is the one appearing in the
+   earliest of the input lists: i.e., effectively, the default PICK function
+   is
 
 	(lambda (candidates output-so-far)
 	  (declare (ignore output-so-far))
@@ -678,6 +679,42 @@
 	  items
 	  :initial-value nil))
 
+(export 'find-duplicates)
+(defun find-duplicates (report sequence &key (key #'identity) (test #'eql))
+  "Call REPORT on each pair of duplicate items in SEQUENCE.
+
+   Duplicates are determined according to the KEY and TEST funcitons."
+  (when (symbolp test) (setf test (symbol-function test)))
+  (cond ((zerop (length sequence)) nil)
+	((or (eq test #'eq)
+	     (eq test #'eql)
+	     (eq test #'equal)
+	     (eq test #'equalp))
+	 (let ((seen (make-hash-table :test test)))
+	   (map nil (lambda (item)
+		      (let ((k (funcall key item)))
+			(multiple-value-bind (previous matchp)
+			    (gethash k seen)
+			  (if matchp (funcall report item previous)
+			      (setf (gethash k seen) item)))))
+		sequence)))
+	((listp sequence)
+	 (mapl (lambda (tail)
+		 (let* ((item (car tail))
+			(rest (cdr tail))
+			(match (member (funcall key item) rest
+				       :test test :key key)))
+		   (when match (funcall report item (car match)))))
+	       sequence))
+	((vectorp sequence)
+	 (dotimes (i (length sequence))
+	   (let* ((item (aref sequence i))
+		  (pos (position (funcall key item) sequence
+				 :key key :test test :start (1+ i))))
+	     (when pos (funcall report item (aref sequence pos))))))
+	(t
+	 (error 'type-error :datum sequence :expected-type 'sequence))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Strings and characters.