;;; 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))))