[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Tue Aug 8 13:35:18 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv23265
Modified Files:
garbage-collector.lisp index.lisp objects.lisp p-btrees.lisp
package.lisp test.lisp transactions.lisp
Log Message:
Fix bugs in BTREE-DELETE and SPLIT-BTREE-NODE.
Rename BTREE-DELETE to BTREE-DELETE-KEY and implement BTREE-DELETE for
btrees with non-unique keys.
Add stress test for btrees.
Implement the :MIN, :MAX, :INCLUDE-MIN, :INCLUDE-MAX and :ORDER arguments
for BTREE-MAP.
Add some more CL mirror functions like P-MAPCAR, P-MAPC, P-DELETE-IF, etcetera.
--- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:39:39 1.14
+++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/08 13:35:18 1.15
@@ -1,4 +1,4 @@
-;; $Id: garbage-collector.lisp,v 1.14 2006/08/03 11:39:39 alemmens Exp $
+;; $Id: garbage-collector.lisp,v 1.15 2006/08/08 13:35:18 alemmens Exp $
(in-package :rucksack)
@@ -58,12 +58,13 @@
(grow-size :initarg :grow-size
:initform nil
:accessor grow-size
- :documentation "Specifies a minimum amount to grow the
-heap when it needs to grow. If 'grow size' is an integer, the expected
-growth rate is additive and the integer is the number of octets to
-add; if it is a float, the expected growth rate for the heap is
-multiplicative and the float is the ratio of the new size to the old
-size. (The actual size might be rounded up.)")))
+ :documentation
+ "Specifies a minimum amount to grow the heap when it needs to grow.
+If 'grow size' is an integer, the expected growth rate is additive and
+the integer is the number of octets to add; if it is a float, the
+expected growth rate for the heap is multiplicative and the float is
+the ratio of the new size to the old size. (The actual size might be
+rounded up.)")))
(defparameter *initial-heap-size* (* 1024 1024)
--- /project/rucksack/cvsroot/rucksack/index.lisp 2006/05/16 22:01:27 1.2
+++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/08 13:35:18 1.3
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $
+;; $Id: index.lisp,v 1.3 2006/08/08 13:35:18 alemmens Exp $
(in-package :rucksack)
@@ -62,7 +62,7 @@
;; An index spec is a symbol or a list starting with a symbol
;; and followed by a plist of keywords and values.
-;; Examples: BTREE, (BTREE :KEY< < :KEY= = :VALUE= EQL)
+;; Examples: BTREE, (BTREE :KEY< < :VALUE= EQL)
(defun make-index (index-spec)
(if (symbolp index-spec)
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/04 22:04:43 1.5
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/08 13:35:18 1.6
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.5 2006/08/04 22:04:43 alemmens Exp $
+;; $Id: objects.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $
(in-package :rucksack)
@@ -161,8 +161,12 @@
;; DO: Other array functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Conses
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
;;
-;; Cons
+;; Basics
;;
(defclass persistent-cons (persistent-data)
@@ -195,11 +199,77 @@
(p-cons (car objects)
(apply #'p-list (cdr objects)))))
+(defun unwrap-persistent-list (list)
+ "Converts a persistent list to a 'normal' Lisp list."
+ (loop until (p-endp list)
+ collect (p-car list)
+ do (setq list (p-cdr list))))
;;
+;; Other functions from chapter 14 of the spec.
+;;
+
+(defmethod p-endp ((object (eql nil)))
+ t)
+
+(defmethod p-endp ((object persistent-cons))
+ nil)
+
+(defmethod p-endp ((object t))
+ (error 'type-error
+ :datum object
+ :expected-type '(or null persistent-cons)))
+
+(defmethod p-cddr ((cons persistent-cons))
+ (p-cdr (p-cdr cons)))
+
+(defun p-mapcar (function list)
+ ;; DO: Accept more than one list argument.
+ (let ((result '()))
+ (loop while list do
+ (setq result (p-cons (funcall function (p-car list))
+ result)
+ list (p-cdr list)))
+ result))
+
+(defun p-mapc (function list)
+ ;; DO: Accept more than one list argument.
+ (let ((tail list))
+ (loop while tail do
+ (funcall function (p-car tail))
+ (setq tail (p-cdr tail)))
+ list))
+
+(defun p-maplist (function list)
+ ;; DO: Accept more than one list argument.
+ (let ((result '()))
+ (loop while list do
+ (setq result (p-cons (funcall function list) result)
+ list (p-cdr list)))
+ result))
+
+(defun p-mapl (function list)
+ ;; DO: Accept more than one list argument.
+ (let ((tail list))
+ (loop while tail do
+ (funcall function tail)
+ (setq tail (p-cdr tail)))
+ list))
+
+(defun p-member-if (predicate list &key key)
+ (unless key
+ (setq key #'identity))
+ (p-mapl (lambda (tail)
+ (when (funcall predicate (funcall key (p-car tail)))
+ (return-from p-member-if tail)))
+ list)
+ nil)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Persistent sequence functions
;; (Just a start...)
-;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check-p-vector (persistent-array function-name)
(unless (= 1 (length (p-array-dimensions persistent-array)))
@@ -211,6 +281,15 @@
(check-p-vector vector 'p-length)
(first (p-array-dimensions vector)))
+(defmethod p-length ((list persistent-cons))
+ ;; DO: Check for circular lists.
+ (let ((result 0))
+ (p-mapc (lambda (pair)
+ (declare (ignore pair))
+ (incf result))
+ list)
+ result))
+
(defmethod p-find (value (vector persistent-array)
&key (key #'identity) (test #'p-eql)
(start 0) (end nil))
@@ -226,12 +305,11 @@
&key (key #'identity) (test #'p-eql)
(start 0) (end nil))
;; Move list to start position.
- (setq list
- (loop repeat start
- do (setq list (p-cdr list))))
+ (loop repeat start
+ do (setq list (p-cdr list)))
;; The real work.
(loop for i from start do
- (if (or (endp list) (and end (= i end)))
+ (if (or (p-endp list) (and end (= i end)))
(return-from p-find nil)
(let ((elt (funcall key (p-car list))))
(if (funcall test value elt)
@@ -269,6 +347,43 @@
(cache-touch-object vector-1 (cache vector-1))
vector-1)
+
+(defmethod p-delete-if (test (list persistent-cons)
+ &key (from-end nil) (start 0) end count key)
+ ;; DO: Implement FROM-END.
+ ;; DO: Write tests.
+ (declare (ignore from-end))
+ (unless key
+ (setq key #'identity))
+ ;; Move list to start position.
+ (let ((tail list)
+ (prev nil))
+ (loop repeat start
+ do (setq prev tail
+ tail (p-cdr tail)))
+ ;; The real work.
+ (let ((nr-deleted 0))
+ (loop for i from start do
+ (if (or (p-endp tail)
+ (and end (= i end))
+ (and count (>= nr-deleted count)))
+ (return-from p-delete-if list)
+ (if (funcall test (funcall key (p-car tail)))
+ ;; Delete the element.
+ (progn
+ (if prev
+ (setf (p-cdr prev) (p-cdr tail))
+ (setq list (p-cdr tail)))
+ ;; Keep count.
+ (incf nr-deleted))
+ ;; Don't delete anything.
+ (setq prev tail)))
+ ;; Keep moving.
+ (setq tail (p-cdr tail)))))
+ ;; Return the (possibly modified) list.
+ list)
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Full fledged persistent objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 22:04:43 1.7
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/08 13:35:18 1.8
@@ -1,7 +1,11 @@
-;; $Id: p-btrees.lisp,v 1.7 2006/08/04 22:04:43 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $
(in-package :rucksack)
+;; DO: We probably need a lock per btree. Each btree operation should
+;; be wrapped in a WITH-LOCK to make sure that nobody else changes the btree
+;; halfway during a btree operation.
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Btrees: API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -14,12 +18,14 @@
#:btree-max-node-size #:btree-unique-keys-p
#:btree-key-type #:btree-value-type
#:btree-node-class
+ #:btree-nr-keys #:btree-nr-values
;; Nodes
#:btree-node
;; Functions
- #:btree-search #:btree-insert #:btree-delete #:map-btree
+ #:btree-search #:btree-insert #:btree-delete #:btree-delete-key
+ #:map-btree #:map-btree-keys
;; Conditions
#:btree-error #:btree-search-error #:btree-insertion-error
@@ -27,9 +33,99 @@
#:btree-error-btree #:btree-error-key #:btree-error-value
|#
+(defgeneric btree-nr-keys (btree)
+ (:documentation "Returns the number of keys in a btree."))
+
+(defgeneric btree-nr-values (btree)
+ (:documentation "Returns the number of values in a btree."))
+
+
+(defgeneric btree-search (btree key &key errorp default-value)
+ (:documentation
+ "Returns the value (or persistent list of values, for btrees that
+don't have unique keys) associated with KEY. If the btree has
+non-unique keys and no value is found, the empty list is returned. If
+the btree has unique keys and no value is found, the result depends on
+the ERRORP option: if ERRORP is true, a btree-search-error is
+signalled; otherwise, DEFAULT-VALUE is returned."))
+
+(defgeneric btree-insert (btree key value &key if-exists)
+ (:documentation
+ "Adds an association from KEY to VALUE to a btree.
+
+IF-EXISTS can be either :OVERWRITE (default) or :ERROR.
+
+If the btree has unique keys (see BTREE-UNIQUE-KEYS-P) and KEY is
+already associated with another (according to BTREE-VALUE=) value, the
+result depends on the IF-EXISTS option: if IF-EXISTS is :OVERWRITE,
+the old value is overwriten; if IF-EXISTS is :ERROR, a
+BTREE-KEY-ALREADY-PRESENT-ERROR is signaled.
+
+For btrees with non-unique keys, the IF-EXISTS option is ignored and
+VALUE is just added to the list of values associated with KEY (unless
+VALUE is already associated with KEY; in that case nothing
+happens)."))
+
+
+(defgeneric btree-delete (btree key value &key if-does-not-exist)
+ (:documentation
+ "Removes an association from KEY to VALUE from a btree.
+IF-DOES-NOT-EXIST can be either :IGNORE (default) or :ERROR.
+If there is no association from KEY to VALUE and IF-DOES-NOT-EXIST
+is :ERROR, a BTREE-DELETION-ERROR is signaled."))
-#+nil(declaim (optimize (debug 3) (speed 0) (space 0)))
+(defgeneric btree-delete-key (btree key &key if-does-not-exist)
+ (:documentation
+ "Removes KEY and all associated values from a btree.
+IF-DOES-NOT-EXIST can be either :IGNORE (default) or :ERROR.
+
+For a btree with unique-keys that contains a value for KEY, this
+operation is identical to
+
+ (btree-delete btree key (btree-search btree key))
+
+For a btree with non-unique keys, it's identical to
+
+ (dolist (value (unwrap-persistent-list (btree-search btree key)))
+ (btree-delete btree key value))"))
+
+
+(defgeneric map-btree (btree function
+ &key min max include-min include-max order)
+ (:documentation
+ "Calls FUNCTION for all key/value associations in the btree where
+key is in the specified interval (this means that FUNCTION can be
+called with the same key more than once for btrees with non-unique
+keys). FUNCTION must be a binary function; the first argument is the
+btree key, the second argument is an associated value.
+
+MIN, MAX, INCLUDE-MIN and INCLUDE-MAX specify the interval. The
+interval is left-open if MIN is nil, right-open if MAX is nil. The
+interval is inclusive on the left if INCLUDE-MIN is true (and
+exclusive on the left otherwise). The interval is inclusive on the
+right if INCLUDE-MAX is true (and exclusive on the right otherwise).
+
+ORDER is either :ASCENDING (default) or :DESCENDING."))
+
+
+(defgeneric map-btree-keys (btree function
+ &key min max include-min include-max order)
+ (:documentation
+ "Calls FUNCTION for all keys in the btree where key is in the
+specified interval. FUNCTION must be a binary function; the first
+argument is the btree key, the second argument is the btree value (or
+persistent list of values, for btrees with non-unique keys). FUNCTION
+will be called exactly once for each key in the btree.
+
+MIN, MAX, INCLUDE-MIN and INCLUDE-MAX specify the interval. The
+interval is left-open if MIN is nil, right-open if MAX is nil. The
+interval is inclusive on the left if INCLUDE-MIN is true (and
+exclusive on the left otherwise). The interval is inclusive on the
+right if INCLUDE-MAX is true (and exclusive on the right otherwise).
+
+ORDER is either :ASCENDING (default) or :DESCENDING."))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; B-trees
@@ -77,6 +173,15 @@
(define-condition btree-type-error (btree-error type-error)
())
+(define-condition btree-deletion-error (btree-error)
+ ((key :initarg :key :reader btree-error-key)
+ (value :initarg :value :reader btree-error-value))
+ (:report (lambda (condition stream)
+ (format stream "Can't delete the association from ~S to ~S
+because it doesn't exist."
+ (btree-error-key condition)
+ (btree-error-value condition)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Classes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -92,12 +197,13 @@
(max-node-size :initarg :max-node-size
:reader btree-max-node-size
:initform 100
- :documentation "An integer specifying the preferred maximum number
-of keys per btree node.")
+ :documentation "An integer specifying the preferred
+maximum number of keys per btree node.")
(unique-keys-p :initarg :unique-keys-p
:reader btree-unique-keys-p
:initform t
- :documentation "If false, one key can correspond to more than one value.")
+ :documentation
+ "If false, one key can correspond to more than one value.")
(key-type :initarg :key-type
:reader btree-key-type
:initform t
@@ -139,7 +245,7 @@
(defmethod btree-key>= ((btree btree))
(lambda (key1 key2)
- (funcall (btree-key< btree) key2 key1)))
+ (not (funcall (btree-key< btree) key1 key2))))
(defmethod btree-key<= ((btree btree))
(let ((key< (btree-key< btree)))
@@ -175,6 +281,32 @@
(:metaclass persistent-class))
;;
+;; Info functions
+;;
+
+(defmethod btree-nr-keys ((btree btree))
+ (if (slot-boundp btree 'root)
+ (btree-node-nr-keys (btree-root btree))
+ 0))
+
+(defmethod btree-node-nr-keys ((node btree-node))
+ (if (btree-node-leaf-p node)
+ (btree-node-index-count node)
+ (loop for i below (btree-node-index-count node)
+ sum (btree-node-nr-keys (binding-value (node-binding node i))))))
+
+
+(defmethod btree-nr-values ((btree btree))
+ (if (btree-unique-keys-p btree)
+ (btree-nr-keys btree)
+ (let ((result 0))
+ (map-btree-keys btree
+ (lambda (key p-values)
+ (declare (ignore key))
+ (incf result (p-length p-values))))
+ result)))
+
+;;
;; Bindings
;;
@@ -220,7 +352,7 @@
(defmethod print-object ((node btree-node) stream)
(print-unreadable-object (node stream :type t :identity t)
- (format stream "with ~D pairs" (btree-node-index-count node))))
+ (format stream "with ~D bindings" (btree-node-index-count node))))
;;
;; Debugging
@@ -229,30 +361,56 @@
(defun display-node (node)
(pprint (node-as-cons node)))
-(defun node-as-cons (node)
+(defun node-as-cons (node &optional (unique-keys t))
(loop with index = (btree-node-index node)
with leaf-p = (btree-node-leaf-p node)
for i below (btree-node-index-count node)
for binding = (p-aref index i)
collect (list (binding-key binding)
(if leaf-p
- (binding-value binding)
+ (if unique-keys
+ (binding-value binding)
+ (unwrap-persistent-list (binding-value binding)))
(node-as-cons (binding-value binding))))))
+(defun btree-as-cons (btree)
+ (and (slot-value btree 'root)
+ (node-as-cons (btree-root btree) (btree-unique-keys-p btree))))
+
+
+;;
+;; Depth and balance
+;;
+
+(defmethod node-max-depth ((node btree-node))
+ (if (btree-node-leaf-p node)
+ 0
+ (loop for i below (btree-node-index-count node)
+ for binding = (node-binding node i)
+ maximize (1+ (node-max-depth (binding-value binding))))))
+
+(defmethod node-min-depth ((node btree-node))
+ (if (btree-node-leaf-p node)
+ 0
+ (loop for i below (btree-node-index-count node)
+ for binding = (node-binding node i)
+ minimize (1+ (node-min-depth (binding-value binding))))))
+
+(defmethod btree-depths ((btree btree))
+ (if (slot-value btree 'root)
+ (values (node-min-depth (btree-root btree))
+ (node-max-depth (btree-root btree)))
+ (values 0 0)))
+
+(defmethod btree-balanced-p ((btree btree))
+ (multiple-value-bind (min max)
+ (btree-depths btree)
+ (<= (- max min) 1)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Search
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric btree-search (btree key &key errorp default-value)
- (:documentation "Returns the value (or list of values, for btrees
-that don't have unique keys) corresponding to KEY. If the btree has
-non-unique keys and no value is found, the empty list is returned. If
-the btree has unique keys and no value is found, the result depends on
-ERRORP option: if ERRORP is true, a btree-search-error is signalled;
-otherwise, DEFAULT-VALUE is returned."))
-
-
(defmethod btree-search (btree key &key (errorp t) (default-value nil))
(restart-case
(if (slot-boundp btree 'root)
@@ -260,7 +418,7 @@
(not-found btree key errorp default-value))
(use-value (value)
:report (lambda (stream)
- (format stream "Specifiy a value to use this time for key ~S." key))
+ (format stream "Specify a value to use this time for key ~S." key))
:interactive (lambda ()
(format t "Enter a value for key ~S: " key)
(multiple-value-list (eval (read))))
@@ -285,28 +443,19 @@
;; Node-search
;;
-(defun find-binding-in-node (key node btree)
- (let ((index-count (btree-node-index-count node)))
- (and (plusp index-count)
- (loop with array = (btree-node-index node)
- with btree-key< = (btree-key< btree)
- for i from 0 below index-count
- for candidate = (p-aref array i)
- for candidate-key = (binding-key candidate)
- while (funcall btree-key< candidate-key key)
- finally (when (funcall (btree-key= btree) key candidate-key)
- (return candidate))))))
-
(defgeneric node-search (btree node key errorp default-value)
(:method ((btree btree) (node btree-node) key errorp default-value)
+ (let ((binding (node-search-binding btree node key)))
+ (if binding
+ (binding-value binding)
+ (not-found btree key errorp default-value)))))
+
+(defgeneric node-search-binding (btree node key)
+ (:method ((btree btree) (node btree-node) key)
(if (btree-node-leaf-p node)
- (let ((binding (find-binding-in-node key node btree)))
- (if binding
- (binding-value binding)
- (not-found btree key errorp default-value)))
+ (find-binding-in-node key node btree)
(let ((subnode (find-subnode btree node key)))
- (node-search btree subnode key errorp default-value)))))
-
+ (node-search-binding btree subnode key)))))
(defun find-subnode (btree node key)
"Returns the subnode that contains more information for the given key."
@@ -323,13 +472,22 @@
do (return-from find-subnode (binding-value binding)))
(error "This shouldn't happen."))
+(defun find-binding-in-node (key node btree)
+ (let ((index-count (btree-node-index-count node)))
+ (and (plusp index-count)
+ (loop with array = (btree-node-index node)
+ with btree-key< = (btree-key< btree)
+ for i from 0 below index-count
+ for candidate = (p-aref array i)
+ for candidate-key = (binding-key candidate)
+ while (funcall btree-key< candidate-key key)
+ finally (when (funcall (btree-key= btree) key candidate-key)
+ (return candidate))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Insert
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric btree-insert (btree key value &key if-exists))
-
(defmethod btree-insert ((btree btree) key value &key (if-exists :overwrite))
;; Check that key and value are of the right type.
(unless (typep key (btree-key-type btree))
@@ -361,14 +519,17 @@
(defun check-btree (btree)
;; Check that it is completely sorted.
(let (prev-key)
- (map-btree btree
- (lambda (key value)
- (declare (ignore value))
- (when prev-key
- (unless (funcall (btree-key< btree) prev-key key)
- (display-node (btree-root btree))
- (error "Btree inconsistency between ~D and ~D" prev-key key)))
- (setq prev-key key)))))
+ (map-btree-keys btree
+ (lambda (key value)
+ (declare (ignore value))
+ (when prev-key
+ (unless (funcall (btree-key< btree) prev-key key)
+ (pprint (btree-as-cons btree))
+ (error "Btree inconsistency between ~D and ~D" prev-key key)))
+ (setq prev-key key))))
+ ;; Check that it is balanced
+ (unless (btree-balanced-p btree)
+ (error "Btree ~S is not balanced." btree)))
(defun make-root (btree left-key left-subnode right-key right-subnode)
@@ -385,11 +546,13 @@
(defgeneric btree-node-insert (btree node parent-stack key value if-exists))
-(defmethod btree-node-insert ((btree btree) (node btree-node) parent-stack key value if-exists)
+(defmethod btree-node-insert ((btree btree) (node btree-node)
+ parent-stack key value if-exists)
(cond ((btree-node-leaf-p node)
(leaf-insert btree node parent-stack key value if-exists))
(t (let ((subnode (find-subnode btree node key)))
- (btree-node-insert btree subnode (cons node parent-stack) key value if-exists)))))
+ (btree-node-insert btree subnode (cons node parent-stack)
+ key value if-exists)))))
(defun smallest-key (node)
(if (btree-node-leaf-p node)
@@ -397,9 +560,10 @@
(smallest-key (binding-value (node-binding node 0)))))
[351 lines skipped]
--- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/04 22:04:43 1.4
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/08 13:35:18 1.5
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.4 2006/08/04 22:04:43 alemmens Exp $
+;; $Id: package.lisp,v 1.5 2006/08/08 13:35:18 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -32,8 +32,11 @@
#:p-cons #:p-array
#:p-eql
#:p-car #:p-cdr #:p-list
+ #:unwrap-persistent-list
+ #:p-mapcar #:p-mapc #:p-maplist #:p-mapl
+ #:p-member-if
#:p-make-array #:p-aref #:p-array-dimensions
- #:p-length #:p-find #:p-replace #:p-position
+ #:p-length #:p-find #:p-replace #:p-delete-if #:p-position
;; Heaps
#:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap
@@ -83,8 +86,10 @@
#:btree-max-node-size #:btree-unique-keys-p
#:btree-key-type #:btree-value-type
#:btree-node-class #:btree-node
+ #:btree-nr-keys #:btree-nr-values
;; Functions
- #:btree-search #:btree-insert #:btree-delete #:map-btree
+ #:btree-search #:btree-insert #:btree-delete #:btree-delete-key
+ #:map-btree #:map-btree-keys
;; Conditions
#:btree-error #:btree-search-error #:btree-insertion-error
#:btree-key-already-present-error #:btree-type-error
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/04 22:04:43 1.5
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/08 13:35:18 1.6
@@ -1,4 +1,4 @@
-;; $Id: test.lisp,v 1.5 2006/08/04 22:04:43 alemmens Exp $
+;; $Id: test.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $
(in-package :test-rucksack)
@@ -58,7 +58,8 @@
(p-test (p-make-array 2 :initial-contents '(a b))
(equal '(a b)
(list (p-aref it 0) (p-aref it 1))))
-
+
+
;;
;; Persistent-objects
;;
@@ -92,6 +93,37 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Test objects
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun test-objects ()
+ ;; P-DELETE-IF
+ (p-test (p-list 1 2 3 4 5)
+ (equal '(1 3 5)
+ (unwrap-persistent-list (p-delete-if #'evenp it))))
+ (p-test (p-list 1 2 3 4 5)
+ (equal '(2 4)
+ (unwrap-persistent-list (p-delete-if #'oddp it))))
+ (p-test (p-list 1 2 4 6)
+ (equal '(1)
+ (unwrap-persistent-list (p-delete-if #'evenp it ))))
+ (p-test (p-list 1 2 3 4 5)
+ (equal '()
+ (unwrap-persistent-list (p-delete-if (constantly t) it ))))
+ (p-test (p-list 1 2 3 4 5)
+ (equal '(3 4 5)
+ (unwrap-persistent-list (p-delete-if (constantly t) it :count 2))))
+ (p-test (p-list 1 2 3 4 5)
+ (equal '(1 2 3 4 5)
+ (unwrap-persistent-list (p-delete-if (constantly t) it :count 0))))
+ ;; DO: We need a lot more tests here for other functions like
+ ;; P-MEMBER-IF, P-FIND, P-REPLACE, etcetera.
+ :ok)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Test basic create, load and update functionality with many objects, so
;;; the incremental garbage collector needs to do some work too.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -153,6 +185,10 @@
;; Test btrees as just another persistent data structure.
;;
+(defparameter *format-strings*
+ ;; Different ways of printing integers.
+ '("~R" "~:R" "~@R" "~D"))
+
(defun shuffle (array)
(loop with n = (array-dimension array 0)
repeat n
@@ -161,19 +197,16 @@
when (/= i j)
do (rotatef (aref array i) (aref array j))))
+
(defun check-size (btree expected)
(format t "~&Counting~%")
- (let ((count 0))
- (map-btree btree
- (lambda (key value)
- (declare (ignore key value))
- (incf count)))
- (unless (= count expected)
+ (let ((count (btree-nr-values btree)))
+ (unless (= count expected)
(error "Wrong btree size - expected ~A, got ~A."
expected count))))
(defun check-order (btree)
- (format t "~&Checking order~%")
+ (format t "~&Checking order and balance~%")
(rs::check-btree btree))
(defun check-contents (btree)
@@ -189,7 +222,9 @@
(prog1 (progn , at body)
(format t "~&Committing..."))))
-(defun test-btree (&key (n 20000) (node-size 100) (delete (floor n 10)) check-contents)
+(defun test-btree (&key (n 20000) (node-size 100) (delete (floor n 10))
+ (unique-keys t)
+ check-contents)
;; Create a rucksack with a btree of size N that maps random
;; integers to the equivalent strings as a cardinal English number.
;; Use node size NODE-SIZE for the btree.
@@ -206,7 +241,11 @@
for i from 1
when (zerop (mod i 1000))
do (format t "~D " i)
- do (btree-insert btree key (format nil "~R" key)))
+ do (btree-insert btree key
+ (format nil (first *format-strings*) key))
+ do (unless unique-keys
+ (loop for format-string in (rest *format-strings*)
+ do (btree-insert btree key (format nil format-string key)))))
(add-rucksack-root btree rucksack))))
(with-rucksack (rucksack *test-suite*)
(with-transaction ()
@@ -225,7 +264,7 @@
(dotimes (i delete)
(when (zerop (mod (1+ i) 1000))
(format t "~D " (1+ i)))
- (btree-delete btree (aref array i)))
+ (btree-delete-key btree (aref array i)))
(check-order btree)
(check-contents btree)))
(with-transaction* ()
@@ -249,9 +288,107 @@
(check-contents btree)))))))
:ok)
+;;
+;; Btrees with non-unique keys
+
+(defun check-non-unique-contents (btree)
+ (format t "~&Checking contents~%")
+ (map-btree btree
+ (lambda (key value)
+ (let ((strings (loop for format-string in *format-strings*
+ collect (format nil format-string key))))
+ (unless (member value strings :test #'string-equal)
+ (error "Value mismatch: Expected one of ~S for ~S, got ~S."
+ strings key value))))))
+
+
+(defun test-non-unique-btree (&key (n 20000) (node-size 100) (delete (floor n 8))
+ check-contents)
+ ;; Create a rucksack with a btree of size N (N must be a multiple of 4) that
+ ;; maps random integers to four different equivalent strings (in Roman and
+ ;; English notation).
+ ;; Use node size NODE-SIZE for the btree.
+ ;; If DELETE is not NIL, it must be a multiple of 4; delete that number of
+ ;; elements as well.
+ (let* ((nr-formats (length *format-strings*))
+ (array-size (floor n nr-formats))
+ (array (make-array array-size
+ :initial-contents (loop for i from 1 to array-size collect i))))
+ (assert (zerop (mod n nr-formats)))
+ (assert (zerop (mod delete nr-formats)))
+ (shuffle array)
+ (with-rucksack (rucksack *test-suite* :if-exists :supersede)
+ (with-transaction* ()
+ (format t "~&Inserting~%")
+ (let ((btree (make-instance 'btree :value= 'string-equal
+ :max-node-size node-size
+ :unique-keys-p nil)))
+ (loop for key across array
+ for i from 1
+ when (zerop (mod i 200))
+ do (format t "~D " i)
+ do (loop for format-string in *format-strings*
+ do (btree-insert btree key (format nil format-string key))))
+ (add-rucksack-root btree rucksack))))
+ (with-rucksack (rucksack *test-suite*)
+ (with-transaction ()
+ (let ((btree (first (rucksack-roots rucksack))))
+ (check-order btree)
+ (check-size btree n)
+ (when check-contents
+ (check-non-unique-contents btree))))
+ (when delete
+ (shuffle array)
+ (setq array (subseq array 0 (floor delete nr-formats)))
+ (shuffle array)
+ (with-transaction* ()
+ (format t "~&Deleting~%")
+ (let ((btree (first (rucksack-roots rucksack))))
+ (loop for i below (floor delete nr-formats)
+ do (loop for j below nr-formats
+ do (when (zerop (mod (+ j (* nr-formats i)) 10))
+ (format t "~D " (+ j (* nr-formats i))))
+ do (let* ((key (aref array i))
+ (from-end (oddp key))
+ (index (if from-end
+ j
+ (- nr-formats (1+ j))))
+ (format-string (elt *format-strings* index))
+ (value (format nil format-string key)))
+ (btree-delete btree key value
+ :if-does-not-exist :error))))
+ (check-order btree)
+ (check-size btree (- n delete))
+ (check-non-unique-contents btree)))
+ (with-transaction* ()
+ (let ((btree (first (rucksack-roots rucksack))))
+ (check-order btree)
+ (check-size btree (- n delete))
+ (when check-contents
+ (check-contents btree))
+ (format t "~&Reinserting~%")
+ (shuffle array)
+ (dotimes (i (floor delete nr-formats))
+ (when (zerop (mod (1+ i) 10))
+ (format t "~D " (1+ i)))
+ (let ((key (aref array i)))
+ (loop for format-string in *format-strings*
+ do (btree-insert btree key (format nil format-string key)))))))
+ (with-transaction ()
+ (let ((btree (first (rucksack-roots rucksack))))
+ (check-order btree)
+ (check-size btree n)
+ (when check-contents
+ (check-contents btree)))))))
+ :ok)
+(defun btree-stress-test (&key (n 1000))
+ (loop for i below n
+ do (print i)
+ do (test-non-unique-btree :n 1600 :node-size 12 :delete 1500)))
-(defun test-btree-map (&key (display t))
+(defun test-btree-map (&key (display t) min max include-min include-max
+ (order :ascending))
;; Print out the contents of the btree.
(with-rucksack (rucksack *test-suite*)
(with-transaction ()
@@ -259,7 +396,12 @@
(map-btree btree
(lambda (key value)
(when display
- (format t "~&~D -> ~A~%" key value))))))))
+ (format t "~&~D -> ~A~%" key value)))
+ :min min
+ :include-min include-min
+ :max max
+ :include-max include-max
+ :order order)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Garbage collector
--- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/04 10:37:59 1.7
+++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/08 13:35:18 1.8
@@ -1,4 +1,4 @@
-;; $Id: transactions.lisp,v 1.7 2006/08/04 10:37:59 alemmens Exp $
+;; $Id: transactions.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $
(in-package :rucksack)
@@ -70,19 +70,21 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric transaction-changed-object (transaction object-id)
- (:documentation "If the given transaction has modified the object
-with the given object id, this function returns the modified object.
-Otherwise it returns nil."))
+ (:documentation
+ "If the given transaction has modified the object with the given
+object id, this function returns the modified object. Otherwise it
+returns nil."))
(defgeneric transaction-older-p (a b)
- (:documentation "Returns true iff transaction A is older than
-transaction B."))
+ (:documentation
+ "Returns true iff transaction A is older than transaction B."))
(defgeneric find-conflicting-transaction (object-id cache transaction)
- (:documentation "Tries to find an open transaction that has modified
-the object with the given object-id and is older than the given
-transaction. Returns this conflicting transaction, if there is one.
-Otherwise it returns nil."))
+ (:documentation
+ "Tries to find an open transaction that has modified the object
+with the given object-id and is older than the given transaction.
+Returns this conflicting transaction, if there is one. Otherwise it
+returns nil."))
(defmethod transaction-nr-dirty-objects ((transaction standard-transaction))
(hash-table-count (dirty-objects transaction)))
More information about the rucksack-cvs
mailing list