--- /dev/null
+*.fasl
+*.FASL
+*.ufasl
+*.ufsl
+*.dx32fsl
+*.dx64fsl
+*.pfsl
+*.dfsl
+*.p64fsl
+*.d64fsl
+*.lx32fsl
+*.lx64fsl
+*.fx32fsl
+*.fx64fsl
+*.fas
+*.lib
+*~
--- /dev/null
+Copyright (c) 2004, Nathan Froyd
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+* Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+* Neither the name of Nathan Froyd nor the names of the contributors
+to this software may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+-*- mode: outline -*-
+
+* Version 0.11, released 17-05-2008
+
+** bugfixes
+
+Fixed an issue with Lispworks and AVL trees. (Thanks to Gregory Tod.)
+
+Removed calls to SLOT-BOUNDP in node printing functions. (Thanks to cmm
+on #lisp.)
+
+** improvements
+
+Converted trees to be structure-based, rather than CLOS-based. Also
+restructured things so that INSERT/DELETE/FIND are regular functions
+rather than generic functions. Significant speedups were obtained while
+benchmarking these changes.
+
+* Version 0.10, released 18-03-2008
+
+This version is a near-total rewrite, with all the incompatibilities
+such a release brings. Please refer to generics.lisp for some details
+on what you might have to do to fix your code, and do note that
+DO-TREE-RANGE and WITH-TREE-ITERATOR have been removed for the time
+being.
+
+* Version 0.6.2, released 30-07-2006
+
+** bugfixes
+
+Fixed bogus DO form in WITH-TREE-ITERATOR. (Thanks to Daniel Franke.)
+
+** incompatible changes
+
+The two return values from ITER in WITH-TREE-ITERATOR have been swapped
+to more closely mimic the semantics of the iterator in
+WITH-HASH-TABLE-ITERATOR. While this is an incompatible change, it is
+unlikely anybody will care, since WITH-TREE-ITERATOR was broken in
+previous releases anyway.
+
+* Version 0.6.1, released 09-01-2006
+
+** bugfixes
+
+Fix three-argument call to EQ in MAXIMUM-NODE. (Thanks to Markus
+Ingvarsson.)
+
+* Version 0.6, released 19-12-2005
+
+** bugfixes
+
+Fixed syntax problems preventing ASDF-INSTALL from working.
+
+Fixed problems with tree rotation code.
+
+** improvements
+
+Major functions exported from TREES (FIND, INSERT, DELETE) are now
+generic functions; this change enables support of future search tree types.
+
+* Version 0.5, released 11-02-2005
+
+** bugfixes
+
+Peter Slotko contributed fixes for the following problems:
+
+DO-TREE-RANGE would produce unexpected behavior with this example:
+
+;; *tree* contains 11, 17, 21, 25, and 30
+(trees:do-tree-range (x *tree* :lower 15 :upper 18)
+ (print x))
+
+=> 11
+ 17
+ NIL
+
+The documentation strings for some functions were incorrect.
+
+** new features
+
+Minor optimizations have been made in some places.
+
+* Version 0.4, released 10-03-2004
+
+** incompatible changes
+
+Removed TREE- prefix from many standard functions. The most useful
+functions now have names which shadow symbols in COMMON-LISP. Feedback
+sought on this change.
+
+** new features
+
+Added utils.lisp with several new macros and functions: DOTREE,
+DO-TREE-RANGE, WITH-TREE-ITERATOR (untested), REDUCE, and POSITION
+
+Added LOWER-BOUND and UPPER-BOUND (in the spirit of C++'s map class)
+
+** miscellany
+
+Added LICENSE file specifying the license for the package (BSD)
+
+Optimized lookup routines
--- /dev/null
+This package implements binary trees of various kinds, presenting a
+uniform interface to them all. Reading package.lisp should give you an
+idea of what sorts of things you can do to trees and reading
+binary-trees.lisp and generics.lisp provides a slightly more in-depth
+look at the functions you would want to use.
+
+There is a moderately extensive test suite which one can run with
+(ASDF:OOS 'ASDF:TEST-OP :TREES). Please be aware that it does take a
+bit of time to run. If any tests fail, you have found a bug; please
+report it.
+
+Report any bugs, comments, or improvements to <froydnj@gmail.com>.
+
+Nathan Froyd
+18 March 2008
--- /dev/null
+ -*- mode: org -*-
+
+* other variations on balanced trees?
+left-leaning red-black trees come to mind
+* add necessary type declarations to get good performance out of structures
+* eliminate SYMBOL-MACROLET from red-black deletion routines
+* add documentation of some sort
+* make sure the asdf system looks sane
+* parse out declarations from DOTREE's &BODY?
+* fix DO-TREE-RANGE
+* fix WITH-TREE-ITERATOR
+* write tests for DO-TREE-RANGE
+** make sure to include tests where
+- :lower is out-of-range for the tree, both :KEY and :INDEX
+- :upper is out-of-range for the tree, both :KEY and :INDEX
+- :upper is < :lower (<= is probably ok, I think)
+* try to make DO-TREE-RANGE support :FROM-END?
+* write tests for WITH-TREE-ITERATOR
+* add :START and :END arguments for REDUCE?
+
+* DONE convert trees to structures?
+* DONE use symbol names for the testcases
+* DONE make separate paths for FUNCTION objects for KEY/PRED/TEST and everything else
+or add COERCEs in MAKE-BINARY-TREE
+* DONE add better test suite
+* DONE change iterators to return the node rather than the datum
+* DONE update utility bits to match
+* DONE make the iterators check the modcount before incrementing
+* DONE iterators feel ugly, try redoing them
+* DONE convert test suite to use RT
+* DONE make DOTREE generate a TAGBODY so that GO works as expected
+* DONE write tests for REDUCE :FROM_END T
+* DONE change method combination in test suite to be non-SBCL specific
+* DONE get ranks working correctly
+* DONE add validation checks for ranks to tests
+* DONE delete old TREES building code from tree-test.lisp
+* DONE switch red-black trees over to using ROTATE-{LEFT,RIGHT}
+* DONE add generation count to accomodate limited forms of mutation during iteration
+* DONE rearrange DELETE and INSERT to have congruent arglists
+* DONE rearrange DELETE and INSERT to have congruent return values
+* DONE write wrapping generic function for MAKE-TREE
+* DONE add validation routines for the various tree kinds
+** DONE red-black black-height invariant
+** DONE red-black child constraint
+these are really slow, though; see if they can be made faster
+** DONE avl height constraint
+** DONE aa level constraint
+need to figure out how this last one works (wikipedia knows all)
+* DONE rewrite testsuite to work on execution traces
+** DONE generate execution traces from testing routines
+** DONE interface to redo execution traces
+what would I use this for, though?
+* DONE redo deletion routines for red-black trees
+* DONE redo deletion routines for AVL trees
+try to factor as much common code from basic and AA
+* DONE fix WITH-TREE-ITERATOR to honor FROM-END
+again, WITH-TREE-ITERATOR needs to be modified to take advantage
+* DONE fix WITH-TREE-ITERATOR to not crash when there's nothing left to move to
+* DONE fix order of return values for WITH-TREE-ITERATOR
+this is basically done with new iterators, but WITH-TREE-ITERATOR needs to use them
+* DONE change DELETE to return the item so deleted
+* DONE rewrite iterators to handle non-parented trees
+some sort of parent/no-parent iterators with generic functions
+* DONE convert nodes to structures
+* DONE profile after doing the structure conversion to find more hotspots
+assuming that the conversion improves performance the estimated 30-50%
+* DONE switch AA trees over to using ROTATE-{LEFT,RIGHT}
+* DONE switch avl insertion routines over to using ROTATE-{LEFT,RIGHT}
--- /dev/null
+(in-package :trees)
+
+(declaim (inline level*))
+(defun level* (x) (if x (level x) 0))
+
+(defun skew (node)
+ (let ((x (left node)))
+ (when (= (level* x) (level node))
+ (setf node (rotate-right node)))
+ node))
+
+(defun split (node)
+ (let ((x (right node)))
+ (when (= (if x
+ (level* (right x))
+ 0)
+ (level node))
+ (setf node (rotate-left node))
+ (incf (level node)))
+ node))
+
+(defun aa-rebalance/insert (tree direction-stack)
+ (when direction-stack
+ (loop with new-child = (split (skew (caar direction-stack)))
+ for x in (cdr direction-stack)
+ for node = (car x)
+ do (insert-child-for-stack-entry x new-child)
+ (setf new-child (split (skew node)))
+ finally (setf (root tree) new-child))))
+
+(defun aa-rebalance/delete (tree node replacement stack)
+ ;; This is what I get for trying to do things without sentinels.
+ (loop initially (when replacement
+ (setf (level replacement) (level node)))
+ for (x . rest) on stack
+ do (let* ((node (car x))
+ (y (left node))
+ (z (right node)))
+ (when (let ((level (1- (level node))))
+ (or (< (level* y) level)
+ (< (level* z) level)))
+ (decf (level node))
+ (when (> (level* z) (level node))
+ (setf (level z) (level node)))
+ (let ((n (skew node)))
+ (set-root-or-entry-child tree (car rest) n)
+ (when (right n)
+ (setf (right n) (skew (right n))))
+ (let ((m (right n)))
+ (when (and m (right m))
+ (setf (right m) (skew (right m)))))
+ (setf n (split n))
+ (set-root-or-entry-child tree (car rest) n)
+ (when (right n)
+ (setf (right n) (split (right n)))))))))
+
+(unless (assoc :aa *binary-tree-info*)
+ (push (list :aa
+ #'make-aa-node
+ #'aa-rebalance/insert
+ #'aa-rebalance/delete)
+ *binary-tree-info*))
--- /dev/null
+(in-package :trees)
+
+(defun update-balance-factors (tree direction-stack)
+ (loop with y = (root tree)
+ with parent = nil
+ with tail = nil
+ with reversed-stack = (nreverse direction-stack)
+ for x on reversed-stack
+ and xp = nil then (car x)
+ do (let ((node (caar x)))
+ (when (not (zerop (balance-info node)))
+ (setf y node parent xp tail x)))
+ finally
+ (return
+ ;; If TAIL is NIL, then we have an entire path of nodes with
+ ;; zero balance factors and the whole path needs to be
+ ;; adjusted.
+ (dolist (p (if (null tail)
+ reversed-stack
+ tail)
+ (values y parent))
+ (let ((node (car p)))
+ (if (eq (cdr p) 'left)
+ (decf (balance-info node))
+ (incf (balance-info node))))))))
+
+(defun avl-rebalance/insert (tree direction-stack)
+ (when direction-stack
+ (multiple-value-bind (y parent-entry)
+ (update-balance-factors tree direction-stack)
+ (case (balance-info y)
+ (#.+avl-falls-left+
+ (let ((x (left y)) w)
+ (ecase (balance-info x)
+ (#.+avl-leans-left+
+ (setf w (rotate-right y)
+ (balance-info x) +avl-equal+
+ (balance-info y) +avl-equal+))
+ (#.+avl-leans-right+
+ (setf (left y) (rotate-left x)
+ w (rotate-right y))
+ (case (balance-info w)
+ (#.+avl-leans-left+
+ (setf (balance-info x) 0
+ (balance-info y) +avl-leans-right+))
+ (#.+avl-equal+
+ (setf (balance-info x) 0
+ (balance-info y) 0))
+ (#.+avl-leans-right+
+ (setf (balance-info x) +avl-leans-left+
+ (balance-info y) 0)))
+ (setf (balance-info w) +avl-equal+)))
+ (set-root-or-entry-child tree parent-entry w)))
+ (#.+avl-falls-right+
+ (let ((x (right y)) w)
+ (ecase (balance-info x)
+ (#.+avl-leans-right+
+ (setf w (rotate-left y)
+ (balance-info x) +avl-equal+
+ (balance-info y) +avl-equal+))
+ (#.+avl-leans-left+
+ (setf (right y) (rotate-right x)
+ w (rotate-left y))
+ (case (balance-info w)
+ (#.+avl-leans-right+
+ (setf (balance-info x) 0
+ (balance-info y) +avl-leans-left+))
+ (#.+avl-equal+
+ (setf (balance-info x) 0
+ (balance-info y) 0))
+ (#.+avl-leans-left+
+ (setf (balance-info x) +avl-leans-right+
+ (balance-info y) 0)))
+ (setf (balance-info w) +avl-equal+)))
+ (set-root-or-entry-child tree parent-entry w)))))))
+
+(defun avl-rebalance/delete (tree node replacement stack)
+ (loop
+ initially (unless (and (null (right node))
+ (eq replacement (left node)))
+ (setf (balance-info replacement) (balance-info node)))
+ for (top . rest) on stack
+ do (let ((y (car top))
+ (direction (cdr top)))
+ (macrolet ((frob (dir opp r1 r2)
+ (flet ((ifleft (dir f1 f2)
+ (if (eq dir 'left)
+ f1
+ f2))
+ (leftinfo (dir a)
+ (if (eq dir 'left) a (- a))))
+ `(progn
+ (,(ifleft dir 'incf 'decf) (balance-info y))
+ (case (balance-info y)
+ (,(leftinfo dir +avl-leans-right+)
+ (loop-finish))
+ (,(leftinfo dir +avl-falls-right+)
+ (let ((x (,opp y)))
+ (case (balance-info x)
+ (,(leftinfo dir +avl-leans-left+)
+ (let ((w (,dir x)))
+ (setf (,opp y) (,r1 x))
+ (let ((r (,r2 y)))
+ (assert (eq w r))
+ (case (balance-info w)
+ (,(leftinfo dir +avl-leans-right+)
+ (setf (balance-info x) +avl-equal+
+ (balance-info y) ,(leftinfo dir +avl-leans-left+)))
+ (,(leftinfo dir +avl-equal+)
+ (setf (balance-info x) +avl-equal+
+ (balance-info y) +avl-equal+))
+ (,(leftinfo dir +avl-leans-left+)
+ (setf (balance-info x) ,(leftinfo dir +avl-leans-right+)
+ (balance-info y) +avl-equal+)))
+ (setf (balance-info w) 0)
+ (set-root-or-entry-child tree (first rest) w))))
+ (t
+ (let ((r (,r2 y)))
+ (set-root-or-entry-child tree (first rest) r)
+ (cond
+ ((= (balance-info x) +avl-equal+)
+ (setf (balance-info x) ,(leftinfo dir +avl-leans-left+)
+ (balance-info y) ,(leftinfo dir +avl-leans-right+))
+ (loop-finish))
+ (t
+ (setf (balance-info x) +avl-equal+
+ (balance-info y) +avl-equal+)))))))))))))
+ (case direction
+ (left (frob left right rotate-right rotate-left))
+ (right (frob right left rotate-left rotate-right)))))))
+
+(unless (assoc :avl *binary-tree-info*)
+ (push (list :avl
+ #'make-avl-node
+ #'avl-rebalance/insert
+ #'avl-rebalance/delete)
+ *binary-tree-info*))
--- /dev/null
+(in-package :trees)
+
+(unless (assoc :normal *binary-tree-info*)
+ (push (list :normal #'make-tree-node nil nil) *binary-tree-info*))
+
+(defun emptyp (tree)
+ (zerop (size tree)))
+
+(declaim (inline rotate-left rotate-right))
+(defun rotate-left (node)
+ (let ((c (right node)))
+ (setf (right node) (left c)
+ (left c) node)
+ (incf (rank c) (rank node))
+ c))
+(defun rotate-right (node)
+ (let ((c (left node)))
+ (setf (left node) (right c)
+ (right c) node)
+ (decf (rank node) (rank c))
+ c))
+
+(defun update-ranks (direction-stack insertedp)
+ (dolist (x direction-stack (values))
+ (let ((direction (cdr x)))
+ (when (eq direction 'left)
+ (if insertedp
+ (incf (rank (car x)))
+ (decf (rank (car x))))))))
+
+(declaim (inline insert-child-for-stack-entry set-root-or-entry-child))
+(defun insert-child-for-stack-entry (entry child)
+ (declare (type cons entry))
+ (if (eq (cdr entry) 'left)
+ (setf (left (car entry)) child)
+ (setf (right (car entry)) child)))
+
+(defun set-root-or-entry-child (tree entry child)
+ (if (null entry)
+ (setf (root tree) child)
+ (insert-child-for-stack-entry entry child)))
+
+;;; Locates the place where we should place ITEM in TREE. Returns two
+;;; values: whether we should insert and a stack of nodes visited and
+;;; the direction we traveled from each node. The newly-created node
+;;; should be a child of the node of the first entry on the stack.
+(defun find-insertion-point (tree item-key)
+ (let ((pred (pred tree))
+ (test (test tree))
+ (key (key tree)))
+ (declare (type function pred test key))
+ (do ((node (root tree))
+ (direction-stack nil))
+ ((eq node nil)
+ (values nil direction-stack item-key))
+ (declare (type (or null tree-node) node))
+ (let ((node-key (funcall key (datum node))))
+ (cond
+ ((funcall test node-key item-key)
+ (return-from find-insertion-point (values node direction-stack item-key)))
+ ((funcall pred item-key node-key)
+ (push (cons node 'left) direction-stack)
+ (setf node (left node)))
+ (t
+ (push (cons node 'right) direction-stack)
+ (setf node (right node))))))))
+
+(defun insert (item tree)
+ "Attempt to insert ITEM into TREE. ITEM must be of a suitable type
+for TREE's key function, and the key returned from calling said function
+must be of a suitable type for TREE's comparison and equality functions.
+Returns two values; the first is the key of ITEM and the second
+indicates whether ITEM was inserted or not."
+ (declare (type binary-tree tree))
+ (multiple-value-bind (presentp direction-stack item-key)
+ (find-insertion-point tree (funcall (key tree) item))
+ (unless presentp
+ (update-ranks direction-stack t)
+ (incf (size tree))
+ (let ((new-node (funcall (nodegen tree) item)))
+ (declare (type tree-node new-node))
+ (incf (modcount tree))
+ (cond
+ (direction-stack
+ (insert-child-for-stack-entry (first direction-stack) new-node))
+ (t
+ (setf (root tree) new-node)))
+ (let ((rebalancer (rebalance/insert tree)))
+ (when rebalancer
+ (funcall rebalancer tree direction-stack)))))
+ (values item-key (null presentp))))
+
+(declaim (inline lower-bound-node-with-path))
+(defun lower-bound-node-with-path (key tree pathp)
+ (let ((pred (pred tree))
+ (%key (key tree)))
+ (declare (type function pred %key))
+ (labels ((locate-node (node candidate path)
+ (cond
+ ((null node) (values candidate path))
+ ((funcall pred key (funcall %key (datum node)))
+ (locate-node (left node) candidate
+ (when pathp
+ (cons (cons node 'left) path))))
+ (t
+ (locate-node (right node) node
+ (when pathp
+ (cons (cons node 'right) path)))))))
+ (locate-node (root tree) nil nil))))
+(declaim (notinline lower-bound-node-with-path))
+
+(defun lower-bound-node (key tree)
+ "Return the node in TREE possessing a key which is equal to or
+less than KEY."
+ (lower-bound-node-with-path key tree nil))
+
+(defun lower-bound (key tree)
+ "Return the item in TREE possessing a key which is equal to or less
+than KEY. Returns NIL if there is no such item."
+ (let ((node (lower-bound-node key tree)))
+ (and node (datum node))))
+
+(declaim (inline upper-bound-node-with-path))
+(defun upper-bound-node-with-path (key tree pathp)
+ (let ((pred (pred tree))
+ (%key (key tree)))
+ (declare (type function pred %key))
+ (labels ((locate-node (node candidate path)
+ (cond
+ ((null node) (values candidate path))
+ ((funcall pred key (funcall %key (datum node)))
+ (locate-node (left node) node
+ (when pathp (cons (cons node 'left) path))))
+ (t
+ (locate-node (right node) candidate
+ (when pathp (cons (cons node 'right) path)))))))
+ (locate-node (the tree-node (root tree)) nil nil))))
+(declaim (notinline upper-bound-node-with-path))
+
+(defun upper-bound-node (key tree)
+ "Return the node in TREE possessing a key which is equal to or greater
+than KEY."
+ (upper-bound-node-with-path key tree nil))
+
+(defun upper-bound (key tree)
+ "Return the item in TREE possessing a key which is equal to or
+greater than KEY. Returns NIL if there is no such item."
+ (let ((node (upper-bound-node key tree)))
+ (and node (datum node))))
+
+(defun find-node-with-key (tree key)
+ "Find the node in TREE with key KEY. Might return the null node if no
+such node can be found."
+ (let ((node (lower-bound-node key tree)))
+ (and node
+ (funcall (test tree) key (funcall (key tree) (datum node)))
+ node)))
+
+(defun find (key tree)
+ "Find the item in TREE whose key is KEY and returns the associated item
+and T as multiple values, or returns NIL and NIL if no such item exists."
+ (let ((node (find-node-with-key tree key)))
+ (if node
+ (values (datum node) t)
+ (values nil nil))))
+
+(defun delete-node (tree node direction-stack)
+ (decf (size tree))
+ (update-ranks direction-stack nil)
+ (let ((parent (caar direction-stack))
+ (direction (cdar direction-stack)))
+ (flet ((move-node (x)
+ (if (null parent)
+ (setf (root tree) x)
+ (if (eq direction 'left)
+ (setf (left parent) x)
+ (setf (right parent) x)))
+ x))
+ (let ((r (right node)))
+ (cond
+ ((null r)
+ (values (move-node (left node)) direction-stack))
+ ((null (left r))
+ (setf (left r) (left node)
+ (rank r) (rank node))
+ (values (move-node r)
+ (cons (cons r 'right) direction-stack)))
+ (t
+ ;; find NODE's in-order successor
+ (let ((placeholder (cons nil 'right))
+ (parent (first direction-stack)))
+ (push placeholder direction-stack)
+ (loop
+ (push (cons r 'left) direction-stack)
+ (let ((succ (left r)))
+ (when (null (left succ))
+ (decf (rank r))
+ ;; move SUCC into NODE's place
+ (setf (left r) (right succ)
+ (left succ) (left node)
+ (right succ) (right node)
+ (rank succ) (rank node))
+ (if (null parent)
+ (setf (root tree) succ)
+ (insert-child-for-stack-entry parent succ))
+ (setf (car placeholder) succ)
+ (return-from delete-node (values (move-node succ) direction-stack)))
+ (decf (rank r))
+ (setf r succ))))))))))
+
+(defun delete (key tree)
+ "Attempt to remove the item with KEY from TREE.
+Returns the item and T as multiple values on success, NIL and NIL on
+failure."
+(declare (type binary-tree tree))
+ (multiple-value-bind (node direction-stack item-key)
+ (find-insertion-point tree key)
+ (declare (ignore item-key))
+ (if node
+ (multiple-value-bind (replacement new-stack)
+ (delete-node tree node direction-stack)
+ (incf (modcount tree))
+ (let ((rebalancer (rebalance/delete tree)))
+ (when rebalancer
+ (funcall rebalancer tree node replacement new-stack)))
+ (values (datum node) t))
+ (values nil nil))))
+
+(defun minimum-node (root)
+ (do ((node root (left node))
+ (parent nil node))
+ ((eq node nil) parent)))
+
+(defun minimum (tree)
+ "Return the item with the minimum key in TREE. It is an error to ask
+for the minimum item of an empty tree."
+ (if (zerop (size tree))
+ (error "Empty tree")
+ (datum (minimum-node (root tree)))))
+
+(defun maximum-node (root)
+ (do ((node root (right node))
+ (parent nil node))
+ ((eq node nil) parent)))
+
+(defun maximum (tree)
+ "Return the item with the maximum key in TREE. It is an error to ask
+for the maximum item of an empty tree."
+ (if (zerop (size tree))
+ (error "Empty tree")
+ (datum (maximum-node (root tree)))))
+
+(defun select-node-with-path (tree k pathp)
+ (labels ((select-loop (node k path)
+ (let ((rank (1- (rank node))))
+ (cond
+ ((= k rank) (values node path))
+ ((< k rank) (select-loop (left node) k
+ (when pathp
+ (cons (cons node 'left) path))))
+ (t (select-loop (right node) (- k rank 1)
+ (when pathp
+ (cons (cons node 'right) path))))))))
+ (cond
+ ((or (minusp k)
+ (>= k (size tree))) (error "Invalid index value"))
+ (t (select-loop (root tree) k nil)))))
+
+(defun select-node (tree k)
+ (select-node-with-path tree k nil))
+
+(defun select (tree k)
+ "Return the Kth item (zero-based) in TREE."
+ (datum (select-node tree k)))
--- /dev/null
+(in-package :trees)
+
+(defvar *binary-tree-info* nil)
+
+(defun make-binary-tree (type pred &key key test)
+ "Create a binary tree based on TYPE. Current acceptable values for TYPE are:
+
+ :NORMAL - a normal binary tree, with no rebalancing
+ :RED-BLACK - a red-black tree
+ :AVL - an AVL tree
+ :AA - an AA tree.
+
+PRED specifies the ordering relation. KEY specifies how to access the
+data for comparison. TEST is optional and, if given, specifies how to
+compare two keys for equality."
+ (let* ((pred (coerce pred 'function))
+ (key (coerce key 'function))
+ (test (if test
+ (coerce test 'function)
+ (lambda (x y)
+ (not (or (funcall pred x y)
+ (funcall pred y x))))))
+ (specifics (assoc type *binary-tree-info*)))
+ (unless specifics
+ (error "Unknown tree kind ~A" type))
+ (apply #'%make-binary-tree pred key test (cdr specifics))))
--- /dev/null
+(in-package :trees)
+
+(defun extreme-node-with-path (root direction &optional path)
+ (do ((node root (funcall direction node))
+ (parent nil node))
+ ((null node) (values parent path))
+ (push node path)))
+
+(defun make-iterator (tree &key
+ forwardp
+ (current nil currentp)
+ (stack nil stackp))
+ (declare (type binary-tree tree))
+ (let ((modcount (modcount tree)))
+ (multiple-value-bind (extremum examine)
+ (if forwardp
+ (values #'left #'right)
+ (values #'right #'left))
+ (multiple-value-bind (current stack)
+ (if (and currentp stackp)
+ (values current stack)
+ (extreme-node-with-path (root tree) extremum))
+ #'(lambda ()
+ (cond
+ ((/= modcount (modcount tree))
+ (error "~A modified during iteration" tree))
+ ((null current)
+ (values nil nil))
+ (t
+ (let* ((next current)
+ (top (pop stack))
+ (node (funcall examine top)))
+ (cond
+ ((null node)
+ (setf current (first stack)))
+ (t
+ (setf (values current stack)
+ (extreme-node-with-path node extremum stack))))
+ (values next t)))))))))
--- /dev/null
+(load "package")
+(load "generics")
+(load "types")
+(load "binary-trees")
+(load "print")
+(load "red-black-trees")
+(load "avl-trees")
+(load "aa-trees")
+(load "utils")
+
+(defvar x (bt:make-binary-tree :red-black :compfun #'< :eqfun #'= :keyfun #'identity))
+(dotimes (i 100)
+ (bt:insert x i))
+
+(bt::do-tree-range (i x)
+ (print i))
\ No newline at end of file
--- /dev/null
+(defpackage "BINARY-TREES"
+ (:use "COMMON-LISP")
+ (:nicknames #:trees)
+ (:shadow reduce find delete position)
+ (:export #:emptyp
+ #:make-binary-tree
+
+ #:binary-tree
+ #:avl-tree
+ #:red-black-tree
+ #:aa-tree
+
+ #:insert
+ #:find
+ #:delete
+ #:size
+ #:minimum
+ #:maximum
+ #:select
+ #:position
+ #:reduce
+
+ #:upper-bound
+ #:lower-bound
+
+ #:dotree
+ ;#:do-tree-range
+ ;#:with-tree-iterator
+
+ #:pprint-tree))
--- /dev/null
+(in-package :trees)
+
+(defmethod make-binary-tree-node ((tree patricia-tree) item)
+ (let ((null-node (sentinel-node tree)))
+ (make-instance 'patricia-tree-node
+ :left null-node
+ :right null-node
+ :parent null-node
+ :datum item)))
+
+(defmethod make-binary-tree ((type (eql :patricia)) &key compfun eqfun keyfun)
+ (let ((sentinel-node (make-sentinel-node 'patricia-tree-node)))
+ (make-instance 'patricia-tree
+ :compfun compfun
+ :eqfun eqfun
+ :keyfun keyfun)))
+
+(defmethod insert-at-node ((tree patricia-tree) item parent direction-stack)
+ )
+
+(defmethod tree-delete-nonempty ((tree patricia-tree) deleted child low-subtree)
+ )
--- /dev/null
+(in-package :trees)
+
+(defmethod print-object ((node tree-node) stream)
+ (print-unreadable-object (node stream)
+ (format stream "btn ~A, rank ~A"
+ (datum node)
+ (rank node))))
+
+(defmethod print-object ((node avl-tree-node) stream)
+ (print-unreadable-object (node stream)
+ (format stream "avltn ~A/~A, rank ~A"
+ (balance-info node)
+ (datum node)
+ (rank node))))
+
+(defmethod print-object ((node red-black-tree-node) stream)
+ (print-unreadable-object (node stream)
+ (format stream "rbtn ~A/~A, rank ~A"
+ (color node)
+ (datum node)
+ (rank node))))
+
+(defmethod print-object ((node aa-tree-node) stream)
+ (print-unreadable-object (node stream)
+ (format stream "aatn ~A/~A, rank ~A"
+ (level node)
+ (datum node)
+ (rank node))))
+
+(defun indent-to-level (n &optional (stream *standard-output*))
+ (dotimes (i n)
+ (write-char #\Space stream)))
+
+(defun pprint-tree (tree &optional (stream *standard-output*))
+ (labels ((recursive-print (node level char)
+ (indent-to-level level stream)
+ (write-char char stream)
+ (write-char #\Space stream)
+ (prin1 node stream)
+ (terpri stream)
+ (unless (null (left node))
+ (recursive-print (left node) (1+ level) #\l))
+ (unless (null (right node))
+ (recursive-print (right node) (1+ level) #\r))))
+ (if (null (root tree))
+ (format stream "empty tree~%")
+ (recursive-print (root tree) 0 #\R))
+ (values)))
--- /dev/null
+(in-package :trees)
+
+(declaim (inline redp blackp redden blacken))
+(defun redp (node) (eq (color node) :red))
+(defun blackp (node) (eq (color node) :black))
+(defun redden (node) (setf (color node) :red))
+(defun blacken (node) (setf (color node) :black))
+
+(defun red-black-rebalance/insert (tree direction-stack)
+ (loop with stack = direction-stack
+ for parent = (caar stack)
+ for pp = (caadr stack)
+ until (or (null parent) (null pp) (blackp parent))
+ do (macrolet ((frob (ppfun opp r1 r2)
+ `(let ((y (,opp pp)))
+ (cond
+ ((and (not (null y)) (redp y))
+ (blacken parent)
+ (blacken y)
+ (redden pp)
+ (pop stack)
+ (pop stack))
+ (t
+ (let ((x pp))
+ (cond
+ ((eq (cdar stack) ',ppfun)
+ (setf y parent))
+ (t
+ (let ((x parent))
+ (setf y (,opp x)
+ (,ppfun pp) (,r1 x)))))
+ (redden x)
+ (blacken y)
+ (,r2 x)
+ (let ((ppp (caddr stack)))
+ (if (null ppp)
+ (setf (root tree) y)
+ (insert-child-for-stack-entry ppp y))
+ (loop-finish))))))))
+ (if (eq (cdadr stack) 'left)
+ (frob left right rotate-left rotate-right)
+ (frob right left rotate-right rotate-left)))
+ finally (progn
+ (blacken (root tree))
+ (return (values)))))
+
+(defun red-black-rebalance/delete (tree node replacement new-stack)
+ (unless (null (right node))
+ (rotatef (color replacement) (color node)))
+ (when (and (blackp node) new-stack)
+ (loop while new-stack
+ do
+ (symbol-macrolet ((tos (car new-stack))
+ (tos-node (car tos))
+ (tos-dir (cdr tos))
+ (poptop (cadr new-stack))
+ (poptop-node (car poptop))
+ (poptop-dir (cdr poptop)))
+ #+nil (format *trace-output* "processing ~A~%" tos)
+ (let ((x (funcall tos-dir tos-node)))
+ #+nil (format *trace-output* "z's ~A child is ~A~%" tos-dir x)
+ (when (and x (redp x))
+ (blacken x)
+ (loop-finish))
+ (macrolet ((frob (rf1 rf2 op1 op2)
+ `(let ((w (,op1 tos-node)))
+ #+nil(format *trace-output* "w is ~A~%" w)
+ (when (redp w)
+ (blacken w)
+ (redden tos-node)
+ (let ((r (,rf2 tos-node)))
+ #+nil (format *trace-output* "1 inserting ~A into ~A~%" r poptop)
+ (if (null (cdr new-stack))
+ (setf (root tree) r)
+ (insert-child-for-stack-entry poptop r)))
+ (push (cons tos-node tos-dir) new-stack)
+ (setf tos-dir ',op2
+ poptop-node w)
+ (setf w (,op1 tos-node))
+ #+nil (format *trace-output* "w is now ~A~%" w)
+ (assert w)
+ (assert (blackp w)))
+ (cond
+ ((let ((s1 (,op1 w))
+ (s2 (,op2 w)))
+ (and (or (null s1) (blackp s1))
+ (or (null s2) (blackp s2))))
+ #+NIL (format *trace-output* "red'ing ~A~%" w)
+ (redden w))
+ (t
+ (when (let ((r (,op1 w)))
+ (or (null r) (blackp r)))
+ #+nil (format *trace-output* "converting cases~%")
+ (assert (redp (,op2 w)))
+ (blacken (,op2 w))
+ (redden w)
+ (let ((y (,rf1 w)))
+ (insert-child-for-stack-entry (cons tos-node ',op1) y)
+ (assert tos-node)
+ (setf w (,op1 tos-node))
+ #+nil (format *trace-output* "w has become ~A~%" w)
+ (assert (eq y w))))
+ #+NIL (format *trace-output* "handling case 3?~%")
+ (setf (color w) (color tos-node))
+ (blacken tos-node)
+ (blacken (,op1 w))
+ (let ((r (,rf2 tos-node)))
+ #+NIL (format *trace-output* "2 inserting ~A into ~A~%" r poptop)
+ (if (null (cdr new-stack))
+ (setf (root tree) r)
+ (insert-child-for-stack-entry poptop r))
+ (loop-finish)))))))
+ (case tos-dir
+ (left (frob rotate-right rotate-left right left))
+ (right (frob rotate-left rotate-right left right)))
+ (pop new-stack))))))
+ (let ((root (root tree)))
+ (when root
+ (blacken root))))
+
+(unless (assoc :red-black *binary-tree-info*)
+ (push (list :red-black
+ #'make-red-black-node
+ #'red-black-rebalance/insert
+ #'red-black-rebalance/delete)
+ *binary-tree-info*))
--- /dev/null
+;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
+
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+(defpackage #:regression-test
+ (:nicknames #:rtest #-lispworks #:rt)
+ (:use #:cl)
+ (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+ #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+ #:rem-all-tests #:rem-test)
+ (:documentation "The MIT regression tester with pfdietz's modifications"))
+
+;;This was the December 19, 1990 version of the regression tester, but
+;;has since been modified.
+
+(in-package :regression-test)
+
+(declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
+(declaim (type list *entries*))
+(declaim (ftype (function (t &rest t) t) report-error))
+(declaim (ftype (function (t &optional t) t) do-entry))
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.")
+(defvar *entries-tail* *entries* "Tail of the *entries* list")
+(defvar *entries-table* (make-hash-table :test #'equal)
+ "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+ "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+
+(defvar *compile-tests* nil "When true, compile the tests before running them.")
+(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
+(defvar *optimization-settings* '((safety 3)))
+
+(defvar *expected-failures* nil
+ "A list of test names that are expected to fail.")
+
+(defvar *notes* (make-hash-table :test 'equal)
+ "A mapping from names of notes to note objects.")
+
+(defstruct (entry (:conc-name nil))
+ pend name props form vals)
+
+;;; Note objects are used to attach information to tests.
+;;; A typical use is to mark tests that depend on a particular
+;;; part of a set of requirements, or a particular interpretation
+;;; of the requirements.
+
+(defstruct note
+ name
+ contents
+ disabled ;; When true, tests with this note are considered inactive
+ )
+
+;; (defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry)
+ (let ((var (gensym)))
+ `(let ((,var ,entry))
+ (list* (name ,var) (form ,var) (vals ,var)))))
+
+(defun entry-notes (entry)
+ (let* ((props (props entry))
+ (notes (getf props :notes)))
+ (if (listp notes)
+ notes
+ (list notes))))
+
+(defun has-disabled-note (entry)
+ (let ((notes (entry-notes entry)))
+ (loop for n in notes
+ for note = (if (note-p n) n
+ (gethash n *notes*))
+ thereis (and note (note-disabled note)))))
+
+(defun pending-tests ()
+ (loop for entry in (cdr *entries*)
+ when (and (pend entry) (not (has-disabled-note entry)))
+ collect (name entry)))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ (setq *entries-tail* *entries*)
+ (clrhash *entries-table*)
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (let ((pred (gethash name *entries-table*)))
+ (when pred
+ (if (null (cddr pred))
+ (setq *entries-tail* pred)
+ (setf (gethash (name (caddr pred)) *entries-table*) pred))
+ (setf (cdr pred) (cddr pred))
+ (remhash name *entries-table*)
+ name)))
+
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry ;; (find name (the list (cdr *entries*))
+ ;; :key #'name :test #'equal)
+ (cadr (gethash name *entries-table*))
+ ))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name &rest body)
+ (let* ((p body)
+ (properties
+ (loop while (keywordp (first p))
+ unless (cadr p)
+ do (error "Poorly formed deftest: ~A~%"
+ (list* 'deftest name body))
+ append (list (pop p) (pop p))))
+ (form (pop p))
+ (vals p))
+ `(add-entry (make-entry :pend t
+ :name ',name
+ :props ',properties
+ :form ',form
+ :vals ',vals))))
+
+(defun add-entry (entry)
+ (setq entry (copy-entry entry))
+ (let* ((pred (gethash (name entry) *entries-table*)))
+ (cond
+ (pred
+ (setf (cadr pred) entry)
+ (report-error nil
+ "Redefining test ~:@(~S~)"
+ (name entry)))
+ (t
+ (setf (gethash (name entry) *entries-table*) *entries-tail*)
+ (setf (cdr *entries-tail*) (cons entry nil))
+ (setf *entries-tail* (cdr *entries-tail*))
+ )))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args)))
+ nil)
+
+(defun do-test (&optional (name *test*))
+ #-sbcl (do-entry (get-entry name))
+ #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
+ (do-entry (get-entry name))))
+
+(defun my-aref (a &rest args)
+ (apply #'aref a args))
+
+(defun my-row-major-aref (a index)
+ (row-major-aref a index))
+
+(defun equalp-with-case (x y)
+ "Like EQUALP, but doesn't do case conversion of characters.
+ Currently doesn't work on arrays of dimension > 2."
+ (cond
+ ((eq x y) t)
+ ((consp x)
+ (and (consp y)
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
+ ((and (typep x 'array)
+ (= (array-rank x) 0))
+ (equalp-with-case (my-aref x) (my-aref y)))
+ ((typep x 'vector)
+ (and (typep y 'vector)
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for i from 0 below x-len
+ for e1 = (my-aref x i)
+ for e2 = (my-aref y i)
+ always (equalp-with-case e1 e2))))))
+ ((and (typep x 'array)
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
+ nil)
+
+ ((typep x 'array)
+ (and (typep y 'array)
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (my-row-major-aref x i)
+ (my-row-major-aref y i))))))
+
+ (t (eql x y))))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
+ ;; (declare (special *break-on-warnings*))
+
+ (block aborted
+ (setf r
+ (flet ((%do
+ ()
+ (cond
+ (*compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry))))))
+ (*expanded-eval*
+ (multiple-value-list
+ (expanded-eval (form entry))))
+ (t
+ (multiple-value-list
+ (eval (form entry)))))))
+ (if *catch-errors*
+ (handler-bind
+ (#-ecl (style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
+
+ (setf (pend entry)
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
+ (when (pend entry)
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (handler-case
+ (let ((st (format nil "Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ (length r) r)))
+ (format s "~A" st))
+ (error () (format s "Actual value: #<error during printing>~%")
+ ))
+ (finish-output s)
+ ))))
+ (when (not (pend entry)) *test*))
+
+(defun expanded-eval (form)
+ "Split off top level of a form and eval separately. This reduces the chance that
+ compiler optimizations will fold away runtime computation."
+ (if (not (consp form))
+ (eval form)
+ (let ((op (car form)))
+ (cond
+ ((eq op 'let)
+ (let* ((bindings (loop for b in (cadr form)
+ collect (if (consp b) b (list b nil))))
+ (vars (mapcar #'car bindings))
+ (binding-forms (mapcar #'cadr bindings)))
+ (apply
+ (the function
+ (eval `(lambda ,vars ,@(cddr form))))
+ (mapcar #'eval binding-forms))))
+ ((and (eq op 'let*) (cadr form))
+ (let* ((bindings (loop for b in (cadr form)
+ collect (if (consp b) b (list b nil))))
+ (vars (mapcar #'car bindings))
+ (binding-forms (mapcar #'cadr bindings)))
+ (funcall
+ (the function
+ (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
+ (eval (car binding-forms)))))
+ ((eq op 'progn)
+ (loop for e on (cdr form)
+ do (if (null (cdr e)) (return (eval (car e)))
+ (eval (car e)))))
+ ((and (symbolp op) (fboundp op)
+ (not (macro-function op))
+ (not (special-operator-p op)))
+ (apply (symbol-function op)
+ (mapcar #'eval (cdr form))))
+ (t (eval form))))))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries* (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (the list (cdr *entries*)) :key #'pend)
+ (length (cdr *entries*)))
+ (finish-output s)
+ (dolist (entry (cdr *entries*))
+ (when (and (pend entry)
+ (not (has-disabled-note entry)))
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))
+ (finish-output s)
+ ))
+ (let ((pending (pending-tests))
+ (expected-table (make-hash-table :test #'equal)))
+ (dolist (ex *expected-failures*)
+ (setf (gethash ex expected-table) t))
+ (let ((new-failures
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length new-failures)
+ new-failures)))
+ ))
+ (finish-output s)
+ (null pending))))
+
+(defun do-entries (s)
+ #-sbcl (do-entries* s)
+ #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
+ (do-entries* s)))
+
+;;; Note handling functions and macros
+
+(defmacro defnote (name contents &optional disabled)
+ `(eval-when (:load-toplevel :execute)
+ (let ((note (make-note :name ',name
+ :contents ',contents
+ :disabled ',disabled)))
+ (setf (gethash (note-name note) *notes*) note)
+ note)))
+
+(defun disable-note (n)
+ (let ((note (if (note-p n) n
+ (setf n (gethash n *notes*)))))
+ (unless note (error "~A is not a note or note name." n))
+ (setf (note-disabled note) t)
+ note))
+
+(defun enable-note (n)
+ (let ((note (if (note-p n) n
+ (setf n (gethash n *notes*)))))
+ (unless note (error "~A is not a note or note name." n))
+ (setf (note-disabled note) nil)
+ note))
--- /dev/null
+(in-package :trees-tests)
+
+(defconstant +max-upper-bound+ (expt 2 15))
+
+(defvar *execution-trace*)
+(defvar *saved-trace*)
+(defvar *print-while-building* nil)
+(defvar *validate-while-building* nil)
+(defvar *building-uses-delete* nil)
+(defvar *let-pred-determine-equivalency* nil)
+
+(defun make-integer-tree (tree-kind)
+ ;; Use explicit lambdes to make SBCL emit calls to GENERIC assembly
+ ;; procedures, rather than the full functions; the GENERIC versions
+ ;; will be faster, as they contain early outs for fixnums.
+ (trees:make-binary-tree tree-kind #'(lambda (x y)
+ (< x y))
+ :key #'identity
+ :test (unless *let-pred-determine-equivalency*
+ #'(lambda (x y) (= x y)))))
+
+(defun make-bitset (upper-bound)
+ (make-array upper-bound :element-type 'bit :initial-element 0))
+
+(defun make-trace-buffer (&optional (size 400))
+ (make-array size :element-type '(unsigned-byte 16)
+ :fill-pointer 0
+ :adjustable t))
+
+(defun add-trace-action (insertp element)
+ (vector-push-extend (dpb insertp (byte 1 15) element) *execution-trace*))
+
+(defun insert-action-p (bits)
+ (not (logbitp 15 bits)))
+
+(defun action-element (bits)
+ (ldb (byte 15 0) bits))
+
+(defun test-with-randomly-built-tree (kind test &optional (size 200))
+ (multiple-value-bind (tree bitvector count)
+ (build-random-tree kind size :delete t)
+ (declare (ignore count))
+ (funcall test tree bitvector)))
+
+(defun check-equivalency (tree bitvector)
+ (loop
+ for start = 0 then (1+ x)
+ for x = (position 1 bitvector :start start)
+ while x
+ do (assert (trees:find x tree))
+ finally (return t)))
+
+(defun check-selection (tree bitvector)
+ (unless (zerop (trees:size tree))
+ (loop for start = 0 then (1+ x)
+ for x = (position 1 bitvector :start start)
+ for i from 0
+ while x
+ do (assert (= x (trees:select tree i)))
+ finally (return t))))
+
+(defun check-forward-position-t (tree bitvector)
+ (loop for start = 0 then (1+ x)
+ for x = (position 1 bitvector :start start)
+ for i from 0
+ while x
+ do (assert (= i (trees:position x tree)))
+ finally (return t)))
+
+(defun check-forward-position-nil (tree bitvector)
+ (loop for start = 0 then (1+ x)
+ for x = (position 0 bitvector :start start)
+ while x
+ do (assert (eq (trees:position x tree) nil))
+ finally (return t)))
+
+(defun check-backward-position-t (tree bitvector)
+ (loop for end = nil then x
+ for x = (position 1 bitvector :from-end t :end end)
+ for i downfrom (1- (trees:size tree))
+ while x
+ do (assert (= i (trees:position x tree)))
+ finally (return t)))
+
+(defun check-backward-position-nil (tree bitvector)
+ (loop for end = nil then x
+ for x = (position 0 bitvector :from-end t :end end)
+ while x
+ do (assert (eq (trees:position x tree :from-end t) nil))
+ finally (return t)))
+
+(defun check-forward-iteration (tree bitvector)
+ (loop with iter = (trees::make-iterator tree :forwardp t)
+ for start = 0 then (1+ x)
+ for x = (position 1 bitvector :start start)
+ for z = (funcall iter)
+ while x
+ do (assert (= (trees::datum z) x))
+ finally (return t)))
+
+(defun check-backward-iteration (tree bitvector)
+ (loop with iter = (trees::make-iterator tree :forwardp nil)
+ for end = nil then y
+ for y = (position 1 bitvector :from-end t :end end)
+ for w = (funcall iter)
+ while y
+ do (assert (= y (trees::datum w)))
+ finally (return t)))
+
+(defun check-dotree (tree bitvector)
+ (let ((new (bit-xor bitvector bitvector)))
+ (trees:dotree (x tree)
+ (setf (aref new x) 1))
+ (assert (not (mismatch new bitvector)))
+ t))
+
+(defun check-reduce (tree bitvector)
+ (loop with tree-sum = (trees:reduce tree #'+)
+ for start = 0 then (1+ x)
+ for x = (position 1 bitvector :start start)
+ while x
+ sum x into sum
+ finally
+ (assert (= tree-sum sum))
+ (return t)))
+
+(defun check-reduce-from-end (tree bitvector)
+ (loop with tree-diff = (trees:reduce tree #'- :initial-value 0 :from-end t)
+ for start = 0 then (1+ x)
+ for x = (position 1 bitvector :start start)
+ while x
+ collect x into list
+ finally
+ (assert (= tree-diff (reduce #'- list :initial-value 0 :from-end t)))
+ (return t)))
+
+(defparameter *tree-checkers*
+ (list #'check-equivalency
+ #'check-selection
+ #'check-forward-position-t
+ #'check-forward-position-nil
+ #'check-backward-position-t
+ #'check-backward-position-nil
+ #'check-forward-iteration
+ #'check-backward-iteration
+ #'check-dotree
+ #'check-reduce
+ #'check-reduce-from-end))
+
+(defun build-random-tree (tree-type upper-bound
+ &key (delete *building-uses-delete*)
+ trace)
+ (when (> upper-bound +max-upper-bound+)
+ (error "upper bound ~A is too large" upper-bound))
+ (let ((*execution-trace* (when trace (make-trace-buffer))))
+ (loop with tree = (make-integer-tree tree-type)
+ with bitvector of-type simple-bit-vector = (make-bitset upper-bound)
+ with size = 0
+ with insert-count = 0
+ with delete-count = 0
+ with insert-limit = (truncate upper-bound 2)
+ with delete-limit = (if delete (truncate upper-bound 2) 0)
+ with validatep = *validate-while-building*
+ until (and (>= insert-count insert-limit)
+ (>= delete-count delete-limit))
+ do (let ((element (random upper-bound))
+ (which (if delete (random 2) 0)))
+ (case which
+ (0 ; insert
+ (multiple-value-bind (key insertedp) (trees:insert element tree)
+ (cond
+ (insertedp
+ (when trace (add-trace-action which element))
+ (assert (= 0 (aref bitvector element)))
+ (setf (aref bitvector element) 1)
+ (incf size)
+ (incf insert-count))
+ (t
+ (assert (= 1 (aref bitvector element)))))
+ (assert (= key element))
+ (assert (trees:find element tree))))
+ (1 ; delete
+ (multiple-value-bind (data successp) (trees:delete element tree)
+ (cond
+ (successp
+ (when trace (add-trace-action which element))
+ (assert (= element data))
+ (assert (= (aref bitvector element) 1))
+ (setf (aref bitvector element) 0)
+ (decf size)
+ (incf delete-count))
+ (t
+ (assert (= (aref bitvector element) 0))))
+ (assert (not (trees:find element tree))))))
+ (when validatep
+ (assert (validate-tree tree)))
+ (assert (= size (trees:size tree))))
+ finally (check-equivalency tree bitvector)
+ (validate-tree tree)
+ (return (values tree bitvector (+ insert-count delete-count))))))
+
+(defun build-tree-from-trace (tree-type trace maker insert delete printer)
+ (loop with tree = (funcall maker tree-type)
+ for action across trace
+ for i from 0
+ do (funcall (if (insert-action-p action) insert delete)
+ (action-element action) tree)
+ (when *print-while-building*
+ (format *trace-output* "step ~D: ~A ~D~%" i
+ (if (insert-action-p action) "insert" "delete")
+ (action-element action))
+ (funcall printer tree *trace-output*))
+ finally (return tree)))
+
+(defun build-new-tree-from-trace (tree-type trace)
+ (build-tree-from-trace tree-type trace
+ #'make-integer-tree
+ #'trees:insert
+ #'trees:delete
+ #'trees::pprint-tree))
+
+(defun build-and-compare (tree-type deletionp)
+ (handler-bind ((error #'(lambda (c)
+ (assert *execution-trace*)
+ (setf *saved-trace* *execution-trace*)
+ (let ((*print-while-building* t))
+ (build-new-tree-from-trace tree-type *execution-trace*))
+ (continue c))))
+ (build-random-tree tree-type 200 :delete deletionp :trace t)))
+
+(defun build-and-run-checkers (tree-kind)
+ (flet ((build-and-run (x)
+ (let ((*let-pred-determine-equivalency* x))
+ (multiple-value-bind (tree bitvector count)
+ (build-random-tree tree-kind 200 :delete t)
+ (declare (ignore count))
+ (dolist (test *tree-checkers* t)
+ (funcall (the function test) tree bitvector))))))
+ (handler-case
+ (loop repeat 1000 always (and (build-and-run t) (build-and-run nil)))
+ (error (c) c)
+ (:no-error (value) value))))
+
+(rtest:deftest :normal (build-and-run-checkers :normal) t)
+
+(rtest:deftest :avl (build-and-run-checkers :avl) t)
+
+(rtest:deftest :red-black (build-and-run-checkers :red-black) t)
+
+(rtest:deftest :aa (build-and-run-checkers :aa) t)
--- /dev/null
+;;; -*- mode: lisp -*-
+
+(cl:defpackage #:trees-system
+ (:use #:cl #:asdf))
+(cl:in-package #:trees-system)
+
+(asdf:defsystem :trees
+ :version "0.11"
+ :author "Nathan Froyd <froydnj@gmail.com>"
+ :maintainer "Nathan Froyd <froydnj@gmail.com>"
+ :description "A library for binary trees in normal and balanced flavors"
+ :license "BSD style"
+ :components ((:file "package")
+ (:file "generics" :depends-on ("package"))
+ (:file "types" :depends-on ("package"))
+ (:file "print" :depends-on ("generics" "types"))
+ (:file "binary-trees" :depends-on ("generics" "types"))
+ (:file "red-black-trees" :depends-on ("types" "binary-trees"))
+ (:file "avl-trees" :depends-on ("types" "binary-trees"))
+ (:file "aa-trees" :depends-on ("types" "binary-trees"))
+ (:file "iterator" :depends-on ("types" "binary-trees"))
+ (:file "utils" :depends-on ("binary-trees"))
+ (:static-file "LICENSE")
+ (:static-file "README")
+ (:static-file "NEWS")
+ (:static-file "TODO")))
+
+(defpackage :trees-tests
+ (:use :cl))
+
+(defmethod perform ((op test-op) (c (eql (find-system :trees))))
+ (oos 'test-op 'trees-tests))
+
+;;; A tester's job is never done!
+(defmethod operation-done-p ((op test-op) (c (eql (find-system :trees))))
+ nil)
+
+(asdf:defsystem :trees-tests
+ :depends-on (:trees)
+ :version "0.3"
+ :in-order-to ((test-op (load-op :trees-tests)))
+ :components ((:file "rt")
+ (:file "validate")
+ (:file "tree-test" :depends-on ("rt" "validate"))))
+
+(defmethod operation-done-p ((op test-op)
+ (c (eql (find-system :trees-tests))))
+ nil)
+
+(defmethod perform ((op test-op) (c (eql (find-system :trees-tests))))
+ (or (funcall (intern "DO-TESTS" (find-package "RTEST")))
+ (error "TEST-OP failed for TREES-TESTS")))
--- /dev/null
+(in-package :trees)
+
+\f
+;;; tree nodes
+
+;;; Structures give better performance than CLOS.
+
+(defstruct (tree-node
+ (:conc-name)
+ (:constructor make-tree-node (datum))
+ (:copier nil))
+ (left nil :type (or null tree-node))
+ (right nil :type (or null tree-node))
+ (rank 1 :type fixnum)
+ (datum nil))
+
+(defstruct (avl-tree-node
+ (:conc-name)
+ (:constructor make-avl-node (datum))
+ (:copier nil)
+ (:include tree-node))
+ (balance-info 0 :type (integer -2 2)))
+
+(defconstant +avl-equal+ 0)
+(defconstant +avl-leans-left+ -1)
+(defconstant +avl-leans-right+ +1)
+(defconstant +avl-falls-left+ -2)
+(defconstant +avl-falls-right+ +2)
+
+(deftype red-black-color ()
+ "Keywords denoting red-black tree colors."
+ '(member :red :black))
+
+(defstruct (red-black-tree-node
+ (:conc-name)
+ (:constructor make-red-black-node (datum))
+ (:copier nil)
+ (:include tree-node))
+ (color :red :type red-black-color))
+
+(defstruct (aa-tree-node
+ (:conc-name)
+ (:constructor make-aa-node (datum))
+ (:copier nil)
+ (:include tree-node))
+ (level 1 :type fixnum))
+\f
+;;; trees
+
+(defstruct (binary-tree
+ (:conc-name)
+ (:constructor %make-binary-tree (pred key test
+ nodegen
+ rebalance/insert
+ rebalance/delete))
+ (:copier nil))
+ (test #1=(error "missing arg") :type function :read-only t)
+ (key #1# :type function :read-only t)
+ (pred #1# :type function :read-only t)
+ (size 0 :type fixnum)
+ (root nil :type (or null tree-node))
+ (modcount 0 :type fixnum)
+ (nodegen #1# :type function :read-only t)
+ (rebalance/insert nil :type (or null function) :read-only t)
+ (rebalance/delete nil :type (or null function) :read-only t))
--- /dev/null
+(in-package :trees)
+
+(defun for-each (func tree forwardp)
+ (let ((iter (make-iterator tree :forwardp forwardp)))
+ (declare (type function iter))
+ (loop (multiple-value-bind (node morep) (funcall iter)
+ (unless morep (return-from for-each (values)))
+ (funcall func (datum node))))))
+
+(defun tree-for-each (func tree)
+ (for-each func tree t))
+
+(defun reverse-tree-for-each (func tree)
+ (for-each func tree nil))
+
+;;; We implement this directly in terms of iterators, rather than
+;;; re-using TREE-FOR-EACH, so that we can provide for GO tags in the
+;;; body of the loop, similarly to DO/DOTIMES/DOLIST.
+(defmacro dotree ((obj-var tree-var &optional return-value) &body body)
+ (let ((node (gensym))
+ (iter (gensym))
+ (tree (gensym)))
+ `(let* ((,tree ,tree-var)
+ (,iter (make-iterator ,tree :forwardp t)))
+ (declare (type function ,iter))
+ (do ((,node (funcall ,iter) (funcall ,iter)))
+ ((null ,node) ,return-value)
+ (let ((,obj-var (datum ,node)))
+ (tagbody
+ ,@body))))))
+
+#||
+(defmacro do-tree-range ((obj-var tree-var
+ &key (type :key)
+ (lower nil)
+ (upper nil)) &body body)
+ (macrolet ((invalid-type (type)
+ `(error "Invalid :type supplied to DO-TREE-RANGE: ~A" ,type)))
+ (let* ((node (gensym))
+ (tree (gensym))
+ (current (gensym))
+ (stack (gensym))
+ (iterator (gensym))
+ (morep (gensym))
+ (name (gensym))
+ (last (gensym))
+ (lower-exp (if lower
+ (cond
+ ((eq type :key)
+ `(upper-bound-node-with-path ,lower ,tree t))
+ ((eq type :index)
+ `(select-node-with-path ,tree ,lower))
+ (t (invalid-type type)))
+ (cond
+ ((or (eq type :key) (eq type :index))
+ `(minimum-node ,tree-var (root ,tree)))
+ (t (invalid-type type)))))
+ (upper-exp (if upper
+ (cond
+ ((eq type :key)
+ `(upper-bound-node ,upper ,tree))
+ ((eq type :index)
+ `(select-node ,tree ,upper))
+ (t (invalid-type type)))
+ (cond
+ ((or (eq type :key) (eq type :index)) nil)
+ (t (invalid-type type))))))
+ `(let ((,tree ,tree-var))
+ (multiple-value-bind (,current ,stack) ,lower-exp
+ (loop named ,name
+ with ,iterator = (make-iterator ,tree :forwardp t
+ :current ,current
+ :stack ,stack)
+ with ,last = ,upper-exp
+ do (multiple-value-bind (,node ,morep) (funcall ,iterator)
+ (when (or (not ,morep)
+ (eq ,node ,last))
+ (return-from ,name))
+ (let ((,obj-var (datum ,node)))
+ (tagbody
+ ,@body)))))))))
+
+;;; FIXME: FROM-END isn't necessarily very intuitive here. find out
+;;; how regular CL sequence functions treat it (especially with indices)
+;;; and rewrite the macro to match.
+(defmacro with-tree-iterator ((iter tree &key
+ (from-end nil) (type :key) (start nil))
+ &body body)
+ "Like WITH-HASH-TABLE-ITERATOR; ITER is a name defined via MACROLET
+and TREE is a form evaluated to produce a tree. Successive calls to ITER
+return the items in the tree, one by one.
+
+ (ITER) two values. The first is a boolean that is true if an object from
+the tree is returned; the second is an object stored in the tree.
+
+TYPE can be either :KEY or :INDEX and defines how to interpret START. If
+TYPE is :KEY and START is specified, then START is taken to be some key of
+the tree from which iteration should begin. If no such key exists, then
+the next greatest key is chosen as the starting point. If TYPE is :INDEX,
+and START is specified, then START is taken to be an index passed to
+SELECT-NODE to determine from what object iteration should begin.
+
+If START is not specified, iteration begins from the minimum node of TREE.
+
+FROM-END is currently broken and should not be used."
+ (let ((treesym (gensym))
+ (n-iter (gensym)))
+ `(let ((,n-iter
+ (let* ((,treesym ,tree)
+ (node ,(cond
+ ((eq type :key)
+ (if start
+ `(lower-bound-node ,start ,treesym)
+ `(minimum-node ,treesym (root-node ,treesym))))
+ ((eq type :index)
+ (if start
+ `(select-node ,start ,treesym)
+ `(minimum-node ,treesym (root-node ,treesym)))))))
+ (labels ((,iter ()
+ (multiple-value-prog1
+ (values (not (null-node-p node ,treesym))
+ (datum node))
+ (setf node (tree-successor node)))))
+ #',iter))))
+ (macrolet ((,iter () '(funcall ,n-iter)))
+ ,@body))))
+||#
+
+(defun reduce (tree function
+ &key key
+ (initial-value nil valuep)
+ (from-end nil))
+ (let ((accum (if valuep
+ initial-value
+ (funcall function))))
+ (flet ((left-reducer (object)
+ (setf accum (funcall function accum (if key
+ (funcall key object)
+ object))))
+ (right-reducer (object)
+ (setf accum (funcall function (if key
+ (funcall key object)
+ object) accum))))
+ (declare (dynamic-extent #'left-reducer #'right-reducer))
+ (if from-end
+ (reverse-tree-for-each #'right-reducer tree)
+ (tree-for-each #'left-reducer tree))
+ accum)))
+
+(defun position (key tree &key from-end)
+ (multiple-value-bind (node stack item-key) (find-insertion-point tree key)
+ (declare (ignore item-key))
+ (if (null node)
+ node
+ (loop with position = (1- (rank node))
+ for entry in stack
+ unless (eq (cdr entry) 'left)
+ do (incf position (rank (car entry)))
+ finally (return
+ (if from-end
+ (- (size tree) position)
+ position))))))
--- /dev/null
+(in-package :trees-tests)
+
+(defun validate-tree (tree)
+ (validate-tree* (trees::root tree)))
+
+(defgeneric validate-tree* (root)
+ (:method-combination and))
+
+(defmethod validate-tree* and (root)
+ (labels ((verify (root)
+ (unless root
+ (return-from verify (values 0 0)))
+ (let ((rank (trees::rank root)))
+ (unless (>= rank 1)
+ (error "node ~A has invalid rank" root))
+ (multiple-value-bind (left-rank left-size) (verify (trees::left root))
+ (declare (ignore left-rank))
+ (unless (= rank (1+ left-size))
+ (error "node ~A has invalid rank left-wise: ~D" root left-size))
+ (multiple-value-bind (right-rank right-size)
+ (verify (trees::right root))
+ (declare (ignore right-rank))
+ (values rank (+ 1 left-size right-size)))))))
+ (verify root)
+ t))
+
+(defmethod validate-tree* and ((root trees::red-black-tree-node))
+ (when root
+ (unless (trees::blackp root)
+ (error "tree has non-black root!")))
+ (labels ((verify (root)
+ (unless root
+ (return-from verify 0))
+ (let ((left (trees::left root))
+ (right (trees::right root)))
+ (when (trees::redp root)
+ (when (let ((x left))
+ (and x (trees::redp x)))
+ (error "red node ~A has red left child ~A~%" root left))
+ (when (let ((x right))
+ (and x (trees::redp x)))
+ (error "red node ~A has red right child ~A~%" root right)))
+ (let ((left-bh (verify left))
+ (right-bh (verify right)))
+ (unless (= left-bh right-bh)
+ (error "node ~A has different black-heights: ~D/~D~%"
+ root left-bh right-bh))
+ (+ left-bh (if (trees::blackp root) 1 0))))))
+ (verify root)
+ t))
+
+(defmethod validate-tree* and ((root trees::avl-tree-node))
+ (labels ((verify (root)
+ (unless root
+ (return-from verify 0))
+ (unless (<= -1 (trees::balance-info root) 1)
+ (error "out-of-range balance factor for ~A" root))
+ (let ((left-height (verify (trees::left root)))
+ (right-height (verify (trees::right root))))
+ (when (/= (- right-height left-height) (trees::balance-info root))
+ (error "node ~A has different sub-heights: ~D/~D"
+ root left-height right-height))
+ (1+ (max left-height right-height)))))
+ (verify root)
+ t))
+
+(defmethod validate-tree* and ((root trees::aa-tree-node))
+ (labels ((verify (root)
+ (unless root
+ (return-from verify 0))
+ (let ((level (trees::level root))
+ (left (trees::left root))
+ (right (trees::right root)))
+ (when (and (null left) (null right))
+ (unless (= level 1)
+ (error "leaf node ~A has invalid level" root)))
+ (when (and left right)
+ (unless (> level 1)
+ (error "non-leaf node ~A has invalid level" root)))
+ (unless (< (trees::level* left) level)
+ (error "left node ~A has invalid level wrt ~A" left root))
+ (unless (<= (trees::level* right) level)
+ (error "right node ~A has invalid level wrt ~A" right root))
+ (verify left)
+ (verify right))))
+ (verify root)
+ t))
projects / trees.git / commitdiff