binary-trees.lisp

   1 (in-package :trees)
   2
   3 (unless (assoc :normal *binary-tree-info*)
   4   (push (list :normal #'make-tree-node nil nil) *binary-tree-info*))
   5
   6 (defun emptyp (tree)
   7   (zerop (size tree)))
   8
   9 (declaim (inline rotate-left rotate-right))
  10 (defun rotate-left (node)
  11   (let ((c (right node)))
  12     (setf (right node) (left c)
  13           (left c) node)
  14     (incf (rank c) (rank node))
  15     c))
  16 (defun rotate-right (node)
  17   (let ((c (left node)))
  18     (setf (left node) (right c)
  19           (right c) node)
  20     (decf (rank node) (rank c))
  21     c))
  22
  23 (defun update-ranks (direction-stack insertedp)
  24   (dolist (x direction-stack (values))
  25     (let ((direction (cdr x)))
  26       (when (eq direction 'left)
  27         (if insertedp
  28             (incf (rank (car x)))
  29             (decf (rank (car x))))))))
  30
  31 (declaim (inline insert-child-for-stack-entry set-root-or-entry-child))
  32 (defun insert-child-for-stack-entry (entry child)
  33   (declare (type cons entry))
  34   (if (eq (cdr entry) 'left)
  35       (setf (left (car entry)) child)
  36       (setf (right (car entry)) child)))
  37
  38 (defun set-root-or-entry-child (tree entry child)
  39   (if (null entry)
  40       (setf (root tree) child)
  41       (insert-child-for-stack-entry entry child)))
  42
  43 ;;; Locates the place where we should place ITEM in TREE.  Returns two
  44 ;;; values: whether we should insert and a stack of nodes visited and
  45 ;;; the direction we traveled from each node.  The newly-created node
  46 ;;; should be a child of the node of the first entry on the stack.
  47 (defun find-insertion-point (tree item-key)
  48   (let ((pred (pred tree))
  49         (test (test tree))
  50         (key (key tree)))
  51     (declare (type function pred test key))
  52     (do ((node (root tree))
  53          (direction-stack nil))
  54         ((eq node nil)
  55          (values nil direction-stack item-key))
  56       (declare (type (or null tree-node) node))
  57       (let ((node-key (funcall key (datum node))))
  58         (cond
  59           ((funcall test node-key item-key)
  60            (return-from find-insertion-point (values node direction-stack node-key)))
  61           ((funcall pred item-key node-key)
  62            (push (cons node 'left) direction-stack)
  63            (setf node (left node)))
  64           (t
  65            (push (cons node 'right) direction-stack)
  66            (setf node (right node))))))))
  67
  68 (defun insert (item tree)
  69   "Attempt to insert ITEM into TREE.  ITEM must be of a suitable type
  70 for TREE's key function, and the key returned from calling said function
  71 must be of a suitable type for TREE's comparison and equality functions.
  72 Returns two values; the first is the key of ITEM and the second
  73 indicates whether ITEM was inserted or not."
  74   (declare (type binary-tree tree))
  75   (multiple-value-bind (presentp direction-stack item-key)
  76       (find-insertion-point tree (funcall (key tree) item))
  77     (unless presentp
  78       (update-ranks direction-stack t)
  79       (incf (size tree))
  80       (let ((new-node (funcall (nodegen tree) item)))
  81         (declare (type tree-node new-node))
  82         (incf (modcount tree))
  83         (cond
  84           (direction-stack
  85            (insert-child-for-stack-entry (first direction-stack) new-node))
  86           (t
  87            (setf (root tree) new-node)))
  88         (let ((rebalancer (rebalance/insert tree)))
  89           (when rebalancer
  90             (funcall rebalancer tree direction-stack)))))
  91     (values item-key (null presentp))))
  92
  93 (declaim (inline lower-bound-node-with-path))
  94 (defun lower-bound-node-with-path (key tree pathp)
  95   (let ((pred (pred tree))
  96         (%key (key tree)))
  97     (declare (type function pred %key))
  98     (labels ((locate-node (node candidate path)
  99                (cond
 100                  ((null node) (values candidate path))
 101                  ((funcall pred key (funcall %key (datum node)))
 102                   (locate-node (left node) candidate
 103                                (when pathp
 104                                  (cons (cons node 'left) path))))
 105                  (t
 106                   (locate-node (right node) node
 107                                (when pathp
 108                                  (cons (cons node 'right) path)))))))
 109       (locate-node (root tree) nil nil))))
 110 (declaim (notinline lower-bound-node-with-path))
 111
 112 (defun lower-bound-node (key tree)
 113   "Return the node in TREE possessing a key which is equal to or
 114 less than KEY."
 115   (lower-bound-node-with-path key tree nil))
 116
 117 (defun lower-bound (key tree)
 118   "Return the item in TREE possessing a key which is equal to or less
 119 than KEY.  Returns NIL if there is no such item."
 120   (let ((node (lower-bound-node key tree)))
 121     (and node (datum node))))
 122
 123 (declaim (inline upper-bound-node-with-path))
 124 (defun upper-bound-node-with-path (key tree pathp)
 125   (let ((pred (pred tree))
 126         (%key (key tree)))
 127     (declare (type function pred %key))
 128     (labels ((locate-node (node candidate path)
 129                (cond
 130                  ((null node) (values candidate path))
 131                  ((funcall pred key (funcall %key (datum node)))
 132                   (locate-node (left node) node
 133                                (when pathp (cons (cons node 'left) path))))
 134                  (t
 135                   (locate-node (right node) candidate
 136                                (when pathp (cons (cons node 'right) path)))))))
 137       (locate-node (the tree-node (root tree)) nil nil))))
 138 (declaim (notinline upper-bound-node-with-path))
 139
 140 (defun upper-bound-node (key tree)
 141   "Return the node in TREE possessing a key which is equal to or greater
 142 than KEY."
 143   (upper-bound-node-with-path key tree nil))
 144
 145 (defun upper-bound (key tree)
 146   "Return the item in TREE possessing a key which is equal to or
 147 greater than KEY.  Returns NIL if there is no such item."
 148   (let ((node (upper-bound-node key tree)))
 149     (and node (datum node))))
 150
 151 (defun find-node-with-key (tree key)
 152   "Find the node in TREE with key KEY.  Might return the null node if no
 153 such node can be found."
 154   (let ((node (lower-bound-node key tree)))
 155     (and node
 156          (funcall (test tree) key (funcall (key tree) (datum node)))
 157          node)))
 158
 159 (defun find (key tree)
 160   "Find the item in TREE whose key is KEY and returns the associated item
 161 and T as multiple values, or returns NIL and NIL if no such item exists."
 162   (let ((node (find-node-with-key tree key)))
 163     (if node
 164         (values (datum node) t)
 165         (values nil nil))))
 166
 167 (defun delete-node (tree node direction-stack)
 168   (decf (size tree))
 169   (update-ranks direction-stack nil)
 170   (let ((parent (caar direction-stack))
 171         (direction (cdar direction-stack)))
 172     (flet ((move-node (x)
 173              (if (null parent)
 174                  (setf (root tree) x)
 175                  (if (eq direction 'left)
 176                      (setf (left parent) x)
 177                      (setf (right parent) x)))
 178              x))
 179       (let ((r (right node)))
 180         (cond
 181           ((null r)
 182            (values (move-node (left node)) direction-stack))
 183           ((null (left r))
 184            (setf (left r) (left node)
 185                  (rank r) (rank node))
 186            (values (move-node r)
 187                    (cons (cons r 'right) direction-stack)))
 188           (t
 189            ;; find NODE's in-order successor
 190            (let ((placeholder (cons nil 'right))
 191                  (parent (first direction-stack)))
 192              (push placeholder direction-stack)
 193              (loop
 194                 (push (cons r 'left) direction-stack)
 195                 (let ((succ (left r)))
 196                   (when (null (left succ))
 197                     (decf (rank r))
 198                     ;; move SUCC into NODE's place
 199                     (setf (left r) (right succ)
 200                           (left succ) (left node)
 201                           (right succ) (right node)
 202                           (rank succ) (rank node))
 203                     (if (null parent)
 204                         (setf (root tree) succ)
 205                         (insert-child-for-stack-entry parent succ))
 206                     (setf (car placeholder) succ)
 207                     (return-from delete-node (values (move-node succ) direction-stack)))
 208                   (decf (rank r))
 209                   (setf r succ))))))))))
 210
 211 (defun delete (key tree)
 212   "Attempt to remove the item with KEY from TREE.
 213 Returns the item and T as multiple values on success, NIL and NIL on
 214 failure."
 215 (declare (type binary-tree tree))
 216   (multiple-value-bind (node direction-stack item-key)
 217       (find-insertion-point tree key)
 218     (declare (ignore item-key))
 219     (if node
 220         (multiple-value-bind (replacement new-stack)
 221             (delete-node tree node direction-stack)
 222           (incf (modcount tree))
 223           (let ((rebalancer (rebalance/delete tree)))
 224             (when rebalancer
 225               (funcall rebalancer tree node replacement new-stack)))
 226           (values (datum node) t))
 227         (values nil nil))))
 228
 229 (defun minimum-node (root)
 230   (do ((node root (left node))
 231        (parent nil node))
 232       ((eq node nil) parent)))
 233
 234 (defun minimum (tree)
 235   "Return the item with the minimum key in TREE.  It is an error to ask
 236 for the minimum item of an empty tree."
 237   (if (zerop (size tree))
 238       (error "Empty tree")
 239       (datum (minimum-node (root tree)))))
 240
 241 (defun maximum-node (root)
 242   (do ((node root (right node))
 243        (parent nil node))
 244       ((eq node nil) parent)))
 245
 246 (defun maximum (tree)
 247   "Return the item with the maximum key in TREE.  It is an error to ask
 248 for the maximum item of an empty tree."
 249   (if (zerop (size tree))
 250       (error "Empty tree")
 251       (datum (maximum-node (root tree)))))
 252
 253 (defun select-node-with-path (tree k pathp)
 254   (labels ((select-loop (node k path)
 255              (let ((rank (1- (rank node))))
 256                (cond
 257                  ((= k rank) (values node path))
 258                  ((< k rank) (select-loop (left node) k
 259                                           (when pathp
 260                                             (cons (cons node 'left) path))))
 261                  (t (select-loop (right node) (- k rank 1)
 262                                  (when pathp
 263                                    (cons (cons node 'right) path))))))))
 264     (cond
 265       ((or (minusp k)
 266            (>= k (size tree))) (error "Invalid index value"))
 267       (t (select-loop (root tree) k nil)))))
 268
 269 (defun select-node (tree k)
 270   (select-node-with-path tree k nil))
 271
 272 (defun select (tree k)
 273   "Return the Kth item (zero-based) in TREE."
 274   (datum (select-node tree k)))