Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv28246 Modified Files: cells.lpr Added Files: cells-store.lisp Log Message: --- /project/cells/cvsroot/cells/cells.lpr 2008/02/02 00:09:28 1.30 +++ /project/cells/cvsroot/cells/cells.lpr 2008/04/22 14:50:56 1.31 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -24,7 +24,8 @@ (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") (make-instance 'module :name "family-values.lisp") - (make-instance 'module :name "test-propagation.lisp")) + (make-instance 'module :name "test-propagation.lisp") + (make-instance 'module :name "cells-store.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/cells-store.lisp 2008/04/22 14:50:56 NONE +++ /project/cells/cvsroot/cells/cells-store.lisp 2008/04/22 14:50:56 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- #| Cells Store -- Dependence on a Hash-Table Copyright (C) 2008 by Peter Hildebrandt This library is free software; you can redistribute it and/or modify it under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. This library is distributed WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp Lesser GNU Public License for more details. |# (in-package :cells) (export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove) (defmacro c?-with-stored ((var key store &optional default) &body body) `(c? (bwhen-c-stored (,var ,key ,store ,default) ,@body))) (defmacro bwhen-c-stored ((var key store &optional if-not) &body body) (with-gensyms (gkey gstore glink gifnot) `(let ((,gkey ,key) (,gstore ,store) (,gifnot ,if-not)) (let ((,glink (query-c-link ,gkey ,gstore))) (declare (ignorable ,glink)) (trc nil "executing bwhen-c-stored" self :update-tick ,glink :lookup (store-lookup ,gkey ,gstore)) (bif (,var (store-lookup ,gkey ,gstore)) (progn ,@body) ,gifnot))))) (defmodel cells-store (family) ((data :accessor data :initarg :data :cell nil)) (:default-initargs :data (make-hash-table))) ;;; infrastructure for manipulating the store and kicking rules (defmethod entry (key (store cells-store)) (gethash key (data store))) (defmethod (setf entry) (new-data key (store cells-store)) (setf (gethash key (data store)) new-data)) (defmethod c-link (key (store cells-store)) (car (entry key store))) (defmethod (setf c-link) (new-c-link key (store cells-store)) (if (consp (entry key store)) (setf (car (entry key store)) new-c-link) (setf (entry key store) (cons new-c-link nil))) new-c-link) (defmethod item (key (store cells-store)) (cdr (entry key store))) (defmethod (setf item) (new-item key (store cells-store)) (if (consp (entry key store)) (setf (cdr (entry key store)) new-item) (setf (entry key store) (cons nil new-item))) new-item) ;;; c-links (defmodel c-link () ((value :accessor value :initform (c-in 0) :initarg :value))) (defmethod query-c-link (key (store cells-store)) (trc "c-link> query link" key store (c-link key store)) (value (or (c-link key store) (setf (c-link key store) (make-instance 'c-link))))) (defmethod kick-c-link (key (store cells-store)) (bwhen (link (c-link key store)) (trc "c-link> kick link" key store link) (with-integrity (:change :kick-c-link) (incf (value link))))) (defmacro with-store-item ((item key store) &body body) `(prog1 (symbol-macrolet ((,item '(item key store))) (progn ,@body)) (kick-c-link ,key ,store))) (defmacro with-store-entry ((key store &key quiet) &body body) `(prog1 (progn ,@body) (unless ,quiet (kick-c-link ,key ,store)))) ;;; item management (defmethod store-add (key (store cells-store) object &key quiet) (with-store-entry (key store :quiet quiet) (when (item key store) (trc "overwriting item" key (item key store))) (setf (item key store) object))) (defmethod store-lookup (key (store cells-store) &optional default) (when (mdead (item key store)) (with-store-entry (key store) (trc "looked up dead item -- resetting to nil" key store) (setf (item key store) nil))) (or (item key store) default)) (defmethod store-remove (key (store cells-store) &key quiet) (with-store-entry (key store :quiet quiet) (setf (item key store) nil))) ;;; 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") ,@body (let ((superfluous-observers (loop for run in *observers* if (not (member run (list ,@asserted-observers))) collect run)) (failed-observers (loop for asserted in (list ,@asserted-observers) if (not (member asserted *observers*)) collect asserted))) (trc "called observers on" *observers* :superflous superfluous-observers :failed failed-observers) (assert (not superfluous-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))))) (bypass-lookup? (make-instance 'family :value (c-in t))) (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?) 'no-lookup (bwhen-c-stored (v :bar store 'nothing) (value v))))))) (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)) (assert-values ("baz w/o lookup") (baz 'no-lookup)) (with-assert-observers ("activating lookup" baz) (setf (value bypass-lookup?) nil)) (assert-values ("baz w/lookup") (baz 2)) (with-assert-observers ("deleting foo" foo foo+1) (store-remove :foo store)) (assert-values ("deleted foo") (foo 'nothing) (foo+1 'nothing) (bar 2) (bar-1 1)) (with-assert-observers ("deleting bar" bar bar-1 baz) (store-remove :bar store)) (assert-values ("deleted bar") (foo 'nothing) (foo+1 'nothing) (bar 'nothing) (bar-1 'nothing) (baz 'nothing)) (with-assert-observers ("de-activating lookup" baz) (setf (value bypass-lookup?) t)) (assert-values ("baz w/o lookup") (baz 'no-lookup))))