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)
cl-prevalence-cvs@common-lisp.net