(cdddr neigh-record) best-path)))))))
dead))
-(export '(inconsistent-merge-error merge-error-candidates))
+(export '(inconsistent-merge-error
+ merge-error-candidates merge-error-present-function))
(define-condition inconsistent-merge-error (error)
((candidates :initarg :candidates
- :reader merge-error-candidates))
+ :reader merge-error-candidates)
+ (present :initarg :present :initform #'identity
+ :reader merge-error-present-function))
(:documentation
"Reports an inconsistency in the arguments passed to `merge-lists'.")
(:report (lambda (condition stream)
(format stream "Merge inconsistency: failed to decide between ~
~{~#[~;~A~;~A and ~A~:;~
~@{~A, ~#[~;and ~A~]~}~]~}"
- (merge-error-candidates condition)))))
+ (mapcar (merge-error-present-function condition)
+ (merge-error-candidates condition))))))
(export 'merge-lists)
(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates (mapcar present candidates)))
+ :candidates candidates
+ :present present))
((null (cdr leasts))
(car leasts))
(pick
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.