56 lines
2.4 KiB
Common Lisp
56 lines
2.4 KiB
Common Lisp
(defun point-distance (p1 p2)
|
|
(destructuring-bind (x1 . y1) p1
|
|
(destructuring-bind (x2 . y2) p2
|
|
(let ((dx (- x2 x1)) (dy (- y2 y1)))
|
|
(sqrt (+ (* dx dx) (* dy dy)))))))
|
|
|
|
(defun closest-pair-bf (points)
|
|
(let ((pair (list (first points) (second points)))
|
|
(dist (point-distance (first points) (second points))))
|
|
(dolist (p1 points (values pair dist))
|
|
(dolist (p2 points)
|
|
(unless (eq p1 p2)
|
|
(let ((pdist (point-distance p1 p2)))
|
|
(when (< pdist dist)
|
|
(setf (first pair) p1
|
|
(second pair) p2
|
|
dist pdist))))))))
|
|
|
|
(defun closest-pair (points)
|
|
(labels
|
|
((cp (xp &aux (length (length xp)))
|
|
(if (<= length 3)
|
|
(multiple-value-bind (pair distance) (closest-pair-bf xp)
|
|
(values pair distance (sort xp '< :key 'cdr)))
|
|
(let* ((xr (nthcdr (1- (floor length 2)) xp))
|
|
(xm (/ (+ (caar xr) (caadr xr)) 2)))
|
|
(psetf xr (rest xr)
|
|
(rest xr) '())
|
|
(multiple-value-bind (lpair ldist yl) (cp xp)
|
|
(multiple-value-bind (rpair rdist yr) (cp xr)
|
|
(multiple-value-bind (dist pair)
|
|
(if (< ldist rdist)
|
|
(values ldist lpair)
|
|
(values rdist rpair))
|
|
(let* ((all-ys (merge 'vector yl yr '< :key 'cdr))
|
|
(ys (remove-if #'(lambda (p)
|
|
(> (abs (- (car p) xm)) dist))
|
|
all-ys))
|
|
(ns (length ys)))
|
|
(dotimes (i ns)
|
|
(do ((k (1+ i) (1+ k)))
|
|
((or (= k ns)
|
|
(> (- (cdr (aref ys k))
|
|
(cdr (aref ys i)))
|
|
dist)))
|
|
(let ((pd (point-distance (aref ys i)
|
|
(aref ys k))))
|
|
(when (< pd dist)
|
|
(setf dist pd
|
|
(first pair) (aref ys i)
|
|
(second pair) (aref ys k))))))
|
|
(values pair dist all-ys)))))))))
|
|
(multiple-value-bind (pair distance)
|
|
(cp (sort (copy-list points) '< :key 'car))
|
|
(values pair distance))))
|