[cl-prevalence-cvs] CVS update: cl-prevalence/src/managed-prevalence.lisp
Sven Van Caekenberghe
scaekenberghe at common-lisp.net
Tue Oct 5 11:35:30 UTC 2004
Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv1751/src
Modified Files:
managed-prevalence.lisp
Log Message:
merged in a contribution from randall randall: you can now create indexes on slots using index-on (or delete them using drop-index-on) and query using those indexes using find-object-with-slot
Date: Tue Oct 5 13:35:28 2004
Author: scaekenberghe
Index: cl-prevalence/src/managed-prevalence.lisp
diff -u cl-prevalence/src/managed-prevalence.lisp:1.1.1.1 cl-prevalence/src/managed-prevalence.lisp:1.2
--- cl-prevalence/src/managed-prevalence.lisp:1.1.1.1 Sun Jun 20 21:13:38 2004
+++ cl-prevalence/src/managed-prevalence.lisp Tue Oct 5 13:35:28 2004
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: managed-prevalence.lisp,v 1.1.1.1 2004/06/20 19:13:38 scaekenberghe Exp $
+;;;; $Id: managed-prevalence.lisp,v 1.2 2004/10/05 11:35:28 scaekenberghe Exp $
;;;;
;;;; The code in this file adds another layer above plain object prevalence.
;;;; We manage objects with ids in an organized fashion, adding an id counter and preferences.
@@ -34,10 +34,11 @@
(let ((classname (if (symbolp class) (string class) (class-name class))))
(intern (concatenate 'string classname "-ROOT") :keyword)))
-(defun get-objects-index-root-name (class)
- "Return the keyword symbol naming the id index of instances of class"
- (let ((classname (if (symbolp class) (string class) (class-name class))))
- (intern (concatenate 'string classname "-ID-INDEX") :keyword)))
+(defun get-objects-slot-index-name (class &optional (slot 'id))
+ "Return the keyword symbol naming the specified index of instances of class."
+ (let ((classname (if (symbolp class) (string class) (class-name class)))
+ (slotname (symbol-name slot)))
+ (intern (concatenate 'string classname "-" slotname "-INDEX") :keyword)))
(defgeneric find-all-objects (system class)
(:documentation "Return an unordered collection of all objects in system that are instances of class"))
@@ -52,33 +53,84 @@
(defmethod find-object-with-id ((system prevalence-system) class id)
"Find and return the object in system of class with id, null if not found"
- (let* ((index-name (get-objects-index-root-name class))
+ (let* ((index-name (get-objects-slot-index-name class 'id))
(index (get-root-object system index-name)))
(when index
(gethash id index))))
-(defun set-slot-values (instance slots-and-values)
- "Set slots and values of instance"
- (dolist (slot-and-value slots-and-values instance)
- (setf (slot-value instance (first slot-and-value)) (second slot-and-value))))
+(defgeneric find-object-with-slot (system class slot value)
+ (:documentation "Find and return the object in system of class with slot, null if not found"))
+
+(defmethod find-object-with-slot ((system prevalence-system) class slot value)
+ "Find and return the object in system of class with slot, null if not found.
+ This constitutes some duplicated effort with FIND-OBJECT-WITH-ID."
+ (let* ((index-name (get-objects-slot-index-name class slot))
+ (index (get-root-object system index-name)))
+ (when index
+ (find-object-with-id system class (gethash value index)))))
+
+(defun tx-create-objects-slot-index (system class slot &optional (test 'equalp))
+ "Create an index for this object on this slot, with an optional test for the hash table (add existing objects)"
+ (let ((index-name (get-objects-slot-index-name class slot)))
+ (unless (get-root-object system index-name)
+ (let ((index (make-hash-table :test test)))
+ (setf (get-root-object system index-name) index)
+ (dolist (object (find-all-objects system class))
+ (add-object-to-slot-index system class slot object))))))
+
+(defun tx-remove-objects-slot-index (system class slot)
+ "Remove an index for this object on this slot"
+ (let ((index-name (get-objects-slot-index-name class slot)))
+ (unless (get-root-object system index-name)
+ (remove-root-object system index-name))))
+
+(defun add-object-to-slot-index (system class slot object)
+ "Add an index entry using this slot to this object"
+ (let* ((index-name (get-objects-slot-index-name class slot))
+ (index (get-root-object system index-name)))
+ (when (and index (slot-boundp object slot))
+ (setf (gethash (slot-value object slot) index) (get-id object)))))
+
+(defun remove-object-from-slot-index (system class slot object)
+ "Remove the index entry using this slot to this object"
+ (let* ((index-name (get-objects-slot-index-name class slot))
+ (index (get-root-object system index-name)))
+ (when (and index (slot-boundp object slot))
+ (remhash (slot-value object slot) index))))
+
+(defun index-on (system class &optional slots (test 'equalp))
+ "Create indexes on each of the slots provided."
+ (dolist (slot slots)
+ (execute-transaction (tx-create-objects-slot-index system class slot test))))
+
+(defun drop-index-on (system class &optional slots)
+ "Drop indexes on each of the slots provided"
+ (dolist (slot slots)
+ (execute-transaction (tx-remove-objects-slot-index system class slot))))
+
+(defun slot-value-changed-p (object slot value)
+ "Return true when slot in object is not eql to value (or when the slot was unbound)"
+ (or (not (slot-boundp object slot))
+ (not (eql (slot-value object slot) value))))
-(defun tx-create-object (system &optional class slots-and-values)
+(defun tx-create-object (system class &optional slots-and-values)
"Create a new object of class in system, assigning it a unique id, optionally setting some slots and values"
(let* ((id (next-id system))
(object (make-instance class :id id))
- (index-name (get-objects-index-root-name class))
+ (index-name (get-objects-slot-index-name class 'id))
(index (or (get-root-object system index-name)
(setf (get-root-object system index-name) (make-hash-table)))))
- (set-slot-values object slots-and-values)
(push object (get-root-object system (get-objects-root-name class)))
- (setf (gethash id index) object)))
+ (setf (gethash id index) object)
+ (tx-change-object-slots system class id slots-and-values)
+ object))
(defun tx-delete-object (system class id)
- "Delete the object of class with if from the system"
+ "Delete the object of class with id from the system"
(let ((object (find-object-with-id system class id)))
(if object
(let ((root-name (get-objects-root-name class))
- (index-name (get-objects-index-root-name class)))
+ (index-name (get-objects-slot-index-name class 'id)))
(setf (get-root-object system root-name) (delete object (get-root-object system root-name)))
(remhash id (get-root-object system index-name)))
(error "no object of class ~a with id ~d found in ~s" system class id))))
@@ -86,10 +138,13 @@
(defun tx-change-object-slots (system class id slots-and-values)
"Change some slots of the object of class with id in system using slots and values"
(let ((object (find-object-with-id system class id)))
- (if object
- (set-slot-values object slots-and-values)
- (error "no object of class ~a with id ~d found in ~s" system class id))))
-
+ (unless object (error "no object of class ~a with id ~d found in ~s" system class id))
+ (loop :for (slot value) :in slots-and-values
+ :do (when (slot-value-changed-p object slot value)
+ (remove-object-from-slot-index system class slot object)
+ (setf (slot-value object slot) value)
+ (add-object-to-slot-index system class slot object)))))
+
;; We use a simple id counter to generate unique object identifiers
(defun tx-create-id-counter (system)
More information about the Cl-prevalence-cvs
mailing list