[cells-cvs] CVS cells

[phildebrandt]

Update of /project/cells/cvsroot/cells
In directory clnet:/tmp/cvs-serv1592

Modified Files:
	md-utilities.lisp 
Log Message:
Added a cells-store.


--- /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/12 22:53:26	1.15
+++ /project/cells/cvsroot/cells/md-utilities.lisp	2008/04/17 13:39:00	1.16
@@ -86,3 +86,143 @@
      , at initargs
      :fm-parent (progn (assert self) self)))
 
+
+;;;
+;;; cells store stuff
+;;;    (w) Peter Hildebrandt
+
+(export! cells-store c?-with-stored with-store-item store-add store-lookup store-remove)
+
+(defmacro c?-with-stored ((var key store &optional default) &body body)
+  `(c? (let ((something (value (get-listener ,key ,store))))
+	 (declare (ignorable something))
+	 (trc nil "executing c?-bwhen" self :something something :lookup (store-lookup ,key ,store))
+	 (bif (,var (store-lookup ,key ,store))
+	      (progn
+		, at body)
+	      ,default))))
+
+(defmodel cells-store (family)
+  ((data :accessor data :initarg :data :cell nil)
+   (listeners :accessor listeners :initarg :listeners :cell nil))
+  (:default-initargs
+      :data (make-hash-table)
+    :listeners (make-hash-table)
+    :kids (c-in nil)))
+
+;;; infrastructure for manipulating the store and kicking rules
+
+(defmethod get-listener (key (store cells-store))
+  (or (gethash key (listeners store))
+      (let ((new-listener (make-instance 'family :fm-parent store :value (c-in 0))))
+	(with-integrity (:change)
+	  (push new-listener (kids store))
+	  (setf (gethash key (listeners store)) new-listener))
+	new-listener)))
+
+(defmethod kick-listener (key (store cells-store))
+  (bwhen (listener (gethash key (listeners store)))
+    (incf (value listener))))
+
+(defmacro with-store-item ((key store) &body body)
+  `(prog1
+       (progn , at body)
+     (kick-listener ,key ,store)))
+
+;;; item management
+
+(defmethod store-add (key (store cells-store) object)
+  (with-store-item (key store)    
+    (setf (gethash key (data store)) object)))
+
+(defmethod store-lookup (key (store cells-store) &optional default)
+  (gethash key (data store) default))
+
+(defmethod store-remove (key (store cells-hash-store))
+  (with-store-item (key store)
+    (remhash key (data store))))
+
+
+;;;  unit test
+
+(export! test-cells-store)
+
+(defmodel test-store-item (family)
+  ())
+
+(defvar *observers*)
+
+(defobserver .value ((self test-store-item))
+  (trc "    changed value" :self self :to (value self))
+  (when (boundp '*observers*)
+    (push self *observers*)))
+
+(defmacro with-assert-observers ((desc &rest asserted-observers) &body body)  
+  `(let ((*observers* nil))
+     (trc ,desc " -- checking observers")
+     , at body
+     (let ((superflous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run))
+	   (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted)))
+       (trc "called observers on" *observers* :superflous superflous-observers :failed failed-observers)
+       (assert (not superflous-observers))
+       (assert (not failed-observers)))))
+
+(defmacro assert-values ((desc) &body objects-and-values)
+  `(progn
+     (trc ,desc)
+     ,@(loop for (obj val) in objects-and-values
+	    collect `(assert (eql (value ,obj) ,val)))))
+
+(defun test-cells-store ()
+  (trc "testing cells-store -- making objects")
+  (let* ((store (make-instance 'cells-store))
+	 (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing)
+						       (bwhen (val (value v)) val))))
+	 (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing)
+							 (bwhen (val (value v)) (1+ val)))))
+	 (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing)
+						       (bwhen (val (value v)) val))))
+	 (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing)
+							 (bwhen (val (value v)) (1- val))))))
+
+    (assert-values ("assert fresh initialization")
+      (foo 'nothing)
+      (foo+1 'nothing)
+      (bar 'nothing)
+      (bar-1 'nothing))
+
+    (with-assert-observers ("adding foo" foo foo+1)
+      (store-add :foo store (make-instance 'family :value (c-in nil))))
+
+    (assert-values ("added foo = nil")
+      (foo nil)
+      (foo+1 nil)
+      (bar 'nothing)
+      (bar-1 'nothing))
+    
+    (with-assert-observers ("changing foo" foo foo+1)
+      (setf (value (store-lookup :foo store)) 1))
+
+    (assert-values ("changed foo = 1")
+      (foo 1)
+      (foo+1 2)
+      (bar 'nothing)
+      (bar-1 'nothing))
+   
+    (with-assert-observers ("adding bar = 42" bar bar-1)
+      (store-add :bar store (make-instance 'family :value (c-in 42))))
+
+    (assert-values ("changed foo = 1")
+      (foo 1)
+      (foo+1 2)
+      (bar 42)
+      (bar-1 41))
+    
+    (with-assert-observers ("changing bar to 2" bar bar-1)
+      (setf (value (store-lookup :bar store)) 2))
+
+    (assert-values ("changed foo = 1")
+      (foo 1)
+      (foo+1 2)
+      (bar 2)
+      (bar-1 1))))
\ No newline at end of file