lisp-algo/union-find/weighted-quick-union.lisp

;;;; Weighted Quick Union Algorithm
;;;; This algorithm solve dynamic connectivity
;;;; problem by providing a way to find if there
;;;; is a path between two nodes in a dynamic graph.
;;;; It is an improved version of the Quick Union algorithm
;;;; by improving the way that the union-tree is constructed
;;;; The algorithm try to reduce the deepness of the tree in
;;;; order to optimize the find-root function

(in-package :com.lisp-algo.union-find)


(defclass weighted-quick-union ()
  ((nw-size
    :initarg :network-size
    :initform 10
    :accessor network-size)
   (nw
    :initform nil
    :accessor network)))

(defmethod initialize-instance :after ((algo weighted-quick-union) &key)
    "Build a quick-find network using a multi-dimensional dynamic vector:\n
1st dimension = the network\n 2nd dimension = each subtree node quantities"
    (with-slots ((n nw-size) (nw nw)) algo
  (let ((network (make-array `(2 ,n) :initial-element 1)))
    (dotimes (id n)
      (setf (aref network 0 id) id))
    (setf nw network))))

(defun wqu-find-root (network node)
  "Find the root of a sub-tree in the network."
  (do ((id node value)
       (value (aref network 0 node) (aref network 0 value)))
      ((= id value) id)))

(defmethod union ((algo weighted-quick-union) n1 n2)
  "Connect to sub-tree together. union represent the union operation on the Quick Union algorithm"
  (with-slots ((network nw)) algo
    (let ((new-network (copy-tree network))) ; Duplicate network
      (let* ((n1-root (wqu-find-root new-network n1))
             (n2-root (wqu-find-root new-network n2))
             (n1-size (aref new-network 1 n1-root))
             (n2-size (aref new-network 1 n2-root)))
        (if (>= n1-size n2-size) ; Check which subtree is LARGER (not deeper)
            (progn (setf (aref new-network 0 n2-root) (aref new-network 0 n1-root)) ; Modify the second node
                   (setf (aref new-network 1 n1-root) ; Update tree larger
                         (+ (aref new-network 1 n1-root) (aref new-network 1 n2-root))))
          (progn (setf (aref new-network 0 n1-root) (aref new-network 0 n2-root)) ; Otherwise modify the first node
                 (setf (aref new-network 1 n2-root) ; Update tree larger
                       (+ (aref new-network 1 n2-root) (aref new-network 1 n1-root)))))
        (setf network new-network)))))

(defmethod connected ((algo weighted-quick-union) n1 n2)
  "Return true if n1 and n2 are connected and nil otherwise. connection represent
the find operation on the Quick Union algorithm"
  (with-slots ((network nw)) algo
    (= (wqu-find-root network n1) (wqu-find-root network n2))))