;;; File: binary-tree.lisp -*- Mode: Lisp; Syntax: Common-Lisp -*- ;;;; The following definitions implement binary search trees. ;;; They are not balanced as yet. Currently, they all order their ;;; elements by #'<, and test for identity of elements by #'eq. (defstruct search-tree-node "node for binary search tree" value ;; list of objects with equal key num-elements ;; size of the value set key ;; f-cost of the a-star-nodes parent ;; parent of search-tree-node leftson ;; direction of search-tree-nodes with lesser f-cost rightson ;; direction of search-tree-nodes with greater f-cost ) (defun make-search-tree (root-elem root-key &aux root) "return dummy header for binary search tree, with initial element root-elem whose key is root-key." (setq root (make-search-tree-node :value nil :parent nil :rightson nil :leftson (make-search-tree-node :value (list root-elem) :num-elements 1 :key root-key :leftson nil :rightson nil))) (setf (search-tree-node-parent (search-tree-node-leftson root)) root) root) (defun create-sorted-tree (list-of-elems key-fun &aux root-elem root) "return binary search tree containing list-of-elems ordered according tp key-fun" (if (null list-of-elems) nil (progn (setq root-elem (nth (random (length list-of-elems)) list-of-elems)) (setq list-of-elems (remove root-elem list-of-elems :test #'eq)) (setq root (make-search-tree root-elem (funcall key-fun root-elem))) (dolist (elem list-of-elems) (insert-element elem root (funcall key-fun elem))) root))) (defun empty-tree (root) "Predicate of search trees; return t iff empty." (null (search-tree-node-leftson root))) (defun leftmost (tree-node &aux next) "return leftmost descendant of tree-node" ;; used by pop-least-element and inorder-successor (loop (if (null (setq next (search-tree-node-leftson tree-node))) (return tree-node) (setq tree-node next)))) (defun rightmost (header &aux next tree-node) "return rightmost descendant of header" ;; used by pop-largest-element ;; recall that root of tree is leftson of header, which is a dummy (setq tree-node (search-tree-node-leftson header)) (loop (if (null (setq next (search-tree-node-rightson tree-node))) (return tree-node) (setq tree-node next)))) (defun pop-least-element (header) "return least element of binary search tree; delete from tree as side-effect" ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of ;; which have same f-cost = key slot of search-tree-node. This function ;; arbitrarily returns first element of list with smallest f-cost, ;; then deletes it from the list. If it was the last element of the list ;; for the node with smallest key, that node is deleted from the search ;; tree. (That's why we have a pointer to the node's parent). ;; Node with smallest f-cost is leftmost descendant of header. (let* ( (place (leftmost header)) (result (pop (search-tree-node-value place))) ) (decf (search-tree-node-num-elements place)) (when (null (search-tree-node-value place)) (when (search-tree-node-rightson place) (setf (search-tree-node-parent (search-tree-node-rightson place)) (search-tree-node-parent place))) (setf (search-tree-node-leftson (search-tree-node-parent place)) (search-tree-node-rightson place))) result)) (defun pop-largest-element (header) "return largest element of binary search tree; delete from tree as side-effect" ;; Note value slots of search-tree-nodes are lists of a-star-nodes, all of ;; which have same key slot of search-tree-node. This function ;; arbitrarily returns first element of list with largest key ;; then deletes it from the list. If it was the last element of the list ;; for the node with largest key, that node is deleted from the search ;; tree. We need to take special account of the case when the largest element ;; is the last element in the root node of the search-tree. In this case, it ;; will be in the leftson of the dummy header. In all other cases, ;; it will be in the rightson of its parent. (let* ( (place (rightmost header)) (result (pop (search-tree-node-value place))) ) (decf (search-tree-node-num-elements place)) (when (null (search-tree-node-value place)) (cond ( (eq place (search-tree-node-leftson header)) (setf (search-tree-node-leftson header) (search-tree-node-leftson place)) ) (t (when (search-tree-node-leftson place) (setf (search-tree-node-parent (search-tree-node-leftson place)) (search-tree-node-parent place))) (setf (search-tree-node-rightson (search-tree-node-parent place)) (search-tree-node-leftson place))))) result)) (defun least-key (header) "return least key of binary search tree; no side effects" (search-tree-node-key (leftmost header))) (defun largest-key (header) "return least key of binary search tree; no side effects" (search-tree-node-key (rightmost header))) (defun insert-element (element parent key &optional (direction #'search-tree-node-leftson) &aux place) "insert new element at proper place in binary search tree" ;; See Reingold and Hansen, Data Structures, sect. 7.2. ;; When called initially, parent will be the header, hence go left. ;; Element is an a-star-node. If tree node with key = f-cost of ;; element already exists, just push element onto list in that ;; node's value slot. Else have to make new tree node. (loop (cond ( (null (setq place (funcall direction parent))) (let ( (new-node (make-search-tree-node :value (list element) :num-elements 1 :parent parent :key key :leftson nil :rightson nil)) ) (if (eq direction #'search-tree-node-leftson) (setf (search-tree-node-leftson parent) new-node) (setf (search-tree-node-rightson parent) new-node))) (return t)) ( (= key (search-tree-node-key place)) (push element (search-tree-node-value place)) (incf (search-tree-node-num-elements place)) (return t)) ( (< key (search-tree-node-key place)) (setq parent place) (setq direction #'search-tree-node-leftson) ) (t (setq parent place) (setq direction #'search-tree-node-rightson))))) (defun randomized-insert-element (element parent key &optional (direction #'search-tree-node-leftson) &aux place) "insert new element at proper place in binary search tree -- break ties randomly" ;; This is just like the above, except that elements with equal keys ;; are shuffled randomly. Not a "perfect shuffle", but the point is ;; just to randomize whenever an arbitrary choice is to be made. (loop (cond ( (null (setq place (funcall direction parent))) (let ( (new-node (make-search-tree-node :value (list element) :num-elements 1 :parent parent :key key :leftson nil :rightson nil)) ) (if (eq direction #'search-tree-node-leftson) (setf (search-tree-node-leftson parent) new-node) (setf (search-tree-node-rightson parent) new-node))) (return t)) ( (= key (search-tree-node-key place)) (setf (search-tree-node-value place) (randomized-push element (search-tree-node-value place))) (incf (search-tree-node-num-elements place)) (return t)) ( (< key (search-tree-node-key place)) (setq parent place) (setq direction #'search-tree-node-leftson) ) (t (setq parent place) (setq direction #'search-tree-node-rightson))))) (defun randomized-push (element list) "return list with element destructively inserted at random into list" (let ((n (random (+ 1 (length list)))) ) (cond ((= 0 n) (cons element list)) (t (push element (cdr (nthcdr (- n 1) list))) list)))) (defun find-element (element parent key &optional (direction #'search-tree-node-leftson) &aux place) "return t if element is int tree" (loop (cond ( (null (setq place (funcall direction parent))) (return nil) ) ( (= key (search-tree-node-key place)) (return (find element (search-tree-node-value place) :test #'eq)) ) ( (< key (search-tree-node-key place)) (setq parent place) (setq direction #'search-tree-node-leftson) ) (t (setq parent place) (setq direction #'search-tree-node-rightson))))) (defun delete-element (element parent key &optional (error-p t) &aux (direction #'search-tree-node-leftson) place) "delete element from binary search tree" ;; When called initially, parent will be the header. ;; Have to search for node containing element, using key, also ;; keep track of parent of node. Delete element from list for ;; node; if it's the last element on that list, delete node from ;; binary tree. See Reingold and Hansen, Data Structures, pp. 301, 309. ;; if error-p is t, signals error if element not found; else just ;; returns t if element found, nil otherwise. (loop (setq place (funcall direction parent)) (cond ( (null place) (if error-p (error "delete-element: element not found") (return nil)) ) ( (= key (search-tree-node-key place)) (cond ( (find element (search-tree-node-value place) :test #'eq) ;; In this case we've found the right binary ;; search-tree node, so we should delete the ;; element from the list of nodes (setf (search-tree-node-value place) (remove element (search-tree-node-value place) :test #'eq)) (decf (search-tree-node-num-elements place)) (when (null (search-tree-node-value place)) ;; If we've deleted the last element, we ;; should delete the node from the binary search tree. (cond ( (null (search-tree-node-leftson place)) ;; If place has no leftson sub-tree, replace it ;; by its right sub-tree. (when (search-tree-node-rightson place) (setf (search-tree-node-parent (search-tree-node-rightson place)) parent)) (if (eq direction #'search-tree-node-leftson) (setf (search-tree-node-leftson parent) (search-tree-node-rightson place)) (setf (search-tree-node-rightson parent) (search-tree-node-rightson place))) ) ( (null (search-tree-node-rightson place) ) ;; Else if place has no right sub-tree, ;; replace it by its left sub-tree. (when (search-tree-node-leftson place) (setf (search-tree-node-parent (search-tree-node-leftson place)) parent)) (if (eq direction #'search-tree-node-leftson) (setf (search-tree-node-leftson parent) (search-tree-node-leftson place)) (setf (search-tree-node-rightson parent) (search-tree-node-leftson place))) ) (t ;; Else find the "inorder-successor" of ;; place, which must have nil leftson. ;; Let it replace place, making its left ;; sub-tree be place's current left ;; sub-tree, and replace it by its own ;; right sub-tree. (For details, see ;; Reingold & Hansen, Data Structures, p. 301.) (let ( (next (inorder-successor place)) ) (setf (search-tree-node-leftson next) (search-tree-node-leftson place)) (setf (search-tree-node-parent (search-tree-node-leftson next)) next) (if (eq direction #'search-tree-node-leftson) (setf (search-tree-node-leftson parent) next) (setf (search-tree-node-rightson parent) next)) (unless (eq next (search-tree-node-rightson place)) (setf (search-tree-node-leftson (search-tree-node-parent next)) (search-tree-node-rightson next)) (when (search-tree-node-rightson next) (setf (search-tree-node-parent (search-tree-node-rightson next)) (search-tree-node-parent next))) (setf (search-tree-node-rightson next) (search-tree-node-rightson place)) (setf (search-tree-node-parent (search-tree-node-rightson next)) next)) (setf (search-tree-node-parent next) (search-tree-node-parent place)))))) (return t)) (t (if error-p (error "delete-element: element not found") (return nil)))) ) ( (< key (search-tree-node-key place)) (setq parent place) (setq direction #'search-tree-node-leftson)) (t (setq parent place) (setq direction #'search-tree-node-rightson))))) (defun inorder-successor (tree-node) "return inorder-successor of tree-node assuming it has a right son" ;; this is used by function delete-element when deleting a node from ;; the binary search tree. See Reingold and Hansen, pp. 301, 309. ;; The inorder-successor is the leftmost descendant of the rightson. (leftmost (search-tree-node-rightson tree-node))) (defun list-elements (parent &aux child) "return list of elements in tree" (append (when (setq child (search-tree-node-leftson parent)) (list-elements child)) (search-tree-node-value parent) (when (setq child (search-tree-node-rightson parent)) (list-elements child))))