src/utilities.lisp, src/class-finalize-impl.lisp: Add `find-duplicates'.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 10e95c7..b02fdf4 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -679,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.