Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

*** empty log message ***

  • Loading branch information...
commit d0bc81228abb2571f906018f8ac645ce00c52bac 1 parent 6cf104c
ktilton authored
Showing with 247 additions and 4 deletions.
  1. +243 −0 cells-store.lisp
  2. +1 −2  cells-test/cells-test.lpr
  3. +3 −2 cells.lpr
View
243 cells-store.lisp
@@ -0,0 +1,243 @@
+;; -*- 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))))
View
3  cells-test/cells-test.lpr
@@ -16,8 +16,7 @@
(make-instance 'module :name "test-cycle.lisp")
(make-instance 'module :name "test-ephemeral.lisp")
(make-instance 'module :name "test-synapse.lisp")
- (make-instance 'module :name "deep-cells.lisp")
- (make-instance 'module :name "cells-store.lisp"))
+ (make-instance 'module :name "deep-cells.lisp"))
:projects (list (make-instance 'project-module :name "..\\cells"))
:libraries nil
:distributed-files nil
View
5 cells.lpr
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.