radio-contact.lisp

; union-find.lisp

;; A generic solution for connected components. "I have some number of graphs. Is this element connected to
;; this other element? Or are the graphs/sets each element belongs to disjoint?"
;;
;; A 'backwards' tree with pointers from a node to its parent, which lets you union two separate trees together by
;; just taking the shorter one's root and pointing it at the taller one's (or vice versa, but this way preserves log
;; behavior).
;; The path compression optimization (not done here) seems to just be an extra pass in find(), after you have the result,
;; to re-parent each item along the path to the found root parent so that any future finds() of any of those items
;; will only have one lookup to reach the component root.
;;
;; This file is in the public domain. (Or licensed under CC0 if your country doesn't have such a concept.)

(in-package #:cl-user)
(defpackage #:union-find
  (:nicknames #:uf)
  (:shadow #:union #:find)
  (:use #:common-lisp)
  (:export #:union-find #:union #:find) ; class & core interface methods
  (:export #:connected)) ; convenience method
(in-package #:uf)

(defclass union-find ()
  ((parent-lookup-table
     :accessor parent-lookup-table
     :initform (make-hash-table :test #'equal)
     :documentation "Table that associates a set element (key) to its parent element (val)).")
   (subtree-size-table
     :accessor subtree-size-table
     :initform (make-hash-table :test #'equal)
     :documentation "Table that associates a subtree with root element (key) to its subtree count of elements (val).")))

(defmethod parent-lookup ((uf union-find) key)
  "Looks up key in uf's parent-lookup table.
   If key hasn't been added yet, sets the key's value
   to key itself and returns it."
  (multiple-value-bind (parent present?) (gethash key (parent-lookup-table uf))
    (unless present?
      (setf (gethash key (parent-lookup-table uf)) key)
      (setf parent key))
    parent))

(defmethod subtree-size ((uf union-find) subtree)
  "Gets the size of the specified subtree. If it's not part of the
   lookup map yet, creates an entry and sets it to 1."
  (multiple-value-bind (size present?) (gethash subtree (subtree-size-table uf))
    (unless present?
      (setf (gethash subtree (subtree-size-table uf)) 1)
      (setf size 1))
    size))

(defmethod find ((uf union-find) element)
  "Finds the root parent of the uf structure."
  (let ((parent (parent-lookup uf element)))
    (if (equal parent element)
        element
        (uf:find uf parent))))

(defmethod union ((uf union-find) set1 set2)
  "Makes set1 and set2 subsets of each other (if not already) by parenting the root
   of the smallest set to the other's root."
  (let ((root1 (uf:find uf set1))
        (root2 (uf:find uf set2))
        (parent-table (parent-lookup-table uf))
        (size-table (subtree-size-table uf)))
    (unless (equal root1 root2)
      ; make sure that root2's size is always greatest, swapping if needed,
      ; then parent root1 -> root2
      (if (> (subtree-size uf root1)
             (subtree-size uf root2))
          (rotatef root1 root2))
      (setf (gethash root1 parent-table)
            root2)
      ; update root2's size to be num elements unioned from root1
      (incf (gethash root2 size-table)
            (gethash root1 size-table))))
  nil)

(defmethod connected ((uf union-find) cmp1 cmp2)
  "If cmp1 and cmp2 have the same root in the uf,
   then they are connected in the same subtree."
  (equal (uf:find uf cmp1)
         (uf:find uf cmp2)))

; radio-contact.lisp

;; radio contact problem:
;; See Problem B from https://web.archive.org/web/20070824024918/http://www.cs.utah.edu/contest/2007/problems/Division%20II%20Problem%20set.pdf

(in-package #:cl-user)
(defpackage #:radio-contact
  (:use #:common-lisp)
  (:export #:radio-contact))
(in-package #:radio-contact)
(unless (find-package :uf)
  (error "Somehow failed to find union-find package."))

(defstruct point
  x
  y)

(defun square (x) (expt x 2))
(defun distance (p1 p2)
  "Euclidean distance."
  (let ((x-diff (- (point-x p1)
                   (point-x p2)))
        (y-diff (- (point-y p1)
                   (point-y p2))))
    (sqrt (+ (square x-diff)
             (square y-diff)))))

(defparameter *problem-data*
"13
118 136
200 386
338 486
412 266
410 484
54 54
194 80
408 226
476 180
116 98
76 94
160 96
434 202")

(defun read-soldiers (&optional (stream *standard-input*))
  "Reads the soldier data as specified in problem statement from STREAM.
   Example in *problem-data*."
  (let* ((soldier-count (read stream))
         (soldiers (make-array soldier-count)))
    (dotimes (i soldier-count)
      (setf (elt soldiers i) (make-point :x (read stream)
                                         :y (read stream))))
    soldiers))

(defparameter *radio-radius* 50.0)

(defun count-squads (soldiers)
  "Return number of disjoint squads, the output of the problem."
  (let ((groups (make-instance 'uf:union-find)))
    ;; for each soldier, loop through each other soldier
    ;; and if the other soldier is <= radius units away
    ;; then they are connected.
    (loop :for i :below (length soldiers)
          :do
          (loop :for j :from (1+ i) :below (length soldiers)
                :do
                (if (<= (distance (elt soldiers i) (elt soldiers j))
                        *radio-radius*)
                    (uf:union groups i j))))
    ;; the number of unique root nodes in the union-find is the number of squads.
    ;; we could add a convenience method to get this cheaply, but like
    ;; the #'connected function, it's just an application of calls to #'find.
    ;; Get the root component for each soldier, remove duplicates, count.
    (length
      (remove-duplicates
        (loop :for i :below (length soldiers)
              :collect (uf:find groups i))))))

(defun radio-contact (&optional use-cli)
  (let ((soldiers (if (eql use-cli :cli)
                      (read-soldiers)
                      (with-input-from-string (s *problem-data*)
                        (read-soldiers s)))))
    (print (count-squads soldiers))))

; (radio-contact:radio-contact)
; hack to run automatically in script but not in slime:
#-:swank (radio-contact :cli)