| 1 | ;;; File: binary-tree.lisp -*- Mode: Lisp; Syntax: Common-Lisp -*- |
|---|
| 2 | |
|---|
| 3 | ;; source: http://aima.cs.berkeley.edu/lisp/utilities/binary-tree.lisp |
|---|
| 4 | |
|---|
| 5 | |
|---|
| 6 | ;;;; The following definitions implement binary search trees. |
|---|
| 7 | |
|---|
| 8 | ;;; They are not balanced as yet. Currently, they all order their |
|---|
| 9 | ;;; elements by #'<, and test for identity of elements by #'eq. |
|---|
| 10 | |
|---|
| 11 | |
|---|
| 12 | (defstruct search-tree-node |
|---|
| 13 | "node for binary search tree" |
|---|
| 14 | value ;; list of objects with equal key |
|---|
| 15 | num-elements ;; size of the value set |
|---|
| 16 | key ;; f-cost of the a-star-nodes |
|---|
| 17 | parent ;; parent of search-tree-node |
|---|
| 18 | leftson ;; direction of search-tree-nodes with lesser f-cost |
|---|
| 19 | rightson ;; direction of search-tree-nodes with greater f-cost |
|---|
| 20 | ) |
|---|
| 21 | |
|---|
| 22 | |
|---|
| 23 | |
|---|
| 24 | (defun make-search-tree (root-elem root-key &aux root) |
|---|
| 25 | "return dummy header for binary search tree, with initial |
|---|
| 26 | element root-elem whose key is root-key." |
|---|
| 27 | (setq root |
|---|
| 28 | (make-search-tree-node |
|---|
| 29 | :value nil |
|---|
| 30 | :parent nil |
|---|
| 31 | :rightson nil |
|---|
| 32 | :leftson (make-search-tree-node |
|---|
| 33 | :value (list root-elem) |
|---|
| 34 | :num-elements 1 |
|---|
| 35 | :key root-key |
|---|
| 36 | :leftson nil :rightson nil))) |
|---|
| 37 | (setf (search-tree-node-parent |
|---|
| 38 | (search-tree-node-leftson root)) root) |
|---|
| 39 | root) |
|---|
| 40 | |
|---|
| 41 | |
|---|
| 42 | |
|---|
| 43 | (defun create-sorted-tree (list-of-elems key-fun &aux root-elem root) |
|---|
| 44 | "return binary search tree containing list-of-elems ordered according |
|---|
| 45 | tp key-fun" |
|---|
| 46 | (if (null list-of-elems) |
|---|
| 47 | nil |
|---|
| 48 | (progn |
|---|
| 49 | (setq root-elem (nth (random (length list-of-elems)) list-of-elems)) |
|---|
| 50 | (setq list-of-elems (remove root-elem list-of-elems :test #'eq)) |
|---|
| 51 | (setq root (make-search-tree root-elem |
|---|
| 52 | (funcall key-fun root-elem))) |
|---|
| 53 | (dolist (elem list-of-elems) |
|---|
| 54 | (insert-element elem root (funcall key-fun elem))) |
|---|
| 55 | root))) |
|---|
| 56 | |
|---|
| 57 | |
|---|
| 58 | |
|---|
| 59 | (defun empty-tree (root) |
|---|
| 60 | "Predicate of search trees; return t iff empty." |
|---|
| 61 | (null (search-tree-node-leftson root))) |
|---|
| 62 | |
|---|
| 63 | |
|---|
| 64 | |
|---|
| 65 | (defun leftmost (tree-node &aux next) |
|---|
| 66 | "return leftmost descendant of tree-node" |
|---|
| 67 | ;; used by pop-least-element and inorder-successor |
|---|
| 68 | (loop (if (null (setq next (search-tree-node-leftson tree-node))) |
|---|
| 69 | (return tree-node) |
|---|
| 70 | (setq tree-node next)))) |
|---|
| 71 | |
|---|
| 72 | |
|---|
| 73 | |
|---|
| 74 | (defun rightmost (header &aux next tree-node) |
|---|
| 75 | "return rightmost descendant of header" |
|---|
| 76 | ;; used by pop-largest-element |
|---|
| 77 | ;; recall that root of tree is leftson of header, which is a dummy |
|---|
| 78 | (setq tree-node (search-tree-node-leftson header)) |
|---|
| 79 | (loop (if (null (setq next (search-tree-node-rightson tree-node))) |
|---|
| 80 | (return tree-node) |
|---|
| 81 | (setq tree-node next)))) |
|---|
| 82 | |
|---|
| 83 | |
|---|
| 84 | |
|---|
| 85 | (defun pop-least-element (header) |
|---|
| 86 | "return least element of binary search tree; delete from tree as side-effect" |
|---|
| 87 | ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of |
|---|
| 88 | ;; which have same f-cost = key slot of search-tree-node. This function |
|---|
| 89 | ;; arbitrarily returns first element of list with smallest f-cost, |
|---|
| 90 | ;; then deletes it from the list. If it was the last element of the list |
|---|
| 91 | ;; for the node with smallest key, that node is deleted from the search |
|---|
| 92 | ;; tree. (That's why we have a pointer to the node's parent). |
|---|
| 93 | ;; Node with smallest f-cost is leftmost descendant of header. |
|---|
| 94 | (let* ( (place (leftmost header)) |
|---|
| 95 | (result (pop (search-tree-node-value place))) ) |
|---|
| 96 | (decf (search-tree-node-num-elements place)) |
|---|
| 97 | (when (null (search-tree-node-value place)) |
|---|
| 98 | (when (search-tree-node-rightson place) |
|---|
| 99 | (setf (search-tree-node-parent |
|---|
| 100 | (search-tree-node-rightson place)) |
|---|
| 101 | (search-tree-node-parent place))) |
|---|
| 102 | (setf (search-tree-node-leftson |
|---|
| 103 | (search-tree-node-parent place)) |
|---|
| 104 | (search-tree-node-rightson place))) |
|---|
| 105 | result)) |
|---|
| 106 | |
|---|
| 107 | |
|---|
| 108 | |
|---|
| 109 | |
|---|
| 110 | (defun pop-largest-element (header) |
|---|
| 111 | "return largest element of binary search tree; delete from tree as side-effect" |
|---|
| 112 | ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of |
|---|
| 113 | ;; which have same key slot of search-tree-node. This function |
|---|
| 114 | ;; arbitrarily returns first element of list with largest key |
|---|
| 115 | ;; then deletes it from the list. If it was the last element of the list |
|---|
| 116 | ;; for the node with largest key, that node is deleted from the search |
|---|
| 117 | ;; tree. We need to take special account of the case when the largest element |
|---|
| 118 | ;; is the last element in the root node of the search-tree. In this case, it |
|---|
| 119 | ;; will be in the leftson of the dummy header. In all other cases, |
|---|
| 120 | ;; it will be in the rightson of its parent. |
|---|
| 121 | (let* ( (place (rightmost header)) |
|---|
| 122 | (result (pop (search-tree-node-value place))) ) |
|---|
| 123 | (decf (search-tree-node-num-elements place)) |
|---|
| 124 | (when (null (search-tree-node-value place)) |
|---|
| 125 | (cond ( (eq place (search-tree-node-leftson header)) |
|---|
| 126 | (setf (search-tree-node-leftson header) |
|---|
| 127 | (search-tree-node-leftson place)) ) |
|---|
| 128 | (t (when (search-tree-node-leftson place) |
|---|
| 129 | (setf (search-tree-node-parent |
|---|
| 130 | (search-tree-node-leftson place)) |
|---|
| 131 | (search-tree-node-parent place))) |
|---|
| 132 | (setf (search-tree-node-rightson |
|---|
| 133 | (search-tree-node-parent place)) |
|---|
| 134 | (search-tree-node-leftson place))))) |
|---|
| 135 | result)) |
|---|
| 136 | |
|---|
| 137 | |
|---|
| 138 | |
|---|
| 139 | |
|---|
| 140 | (defun least-key (header) |
|---|
| 141 | "return least key of binary search tree; no side effects" |
|---|
| 142 | (search-tree-node-key (leftmost header))) |
|---|
| 143 | |
|---|
| 144 | |
|---|
| 145 | (defun largest-key (header) |
|---|
| 146 | "return least key of binary search tree; no side effects" |
|---|
| 147 | (search-tree-node-key (rightmost header))) |
|---|
| 148 | |
|---|
| 149 | |
|---|
| 150 | |
|---|
| 151 | (defun insert-element (element parent key |
|---|
| 152 | &optional (direction #'search-tree-node-leftson) |
|---|
| 153 | &aux place) |
|---|
| 154 | "insert new element at proper place in binary search tree" |
|---|
| 155 | ;; See Reingold and Hansen, Data Structures, sect. 7.2. |
|---|
| 156 | ;; When called initially, parent will be the header, hence go left. |
|---|
| 157 | ;; Element is an a-star-node. If tree node with key = f-cost of |
|---|
| 158 | ;; element already exists, just push element onto list in that |
|---|
| 159 | ;; node's value slot. Else have to make new tree node. |
|---|
| 160 | (loop (cond ( (null (setq place (funcall direction parent))) |
|---|
| 161 | (let ( (new-node (make-search-tree-node |
|---|
| 162 | :value (list element) :num-elements 1 |
|---|
| 163 | :parent parent :key key |
|---|
| 164 | :leftson nil :rightson nil)) ) |
|---|
| 165 | (if (eq direction #'search-tree-node-leftson) |
|---|
| 166 | (setf (search-tree-node-leftson parent) new-node) |
|---|
| 167 | (setf (search-tree-node-rightson parent) new-node))) |
|---|
| 168 | (return t)) |
|---|
| 169 | ( (= key (search-tree-node-key place)) |
|---|
| 170 | (push element (search-tree-node-value place)) |
|---|
| 171 | (incf (search-tree-node-num-elements place)) |
|---|
| 172 | (return t)) |
|---|
| 173 | ( (< key (search-tree-node-key place)) |
|---|
| 174 | (setq parent place) |
|---|
| 175 | (setq direction #'search-tree-node-leftson) ) |
|---|
| 176 | (t (setq parent place) |
|---|
| 177 | (setq direction #'search-tree-node-rightson))))) |
|---|
| 178 | |
|---|
| 179 | |
|---|
| 180 | |
|---|
| 181 | |
|---|
| 182 | (defun randomized-insert-element (element parent key |
|---|
| 183 | &optional (direction #'search-tree-node-leftson) |
|---|
| 184 | &aux place) |
|---|
| 185 | "insert new element at proper place in binary search tree -- break |
|---|
| 186 | ties randomly" |
|---|
| 187 | ;; This is just like the above, except that elements with equal keys |
|---|
| 188 | ;; are shuffled randomly. Not a "perfect shuffle", but the point is |
|---|
| 189 | ;; just to randomize whenever an arbitrary choice is to be made. |
|---|
| 190 | |
|---|
| 191 | (loop (cond ( (null (setq place (funcall direction parent))) |
|---|
| 192 | (let ( (new-node (make-search-tree-node |
|---|
| 193 | :value (list element) :num-elements 1 |
|---|
| 194 | :parent parent :key key |
|---|
| 195 | :leftson nil :rightson nil)) ) |
|---|
| 196 | (if (eq direction #'search-tree-node-leftson) |
|---|
| 197 | (setf (search-tree-node-leftson parent) new-node) |
|---|
| 198 | (setf (search-tree-node-rightson parent) new-node))) |
|---|
| 199 | (return t)) |
|---|
| 200 | ( (= key (search-tree-node-key place)) |
|---|
| 201 | (setf (search-tree-node-value place) |
|---|
| 202 | (randomized-push element (search-tree-node-value place))) |
|---|
| 203 | (incf (search-tree-node-num-elements place)) |
|---|
| 204 | (return t)) |
|---|
| 205 | ( (< key (search-tree-node-key place)) |
|---|
| 206 | (setq parent place) |
|---|
| 207 | (setq direction #'search-tree-node-leftson) ) |
|---|
| 208 | (t (setq parent place) |
|---|
| 209 | (setq direction #'search-tree-node-rightson))))) |
|---|
| 210 | |
|---|
| 211 | |
|---|
| 212 | |
|---|
| 213 | |
|---|
| 214 | (defun randomized-push (element list) |
|---|
| 215 | "return list with element destructively inserted at random into list" |
|---|
| 216 | (let ((n (random (+ 1 (length list)))) ) |
|---|
| 217 | (cond ((= 0 n) |
|---|
| 218 | (cons element list)) |
|---|
| 219 | (t (push element (cdr (nthcdr (- n 1) list))) |
|---|
| 220 | list)))) |
|---|
| 221 | |
|---|
| 222 | |
|---|
| 223 | |
|---|
| 224 | |
|---|
| 225 | (defun find-element (element parent key |
|---|
| 226 | &optional (direction #'search-tree-node-leftson) |
|---|
| 227 | &aux place) |
|---|
| 228 | "return t if element is int tree" |
|---|
| 229 | (loop (cond ( (null (setq place (funcall direction parent))) |
|---|
| 230 | (return nil) ) |
|---|
| 231 | ( (= key (search-tree-node-key place)) |
|---|
| 232 | (return (find element (search-tree-node-value place) |
|---|
| 233 | :test #'eq)) ) |
|---|
| 234 | ( (< key (search-tree-node-key place)) |
|---|
| 235 | (setq parent place) |
|---|
| 236 | (setq direction #'search-tree-node-leftson) ) |
|---|
| 237 | (t (setq parent place) |
|---|
| 238 | (setq direction #'search-tree-node-rightson))))) |
|---|
| 239 | |
|---|
| 240 | |
|---|
| 241 | |
|---|
| 242 | |
|---|
| 243 | |
|---|
| 244 | (defun delete-element (element parent key &optional (error-p t) |
|---|
| 245 | &aux (direction #'search-tree-node-leftson) |
|---|
| 246 | place) |
|---|
| 247 | "delete element from binary search tree" |
|---|
| 248 | ;; When called initially, parent will be the header. |
|---|
| 249 | ;; Have to search for node containing element, using key, also |
|---|
| 250 | ;; keep track of parent of node. Delete element from list for |
|---|
| 251 | ;; node; if it's the last element on that list, delete node from |
|---|
| 252 | ;; binary tree. See Reingold and Hansen, Data Structures, pp. 301, 309. |
|---|
| 253 | ;; if error-p is t, signals error if element not found; else just |
|---|
| 254 | ;; returns t if element found, nil otherwise. |
|---|
| 255 | (loop (setq place (funcall direction parent)) |
|---|
| 256 | (cond ( (null place) (if error-p |
|---|
| 257 | (error "delete-element: element not found") |
|---|
| 258 | (return nil)) ) |
|---|
| 259 | ( (= key (search-tree-node-key place)) |
|---|
| 260 | (cond ( (find element (search-tree-node-value place) :test #'eq) |
|---|
| 261 | ;; In this case we've found the right binary |
|---|
| 262 | ;; search-tree node, so we should delete the |
|---|
| 263 | ;; element from the list of nodes |
|---|
| 264 | (setf (search-tree-node-value place) |
|---|
| 265 | (remove element (search-tree-node-value place) |
|---|
| 266 | :test #'eq)) |
|---|
| 267 | (decf (search-tree-node-num-elements place)) |
|---|
| 268 | (when (null (search-tree-node-value place)) |
|---|
| 269 | ;; If we've deleted the last element, we |
|---|
| 270 | ;; should delete the node from the binary search tree. |
|---|
| 271 | (cond ( (null (search-tree-node-leftson place)) |
|---|
| 272 | ;; If place has no leftson sub-tree, replace it |
|---|
| 273 | ;; by its right sub-tree. |
|---|
| 274 | (when (search-tree-node-rightson place) |
|---|
| 275 | (setf (search-tree-node-parent |
|---|
| 276 | (search-tree-node-rightson place)) |
|---|
| 277 | parent)) |
|---|
| 278 | (if (eq direction #'search-tree-node-leftson) |
|---|
| 279 | (setf (search-tree-node-leftson parent) |
|---|
| 280 | (search-tree-node-rightson place)) |
|---|
| 281 | (setf (search-tree-node-rightson parent) |
|---|
| 282 | (search-tree-node-rightson place))) ) |
|---|
| 283 | ( (null (search-tree-node-rightson place) ) |
|---|
| 284 | ;; Else if place has no right sub-tree, |
|---|
| 285 | ;; replace it by its left sub-tree. |
|---|
| 286 | (when (search-tree-node-leftson place) |
|---|
| 287 | (setf (search-tree-node-parent |
|---|
| 288 | (search-tree-node-leftson place)) |
|---|
| 289 | parent)) |
|---|
| 290 | (if (eq direction #'search-tree-node-leftson) |
|---|
| 291 | (setf (search-tree-node-leftson parent) |
|---|
| 292 | (search-tree-node-leftson place)) |
|---|
| 293 | (setf (search-tree-node-rightson parent) |
|---|
| 294 | (search-tree-node-leftson place))) ) |
|---|
| 295 | (t ;; Else find the "inorder-successor" of |
|---|
| 296 | ;; place, which must have nil leftson. |
|---|
| 297 | ;; Let it replace place, making its left |
|---|
| 298 | ;; sub-tree be place's current left |
|---|
| 299 | ;; sub-tree, and replace it by its own |
|---|
| 300 | ;; right sub-tree. (For details, see |
|---|
| 301 | ;; Reingold & Hansen, Data Structures, p. 301.) |
|---|
| 302 | (let ( (next (inorder-successor place)) ) |
|---|
| 303 | (setf (search-tree-node-leftson next) |
|---|
| 304 | (search-tree-node-leftson place)) |
|---|
| 305 | (setf (search-tree-node-parent |
|---|
| 306 | (search-tree-node-leftson next)) |
|---|
| 307 | next) |
|---|
| 308 | (if (eq direction #'search-tree-node-leftson) |
|---|
| 309 | (setf (search-tree-node-leftson |
|---|
| 310 | parent) next) |
|---|
| 311 | (setf (search-tree-node-rightson parent) |
|---|
| 312 | next)) |
|---|
| 313 | (unless (eq next (search-tree-node-rightson |
|---|
| 314 | place)) |
|---|
| 315 | (setf (search-tree-node-leftson |
|---|
| 316 | (search-tree-node-parent next)) |
|---|
| 317 | (search-tree-node-rightson next)) |
|---|
| 318 | (when (search-tree-node-rightson next) |
|---|
| 319 | (setf (search-tree-node-parent |
|---|
| 320 | (search-tree-node-rightson next)) |
|---|
| 321 | (search-tree-node-parent next))) |
|---|
| 322 | (setf (search-tree-node-rightson next) |
|---|
| 323 | (search-tree-node-rightson |
|---|
| 324 | place)) |
|---|
| 325 | (setf (search-tree-node-parent |
|---|
| 326 | (search-tree-node-rightson next)) |
|---|
| 327 | next)) |
|---|
| 328 | (setf (search-tree-node-parent next) |
|---|
| 329 | (search-tree-node-parent place)))))) |
|---|
| 330 | (return t)) |
|---|
| 331 | (t (if error-p |
|---|
| 332 | (error "delete-element: element not found") |
|---|
| 333 | (return nil)))) ) |
|---|
| 334 | ( (< key (search-tree-node-key place)) |
|---|
| 335 | (setq parent place) |
|---|
| 336 | (setq direction #'search-tree-node-leftson)) |
|---|
| 337 | (t (setq parent place) |
|---|
| 338 | (setq direction #'search-tree-node-rightson))))) |
|---|
| 339 | |
|---|
| 340 | |
|---|
| 341 | |
|---|
| 342 | |
|---|
| 343 | |
|---|
| 344 | (defun inorder-successor (tree-node) |
|---|
| 345 | "return inorder-successor of tree-node assuming it has a right son" |
|---|
| 346 | ;; this is used by function delete-element when deleting a node from |
|---|
| 347 | ;; the binary search tree. See Reingold and Hansen, pp. 301, 309. |
|---|
| 348 | ;; The inorder-successor is the leftmost descendant of the rightson. |
|---|
| 349 | (leftmost (search-tree-node-rightson tree-node))) |
|---|
| 350 | |
|---|
| 351 | |
|---|
| 352 | |
|---|
| 353 | (defun list-elements (parent &aux child) |
|---|
| 354 | "return list of elements in tree" |
|---|
| 355 | (append (when (setq child (search-tree-node-leftson parent)) |
|---|
| 356 | (list-elements child)) |
|---|
| 357 | (search-tree-node-value parent) |
|---|
| 358 | (when (setq child (search-tree-node-rightson parent)) |
|---|
| 359 | (list-elements child)))) |
|---|
