[elephant-cvs] CVS elephant/src/elephant

[ieslick]

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv21893/src/elephant

Modified Files:
	package.lisp serializer2.lisp 
Added Files:
	pset.lisp 
Log Message:
Trial pset abstraction; fix for debug serialize of complex and more documentation edits

--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/04/01 20:56:19	1.28
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp	2007/04/06 02:51:48	1.29
@@ -206,6 +206,8 @@
    #:persistent #:persistent-object #:persistent-metaclass #:defpclass
    #:persistent-collection #:drop-pobject
 
+   #:pset #:make-pset #:insert-item #:remove-item #:map-pset #:find-item #:pset-list
+
    #:btree #:make-btree
    #:get-value #:remove-kv #:existsp
    #:indexed-btree #:make-indexed-btree 
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/04/04 15:28:29	1.36
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/04/06 02:51:48	1.37
@@ -368,7 +368,8 @@
     (,+object+ . "standard object")
     (,+array+ . "array")
     (,+struct+ . "struct")
-    (,+class+ . "class")))
+    (,+class+ . "class")
+    (,+complex+ . "complex")))
 
 (defun enable-deserializer-tracing ()
   (setf *trace-deserializer* t))

--- /project/elephant/cvsroot/elephant/src/elephant/pset.lisp	2007/04/06 02:51:48	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/pset.lisp	2007/04/06 02:51:48	1.1
(in-package :elephant)

;;
;; Simple implementation of persistent sets
;;

;;
;; Public API
;;

(defclass pset (persistent-collection) ()
  (:documentation "An unordered persistent collection of unique elements according to
                   serializer equal comparison"))

(defgeneric insert-item (item pset)
  (:documentation "Insert a new item into the pset"))

(defgeneric remove-item (item pset)
  (:documentation "Remove specified item from pset"))

(defgeneric map-pset (fn pset)
  (:documentation "Map operator for psets"))

(defgeneric find-item (item pset &key key test)
  (:documentation "Find a an item in the pset using key and test"))

(defgeneric pset-list (pset)
  (:documentation "Convert items of pset into a list for processing"))

(defgeneric build-pset (sc)
  (:documentation "Construct an empty default pset or backend specific pset.
                   This is an internal function used by make-pset"))

;; NOTE: Other operators?
;; - Efficient union, intersection and difference fn's exploiting an underlying
;;   sorted order?
;; - map delete operator?

;;
;; Default implementation based on btrees
;;

(defclass default-pset (pset)
  ((btree :accessor pset-btree :initarg :btree)))

(defmethod build-pset ((sc store-controller))
  "Default pset method; override if backend has better policy"
  (let ((btree (make-btree sc)))
    (make-instance 'default-pset :btree btree :sc sc :from-oid (oid btree))))

(defun make-pset (&key items pset (sc *store-controller*))
  (let ((new-pset (build-pset sc)))
    (when (and items pset)
      (error "Can only initialize a new pset with item list or pset to copy, not both"))
    (when items
      (mapc (lambda (item)
	      (insert-item item new-pset))
	    items))
    (when pset
      (map-pset (lambda (item)
		  (insert-item item new-pset))
		pset))
    new-pset))

(defmethod insert-item (item (pset default-pset))
  (setf (get-value item (pset-btree pset)) t)
  item)

(defmethod remove-item (item (pset default-pset))
  (remove-kv item (pset-btree pset))
  item)

(defmethod find-item (item (pset default-pset) &key key (test #'equal))
  (if (not (or key test))
      (get-value item (pset-btree pset))
      (map-btree (lambda (elt dc)
		   (declare (ignore dc))
		   (let ((cmpval (if key (funcall key elt) elt)))
		     (if (funcall test item cmpval)
			 (return-from find-item elt))))
		 (pset-btree pset))))

(defmethod map-pset (fn (pset default-pset))
  (map-btree fn (pset-btree pset))
  pset)

(defmethod pset-list ((pset default-pset))
  (let ((list nil))
    (flet ((collect (item)
	     (push item list)))
      (declare (dynamic-extent collect))
      (map-btree (lambda (item dc)
		   (declare (ignore dc))
		   (push item list))
		 (pset-btree pset)))
    list))