Update of /project/cells/cvsroot/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv6620/cells-test Modified Files: boiler-examples.lisp cells-test.asd df-interference.lisp hello-world-q.lisp hello-world.lisp internal-combustion.lisp lazy-propagation.lisp person.lisp test-cyclicity.lisp test-family.lisp test-kid-slotting.lisp test.lisp Removed Files: qrock.lisp ring-net-clocked.lisp ring-net.lisp Log Message: Preparing for first CVS of Cello Date: Tue Dec 16 10:03:02 2003 Author: ktilton Index: cells/cells-test/boiler-examples.lisp diff -u cells/cells-test/boiler-examples.lisp:1.1.1.1 cells/cells-test/boiler-examples.lisp:1.2 --- cells/cells-test/boiler-examples.lisp:1.1.1.1 Sat Nov 8 18:44:57 2003 +++ cells/cells-test/boiler-examples.lisp Tue Dec 16 10:03:02 2003 @@ -1,289 +1,289 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -;; -;; OK, nothing new here, just some old example code I found lying around. FWIW... -;; - -(defmodel boiler1 () - ((id :cell nil :initarg :id :accessor id :initform (random 1000000)) - (status :initarg :status :accessor status :initform nil) ;; vanilla cell - (temp :initarg :temp :accessor temp :initform nil) - (vent :initarg :vent :accessor vent :initform nil) - )) - -(defun boiler-1 () - - ;; resets debugging/testing specials - (cell-reset) - - (let ((b (make-instance 'boiler1 - :temp (cv 20) - :status (c? (if (< (temp self) 100) - :on - :off)) - :vent (c? (ecase (^status) ;; expands to (status self) and also makes coding synapses convenient - (:on :open) - (:off :closed)))))) - - (cv-assert (eql 20 (temp b))) - (cv-assert (eql :on (status b))) - (cv-assert (eql :open (vent b))) - - (setf (temp b) 100) ;; triggers the recalculation of status and then of vent - - (cv-assert (eql 100 (temp b))) - (cv-assert (eql :off (status b))) - (cv-assert (eql :closed (vent b))) - )) - -#+test -(boiler-1) - -; -; now let's see how echo functions can be used... -; and let's also demonstrate inter-object dependency by -; separating out the thermometer -; - -;;; note that thermometer is just a regular slot, it is -;;; not cellular. - -(defmodel boiler2 () - ((status :initarg :status :accessor status :initform nil) - (vent :initarg :vent :accessor vent :initform nil) - (thermometer :cell nil :initarg :thermometer :accessor thermometer :initform nil) - )) - -;;; def-c-echo ((slot-name) (&optional method-args) &body body - -;;; the def-c-echo macro defines a method with -;;; three arguments -- by default, these arguments are named -;;; self -- bound to the instance being operated on -;;; old-value -- bound to the previous value of the cellular slot -;;; named slot-name, of the instance being operated on. -;;; new-value -- bound to the new value of said cellular slot - -;;; (this is why the variables self, old-value, and new-value can exist -;;; below in the body, when it appears they are not defined in any -;;; lexical scope) - -;;; the body of the macro defines code which is executed -;;; when the the slot-name slot is initialized or changed. - -(def-c-echo status ((self boiler2)) - (trc "echo> boiler status" self :oldstatus= old-value :newstatus= new-value) - ; - ; << in real life call boiler api here to actually turn it on or off >> - ; - ) - -(def-c-echo vent ((self boiler2)) - (trc "echo> boiler vent changing from" old-value :to new-value) - ; - ; << in real life call boiler api here to actually open or close it >> - ; - ) - - -(defmodel quiet-thermometer () - ((temp :initarg :temp :accessor temp :initform nil) - )) - -(defmodel thermometer (quiet-thermometer)()) - -;;; notice instead of oldvalue and newvalue, here the -;;; old and new values are bound to parameters called oldtemp -;;; and newtemp - -(def-c-echo temp ((self thermometer) newtemp oldtemp) - (trc "echo> thermometer temp changing from" oldtemp :to newtemp)) - -;-------------------------- - - -;;; here we introduce the to-be-primary construct, which causes -;;; immediate initialization of cellular slots. - -;;; notice how the status cell of a boiler2 can depend -;;; on the temp slot of a thermometer, illustrating how -;;; dependencies can be made between the cellular slots of -;;; instances of different classes. - - -(defun boiler-2 () - (cell-reset) - (let ((b (to-be (make-instance 'boiler2 - :status (c? (eko ("boiler2 status c?") - (if (< (^temp (thermometer self)) 100) - :on :off))) - :vent (c? (ecase (^status) - (:on :open) - (:off :closed))) - :thermometer (make-instance 'thermometer - :temp (cv 20)))) - )) - - (cv-assert (eql 20 (temp (thermometer b)))) - (cv-assert (eql :on (status b))) - (cv-assert (eql :open (vent b))) - - (setf (temp (thermometer b)) 100) - - (cv-assert (eql 100 (temp (thermometer b)))) - (cv-assert (eql :off (status b))) - (cv-assert (eql :closed (vent b))) - )) - -#+test -(boiler-2) - -;;; *********************************************** -;;; *********************************************** -;;; *********************************************** - -#| intro to cells, example 3 |# - -;;; *********************************************** -;;; *********************************************** -;;; *********************************************** - - -;;; note: we use boiler2 and thermometer from example 2 in example 3, -;;; along with their def-echo methods defined in example 2. -;;; -;;; also: these do not use cv-assert to perform automatic testing, but -;;; they do illustrate a possible real-world application of synapses. to -;;; observe the difference made by synapses, one must look at the trace output -; -; now let's look at synapses, which mediate a dependency between two cells. -; the example here has an input argument (sensitivity-enabled) which when -; enables gives the temp cell an (fsensitivity 0.05) clause. - -; the example simulates a thermometer perhaps -; malfunctioning which is sending streams of values randomly plus or minus -; two-hundredths of a degree. does not sound serious, except... -; -; if you run the example as is, when the temperature gets to our on/off threshhold -; of 100, chances are you will see the boiler toggle itself on and off several times -; before the temperature moves away from 100. -; -; building maintenance personel will report this odd behavior, probably hearing the -; vent open and shut and open again several times in quick succession. - -; the problem is traced to the cell rule which reacts too slavishly to the stream -; of temperature values. a work order is cut to replace the thermometer, and to reprogram -; the controller not to be so slavish. there are lots of ways to solve this; here if -; you enable sensitivity by running example 4 you can effectively place a synapse between the -; temperature cell of the thermometer and the status cell of the boiler which -; does not even trigger the status cell unless the received value differs by the -; specified amount from the last value which was actually relayed. - -; now the boiler simply cuts off as the temperature passes 100, and stays off even if -; the thermometer temperature goes to 99.98. the trace output shows that although the temperature -; of the thermometer is changing, only occasionally does the rule to decide the boiler -; status get kicked off. -; - -(defun boiler-3 (&key (sensitivity-enabled nil)) - - (cell-reset) - - (let ((b (to-be - (make-instance 'boiler2 - :status (c? (let ((temp (if sensitivity-enabled - (^temp (thermometer self) (fsensitivity 0.05)) - (^temp (thermometer self))))) - ;;(trc "status c? sees temp" temp) - (if (< temp 100) :on :off) - )) - :vent (c? (ecase (^status) (:on :open) (:off :closed))) - :thermometer (make-instance 'quiet-thermometer :temp (cv 20)) - )))) - ; - ; let's simulate a thermometer which, when the temperature is actually - ; any given value t will indicate randomly anything in the range - ; t plus/minus 0.02. no big deal unless the actual is exactly our - ; threshold point of 100... - ; - (dotimes (x 4) - ;;(trc "top> ----------- set base to" (+ 98 x)) - (dotimes (y 10) - (let ((newtemp (+ 98 x (random 0.04) -.02))) ;; force random variation around (+ 98 x) - ;;(trc "top> ----------- set temp to" newtemp) - (setf (temp (thermometer b)) newtemp)))))) - - -(defun boiler-4 () (boiler-3 :sensitivity-enabled t)) - -;; -;; de-comment 'trc statements above to see what is happening -;; -#+test -(boiler-3) - -#+test -(boiler-4) - -(defun boiler-5 () - - (cell-reset) - - (let ((b (to-be - (make-instance 'boiler2 - :status (cv :off) - :vent (c? (trc "caculating vent" (^status)) - (if (eq (^status) :on) - (if (> (^temp (thermometer self) (fDebug 3)) 100) - :open :closed) - :whatever-off)) - :thermometer (make-instance 'quiet-thermometer :temp (cv 20)) - )))) - - (dotimes (x 4) - (dotimes (n 4) - (incf (temp (thermometer b)))) - (setf (status b) (case (status b) (:on :off)(:off :on)))))) - -#+test - -(boiler-5) - -(defun fDebug (sensitivity &optional subtypename) - (mksynapse (priorrelayvalue) - :fire-p (lambda (syn newvalue) - (declare (ignorable syn)) - (eko ("fire-p decides" priorrelayvalue sensitivity) - (delta-greater-or-equal - (delta-abs (delta-diff newvalue priorrelayvalue subtypename) subtypename) - (delta-abs sensitivity subtypename) - subtypename))) - - :relay-value (lambda (syn newvalue) - (declare (ignorable syn)) - (eko ("fsensitivity relays") - (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +;; +;; OK, nothing new here, just some old example code I found lying around. FWIW... +;; + +(defmodel boiler1 () + ((id :cell nil :initarg :id :accessor id :initform (random 1000000)) + (status :initarg :status :accessor status :initform nil) ;; vanilla cell + (temp :initarg :temp :accessor temp :initform nil) + (vent :initarg :vent :accessor vent :initform nil) + )) + +(defun boiler-1 () + + ;; resets debugging/testing specials + (cell-reset) + + (let ((b (make-instance 'boiler1 + :temp (cv 20) + :status (c? (if (< (temp self) 100) + :on + :off)) + :vent (c? (ecase (^status) ;; expands to (status self) and also makes coding synapses convenient + (:on :open) + (:off :closed)))))) + + (cv-assert (eql 20 (temp b))) + (cv-assert (eql :on (status b))) + (cv-assert (eql :open (vent b))) + + (setf (temp b) 100) ;; triggers the recalculation of status and then of vent + + (cv-assert (eql 100 (temp b))) + (cv-assert (eql :off (status b))) + (cv-assert (eql :closed (vent b))) + )) + +#+test +(boiler-1) + +; +; now let's see how echo functions can be used... +; and let's also demonstrate inter-object dependency by +; separating out the thermometer +; + +;;; note that thermometer is just a regular slot, it is +;;; not cellular. + +(defmodel boiler2 () + ((status :initarg :status :accessor status :initform nil) + (vent :initarg :vent :accessor vent :initform nil) + (thermometer :cell nil :initarg :thermometer :accessor thermometer :initform nil) + )) + +;;; def-c-echo ((slot-name) (&optional method-args) &body body + +;;; the def-c-echo macro defines a method with +;;; three arguments -- by default, these arguments are named +;;; self -- bound to the instance being operated on +;;; old-value -- bound to the previous value of the cellular slot +;;; named slot-name, of the instance being operated on. +;;; new-value -- bound to the new value of said cellular slot + +;;; (this is why the variables self, old-value, and new-value can exist +;;; below in the body, when it appears they are not defined in any +;;; lexical scope) + +;;; the body of the macro defines code which is executed +;;; when the the slot-name slot is initialized or changed. + +(def-c-echo status ((self boiler2)) + (trc "echo> boiler status" self :oldstatus= old-value :newstatus= new-value) + ; + ; << in real life call boiler api here to actually turn it on or off >> + ; + ) + +(def-c-echo vent ((self boiler2)) + (trc "echo> boiler vent changing from" old-value :to new-value) + ; + ; << in real life call boiler api here to actually open or close it >> + ; + ) + + +(defmodel quiet-thermometer () + ((temp :initarg :temp :accessor temp :initform nil) + )) + +(defmodel thermometer (quiet-thermometer)()) + +;;; notice instead of oldvalue and newvalue, here the +;;; old and new values are bound to parameters called oldtemp +;;; and newtemp + +(def-c-echo temp ((self thermometer) newtemp oldtemp) + (trc "echo> thermometer temp changing from" oldtemp :to newtemp)) + +;-------------------------- + + +;;; here we introduce the to-be-primary construct, which causes +;;; immediate initialization of cellular slots. + +;;; notice how the status cell of a boiler2 can depend +;;; on the temp slot of a thermometer, illustrating how +;;; dependencies can be made between the cellular slots of +;;; instances of different classes. + + +(defun boiler-2 () + (cell-reset) + (let ((b (to-be (make-instance 'boiler2 + :status (c? (eko ("boiler2 status c?") + (if (< (^temp (thermometer self)) 100) + :on :off))) + :vent (c? (ecase (^status) + (:on :open) + (:off :closed))) + :thermometer (make-instance 'thermometer + :temp (cv 20)))) + )) + + (cv-assert (eql 20 (temp (thermometer b)))) + (cv-assert (eql :on (status b))) + (cv-assert (eql :open (vent b))) + + (setf (temp (thermometer b)) 100) + + (cv-assert (eql 100 (temp (thermometer b)))) + (cv-assert (eql :off (status b))) + (cv-assert (eql :closed (vent b))) + )) + +#+test +(boiler-2) + +;;; *********************************************** +;;; *********************************************** +;;; *********************************************** + +#| intro to cells, example 3 |# + +;;; *********************************************** +;;; *********************************************** +;;; *********************************************** + + +;;; note: we use boiler2 and thermometer from example 2 in example 3, +;;; along with their def-echo methods defined in example 2. +;;; +;;; also: these do not use cv-assert to perform automatic testing, but +;;; they do illustrate a possible real-world application of synapses. to +;;; observe the difference made by synapses, one must look at the trace output +; +; now let's look at synapses, which mediate a dependency between two cells. +; the example here has an input argument (sensitivity-enabled) which when +; enables gives the temp cell an (fsensitivity 0.05) clause. + +; the example simulates a thermometer perhaps +; malfunctioning which is sending streams of values randomly plus or minus +; two-hundredths of a degree. does not sound serious, except... +; +; if you run the example as is, when the temperature gets to our on/off threshhold +; of 100, chances are you will see the boiler toggle itself on and off several times +; before the temperature moves away from 100. +; +; building maintenance personel will report this odd behavior, probably hearing the +; vent open and shut and open again several times in quick succession. + +; the problem is traced to the cell rule which reacts too slavishly to the stream +; of temperature values. a work order is cut to replace the thermometer, and to reprogram +; the controller not to be so slavish. there are lots of ways to solve this; here if +; you enable sensitivity by running example 4 you can effectively place a synapse between the +; temperature cell of the thermometer and the status cell of the boiler which +; does not even trigger the status cell unless the received value differs by the +; specified amount from the last value which was actually relayed. + +; now the boiler simply cuts off as the temperature passes 100, and stays off even if +; the thermometer temperature goes to 99.98. the trace output shows that although the temperature +; of the thermometer is changing, only occasionally does the rule to decide the boiler +; status get kicked off. +; + +(defun boiler-3 (&key (sensitivity-enabled nil)) + + (cell-reset) + + (let ((b (to-be + (make-instance 'boiler2 + :status (c? (let ((temp (if sensitivity-enabled + (^temp (thermometer self) (fsensitivity 0.05)) + (^temp (thermometer self))))) + ;;(trc "status c? sees temp" temp) + (if (< temp 100) :on :off) + )) + :vent (c? (ecase (^status) (:on :open) (:off :closed))) + :thermometer (make-instance 'quiet-thermometer :temp (cv 20)) + )))) + ; + ; let's simulate a thermometer which, when the temperature is actually + ; any given value t will indicate randomly anything in the range + ; t plus/minus 0.02. no big deal unless the actual is exactly our + ; threshold point of 100... + ; + (dotimes (x 4) + ;;(trc "top> ----------- set base to" (+ 98 x)) + (dotimes (y 10) + (let ((newtemp (+ 98 x (random 0.04) -.02))) ;; force random variation around (+ 98 x) + ;;(trc "top> ----------- set temp to" newtemp) + (setf (temp (thermometer b)) newtemp)))))) + + +(defun boiler-4 () (boiler-3 :sensitivity-enabled t)) + +;; +;; de-comment 'trc statements above to see what is happening +;; +#+test +(boiler-3) + +#+test +(boiler-4) + +(defun boiler-5 () + + (cell-reset) + + (let ((b (to-be + (make-instance 'boiler2 + :status (cv :off) + :vent (c? (trc "caculating vent" (^status)) + (if (eq (^status) :on) + (if (> (^temp (thermometer self) (fDebug 3)) 100) + :open :closed) + :whatever-off)) + :thermometer (make-instance 'quiet-thermometer :temp (cv 20)) + )))) + + (dotimes (x 4) + (dotimes (n 4) + (incf (temp (thermometer b)))) + (setf (status b) (case (status b) (:on :off)(:off :on)))))) + +#+test + +(boiler-5) + +(defun fDebug (sensitivity &optional subtypename) + (mksynapse (priorrelayvalue) + :fire-p (lambda (syn newvalue) + (declare (ignorable syn)) + (eko ("fire-p decides" priorrelayvalue sensitivity) + (delta-greater-or-equal + (delta-abs (delta-diff newvalue priorrelayvalue subtypename) subtypename) + (delta-abs sensitivity subtypename) + subtypename))) + + :relay-value (lambda (syn newvalue) + (declare (ignorable syn)) + (eko ("fsensitivity relays") + (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time ))) Index: cells/cells-test/cells-test.asd diff -u cells/cells-test/cells-test.asd:1.1.1.1 cells/cells-test/cells-test.asd:1.2 --- cells/cells-test/cells-test.asd:1.1.1.1 Sat Nov 8 18:44:57 2003 +++ cells/cells-test/cells-test.asd Tue Dec 16 10:03:02 2003 @@ -1,26 +1,25 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - - -#+(or allegro lispworks cmu mcl cormanlisp sbcl scl) - -(asdf:defsystem :cells-test - :name "cells-test" - :author "Kenny Tilton <ktilton@nyc.rr.com>" - :version "05-Nov-2003" - :maintainer "Kenny Tilton <ktilton@nyc.rr.com>" - :licence "MIT Style" - :description "Cells Regression Test/Documentation" - :long-description "Informatively-commented regression tests for Cells" - :components ((:file "test") - (:file "hello-world") - (:file "internal-combustion") - (:file "boiler-examples") - (:file "person") - (:file "df-interference") - (:file "test-family") - (:file "test-kid-slotting") - (:file "lazy-propagation") - (:file "ring-net") - )) \ No newline at end of file +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + + +#+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl) + +(asdf:defsystem :cells-test + :name "cells-test" + :author "Kenny Tilton <ktilton@nyc.rr.com>" + :version "05-Nov-2003" + :maintainer "Kenny Tilton <ktilton@nyc.rr.com>" + :licence "MIT Style" + :description "Cells Regression Test/Documentation" + :long-description "Informatively-commented regression tests for Cells" + :components ((:file "test") + (:file "hello-world") + (:file "internal-combustion") + (:file "boiler-examples") + (:file "person") + (:file "df-interference") + (:file "test-family") + (:file "test-kid-slotting") + (:file "lazy-propagation") + )) Index: cells/cells-test/df-interference.lisp diff -u cells/cells-test/df-interference.lisp:1.1.1.1 cells/cells-test/df-interference.lisp:1.2 --- cells/cells-test/df-interference.lisp:1.1.1.1 Sat Nov 8 18:44:57 2003 +++ cells/cells-test/df-interference.lisp Tue Dec 16 10:03:02 2003 @@ -1,176 +1,176 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -(defvar *eex* 0) - -(defmodel xx3 () - ((aa :initform (cv 0) :initarg :aa :accessor aa) - (dd :initform (c? (min 0 (+ (^cc) (^bb)))) :initarg :dd :accessor dd) - (ddx :initform (c? (+ (^cc) (^bb))) :initarg :ddx :accessor ddx) - (cc :initform (c? (+ (^aa) (^bb))) :initarg :cc :reader cc) - (bb :initform (c? (* 2 (^aa))) :initarg :bb :accessor bb) - (ee :initform (c? (+ (^aa) (^dd))) :initarg :ee :reader ee) - (eex :initform (c? (trc "in rule of eex, *eex* incfed to ~d" *eex*) - (+ (^aa) (^ddx))) :initarg :eex :reader eex) - )) - -(def-c-echo aa ((self xx3)) - (trc nil "echo aa:" new-value)) - -(def-c-echo bb ((self xx3)) - (trc nil "echo bb:" new-value)) - -(def-c-echo cc ((self xx3)) - (trc nil "echo cc:" new-value)) - -(def-c-echo dd ((self xx3)) - (trc nil "echo dd:" new-value)) - -(def-c-echo ee ((self xx3)) - (trc nil "echo ee:" new-value)) - -(def-c-echo eex ((self xx3)) - (incf *eex*) - (trc "echo eex:" new-value *eex*)) - -;; -;; here we look at just one problem, what i call dataflow interference. consider -;; a dependency graph underlying: -;; -;; - a depends on b and c, and... -;; - b depends on c -;; -;; if c changes, depending on the accident of the order in which a and b happened to -;; be first evaluated, a might appear before b on c's list of dependents (users). then the -;; following happens: -;; -;; - c triggers a -;; - a calculates off the new value of c and an obsolete cached value for b -;; - a echos an invalid value and triggers any dependents, all of whom recalculate -;; using a's invalid value -;; - c triggers b -;; - b recalculates and then triggers a, which then recalculates correctly and echos and triggers -;; the rest of the df graph back into line -;; -;; the really bad news is that echos go outside the model: what if the invalid echo caused -;; a missile launch? sure, a subsequent correct calculation comes along shortly, but -;; irrevocable damage may have been done. -;; -;; of historical interest: this flaw was corrected only recently. while it seems like a -;; a serious flaw, it never caused a problem in practice. perhaps a year ago i do recall -;; applying a partial quick fix: in the above scenario, c flagged both a and b as "invalid" -;; before triggering a. that way, when a went to sample the un-refreshed b, b did a jit -;; recalculation and a came up with the correct value. so if the interference was just one -;; layer deep all was well. -;; -;; more historical amusement: that one-layer patch made it hard to concoct a set of interdependencies -;; to manifest intereference. that is why the example has more than just a few slots. the fix was also -;; dead simple, so i left it in for the first fix of -;; the deeper interference problems. but subsequently i found a problem arising from the -;; leftover original one-layer fix's interaction with the deeper fix, so i yanked the one-layer fix -;; and revised the deeper fix to cover everything. without the one-layer fix, this example -;; problem is overkill: it causes /double/ interference. but it has already proven it is a -;; tougher test, so i will stick with it on the chance that someday a change will be made which -;; a simpler test would not detect. -;; -;; the test run with (*df-interference-detection* t) succeeds and produces this output: -;;; -;;;0> echo aa: 2 -;;;0> echo bb: 4 -;;;0> echo cc: 6 -;;;0> echo eex: 12 -;;;0> echo ee: 2 -;;;ok: (and (eql (aa it) 2) (eql (bb it) 4) (eql (cc it) 6) -;;; (eql (dd it) 0) (eql (ddx it) 10) (eql (ee it) 2) -;;; (eql (eex it) 12)) -;;;ok: (eql *eex* 1) -;;; -;; change the first let to (*df-interference-detection* nil) and the test fails after producing this output: -;;; -;;;0> --------- 1 => (aa it) -------------------------- -;;;0> echo aa: 1 -;;;0> echo eex: 1 -;;;0> echo ee: 1 -;;;0> echo bb: 2 -;;;0> echo eex: 3 -;;;0> echo cc: 3 -;;;0> echo eex: 6 -;;;ok: (and (eql (aa it) 1) (eql (bb it) 2) (eql (cc it) 3)) -;;;ok: (and (eql (dd it) 0) (eql (ddx it) 5)) -;;;ok: (and (eql (ee it) 1) (eql (eex it) 6)) -;;; error: (eql *eex* 1)...failed -;; -;; because in fact the rule for eex ran not two but three times. notice that, as advertised, before -;; propagation completes all cells converge on the correct value--but in some cases they assume -;; illogical values and propagate them (most crucially via irretrievable echos) before getting to -;; the correct value. -;; - -#+fail -(df-test nil) - -#+succeed -(df-test t) - -(defun df-test-t () (df-test t)) - -(defun df-test (dfid) - (dotimes (x 1) - (let* ((*df-interference-detection* dfid) - (*eex* 0) - (it (md-make 'xx3))) - (trc "eex =" *eex*) - (cv-assert (eql *eex* 1)) - ;;(inspect it);;(cellbrk) - (cv-assert (and (eql (aa it) 0)(eql (bb it) 0)(eql (cc it) 0))) - (cv-assert (and (eql (dd it) 0)(eql (ddx it) 0)(eql (ee it) 0)(eql (eex it) 0))) - - ;;;- interference handling - ;;; - (let ((*eex* 0)) - (trc "--------- 1 => (aa it) --------------------------") - (setf (aa it) 1) - (cv-assert (and (eql (aa it) 1)(eql (bb it) 2)(eql (cc it) 3))) - (cv-assert (and (eql (dd it) 0)(eql (ddx it) 5))) - (cv-assert (and (eql (ee it) 1)(eql (eex it) 6))) - (cv-assert (eql *eex* 1))) - - (let ((*eex* 0)) - (trc "--------- 2 => (aa it) --------------------------") - (setf (aa it) 2) - (cv-assert (and (eql (aa it) 2)(eql (bb it) 4)(eql (cc it) 6) - (eql (dd it) 0)(eql (ddx it) 10)(eql (ee it) 2)(eql (eex it) 12))) - (cv-assert (eql *eex* 1))) - - (dolist (c (cells it)) - (trc "cell is" c) - (when (typep (cdr c) 'c-user-notifying) - (print `(notifier ,c)) - (dolist (u (un-users (cdr c))) - (print `(___ ,u))))) - ))) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +(defvar *eex* 0) + +(defmodel xx3 () + ((aa :initform (cv 0) :initarg :aa :accessor aa) + (dd :initform (c? (min 0 (+ (^cc) (^bb)))) :initarg :dd :accessor dd) + (ddx :initform (c? (+ (^cc) (^bb))) :initarg :ddx :accessor ddx) + (cc :initform (c? (+ (^aa) (^bb))) :initarg :cc :reader cc) + (bb :initform (c? (* 2 (^aa))) :initarg :bb :accessor bb) + (ee :initform (c? (+ (^aa) (^dd))) :initarg :ee :reader ee) + (eex :initform (c? (trc "in rule of eex, *eex* incfed to ~d" *eex*) + (+ (^aa) (^ddx))) :initarg :eex :reader eex) + )) + +(def-c-echo aa ((self xx3)) + (trc nil "echo aa:" new-value)) + +(def-c-echo bb ((self xx3)) + (trc nil "echo bb:" new-value)) + +(def-c-echo cc ((self xx3)) + (trc nil "echo cc:" new-value)) + +(def-c-echo dd ((self xx3)) + (trc nil "echo dd:" new-value)) + +(def-c-echo ee ((self xx3)) + (trc nil "echo ee:" new-value)) + +(def-c-echo eex ((self xx3)) + (incf *eex*) + (trc "echo eex:" new-value *eex*)) + +;; +;; here we look at just one problem, what i call dataflow interference. consider +;; a dependency graph underlying: +;; +;; - a depends on b and c, and... +;; - b depends on c +;; +;; if c changes, depending on the accident of the order in which a and b happened to +;; be first evaluated, a might appear before b on c's list of dependents (users). then the +;; following happens: +;; +;; - c triggers a +;; - a calculates off the new value of c and an obsolete cached value for b +;; - a echos an invalid value and triggers any dependents, all of whom recalculate +;; using a's invalid value +;; - c triggers b +;; - b recalculates and then triggers a, which then recalculates correctly and echos and triggers +;; the rest of the df graph back into line +;; +;; the really bad news is that echos go outside the model: what if the invalid echo caused +;; a missile launch? sure, a subsequent correct calculation comes along shortly, but +;; irrevocable damage may have been done. +;; +;; of historical interest: this flaw was corrected only recently. while it seems like a +;; a serious flaw, it never caused a problem in practice. perhaps a year ago i do recall +;; applying a partial quick fix: in the above scenario, c flagged both a and b as "invalid" +;; before triggering a. that way, when a went to sample the un-refreshed b, b did a jit +;; recalculation and a came up with the correct value. so if the interference was just one +;; layer deep all was well. +;; +;; more historical amusement: that one-layer patch made it hard to concoct a set of interdependencies +;; to manifest intereference. that is why the example has more than just a few slots. the fix was also +;; dead simple, so i left it in for the first fix of +;; the deeper interference problems. but subsequently i found a problem arising from the +;; leftover original one-layer fix's interaction with the deeper fix, so i yanked the one-layer fix +;; and revised the deeper fix to cover everything. without the one-layer fix, this example +;; problem is overkill: it causes /double/ interference. but it has already proven it is a +;; tougher test, so i will stick with it on the chance that someday a change will be made which +;; a simpler test would not detect. +;; +;; the test run with (*df-interference-detection* t) succeeds and produces this output: +;;; +;;;0> echo aa: 2 +;;;0> echo bb: 4 +;;;0> echo cc: 6 +;;;0> echo eex: 12 +;;;0> echo ee: 2 +;;;ok: (and (eql (aa it) 2) (eql (bb it) 4) (eql (cc it) 6) +;;; (eql (dd it) 0) (eql (ddx it) 10) (eql (ee it) 2) +;;; (eql (eex it) 12)) +;;;ok: (eql *eex* 1) +;;; +;; change the first let to (*df-interference-detection* nil) and the test fails after producing this output: +;;; +;;;0> --------- 1 => (aa it) -------------------------- +;;;0> echo aa: 1 +;;;0> echo eex: 1 +;;;0> echo ee: 1 +;;;0> echo bb: 2 +;;;0> echo eex: 3 +;;;0> echo cc: 3 +;;;0> echo eex: 6 +;;;ok: (and (eql (aa it) 1) (eql (bb it) 2) (eql (cc it) 3)) +;;;ok: (and (eql (dd it) 0) (eql (ddx it) 5)) +;;;ok: (and (eql (ee it) 1) (eql (eex it) 6)) +;;; error: (eql *eex* 1)...failed +;; +;; because in fact the rule for eex ran not two but three times. notice that, as advertised, before +;; propagation completes all cells converge on the correct value--but in some cases they assume +;; illogical values and propagate them (most crucially via irretrievable echos) before getting to +;; the correct value. +;; + +#+fail +(df-test nil) + +#+succeed +(df-test t) + +(defun df-test-t () (df-test t)) + +(defun df-test (dfid) + (dotimes (x 1) + (let* ((*df-interference-detection* dfid) + (*eex* 0) + (it (md-make 'xx3))) + (trc "eex =" *eex*) + (cv-assert (eql *eex* 1)) + ;;(inspect it);;(cellbrk) + (cv-assert (and (eql (aa it) 0)(eql (bb it) 0)(eql (cc it) 0))) + (cv-assert (and (eql (dd it) 0)(eql (ddx it) 0)(eql (ee it) 0)(eql (eex it) 0))) + + ;;;- interference handling + ;;; + (let ((*eex* 0)) + (trc "--------- 1 => (aa it) --------------------------") + (setf (aa it) 1) + (cv-assert (and (eql (aa it) 1)(eql (bb it) 2)(eql (cc it) 3))) + (cv-assert (and (eql (dd it) 0)(eql (ddx it) 5))) + (cv-assert (and (eql (ee it) 1)(eql (eex it) 6))) + (cv-assert (eql *eex* 1))) + + (let ((*eex* 0)) + (trc "--------- 2 => (aa it) --------------------------") + (setf (aa it) 2) + (cv-assert (and (eql (aa it) 2)(eql (bb it) 4)(eql (cc it) 6) + (eql (dd it) 0)(eql (ddx it) 10)(eql (ee it) 2)(eql (eex it) 12))) + (cv-assert (eql *eex* 1))) + + (dolist (c (cells it)) + (trc "cell is" c) + (when (typep (cdr c) 'cell) + (print `(notifier ,c)) + (dolist (u (c-users (cdr c))) + (print `(___ ,u))))) + ))) + + Index: cells/cells-test/hello-world-q.lisp diff -u cells/cells-test/hello-world-q.lisp:1.1.1.1 cells/cells-test/hello-world-q.lisp:1.2 --- cells/cells-test/hello-world-q.lisp:1.1.1.1 Sat Nov 8 18:44:57 2003 +++ cells/cells-test/hello-world-q.lisp Tue Dec 16 10:03:02 2003 @@ -1,82 +1,82 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -;;; -;;;(defstrudel computer -;;; (happen :cell :ephemeral :initform (cv nil)) -;;; (location :cell t -;;; :initform (c? (case (^happen) -;;; (:leave :away) -;;; (:arrive :at-home) -;;; (t (c-value c)))) -;;; :accessor location) -;;; (response :cell :ephemeral :initform nil :initarg :response :accessor response))) - -(def-c-echo response((self computer) newResponse oldResponse) - (when newResponse - (format t "~&Computer: ~a" newResponse))) - -(def-c-echo happen((self computer)) - (when new-value - (format t "~&Happen: ~a" new-Value))) - -(defun hello-world-q () - (let ((dell (to-be - (make-instance 'computer - :response (c? (bWhen (h (happen self)) - (if (eql (^location) :at-home) - (case h - (:knock-knock "Who's there?") - (:world "Hello, world.")) - "<silence>"))))))) - (dotimes (n 2) - (setf (happen dell) :knock-knock)) - (setf (happen dell) :arrive) - (setf (happen dell) :knock-knock) - (setf (happen dell) :world) - (values))) - -#+test -(hello-world) - -#+test -(traceo sm-echo) - - -#| Output - -Happen: KNOCK-KNOCK -Computer: <silence> -Happen: KNOCK-KNOCK -Computer: <silence> -Happen: ARRIVE -Happen: KNOCK-KNOCK -Computer: Who's there? -Happen: WORLD -Computer: Hello, world. - -|# - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +;;; +;;;(defstrudel computer +;;; (happen :cell :ephemeral :initform (cv nil)) +;;; (location :cell t +;;; :initform (c? (case (^happen) +;;; (:leave :away) +;;; (:arrive :at-home) +;;; (t (c-value c)))) +;;; :accessor location) +;;; (response :cell :ephemeral :initform nil :initarg :response :accessor response))) + +(def-c-echo response((self computer) newResponse oldResponse) + (when newResponse + (format t "~&Computer: ~a" newResponse))) + +(def-c-echo happen((self computer)) + (when new-value + (format t "~&Happen: ~a" new-Value))) + +(defun hello-world-q () + (let ((dell (to-be + (make-instance 'computer + :response (c? (bWhen (h (happen self)) + (if (eql (^location) :at-home) + (case h + (:knock-knock "Who's there?") + (:world "Hello, world.")) + "<silence>"))))))) + (dotimes (n 2) + (setf (happen dell) :knock-knock)) + (setf (happen dell) :arrive) + (setf (happen dell) :knock-knock) + (setf (happen dell) :world) + (values))) + +#+test +(hello-world) + +#+test +(traceo sm-echo) + + +#| Output + +Happen: KNOCK-KNOCK +Computer: <silence> +Happen: KNOCK-KNOCK +Computer: <silence> +Happen: ARRIVE +Happen: KNOCK-KNOCK +Computer: Who's there? +Happen: WORLD +Computer: Hello, world. + +|# + Index: cells/cells-test/hello-world.lisp diff -u cells/cells-test/hello-world.lisp:1.1.1.1 cells/cells-test/hello-world.lisp:1.2 --- cells/cells-test/hello-world.lisp:1.1.1.1 Sat Nov 8 18:44:57 2003 +++ cells/cells-test/hello-world.lisp Tue Dec 16 10:03:02 2003 @@ -1,82 +1,82 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -(defmodel computer () - ((happen :cell :ephemeral :initform (cv nil) :accessor happen) - (location :cell t - :initform (c? (case (^happen) - (:leave :away) - (:arrive :at-home) - (t .cache))) ;; ie, unchanged - :accessor location) - (response :cell :ephemeral :initform nil :initarg :response :accessor response))) - -(def-c-echo response(self newResponse oldResponse) - (when newResponse - (format t "~&Computer: ~a" newResponse))) - -(def-c-echo happen() - (when new-value - (format t "~&Happen: ~a" new-Value))) - -(defun hello-world () - (let ((dell (to-be - (make-instance 'computer - :response (c? (bWhen (h (happen self)) - (if (eql (^location) :at-home) - (case h - (:knock-knock "Who's there?") - (:world "Hello, world.")) - "<silence>"))))))) - (dotimes (n 2) - (setf (happen dell) :knock-knock)) - - (setf (happen dell) :arrive) - (setf (happen dell) :knock-knock) - (setf (happen dell) :world) - (values))) - -#+test -(hello-world) - -#+test -(trace sm-echo) - - -#| Output - -Happen: KNOCK-KNOCK -Computer: <silence> -Happen: KNOCK-KNOCK -Computer: <silence> -Happen: ARRIVE -Happen: KNOCK-KNOCK -Computer: Who's there? -Happen: WORLD -Computer: Hello, world. - -|# - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +(defmodel computer () + ((happen :cell :ephemeral :initform (cv nil) :accessor happen) + (location :cell t + :initform (c? (case (^happen) + (:leave :away) + (:arrive :at-home) + (t .cache))) ;; ie, unchanged + :accessor location) + (response :cell :ephemeral :initform nil :initarg :response :accessor response))) + +(def-c-echo response(self newResponse oldResponse) + (when newResponse + (format t "~&Computer: ~a" newResponse))) + +(def-c-echo happen() + (when new-value + (format t "~&Happen: ~a" new-Value))) + +(defun hello-world () + (let ((dell (to-be + (make-instance 'computer + :response (c? (bWhen (h (happen self)) + (if (eql (^location) :at-home) + (case h + (:knock-knock "Who's there?") + (:world "Hello, world.")) + "<silence>"))))))) + (dotimes (n 2) + (setf (happen dell) :knock-knock)) + + (setf (happen dell) :arrive) + (setf (happen dell) :knock-knock) + (setf (happen dell) :world) + (values))) + +#+test +(hello-world) + +#+test +(trace sm-echo) + + +#| Output + +Happen: KNOCK-KNOCK +Computer: <silence> +Happen: KNOCK-KNOCK +Computer: <silence> +Happen: ARRIVE +Happen: KNOCK-KNOCK +Computer: Who's there? +Happen: WORLD +Computer: Hello, world. + +|# + Index: cells/cells-test/internal-combustion.lisp diff -u cells/cells-test/internal-combustion.lisp:1.1.1.1 cells/cells-test/internal-combustion.lisp:1.2 --- cells/cells-test/internal-combustion.lisp:1.1.1.1 Sat Nov 8 18:45:03 2003 +++ cells/cells-test/internal-combustion.lisp Tue Dec 16 10:03:02 2003 @@ -1,353 +1,353 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - - -(in-package :cells) - -(defmodel engine () - ((fuel :cell nil :initarg :fuel :initform nil :accessor fuel) - (cylinders :initarg :cylinders :initform (cv 4) :accessor cylinders) - (valves-per-cylinder :initarg :valves-per-cylinder :initform 2 :accessor valves-per-cylinder) - (valves :initarg :valves - :accessor valves - :initform (c? (* (valves-per-cylinder self) - (cylinders self)))) - (mod3 :initarg :mod3 :initform nil :accessor mod3) - (mod3ek :initarg :mod3ek :initform nil :accessor mod3ek) - )) - -(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3))) - (lambda (new-value old-value) - (flet ((test (it) (zerop (mod it 3)))) - (eql (test new-value) (test old-value))))) - -(def-c-echo mod3ek () (trc "mod3ek echo" self)) - -(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3ek))) - (lambda (new-value old-value) - (flet ((test (it) (zerop (mod it 3)))) - (eql (test new-value) (test old-value))))) - -(def-c-echo cylinders () - ;;(when *dbg* (break)) - (trc "cylinders echo" self old-value new-value)) - -(defvar *propagations* nil) - -(defmodel engine-w-initform () - ((cylinders :initform 33 :reader cylinders))) - -(defclass non-model ()()) -(defmodel faux-model (non-model)()) -(defmodel true-model ()()) -(defmodel indirect-model (true-model)()) - - -(defun cv-test-engine () - ;; - ;; before we get to engines, a quick check that we are correctly enforcing the - ;; requirment that classes defined by defmodel inherit from model-object - ;; - (cv-assert (make-instance 'non-model)) - (cv-assert (make-instance 'true-model)) - (cv-assert (make-instance 'indirect-model)) - (cv-assert (handler-case - (progn - (make-instance 'faux-model) - nil) ;; bad to reach here - (t (error) (trc "error is" error) - error))) - ;; -------------------------------------------------------------------------- - ;; -- make sure non-cell slots still work -- - ;; - ;; in mop-based implementations we specialize the slot-value-using-class accessors - ;; to make cells work. rather than slow down all slots where a class might have only - ;; a few cell-mediated slots, we allow a class to pick and choose which slots are cell-mediated. - ;; - ;; here we make sure all is well in re such mixing of cell and non-cell, by exercising first - ;; the reader and then the writer. - ;; - ;; the read is not much of a test since it should work even if through some error the slot - ;; gets treated as if it were cell. but the setf will fail since cell internals reject changes - ;; to cellular slots unless they are c-variable. (why this is so has to do with efficiency, - ;; and will be covered when we get to cells being optimized away.) - ;; - (cv-assert - (eql :gas (fuel (make-instance 'engine :fuel :gas)))) - (cv-assert - (eql :diesel (setf (fuel (make-instance 'engine :fuel :gas)) :diesel))) - ;; - ;; - #+noterror ;; Cloucell needed to hold a Cell in a non cellular slot. duh. - (cv-assert - (handler-case - (progn - (make-instance 'engine :fuel (cv :gas)) - nil) ;; bad to reach here - (t (error) (trc "error is" error) - error))) - ;; - ;; --------------------------------------------------------------------------- - ;; (1) reading cellular slots (2) instantiated as constant, variable or ruled - ;; - ;; aside from the simple mechanics of successfuly accessing cellular slots, this - ;; code exercises the implementation task of binding a cell to a slot such that - ;; a standard read op finds the wrapped value, including a functional value (the c?) - ;; - ;; aside; the cell pattern includes a transparency requirement so cells will be - ;; programmer-friendly and in turn yield greater productivity gains. below we /initialize/ - ;; the cylinders cell to (cv 4) and then (c? (+ 2 2)), but when you read those slots the - ;; cell implementation structures are not returned, the value 4 is returned. - ;; - ;; aside: the value 4 itself occupies the actual slot. this helped when we used Cells - ;; with a persistent CLOS tool which maintained inverse indices off slots if asked. - ;; - (cv-assert - (progn - (eql 33 (cylinders (make-instance 'engine-w-initform))))) - - (cv-assert - (eql 4 (cylinders (make-instance 'engine :cylinders 4)))) - - (cv-assert - (eql 4 (cylinders (make-instance 'engine :cylinders (cv 4))))) - - (cv-assert - (eql 4 (cylinders (make-instance 'engine :cylinders (c? (+ 2 2)))))) - - (cv-assert - (eql 16 (valves (make-instance 'engine - :cylinders 8 - :valves (c? (* (cylinders self) (valves-per-cylinder self))) - :valves-per-cylinder (c? (floor (cylinders self) 4)))))) ;; admittedly weird semantics - - ;; ---------------------------------------------------------- - ;; initialization echo - ;; - ;; cells are viewed in part as supportive of modelling. the echo functions provide - ;; a callback allowing state changes to be manifested outside the dataflow, perhaps - ;; by updating the screen or by operating some real-world device through its api. - ;; that way a valve model instance could drive a real-world valve. - ;; - ;; it seems best then that the state of model and modelled should as much as possible - ;; be kept consistent with each other, and this is why we "echo" cells as soon as they - ;; come to life as well as when they change. - ;; - ;; one oddball exception is that cellular slots for which no echo is defined do not get echoed - ;; initially. why not? this gets a little complicated. - ;; - ;; first of all, echoing requires evaluation of a ruled cell. by checking first - ;; if a cell even is echoed, and punting on those that are not echoed we can defer - ;; the evaluation of any ruled cell bound to an unechoed slot until such a slot is - ;; read by other code. i call this oddball because it is a rare slot that is - ;; neither echoed nor used directly or indirectly by an echoed slot. but i have had fairly - ;; expensive rules on debugging slots which i did not want kicked off until i had - ;; to check their values in the inspector. ie, oddball. - ;; - - (macrolet ((echo-init (newv cylini) - `(progn - (echo-clear 'cylinders) - (echo-clear 'valves) - (to-be (make-instance 'engine :cylinders ,cylini :valves ,cylini)) - (cv-assert (echoed 'cylinders)) - (cv-assert (eql ,newv (echo-new 'cylinders))) - ;(cv-assert (not (echo-old-boundp 'cylinders))) - ;(cv-assert (not (echoed 'valves))) - ))) - (echo-init 6 6) - (echo-init 10 (cv 10)) - (echo-init 5 (c? (+ 2 3))) - ) - - ;; ---------------------------------------------------------------- - ;; write cell slot - ;; - ;; for now only variable cells (slots mediated by c-variable structures) can be - ;; modified via setf. an exception (drifter cells) may get resurrected soon. but as mentioned - ;; above, an optimization discussed below requires rejection of changes to cellular slots - ;; instantiated without any cell, and for purity the cell engine rejects setf's of slots mediated - ;; by ruled cells. the idea being that we want the semantics of a ruled - ;; cell to be fully defined by its rule, not arbitrary setf's from anywhere in the code. - ;; - ;; aside: variable cells can be setf'ed from anywhere, a seeming loss of semantic - ;; control by the above purist view. but variables exist mainly to allow inputs to a dataflow model - ;; from outside the model, usually in an event-loop processing os events, so spaghetti dataflow - ;; should not follow from this. - ;; - ;; that said, in weak moments i resort to having the echo of one cell setf some other variable cell, - ;; but i always think of these as regrettable gotos and maybe someday i will try to polish them out - ;; of existence test. - ;; - ;;------------------------- - ;; - ;; first verify acceptable setf... - ;; - (cv-assert - (let ((e (make-instance 'engine :cylinders (cv 4)))) - (setf (cylinders e) 6) - (eql 6 (cylinders e)))) - ;; - ;; ...and two not acceptable... - ;; - (cv-assert - (handler-case - (let ((e (make-instance 'engine :cylinders 4))) - (setf (cylinders e) 6) - nil) ;; bad to reach here - (t (error) - (trc "error correctly is" error) - (cell-reset) - t))) ;; something non-nil to satisfy assert - - (cv-assert - (handler-case - (let ((e (make-instance 'engine :cylinders (c? (+ 2 2))))) - (setf (cylinders e) 6) - nil) ;; bad to reach here - (t (error) (trc "error correctly is" error) t))) - - (cv-test-propagation-on-slot-write) - (cv-test-no-prop-unchanged) - - ;; - ;; here we exercise a feature which allows the client programmer to override the default - ;; test of eql when comparing old and new values. above we defined nonsense slot mod3 (unechoed) - ;; and mod3ek (echoed) with a custom "unchanged" test: - ;; - - ;; - #+not (let ((e (to-be - (make-instance 'engine - :mod3 (cv 3) - :mod3ek (cv 3) - :cylinders (c? (* 4 (mod3 self))))))) - - (cv-assert (eql 12 (cylinders e))) - (echo-clear 'mod3) - (echo-clear 'mod3ek) - (trc "mod3 echoes cleared, setting mod3s now") - (setf (mod3 e) 6 - (mod3ek e) 6) - ;; - ;; both 3 and 6 are multiples of 3, so the engine guided by the above - ;; override treats the cell as unchanged; no echo, no recalculation - ;; of the cylinders cell - ;; - (cv-assert (not (echoed 'mod3ek))) ;; no real need to check mod3 unechoed - (cv-assert (eql 12 (cylinders e))) - ;; - ;; now test in the other direction to make sure change according to the - ;; override still works. - ;; - (setf (mod3 e) 5 - (mod3ek e) 5) - (cv-assert (echoed 'mod3ek)) - (cv-assert (eql 20 (cylinders e))) - ) - ) - -(defun cv-test-propagation-on-slot-write () - ;; --------------------------------------------------------------- - ;; propagation (echo and trigger dependents) on slot write - ;; - ;; propagation involves both echoing my change and notifying cells dependent on me - ;; that i have changed and that they need to recalculate themselves. - ;; - ;; the standard echo callback is passed the slot-name, instance, new value, - ;; old value and a flag 'old-value-boundp indicating, well, whether the new value - ;; was the first ever for this instance. - ;; - ;; the first set of tests make sure actual change is handled correctly - ;; - (echo-clear 'cylinders) - (echo-clear 'valves) - (echo-clear 'valves-per-cylinder) - (when *stop* (break "stopped!")) - (let ((e (to-be (make-instance 'engine - :cylinders 4 - :valves-per-cylinder (cv 2) - :valves (c? (* (valves-per-cylinder self) (cylinders self))))))) - ;; - ;; these first tests check that cells get echoed appropriately at make-instance time (the change - ;; is from not existing to existing) - ;; - (cv-assert (and (eql 4 (echo-new 'cylinders)) - (not (echo-old-boundp 'cylinders)))) - - (cv-assert (valves-per-cylinder e)) ;; but no echo is defined for this slot - - (cv-assert (valves e)) - ;; - ;; now we test true change from one value to another - ;; - (setf (valves-per-cylinder e) 4) - ;; - (cv-assert (eql 16 (valves e))) - )) - -(defun cv-test-no-prop-unchanged () - ;; - ;; next we check the engines ability to handle dataflow efficiently by /not/ reacting - ;; to coded setfs which in fact produce no change. - ;; - ;; the first takes a variable cylinders cell initiated to 4 and again setf's it to 4. we - ;; confirm that the cell does not echo and that a cell dependent on it does not get - ;; triggered to recalculate. ie, the dependency's value has not changed so the dependent - ;; cell's cached value remains valid. - ;; - (cell-reset) - (echo-clear 'cylinders) - (let* ((*dbg* t) - valves-fired - (e (To-be (make-instance 'engine - :cylinders (cv 4) - :valves-per-cylinder 2 - :valves (c? (setf valves-fired t) - (trc "!!!!!! valves") - (* (valves-per-cylinder self) (cylinders self))))))) - (trc "!!!!!!!!hunbh?") - (cv-assert (echoed 'cylinders)) - (echo-clear 'cylinders) - (cv-assert (not valves-fired)) ;; no echo is defined so evaluation is deferred - (trc "sampling valves....") - (let () - (cv-assert (valves e)) ;; wake up unechoed cell - ) - (cv-assert valves-fired) - (setf valves-fired nil) - - (cv-assert (and 1 (not (echoed 'cylinders)))) - (setf (cylinders e) 4) ;; same value - (trc "same cyl") - (cv-assert (and 2 (not (echoed 'cylinders)))) - (cv-assert (not valves-fired)) - - (setf (cylinders e) 6) - (cv-assert (echoed 'cylinders)) - (cv-assert valves-fired))) - -#+test - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + + +(in-package :cells) + +(defmodel engine () + ((fuel :cell nil :initarg :fuel :initform nil :accessor fuel) + (cylinders :initarg :cylinders :initform (cv 4) :accessor cylinders) + (valves-per-cylinder :initarg :valves-per-cylinder :initform 2 :accessor valves-per-cylinder) + (valves :initarg :valves + :accessor valves + :initform (c? (* (valves-per-cylinder self) + (cylinders self)))) + (mod3 :initarg :mod3 :initform nil :accessor mod3) + (mod3ek :initarg :mod3ek :initform nil :accessor mod3ek) + )) + +(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3))) + (lambda (new-value old-value) + (flet ((test (it) (zerop (mod it 3)))) + (eql (test new-value) (test old-value))))) + +(def-c-echo mod3ek () (trc "mod3ek echo" self)) + +(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3ek))) + (lambda (new-value old-value) + (flet ((test (it) (zerop (mod it 3)))) + (eql (test new-value) (test old-value))))) + +(def-c-echo cylinders () + ;;(when *dbg* (break)) + (trc "cylinders echo" self old-value new-value)) + +(defvar *propagations* nil) + +(defmodel engine-w-initform () + ((cylinders :initform 33 :reader cylinders))) + +(defclass non-model ()()) +(defmodel faux-model (non-model)()) +(defmodel true-model ()()) +(defmodel indirect-model (true-model)()) + + +(defun cv-test-engine () + ;; + ;; before we get to engines, a quick check that we are correctly enforcing the + ;; requirment that classes defined by defmodel inherit from model-object + ;; + (cv-assert (make-instance 'non-model)) + (cv-assert (make-instance 'true-model)) + (cv-assert (make-instance 'indirect-model)) + (cv-assert (handler-case + (progn + (make-instance 'faux-model) + nil) ;; bad to reach here + (t (error) (trc "error is" error) + error))) + ;; -------------------------------------------------------------------------- + ;; -- make sure non-cell slots still work -- + ;; + ;; in mop-based implementations we specialize the slot-value-using-class accessors + ;; to make cells work. rather than slow down all slots where a class might have only + ;; a few cell-mediated slots, we allow a class to pick and choose which slots are cell-mediated. + ;; + ;; here we make sure all is well in re such mixing of cell and non-cell, by exercising first + ;; the reader and then the writer. + ;; + ;; the read is not much of a test since it should work even if through some error the slot + ;; gets treated as if it were cell. but the setf will fail since cell internals reject changes + ;; to cellular slots unless they are c-variable. (why this is so has to do with efficiency, + ;; and will be covered when we get to cells being optimized away.) + ;; + (cv-assert + (eql :gas (fuel (make-instance 'engine :fuel :gas)))) + (cv-assert + (eql :diesel (setf (fuel (make-instance 'engine :fuel :gas)) :diesel))) + ;; + ;; + #+noterror ;; Cloucell needed to hold a Cell in a non cellular slot. duh. + (cv-assert + (handler-case + (progn + (make-instance 'engine :fuel (cv :gas)) + nil) ;; bad to reach here + (t (error) (trc "error is" error) + error))) + ;; + ;; --------------------------------------------------------------------------- + ;; (1) reading cellular slots (2) instantiated as constant, variable or ruled + ;; + ;; aside from the simple mechanics of successfuly accessing cellular slots, this + ;; code exercises the implementation task of binding a cell to a slot such that + ;; a standard read op finds the wrapped value, including a functional value (the c?) + ;; + ;; aside; the cell pattern includes a transparency requirement so cells will be + ;; programmer-friendly and in turn yield greater productivity gains. below we /initialize/ + ;; the cylinders cell to (cv 4) and then (c? (+ 2 2)), but when you read those slots the + ;; cell implementation structures are not returned, the value 4 is returned. + ;; + ;; aside: the value 4 itself occupies the actual slot. this helped when we used Cells + ;; with a persistent CLOS tool which maintained inverse indices off slots if asked. + ;; + (cv-assert + (progn + (eql 33 (cylinders (make-instance 'engine-w-initform))))) + + (cv-assert + (eql 4 (cylinders (make-instance 'engine :cylinders 4)))) + + (cv-assert + (eql 4 (cylinders (make-instance 'engine :cylinders (cv 4))))) + + (cv-assert + (eql 4 (cylinders (make-instance 'engine :cylinders (c? (+ 2 2)))))) + + (cv-assert + (eql 16 (valves (make-instance 'engine + :cylinders 8 + :valves (c? (* (cylinders self) (valves-per-cylinder self))) + :valves-per-cylinder (c? (floor (cylinders self) 4)))))) ;; admittedly weird semantics + + ;; ---------------------------------------------------------- + ;; initialization echo + ;; + ;; cells are viewed in part as supportive of modelling. the echo functions provide + ;; a callback allowing state changes to be manifested outside the dataflow, perhaps + ;; by updating the screen or by operating some real-world device through its api. + ;; that way a valve model instance could drive a real-world valve. + ;; + ;; it seems best then that the state of model and modelled should as much as possible + ;; be kept consistent with each other, and this is why we "echo" cells as soon as they + ;; come to life as well as when they change. + ;; + ;; one oddball exception is that cellular slots for which no echo is defined do not get echoed + ;; initially. why not? this gets a little complicated. + ;; + ;; first of all, echoing requires evaluation of a ruled cell. by checking first + ;; if a cell even is echoed, and punting on those that are not echoed we can defer + ;; the evaluation of any ruled cell bound to an unechoed slot until such a slot is + ;; read by other code. i call this oddball because it is a rare slot that is + ;; neither echoed nor used directly or indirectly by an echoed slot. but i have had fairly + ;; expensive rules on debugging slots which i did not want kicked off until i had + ;; to check their values in the inspector. ie, oddball. + ;; + + (macrolet ((echo-init (newv cylini) + `(progn + (echo-clear 'cylinders) + (echo-clear 'valves) + (to-be (make-instance 'engine :cylinders ,cylini :valves ,cylini)) + (cv-assert (echoed 'cylinders)) + (cv-assert (eql ,newv (echo-new 'cylinders))) + ;(cv-assert (not (echo-old-boundp 'cylinders))) + ;(cv-assert (not (echoed 'valves))) + ))) + (echo-init 6 6) + (echo-init 10 (cv 10)) + (echo-init 5 (c? (+ 2 3))) + ) + + ;; ---------------------------------------------------------------- + ;; write cell slot + ;; + ;; for now only variable cells (slots mediated by c-variable structures) can be + ;; modified via setf. an exception (drifter cells) may get resurrected soon. but as mentioned + ;; above, an optimization discussed below requires rejection of changes to cellular slots + ;; instantiated without any cell, and for purity the cell engine rejects setf's of slots mediated + ;; by ruled cells. the idea being that we want the semantics of a ruled + ;; cell to be fully defined by its rule, not arbitrary setf's from anywhere in the code. + ;; + ;; aside: variable cells can be setf'ed from anywhere, a seeming loss of semantic + ;; control by the above purist view. but variables exist mainly to allow inputs to a dataflow model + ;; from outside the model, usually in an event-loop processing os events, so spaghetti dataflow + ;; should not follow from this. + ;; + ;; that said, in weak moments i resort to having the echo of one cell setf some other variable cell, + ;; but i always think of these as regrettable gotos and maybe someday i will try to polish them out + ;; of existence test. + ;; + ;;------------------------- + ;; + ;; first verify acceptable setf... + ;; + (cv-assert + (let ((e (make-instance 'engine :cylinders (cv 4)))) + (setf (cylinders e) 6) + (eql 6 (cylinders e)))) + ;; + ;; ...and two not acceptable... + ;; + (cv-assert + (handler-case + (let ((e (make-instance 'engine :cylinders 4))) + (setf (cylinders e) 6) + nil) ;; bad to reach here + (t (error) + (trc "error correctly is" error) + (cell-reset) + t))) ;; something non-nil to satisfy assert + + (cv-assert + (handler-case + (let ((e (make-instance 'engine :cylinders (c? (+ 2 2))))) + (setf (cylinders e) 6) + nil) ;; bad to reach here + (t (error) (trc "error correctly is" error) t))) + + (cv-test-propagation-on-slot-write) + (cv-test-no-prop-unchanged) + + ;; + ;; here we exercise a feature which allows the client programmer to override the default + ;; test of eql when comparing old and new values. above we defined nonsense slot mod3 (unechoed) + ;; and mod3ek (echoed) with a custom "unchanged" test: + ;; + + ;; + #+not (let ((e (to-be + (make-instance 'engine + :mod3 (cv 3) + :mod3ek (cv 3) + :cylinders (c? (* 4 (mod3 self))))))) + + (cv-assert (eql 12 (cylinders e))) + (echo-clear 'mod3) + (echo-clear 'mod3ek) + (trc "mod3 echoes cleared, setting mod3s now") + (setf (mod3 e) 6 + (mod3ek e) 6) + ;; + ;; both 3 and 6 are multiples of 3, so the engine guided by the above + ;; override treats the cell as unchanged; no echo, no recalculation + ;; of the cylinders cell + ;; + (cv-assert (not (echoed 'mod3ek))) ;; no real need to check mod3 unechoed + (cv-assert (eql 12 (cylinders e))) + ;; + ;; now test in the other direction to make sure change according to the + ;; override still works. + ;; + (setf (mod3 e) 5 + (mod3ek e) 5) + (cv-assert (echoed 'mod3ek)) + (cv-assert (eql 20 (cylinders e))) + ) + ) + +(defun cv-test-propagation-on-slot-write () + ;; --------------------------------------------------------------- + ;; propagation (echo and trigger dependents) on slot write + ;; + ;; propagation involves both echoing my change and notifying cells dependent on me + ;; that i have changed and that they need to recalculate themselves. + ;; + ;; the standard echo callback is passed the slot-name, instance, new value, + ;; old value and a flag 'old-value-boundp indicating, well, whether the new value + ;; was the first ever for this instance. + ;; + ;; the first set of tests make sure actual change is handled correctly + ;; + (echo-clear 'cylinders) + (echo-clear 'valves) + (echo-clear 'valves-per-cylinder) + (when *stop* (break "stopped!")) + (let ((e (to-be (make-instance 'engine + :cylinders 4 + :valves-per-cylinder (cv 2) + :valves (c? (* (valves-per-cylinder self) (cylinders self))))))) + ;; + ;; these first tests check that cells get echoed appropriately at make-instance time (the change + ;; is from not existing to existing) + ;; + (cv-assert (and (eql 4 (echo-new 'cylinders)) + (not (echo-old-boundp 'cylinders)))) + + (cv-assert (valves-per-cylinder e)) ;; but no echo is defined for this slot + + (cv-assert (valves e)) + ;; + ;; now we test true change from one value to another + ;; + (setf (valves-per-cylinder e) 4) + ;; + (cv-assert (eql 16 (valves e))) + )) + +(defun cv-test-no-prop-unchanged () + ;; + ;; next we check the engines ability to handle dataflow efficiently by /not/ reacting + ;; to coded setfs which in fact produce no change. + ;; + ;; the first takes a variable cylinders cell initiated to 4 and again setf's it to 4. we + ;; confirm that the cell does not echo and that a cell dependent on it does not get + ;; triggered to recalculate. ie, the dependency's value has not changed so the dependent + ;; cell's cached value remains valid. + ;; + (cell-reset) + (echo-clear 'cylinders) + (let* ((*dbg* t) + valves-fired + (e (To-be (make-instance 'engine + :cylinders (cv 4) + :valves-per-cylinder 2 + :valves (c? (setf valves-fired t) + (trc "!!!!!! valves") + (* (valves-per-cylinder self) (cylinders self))))))) + (trc "!!!!!!!!hunbh?") + (cv-assert (echoed 'cylinders)) + (echo-clear 'cylinders) + (cv-assert (not valves-fired)) ;; no echo is defined so evaluation is deferred + (trc "sampling valves....") + (let () + (cv-assert (valves e)) ;; wake up unechoed cell + ) + (cv-assert valves-fired) + (setf valves-fired nil) + + (cv-assert (and 1 (not (echoed 'cylinders)))) + (setf (cylinders e) 4) ;; same value + (trc "same cyl") + (cv-assert (and 2 (not (echoed 'cylinders)))) + (cv-assert (not valves-fired)) + + (setf (cylinders e) 6) + (cv-assert (echoed 'cylinders)) + (cv-assert valves-fired))) + +#+test + (cv-test-engine) Index: cells/cells-test/lazy-propagation.lisp diff -u cells/cells-test/lazy-propagation.lisp:1.1.1.1 cells/cells-test/lazy-propagation.lisp:1.2 --- cells/cells-test/lazy-propagation.lisp:1.1.1.1 Sat Nov 8 18:45:03 2003 +++ cells/cells-test/lazy-propagation.lisp Tue Dec 16 10:03:02 2003 @@ -1,80 +1,80 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -(defvar *area*) -(defvar *density*) - -(defmodel cirkl () - ((radius :initform (cv 10) :initarg :radius :accessor radius) - (area :initform (c?_ (incf *area*) (trc "in area rule it is now" *area*) - (* pi (^radius) (^radius))) :initarg :area :accessor area) - (density :initform (c?_ (incf *density*) - (/ 1000 (^area))) :initarg :density :accessor density))) - - -#+test -(cv-laziness) - -(defun cv-laziness () - (macrolet ((chk (area density) - `(progn - (assert (= ,area *area*) () "area is ~a, should be ~a" *area* ,area) - (assert (= ,density *density*) () "density is ~a, should be ~a" *density* ,density)))) - (let ((*c-debug* t)) - (cell-reset) - - (let* ((*area* 0) - (*density* 0) - (it (md-make 'cirkl))) - (chk 0 0) - - (print `(area is ,(area it))) - (chk 1 0) - - (setf (radius it) 1) - (chk 1 0) - - (print `(area is now ,(area it))) - (chk 2 0) - (assert (= (area it) pi)) - - (setf (radius it) 2) - (print `(density is ,(density it))) - (chk 3 1) - - (setf (radius it) 3) - (chk 3 1) - (print `(area is ,(area it))) - (chk 4 1) - it)))) - -#+test -(cv-laziness) - -(def-c-echo area () - (trc "area is" new-value :was old-value)) - - +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +(defvar *area*) +(defvar *density*) + +(defmodel cirkl () + ((radius :initform (cv 10) :initarg :radius :accessor radius) + (area :initform (c?_ (incf *area*) (trc "in area rule it is now" *area*) + (* pi (^radius) (^radius))) :initarg :area :accessor area) + (density :initform (c?_ (incf *density*) + (/ 1000 (^area))) :initarg :density :accessor density))) + + +#+test +(cv-laziness) + +(defun cv-laziness () + (macrolet ((chk (area density) + `(progn + (assert (= ,area *area*) () "area is ~a, should be ~a" *area* ,area) + (assert (= ,density *density*) () "density is ~a, should be ~a" *density* ,density)))) + (let ((*c-debug* t)) + (cell-reset) + + (let* ((*area* 0) + (*density* 0) + (it (md-make 'cirkl))) + (chk 0 0) + + (print `(area is ,(area it))) + (chk 1 0) + + (setf (radius it) 1) + (chk 1 0) + + (print `(area is now ,(area it))) + (chk 2 0) + (assert (= (area it) pi)) + + (setf (radius it) 2) + (print `(density is ,(density it))) + (chk 3 1) + + (setf (radius it) 3) + (chk 3 1) + (print `(area is ,(area it))) + (chk 4 1) + it)))) + +#+test +(cv-laziness) + +(def-c-echo area () + (trc "area is" new-value :was old-value)) + + Index: cells/cells-test/person.lisp diff -u cells/cells-test/person.lisp:1.1.1.1 cells/cells-test/person.lisp:1.2 --- cells/cells-test/person.lisp:1.1.1.1 Sat Nov 8 18:45:03 2003 +++ cells/cells-test/person.lisp Tue Dec 16 10:03:02 2003 @@ -1,275 +1,275 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -(defvar *name-ct-calc* 0) - -(defmodel person () - ((speech :cell :ephemeral :initform (cv "hello, world") :initarg :speech :accessor speech) - (thought :cell :ephemeral :initform (c? (speech self)) :initarg :thought :accessor thought) - (names :initform nil :initarg :names :accessor names) - (pulse :initform nil :initarg :pulse :accessor pulse) - (name-ct :initarg :name-ct :accessor name-ct - :initform (c? "name-ct" - (incf *name-ct-calc*) - (length (names self)))))) - -(def-c-echo names ((self person) new-names) - (format t "~&you can call me ~a" new-names)) - -(defmethod c-unchanged-test ((self person) (slotname (eql 'names))) - 'equal) - -(defvar *thought* "less") - -(def-c-echo thought ((self person) new-value) - (when new-value - (setq *thought* new-value) - (trc "i am thinking" new-value))) - -(def-c-echo speech ()) - -(defmodel sick () - ((e-value :cell :ephemeral :initarg :e-value :accessor e-value) - (s-value :initarg :s-value :reader s-value))) - -(def-c-echo s-value () - :test) - -(def-c-echo e-value () - :test) - -(defun cv-test-person () - (cv-test-person-1) - (cv-test-person-3) - (cv-test-person-4) - (cv-test-person-5) - (cv-test-talker) - ) - -(defun cv-test-person-1 () - ;; - ;; a recent exchange with someone who has developed with others a visual - ;; programming system was interesting. i mentioned my dataflow thing, he mentioned - ;; they liked the event flow model. i responded that events posed a problem for - ;; cells. consider something like: - ;; - ;; (make-instance 'button - ;; :clicked (cv nil) - ;; :action (c? (when (clicked self) (if (- (time-now *cg-system*) (last-click-time..... - ;; - ;; well, once the button is clicked, that cell has the value t. the rest of the rule executes - ;; and does whatever, the rule completes. finis? no. the time-now cell of - ;; the system instance continues to tick-tick-tick. at each tick the action cell gets triggered, - ;; and (here is the problem) the clicked cell still says t. - ;; - ;; the problem is that clicked is event-ish. the semantics are not "has it ever been clicked", - ;; they are more like "when the /passing/ click occurs...". we could try requiring the programmer - ;; always to execute: - ;; - ;; (setf (clicked it) t) - ;; (setf (clicked it nil) - ;; - ;; ...but in fact cells like this often are ruled cells which watch mouse actions and check if the - ;; mouse up was in the control where the mousedown occurred. so where to put a line of code - ;; to change clicked back to nil? a deep fix seemed appropriate: teach cells about events, so... - ;; - ;; cellular slots can be defined to be :ephemeral if the slot will be used for - ;; event-like data. [defining slots and not cells as ephemeral means one cannot arrange for such a - ;; slot to have a non-ephemeral value for one instance and ephemeral values for other instances. we - ;; easily could go the other way on this, but this seems right.] - ;; - ;; the way ephemerals work is this: when a new value arrives in an ephemeral slot it is echoed and - ;; propagated to dependent cells normally, but then internally the slot value is cleared to nil. - ;; thus during the echo and any dataflow direct or indirect the value is visible to other code, but - ;; no longer than that. note that setting the slot back to nil bypasses propagation: no echo, no - ;; triggering of slot dependents. - ;; - ;; - (let ((p (md-make 'person :speech (cv nil)))) - ;; - ;; - ephemeral c-variable cells revert to nil if setf'ed non-nil later - ;; - (setf (speech p) "thanks for all the fish") - (cv-assert (null (speech p))) - (cv-assert (equal (echo-new 'speech) "thanks for all the fish")) - (cv-assert (equal *thought* "thanks for all the fish")) ;; thought is ephemeral as well, so tricky test - ;; - ;; now check the /ruled/ ephemeral got reset to nil - ;; - (cv-assert (null (thought p))))) - -(defun cv-test-person-3 () - ;; ------------------------------------------------------- - ;; dynamic dependency graph maintenance - ;; - ;; dependencies of a cell are those other cells actually accessed during the latest - ;; invocation of the rule. note that a cellular slot may be constant, not mediated by a - ;; cell, in which case the access does not record a dependency. - ;; - (let ((p (md-make 'person - :names (cv '("speedy" "chill")) - :pulse (cv 60) - :speech "nice and easy does it" - :thought (c? (if (> (pulse self) 180) - (concatenate 'string (car (names self)) ", slow down!") - (speech self)))))) - ;; - ;; with the (variable=1) pulse not > 80, the branch taken leads to (constant=0) speech, so: - ;; - (cv-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) - ;; - ;; with the (variable=1) pulse > 80, the branch taken leads to (variable=1) names, so: - ;; - (setf (pulse p) 200) - (cv-assert (eql 2 (length (cd-useds (md-slot-cell p 'thought))))) - ;; - ;; let's check the engine's ability reliably to frop dependencies by lowering the pulse again - ;; - (setf (pulse p) 50) - (cv-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))))) - -(defun cv-test-person-4 () - (let ((p (md-make 'person - :names '("speedy" "chill") - :pulse (cv 60) - :speech (c? (car (names self))) - :thought (c? (when (< (pulse self) 100) (speech self)))))) - ;; - ;; now let's see if cells are correctly optimized away when: - ;; - ;; - they are defined and - ;; - all cells accessed are constant. - ;; - (cv-assert (null (md-slot-cell p 'speech))) - (cv-assert (md-slot-cell-flushed p 'speech)) - (cv-assert (c-optimized-away-p (md-slot-cell-flushed p 'speech))) - - (cv-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti - (cv-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used - )) - -(defun cv-test-person-5 () - ;; - ;; for now cells do not allow cyclic dependency, where a computation of a cell leads back - ;; to itself. we could do something like have the self-reference return the cached value - ;; or (for the first evaluation) a required seed value. we already have logic which says - ;; that, if setf on a variable cell cycles back to setf on the same cell we simply stop, so - ;; there is no harm on the propagation side. but so far no need for such a thing. - ;; - ;; one interesting experiment would be to change things so propagation looping back on itself - ;; would be allowed. we would likewise change things so propagation was breadth first. then - ;; state change, once set in motion, would continue indefinitely. (propagation would also have to - ;; be non-recursive.) we would want to check for os events after each propagation and where - ;; real-time synchronization was necessary do some extra work. this in contrast to having a timer - ;; or os null events artificially move forward the state of, say, a simulation of a physical system. - ;; allowing propagation to loop back on itslef means the system would simply run, and might make - ;; parallelization feasible since we already have logic to serialize where semantically necessary. - ;; anyway, a prospect for future investigation. - ;; - ;; make sure cyclic dependencies are trapped: - ;; - (cv-assert - (handler-case - (progn - (pulse (md-make 'person - :names (c? (maptimes (n (pulse self)))) - :pulse (c? (length (names self))))) - nil) - (t (error) - (trc "error" error) - t))) - ) -;; -;; we'll toss off a quick class to test tolerance of cyclic - -(defmodel talker8 () - ( - (words8 :initform (cv8 "hello, world") :initarg :words8 :accessor words8) - (idea8 :initform (cv8 "new friend!") :initarg :idea8 :accessor idea8))) - -(defmodel talker () - ((words :initform (cv "hello, world") :initarg :words :accessor words) - (idea :initform (cv "new friend!") :initarg :idea :accessor idea))) - -(def-c-echo words ((self talker) new-words) - (trc "new words" new-words) - (setf (idea self) new-words)) - -(defmethod c-unchanged-test ((self talker) (slotname (eql 'words))) - 'string-equal) - -(def-c-echo idea ((self talker) new-idea) - (trc "new idea" new-idea) - (setf (words self) new-idea)) - -(defmethod c-unchanged-test ((self talker) (slotname (eql 'idea))) - 'string-equal) - -(def-c-echo words8 ((self talker) new-words8) - (trc "new words8" new-words8) - (setf (idea8 self) new-words8)) - -(defmethod c-unchanged-test ((self talker) (slotname (eql 'words8))) - 'string-equal) - -(def-c-echo idea8 ((self talker) new-idea8) - (trc "new idea8" new-idea8) - (setf (words8 self) new-idea8)) - -(defmethod c-unchanged-test ((self talker) (slotname (eql 'idea8))) - 'string-equal) - -(defmacro cv-assert-error (&body body) - `(cv-assert - (handler-case - (prog1 nil - ,@body) - (t (error) - (trc "error" error) - t)))) - -(defun cv-test-talker () - ;; - ;; make sure cyclic setf is trapped - ;; - (cell-reset) - (cv-assert-error - (let ((tk (make-instance 'talker))) - (setf (idea tk) "yes") - (string-equal "yes" (words tk)) - (setf (words tk) "no") - (string-equal "no" (idea tk)))) - ;; - ;; make sure cells declared to be cyclic are allowed - ;; and halt (because after the first cyclic setf the cell in question - ;; is being given the same value it already has, and propagation stops. - ;; - (let ((tk (make-instance 'talker8))) - (setf (idea8 tk) "yes") - (string-equal "yes" (words8 tk)) - (setf (words8 tk) "no") - (string-equal "no" (idea8 tk))) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +(defvar *name-ct-calc* 0) + +(defmodel person () + ((speech :cell :ephemeral :initform (cv "hello, world") :initarg :speech :accessor speech) + (thought :cell :ephemeral :initform (c? (speech self)) :initarg :thought :accessor thought) + (names :initform nil :initarg :names :accessor names) + (pulse :initform nil :initarg :pulse :accessor pulse) + (name-ct :initarg :name-ct :accessor name-ct + :initform (c? "name-ct" + (incf *name-ct-calc*) + (length (names self)))))) + +(def-c-echo names ((self person) new-names) + (format t "~&you can call me ~a" new-names)) + +(defmethod c-unchanged-test ((self person) (slotname (eql 'names))) + 'equal) + +(defvar *thought* "less") + +(def-c-echo thought ((self person) new-value) + (when new-value + (setq *thought* new-value) + (trc "i am thinking" new-value))) + +(def-c-echo speech ()) + +(defmodel sick () + ((e-value :cell :ephemeral :initarg :e-value :accessor e-value) + (s-value :initarg :s-value :reader s-value))) + +(def-c-echo s-value () + :test) + +(def-c-echo e-value () + :test) + +(defun cv-test-person () + (cv-test-person-1) + (cv-test-person-3) + (cv-test-person-4) + (cv-test-person-5) + (cv-test-talker) + ) + +(defun cv-test-person-1 () + ;; + ;; a recent exchange with someone who has developed with others a visual + ;; programming system was interesting. i mentioned my dataflow thing, he mentioned + ;; they liked the event flow model. i responded that events posed a problem for + ;; cells. consider something like: + ;; + ;; (make-instance 'button + ;; :clicked (cv nil) + ;; :action (c? (when (clicked self) (if (- (time-now *cg-system*) (last-click-time..... + ;; + ;; well, once the button is clicked, that cell has the value t. the rest of the rule executes + ;; and does whatever, the rule completes. finis? no. the time-now cell of + ;; the system instance continues to tick-tick-tick. at each tick the action cell gets triggered, + ;; and (here is the problem) the clicked cell still says t. + ;; + ;; the problem is that clicked is event-ish. the semantics are not "has it ever been clicked", + ;; they are more like "when the /passing/ click occurs...". we could try requiring the programmer + ;; always to execute: + ;; + ;; (setf (clicked it) t) + ;; (setf (clicked it nil) + ;; + ;; ...but in fact cells like this often are ruled cells which watch mouse actions and check if the + ;; mouse up was in the control where the mousedown occurred. so where to put a line of code + ;; to change clicked back to nil? a deep fix seemed appropriate: teach cells about events, so... + ;; + ;; cellular slots can be defined to be :ephemeral if the slot will be used for + ;; event-like data. [defining slots and not cells as ephemeral means one cannot arrange for such a + ;; slot to have a non-ephemeral value for one instance and ephemeral values for other instances. we + ;; easily could go the other way on this, but this seems right.] + ;; + ;; the way ephemerals work is this: when a new value arrives in an ephemeral slot it is echoed and + ;; propagated to dependent cells normally, but then internally the slot value is cleared to nil. + ;; thus during the echo and any dataflow direct or indirect the value is visible to other code, but + ;; no longer than that. note that setting the slot back to nil bypasses propagation: no echo, no + ;; triggering of slot dependents. + ;; + ;; + (let ((p (md-make 'person :speech (cv nil)))) + ;; + ;; - ephemeral c-variable cells revert to nil if setf'ed non-nil later + ;; + (setf (speech p) "thanks for all the fish") + (cv-assert (null (speech p))) + (cv-assert (equal (echo-new 'speech) "thanks for all the fish")) + (cv-assert (equal *thought* "thanks for all the fish")) ;; thought is ephemeral as well, so tricky test + ;; + ;; now check the /ruled/ ephemeral got reset to nil + ;; + (cv-assert (null (thought p))))) + +(defun cv-test-person-3 () + ;; ------------------------------------------------------- + ;; dynamic dependency graph maintenance + ;; + ;; dependencies of a cell are those other cells actually accessed during the latest + ;; invocation of the rule. note that a cellular slot may be constant, not mediated by a + ;; cell, in which case the access does not record a dependency. + ;; + (let ((p (md-make 'person + :names (cv '("speedy" "chill")) + :pulse (cv 60) + :speech "nice and easy does it" + :thought (c? (if (> (pulse self) 180) + (concatenate 'string (car (names self)) ", slow down!") + (speech self)))))) + ;; + ;; with the (variable=1) pulse not > 80, the branch taken leads to (constant=0) speech, so: + ;; + (cv-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) + ;; + ;; with the (variable=1) pulse > 80, the branch taken leads to (variable=1) names, so: + ;; + (setf (pulse p) 200) + (cv-assert (eql 2 (length (cd-useds (md-slot-cell p 'thought))))) + ;; + ;; let's check the engine's ability reliably to frop dependencies by lowering the pulse again + ;; + (setf (pulse p) 50) + (cv-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))))) + +(defun cv-test-person-4 () + (let ((p (md-make 'person + :names '("speedy" "chill") + :pulse (cv 60) + :speech (c? (car (names self))) + :thought (c? (when (< (pulse self) 100) (speech self)))))) + ;; + ;; now let's see if cells are correctly optimized away when: + ;; + ;; - they are defined and + ;; - all cells accessed are constant. + ;; + (cv-assert (null (md-slot-cell p 'speech))) + (cv-assert (md-slot-cell-flushed p 'speech)) + (cv-assert (c-optimized-away-p (md-slot-cell-flushed p 'speech))) + + (cv-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti + (cv-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used + )) + +(defun cv-test-person-5 () + ;; + ;; for now cells do not allow cyclic dependency, where a computation of a cell leads back + ;; to itself. we could do something like have the self-reference return the cached value + ;; or (for the first evaluation) a required seed value. we already have logic which says + ;; that, if setf on a variable cell cycles back to setf on the same cell we simply stop, so + ;; there is no harm on the propagation side. but so far no need for such a thing. + ;; + ;; one interesting experiment would be to change things so propagation looping back on itself + ;; would be allowed. we would likewise change things so propagation was breadth first. then + ;; state change, once set in motion, would continue indefinitely. (propagation would also have to + ;; be non-recursive.) we would want to check for os events after each propagation and where + ;; real-time synchronization was necessary do some extra work. this in contrast to having a timer + ;; or os null events artificially move forward the state of, say, a simulation of a physical system. + ;; allowing propagation to loop back on itslef means the system would simply run, and might make + ;; parallelization feasible since we already have logic to serialize where semantically necessary. + ;; anyway, a prospect for future investigation. + ;; + ;; make sure cyclic dependencies are trapped: + ;; + (cv-assert + (handler-case + (progn + (pulse (md-make 'person + :names (c? (maptimes (n (pulse self)))) + :pulse (c? (length (names self))))) + nil) + (t (error) + (trc "error" error) + t))) + ) +;; +;; we'll toss off a quick class to test tolerance of cyclic + +(defmodel talker8 () + ( + (words8 :initform (cv8 "hello, world") :initarg :words8 :accessor words8) + (idea8 :initform (cv8 "new friend!") :initarg :idea8 :accessor idea8))) + +(defmodel talker () + ((words :initform (cv "hello, world") :initarg :words :accessor words) + (idea :initform (cv "new friend!") :initarg :idea :accessor idea))) + +(def-c-echo words ((self talker) new-words) + (trc "new words" new-words) + (setf (idea self) new-words)) + +(defmethod c-unchanged-test ((self talker) (slotname (eql 'words))) + 'string-equal) + +(def-c-echo idea ((self talker) new-idea) + (trc "new idea" new-idea) + (setf (words self) new-idea)) + +(defmethod c-unchanged-test ((self talker) (slotname (eql 'idea))) + 'string-equal) + +(def-c-echo words8 ((self talker) new-words8) + (trc "new words8" new-words8) + (setf (idea8 self) new-words8)) + +(defmethod c-unchanged-test ((self talker) (slotname (eql 'words8))) + 'string-equal) + +(def-c-echo idea8 ((self talker) new-idea8) + (trc "new idea8" new-idea8) + (setf (words8 self) new-idea8)) + +(defmethod c-unchanged-test ((self talker) (slotname (eql 'idea8))) + 'string-equal) + +(defmacro cv-assert-error (&body body) + `(cv-assert + (handler-case + (prog1 nil + ,@body) + (t (error) + (trc "error" error) + t)))) + +(defun cv-test-talker () + ;; + ;; make sure cyclic setf is trapped + ;; + (cell-reset) + (cv-assert-error + (let ((tk (make-instance 'talker))) + (setf (idea tk) "yes") + (string-equal "yes" (words tk)) + (setf (words tk) "no") + (string-equal "no" (idea tk)))) + ;; + ;; make sure cells declared to be cyclic are allowed + ;; and halt (because after the first cyclic setf the cell in question + ;; is being given the same value it already has, and propagation stops. + ;; + (let ((tk (make-instance 'talker8))) + (setf (idea8 tk) "yes") + (string-equal "yes" (words8 tk)) + (setf (words8 tk) "no") + (string-equal "no" (idea8 tk))) ) Index: cells/cells-test/test-cyclicity.lisp diff -u cells/cells-test/test-cyclicity.lisp:1.1.1.1 cells/cells-test/test-cyclicity.lisp:1.2 --- cells/cells-test/test-cyclicity.lisp:1.1.1.1 Sat Nov 8 18:45:17 2003 +++ cells/cells-test/test-cyclicity.lisp Tue Dec 16 10:03:02 2003 @@ -1,94 +1,94 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defmodel ring-node () - ((router-ids :cell nil :initform nil :initarg :router-ids :accessor router-ids) - (system-status :initform (cv 'up) :initarg :system-status :accessor system-status - :documentation "'up, 'down, or 'unknown if unreachable") - (reachable :initarg :reachable :accessor reachable - :initform (c? (not (null ;; convert to boolean for readable test output - (find self (^reachable-nodes .parent)))))))) - -(defun up (self) (eq 'up (^system-status))) - -(defmodel ring-net (family) - ( - (ring :cell nil :initform nil :accessor ring :initarg :ring) - (sys-node :cell nil :initform nil :accessor sys-node :initarg :sys-node) - (reachable-nodes :initarg :reachable-nodes :accessor reachable-nodes - :initform (c? (contiguous-nodes-up - (find (sys-node self) (^kids) - :key 'md-name)))) - ) - (:default-initargs - :kids (c? (assert (sys-node self)) - (assert (find (sys-node self) (ring self))) - (loop with ring = (ring self) - for triples on (cons (last1 ring) - (append ring (list (first ring)))) - when (third triples) - collect (destructuring-bind (ccw node cw &rest others) triples - (declare (ignorable others)) - (print (list ccw node cw)) - (make-instance 'ring-node - :md-name node - :router-ids (list ccw cw))))))) - -(defun contiguous-nodes-up (node &optional (visited-nodes (list))) - (assert (not (find (md-name node) visited-nodes))) - - (if (not (up node)) - (values nil (push (md-name node) visited-nodes)) - (progn - (push (md-name node) visited-nodes) - (values - (list* node - (mapcan (lambda (router-id) - (unless (find router-id visited-nodes) - (multiple-value-bind (ups new-visiteds) - (contiguous-nodes-up (fm! node router-id) visited-nodes) - (setf visited-nodes new-visiteds) - ups))) - (router-ids node))) - visited-nodes)))) - -(defun test-ring-net () - (flet ((dump-net (net msg) - (print '----------------------) - (print `(*** dump-net ,msg ******)) - (dolist (n (kids net)) - (print (list n (system-status n)(reachable n)(router-ids n)))))) - (cell-reset) - (let ((net (md-make 'ring-net - :sys-node 'two - :ring '(one two three four five six)))) - (dump-net net "Initially") - (setf (system-status (fm! net 'three)) 'down) - (dump-net net "Down goes three!!") - (setf (system-status (fm! net 'six)) 'down) - (dump-net net "Down goes six!!!")))) - -#+do-it -(test-ring-net) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defmodel ring-node () + ((router-ids :cell nil :initform nil :initarg :router-ids :accessor router-ids) + (system-status :initform (cv 'up) :initarg :system-status :accessor system-status + :documentation "'up, 'down, or 'unknown if unreachable") + (reachable :initarg :reachable :accessor reachable + :initform (c? (not (null ;; convert to boolean for readable test output + (find self (^reachable-nodes .parent)))))))) + +(defun up (self) (eq 'up (^system-status))) + +(defmodel ring-net (family) + ( + (ring :cell nil :initform nil :accessor ring :initarg :ring) + (sys-node :cell nil :initform nil :accessor sys-node :initarg :sys-node) + (reachable-nodes :initarg :reachable-nodes :accessor reachable-nodes + :initform (c? (contiguous-nodes-up + (find (sys-node self) (^kids) + :key 'md-name)))) + ) + (:default-initargs + :kids (c? (assert (sys-node self)) + (assert (find (sys-node self) (ring self))) + (loop with ring = (ring self) + for triples on (cons (last1 ring) + (append ring (list (first ring)))) + when (third triples) + collect (destructuring-bind (ccw node cw &rest others) triples + (declare (ignorable others)) + (print (list ccw node cw)) + (make-instance 'ring-node + :md-name node + :router-ids (list ccw cw))))))) + +(defun contiguous-nodes-up (node &optional (visited-nodes (list))) + (assert (not (find (md-name node) visited-nodes))) + + (if (not (up node)) + (values nil (push (md-name node) visited-nodes)) + (progn + (push (md-name node) visited-nodes) + (values + (list* node + (mapcan (lambda (router-id) + (unless (find router-id visited-nodes) + (multiple-value-bind (ups new-visiteds) + (contiguous-nodes-up (fm! node router-id) visited-nodes) + (setf visited-nodes new-visiteds) + ups))) + (router-ids node))) + visited-nodes)))) + +(defun test-ring-net () + (flet ((dump-net (net msg) + (print '----------------------) + (print `(*** dump-net ,msg ******)) + (dolist (n (kids net)) + (print (list n (system-status n)(reachable n)(router-ids n)))))) + (cell-reset) + (let ((net (md-make 'ring-net + :sys-node 'two + :ring '(one two three four five six)))) + (dump-net net "Initially") + (setf (system-status (fm! net 'three)) 'down) + (dump-net net "Down goes three!!") + (setf (system-status (fm! net 'six)) 'down) + (dump-net net "Down goes six!!!")))) + +#+do-it +(test-ring-net) Index: cells/cells-test/test-family.lisp diff -u cells/cells-test/test-family.lisp:1.1.1.1 cells/cells-test/test-family.lisp:1.2 --- cells/cells-test/test-family.lisp:1.1.1.1 Sat Nov 8 18:45:17 2003 +++ cells/cells-test/test-family.lisp Tue Dec 16 10:03:02 2003 @@ -1,158 +1,158 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(defmodel human (family) - ((age :initarg :age :accessor age :initform 10))) - -(def-c-echo .kids ((self human)) - (when new-value - (print `(i have ,(length new-value) kids)) - (dolist (k new-value) - (trc "one kid is named" (md-name k) :age (age k))))) - -(def-c-echo age ((k human)) - (format t "~&~a is ~d years old" (md-name k) (age k))) - -(defun cv-test-family () - (cell-reset) - (let ((mom (md-make 'human))) - ; - ; the real power of cells appears when a population of model-objects are linked by cells, as - ; when a real-word collection of things all potentially affect each other. - ; - ; i use the family class to create a simple hierarchy in which kids have a pointer to their - ; parent (.fmparent, accessor fmparent) and a parent has a cellular list of their .kids (accessor kids) - ; - ; great expressive power comes from having kids be cellular; the model population changes as - ; the model changes in other ways. but this creates a delicate timing problem: kids must be fully - ; spliced into the model before their ruled cellular slots can be accessed, because a cell rule - ; itself might try to navigate the model to get to a cell value of some other model-object. - ; - ; the cell engine handles this in two steps. first, deep in the state change handling code - ; the .kids slot gets special handling (this is new for 2002, and come to think of it i will - ; have to expose that hook to client code so others can create models from structures other - ; than family) during which the fmparent gets populated, among other things. second, the echo of - ; kids calls to-be on each kid. - ; - ; one consequence of this is that one not need call to-be on new instances being added to - ; a larger model family, it will be done as a matter of course. - ; - (push (make-instance 'human :md-name 'natalia :age (cv 23)) (kids mom)) - (push (make-instance 'human :md-name 'veronica :age (c? (- (age (fm-other natalia)) 6))) (kids mom)) - (push (make-instance 'human :md-name 'aaron :age (c? (- (age (fm-other veronica)) 4))) (kids mom)) - (push (make-instance 'human :md-name 'melanie :age (c? (- (age (fm-other veronica)) 12))) (kids mom)) - ; - ; some of the above rules invoke the macro fm-other. that searches the model space, first searching the - ; kids of the starting point (which defaults to a captured 'self), then recursively up to the - ; parent and the parent's kids (ie, self's siblings) - ; - (flet ((nat-age (n) - (setf (age (fm-other natalia :starting mom)) n) - (dolist (k (kids mom)) - (cv-assert - (eql (age k) - (ecase (md-name k) - (natalia n) - (veronica (- n 6)) - (aaron (- n 10)) - (melanie (- n 18)))))))) - (nat-age 23) - (nat-age 30) - (pop (kids mom)) - (nat-age 40)))) - -#+test - -(cv-test-family) - -;------------ family-values ------------------------------------------ -;;; -;;; while family-values is itself rather fancy, the only cell concept introduced here -;;; is that cell rules have convenient access to the current value of the slot, via -;;; the symbol-macro ".cache" (leading and trailing full-stops). to see this we need to -;;; go to the definition of family-values and examine the rule for the kids cell: -;;; -;;; (c? (assert (listp (kidvalues self))) -;;; (eko (nil "gridhost kids") -;;; (let ((newkids (mapcan (lambda (kidvalue) -;;; (list (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self)) -;;; (trc nil "family-values forced to make new kid" self .cache kidvalue) -;;; (funcall (kidfactory self) self kidvalue)))) -;;; (^kidvalues)))) -;;; (nconc (mapcan (lambda (oldkid) -;;; (unless (find oldkid newkids) -;;; (when (fv-kid-keep self oldkid) -;;; (list oldkid)))) -;;; .cache) -;;; newkids)))) -;;; -;;; for efficiency's sake, family-values (fvs) generate kids only as needed based on determining -;;; kidvalues cell. wherever possible existing kids are kept. this is done by looking in the current -;;; value of the kids slot for a kid matching each new kidvalue and reusing that. we cannot use the -;;; accessor kids because the first time thru the cell is internally invalid, so the rule will get dispatched -;;; again in an infinite loop if we go through the accessor protocol. -;;; -;;; mind you, we could just use slot-value; .cache is just a convenience. -;;; -(defmodel bottle (model) - ((label :initarg :label :initform "unlabelled" :accessor label))) - -#+test -(cv-family-values) - -(defun cv-family-values () - (let* ((kf-calls 0) - (wall (md-make 'family-values - :kvcollector (lambda (mdv) - (eko ("kidnos")(when (numberp mdv) - (loop for kn from 1 to (floor mdv) - collecting kn)))) - :mdvalue (cv 5) - :kvkey #'mdvalue - :kidfactory (lambda (f kv) - (declare (ignorable f)) - (incf kf-calls) - (trc "making kid" kv) - (make-instance 'bottle - :mdvalue kv - :label (c? (format nil "bottle ~d out of ~d on the wall" - (^mdvalue) - (length (kids f))))))))) - (cv-assert (eql 5 kf-calls)) - - (setq kf-calls 0) - (decf (mdvalue wall)) - (cv-assert (eql 4 (length (kids wall)))) - (cv-assert (zerop kf-calls)) - - (setq kf-calls 0) - (incf (mdvalue wall)) - (cv-assert (eql 5 (length (kids wall)))) - (cv-assert (eql 1 kf-calls)) - - )) - -#+test +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(defmodel human (family) + ((age :initarg :age :accessor age :initform 10))) + +(def-c-echo .kids ((self human)) + (when new-value + (print `(i have ,(length new-value) kids)) + (dolist (k new-value) + (trc "one kid is named" (md-name k) :age (age k))))) + +(def-c-echo age ((k human)) + (format t "~&~a is ~d years old" (md-name k) (age k))) + +(defun cv-test-family () + (cell-reset) + (let ((mom (md-make 'human))) + ; + ; the real power of cells appears when a population of model-objects are linked by cells, as + ; when a real-word collection of things all potentially affect each other. + ; + ; i use the family class to create a simple hierarchy in which kids have a pointer to their + ; parent (.fm-parent, accessor fm-parent) and a parent has a cellular list of their .kids (accessor kids) + ; + ; great expressive power comes from having kids be cellular; the model population changes as + ; the model changes in other ways. but this creates a delicate timing problem: kids must be fully + ; spliced into the model before their ruled cellular slots can be accessed, because a cell rule + ; itself might try to navigate the model to get to a cell value of some other model-object. + ; + ; the cell engine handles this in two steps. first, deep in the state change handling code + ; the .kids slot gets special handling (this is new for 2002, and come to think of it i will + ; have to expose that hook to client code so others can create models from structures other + ; than family) during which the fm-parent gets populated, among other things. second, the echo of + ; kids calls to-be on each kid. + ; + ; one consequence of this is that one not need call to-be on new instances being added to + ; a larger model family, it will be done as a matter of course. + ; + (push (make-instance 'human :md-name 'natalia :age (cv 23)) (kids mom)) + (push (make-instance 'human :md-name 'veronica :age (c? (- (age (fm-other natalia)) 6))) (kids mom)) + (push (make-instance 'human :md-name 'aaron :age (c? (- (age (fm-other veronica)) 4))) (kids mom)) + (push (make-instance 'human :md-name 'melanie :age (c? (- (age (fm-other veronica)) 12))) (kids mom)) + ; + ; some of the above rules invoke the macro fm-other. that searches the model space, first searching the + ; kids of the starting point (which defaults to a captured 'self), then recursively up to the + ; parent and the parent's kids (ie, self's siblings) + ; + (flet ((nat-age (n) + (setf (age (fm-other natalia :starting mom)) n) + (dolist (k (kids mom)) + (cv-assert + (eql (age k) + (ecase (md-name k) + (natalia n) + (veronica (- n 6)) + (aaron (- n 10)) + (melanie (- n 18)))))))) + (nat-age 23) + (nat-age 30) + (pop (kids mom)) + (nat-age 40)))) + +#+test + +(cv-test-family) + +;------------ family-values ------------------------------------------ +;;; +;;; while family-values is itself rather fancy, the only cell concept introduced here +;;; is that cell rules have convenient access to the current value of the slot, via +;;; the symbol-macro ".cache" (leading and trailing full-stops). to see this we need to +;;; go to the definition of family-values and examine the rule for the kids cell: +;;; +;;; (c? (assert (listp (kidvalues self))) +;;; (eko (nil "gridhost kids") +;;; (let ((newkids (mapcan (lambda (kidvalue) +;;; (list (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self)) +;;; (trc nil "family-values forced to make new kid" self .cache kidvalue) +;;; (funcall (kidfactory self) self kidvalue)))) +;;; (^kidvalues)))) +;;; (nconc (mapcan (lambda (oldkid) +;;; (unless (find oldkid newkids) +;;; (when (fv-kid-keep self oldkid) +;;; (list oldkid)))) +;;; .cache) +;;; newkids)))) +;;; +;;; for efficiency's sake, family-values (fvs) generate kids only as needed based on determining +;;; kidvalues cell. wherever possible existing kids are kept. this is done by looking in the current +;;; value of the kids slot for a kid matching each new kidvalue and reusing that. we cannot use the +;;; accessor kids because the first time thru the cell is internally invalid, so the rule will get dispatched +;;; again in an infinite loop if we go through the accessor protocol. +;;; +;;; mind you, we could just use slot-value; .cache is just a convenience. +;;; +(defmodel bottle (model) + ((label :initarg :label :initform "unlabelled" :accessor label))) + +#+test +(cv-family-values) + +(defun cv-family-values () + (let* ((kf-calls 0) + (wall (md-make 'family-values + :kvcollector (lambda (mdv) + (eko ("kidnos")(when (numberp mdv) + (loop for kn from 1 to (floor mdv) + collecting kn)))) + :md-value (cv 5) + :kvkey #'md-value + :kidfactory (lambda (f kv) + (declare (ignorable f)) + (incf kf-calls) + (trc "making kid" kv) + (make-instance 'bottle + :md-value kv + :label (c? (format nil "bottle ~d out of ~d on the wall" + (^md-value) + (length (kids f))))))))) + (cv-assert (eql 5 kf-calls)) + + (setq kf-calls 0) + (decf (md-value wall)) + (cv-assert (eql 4 (length (kids wall)))) + (cv-assert (zerop kf-calls)) + + (setq kf-calls 0) + (incf (md-value wall)) + (cv-assert (eql 5 (length (kids wall)))) + (cv-assert (eql 1 kf-calls)) + + )) + +#+test (cv-family-values) Index: cells/cells-test/test-kid-slotting.lisp diff -u cells/cells-test/test-kid-slotting.lisp:1.1.1.1 cells/cells-test/test-kid-slotting.lisp:1.2 --- cells/cells-test/test-kid-slotting.lisp:1.1.1.1 Sat Nov 8 18:45:24 2003 +++ cells/cells-test/test-kid-slotting.lisp Tue Dec 16 10:03:02 2003 @@ -1,89 +1,89 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - - -(in-package :cells) - -(defmodel image (family) - ((left :initform nil :initarg :left :accessor left) - (top :initform nil :initarg :top :accessor top) - (width :initform nil :initarg :width :accessor width) - (height :initform nil :initarg :height :accessor height) - )) - -(defun right (x) (+ (left x) (width x))) -(defun bottom (x) (+ (top x) (height x))) - -(defmodel stack (image) - ((justify :initform :left :initarg :justify :accessor justify) - (.kid-slots :initform (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (left :ifmissing t) - (c? (+ (left .parent) - (ecase (justify .parent) - (:left 0) - (:center (floor (- (width .parent) (^width)) 2)) - (:right (- (width .parent) (^width))))))) - (mk-kid-slot (top) - (c? (bif (psib (psib)) - (bottom psib) - (top .parent)))))) - :accessor kid-slots - :initarg :kid-slots))) -;; -;; kid-slotting exists largely so graphical containers can be defined which arrange their -;; component parts without those parts' cooperation. so a stack class can be defined as shown -;; and then arbitrary components thrown in as children and they will be, say, right-justified -;; because they will be endowed with rules as necessary to achieve that end by the parent stack. -;; -;; note the ifmissing option, which defaults to nil. the stack's goal is mainly to manage the -;; top attribute of each kid to match any predecessor's bottom attribute. the stack will as a -;; a convenience arrange for horizontal justification, but if some kid chose to define its -;; left attribute that would be honored. -;; -(defun cv-kid-slotting () - (cell-reset) - (let ((stack (md-make 'stack - :left 10 :top 20 - :width 500 :height 1000 - :justify (cv :left) - :kids (eko ("kids") (loop for kn from 1 to 4 - collect (make-instance 'image - :top 0 ;; overridden - :width (* kn 10) - :height (* kn 50)))) - ))) - (cv-assert (eql (length (kids stack)) 4)) - (cv-assert (and (eql 10 (left stack)) - (every (lambda (k) (eql 10 (left k))) - (kids stack)))) - (cv-assert (every (lambda (k) - (eql (top k) (bottom (fm-prior-sib k)))) - (cdr (kids stack)))) - - (setf (justify stack) :right) - (cv-assert (and (eql 510 (right stack)) - (every (lambda (k) (eql 510 (right k))) - (kids stack)))) - )) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + + +(in-package :cells) + +(defmodel image (family) + ((left :initform nil :initarg :left :accessor left) + (top :initform nil :initarg :top :accessor top) + (width :initform nil :initarg :width :accessor width) + (height :initform nil :initarg :height :accessor height) + )) + +(defun right (x) (+ (left x) (width x))) +(defun bottom (x) (+ (top x) (height x))) + +(defmodel stack (image) + ((justify :initform :left :initarg :justify :accessor justify) + (.kid-slots :initform (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (left :ifmissing t) + (c? (+ (left .parent) + (ecase (justify .parent) + (:left 0) + (:center (floor (- (width .parent) (^width)) 2)) + (:right (- (width .parent) (^width))))))) + (mk-kid-slot (top) + (c? (bif (psib (psib)) + (bottom psib) + (top .parent)))))) + :accessor kid-slots + :initarg :kid-slots))) +;; +;; kid-slotting exists largely so graphical containers can be defined which arrange their +;; component parts without those parts' cooperation. so a stack class can be defined as shown +;; and then arbitrary components thrown in as children and they will be, say, right-justified +;; because they will be endowed with rules as necessary to achieve that end by the parent stack. +;; +;; note the ifmissing option, which defaults to nil. the stack's goal is mainly to manage the +;; top attribute of each kid to match any predecessor's bottom attribute. the stack will as a +;; a convenience arrange for horizontal justification, but if some kid chose to define its +;; left attribute that would be honored. +;; +(defun cv-kid-slotting () + (cell-reset) + (let ((stack (md-make 'stack + :left 10 :top 20 + :width 500 :height 1000 + :justify (cv :left) + :kids (eko ("kids") (loop for kn from 1 to 4 + collect (make-instance 'image + :top 0 ;; overridden + :width (* kn 10) + :height (* kn 50)))) + ))) + (cv-assert (eql (length (kids stack)) 4)) + (cv-assert (and (eql 10 (left stack)) + (every (lambda (k) (eql 10 (left k))) + (kids stack)))) + (cv-assert (every (lambda (k) + (eql (top k) (bottom (fm-prior-sib k)))) + (cdr (kids stack)))) + + (setf (justify stack) :right) + (cv-assert (and (eql 510 (right stack)) + (every (lambda (k) (eql 510 (right k))) + (kids stack)))) + )) Index: cells/cells-test/test.lisp diff -u cells/cells-test/test.lisp:1.1.1.1 cells/cells-test/test.lisp:1.2 --- cells/cells-test/test.lisp:1.1.1.1 Sat Nov 8 18:45:24 2003 +++ cells/cells-test/test.lisp Tue Dec 16 10:03:02 2003 @@ -1,92 +1,109 @@ -;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- -;;; -;;; -;;; Copyright © 1995,2003 by Kenneth William Tilton. -;;; -;;; Permission is hereby granted, free of charge, to any person obtaining a copy -;;; of this software and associated documentation files (the "Software"), to deal -;;; in the Software without restriction, including without limitation the rights -;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -;;; copies of the Software, and to permit persons to whom the Software is furnished -;;; to do so, subject to the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be included in -;;; all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -;;; IN THE SOFTWARE. - -(in-package :cells) - -(eval-when (compile :execute load) - (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))) - (defmacro cv-assert (form &optional places (datum "~&~a~&...failed") &rest args) - `(progn - (assert ,form ,places ,datum ,@(or args (list `',form))) - (format t "~&ok: ~a~&" ',form) - ))) - -(defun cv-test () - (let ((*c-debug* t)) - (cell-reset) - (hello-world) ;; non-assertive - (cv-test-engine) - (cv-test-person) -;;; ;; should fail: (df-test nil) - (df-test t) - (cv-test-family) - (cv-family-values) - (cv-kid-slotting) - (boiler-1) - (boiler-2) - (boiler-3) ;; non-assertive - (boiler-4) ;; non-assertive - )) - -(defun dft () - (let ();(*c-debug* t)) - (cell-reset) - (df-test t) - )) - -(defun echo-clear (slot-name) - (setf (getf (symbol-plist slot-name) 'echoed) nil) - (setf (getf (symbol-plist slot-name) 'echo-new-value) :unbound) - (setf (getf (symbol-plist slot-name) 'echo-old-value) :unbound) - (setf (getf (symbol-plist slot-name) 'echo-old-boundp) nil)) - -(defun echoed (slot-name) - (getf (symbol-plist slot-name) 'echoed)) - -(defun echo-new (slot-name) - (bwhen (nv (getf (symbol-plist slot-name) 'echo-new-value)) - (unless (eql nv :unbound) nv))) - -(defun echo-old (slot-name) - (bwhen (nv (getf (symbol-plist slot-name) 'echo-old-value)) - (unless (eql nv :unbound) nv))) - -(defun echo-old-boundp (slot-name) - (getf (symbol-plist slot-name) 'echo-old-boundp)) - -;; --------------------------------------------------------- -;; the redefinition warning on this next method is OK, just don't -;; load this unless running the regression test on cells -;; -(defmethod c-echo-slot-name - #-(or cormanlisp clisp) progn - #+(or cormanlisp clisp) :before - (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp)) - #-runtime-system - (progn - (trc nil "echo registering" slot-name new old old-boundp) - (setf (getf (symbol-plist slot-name) 'echoed) t) - (setf (getf (symbol-plist slot-name) 'echo-new-value) new) - (setf (getf (symbol-plist slot-name) 'echo-old-value) old) +;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- +;;; +;;; +;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a copy +;;; of this software and associated documentation files (the "Software"), to deal +;;; in the Software without restriction, including without limitation the rights +;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;;; copies of the Software, and to permit persons to whom the Software is furnished +;;; to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +;;; IN THE SOFTWARE. + +(in-package :cells) + +(eval-when (compile :execute load) + (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))) + (defmacro cv-assert (form &optional places (datum "~&~a~&...failed") &rest args) + `(progn + (assert ,form ,places ,datum ,@(or args (list `',form))) + (format t "~&ok: ~a~&" ',form)))) + +(defun cv-test () + (let ((*c-debug* t)) + (cell-reset) + (hello-world) ;; non-assertive + (cv-test-engine) + (cv-test-person) +;;; ;; should fail: (df-test nil) + (df-test t) + (cv-test-family) + (cv-family-values) + (cv-kid-slotting) + (boiler-1) + (boiler-2) + (boiler-3) ;; non-assertive + (boiler-4) ;; non-assertive + )) + +#+test +(progn + (let ((*c-debug* t)) + (cell-reset) + ;(hello-world) ;; non-assertive + (cv-test-engine) +;;; (cv-test-person) +;;; ;; should fail: (df-test nil) +;;; (df-test t) +;;; (cv-test-family) +;;; (cv-family-values) +;;; (cv-kid-slotting) +;;; (boiler-1) +;;; (boiler-2) +;;; (boiler-3) ;; non-assertive +;;; (boiler-4) ;; non-assertive + )) + +(defun dft () + (let ();(*c-debug* t)) + (cell-reset) + (df-test t) + )) + +(defun echo-clear (slot-name) + (setf (getf (symbol-plist slot-name) 'echoed) nil) + (setf (getf (symbol-plist slot-name) 'echo-new-value) :unbound) + (setf (getf (symbol-plist slot-name) 'echo-old-value) :unbound) + (setf (getf (symbol-plist slot-name) 'echo-old-boundp) nil)) + +(defun echoed (slot-name) + (getf (symbol-plist slot-name) 'echoed)) + +(defun echo-new (slot-name) + (bwhen (nv (getf (symbol-plist slot-name) 'echo-new-value)) + (unless (eql nv :unbound) nv))) + +(defun echo-old (slot-name) + (bwhen (nv (getf (symbol-plist slot-name) 'echo-old-value)) + (unless (eql nv :unbound) nv))) + +(defun echo-old-boundp (slot-name) + (getf (symbol-plist slot-name) 'echo-old-boundp)) + +;; --------------------------------------------------------- +;; the redefinition warning on this next method is OK, just don't +;; load this unless running the regression test on cells +;; +(defmethod c-echo-slot-name + #-(or cormanlisp clisp) progn + #+(or cormanlisp clisp) :before + (slot-name self new old old-boundp) + (declare (ignorable slot-name self new old old-boundp)) + #-runtime-system + (progn + (trc nil "echo registering" slot-name new old old-boundp) + (setf (getf (symbol-plist slot-name) 'echoed) t) + (setf (getf (symbol-plist slot-name) 'echo-new-value) new) + (setf (getf (symbol-plist slot-name) 'echo-old-value) old) (setf (getf (symbol-plist slot-name) 'echo-old-boundp) old-boundp)))