Removed unecessary change to key when updating rather than inserting

base.lisp

@@ -20,7 +20,7 @@
 
 (defclass red-black-tree ()
   ((root :accessor root)
-   (leaf :reader leaf)))
+   (leaf :accessor leaf)))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;; generics
@@ -29,6 +29,9 @@
 (defgeneric rb-node-class (tree)
   (:documentation "Return the class to be used for creating nodes in the tree"))
 
+(defgeneric rb-make-node (tree &key key data)
+  (:documentation "Return a node suitable for insertion within the tree"))
+
 (defgeneric rb-insert (tree node))
 
 (defgeneric rb-insert-fixup (tree node))
@@ -88,15 +91,17 @@
 ;; generics
 ;; ---------------------------------------------------------------------------------------------------------------------
 
-(defmethod initialize-instance :after ((obj red-black-tree)  &key)
-  (let ((leaf (make-instance (rb-node-class obj))))
+(defmethod rb-make-node ((tree red-black-tree) &key ((:key key) nil) ((:data data) nil))
+  (make-instance (rb-node-class tree) :key key :data data))
+
+(defmethod initialize-instance :after ((tree red-black-tree)  &key)
+  (let ((leaf (rb-make-node tree)))
     (setf (color leaf) :black)
     (setf (parent leaf) leaf)
     (setf (left leaf) leaf)
     (setf (right leaf) leaf)
-    (setf (slot-value obj 'leaf) leaf)
-    (setf (root obj) leaf)
-    (setf (color (root obj)) :black)))
+    (setf (leaf tree) leaf)
+    (setf (root tree) leaf)))
 
 (defmethod rb-insert ((tree red-black-tree) (node red-black-node))
   (let ((z node)
@@ -328,7 +333,7 @@
 
 (defmethod rb-put ((tree red-black-tree) (key t) (data t))
   (when data ;; can't store nil
-    (let ((node (make-instance (rb-node-class tree) :key key :data data)))
+    (let ((node (rb-make-node tree :key key :data data)))
       (rb-insert tree node))))
 
 (defmethod rb-get ((tree red-black-tree) key &optional (default nil))

memory.lisp

@@ -10,10 +10,16 @@
 ;; types
 ;; ---------------------------------------------------------------------------------------------------------------------
 (defclass memory-red-black-node (red-black-node)
-  ())
+  ((parent :initform nil :accessor parent)
+   (left :initform nil :accessor left)
+   (right :initform nil :accessor right)
+   (color :initform nil :accessor color)
+   (key :initform nil :initarg :key :accessor key)
+   (data :initform nil :initarg :data :accessor data)))
 
 (defclass memory-red-black-tree (red-black-tree)
-  ())
+  ((root :accessor root)
+   (leaf :accessor leaf)))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;; implementation

persistent.lisp

@@ -21,13 +21,14 @@
   ())
 
 (defclass red-black-tree-memory-storage (red-black-tree-storage)
-  ())
+  ((objects :initform (make-array 0) :accessor objects)))
 
 (defclass red-black-tree-file-storage (red-black-tree-storage)
   ((file-name :initarg :file-name :accessor file-name)))
 
 (defclass red-black-tree-transaction ()
   ((tree :initarg :tree :accessor tree) 
+   (root :accessor root :documentation "Contains any new root for the tree, if root is changed")
    (opened :initform (make-hash-table :test #'equal) :accessor opened)
    (changed :initform (make-hash-table :test #'equal) :accessor changed)))
 
@@ -42,6 +43,10 @@
 ;; generics
 ;; ---------------------------------------------------------------------------------------------------------------------
 
+(defgeneric +opened (node))
+
+(defgeneric +changed (node))
+
 (defgeneric prb-open-storage (storage)
   (:documentation "Prepare storage for use; after this call load & save operations should succeed"))
 
@@ -52,20 +57,46 @@
   (:documentation "Load the indicated object from storage (usually a node or tree)"))
 
 (defgeneric prb-save (storage object)
-  (:documentation "Save the indicated object in storage (usually a node or tree)"))
+  (:documentation "Save the indicated object in storage (usually a node or tree); 
+    return a reference to its location within the storage"))
 
-(defgeneric prb-commit (tree)
+(defgeneric prb-commit (transaction-or-tree)
   (:documentation "Orchestrate the persisting of all changes to a tree, including all changed nodes"))
 
-(defgeneric prb-abort (tree)
+(defgeneric prb-abort (transaction-or-tree)
   (:documentation "Abandon any changes in the tree; note that any nodes held should be reacquired after an abort"))
 
 ;; ---------------------------------------------------------------------------------------------------------------------
 ;; implementation
 ;; ---------------------------------------------------------------------------------------------------------------------
 
+(defmacro with-rb-transaction (() &rest body)
+  `(let ((*rb-transaction* (make-instance 'red-black-tree-transaction)))
+     (handler-case (let ((v (multiple-value-list (progn ,@body))))
+		     (prb-commit *rb-transaction*)
+		     (values-list v))
+       (error () (progn 
+		   (prb-abort *rb-transaction*)
+		   nil)))))
+
 (defun make-persistent-red-black-tree ()
-  (make-instance 'persistent-red-black-tree))
+  (with-rb-transaction ()
+    (make-instance 'persistent-red-black-tree)))
+
+(defmethod (setf leaf) :around (leaf (tree persistent-red-black-tree))
+  (with-slots (storage) tree
+    (let ((location (prb-save storage leaf)))
+      (call-next-method location tree))))
+
+(defmethod leaf :around ((tree persistent-red-black-tree))
+  (with-slots (storage) tree
+    (let ((leaf (prb-load storage (call-next-method tree))))
+      leaf)))
+
+(defmethod (setf root) :around (root (tree persistent-red-black-tree))
+  (with-slots (storage) tree
+    (let ((new-root (prb-save storage root)))
+      (setf (root *rb-transaction*) new-root))))
 
 (defun open-persistent-red-black-tree (storage-info)
   "Return a persisted red-black tree connected to its backing storage"
@@ -79,3 +110,11 @@
 
 (defmethod rb-node-class ((tree persistent-red-black-tree))
   'persistent-red-black-node)
+
+(defmethod prb-open-storage ((storage red-black-tree-memory-storage))
+  )
+
+(defmethod prb-load ((storage red-black-tree-memory-storage) (tree persistent-red-black-tree))
+  (when (= 0 (length (objects storage)))
+    ;; storage is empty, so pre-initialize the tree, leaf, and root node storage
+    ))

tests.lisp

@@ -8,7 +8,7 @@
 (define-test create-rb-rtree-tests
     (let ((tree (make-red-black-tree)))
       (assert-true tree)
-      (assert-eq :black (slot-value (rb-tree::root tree) 'rb-tree::color))
+      (assert-eq :black (rb-tree::color (rb-tree::root tree)))
       (assert-false (rb-tree::rb-first tree))
       (assert-false (rb-tree::rb-last tree))))
 
@@ -19,7 +19,7 @@
 (define-test put-tests
   (let ((tree (make-red-black-tree)))
       (rb-put tree 1 "one")
-      (assert-eq :black (slot-value (rb-tree::root tree) 'rb-tree::color))
+      (assert-eq :black (rb-tree::color (rb-tree::root tree)))
       (assert-true t)))
 
 (define-test put-get-tests