[cells-cvs] CVS update: cells/cells-test/boiler-examples.lisp cells/cells-test/cells-test.asd cells/cells-test/df-interference.lisp cells/cells-test/hello-world-q.lisp cells/cells-test/hello-world.lisp cells/cells-test/internal-combustion.lisp cells/cells-test/lazy-propagation.lisp cells/cells-test/person.lisp cells/cells-test/test-cyclicity.lisp cells/cells-test/test-family.lisp cells/cells-test/test-kid-slotting.lisp cells/cells-test/test.lisp cells/cells-test/qrock.lisp cells/cells-test/ring-net-clocked.lisp cells/cells-test/ring-net.lisp
Kenny Tilton
ktilton at common-lisp.net
Tue Dec 16 15:03:04 UTC 2003
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 at nyc.rr.com>"
- :version "05-Nov-2003"
- :maintainer "Kenny Tilton <ktilton at 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 at nyc.rr.com>"
+ :version "05-Nov-2003"
+ :maintainer "Kenny Tilton <ktilton at 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
- , at 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
+ , at 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)))
More information about the Cells-cvs
mailing list