-
-\f
-;;;; AA Trees
-
-;;; An AA tree is a red-black tree with the extra condition that left
-;;; children may not be red. This condition simplifies the red-black
-;;; algorithm. It eliminates half of the restructuring cases, and
-;;; simplifies the delete algorithm.
-
-(defstruct (aa-node (:conc-name aa-))
- (left nil :type (or null aa-node))
- (right nil :type (or null aa-node))
- (level 0 :type integer)
- (data nil :type t))
-
-(defvar *null-node*
- (let ((node (make-aa-node)))
- (setf (aa-left node) node)
- (setf (aa-right node) node)
- node))
-
-(defstruct aa-tree
- (root *null-node* :type aa-node))
-
-(declaim (inline skew split rotate-with-left-child rotate-with-right-child))
-
-(defun rotate-with-left-child (k2)
- (let ((k1 (aa-left k2)))
- (setf (aa-left k2) (aa-right k1))
- (setf (aa-right k1) k2)
- k1))
-
-(defun rotate-with-right-child (k1)
- (let ((k2 (aa-right k1)))
- (setf (aa-right k1) (aa-left k2))
- (setf (aa-left k2) k1)
- k2))
-
-(defun skew (aa)
- (if (= (aa-level (aa-left aa)) (aa-level aa))
- (rotate-with-left-child aa)
- aa))
-
-(defun split (aa)
- (when (= (aa-level (aa-right (aa-right aa)))
- (aa-level aa))
- (setq aa (rotate-with-right-child aa))
- (incf (aa-level aa)))
- aa)
-
-(macrolet ((def (name () &body body)
- (let ((name (sb-int::symbolicate 'aa- name)))
- `(defun ,name (item tree &key
- (test-< #'<) (test-= #'=)
- (node-key #'identity) (item-key #'identity))
- (let ((.item-key. (funcall item-key item)))
- (flet ((item-< (node)
- (funcall test-< .item-key.
- (funcall node-key (aa-data node))))
- (item-= (node)
- (funcall test-= .item-key.
- (funcall node-key (aa-data node)))))
- (declare (inline item-< item-=))
- ,@body))))))
-
- (def insert ()
- (labels ((insert-into (aa)
- (cond ((eq aa *null-node*)
- (setq aa (make-aa-node :data item
- :left *null-node*
- :right *null-node*)))
- ((item-= aa)
- (return-from insert-into aa))
- ((item-< aa)
- (setf (aa-left aa) (insert-into (aa-left aa))))
- (t
- (setf (aa-right aa) (insert-into (aa-right aa)))))
- (split (skew aa))))
- (setf (aa-tree-root tree)
- (insert-into (aa-tree-root tree)))))
-
- (def delete ()
- (let ((deleted-node *null-node*)
- (last-node nil))
- (labels ((remove-from (aa)
- (unless (eq aa *null-node*)
- (setq last-node aa)
- (if (item-< aa)
- (setf (aa-left aa) (remove-from (aa-left aa)))
- (progn
- (setq deleted-node aa)
- (setf (aa-right aa) (remove-from (aa-right aa)))))
- (cond ((eq aa last-node)
- ;;
- ;; If at the bottom of the tree, and item
- ;; is present, delete it.
- (when (and (not (eq deleted-node *null-node*))
- (item-= deleted-node))
- (setf (aa-data deleted-node) (aa-data aa))
- (setq deleted-node *null-node*)
- (setq aa (aa-right aa))))
- ;;
- ;; Otherwise not at bottom of tree; rebalance.
- ((or (< (aa-level (aa-left aa))
- (1- (aa-level aa)))
- (< (aa-level (aa-right aa))
- (1- (aa-level aa))))
- (decf (aa-level aa))
- (when (> (aa-level (aa-right aa)) (aa-level aa))
- (setf (aa-level (aa-right aa)) (aa-level aa)))
- (setq aa (skew aa))
- (setf (aa-right aa) (skew (aa-right aa)))
- (setf (aa-right (aa-right aa))
- (skew (aa-right (aa-right aa))))
- (setq aa (split aa))
- (setf (aa-right aa) (split (aa-right aa))))))
- aa))
- (setf (aa-tree-root tree)
- (remove-from (aa-tree-root tree))))))
-
- (def find ()
- (let ((current (aa-tree-root tree)))
- (setf (aa-data *null-node*) item)
- (loop
- (cond ((eq current *null-node*)
- (return (values nil nil)))
- ((item-= current)
- (return (values (aa-data current) t)))
- ((item-< current)
- (setq current (aa-left current)))
- (t
- (setq current (aa-right current))))))))
-
-\f
-;;;; Other Utilities
-
-;;; Sort the subsequence of Vec in the interval [From To] using
-;;; comparison function Test. Assume each element to sort consists of
-;;; Element-Size array slots, and that the slot Key-Offset contains
-;;; the sort key.
-(defun qsort (vec &key (element-size 1) (key-offset 0)
- (from 0) (to (- (length vec) element-size)))
- (declare (type fixnum to from element-size key-offset))
- (declare (type (simple-array address) vec))
- (labels ((rotate (i j)
- (declare (fixnum i j))
- (loop repeat element-size
- for i from i and j from j do
- (rotatef (aref vec i) (aref vec j))))
- (key (i)
- (aref vec (+ i key-offset)))
- (rec-sort (from to)
- (declare (fixnum to from))
- (when (> to from)
- (let* ((mid (* element-size
- (round (+ (/ from element-size)
- (/ to element-size))
- 2)))
- (i from)
- (j (+ to element-size))
- (p (key mid)))
- (declare (fixnum mid i j))
- (rotate mid from)
- (loop
- (loop do (incf i element-size)
- until (or (> i to)
- ;; QSORT used to take a test
- ;; parameter which was funcalled
- ;; here. This caused some consing,
- ;; which is problematic since
- ;; QSORT is indirectly called in
- ;; an after-gc-hook. So just
- ;; hardcode >, which would've been
- ;; used for the test anyway.
- ;; --JES, 2004-07-09
- (> p (key i))))
- (loop do (decf j element-size)
- until (or (<= j from)
- ;; As above.
- (> (key j) p)))
- (when (< j i) (return))
- (rotate i j))
- (rotate from j)
- (rec-sort from (- j element-size))
- (rec-sort i to)))))
- (rec-sort from to)
- vec))
-