From: Nathan Froyd Date: Sat, 12 May 2012 16:32:49 +0000 (-0400) Subject: initial commit X-Git-Url: http://repo.macrolet.net/gitweb/?p=trees.git;a=commitdiff_plain;h=981c7f5adec954a094eb52f48fa7fddd7f4168da initial commit --- 981c7f5adec954a094eb52f48fa7fddd7f4168da diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..16430fc --- /dev/null +++ b/.gitignore @@ -0,0 +1,17 @@ +*.fasl +*.FASL +*.ufasl +*.ufsl +*.dx32fsl +*.dx64fsl +*.pfsl +*.dfsl +*.p64fsl +*.d64fsl +*.lx32fsl +*.lx64fsl +*.fx32fsl +*.fx64fsl +*.fas +*.lib +*~ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..0dd564d --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +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. diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..4caff01 --- /dev/null +++ b/NEWS @@ -0,0 +1,102 @@ +-*- 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 diff --git a/README b/README new file mode 100644 index 0000000..fbd7cf0 --- /dev/null +++ b/README @@ -0,0 +1,15 @@ +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 . + +Nathan Froyd +18 March 2008 diff --git a/TODO b/TODO new file mode 100644 index 0000000..e34ae4c --- /dev/null +++ b/TODO @@ -0,0 +1,68 @@ + -*- 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} diff --git a/aa-trees.lisp b/aa-trees.lisp new file mode 100644 index 0000000..09fceb3 --- /dev/null +++ b/aa-trees.lisp @@ -0,0 +1,62 @@ +(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*)) diff --git a/avl-trees.lisp b/avl-trees.lisp new file mode 100644 index 0000000..afc4393 --- /dev/null +++ b/avl-trees.lisp @@ -0,0 +1,137 @@ +(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*)) diff --git a/binary-trees.lisp b/binary-trees.lisp new file mode 100644 index 0000000..bccc1b6 --- /dev/null +++ b/binary-trees.lisp @@ -0,0 +1,274 @@ +(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))) diff --git a/generics.lisp b/generics.lisp new file mode 100644 index 0000000..b533629 --- /dev/null +++ b/generics.lisp @@ -0,0 +1,26 @@ +(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)))) diff --git a/iterator.lisp b/iterator.lisp new file mode 100644 index 0000000..3cdaa1c --- /dev/null +++ b/iterator.lisp @@ -0,0 +1,39 @@ +(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))))))))) diff --git a/load.lisp b/load.lisp new file mode 100644 index 0000000..a5ac535 --- /dev/null +++ b/load.lisp @@ -0,0 +1,16 @@ +(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 diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..3e50a70 --- /dev/null +++ b/package.lisp @@ -0,0 +1,30 @@ +(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)) diff --git a/patricia.lisp b/patricia.lisp new file mode 100644 index 0000000..d3870af --- /dev/null +++ b/patricia.lisp @@ -0,0 +1,22 @@ +(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) + ) diff --git a/print.lisp b/print.lisp new file mode 100644 index 0000000..6e1294f --- /dev/null +++ b/print.lisp @@ -0,0 +1,48 @@ +(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))) diff --git a/red-black-trees.lisp b/red-black-trees.lisp new file mode 100644 index 0000000..bc222ff --- /dev/null +++ b/red-black-trees.lisp @@ -0,0 +1,126 @@ +(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*)) diff --git a/rt.lisp b/rt.lisp new file mode 100644 index 0000000..dabd075 --- /dev/null +++ b/rt.lisp @@ -0,0 +1,409 @@ +;-*-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: #~%") + )) + (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)) diff --git a/tree-test.lisp b/tree-test.lisp new file mode 100644 index 0000000..2a2ca37 --- /dev/null +++ b/tree-test.lisp @@ -0,0 +1,250 @@ +(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) diff --git a/trees.asd b/trees.asd new file mode 100644 index 0000000..b8b3a47 --- /dev/null +++ b/trees.asd @@ -0,0 +1,52 @@ +;;; -*- mode: lisp -*- + +(cl:defpackage #:trees-system + (:use #:cl #:asdf)) +(cl:in-package #:trees-system) + +(asdf:defsystem :trees + :version "0.11" + :author "Nathan Froyd " + :maintainer "Nathan Froyd " + :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"))) diff --git a/types.lisp b/types.lisp new file mode 100644 index 0000000..d2235d1 --- /dev/null +++ b/types.lisp @@ -0,0 +1,65 @@ +(in-package :trees) + + +;;; 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)) + +;;; 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)) diff --git a/utils.lisp b/utils.lisp new file mode 100644 index 0000000..7afe32e --- /dev/null +++ b/utils.lisp @@ -0,0 +1,162 @@ +(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)))))) diff --git a/validate.lisp b/validate.lisp new file mode 100644 index 0000000..c2260b5 --- /dev/null +++ b/validate.lisp @@ -0,0 +1,87 @@ +(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))