[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Tue Feb 20 19:12:59 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv13701/src/elephant
Modified Files:
classindex.lisp collections.lisp package.lisp
Log Message:
Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/18 23:38:18 1.18
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 19:12:58 1.19
@@ -345,35 +345,56 @@
(cursor-close ,var))))
-;; =========================
-;; User-level lisp API
-;; =========================
+;; ====================================
+;; User level Mapping API
+;; ====================================
+
+(defun map-class (fn class)
+ "Perform a map operation across all instances of class. Takes a
+ function of one argument, the class instance"
+ (let* ((class (if (symbolp class)
+ (find-class class)
+ class))
+ (class-idx (find-class-index class)))
+ (flet ((map-fn (k v)
+ (declare (ignore k))
+ (funcall fn v)))
+ (declare (dynamic-extent map-fn))
+ (map-btree #'map-fn class-idx))))
+
+(defun map-instances (fn class index start end)
+ "If you want to map over a subset of instances, pick an index
+ and specify bounds for the traversal. Otherwise use map-class
+ for all instances"
+ (let* ((index (if (symbolp index)
+ (find-inverted-index class index)
+ index)))
+ (flet ((wrapper (key value pkey)
+ (declare (ignore key pkey))
+ (funcall fn value)))
+ (declare (dynamic-extent wrapper))
+ (map-index #'wrapper index :start start :end end))))
+
+
+;; ===============================
+;; User-level LIST-oriented API
+;; ===============================
(defgeneric get-instances-by-class (persistent-metaclass))
(defgeneric get-instance-by-value (persistent-metaclass slot-name value))
(defgeneric get-instances-by-value (persistent-metaclass slot-name value))
(defgeneric get-instances-by-range (persistent-metaclass slot-name start end))
-;; map instances
-;; iterate over instances
-
(defmethod get-instances-by-class ((class symbol))
(get-instances-by-class (find-class class)))
(defmethod get-instances-by-class ((class persistent-metaclass))
- (let ((instances nil)
- (cidx (find-class-index class)))
- (with-btree-cursor (cur cidx)
- (multiple-value-bind (exists? key val) (cursor-first cur)
- (declare (ignore key))
- (when exists?
- (push val instances)
- (loop
- (multiple-value-bind (exists? key val) (cursor-next cur)
- (declare (ignore key))
- (if exists?
- (push val instances)
- (return-from get-instances-by-class instances)))))))))
+ (let ((instances nil))
+ (flet ((accum (c)
+ (declare (dynamic-extent c))
+ (push c instances)))
+ (map-class #'accum class)
+ (nreverse instances))))
(defmethod get-instances-by-value ((class symbol) slot-name value)
(get-instances-by-value (find-class class) slot-name value))
@@ -381,17 +402,14 @@
(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value)
(declare (type (or string symbol) slot-name))
(let ((instances nil))
- (with-btree-cursor (cur (find-inverted-index class slot-name))
- (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value)
- (declare (ignore skey pkey))
- (when exists?
- (push val instances)
- (loop
- (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur)
- (declare (ignorable skey pkey))
- (if exists?
- (push val instances)
- (return-from get-instances-by-value instances)))))))))
+ (declare (type list instances))
+ (flet ((collector (k v pk)
+ (declare (ignore k pk))
+ (push v instances)))
+ (declare (dynamic-extent collector))
+ (map-index #'collector (find-inverted-index class slot-name)
+ :start value :end value))
+ (nreverse instances)))
(defmethod get-instance-by-value ((class symbol) slot-name value)
(let ((list (get-instances-by-value (find-class class) slot-name value)))
@@ -409,27 +427,16 @@
(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end)
(declare (type fixnum start end)
(type string idx-name))
- (with-inverted-cursor (cur class idx-name)
- (labels ((next-range (instances)
- (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur)
- (declare (ignore pkey))
- (if (and exists? (<= skey end))
- (next-in-range skey (cons val instances))
- (nreverse instances))))
- (next-in-range (key instances)
- (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur)
- (declare (ignore pkey skey))
- (if exists?
- (next-in-range key (cons val instances))
- (progn
- (cursor-pset-range cur key)
- (next-range instances))))))
- (multiple-value-bind (exists? skey val pkey) (cursor-pset-range cur start)
- (declare (ignore pkey))
- (if (and exists? (<= skey end))
- (next-in-range skey (cons val nil))
- nil)))))
-
+ (let ((instances nil))
+ (declare (type list instances))
+ (flet ((collector (k v pk)
+ (declare (ignore k pk))
+ (push v instances)))
+ (declare (dynamic-extent collector))
+ (map-index #'collector (find-inverted-index class idx-name)
+ :start start :end end))
+ (nreverse instances)))
+
(defun drop-instances (instances &key (sc *store-controller*))
(when instances
(assert (consp instances))
@@ -440,5 +447,3 @@
(drop-pobject instance))
subset)))))
-
-
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/16 07:11:02 1.9
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 19:12:58 1.10
@@ -314,27 +314,71 @@
primary key."))
-;;
-;; Some generic utility functions
-;;
+;; =======================================
+;; Generic Mapping Functions
+;; =======================================
(defmacro with-btree-cursor ((var bt) &body body)
"Macro which opens a named cursor on a BTree (primary or
not), evaluates the forms, then closes the cursor."
`(let ((,var (make-cursor ,bt)))
- (unwind-protect
- (progn , at body)
- (cursor-close ,var))))
+ (unwind-protect
+ (progn , at body)
+ (cursor-close ,var))))
(defmethod map-btree (fn (btree btree))
- "Like maphash. Default implementation - overridable"
- (with-transaction (:store-controller (get-con btree))
+ "Like maphash. Default implementation - overridable
+ Function of two arguments key and value"
+ (ensure-transaction (:store-controller (get-con btree))
(with-btree-cursor (curs btree)
(loop
(multiple-value-bind (more k v) (cursor-next curs)
+ (declare (dynamic-extent more k v))
(unless more (return nil))
(funcall fn k v))))))
+(defmethod map-index (fn (index btree-index) &rest args &key start end)
+ "Like map-btree, but takes a function of three arguments key, value and primary key
+ if you want to get at the primary key value, otherwise use map-btree"
+ (declare (dynamic-extent args))
+ (let ((sc (get-con index)))
+ (ensure-transaction (:store-controller sc)
+ (with-btree-cursor (cur index)
+ (labels ((next-range ()
+ (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur)
+ (if (or (and exists? (not end))
+ (and exists? (<= skey end)))
+ (progn
+ (funcall fn skey val pkey)
+ (next-in-range skey))
+ (return-from map-index nil))))
+ (next-in-range (key)
+ (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur)
+ (if exists?
+ (progn
+ (funcall fn skey val pkey)
+ (next-in-range key))
+ (progn
+ (cursor-pset-range cur key)
+ (next-range))))))
+ (declare (dynamic-extent next-range next-in-range))
+ (multiple-value-bind (exists? skey val pkey)
+ (if start
+ (cursor-pset-range cur start)
+ (cursor-pfirst cur))
+ (if (or (and exists? (not end))
+ (and exists? (<= skey end)))
+ (progn
+ (funcall fn skey val pkey)
+ (next-in-range skey))
+ nil)))))))
+
+
+
+;; ===============================
+;; Some generic utility functions
+;; ===============================
+
(defmethod empty-btree-p ((btree btree))
(ensure-transaction (:store-controller (get-con btree))
(with-btree-cursor (cur btree)
@@ -345,10 +389,9 @@
(eq k *elephant-properties-label*)) ;; has properties
(not (cursor-next cur)))
(t nil))))))
-
-(defun print-btree-node (k v)
- (format t "k ~A / v ~A~%" k v))
+(defun print-btree-entry (k v)
+ (format t "key: ~A / value: ~A~%" k v))
(defun dump-btree (bt &key (print-fn #'print-btree-node) (count nil))
"Print the contents of a btree for easy inspection & debugging"
@@ -361,13 +404,16 @@
(funcall print-fn k v))
bt)))
-(defun btree-keys (bt)
- (format t "BTREE keys for ~A~%" bt)
- (map-btree #'(lambda (k v)
- (format t "key ~A / value type ~A~%" k (type-of v)))
- bt))
+(defun print-btree-key-and-type (k v)
+ (format t "key ~A / value type ~A~%" k (type-of v)))
-(defun btree-differ (x y)
+(defun btree-keys (bt &key (print-fn #'print-btree-key-and-type) (count nil))
+ (format t "BTREE keys and types for ~A~%" bt)
+ (dump-btree bt :print-fn print-fn :count count))
+
+(defmethod btree-differ-p ((x btree) (y btree))
+ (assert (eq (get-con x) (get-con y)))
+ (ensure-transaction (:store-controller (get-con x))
(let ((cx1 (make-cursor x))
(cy1 (make-cursor y))
(done nil)
@@ -402,4 +448,4 @@
(cursor-close cx1)
(cursor-close cy1)
rv
- ))
+ )))
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/16 07:11:02 1.14
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/20 19:12:58 1.15
@@ -55,7 +55,7 @@
#:persistent #:persistent-object #:persistent-metaclass
#:persistent-collection #:defpclass
- #:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree
+ #:btree #:make-btree #:get-value #:remove-kv #:existp
#:indexed-btree #:make-indexed-btree
#:add-index #:get-index #:remove-index #:map-indices
#:btree-index #:get-primary-key
@@ -69,7 +69,7 @@
#:int-byte-spec
#:cursor #:secondary-cursor #:make-cursor
- #:with-btree-cursor #:cursor-close #:cursor-init
+ #:cursor-close #:cursor-init
#:cursor-duplicate #:cursor-current #:cursor-first
#:cursor-last #:cursor-next #:cursor-next-dup
#:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup
@@ -95,6 +95,21 @@
#:make-inverted-cursor #:make-class-cursor
#:with-inverted-cursor #:with-class-cursor
+ ;; Primitive mapping API
+ #:with-btree-cursor
+ #:map-btree
+ #:map-index
+
+ ;; BTREE Utilities
+ #:empty-btree-p
+ #:dump-btree
+ #:btree-keys
+ #:btree-differ-p
+
+ ;; Class mapping API
+ #:map-class
+ #:map-instances
+
;; Instance query API
#:get-instances-by-class
#:get-instance-by-value
More information about the Elephant-cvs
mailing list